pax_global_header00006660000000000000000000000064147531447040014523gustar00rootroot0000000000000052 comment=1ca343e16a2038e406d1ac674e7e3a1b722b36c7 herd-herdtools7-1ca343e/000077500000000000000000000000001475314470400151425ustar00rootroot00000000000000herd-herdtools7-1ca343e/.github/000077500000000000000000000000001475314470400165025ustar00rootroot00000000000000herd-herdtools7-1ca343e/.github/workflows/000077500000000000000000000000001475314470400205375ustar00rootroot00000000000000herd-herdtools7-1ca343e/.github/workflows/build-asl-reference.yml000066400000000000000000000022671475314470400251010ustar00rootroot00000000000000name: Build ASL reference on: workflow_dispatch: schedule: # Prime the caches every Monday - cron: 0 1 * * MON pull_request: paths: - 'internal/bento.mll' - 'asllib/doc/**' - '.github/workflows/**' permissions: read-all # Copy-pasted from https://stackoverflow.com/questions/66335225/how-to-cancel-previous-runs-in-the-pr-when-you-push-new-commitsupdate-the-curre concurrency: group: ${{ github.workflow }}-${{ github.event.pull_request.number || github.ref }} cancel-in-progress: true jobs: make-asldoc: runs-on: ubuntu-latest steps: - name: Checkout tree uses: actions/checkout@v4 - name: Update apt database run: sudo apt-get update --quiet --yes - name: Install opam and texlive run: sudo apt-get install --quiet --yes opam texlive-full - name: Make sure opam is well installed run: opam init - name: Install opam dependencies run: opam install . --deps-only --yes - name: Build ASL Reference run: opam exec -- make asldoc - uses: actions/upload-artifact@v4 with: name: ASL Reference Document path: asllib/doc/ASLReference.pdf herd-herdtools7-1ca343e/.github/workflows/build-www.yml000066400000000000000000000011701475314470400232020ustar00rootroot00000000000000name: Build WWW on: workflow_dispatch jobs: build: runs-on: ubuntu-latest steps: - name: Checkout tree uses: actions/checkout@v4 - name: Set-up OCaml 5 uses: ocaml/setup-ocaml@v3 with: ocaml-compiler: 5 - run: | opam install dune menhir zarith js_of_ocaml js_of_ocaml-ppx zarith_stubs_js opam exec -- make Version.ml opam exec -- dune build tools/cat2html.exe opam exec -- make -C herd-www - name: www uses: actions/upload-artifact@v4 with: name: www path: | herd-www/www herd-herdtools7-1ca343e/.github/workflows/check-build-www.yml000066400000000000000000000011501475314470400242530ustar00rootroot00000000000000name: Check Build WWW on: schedule: - cron: '0 8 * * 0' jobs: build: strategy: fail-fast: false matrix: ocaml-compiler: - "5.1" runs-on: ubuntu-latest steps: - name: Checkout tree uses: actions/checkout@v4 - name: Set-up OCaml 5 uses: ocaml/setup-ocaml@v3 with: ocaml-compiler: 5 - run: | opam install dune menhir zarith js_of_ocaml js_of_ocaml-ppx zarith_stubs_js opam exec -- make Version.ml opam exec -- dune build tools/cat2html.exe opam exec -- make -C herd-www herd-herdtools7-1ca343e/.github/workflows/make-test.yml000066400000000000000000000027421475314470400231610ustar00rootroot00000000000000name: build & make test on: pull_request: # push: workflow_dispatch: schedule: # Prime the caches every Monday - cron: 0 1 * * MON permissions: read-all # Copy-pasted from https://stackoverflow.com/questions/66335225/how-to-cancel-previous-runs-in-the-pr-when-you-push-new-commitsupdate-the-curre concurrency: group: ${{ github.workflow }}-${{ github.event.pull_request.number || github.ref }} cancel-in-progress: true jobs: build: strategy: fail-fast: false matrix: os: - ubuntu-latest cfg: - ocaml-version: "4.08.1" with-fmt: false job-name: "OCaml v4.08" - ocaml-version: "5.2" with-fmt: true job-name: "OCaml v5.2, with formatting check" name: Make test on ${{ matrix.cfg.job-name }} runs-on: ${{ matrix.os }} env: DUNE_CACHE: 'enabled-except-user-rules' steps: - name: Checkout tree uses: actions/checkout@v4 - name: Set-up OCaml ${{ matrix.cfg.ocaml-version }} uses: ocaml/setup-ocaml@v3 with: ocaml-compiler: ${{ matrix.cfg.ocaml-version }} dune-cache: true - run: opam install . --deps-only --with-test - run: opam exec -- make build DUNE_PROFILE=dev - run: opam exec -- make test DUNE_PROFILE=dev - run: opam install ocamlformat.0.26.2 if: ${{ matrix.cfg.with-fmt }} - run: opam exec -- dune fmt if: ${{ matrix.cfg.with-fmt }} herd-herdtools7-1ca343e/.github/workflows/run-litmus.yml000066400000000000000000000016201475314470400234000ustar00rootroot00000000000000name: Run Litmus on: schedule: - cron: '0 10 * * 0' workflow_dispatch: jobs: build: strategy: fail-fast: false matrix: arch: - os: ubuntu-latest make-test-target: litmus-x86_64-test X86_64_PREFIX='' - os: ubuntu-24.04-arm make-test-target: litmus-aarch64-test ocaml-compiler: - "5.2" runs-on: ${{ matrix.arch.os }} steps: - name: Checkout tree uses: actions/checkout@v4 - name: Set-up OCaml ${{ matrix.ocaml-compiler }} uses: ocaml/setup-ocaml@v3 with: ocaml-compiler: ${{ matrix.ocaml-compiler }} - run: | opam install dune menhir zarith opam exec -- make Version.ml opam exec -- dune build litmus/litmus.exe opam exec -- make ${{ matrix.arch.make-test-target }} LITMUS=$(pwd)/_build/default/litmus/litmus.exe herd-herdtools7-1ca343e/.ocamlformat000066400000000000000000000000401475314470400174410ustar00rootroot00000000000000version = 0.26.2 disable = true herd-herdtools7-1ca343e/.pre-commit-config.yaml000066400000000000000000000036771475314470400214400ustar00rootroot00000000000000# See https://pre-commit.com for more information # See https://pre-commit.com/hooks.html for more hooks repos: - repo: https://github.com/pre-commit/pre-commit-hooks rev: v2.4.0 hooks: - id: check-case-conflict - id: check-executables-have-shebangs - id: check-yaml - id: mixed-line-ending - id: end-of-file-fixer # `(?x)` enables multi-line regexps: https://docs.python.org/3/library/re.html#re.X. exclude: | (?x)( # Vendored files for the Herd web interface. ^herd-www/www/( ace/| BS/| FileSaver.min.js| fonts/| viz.js| whhg-font/ )| # Expected files should be left verbatim. \.expected(-failure)?$ ) - id: trailing-whitespace # `(?x)` enables multi-line regexps: https://docs.python.org/3/library/re.html#re.X. exclude: | (?x)( # Vendored files for the Herd web interface. ^herd-www/www/( ace/| BS/| FileSaver.min.js| fonts/| viz.js| whhg-font/ )| # Expected files should be left verbatim. \.expected(-failure)?$ ) - repo: https://github.com/arenadotio/pre-commit-ocamlformat rev: 0439858f79b3bcb49e757278eb1312e212d7dd4f hooks: - id: ocamlformat types: [ocaml] - repo: local hooks: - id: make-test name: Run make test language: system entry: make test files: (dune|\.ml.*$|\.litmus.*$) pass_filenames: false - id: opam-lint name: opam lint language: system entry: opam lint files: (\.opam$) - id: lint-shelves name: Lint Catalogue shelves language: system entry: internal/run_built_binary lint_shelves files: shelf.py$ herd-herdtools7-1ca343e/CHANGES.txt000066400000000000000000000257651475314470400167720ustar00rootroot000000000000007.56 * Experimental -variant 'deps': computes dependencies in cat. 7.55 * X86_64 support (Credit Antoine Hacquard) * Numerous AArch86 extensions, including regisions and scope definitions. * RISCV amo support. 7.47+3 * Correct double labelling of rf edges: -doshow rf is now a no-operation * RISCV support for herd 7.47+2 * RISCV support for litmus and generators. 7.47+1 * Some cleanup in options while documenting klitmus. 7.47 * Add many Linux C atomic primitives. 7.46+3 * lock primitive actions take part to dependencies. * herd/linux: serious semantical work on compare exchange and add_unless * herd/linux: failed fenced atomics do not generate fence events. * herd: uniform handling of indivudual events and relational pairs. * litmus: accept void * in argument types. * tools: Introduce mlisa2c, a tool to produce C11/Linux versions from Linux LISA 7.46+2 * New linux locks, simulate load-acquire write release behaviour more closely. 7.46 * C better lock integration. NB: POSIX locks used by litmus. * herd: correct PR #3 [semantics of C11 CAS] * linux: complete (?) implementation of atomic.h * tools, add -int32 command-line option. * gen Arch64, for -ua 0, now emit a LDXR/STXR pair and observe result register of STXR. * herd, global behaviour for 'show' instruction (no purge of state show component at procedure return) * Add AArch64 instruction csel 7.45 * New ARMv8 model * klitmus tool 7.44 * herd: add atomic_compare_exchange_..._explicit in C parser. * Suppress " in mcond output. 7.43+3 * gen/litmus/herd: add ARMv8 LDAPR instruction (contribution by Will Deacon) * herd: cos-opt.cat, bug ! --> Do not redefine RMW * herd: PPC, avoid data or address dependencies from lwarx to matchin stwcx. 7.43+2 * Correct C semantics bug if (e) was understood as direct boolean 0/1 test. Now understood as if (e != 0), as it should. 7.43+1 * New tool mlock 7.43 * opam release 7.42+1 * Add -cycles names option, to display cycles of failing checks. * Add support for C11 atomic_compare_exchange_... primitives. 7.42 * Fix license, add README, publish as an OPAM package * gen: avoid pseudo-instruction li in generated tests. * tools: option -alloc for mprog [allocate symbolic registers]. * herd: the match constructs also applies to relation. * Correct libdir definition for gen: same as herd, as it may parse bell files and would thus include stdlib.cat 7.41 * More opam 7.40 * Opam build 7.39 * herd: enable matching over event sets. * tools: add msethashes, for changing *test* hashes. 7.38 * gen: list all global variables in init when type is non-default * new mselect: specify intervals for number of ins and number of threads. * Data dependencies are through registers only. 7.37 * Add array access as a location, meaningfull only for litmus at present 7.36 * herd: support for linux spin_lock and spin_unlock. 7.35 * herd: Correct LISA rmw "exchange" -> same semantics as X86 xch 7.34 * suppress some 32 bits constants -> 31 bits * gen : follow -realdep true option for AArch64 and ARM 7.33 * herd: reformulate C load and store to use expressions as locations. Brittle (cf. jingle) 7.32 * Specific internal dependencies for C exchange and LISA Rmw... * X86, correct data ports for the exchange instruction. 7.31 * Backward compatibility 7.30 * herd: bug LISA, parsing, add one-letter instruction as possible annotations. 7.29 * herd: bug stdlib.cat (old fromto). 7.28 * herd: correcy fromto ? At least compatible with article. 7.27 * linux: lock -> rcu_read_lock; unlock -> rcu_read_unlock 7.26 * AArch64, add logical and instruction. * Generators, implement -obs three,four,infinity 7.25 * litmus bug, strh instruction were parsed as strb (copy-paste bug) * Linux atomic operations, xchg only. 7.24 * Add AArch64 instruction STP/STNP (litmus only) * Correct msum7 -hexa ---> Conditions are also in hexa. * Add AArch64 instruction LDNP (litmus only). 7.23 * Add AArch64 instruction LDP (litmus only). * Set X is also RMW (Lisa) 7.22 * litmus option -exit true --> exit status reflects final condition success or failure. * qemu mode for litmus * add -force option to mrcu forces translation in all conditions. * handle the CALL[sync] -> f[sync] change un mrcu 7.21 * LISA: CALL instructuction reversed to F instruction. Compatibility mode present. 7.20 * C arch, correct stupid bug in control dependencies (forgot if without else....) 7.19 * herd/cat : empty check also operates on sets. * Litmus: noalign meta information 7.18 * Add a set of data ports to event structures, in order to separate data and address dependencies. Brittle on RMW. * Add intruction level control dependency (for C). * Suppress deprecaton warnings, by writing code in misc... 7.17 * More Linux macros * Locked instructions for X86, simplify setting: 1. suppress atomicity component of event structures + set atomicity at event creation time. 7.16 * Oups trivial bug in filters.cat 7.15 * Add M. Batty et all's models and take the most advanced (with partial orders) one as the C default. * Add macros to C arch and bell support * Correct x86tso bug + use A in filters as atomic. 7.14 * mrcu (check that call[sync] L...U ran at most once (replace condition on shared location by specific register, because of "last write" problem) 7.13 * mrcu (check that call[sync] L...U ran at most once. 7.12 * tools added mrcu (for rcu translation) => add "filter" component to tests. 7.11 * tools: correct mcmp (normalize_simple in logState), so as to accept flowing model output. * tools: add mshowhashes to list test hashes + share code with mdiag 7.10 * Correct bug in computing ne (not equal): was 1 (true) for two different "S" vars... 7.09 * Internal change of mdiag: diagnostics are more precise. * All lexers, ignore '\r'. * CAT: make the initial "identity" string optional. 7.08 * C11: add NA for non-atomics events (needed by popl15c11 models from the catalogue) * LISA: change rmw sematics as fetch_and_op , was op_and_fetch 7.07 * herd: set 'Atom' -> set 'X' (compatibility) 7.06 * herd: Add set 'Atom' for LISA atimic events. * Dependencies for C, always "real". * generators: -realdep option * LISA, non-conditional branch. 7.05 * litmus -noalign option 7.04 7.03 7.02 * LISA :backward compatibility: f[sync] -> call[sync] * LISA : introduce call instructions. * herd : make exchange an expression (was an instruction !) * herd : use short memory model names in pictures * lib : C make exchange and fetch expressions, as they should be. * tools : handle C arch completely 7.01 * herd: Add minimal atomicity to LL/SS (PPC and ARM). * herd: Recursive procedure + match instruction. 7.00 Release 'Seven' * herd: refactored release. * litmus: -driver optiopn to generate standalone C programs or Objective C * litmus: More configuration files (nexus10..) * litmus: Refactoring: avoid mutable internal flags. 5.01 Release * litmus: litmus option -crossrun adb -> run.sh connects to device using adb (Android Debugging Bridge) 5.00 Release * gen: Added classify tool * gen: Uniform naming scheme, clarify usage and document * gen: Refactor diyone second mode, in the same style as diy/diycross * gen: Support for atomic accesses (undocumented) * litmus: added the mcycles tool * litmus: iPad and asus TF300T configuration files. * litmus: New user synchronisation mode userfence (suggested by Javi Merino) * litmus: More POSIX compliant code in two occasions (malloc/errno and use thread level affinity functions, suggested by Javi Merino) * litmus: Runtime option +fix, to cancel out changing launch mode * litmus: Make timebase delay settable (option -delay) * litmus: Timebase synchronisation mode (-barrier timebase). * litmus: option -crossrun -> run.sh run executables on distant machine . * litmus: add -stride mode (memory scanned by increments > 1), useful ? Very useful. * litmus: -linkopt option * litmus: -kind false option, to suppress kind and validation information from output * litmus: -gcc option * litmus: ARM and cortex9 (cross-compilation) configuration files 4.00 Release * gen: ARM support. * gen: Generalize -o option, as for litmus. * gen: option -var for diycross for nice variables., * gen: new tool diycross, similar to diyvar, but let user specify the list of alternatives eg: diycross -name SB PodWR,SyncdWR Fre PodWR,SyncdWR Fre For 3 MP-like tests (MP, MP+sync+po, MP+syncs) diyvar behavior is still here with the pseudo-relaxation all(R|W)(R|W) eg: diycross -name SB allWR Fre allWR Fre * gen: Add a new functionality for diyone: generate tests from a list of cycles given in stdin. * Mode precise edge dependencies, DpdR, DpdW, CltrdR, CtrldW are still recognised by parser and are default values (backward compatibility). However, Dpd* and Ctrld* are not available anymore. * gen: dont: uncompress archive with gunzip (AIX: tar z.. not accepted) * gen: diy: -cumul false also acts on RfStar * gen: dont: Corrected bug in default safe_conform list for PPC. * gen: dont: Use compressed archive * litmus: new -o support -> dir/tar/tgz * litmus: ARM support, tested on uniproc only * litmus: -loop option, for time measurement * litmus: power7.32 config file, [used for shipped testcases] * litmus: power7 config file * litmus: If affinity is enabled, avail=0 instructs binaries to detects available logical processors. * litmus: add optional shuffle in indirect mode (similar to direct mode) * litmus: add random affinity mode (-ra true/+ra) * litmus: added chianti config file * litmus: added vargas16 config file * litmus: -o name.tgz produce compressed archives 3.00 Release * litmus: There is now a Makefile in archives produced with -o .tar. Best way to provide parallel compilation (make -j N). * litmus: added -index <@name>, for dumping an index of compiled tests. * litmus: added the -no option (used by dont). 2.99 Release (beta) * gen: Introduce dont, for automating testing. * gen: Additional mode for diy: critical, for generating critical cycles (no Po/Po consing) * gen: Additional option for diy: -cumul, for avoiding ambiguous tests. 2.00 Release * gen: -mix option (default false, for backward compatibility) * gen: Clarification of observers and documentation [three modes accept/avoid/force, three sorts straight/fenced/loop] Defaults avoid/fenced. * gen: Added PPO pseudo-relaxation, very ad-hoc. * gen: Added RfStar edge (ie Rf to a read by lwarx) * gen: various -fno mode * gen: -sta mode * gen: PPO macro * gen: Arch independant readRelax * litmus: Added affinity control * litmus: Added prealloc mode. * litmus: -o a.tar and -cross a.tar behave slightly differently. (-cross is for released tests, with Makefile & README * litmus: Added call mode. * litmus: Added cache mode. 1.0 Initial release. herd-herdtools7-1ca343e/INSTALL.md000066400000000000000000000023051475314470400165720ustar00rootroot00000000000000Binary installation with OPAM ======================= [Install OPAM](https://opam.ocaml.org/doc/Install.html), then: % opam install herdtools7 Then, to get the newest version: % opam update % opam upgrade Source build ============ Tools will be installed in PREFIX/bin, and various files in PREFIX/share/herdtools7. By default (see Makefile) PREFIX is $HOME. You can change PREFIX by editing the Makefile, or by running ``make ...`` as ``make PREFIX=yourprefix ...``. Requirements ------------ - OCaml (version >= 4.08.0) - dune - menhir (version >= 20180530) - zarith We strongly recommend to have this base software installed through the opam package manager. % opam install dune menhir zarith Make sure to run `eval $(opam config env)` to make tools available in your PATH. Notice: Compilation with ocamlbuild is not longer possible Build ----- % make all Testing ------- The optionnal dependency `qcheck` can be installed with `opam` as follows: % opam install qcheck Whether or not optional dependencies are installed, the following command runs the tests, skipping the ones that necessitate non-available dependencies. % make test Install ------- % make install herd-herdtools7-1ca343e/LICENSE.txt000066400000000000000000000536701475314470400170000ustar00rootroot00000000000000NOTE This license applies to all files in the distribution, except as stated below: * Files in directory asllib/ are copyright Arm Ltd and are distributed under the terms of the BSD-3-Clause license. * Some OCaml source files have a joint copyright attribution with Arm Ltd, as specified in the files themselves. Those files are under Cecill-B, like the rest of herdtools7. * The files in the following sub-directories of catalogue are under Cecill-B, like the rest of herdtools7 but have copyright attribution with Arm Ltd: aarch64-ETS2/ aarch64-MTE/ aarch64-MTE-mixed/ aarch64-MTE-pick/ aarch64-VMSA/ aarch64-down-one-leg/ aarch64-faults/ aarch64-ifetch/ aarch64-pick/ * The following files are copyright Arm Ltd: herd/libdir/aarch64hwreqs.cat herd/libdir/aarch64.cat herd/libdir/aarch32.cat herd/libdir/enumerations.cat herd/libdir/aarch64memattrs.cat herd/libdir/aarch64bbm.cat herd/libdir/aarch64deps.cat herd/libdir/aarch64util.cat ---------------------------------------- CeCILL-B 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-B (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 This Agreement is an open source software license intended to give users significant freedom to modify and redistribute the software licensed hereunder. The exercising of this freedom is conditional upon a strong obligation of giving credits for everybody that distributes a software incorporating a software ruled by the current license so as all contributions to be properly identified and acknowledged. 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 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 Contribution. Licensor: means the Holder, or any other individual or legal entity, who distributes the Software under the Agreement. Contribution: means any or all modifications, corrections, translations, adaptations and/or new functions integrated into the Software by any or all Contributors, as well as any or all Internal Modules. Module: means a set of sources files including their documentation that enables supplementary functions or services in addition to those offered by the Software. External Module: means any or all Modules, not derived from the Software, so that this Module and the Software run in separate address spaces, with one calling the other when they are run. Internal Module: means any or all Module, connected to the Software so that they both execute in the same address space. 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 ENTITLEMENT TO MAKE CONTRIBUTIONS The right to make Contributions includes the right to translate, adapt, arrange, or make any or all modifications to the Software, and the right to reproduce the resulting software. The Licensee is authorized to make any or all Contributions to the Software provided that it includes an explicit notice that it is the author of said Contribution 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 If the Licensee makes any Contribution to the Software, the resulting Modified Software may be distributed under a license agreement other than this Agreement subject to compliance with the provisions of Article 5.3.4. 5.3.3 DISTRIBUTION OF EXTERNAL MODULES When the Licensee has developed an External Module, the terms and conditions of this Agreement do not apply to said External Module, that may be distributed under a separate license agreement. 5.3.4 CREDITS Any Licensee who may distribute a Modified Software hereby expressly agrees to: 1. indicate in the related documentation that it is based on the Software licensed hereunder, and reproduce the intellectual property notice for the Software, 2. ensure that written indications of the Software intended use, intellectual property notice and license hereunder are included in easily accessible format from the Modified Software interface, 3. mention, on a freely accessible website describing the Modified Software, at least throughout the distribution term thereof, that it is based on the Software licensed hereunder, and reproduce the Software intellectual property notice, 4. where it is distributed to a third party that may distribute a Modified Software without having to make its source code available, make its best efforts to ensure that said third party agrees to comply with the obligations set forth in this Article . If the Software, whether or not modified, is distributed with an External Module designed for use in connection with the Software, the Licensee shall submit said External Module to the foregoing obligations. 5.3.5 COMPATIBILITY WITH THE CeCILL AND CeCILL-C LICENSES Where a Modified Software contains a Contribution subject to the CeCILL license, the provisions set forth in Article 5.3.4 shall be optional. A Modified Software may be distributed under the CeCILL-C license. In such a case the provisions set forth in Article 5.3.4 shall be 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 CONTRIBUTIONS The Licensee who develops a Contribution is the owner of the intellectual property rights over this Contribution as defined by applicable law. 6.3 OVER THE EXTERNAL MODULES The Licensee who develops an External Module is the owner of the intellectual property rights over this External Module as defined by applicable law and is free to choose the type of agreement that shall govern its distribution. 6.4 JOINT PROVISIONS 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. 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. herd-herdtools7-1ca343e/Makefile000066400000000000000000000442711475314470400166120ustar00rootroot00000000000000.PHONY: check-deps OS := $(shell uname) PREFIX=$$HOME D=dune #Limit parallelism of some expensive operations ifeq ($(OS),Darwin) J=$(shell sysctl -n hw.logicalcpu) else J=$(shell nproc) endif REGRESSION_TEST_MODE = test # REGRESSION_TEST_MODE = promote # REGRESSION_TEST_MODE = show DUNE_PROFILE = release DIYCROSS = _build/install/default/bin/diycross7 HERD = _build/install/default/bin/herd7 LITMUS = _build/install/default/bin/litmus7 LITMUS_LIB_DIR = $(PWD)/litmus/libdir HERD_REGRESSION_TEST = _build/default/internal/herd_regression_test.exe HERD_DIYCROSS_REGRESSION_TEST = _build/default/internal/herd_diycross_regression_test.exe HERD_CATALOGUE_REGRESSION_TEST = _build/default/internal/herd_catalogue_regression_test.exe BENTO = _build/default/tools/bento.exe all: build .PHONY: Version.ml Version.ml: sh ./version-gen.sh $(PREFIX) just-build: Version.ml dune build -j $(J) --profile $(DUNE_PROFILE) build: check-deps | just-build $(BENTO): Version.ml | check-deps dune build -j $(J) --profile $(DUNE_PROFILE) $@ install: sh ./dune-install.sh $(PREFIX) uninstall: sh ./dune-uninstall.sh $(PREFIX) clean: dune-clean clean-asl-pseudocode clean-asldoc rm -f Version.ml dune-clean: dune clean versions: Version.ml @ dune build -j $(J) --workspace dune-workspace.versions # Dependencies. check-deps:: $(if $(shell which ocaml),,$(error "Could not find ocaml in PATH")) $(if $(shell which menhir),,$(error "Could not find menhir in PATH; it can be installed with `opam install menhir`.")) check-deps:: $(if $(shell which dune),,$(error "Could not find dune in PATH; it can be installed with `opam install dune`.")) # Tests. TIMEOUT=16.0 test-all:: test test:: | build test:: dune-test @ echo "OCaml unit tests: OK" dune-test: @ echo dune runtest --profile=$(DUNE_PROFILE) .PHONY: dune-no-missing-file-in-runt test:: dune-no-missing-file-in-runt dune-no-missing-file-in-runt: asllib/tests/check-no-missing-file-in-run.sh ./ test:: test.aarch64 test-local:: test.aarch64 test.aarch64: @ echo $(HERD_REGRESSION_TEST) \ -j $(J) \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -litmus-dir ./herd/tests/instructions/AArch64 \ $(REGRESSION_TEST_MODE) @ echo "herd7 AArch64 instructions tests: OK" test:: test.riscv test-local:: test.riscv test.riscv: @ echo $(HERD_REGRESSION_TEST) \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -litmus-dir ./herd/tests/instructions/RISCV \ $(REGRESSION_TEST_MODE) @ echo "herd7 RISCV instructions tests: OK" test:: test.x86_64 test-local:: test.x86_64 test.x86_64: @ echo $(HERD_REGRESSION_TEST) \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -litmus-dir ./herd/tests/instructions/X86_64 \ $(REGRESSION_TEST_MODE) @ echo "herd7 X86_64 instructions tests: OK" test:: test.mixed test-local:: test.mixed test.mixed: @ echo $(HERD_REGRESSION_TEST) \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -litmus-dir ./herd/tests/instructions/AArch64.mixed \ -conf ./herd/tests/instructions/AArch64.mixed/mixed.cfg \ $(REGRESSION_TEST_MODE) @ echo "herd7 AArch64 mixed instructions tests: OK" test:: test.mips test-local:: test.mips test.mips: @ echo $(HERD_REGRESSION_TEST) \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -litmus-dir ./herd/tests/instructions/MIPS \ $(REGRESSION_TEST_MODE) @ echo "herd7 RISCV instructions tests: OK" test:: test.neon test-local:: test.neon test.neon:: @ echo $(HERD_REGRESSION_TEST) \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -litmus-dir ./herd/tests/instructions/AArch64.neon \ -variant neon \ $(REGRESSION_TEST_MODE) @ echo "herd7 AArch64 NEON instructions tests: OK" test:: test.sve test-local:: test.sve test.sve:: @ echo $(HERD_REGRESSION_TEST) \ -j $(J) \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -litmus-dir ./herd/tests/instructions/AArch64.sve \ -variant sve \ $(REGRESSION_TEST_MODE) @ echo "herd7 AArch64 SVE instructions tests: OK" test:: test.sme test-local:: test.sme test.sme:: @ echo $(HERD_REGRESSION_TEST) \ -j $(J) \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -litmus-dir ./herd/tests/instructions/AArch64.sme \ -variant sme \ $(REGRESSION_TEST_MODE) @ echo "herd7 AArch64 SME instructions tests: OK" test:: test.mte test-local:: test.mte test.mte:: @ echo $(HERD_REGRESSION_TEST) \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -litmus-dir ./herd/tests/instructions/AArch64.MTE \ -conf ./herd/tests/instructions/AArch64.MTE/mte.cfg \ $(REGRESSION_TEST_MODE) @ echo "herd7 AArch64 MTE instructions tests: OK" test:: test.self test-local:: test.self test.self: @ echo $(HERD_REGRESSION_TEST) \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -litmus-dir ./herd/tests/instructions/AArch64.self \ -conf ./herd/tests/instructions/AArch64.self/self.cfg \ $(REGRESSION_TEST_MODE) @ echo "herd7 AArch64 variant -self instructions tests: OK" test:: test.kvm test-local:: test.kvm test.kvm: @ echo $(HERD_REGRESSION_TEST) \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -litmus-dir ./herd/tests/instructions/AArch64.kvm \ -conf ./herd/tests/instructions/AArch64.kvm/kvm.cfg \ $(REGRESSION_TEST_MODE) @ echo "herd7 AArch64 KVM instructions tests: OK" test:: test-c test-local:: test-c test-c: @ echo $(HERD_REGRESSION_TEST) \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -litmus-dir ./herd/tests/instructions/C \ -conf ./herd/tests/instructions/C/c.cfg \ $(REGRESSION_TEST_MODE) @ echo "herd7 AArch64 C instructions tests: OK" test:: test-ppc test-local:: test-ppc test-ppc: @ echo $(HERD_REGRESSION_TEST) \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -litmus-dir ./herd/tests/instructions/PPC \ $(REGRESSION_TEST_MODE) @ echo "herd7 PPC instructions tests: OK" test:: test-asl test-local:: test-asl test-asl: @ echo $(HERD_REGRESSION_TEST) \ -nohash \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -litmus-dir ./herd/tests/instructions/ASL \ $(REGRESSION_TEST_MODE) @ echo "herd7 ASL instructions tests: OK" test:: test-pseudo-asl test-local:: test-pseudo-asl test-pseudo-asl: @ echo $(HERD_REGRESSION_TEST) \ -nohash \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -litmus-dir ./herd/tests/instructions/ASL-pseudo-arch \ -conf ./herd/tests/instructions/ASL-pseudo-arch/pseudo-conf.cfg \ $(REGRESSION_TEST_MODE) @ echo "herd7 ASL instructions tests on pseudo-architecture: OK" test:: test-aarch64-asl test-aarch64-asl: asl-pseudocode @echo $(HERD_REGRESSION_TEST) \ -j $(J) \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -litmus-dir ./herd/tests/instructions/AArch64.ASL \ -conf ./herd/tests/instructions/AArch64.ASL/asl.cfg \ $(REGRESSION_TEST_MODE) @ echo "herd7 AArch64+ASL instructions tests: OK" test:: test-aarch64-noasl test-local:: test-aarch64-noasl test-aarch64-noasl: @echo $(HERD_REGRESSION_TEST) \ -j $(J) \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -litmus-dir ./herd/tests/instructions/AArch64.ASL \ -conf ./herd/tests/instructions/AArch64.ASL/noasl.cfg \ $(REGRESSION_TEST_MODE) @ echo "herd7 AArch64+NOASL instructions tests: OK" test:: test-aarch64-noasl-mixed test-local:: test-aarch64-noasl-mixed test-aarch64-noasl-mixed: @echo $(HERD_REGRESSION_TEST) \ -j $(J) \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -litmus-dir ./herd/tests/instructions/AArch64.ASL \ -conf ./herd/tests/instructions/AArch64.ASL/noasl-mixed.cfg \ $(REGRESSION_TEST_MODE) @ echo "herd7 AArch64+NOASL+MIXED instructions tests: OK" test:: arm-test test-local:: arm-test arm-test:: @ echo $(HERD_REGRESSION_TEST) \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -litmus-dir ./herd/tests/instructions/ARM \ $(REGRESSION_TEST_MODE) @ echo "herd7 ARM instructions tests: OK" aarch32-test:: @ echo $(HERD_REGRESSION_TEST) \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -litmus-dir ./herd/tests/instructions/AArch32 \ -conf ./herd/tests/instructions/AArch32/aarch32.cfg \ $(REGRESSION_TEST_MODE) @ echo "herd7 AArch32 instructions tests: OK" test::aarch32-test test-local::aarch32-test diy-test:: diy-test-aarch64 diy-test-aarch64: @ echo $(HERD_DIYCROSS_REGRESSION_TEST) \ -herd-path $(HERD) \ -diycross-path $(DIYCROSS) \ -libdir-path ./herd/libdir \ -expected-dir ./herd/tests/diycross/AArch64 \ -diycross-arg -arch \ -diycross-arg AArch64 \ -diycross-arg 'Pod**,Fenced**' \ -diycross-arg 'Rfe,Fre,Coe' \ -diycross-arg 'Pod**,Fenced**,DpAddrdR,DpAddrdW,DpDatadW,CtrldR,CtrldW' \ -diycross-arg 'Rfe,Fre,Coe' \ $(REGRESSION_TEST_MODE) @ echo "herd7 AArch64 diycross7 tests: OK" ### CATALOGUE testing, catalogue must be here CATATEST := $(shell if test -d catalogue; then echo cata-test; fi) test:: $(CATATEST) test-local:: $(CATATEST) cata-test:: cata-bpf-test cata-bpf-test: @ echo $(HERD_CATALOGUE_REGRESSION_TEST) \ -j $(J) \ -herd-timeout $(TIMEOUT) \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -kinds-path catalogue/bpf/tests/kinds.txt \ -shelf-path catalogue/bpf/shelf.py \ $(REGRESSION_TEST_MODE) @ echo "herd7 catalogue bpf tests: OK" cata-test:: cata-aarch64-test cata-aarch64-test: @ echo $(HERD_CATALOGUE_REGRESSION_TEST) \ -j $(J) \ -herd-timeout $(TIMEOUT) \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -kinds-path catalogue/aarch64/tests/kinds.txt \ -shelf-path catalogue/aarch64/shelf.py \ $(REGRESSION_TEST_MODE) @ echo "herd7 catalogue aarch64 tests: OK" cata-test:: aarch64-test-mixed aarch64-test-mixed: @ echo $(HERD_CATALOGUE_REGRESSION_TEST) \ -j $(J) \ -herd-timeout $(TIMEOUT) \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -kinds-path catalogue/aarch64/tests/kinds.txt \ -shelf-path catalogue/aarch64/shelf.py \ -variant mixed \ $(REGRESSION_TEST_MODE) @ echo "herd7 catalogue aarch64 tests (mixed mode): OK" cata-test:: mixed-test mixed-test: @ echo $(HERD_CATALOGUE_REGRESSION_TEST) \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -kinds-path catalogue/aarch64-mixed/tests/kinds.txt \ -shelf-path catalogue/aarch64-mixed/shelf.py \ $(REGRESSION_TEST_MODE) @ echo "herd7 catalogue aarch64-mixed tests: OK" cata-test:: pick-test pick-test: @ echo $(HERD_CATALOGUE_REGRESSION_TEST) \ -j $(J) \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -kinds-path catalogue/aarch64-pick/tests/desired-kinds.txt \ -shelf-path catalogue/aarch64-pick/shelf.py \ $(REGRESSION_TEST_MODE) @ echo "herd7 catalogue aarch64-pick tests: OK" cata-test:: faults-test faults-test: @ echo $(HERD_CATALOGUE_REGRESSION_TEST) \ -j $(J) \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -kinds-path catalogue/aarch64-faults/tests/kinds.txt \ -shelf-path catalogue/aarch64-faults/shelf.py \ $(REGRESSION_TEST_MODE) @ echo "herd7 catalogue aarch64-faults tests: OK" cata-test:: pick-test-mixed pick-test-mixed: @ echo $(HERD_CATALOGUE_REGRESSION_TEST) \ -j $(J) \ -herd-path $(HERD) \ -herd-timeout $(TIMEOUT) \ -libdir-path ./herd/libdir \ -kinds-path catalogue/aarch64-pick/tests/desired-kinds.txt \ -shelf-path catalogue/aarch64-pick/shelf.py \ -variant mixed \ $(REGRESSION_TEST_MODE) @ echo "herd7 catalogue aarch64-pick tests (mixed mode): OK" cata-test:: mte-test mte-test: @ echo $(HERD_CATALOGUE_REGRESSION_TEST) \ -herd-timeout $(TIMEOUT) \ -j $(J) \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -kinds-path catalogue/aarch64-MTE/tests/kinds.txt \ -shelf-path catalogue/aarch64-MTE/shelf.py \ $(REGRESSION_TEST_MODE) @ echo "herd7 catalogue aarch64-MTE tests: OK" test-all:: vmsa-test vmsa-test: @ echo $(HERD_CATALOGUE_REGRESSION_TEST) \ -j $(J) \ -herd-path $(HERD) \ -herd-timeout $(TIMEOUT) \ -libdir-path ./herd/libdir \ -kinds-path catalogue/aarch64-VMSA/tests/VMSA-kinds.txt \ -shelf-path catalogue/aarch64-VMSA/shelf.py \ $(REGRESSION_TEST_MODE) @ echo "herd7 catalogue aarch64-VMSA tests: OK" test-all:: ets2-test ets2-test: @ echo $(HERD_CATALOGUE_REGRESSION_TEST) \ -j $(J) \ -herd-path $(HERD) \ -herd-timeout $(TIMEOUT) \ -libdir-path ./herd/libdir \ -kinds-path catalogue/aarch64-ETS2/tests/VMSA-ETS2-kinds.txt \ -shelf-path catalogue/aarch64-ETS2/shelf.py \ $(REGRESSION_TEST_MODE) @ echo "herd7 catalogue aarch64-ETS2 tests: OK" test.vmsa+mte: @ echo $(HERD_REGRESSION_TEST) \ -herd-path $(HERD) \ -libdir-path ./herd/libdir \ -litmus-dir ./herd/tests/instructions/AArch64.vmsa+mte \ -conf ./herd/tests/instructions/AArch64.vmsa+mte/vmsa+mte.cfg \ $(REGRESSION_TEST_MODE) @ echo "herd7 AArch64 VMSA+MTE instructions tests: OK" test:: diy-test test-local:: diy-test LDS:="Amo.Cas,Amo.LdAdd,Amo.LdClr,Amo.LdEor,Amo.LdSet" LDSPLUS:="LxSx",$(LDS) diy-test:: diy-test-mixed diy-test-mixed:: @ echo $(HERD_DIYCROSS_REGRESSION_TEST) \ -j $(J) \ -herd-path $(HERD) \ -diycross-path $(DIYCROSS) \ -libdir-path ./herd/libdir \ -expected-dir ./herd/tests/diycross/AArch64.mixed \ -conf ./herd/tests/diycross/AArch64.mixed/mixed.cfg \ -diycross-arg -ua \ -diycross-arg 0 \ -diycross-arg -obs \ -diycross-arg oo \ -diycross-arg -arch \ -diycross-arg AArch64 \ -diycross-arg -variant \ -diycross-arg mixed \ -diycross-arg -hexa \ -diycross-arg Hat \ -diycross-arg h0 \ -diycross-arg $(LDSPLUS) \ -diycross-arg h0 \ -diycross-arg Rfi \ -diycross-arg w0 \ -diycross-arg Amo.StAdd \ -diycross-arg w0 \ -diycross-arg Rfi \ -diycross-arg h2 \ -diycross-arg $(LDS) \ -diycross-arg h2 \ -diycross-arg PodWR \ -diycross-arg Hat \ -diycross-arg w0 \ -diycross-arg Amo.LdSet \ -diycross-arg w0 \ -diycross-arg PodWR \ $(REGRESSION_TEST_MODE) @ echo "herd7 AArch64.mixed diycross7 tests: OK" diy-test-mixed:: @ echo $(HERD_DIYCROSS_REGRESSION_TEST) \ -j $(J) \ -herd-path $(HERD) \ -diycross-path $(DIYCROSS) \ -libdir-path ./herd/libdir \ -expected-dir ./herd/tests/diycross/AArch64.mixed.strict \ -conf ./herd/tests/diycross/AArch64.mixed.strict/mixed.cfg \ -diycross-arg -arch \ -diycross-arg AArch64 \ -diycross-arg -ua \ -diycross-arg 0 \ -diycross-arg -variant \ -diycross-arg mixed,MixedStrictOverlap \ -diycross-arg -hexa \ -diycross-arg h0,h2,w0 \ -diycross-arg Amo.CasAP,LxSxAP \ -diycross-arg h0,h2,w0 \ -diycross-arg PodWR \ -diycross-arg w0,h0 \ -diycross-arg Fre \ -diycross-arg w0,h2 \ -diycross-arg FencedWW \ -diycross-arg w0,h0,h2 \ -diycross-arg Rfe \ $(REGRESSION_TEST_MODE) @ echo "herd7 AArch64.mixed.strict diycross7 tests: OK" diy-test-mixed:: v32 v64 v32: @ echo $(HERD_DIYCROSS_REGRESSION_TEST) \ -j $(J) \ -herd-path $(HERD) \ -diycross-path $(DIYCROSS) \ -libdir-path ./herd/libdir \ -expected-dir ./herd/tests/diycross/AArch64.mixed.v32 \ -conf ./herd/tests/diycross/AArch64.mixed.strict/mixed.cfg \ -diycross-arg -arch \ -diycross-arg AArch64 \ -diycross-arg -variant \ -diycross-arg mixed \ -diycross-arg -hexa \ -diycross-arg PodWW \ -diycross-arg RfeLA \ -diycross-arg h0,h2,w0 \ -diycross-arg DpDatadW,DpAddrdR,DpAddrdW \ -diycross-arg A,P,L \ -diycross-arg h0,h2,w0 \ -diycross-arg Coe,Fre \ $(REGRESSION_TEST_MODE) @ echo "herd7 AArch64.mixed.v32 diycross7 tests: OK" v64: @ echo $(HERD_DIYCROSS_REGRESSION_TEST) \ -j $(J) \ -herd-path $(HERD) \ -diycross-path $(DIYCROSS) \ -libdir-path ./herd/libdir \ -expected-dir ./herd/tests/diycross/AArch64.mixed.v64 \ -conf ./herd/tests/diycross/AArch64.mixed.strict/mixed.cfg \ -diycross-arg -arch \ -diycross-arg AArch64 \ -diycross-arg -variant \ -diycross-arg mixed \ -diycross-arg -hexa \ -diycross-arg -type \ -diycross-arg uint64_t \ -diycross-arg PodWW \ -diycross-arg RfeLA \ -diycross-arg w0,w4,q0 \ -diycross-arg DpDatadW,DpAddrdR,DpAddrdW \ -diycross-arg A,P,L \ -diycross-arg w0,w4,q0 \ -diycross-arg Coe,Fre \ $(REGRESSION_TEST_MODE) @ echo "herd7 AArch64.mixed.v64 diycross7 tests: OK" diy-test:: diy-store-test diy-store-test: @ echo $(HERD_DIYCROSS_REGRESSION_TEST) \ -herd-path $(HERD) \ -diycross-path $(DIYCROSS) \ -libdir-path ./herd/libdir \ -expected-dir ./herd/tests/diycross/AArch64.store \ -diycross-arg -obs \ -diycross-arg four \ -diycross-arg -arch \ -diycross-arg AArch64 \ -diycross-arg 'Fenced**' \ -diycross-arg 'Rfe,Fre,Coe' \ -diycross-arg 'DpAddrdR,DpDatadW' \ -diycross-arg 'Pos**' \ -diycross-arg 'Store' \ -diycross-arg 'Rfe,Fre,Coe' \ $(REGRESSION_TEST_MODE) @ echo "herd7 AArch64 diycross7.store tests: OK" diy-test:: diy-test-mte diy-test-mte:: @ echo $(HERD_DIYCROSS_REGRESSION_TEST) \ -j $(J) \ -herd-path $(HERD) \ -diycross-path $(DIYCROSS) \ -libdir-path ./herd/libdir \ -expected-dir ./herd/tests/diycross/AArch64.MTE \ -conf ./herd/tests/diycross/AArch64.MTE/MTE.cfg \ -diycross-arg -arch \ -diycross-arg AArch64 \ -diycross-arg -variant \ -diycross-arg memtag \ -diycross-arg DMB.SYd*W \ -diycross-arg T,P \ -diycross-arg Rfe \ -diycross-arg A \ -diycross-arg Amo.LdAdd \ -diycross-arg L \ -diycross-arg PodW* \ -diycross-arg T,P \ -diycross-arg Coe,Rfe,Fre \ -diycross-arg T,P \ $(REGRESSION_TEST_MODE) @ echo "herd7 AArch64.MTE diycross7 tests: OK" diy-test:: diy-test-C diy-test-C: @ echo $(HERD_DIYCROSS_REGRESSION_TEST) \ -j $(J) \ -herd-path $(HERD) \ -diycross-path $(DIYCROSS) \ -libdir-path ./herd/libdir \ -expected-dir ./herd/tests/diycross/C \ -conf ./herd/tests/diycross/C/C.cfg \ -diycross-arg -arch \ -diycross-arg C \ -diycross-arg [Rlx,Coe,Rlx],[Rlx,Rfe,Rlx],[Rlx,Fre,Rlx],[Rlx,Hat,Rlx] \ -diycross-arg PosRW,Fetch.Add,Exch \ -diycross-arg Rlx \ -diycross-arg PodW* \ -diycross-arg [Rlx,Coe,Rlx],[Rlx,Rfe,Rlx],[Rlx,Fre,Rlx] \ -diycross-arg Pod**,[Fetch.Add,Rlx,PodW*] \ $(REGRESSION_TEST_MODE) @ echo "herd7 C diycross7 tests: OK" .PHONY: asl-pseudocode clean-asl-pseudocode asl-pseudocode: herd/libdir/asl-pseudocode/shared_pseudocode.asl herd/libdir/asl-pseudocode/shared_pseudocode.asl: @ $(MAKE) -C $(@D) a64 clean-tmp clean-asl-pseudocode: @ $(MAKE) -C $(@D)/herd/libdir/asl-pseudocode clean asldoc: $(BENTO) @ $(MAKE) $(MFLAGS) -C $(@D)/asllib/doc all clean-asldoc: @ $(MAKE) $(MFLAGS) -C $(@D)/asllib/doc clean RUN_TESTS?=false $(V).SILENT: $(V)SILENTOPT=-s include Makefile.x86_64 include Makefile.aarch64 herd-herdtools7-1ca343e/Makefile.aarch64000066400000000000000000000101321475314470400200260ustar00rootroot00000000000000ifneq ($(OS),Darwin) AARCH64_PREFIX ?= aarch64-linux-gnu- endif litmus-aarch64-test:: litmus-cata-aarch64-test-std litmus-cata-aarch64-test-std: TEMP_DIR:=$(shell mktemp -d) litmus-cata-aarch64-test-std: $(LITMUS) \ -set-libdir $(LITMUS_LIB_DIR) \ -gcc=$(AARCH64_PREFIX)gcc \ -ccopts='-march=armv8-a+lse' \ -o $(TEMP_DIR) \ -mode std -a 4 \ catalogue/aarch64/tests/@all make $(SILENTOPT) -C $(TEMP_DIR) -j $(J) if $(RUN_TESTS); then ( cd $(TEMP_DIR) && sh run.sh ); fi $(RM) -r $(TEMP_DIR) @ echo "litmus7 in -mode std catalogue aarch64 tests: OK" litmus-aarch64-test:: litmus-cata-aarch64-test-presi litmus-cata-aarch64-test-presi: TEMP_DIR:=$(shell mktemp -d) litmus-cata-aarch64-test-presi: $(LITMUS) \ -set-libdir $(LITMUS_LIB_DIR) \ -gcc=$(AARCH64_PREFIX)gcc \ -ccopts='-march=armv8-a+lse' \ -o $(TEMP_DIR) \ -mode presi -a 4 \ catalogue/aarch64/tests/@all make $(SILENTOPT) -C $(TEMP_DIR) -j $(J) if $(RUN_TESTS); then ( cd $(TEMP_DIR) && sh run.sh ); fi $(RM) -r $(TEMP_DIR) @ echo "litmus7 in -mode presi catalogue aarch64 tests: OK" litmus-aarch64-test:: litmus-cata-aarch64-ifetch-test litmus-cata-aarch64-ifetch-test: TEMP_DIR:=$(shell mktemp -d) litmus-cata-aarch64-ifetch-test: $(LITMUS) \ -set-libdir $(LITMUS_LIB_DIR) \ -gcc=$(AARCH64_PREFIX)gcc \ -ccopts='-march=armv8-a+lse' \ -o $(TEMP_DIR) \ -mode std -a 4 \ catalogue/aarch64-ifetch/tests/@nofault make $(SILENTOPT) -C $(TEMP_DIR) -j $(J) if $(RUN_TESTS); then ( cd $(TEMP_DIR) && sh run.sh ); fi $(RM) -r $(TEMP_DIR) @ echo "litmus7 in -mode std catalogue aarch64-ifetch tests: OK" KUT_AARCH64_PREFFIX = $(AARCH64_PREFIX) ifeq ($(OS),Darwin) KUT_AARCH64_PREFFIX = aarch64-elf- endif KUT_CONFIG_PARAMS=--arch=arm64 --page-size=4k --cross-prefix=$(KUT_AARCH64_PREFFIX) KUT_DIR_AARCH64:=$(shell mktemp -d) litmus-aarch64-dep: cd $(KUT_DIR_AARCH64); \ git clone -q https://gitlab.com/kvm-unit-tests/kvm-unit-tests.git; \ cd kvm-unit-tests; \ ./configure $(KUT_CONFIG_PARAMS); \ make $(SILENTOPT) litmus-aarch64-test:: litmus-cata-aarch64-test-kvm litmus-cata-aarch64-test-kvm: litmus-aarch64-dep mkdir $(KUT_DIR_AARCH64)/kvm-unit-tests/t $(LITMUS) \ -set-libdir $(LITMUS_LIB_DIR) \ -o $(KUT_DIR_AARCH64)/kvm-unit-tests/t \ -mach kvm-armv8.1 -a 4 \ catalogue/aarch64/tests/@all cd $(KUT_DIR_AARCH64)/kvm-unit-tests/t; make $(SILENTOPT) -j $(J) if $(RUN_TESTS); then ( cd $(KUT_DIR_AARCH64)/kvm-unit-tests && sh t/run.sh ); fi $(RM) -r $(KUT_DIR_AARCH64)/kvm-unit-tests/t @ echo "litmus7 in -mode kvm catalogue aarch64 tests: OK" litmus-aarch64-test:: litmus-cata-aarch64-VMSA-test-kvm litmus-cata-aarch64-VMSA-test-kvm: litmus-aarch64-dep mkdir $(KUT_DIR_AARCH64)/kvm-unit-tests/t $(LITMUS) \ -set-libdir $(LITMUS_LIB_DIR) \ -o $(KUT_DIR_AARCH64)/kvm-unit-tests/t \ -mach kvm-armv8.1+rcpc -a 4 -s 10 -r 10 \ catalogue/aarch64-VMSA/tests/@all cd $(KUT_DIR_AARCH64)/kvm-unit-tests/t; make $(SILENTOPT) -j $(J) if $(RUN_TESTS); then ( cd $(KUT_DIR_AARCH64)/kvm-unit-tests && sh t/run.sh ); fi $(RM) -r $(KUT_DIR_AARCH64)/kvm-unit-tests/t @ echo "litmus7 in -mode kvm catalogue aarch64-VMSA tests: OK" litmus-aarch64-test:: litmus-cata-aarch64-ifetch-test-kvm litmus-cata-aarch64-ifetch-test-kvm: litmus-aarch64-dep mkdir $(KUT_DIR_AARCH64)/kvm-unit-tests/t $(LITMUS) \ -set-libdir $(LITMUS_LIB_DIR) \ -o $(KUT_DIR_AARCH64)/kvm-unit-tests/t \ -mach kvm-armv8.1 -variant self -a 4 -s 10 -r 10 \ catalogue/aarch64-ifetch/tests/@all cd $(KUT_DIR_AARCH64)/kvm-unit-tests/t; make $(SILENTOPT) -j $(J) #Disabled as some tests are not terminating. Those tests are # WRC-inst-modified-2 IDC1.WRC-inst-modified-2 # DIC1.WRC-inst-modified-2 UDF+2FH if false; then ( cd $(KUT_DIR_AARCH64)/kvm-unit-tests && sh t/run.sh ); fi $(RM) -r $(KUT_DIR_AARCH64)/kvm-unit-tests/t @ echo "litmus7 in -mode kvm catalogue aarch64-ifetch tests: OK" litmus-test:: litmus-aarch64-test herd-herdtools7-1ca343e/Makefile.x86_64000066400000000000000000000034221475314470400175400ustar00rootroot00000000000000X86_64_PREFIX ?= x86_64-linux-gnu- litmus-x86_64-test:: litmus-cata-x86_64-test-std litmus-cata-x86_64-test-std: TEMP_DIR:=$(shell mktemp -d) litmus-cata-x86_64-test-std: $(LITMUS) -set-libdir $(PWD)/litmus/libdir -mach x86_64 -gcc=$(X86_64_PREFIX)gcc -mode std -a 4 catalogue/x86_64/tests/@all -o $(TEMP_DIR) make $(SILENTOPT) -C $(TEMP_DIR) -j $(J) if $(RUN_TESTS); then ( cd $(TEMP_DIR) && sh ./run.sh ); fi $(RM) -rf $(TEMP_DIR) @ echo "litmus7 in -mode std catalogue x86_64 tests: OK" litmus-x86_64-test:: litmus-cata-x86_64-test-presi litmus-cata-x86_64-test-presi: TEMP_DIR:=$(shell mktemp -d) litmus-cata-x86_64-test-presi: $(LITMUS) -set-libdir $(PWD)/litmus/libdir -mach x86_64 -gcc=$(X86_64_PREFIX)gcc -mode presi -driver C -a 4 -s 1k -r 50 catalogue/x86_64/tests/@all -o $(TEMP_DIR) make $(SILENTOPT) -C $(TEMP_DIR) -j $(J) if $(RUN_TESTS); then ( cd $(TEMP_DIR) && ./run.exe ); fi $(RM) -rf $(TEMP_DIR) @ echo "litmus7 in -mode presi catalogue x86_64 tests: OK" KUT_X86_64_CONFIG_PARAMS=--cross-prefix=$(X86_64_PREFIX) --arch=x86_64 KUT_DIR := $(shell mktemp -d) litmus-x86_64-dep: cd $(KUT_DIR); \ git clone -q https://gitlab.com/kvm-unit-tests/kvm-unit-tests.git; \ cd kvm-unit-tests; \ ./configure $(KUT_X86_64_CONFIG_PARAMS); \ make $(SILENTOPT) litmus-x86_64-test:: litmus-cata-x86_64-test-kvm litmus-cata-x86_64-test-kvm: litmus-x86_64-dep mkdir $(KUT_DIR)/kvm-unit-tests/t $(LITMUS) -set-libdir $(PWD)/litmus/libdir -mach kvm-x86_64 -s 1k -r 50 -driver C -a 4 catalogue/x86_64/tests/@all -o $(KUT_DIR)/kvm-unit-tests/t cd $(KUT_DIR)/kvm-unit-tests/t; make $(SILENTOPT) -j $(J) if $(RUN_TESTS); then ( cd $(KUT_DIR)/kvm-unit-tests && sh t/run.sh ); fi $(RM) -rf $(KUT_DIR) @ echo "litmus7 in -mode kvm catalogue x86_64 tests: OK" litmus-test:: litmus-x86_64-test herd-herdtools7-1ca343e/README.md000066400000000000000000000036251475314470400164270ustar00rootroot00000000000000This is herdtools7, a tool suite to test weak memory models. We provide the following tools: - herd7: a generic simulator for weak memory models - litmus7: run litmus tests (given as assembler programs for Power, ARM, AArch64 or X86) to test the memory model of the executing machine - diy7: produce litmus tests from concise specifications - some additional tools In particular, * mcompare7 to analyse run logs of both herd and litmus. * klitmus7, an experimental tool, similar to litmus7 that runs kernel memory model tests as kernel modules. The tool klitmus7 is inspired from a python script by Andrea Parri,. herdtools7 is the successor of the diy tool suite. Home ==== http://diy.inria.fr/ diy-devel@inria.fr Compilation and installation ============================ See file [INSTALL.md](INSTALL.md). Contributing ============ This repository uses the [Pre-Commit tool](https://pre-commit.com) to manage pre-commit validation, to check for formatting, test regressions, etc. Pre-Commit can be installed on macOS with [Homebrew](https://brew.sh), or on all platforms with Python's `pip`: # macOS with Homebrew. % brew install pre-commit # All other OS (including macOS without Homebrew). % pip install pre-commit To make Pre-Commit run automatically when you `git commit`, add it to your Git repository's local `pre-commit` hooks. From within this repository, run: % pre-commit install When adding a new pre-commit check, please run Pre-Commit manually first: % pre-commit run --all-files License ======= The authors of the diy7 tool suite are Jade Alglave and Luc Maranget. Copyright 2010 -- present: Institut National de Recherche en Informatique et en Automatique, and the authors. Diy7 is released under the terms of the CeCILL-B free software license agreement. See file [LICENSE.txt](LICENSE.txt). herd-herdtools7-1ca343e/VERSION.txt000066400000000000000000000000051475314470400170230ustar00rootroot000000000000007.58 herd-herdtools7-1ca343e/_tags000066400000000000000000000006361475314470400161670ustar00rootroot00000000000000: include : include : include : include : include : include : include : include : include : include true: safe_string true: dtypes true: -traverse true: use_menhir <*/*.byte>: debug <*/*.cmo>: debug <*/*.{d.byte,byte,native}>: use_unix,use_str <*/*/*/*.{d.byte,byte,native}>: use_unix,use_str : use_unix herd-herdtools7-1ca343e/asllib/000077500000000000000000000000001475314470400164105ustar00rootroot00000000000000herd-herdtools7-1ca343e/asllib/.ocamlformat000066400000000000000000000000201475314470400207050ustar00rootroot00000000000000disable = false herd-herdtools7-1ca343e/asllib/AST.mli000066400000000000000000000401241475314470400175430ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) (** An Abstract Syntax Tree for ASL. *) (* ------------------------------------------------------------------------- Utils ------------------------------------------------------------------------- *) (** {2 Utils} *) type version = V0 | V1 type position = Lexing.position type 'a annotated = { desc : 'a; pos_start : position; pos_end : position; version : version; } type identifier = string (** Type of local identifiers in the AST. *) type uid = int (** Unique identifiers *) (* ------------------------------------------------------------------------- Operations ------------------------------------------------------------------------- *) (** {2 Operations} *) (** Operations on base value of arity one. *) type unop = | BNOT (** Boolean inversion *) | NEG (** Integer or real negation *) | NOT (** Bitvector bitwise inversion *) (** Operations on base value of arity two. *) type binop = | AND (** Bitvector bitwise and *) | BAND (** Boolean and *) | BEQ (** Boolean equivalence *) | BOR (** Boolean or *) | DIV (** Integer division *) | DIVRM (** Inexact integer division, with rounding towards negative infinity. *) | EOR (** Bitvector bitwise exclusive or *) | EQ_OP (** Equality on two base values of same type *) | GT (** Greater than for int or reals *) | GEQ (** Greater or equal for int or reals *) | IMPL (** Boolean implication *) | LT (** Less than for int or reals *) | LEQ (** Less or equal for int or reals *) | MOD (** Remainder of integer division *) | MINUS (** Substraction for int or reals or bitvectors *) | MUL (** Multiplication for int or reals or bitvectors *) | NEQ (** Non equality on two base values of same type *) | OR (** Bitvector bitwise or *) | PLUS (** Addition for int or reals or bitvectors *) | POW (** Exponentiation for ints *) | RDIV (** Division for reals *) | SHL (** Shift left for ints *) | SHR (** Shift right for ints *) | BV_CONCAT (** Bit vector concatenation *) (* ------------------------------------------------------------------------- Parsed values ------------------------------------------------------------------------- *) (** {2 Literals} Literals are the values written straight into ASL specifications. There is only literal constructors for a few concepts that could be encapsulated into an ASL value. *) (** Main value type, parametric on its base values *) type literal = | L_Int of Z.t | L_Bool of bool | L_Real of Q.t | L_BitVector of Bitvector.t | L_String of string | L_Label of string (** An enumeration label, given by its name. *) (* ------------------------------------------------------------------------- Expressions ------------------------------------------------------------------------- *) (** {2 Expressions} *) type subprogram_type = | ST_Procedure (** A procedure is a subprogram without return type, called from a statement. *) | ST_Function (** A function is a subprogram with a return type, called from an expression. *) | ST_Getter (** A getter is a special function called with a syntax similar to slices. *) | ST_EmptyGetter (** An empty getter is a special function called with a syntax similar to a variable. This is relevant only for V0. *) | ST_Setter (** A setter is a special procedure called with a syntax similar to slice assignment. *) | ST_EmptySetter (** An empty setter is a special procedure called with a syntax similar to an assignment to a variable. This is relevant only for V0. *) (** Expressions. Parametric on the type of literals. *) type expr_desc = | E_Literal of literal | E_Var of identifier | E_ATC of expr * ty (** Asserted type conversion *) | E_Binop of binop * expr * expr | E_Unop of unop * expr | E_Call of call | E_Slice of expr * slice list | E_Cond of expr * expr * expr | E_GetArray of expr * expr (** [E_GetArray base index] Represents an access to an array given by the expression [base] at index [index]. When this node appears in the untyped AST, the index may either be integer-typed or enumeration-typed. When this node appears in the typed AST, the index can only be integer-typed. *) | E_GetEnumArray of expr * expr (** Access an array with an enumeration index. This constructor is only part of the typed AST. *) | E_GetField of expr * identifier | E_GetFields of expr * identifier list | E_GetItem of expr * int | E_Record of ty * (identifier * expr) list (** Represents a record or an exception construction expression. *) | E_Tuple of expr list | E_Array of { length : expr; value : expr } (** Initial value for an array of size [length] and of content [value] at each array cell. This expression constructor is only part of the typed AST, i.e. it is only built by the type-checker, not any parser. *) | E_EnumArray of { enum : identifier; labels : identifier list; value : expr } (** Initial value for an array where the index is the enumeration [enum], which declares the list of labels [labels], and the content of each cell is given by [value]. [enum] is only used for pretty-printing. This expression constructor is only part of the typed AST, i.e. it is only built by the type-checker, not any parser. *) | E_Arbitrary of ty | E_Pattern of expr * pattern and expr = expr_desc annotated and pattern_desc = | Pattern_All | Pattern_Any of pattern list | Pattern_Geq of expr | Pattern_Leq of expr | Pattern_Mask of Bitvector.mask | Pattern_Not of pattern | Pattern_Range of expr * expr (* lower -> upper, included *) | Pattern_Single of expr | Pattern_Tuple of pattern list and pattern = pattern_desc annotated (** Slices define lists of indices into arrays and bitvectors. *) and slice = | Slice_Single of expr (** [Slice_Single i] is the slice of length [1] at position [i]. *) | Slice_Range of expr * expr (** [Slice_Range (j, i)] denotes the slice from [i] to [j - 1]. *) | Slice_Length of expr * expr (** [Slice_Length (i, n)] denotes the slice starting at [i] of length [n]. *) | Slice_Star of expr * expr (** [Slice_Start (factor, length)] denotes the slice starting at [factor * length] of length [n]. *) (** All positions mentioned above are inclusive. *) and call = { name : identifier; params : expr list; args : expr list; call_type : subprogram_type; } (* ------------------------------------------------------------------------- Types ------------------------------------------------------------------------- *) (** {2 Types} *) (** Type descriptors.*) and type_desc = (* Begin Constrained *) | T_Int of constraint_kind | T_Bits of expr * bitfield list (* End Constrained *) | T_Real | T_String | T_Bool | T_Enum of identifier list | T_Tuple of ty list | T_Array of array_index * ty | T_Record of field list | T_Exception of field list | T_Named of identifier (** A type variable. *) and ty = type_desc annotated (** A constraint on an integer part. *) and int_constraint = | Constraint_Exact of expr (** Exactly this value, as given by a statically evaluable expression. *) | Constraint_Range of (expr * expr) (** In the inclusive range of these two statically evaluable values. *) (** The constraint_kind constrains an integer type to a certain subset. *) and constraint_kind = | UnConstrained (** The normal, unconstrained, integer type. *) | WellConstrained of int_constraint list (** An integer type constrained from ASL syntax: it is the union of each constraint in the list. *) | PendingConstrained (** An integer type whose constraint will be inferred during type-checking. *) | Parameterized of uid * identifier (** A parameterized integer, the default type for parameters of function at compile time, with a unique identifier and the variable bearing its name. *) (** Represent static slices on a given bitvector type. *) and bitfield = | BitField_Simple of identifier * slice list (** A name and its corresponding slice *) | BitField_Nested of identifier * slice list * bitfield list (** A name, its corresponding slice and some nested bitfields. *) | BitField_Type of identifier * slice list * ty (** A name, its corresponding slice and the type of the bitfield. *) (** The type of indexes for an array. *) and array_index = | ArrayLength_Expr of expr (** An integer expression giving the length of the array. *) | ArrayLength_Enum of identifier * identifier list (** An enumeration name and its list of labels. *) and field = identifier * ty (** A field of a record-like structure. *) and typed_identifier = identifier * ty (** An identifier declared with its type. *) (* ------------------------------------------------------------------------- l-expressions and statements ------------------------------------------------------------------------- *) (** {2 Statements} *) (** Type of left-hand side of assignments. *) type lexpr_desc = | LE_Discard | LE_Var of identifier | LE_Slice of lexpr * slice list | LE_SetArray of lexpr * expr (** [LE_SetArray base index] represents a write to an array given by the expression [base] at index [index]. When this node appears in the untyped AST, the index may either be integer-typed or enumeration-typed. When this node appears in the typed AST, the index can only be integer-typed. *) | LE_SetEnumArray of lexpr * expr (** Represents a write to an array with an enumeration index. This constructor is only part of the typed AST. *) | LE_SetField of lexpr * identifier | LE_SetFields of lexpr * identifier list * (int * int) list (** LE_SetFields (le, fields, _) unpacks the various fields. Third argument is a type annotation. *) | LE_Destructuring of lexpr list and lexpr = lexpr_desc annotated type local_decl_keyword = LDK_Var | LDK_Constant | LDK_Let (** A left-hand side of a declaration statement. In the following example of a declaration statement, [(2, 3, 4): (integer, integer, integer {0..32})] is the local declaration item: {v let (x, -, z): (integer, integer, integer {0..32}) = (2, 3, 4); v} *) type local_decl_item = | LDI_Var of identifier (** [LDI_Var x] is the variable declaration of the variable [x], used for example in: {v let x = 42; v}. *) | LDI_Tuple of identifier list (** [LDI_Tuple names] is the tuple declarations of [names], for example: {v let (x, y, z) = (1, 2, 3); v} We expect the list to contain at least 2 items. *) (** Statements. Parametric on the type of literals in expressions. *) type for_direction = Up | Down type stmt_desc = | S_Pass | S_Seq of stmt * stmt | S_Decl of local_decl_keyword * local_decl_item * ty option * expr option | S_Assign of lexpr * expr | S_Call of call | S_Return of expr option | S_Cond of expr * stmt * stmt | S_Assert of expr | S_For of { index_name : identifier; start_e : expr; dir : for_direction; end_e : expr; body : stmt; limit : expr option; } | S_While of expr * expr option * stmt | S_Repeat of stmt * expr * expr option | S_Throw of (expr * ty option) option (** The ty option is a type annotation added by the type-checker to be matched later with the catch guards. It is always None for the untyped AST and never None for the typed AST. The outer option is used to represent the implicit throw, such as [throw;]. *) | S_Try of stmt * catcher list * stmt option (** The stmt option is the optional otherwise guard. *) | S_Print of { args : expr list; newline : bool; debug : bool } (** A call to print, as an explicit node as it does not require type-checking. [newline] indicates if the print statement should add an extra new line after printing all the arguments. [debug] indicates if the print statement has been made using the ASLRef specific function [__debug]. *) | S_Unreachable (** The unreachable statement, as an explicit node as it has a specific control-flow behaviour. *) | S_Pragma of identifier * expr list (** A pragma statement, as an explicit node to be used by tools which need AST level hints. *) and stmt = stmt_desc annotated and case_alt_desc = { pattern : pattern; where : expr option; stmt : stmt } and case_alt = case_alt_desc annotated and catcher = identifier option * ty * stmt (** The optional name of the matched exception, the guard type and the statement to be executed if the guard matches. *) (* ------------------------------------------------------------------------- Functions and declarations ------------------------------------------------------------------------- *) (** {2 Top-level declarations} *) (** Represents the different types of subprogram bodies. *) type subprogram_body = | SB_ASL of stmt (** A normal body of a subprogram *) | SB_Primitive of bool (** Whether or not this primitive is side-effecting *) type func = { name : identifier; parameters : (identifier * ty option) list; args : typed_identifier list; body : subprogram_body; return_type : ty option; subprogram_type : subprogram_type; recurse_limit : expr option; builtin : bool; (** Builtin functions are treated specially when checking parameters at call sites - see [Typing.insert_stdlib_param]. *) } (** Function types in the AST. For the moment, they represent getters, setters, functions, procedures and primitives. *) (** Declaration keyword for global storage elements. *) type global_decl_keyword = GDK_Constant | GDK_Config | GDK_Let | GDK_Var type global_decl = { keyword : global_decl_keyword; name : identifier; ty : ty option; initial_value : expr option; } (** Global declaration type *) (** Declarations, ie. top level statement in a asl file. *) type decl_desc = | D_Func of func | D_GlobalStorage of global_decl | D_TypeDecl of identifier * ty * (identifier * field list) option | D_Pragma of identifier * expr list (** A global pragma, as an explicit node to be used by tools which need AST level hints. *) type decl = decl_desc annotated type t = decl list (** Main AST type. *) herd-herdtools7-1ca343e/asllib/ASTUtils.ml000066400000000000000000001026101475314470400204120ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) open AST let list_iterated_op ~empty op = let rec pairwise acc = function | [] -> acc | [ x ] -> x :: acc | x :: y :: t -> pairwise (op x y :: acc) t and iter = function | [] -> empty | [ x ] -> x | li -> pairwise [] li |> iter in iter module ISet = struct include Set.Make (String) let of_option = function None -> empty | Some s -> singleton s let pp_print f t = let open Format in let pp_comma f () = fprintf f ",@ " in fprintf f "@[{@,%a}@]" (pp_print_list ~pp_sep:pp_comma pp_print_string) (elements t) let unions = list_iterated_op ~empty union end module IMap = struct include Map.Make (String) let of_list li = List.fold_left (fun acc (key, value) -> add key value acc) empty li let pp_print pp_elt f t = let open Format in let pp_comma f () = fprintf f ",@ " in let pp_one f (name, v) = fprintf f "@[%s:@ @[%a@]@]" name pp_elt v in fprintf f "{@[@,%a@]}" (pp_print_list ~pp_sep:pp_comma pp_one) (bindings t) end let dummy_pos = Lexing.dummy_pos let default_version = V1 let desc v = v.desc let annotated desc pos_start pos_end version = { desc; pos_start; pos_end; version } let add_dummy_annotation ?(version = default_version) desc = annotated desc dummy_pos dummy_pos version let dummy_annotated = add_dummy_annotation () let to_pos pos = { pos with desc = () } let add_pos_from_st pos desc = if pos.desc == desc then pos else { pos with desc } let add_pos_from pos desc = { pos with desc } let map_desc f thing = f thing |> add_pos_from thing let map_desc_st' thing f = f thing.desc |> add_pos_from thing let add_pos_from_pos_of ((fname, lnum, cnum, enum), desc) = let open Lexing in let common = { pos_fname = fname; pos_lnum = lnum; pos_bol = 0; pos_cnum = 0 } in { desc; pos_start = { common with pos_cnum = cnum }; pos_end = { common with pos_cnum = enum }; version = default_version (* used only in testing *); } let list_equal equal li1 li2 = li1 == li2 || (List.compare_lengths li1 li2 = 0 && List.for_all2 equal li1 li2) let rec list_compare cmp l1 l2 = (* List.compare available >= 4.12 *) match (l1, l2) with | [], [] -> 0 | [], _ :: _ -> -1 | _ :: _, [] -> 1 | a1 :: l1, a2 :: l2 -> let c = cmp a1 a2 in if c <> 0 then c else list_compare cmp l1 l2 (* Straight out of stdlib v4.11 *) let list_fold_left_map f accu l = let rec aux accu l_accu = function | [] -> (accu, List.rev l_accu) | x :: l -> let accu, x = f accu x in aux accu (x :: l_accu) l in aux accu [] l let list_fold_lefti f accu l = List.fold_left (fun (i, accu) elt -> (i + 1, f i accu elt)) (0, accu) l |> snd let list_coalesce_right f l = List.fold_right (fun e acc -> match acc with | [] -> [ e ] | acc_head :: acc_tail -> ( match f e acc_head with | Some coalesced -> coalesced :: acc_tail | None -> e :: acc)) l [] (* Straight out of stdlib v4.10 *) let list_concat_map f l = let open List in let rec aux f acc = function | [] -> rev acc | x :: l -> let xs = f x in aux f (rev_append xs acc) l in aux f [] l let list_take = let rec aux acc n li = match (li, n) with | [], _ | _, 0 -> List.rev acc | h :: t, n -> aux (h :: acc) (n - 1) t in fun n li -> if n < 0 then raise (Invalid_argument "list_take"); aux [] n li (** [list_take_while pred li] is the longest prefix of [li] where all items satisfy [pred]. *) let list_take_while = let rec aux pred accu = function | [] -> List.rev accu | x :: xs -> if pred x then aux pred (x :: accu) xs else List.rev accu in fun pred li -> aux pred [] li let uniq l = List.fold_left (fun acc x -> if List.mem x acc then acc else x :: acc) [] l |> List.rev let rec list_split3 = function | [] -> ([], [], []) | (x, y, z) :: l -> let xs, ys, zs = list_split3 l in (x :: xs, y :: ys, z :: zs) let rec list_map_split f = function | [] -> ([], []) | [ a ] -> let x, y = f a in ([ x ], [ y ]) | a1 :: a2 :: l -> let x1, y1 = f a1 in let x2, y2 = f a2 in let xs, ys = list_map_split f l in (x1 :: x2 :: xs, y1 :: y2 :: ys) let get_first_duplicate li = let rec scan_for_dup = function | [] | [ _ ] -> None | x :: y :: rest -> if String.equal x y then Some x else scan_for_dup (y :: rest) in let sorted = List.sort String.compare li in scan_for_dup sorted let list_is_empty = function [] -> true | _ -> false let pair x y = (x, y) let pair' y x = (x, y) let pair_equal f g (x1, y1) (x2, y2) = f x1 x2 && g y1 y2 let map2_desc f thing1 thing2 = { desc = f thing1 thing2; pos_start = thing1.pos_start; pos_end = thing2.pos_end; version = thing1.version; } let s_pass = add_dummy_annotation S_Pass let s_then = map2_desc (fun s1 s2 -> S_Seq (s1, s2)) let boolean = T_Bool |> add_dummy_annotation let integer' = T_Int UnConstrained let integer = integer' |> add_dummy_annotation let integer_exact' e = T_Int (WellConstrained [ Constraint_Exact e ]) let integer_exact e = integer_exact' e |> add_dummy_annotation let string = T_String |> add_dummy_annotation let real = T_Real |> add_dummy_annotation let stmt_from_list : stmt list -> stmt = let is_not_s_pass = function { desc = S_Pass; _ } -> false | _ -> true in let rec one_step acc = function | [] -> List.rev acc | [ x ] -> List.rev (x :: acc) | s1 :: s2 :: t -> one_step (s_then s1 s2 :: acc) t in let rec aux = function | [] -> s_pass | [ x ] -> x | l -> aux @@ one_step [] l in fun l -> List.filter is_not_s_pass l |> aux let mask_from_set_bits_positions size pos = let buf = Bytes.make size '0' in let set i = Bytes.set buf i '1' in let () = List.iter set pos in Bytes.to_string buf let inv_mask = let one_char = function '0' -> '1' | '1' -> '0' | c -> c in String.map one_char let slices_to_positions as_int = let one_slice (start, length) = let start = as_int start and length = as_int length in (* Reversed interval - recall that bitvectors are reversed. *) if length >= 0 then List.init length (( - ) (start + length - 1)) else raise (Invalid_argument "slices_to_positions") in fun positions -> List.map one_slice positions |> List.flatten let fold_named_list folder acc list = List.fold_left (fun acc (_, v) -> folder acc v) acc list let ( $ ) f1 f2 acc = f1 acc |> f2 let use_option use_elt = function None -> Fun.id | Some elt -> use_elt elt let use_list use_elt elts acc = List.fold_left (Fun.flip use_elt) acc elts let use_named_list use_elt named_elts acc = fold_named_list (Fun.flip use_elt) acc named_elts let rec use_e e = match e.desc with | E_Literal _ -> Fun.id | E_ATC (e, ty) -> use_ty ty $ use_e e | E_Var x -> ISet.add x | E_GetArray (e1, e2) | E_GetEnumArray (e1, e2) | E_Binop (_, e1, e2) -> use_e e1 $ use_e e2 | E_Unop (_op, e) -> use_e e | E_Call { name; args; params } -> ISet.add name $ use_es params $ use_es args | E_Slice (e, slices) -> use_e e $ use_slices slices | E_Cond (e1, e2, e3) -> use_e e1 $ use_e e2 $ use_e e3 | E_GetItem (e, _) -> use_e e | E_GetField (e, _) -> use_e e | E_GetFields (e, _) -> use_e e | E_Record (ty, li) -> use_ty ty $ use_fields li | E_Tuple es -> use_es es | E_Array { length; value } -> use_e length $ use_e value | E_EnumArray { labels; value } -> use_list ISet.add labels $ use_e value | E_Arbitrary t -> use_ty t | E_Pattern (e, p) -> use_e e $ use_pattern p and use_es es acc = use_list use_e es acc and use_fields fields acc = use_named_list use_e fields acc and use_pattern p = match p.desc with | Pattern_Mask _ | Pattern_All -> Fun.id | Pattern_Tuple li | Pattern_Any li -> use_list use_pattern li | Pattern_Single e | Pattern_Geq e | Pattern_Leq e -> use_e e | Pattern_Not p -> use_pattern p | Pattern_Range (e1, e2) -> use_e e1 $ use_e e2 and use_slice = function | Slice_Single e -> use_e e | Slice_Star (e1, e2) | Slice_Length (e1, e2) | Slice_Range (e1, e2) -> use_e e1 $ use_e e2 and use_slices slices = use_list use_slice slices (** [use_ty t s] adds the identifiers that appear in [t] to the set of identifiers [s] *) and use_ty t = match t.desc with | T_Named s -> ISet.add s | T_Int (UnConstrained | Parameterized _ | PendingConstrained) | T_Enum _ | T_Bool | T_Real | T_String -> Fun.id | T_Int (WellConstrained cs) -> use_constraints cs | T_Tuple li -> use_list use_ty li | T_Record fields | T_Exception fields -> use_named_list use_ty fields | T_Array (ArrayLength_Expr e, t') -> use_e e $ use_ty t' | T_Array (ArrayLength_Enum (s, _), t') -> ISet.add s $ use_ty t' | T_Bits (e, bit_fields) -> use_e e $ use_bitfields bit_fields and use_bitfields bitfields = use_list use_bitfield bitfields and use_bitfield = function | BitField_Simple (_name, slices) -> use_slices slices | BitField_Nested (_name, slices, bitfields) -> use_bitfields bitfields $ use_slices slices | BitField_Type (_name, slices, ty) -> use_ty ty $ use_slices slices and use_constraint = function | Constraint_Exact e -> use_e e | Constraint_Range (e1, e2) -> use_e e1 $ use_e e2 and use_constraints cs = use_list use_constraint cs let rec use_s s = match s.desc with | S_Pass | S_Return None -> Fun.id | S_Seq (s1, s2) -> use_s s1 $ use_s s2 | S_Assert e | S_Return (Some e) -> use_e e | S_Assign (le, e) -> use_e e $ use_le le | S_Call { name; args; params } -> ISet.add name $ use_es params $ use_es args | S_Cond (e, s1, s2) -> use_s s1 $ use_s s2 $ use_e e | S_For { start_e; end_e; body; index_name = _; dir = _; limit } -> use_option use_e limit $ use_e start_e $ use_e end_e $ use_s body | S_While (e, limit, s) | S_Repeat (s, e, limit) -> use_option use_e limit $ use_s s $ use_e e | S_Decl (_, _, ty, e) -> use_option use_e e $ use_option use_ty ty | S_Throw (Some (e, _)) -> use_e e | S_Throw None -> Fun.id | S_Try (s, catchers, s') -> use_s s $ use_option use_s s' $ use_catchers catchers | S_Print { args; debug = _ } -> use_es args | S_Pragma (name, args) -> ISet.add name $ use_es args | S_Unreachable -> Fun.id and use_le le = match le.desc with | LE_Var x -> ISet.add x | LE_Destructuring les -> List.fold_right use_le les | LE_Discard -> Fun.id | LE_SetArray (le, e) | LE_SetEnumArray (le, e) -> use_le le $ use_e e | LE_SetField (le, _) | LE_SetFields (le, _, _) -> use_le le | LE_Slice (le, slices) -> use_slices slices $ use_le le and use_catcher (_name, ty, s) = use_s s $ use_ty ty and use_catchers catchers = use_list use_catcher catchers and use_decl d = match d.desc with | D_TypeDecl (_name, ty, fields) -> use_ty ty $ use_option use_subtypes fields | D_GlobalStorage { initial_value; ty; name = _; keyword = _ } -> use_option use_e initial_value $ use_option use_ty ty | D_Func { body; name = _; args; return_type; parameters; subprogram_type = _ } -> ( use_named_list use_ty args $ use_option use_ty return_type $ use_named_list (use_option use_ty) parameters $ match body with SB_ASL s -> use_s s | SB_Primitive _ -> Fun.id) | D_Pragma (name, args) -> ISet.add name $ use_es args and use_subtypes (x, subfields) = ISet.add x $ use_named_list use_ty subfields let used_identifiers ast = use_list use_decl ast ISet.empty let used_identifiers_stmt s = use_s s ISet.empty let canonical_fields li = let compare (x, _) (y, _) = String.compare x y in List.sort compare li let literal_equal v1 v2 = v1 == v2 || match (v1, v2) with | L_Bool b1, L_Bool b2 -> b1 = b2 | L_Bool _, _ -> false | L_Int i1, L_Int i2 -> i1 = i2 | L_Int _, _ -> false | L_Real f1, L_Real f2 -> f1 = f2 | L_Real _, _ -> false | L_BitVector bv1, L_BitVector bv2 -> Bitvector.equal bv1 bv2 | L_BitVector _, _ -> false | L_String s1, L_String s2 -> String.equal s1 s2 | L_String _, _ -> false | L_Label l1, L_Label l2 -> String.equal l1 l2 | L_Label _, _ -> false let rec expr_equal eq e1 e2 = e1 == e2 || eq e1 e2 || match (e1.desc, e2.desc) with | E_Binop (o1, e11, e21), E_Binop (o2, e12, e22) -> o1 = o2 && expr_equal eq e11 e12 && expr_equal eq e21 e22 | E_Binop _, _ | _, E_Binop _ -> false | ( E_Call { name = x1; params = params1; args = args1 }, E_Call { name = x2; params = params2; args = args2 } ) -> if e1.version = V0 then (* We can ignore parameters as they are deduced from arguments. *) String.equal x1 x2 && list_equal (expr_equal eq) args1 args2 else String.equal x1 x2 && list_equal (expr_equal eq) params1 params2 && list_equal (expr_equal eq) args1 args2 | E_Call _, _ | _, E_Call _ -> false | E_Cond (e11, e21, e31), E_Cond (e12, e22, e32) -> expr_equal eq e11 e12 && expr_equal eq e21 e22 && expr_equal eq e31 e32 | E_Cond _, _ | _, E_Cond _ -> false | E_Slice (e1, slices1), E_Slice (e2, slices2) -> expr_equal eq e1 e2 && slices_equal eq slices1 slices2 | E_Slice _, _ | _, E_Slice _ -> false | E_GetArray (e11, e21), E_GetArray (e12, e22) -> expr_equal eq e11 e12 && expr_equal eq e21 e22 | E_GetArray _, _ | _, E_GetArray _ -> false | E_GetEnumArray (e11, e21), E_GetEnumArray (e12, e22) -> expr_equal eq e11 e12 && expr_equal eq e21 e22 | E_GetEnumArray _, _ | _, E_GetEnumArray _ -> false | E_GetField (e1', f1), E_GetField (e2', f2) -> String.equal f1 f2 && expr_equal eq e1' e2' | E_GetField _, _ | _, E_GetField _ -> false | E_GetFields (e1', f1s), E_GetFields (e2', f2s) -> list_equal String.equal f1s f2s && expr_equal eq e1' e2' | E_GetFields _, _ | _, E_GetFields _ -> false | E_GetItem (e1', i1), E_GetItem (e2', i2) -> Int.equal i1 i2 && expr_equal eq e1' e2' | E_GetItem _, _ | _, E_GetItem _ -> false | E_Pattern _, _ | E_Record _, _ -> assert false | E_Literal v1, E_Literal v2 -> literal_equal v1 v2 | E_Literal _, _ | _, E_Literal _ -> false | E_Tuple li1, E_Tuple li2 -> list_equal (expr_equal eq) li1 li2 | E_Tuple _, _ | _, E_Tuple _ -> false | E_Array { length = l1; value = v1 }, E_Array { length = l2; value = v2 } -> expr_equal eq l1 l2 && expr_equal eq v1 v2 | E_Array _, _ | _, E_Array _ -> false | ( E_EnumArray { labels = l1; value = v1 }, E_EnumArray { labels = l2; value = v2 } ) -> list_equal String.equal l1 l2 && expr_equal eq v1 v2 | E_EnumArray _, _ | _, E_EnumArray _ -> false | E_ATC (e1, t1), E_ATC (e2, t2) -> expr_equal eq e1 e2 && type_equal eq t1 t2 | E_ATC _, _ | _, E_ATC _ -> false | E_Unop (o1, e1), E_Unop (o2, e2) -> o1 = o2 && expr_equal eq e1 e2 | E_Unop _, _ | _, E_Unop _ -> false | E_Arbitrary _, _ | _, E_Arbitrary _ -> false | E_Var s1, E_Var s2 -> String.equal s1 s2 | E_Var _, _ (* | _, E_Var _ *) -> false and slices_equal eq slices1 slices2 = list_equal (slice_equal eq) slices1 slices2 and slice_equal eq slice1 slice2 = slice1 == slice2 || match (slice1, slice2) with | Slice_Single e1, Slice_Single e2 -> expr_equal eq e1 e2 | Slice_Range (e11, e21), Slice_Range (e12, e22) | Slice_Length (e11, e21), Slice_Length (e12, e22) -> expr_equal eq e11 e12 && expr_equal eq e21 e22 | _ -> false and constraint_equal eq c1 c2 = c1 == c2 || match (c1, c2) with | Constraint_Exact e1, Constraint_Exact e2 -> expr_equal eq e1 e2 | Constraint_Range (e11, e21), Constraint_Range (e12, e22) -> expr_equal eq e11 e12 && expr_equal eq e21 e22 | _ -> false and constraints_equal eq cs1 cs2 = cs1 == cs2 || list_equal (constraint_equal eq) cs1 cs2 and array_length_equal eq l1 l2 = match (l1, l2) with | ArrayLength_Expr e1, ArrayLength_Expr e2 -> expr_equal eq e1 e2 | ArrayLength_Enum (enum1, _), ArrayLength_Enum (enum2, _) -> String.equal enum1 enum2 | ArrayLength_Enum (_, _), ArrayLength_Expr _ | ArrayLength_Expr _, ArrayLength_Enum (_, _) -> false and type_equal eq t1 t2 = t1.desc == t2.desc || match (t1.desc, t2.desc) with | T_Bool, T_Bool | T_Real, T_Real | T_String, T_String | T_Int UnConstrained, T_Int UnConstrained -> true | T_Int (Parameterized (i1, _)), T_Int (Parameterized (i2, _)) -> i1 == i2 | T_Int (WellConstrained c1), T_Int (WellConstrained c2) -> constraints_equal eq c1 c2 | T_Bits (w1, bf1), T_Bits (w2, bf2) -> bitwidth_equal eq w1 w2 && bitfields_equal eq bf1 bf2 | T_Array (l1, t1), T_Array (l2, t2) -> array_length_equal eq l1 l2 && type_equal eq t1 t2 | T_Named s1, T_Named s2 -> String.equal s1 s2 | T_Enum li1, T_Enum li2 -> (* TODO: order of fields? *) list_equal String.equal li1 li2 | T_Exception f1, T_Exception f2 | T_Record f1, T_Record f2 -> list_equal (pair_equal String.equal (type_equal eq)) (canonical_fields f1) (canonical_fields f2) | T_Tuple ts1, T_Tuple ts2 -> list_equal (type_equal eq) ts1 ts2 | _ -> false and bitwidth_equal eq w1 w2 = expr_equal eq w1 w2 and bitfields_equal eq bf1 bf2 = bf1 == bf2 || (list_equal (bitfield_equal eq)) bf1 bf2 and bitfield_equal eq bf1 bf2 = bf1 == bf2 || match (bf1, bf2) with | BitField_Simple (name1, slices1), BitField_Simple (name2, slices2) -> String.equal name1 name2 && slices_equal eq slices1 slices2 | ( BitField_Nested (name1, slices1, bf1'), BitField_Nested (name2, slices2, bf2') ) -> String.equal name1 name2 && slices_equal eq slices1 slices2 && bitfields_equal eq bf1' bf2' | BitField_Type (name1, slices1, t1), BitField_Type (name2, slices2, t2) -> String.equal name1 name2 && slices_equal eq slices1 slices2 && type_equal eq t1 t2 | BitField_Simple _, BitField_Nested _ | BitField_Simple _, BitField_Type _ | BitField_Nested _, BitField_Simple _ | BitField_Nested _, BitField_Type _ | BitField_Type _, BitField_Nested _ | BitField_Type _, BitField_Simple _ -> false let var_ x = E_Var x |> add_dummy_annotation let binop op = map2_desc (fun e1 e2 -> E_Binop (op, e1, e2)) let unop op = map_desc (fun e -> E_Unop (op, e)) let literal v = E_Literal v |> add_dummy_annotation let expr_of_int i = literal (L_Int (Z.of_int i)) let expr_of_z z = literal (L_Int z) let zero_expr = expr_of_z Z.zero let one_expr = expr_of_z Z.one let minus_one_expr = expr_of_z Z.minus_one let expr_of_rational q = if Z.equal (Q.den q) Z.one then expr_of_z (Q.num q) else binop DIV (expr_of_z (Q.num q)) (expr_of_z (Q.den q)) let mul_expr e1 e2 = if expr_equal (fun _ _ -> false) e1 one_expr then e2 else if expr_equal (fun _ _ -> false) e2 one_expr then e1 else binop MUL e1 e2 let pow_expr e = function | 0 -> one_expr | 1 -> e | 2 -> mul_expr e e | p -> binop POW e (expr_of_int p) let div_expr e z = if Z.equal z Z.one then e else binop DIV e (expr_of_z z) let add_expr e1 (s, e2) = if s = 0 then e1 else if s > 0 then binop PLUS e1 e2 else binop MINUS e1 e2 let conj_expr e1 e2 = let lit_true = literal (L_Bool true) in if expr_equal (fun _ _ -> false) e1 lit_true then e2 else if expr_equal (fun _ _ -> false) e2 lit_true then e1 else binop BAND e1 e2 let cond_expr e1 e2 e3 = E_Cond (e1, e2, e3) |> add_pos_from dummy_annotated module Infix = struct let ( ~$ ) i = L_Int (Z.of_int i) let ( !$ ) i = expr_of_int i end let fresh_var = let i = ref 0 in fun s -> let () = incr i in s ^ "-" ^ string_of_int !i let ldi_of_lexpr = let tr_tuple_var le = match le.desc with LE_Var x -> x | _ -> raise Exit in let tr le = match le.desc with | LE_Discard -> LDI_Var (fresh_var "__ldi_discard") | LE_Var x -> LDI_Var x | LE_Destructuring les -> LDI_Tuple (List.map tr_tuple_var les) | _ -> raise Exit in fun le -> try Some (tr le) with Exit -> None let expr_of_lexpr : lexpr -> expr = let rec aux le = match le.desc with | LE_Var x -> E_Var x | LE_Slice (le, args) -> E_Slice (map_desc aux le, args) | LE_SetArray (le, e) -> E_GetArray (map_desc aux le, e) | LE_SetEnumArray (le, e) -> E_GetEnumArray (map_desc aux le, e) | LE_SetField (le, x) -> E_GetField (map_desc aux le, x) | LE_SetFields (le, x, _) -> E_GetFields (map_desc aux le, x) | LE_Discard -> E_Var "-" | LE_Destructuring les -> E_Tuple (List.map (map_desc aux) les) in map_desc aux (* Straight out of stdlib 4.12 *) let string_starts_with ~prefix s = let open String in let len_s = length s and len_pre = length prefix in let rec aux i = if i = len_pre then true else if unsafe_get s i <> unsafe_get prefix i then false else aux (i + 1) in len_s >= len_pre && aux 0 let global_ignored_prefix = "__global_ignored" let global_ignored () = fresh_var global_ignored_prefix let is_global_ignored s = string_starts_with ~prefix:global_ignored_prefix s let slice_is_single = function Slice_Single _ -> true | _ -> false let slice_as_single = function | Slice_Single e -> e | _ -> raise @@ Invalid_argument "slice_as_single" let default_t_bits = T_Bits (E_Var "-" |> add_dummy_annotation, []) let default_array_ty = let len = ArrayLength_Expr (E_Var "-" |> add_dummy_annotation) in let ty = T_Named "-" |> add_dummy_annotation in T_Array (len, ty) let identifier_of_decl d = match d.desc with | D_Func { name; _ } | D_GlobalStorage { name; _ } | D_TypeDecl (name, _, _) -> name | D_Pragma _ -> assert false let patch ~src ~patches = (* Size considerations: - [src] is BIG. - [patches] is not that little. *) let to_remove = patches |> List.to_seq |> Seq.map identifier_of_decl |> ISet.of_seq in let filter d = not (ISet.mem (identifier_of_decl d) to_remove) in src |> List.filter filter |> List.rev_append patches let list_cross f li1 li2 = List.fold_left (fun xys x -> List.fold_left (fun xys' y -> f x y :: xys') xys li2) [] li1 |> List.rev let list_flat_cross f li1 li2 = List.fold_left (fun xys x -> List.fold_left (fun xys' y -> List.rev_append (f x y) xys') xys li2) [] li1 |> List.rev (* Begin SubstExpr *) let rec subst_expr substs e = (* WARNING: only subst runtime vars. *) let tr e = subst_expr substs e in add_pos_from_st e @@ match e.desc with | E_Var s -> ( match List.assoc_opt s substs with None -> e.desc | Some e' -> e'.desc) | E_Binop (op, e1, e2) -> E_Binop (op, tr e1, tr e2) | E_Cond (e1, e2, e3) -> E_Cond (tr e1, tr e2, tr e3) | E_Call { name; args; params; call_type } -> E_Call { name; args = List.map tr args; params = List.map tr params; call_type; } | E_GetArray (e1, e2) -> E_GetArray (tr e1, tr e2) | E_GetEnumArray (e1, e2) -> E_GetEnumArray (tr e1, tr e2) | E_GetField (e, x) -> E_GetField (tr e, x) | E_GetFields (e, fields) -> E_GetFields (tr e, fields) | E_GetItem (e, i) -> E_GetItem (tr e, i) | E_Literal _ -> e.desc | E_Pattern (e, ps) -> E_Pattern (tr e, ps) | E_Record (t, fields) -> E_Record (t, List.map (fun (x, e) -> (x, tr e)) fields) | E_Slice (e, slices) -> E_Slice (tr e, slices) | E_Tuple es -> E_Tuple (List.map tr es) | E_Array { length; value } -> E_Array { length = tr length; value = tr value } | E_EnumArray { enum; labels; value } -> E_EnumArray { enum; labels; value = tr value } | E_ATC (e, t) -> E_ATC (tr e, t) | E_Arbitrary _ -> e.desc | E_Unop (op, e) -> E_Unop (op, tr e) (* End *) let rec is_simple_expr e = match e.desc with | E_Var _ | E_Literal _ | E_Arbitrary _ -> true | E_Array { length = e1; value = e2 } | E_GetArray (e1, e2) | E_GetEnumArray (e1, e2) | E_Binop (_, e1, e2) -> is_simple_expr e1 && is_simple_expr e2 | E_EnumArray { value = e } | E_ATC (e, _) | E_GetFields (e, _) | E_GetField (e, _) | E_GetItem (e, _) | E_Unop (_, e) | E_Pattern (e, _) (* because pattern must be side-effect free. *) -> is_simple_expr e | E_Tuple es -> List.for_all is_simple_expr es | E_Cond (e1, e2, e3) -> is_simple_expr e1 && is_simple_expr e2 && is_simple_expr e3 | E_Slice (e, slices) -> is_simple_expr e && List.for_all is_simple_slice slices | E_Record (_, fields) -> List.for_all (fun (_name, e) -> is_simple_expr e) fields | E_Call _ -> false and is_simple_slice = function | Slice_Length (e1, e2) | Slice_Range (e1, e2) | Slice_Star (e1, e2) -> is_simple_expr e1 && is_simple_expr e2 | Slice_Single e -> is_simple_expr e let bitfield_get_name = function | BitField_Simple (name, _) | BitField_Nested (name, _, _) | BitField_Type (name, _, _) -> name let bitfield_get_slices = function | BitField_Simple (_, slices) | BitField_Nested (_, slices, _) | BitField_Type (_, slices, _) -> slices let bitfield_get_nested = function | BitField_Simple _ | BitField_Type _ -> [] | BitField_Nested (_, _, nested_fields) -> nested_fields let has_name name bf = bitfield_get_name bf |> String.equal name (* Begin FindBitfieldOpt *) let find_bitfield_opt name bitfields = List.find_opt (has_name name) bitfields (* End *) (* Begin FindBitFieldsSlices *) let find_bitfields_slices_opt name bitfields = try List.find (has_name name) bitfields |> bitfield_get_slices |> Option.some with Not_found -> None (* End *) let rename_locals map_name ast = (* Begin RenameLocalsExpr *) let rec map_e e = map_desc_st' e @@ function | E_Literal _ -> e.desc | E_Arbitrary t -> E_Arbitrary (map_t t) | E_Var x -> E_Var (map_name x) | E_ATC (e1, t) -> E_ATC (map_e e1, map_t t) | E_Binop (op, e1, e2) -> E_Binop (op, map_e e1, map_e e2) | E_Unop (op, e1) -> E_Unop (op, map_e e1) | E_Call { name; args; params; call_type } -> E_Call { name; args = map_es args; params = map_es params; call_type } | E_Slice (e1, slices) -> E_Slice (map_e e1, map_slices slices) | E_Cond (e1, e2, e3) -> E_Cond (map_e e1, map_e e2, map_e e3) | E_GetArray (e1, e2) -> E_GetArray (map_e e1, map_e e2) | E_GetEnumArray (e1, e2) -> E_GetEnumArray (map_e e1, map_e e2) | E_GetField (e1, f) -> E_GetField (map_e e1, f) | E_GetFields (e1, li) -> E_GetFields (map_e e1, li) | E_GetItem (e1, i) -> E_GetItem (map_e e1, i) | E_Record (t, li) -> E_Record (t, List.map (fun (f, e) -> (f, map_e e)) li) | E_Tuple li -> E_Tuple (map_es li) | E_Array { length; value } -> E_Array { length = map_e length; value = map_e value } | E_EnumArray { enum; labels; value } -> E_EnumArray { enum; labels; value = map_e value } | E_Pattern (_, _) -> failwith "Not yet implemented: obfuscate patterns" (* End *) and map_es li = List.map map_e li and map_slices slices = List.map map_slice slices (* Begin RenameLocalsSlice *) and map_slice = function | Slice_Length (e1, e2) -> Slice_Length (map_e e1, map_e e2) | Slice_Single e -> Slice_Single (map_e e) | Slice_Range (e1, e2) -> Slice_Range (map_e e1, map_e e2) | Slice_Star (e1, e2) -> Slice_Star (map_e e1, map_e e2) (* End *) (* Begin RenameLocalsType *) and map_t t = map_desc_st' t @@ function | T_Real | T_String | T_Bool | T_Enum _ | T_Named _ | T_Int (UnConstrained | PendingConstrained) -> t.desc | T_Int (Parameterized _) -> failwith "Not yet implemented: obfuscate parametrized types" | T_Int (WellConstrained cs) -> T_Int (WellConstrained (map_cs cs)) | T_Bits (e, bitfields) -> T_Bits (map_e e, bitfields) | T_Tuple li -> T_Tuple (List.map map_t li) | T_Array (_, _) -> failwith "Not yet implemented: obfuscate array types" | T_Record li -> T_Record (List.map (fun (f, t) -> (f, map_t t)) li) | T_Exception li -> T_Exception (List.map (fun (f, t) -> (f, map_t t)) li) (* End *) and map_cs cs = List.map map_c cs (* Begin RenameLocalsConstraint *) and map_c = function | Constraint_Exact e -> Constraint_Exact (map_e e) | Constraint_Range (e1, e2) -> Constraint_Range (map_e e1, map_e e2) (* End *) (* Begin RenameLocalsStmt *) and map_s s = map_desc_st' s @@ function | S_Pass -> s.desc | S_Seq (s1, s2) -> S_Seq (map_s s1, map_s s2) | S_Decl (ldk, ldi, ty, e) -> S_Decl (ldk, map_ldi ldi, Option.map map_t ty, Option.map map_e e) | S_Assign (le, e) -> S_Assign (map_le le, map_e e) | S_Call { name; args; params; call_type } -> S_Call { name; args = map_es args; params = map_es params; call_type } | S_Return e -> S_Return (Option.map map_e e) | S_Cond (e, s1, s2) -> S_Cond (map_e e, map_s s1, map_s s2) | S_Assert e -> S_Assert (map_e e) | S_For { index_name; start_e; dir; end_e; body; limit } -> let index_name = map_name index_name and start_e = map_e start_e and end_e = map_e end_e and limit = Option.map map_e limit and body = map_s body in S_For { index_name; start_e; dir; end_e; body; limit } | S_While (e, limit, body) -> S_While (map_e e, Option.map map_e limit, map_s body) | S_Repeat (s, e, limit) -> S_Repeat (map_s s, map_e e, Option.map map_e limit) | S_Throw (Some (e, t)) -> S_Throw (Some (map_e e, Option.map map_t t)) | S_Throw None -> s.desc | S_Try (_, _, _) -> failwith "Not yet implemented: obfuscate try" | S_Print { args; newline; debug } -> S_Print { args = List.map map_e args; newline; debug } | S_Unreachable -> S_Unreachable | S_Pragma (name, args) -> let args = map_es args in S_Pragma (name, args) (* End *) (* Begin RenameLocalsLexpr *) and map_le le = map_desc_st' le @@ function | LE_Discard -> le.desc | LE_Var x -> LE_Var (map_name x) | LE_Slice (le1, slices) -> LE_Slice (map_le le1, map_slices slices) | LE_SetArray (le1, i) -> LE_SetArray (map_le le1, map_e i) | LE_SetEnumArray (le, i) -> LE_SetEnumArray (map_le le, map_e i) | LE_SetField (le1, f) -> LE_SetField (map_le le1, f) | LE_SetFields (le1, fl, annot) -> LE_SetFields (map_le le1, fl, annot) | LE_Destructuring les -> LE_Destructuring (List.map map_le les) (* End *) (* Begin RenameLocalsLDI *) and map_ldi = function | LDI_Var x -> LDI_Var (map_name x) | LDI_Tuple names -> LDI_Tuple (List.map map_name names) (* End *) and map_body = function | SB_Primitive _ as b -> b | SB_ASL s -> SB_ASL (map_s s) (* Begin RenameLocalsFunc *) and map_func f = (* RenameLocalsArgs( *) let map_args li = List.map (fun (name, t) -> (map_name name, map_t t)) li in (* RenameLocalsArgs) *) (* RenameLocalsNamedArgs( *) let map_nargs li = List.map (fun (name, t) -> (map_name name, Option.map map_t t)) li (* RenameLocalsNamedArgs) *) in { f with parameters = map_nargs f.parameters; args = map_args f.args; body = map_body f.body; return_type = Option.map map_t f.return_type; } (* End *) (* Begin RenameLocals *) and map_decl d = map_desc_st' d @@ function D_Func f -> D_Func (map_func f) | d -> d in List.map map_decl ast (* End *) (* Taken from lib/innerRel.ml *) let rec transitive_closure m0 = let m1 = IMap.fold (fun x ys m -> let zs = ISet.fold (fun y k -> try IMap.find y m :: k with Not_found -> k) ys [] in IMap.add x (ISet.unions zs) m) m0 m0 in if IMap.equal ISet.equal m0 m1 then m0 else transitive_closure m1 let get_cycle m = (* Depth first search for a cycle. [m] is the graph represented as a Map from a node to its successors; [seen] is the set of already seen nodes; [path] is the set of nodes along the branch currently taken, with the parent of the current node just on top, the starting point of the algorithm being the lowest on the stack; [above] is the set of nodes in path; When a cycle is found, the exception [Cycle] is used for early return. *) let exception Cycle of identifier list in let rec dfs path above e seen = if ISet.mem e above then let cycle = e :: list_take_while (fun e' -> not (String.equal e e')) path in raise (Cycle cycle) else if ISet.mem e seen then seen else let path' = e :: path and above' = ISet.add e above and seen' = ISet.add e seen and succs = try IMap.find e m with Not_found -> ISet.empty in ISet.fold (dfs path' above') succs seen' in try let above0 = ISet.empty and seen0 = ISet.empty and path0 = [] in let _ = IMap.fold (fun x _ -> dfs path0 above0 x) m seen0 in None with Cycle e -> Some (List.rev e) herd-herdtools7-1ca343e/asllib/ASTUtils.mli000066400000000000000000000330401475314470400205630ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) (** This module provides some tools to work on ASL ASTs. *) open AST (** {1 Identifiers utils} *) (*------------------------*) (** An extended [identifier] set. *) module ISet : sig include Set.S with type elt = identifier val unions : t list -> t (** Iterated union. *) val of_option : identifier option -> t val pp_print : Format.formatter -> t -> unit end (** An extended [identifier] map. *) module IMap : sig include Map.S with type key = identifier val of_list : (key * 'a) list -> 'a t val pp_print : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit end (** {1 Position utils} *) (*---------------------*) val dummy_pos : Lexing.position (** A dummy position. *) val default_version : version (** The default version, [V1]. *) val annotated : 'a -> position -> position -> version -> 'a annotated (** [annotated v start end version] is [v] with location specified as from [start] to [end] and version specified by [version]. *) val desc : 'a annotated -> 'a (** [desc v] is [v.desc] *) val add_dummy_annotation : ?version:version -> 'a -> 'a annotated (** Add a dummy annotation to a value. The default version is [default_version]. *) val dummy_annotated : unit annotated (** A dummy annotation *) val to_pos : 'a annotated -> unit annotated (** Removes the value from an annotated record. *) val add_pos_from_pos_of : (string * int * int * int) * 'a -> 'a annotated (** [add_pos_from_pos_of (__POS_OF__ e)] is [annotated s s' e] where [s] and [s'] correspond to [e]'s position in the ocaml file. *) val add_pos_from : 'a annotated -> 'b -> 'b annotated (** [add_pos_from loc v] is [v] with the location data from [loc]. *) val add_pos_from_st : 'a annotated -> 'a -> 'a annotated (** [add_pos_from_st a' a] is [a] with the location from [a']. If both arguments are physically equal, then the result is also physically equal. *) val map2_desc : ('a annotated -> 'b annotated -> 'c) -> 'a annotated -> 'b annotated -> 'c annotated (** Folder on two annotated types. *) (** {1 Type utils} *) (*-----------------*) val integer : ty (** The ASL unconstrained integer type. *) val integer' : type_desc (** [integer], without the position annotation. *) val integer_exact : expr -> ty (** [integer_exact e] is the integer type constrained to be equal to [e]. *) val integer_exact' : expr -> type_desc (** [integer_exact' e] is [integer_exact e] without the position annotation. *) val boolean : ty (** The ASL boolean type. *) val string : ty (** The ASL string type. *) val real : ty (** The ASL real type. *) val default_t_bits : type_desc val default_array_ty : type_desc (** {1 Constructor helpers} *) (*--------------------------*) val s_pass : stmt (** An ASL pass statement. *) val s_then : stmt -> stmt -> stmt (** [s_then s1 s2] is [s1; s2] in ASL. *) val stmt_from_list : stmt list -> stmt (** [stmt_from_list [s1; ... sn]] is [s1; ... sn] in ASL. *) val expr_of_int : int -> expr (** [expr_of_int i] is the literal expression containing [i]. *) val literal : literal -> expr (** [literal v] is the expression evaluated to [v]. *) val var_ : identifier -> expr (** [var_ x] is the expression [x]. *) val binop : binop -> expr -> expr -> expr (** Builds a binary operation from to subexpressions. *) val unop : unop -> expr -> expr (** Builds a unary operation from its subexpression. *) val expr_of_z : Z.t -> expr (** [expr_of_z z] is the integer literal for [z]. *) val zero_expr : expr (** The integer literal for [0]. *) val one_expr : expr (** The integer literal for [1]. *) val minus_one_expr : expr (** The integer literal for [-1]. *) val expr_of_rational : Q.t -> expr (** [expr_of_rational q] is the rational literal for [q]. *) val mul_expr : expr -> expr -> expr (** [mul_expr e1 e2] is an expression representing [e1 * e2]. *) val pow_expr : expr -> int -> expr (** [pow_expr e i] is an expression representing [e ^ i]. *) val div_expr : expr -> Z.t -> expr (** [div_expr e z] is an expression representing [e DIV z]. *) val add_expr : expr -> int * expr -> expr (** [add_expr e1 (s, e2)] is an expression representing [e1 + sign(s) * e2]. [e2] is expected to be non-negative. *) val conj_expr : expr -> expr -> expr (** [conj_expr e1 e2] is an expression representing [e1 && e2]. *) val cond_expr : expr -> expr -> expr -> expr (** [cond_expr e e1 e2] is an expression representing [if e then e1 else e2]. *) val fresh_var : string -> identifier (** [fresh_var "doc"] is a fresh variable whose name begins with "doc". *) val global_ignored : unit -> identifier (** Creates a fresh dummy variable for a global ignored variable. *) val string_starts_with : prefix:string -> string -> bool (** A copy of String.starts_with out of stdlib 4.12 *) val is_global_ignored : identifier -> bool (** [is_global_ignored s] is true iff [s] has been created with [global_ignored ()]. *) (** {1 Fields, masks and slices handling} *) val mask_from_set_bits_positions : int -> int list -> string (** Builds a mask from specified positions. *) val inv_mask : string -> string (** Flip all the 0/1 in the mask. Doesn't change the 'x'. *) val slices_to_positions : ('a -> int) -> ('a * 'a) list -> int list (** [slices_to_positions as_int slices] evaluates [slices] and returns a list of all queried positions in the correct order. *) val canonical_fields : (string * 'a) list -> (string * 'a) list (** Sorts the fields of a record to allow an element wise comparison. *) val bitfield_get_name : bitfield -> string (** Returns the name of the bitfield in question. *) val bitfield_get_slices : bitfield -> slice list (** Returns the slices corresponding to this bitfield. *) val bitfield_get_nested : bitfield -> bitfield list (** Returns the list of bitfields listed in the given bitfield and an empty list if it is not a nested bitfield. *) val find_bitfield_opt : string -> bitfield list -> bitfield option (** [bitfield_find_opt name bfs] is [Some (bf)] if there exists [bf] in [bfs] with [name], [None] otherwise. *) val find_bitfields_slices_opt : string -> bitfield list -> slice list option (** [bitfields_find_slices_opt name bfs] is [Some (slices)] if there exists a bitfield with name [name] and slices [slices]. *) module Infix : sig (** Infix utils. *) val ( ~$ ) : int -> literal (** [~$i] is an integer literal that contains [i]. *) val ( !$ ) : int -> expr (** An alias for [expr_of_int]. *) end (** {1 Equality helpers} Most of those take a [cmp_expr] argument that is the static analyser expression comparison. *) val expr_equal : (expr -> expr -> bool) -> expr -> expr -> bool val literal_equal : literal -> literal -> bool val slice_equal : (expr -> expr -> bool) -> slice -> slice -> bool val slices_equal : (expr -> expr -> bool) -> slice list -> slice list -> bool val constraint_equal : (expr -> expr -> bool) -> int_constraint -> int_constraint -> bool val constraints_equal : (expr -> expr -> bool) -> int_constraint list -> int_constraint list -> bool val type_equal : (expr -> expr -> bool) -> ty -> ty -> bool val array_length_equal : (expr -> expr -> bool) -> array_index -> array_index -> bool val bitfield_equal : (expr -> expr -> bool) -> bitfield -> bitfield -> bool val bitwidth_equal : (expr -> expr -> bool) -> expr -> expr -> bool (** {1 Transformers} *) val ldi_of_lexpr : lexpr -> local_decl_item option val expr_of_lexpr : lexpr -> expr val slice_is_single : slice -> bool val slice_as_single : slice -> expr val patch : src:AST.t -> patches:AST.t -> AST.t (** [patch ~src ~patches] replaces in [src] the global identifiers defined by [patches]. *) val subst_expr : (identifier * expr) list -> expr -> expr (** [subst_expr substs e] replaces the variables used inside [e] by their associated expression in [substs], if any. Warning: constants and statically-evaluated parts are not changed, for example: [E_Slice (E_Var "y", [Slice_Single (E_Var "y")])] will become after [subst_expr [("y", E_Var "x")]]: [E_Slice (E_Var "x", [Slice_Single (E_Var "y")])] *) val rename_locals : (identifier -> identifier) -> AST.t -> AST.t (** [rename_locals f ast] is [ast] where all instances of variables [x] are replaced with [f x]. *) val is_simple_expr : expr -> bool (** [is_simple_expr e] is true if [e] does not contain any call to any other subprogram. It has false negative. *) (** {1 Def/use analysis} *) val use_e : expr -> ISet.t -> ISet.t val use_ty : ty -> ISet.t -> ISet.t val use_decl : decl -> ISet.t -> ISet.t (** [use_decl d] is the set of other declared names required to have in the environment to be able to type-check d. *) val used_identifiers : decl list -> ISet.t val used_identifiers_stmt : stmt -> ISet.t val identifier_of_decl : decl -> identifier (** [identifier_of_decl d] is the name of the global element defined by [d]. *) (** {1 Standard functions} *) val pair : 'a -> 'b -> 'a * 'b (** [pair a b] is [(a, b)]. *) val pair' : 'b -> 'a -> 'a * 'b (** [pair' b a] is [(b, a)]. *) val list_equal : ('a -> 'a -> bool) -> 'a list -> 'a list -> bool (** [list_equal elt_equal li1 li2] is true iff [li1] and [li2] are element-wise equal. *) val list_compare : ('a -> 'a -> int) -> 'a list -> 'a list -> int (** An element wise comparaison for lists. *) val list_cross : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list (** [list_cross f [a1; ... an] [b1; ... bm]] is the list of all [f ai bj] in a non-specified order. *) val list_take : int -> 'a list -> 'a list (** [list_take n li] is the list of the first [n] elements of [li]. If [li] has less than [n] elements, [list_take n li] is [li]. *) val list_flat_cross : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list (** [list_flat_cross f [a1; ... an] [b1; ... bm]] is the concatenation of all [f ai bj] in a non-specified order. *) val list_concat_map : ('a -> 'b list) -> 'a list -> 'b list (** [list_concat_map f l] gives the same result as [List.concat (List.map f l)]. Tail-recursive. Taken from stdlib 4.10. *) val list_fold_lefti : (int -> 'acc -> 'a -> 'acc) -> 'acc -> 'a list -> 'acc (** Same as [List.fold_left] but takes a index. *) val list_fold_left_map : ('acc -> 'a -> 'acc * 'b) -> 'acc -> 'a list -> 'acc * 'b list (** [fold_left_map] is a combination of [fold_left] and [map] that threads an accumulator through calls to [f]. Taken from stdlib 4.11. *) val list_coalesce_right : ('a -> 'a -> 'a option) -> 'a list -> 'a list (** [list_coalesce_right f l] applies the coalescing function [f] to adjacent elements of [l], using it to folding [l] in a right-to-left order. @param [f] is a function that, given two elements, either coalesces them into a single element or returns [None], signalling that the elements cannot be coalesced. *) val uniq : 'a list -> 'a list (** [uniq l] returns the unique elements of [l], in the order they appear *) val get_first_duplicate : identifier list -> identifier option (** [get_first_duplicate ids] returns [None] if all identifiers in [ids] are unique, otherwise it returns [Some id] where [id] is the first duplicate. *) val list_is_empty : 'a list -> bool (** [list_is_empty li] is [true] iff [li] is empty, [false] otherwise. *) val list_split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list (** Generalisation of [List.split] for 3-uples. *) val list_map_split : ('a -> 'b * 'c) -> 'a list -> 'b list * 'c list (** Composition of [List.map] and [List.split]. *) val list_iterated_op : empty:'a -> ('a -> 'a -> 'a) -> 'a list -> 'a (** [list_iterated_op ~empty op li] computes the iterated binary operation [op] on the elements of [li], with the assumption that [op] is associative. If the list [li], this function returns [empty]. This considers that applying [op] to 2 elements is longer than iterating on the list, in particular that the complexity of [op a b] depends on the size of [a] and [b], and the size of [op a b] increases with the size of [a] and the size of [b]. *) val transitive_closure : ISet.t IMap.t -> ISet.t IMap.t (** Returns the transitive closure of the graph. *) val get_cycle : ISet.t IMap.t -> identifier list option (** [get_cycle m] is [None] if the graph whose transition function is given by [m] is acyclic, [Some li] if [li] is a cycle in [m]. *) herd-herdtools7-1ca343e/asllib/Interpreter.ml000066400000000000000000001574731475314470400212660ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) open AST open ASTUtils let fatal_from pos = Error.fatal_from pos (* A bit more informative than assert false *) let _warn = false let _dbg = false let rec subtypes_names env s1 s2 = if String.equal s1 s2 then true else match IMap.find_opt s1 StaticEnv.(env.global.subtypes) with | None -> false | Some s1' -> subtypes_names env s1' s2 let subtypes env t1 t2 = match (t1.desc, t2.desc) with | T_Named s1, T_Named s2 -> subtypes_names env s1 s2 | _ -> false module type S = sig module B : Backend.S module IEnv : Env.S with type v = B.value and module Scope = B.Scope type value_read_from = B.value * AST.identifier * B.Scope.t type 'a maybe_exception = | Normal of 'a | Throwing of (value_read_from * AST.ty) option * IEnv.env val eval_expr : IEnv.env -> AST.expr -> (B.value * IEnv.env) maybe_exception B.m val run_typed_env : (AST.identifier * B.value) list -> StaticEnv.global -> AST.t -> B.value B.m val run_typed : StaticEnv.global -> AST.t -> B.value B.m end module type Config = sig module Instr : Instrumentation.SEMINSTR val unroll : int val error_handling_time : Error.error_handling_time end module Make (B : Backend.S) (C : Config) = struct module B = B module SemanticsRule = Instrumentation.SemanticsRule type 'a m = 'a B.m module EnvConf = struct module Scope = B.Scope type v = B.value let unroll = C.unroll end module IEnv = Env.RunTime (EnvConf) type env = IEnv.env type value_read_from = B.value * identifier * B.Scope.t type 'a maybe_exception = | Normal of 'a | Throwing of (value_read_from * ty) option * env (** An intermediate result of a statement. *) type control_flow_state = | Returning of B.value list * IEnv.global (** Control flow interruption: skip to the end of the function. *) | Continuing of env (** Normal behaviour: pass to next statement. *) type expr_eval_type = (B.value * env) maybe_exception m type stmt_eval_type = control_flow_state maybe_exception m type func_eval_type = (value_read_from list * IEnv.global) maybe_exception m let unsupported_expr e = fatal_from e Error.(UnsupportedExpr (C.error_handling_time, e)) (*****************************************************************************) (* *) (* Monadic operators *) (* *) (*****************************************************************************) let one = B.v_of_int 1 let true' = E_Literal (L_Bool true) |> add_dummy_annotation let false' = E_Literal (L_Bool false) |> add_dummy_annotation (* Return *) (* ------ *) let return = B.return let return_normal v = Normal v |> return let return_continue env : stmt_eval_type = Continuing env |> return_normal let return_return env vs : stmt_eval_type = Returning (vs, env.IEnv.global) |> return_normal (* Bind *) (* ---- *) (* Sequential bind *) let ( let*| ) = B.bind_seq (* Data bind *) let ( let* ) = B.bind_data let ( >>= ) = B.bind_data (* Control bind *) let ( let*= ) = B.bind_ctrl let ( >>*= ) = B.bind_ctrl (* Choice *) let choice m v1 v2 = B.choice m (return v1) (return v2) (* * Choice with inserted branching (commit) effect/ * [choice_with_branching_effect_msg m_cond msg v1 v2 kont]: * [m_cond], evaluates to boolean condition, * [msg], message to decorate the branching event, * [v1 v2] alternative for choice. * [kont] contitinuation, takes choosed [v1] or [v2] as * input . *) let choice_with_branch_effect_msg m_cond msg v1 v2 kont = choice m_cond v1 v2 >>= fun v -> B.commit (Some msg) >>*= fun () -> kont v let choice_with_branch_effect m_cond e_cond v1 v2 kont = let pp_cond = Format.asprintf "%a@?" PP.pp_expr e_cond in choice_with_branch_effect_msg m_cond pp_cond v1 v2 kont (* Exceptions *) let bind_exception binder m f = binder m (function Normal v -> f v | Throwing _ as res -> return res) let bind_exception_seq m f = bind_exception B.bind_seq m f let ( let**| ) = bind_exception_seq let bind_exception_data m f = bind_exception B.bind_data m f let ( let** ) = bind_exception_data (* Continue *) (* [bind_continue m f] executes [f] on [m] only if [m] is [Normal (Continuing _)] *) let bind_continue (m : stmt_eval_type) f : stmt_eval_type = bind_exception_seq m @@ function | Continuing env -> f env | Returning _ as res -> return_normal res let ( let*> ) = bind_continue (* Unroll *) (* [bind_unroll "while" m f] executes [f] on [m] after having ticked the unrolling stack of [m] only if [m] is [Normal (Continuing _)] *) let bind_unroll (loop_name, loop_pos) (m : stmt_eval_type) f : stmt_eval_type = bind_continue m @@ fun env -> let stop, env' = IEnv.tick_decr env in if stop then let msg = Printf.sprintf "%s at %s pruned" loop_name (PP.pp_pos_str_no_char loop_pos) in B.cutoffT msg env >>= return_continue else f env' let bind_maybe_unroll loop_name undet = if undet then bind_unroll loop_name else bind_continue (* To give name to rules *) let ( |: ) = C.Instr.use_with (* Product parallel *) (* ---------------- *) let ( and* ) = B.prod_par (* Application *) (* ----------- *) let ( >=> ) m f = B.appl_data m f (*****************************************************************************) (* *) (* Environments *) (* *) (*****************************************************************************) (* Global env *) (* ---------- *) let eval_global_decl env0 eval_expr d env_m = let*| env = env_m in match d.desc with | D_GlobalStorage { initial_value; name; _ } -> ( let scope = B.Scope.global ~init:true in match IMap.find_opt name env0 with | Some v -> IEnv.declare_global name v env |> return | None -> let init_expr = match initial_value with | Some e -> e | None -> fatal_from d TypeInferenceNeeded in let* eval_res = eval_expr env init_expr in let v, env2 = match eval_res with | Normal (v, env2) -> (v, env2) | Throwing (exc, _env2) -> let ty = match exc with | Some (_, ty) -> ty | None -> T_Named "implicit" |> add_pos_from d in fatal_from d (UnexpectedInitialisationThrow (ty, name)) in let* () = B.on_write_identifier name scope v in let env3 = IEnv.declare_global name v env2 in return env3) | _ -> return env (* Begin EvalBuildGlobalEnv *) (** [build_genv penv static_env ast primitives] is the global environment before the start of the evaluation of [ast], with predefined values in [penv]. *) let build_genv env0 eval_expr (static_env : StaticEnv.global) (ast : AST.t) = let () = if _dbg then Format.eprintf "@[Executing in env:@ %a@.]" StaticEnv.pp_global static_env in let env0 = IMap.of_list env0 in let global_decl_folder = function | TopoSort.ASTFold.Single d -> eval_global_decl env0 eval_expr d | TopoSort.ASTFold.Recursive ds -> List.fold_right (eval_global_decl env0 eval_expr) ds in let env = let open IEnv in let global = global_from_static static_env and local = local_empty_scoped (B.Scope.global ~init:true) in { global; local } in let*| env = TopoSort.ASTFold.fold global_decl_folder ast (return env) in return env.global |: SemanticsRule.BuildGlobalEnv (* End *) (* Bind Environment *) (* ---------------- *) let discard_exception m = B.bind_data m @@ function | Normal v -> return v | Throwing _ -> assert false let bind_env m f = B.delay m @@ fun res m -> match res with | Normal (_v, env) -> f (discard_exception m >=> fst, env) | Throwing _ as res -> (* Do not discard [m], otherwise events are lost *) m >>= fun _ -> return res let ( let*^ ) = bind_env (* Primitives handling *) (* ------------------- *) let primitive_runtimes = List.to_seq B.primitives |> Seq.map AST.(fun ({ name; subprogram_type = _; _ }, f) -> (name, f)) |> Hashtbl.of_seq let primitive_decls = List.map (fun (f, _) -> D_Func f |> add_dummy_annotation) B.primitives let () = if false then Format.eprintf "@[Primitives:@ %a@]@." PP.pp_t primitive_decls (*****************************************************************************) (* *) (* Evaluation functions *) (* *) (*****************************************************************************) (* Utils *) (* ----- *) let v_false = L_Bool false |> B.v_of_literal let v_true = L_Bool true |> B.v_of_literal let m_false = return v_false let m_true = return v_true let v_to_int ~loc v = match B.v_to_z v with | Some z when Z.fits_int z -> Z.to_int z | Some z -> Printf.eprintf "Overflow in asllib: cannot convert back to 63-bit integer the \ integer %a.\n\ %!" Z.output z; unsupported_expr loc | None -> fatal_from loc (MismatchType (B.debug_value v, [ integer' ])) let sync_list ms = let folder m vsm = let* v = m and* vs = vsm in return (v :: vs) in List.fold_right folder ms (return []) let fold_par2 fold1 fold2 acc e1 e2 = let*^ m1, acc = fold1 acc e1 in let*^ m2, acc = fold2 acc e2 in let* v1 = m1 and* v2 = m2 in return_normal ((v1, v2), acc) let rec fold_par_list fold acc es = match es with | [] -> return_normal ([], acc) | e :: es -> let** (v, vs), acc = fold_par2 fold (fold_par_list fold) acc e es in return_normal (v :: vs, acc) let rec fold_parm_list fold acc es = match es with | [] -> return_normal ([], acc) | e :: es -> let*^ m, acc = fold acc e in let** ms, acc = fold_parm_list fold acc es in return_normal (m :: ms, acc) let lexpr_is_var le = match le.desc with LE_Var _ | LE_Discard -> true | _ -> false let declare_local_identifier env name v = let* () = B.on_write_identifier name (IEnv.get_scope env) v in IEnv.declare_local name v env |> return let declare_local_identifier_m env x m = m >>= declare_local_identifier env x let declare_local_identifier_mm envm x m = let*| env = envm in declare_local_identifier_m env x m let assign_local_identifier env x v = let* () = B.on_write_identifier x (IEnv.get_scope env) v in IEnv.assign_local x v env |> return let return_identifier i = "return-" ^ string_of_int i let throw_identifier () = fresh_var "thrown" (* Begin EvalReadValueFrom *) let read_value_from ((v, name, scope) : value_read_from) = let* () = B.on_read_identifier name scope v in return v |: SemanticsRule.ReadValueFrom (* End *) let big_op default op = let folder m_acc m = let* acc = m_acc and* v = m in op acc v in function [] -> default | x :: li -> List.fold_left folder x li (** [check_non_overlapping_slices slices value_ranges] checks that the slice ranges [value_ranges] are non-overlapping. [value_ranges] are given by a list of couples [(start, length)]. If they are overlapping, an error [OverlappingSlices (slices, Dynamic)] is thrown. *) let check_non_overlapping_slices slices value_ranges = let check_two_ranges_are_non_overlapping (s1, l1) m (s2, l2) = let* () = m in let cond = let* s1l1s2 = let* s1l1 = B.binop PLUS s1 l1 in B.binop LEQ s1l1 s2 and* s2l2s1 = let* s2l2 = B.binop PLUS s2 l2 in B.binop LEQ s2l2 s1 in B.binop BOR s1l1s2 s2l2s1 in let* b = choice cond true false in if b then return () else Error.( fatal_unknown_pos (OverlappingSlices (slices, C.error_handling_time))) in let check_range_does_not_overlap_previous_ranges past_ranges range = let* past_ranges = past_ranges in let* () = List.fold_left (check_two_ranges_are_non_overlapping range) (return ()) past_ranges in return (range :: past_ranges) in let* _ = List.fold_left check_range_does_not_overlap_previous_ranges (return []) value_ranges in return () (* Evaluation of Expressions *) (* ------------------------- *) (** [eval_expr] specifies how to evaluate an expression [e] in an environment [env]. More precisely, [eval_expr env e] is the monadic evaluation of [e] in [env]. *) let rec eval_expr (env : env) (e : expr) : expr_eval_type = if false then Format.eprintf "@[<3>Eval@ @[%a@]@]@." PP.pp_expr e; match e.desc with (* Begin EvalELit *) | E_Literal l -> return_normal (B.v_of_literal l, env) |: SemanticsRule.ELit (* End *) (* Begin EvalATC *) | E_ATC (e1, t) -> let** v, new_env = eval_expr env e1 in let* b = is_val_of_type e1 env v t in (if b then return_normal (v, new_env) else fatal_from e1 (Error.MismatchType (B.debug_value v, [ t.desc ]))) |: SemanticsRule.ATC (* End *) (* Begin EvalEVar *) | E_Var x -> (match IEnv.find x env with | Local v -> let* () = B.on_read_identifier x (IEnv.get_scope env) v in return_normal (v, env) | Global v -> let* () = B.on_read_identifier x (B.Scope.global ~init:false) v in return_normal (v, env) | NotFound -> fatal_from e @@ Error.UndefinedIdentifier x) |: SemanticsRule.EVar (* End *) | E_Binop (((BAND | BOR | IMPL) as op), e1, e2) when is_simple_expr e1 && is_simple_expr e2 -> let*= v1 = eval_expr_sef env e1 in if B.is_undetermined v1 then let* v2 = eval_expr_sef env e2 in let* v = B.binop op v1 v2 in return_normal (v, env) else (* This is equivalent to the non-optimised case, but we can't use the syntactic sugar trick used in the following cases as we can't reconstruct an expression from a value. *) let eval_e2 () = eval_expr_sef env e2 in let ret_true () = m_true and ret_false () = m_false in let on_true, on_false = match op with | BAND -> (eval_e2, ret_false) | BOR -> (ret_true, eval_e2) | IMPL -> (eval_e2, ret_true) | _ -> assert false in let* v = B.ternary v1 on_true on_false in return_normal (v, env) (* Begin EvalBinopAnd *) | E_Binop (BAND, e1, e2) -> (* if e1 then e2 else false *) E_Cond (e1, e2, false') |> add_pos_from e |> eval_expr env |: SemanticsRule.BinopAnd (* End *) (* Begin EvalBinopOr *) | E_Binop (BOR, e1, e2) -> (* if e1 then true else e2 *) E_Cond (e1, true', e2) |> add_pos_from e |> eval_expr env |: SemanticsRule.BinopOr (* End *) (* Begin EvalBinopImpl *) | E_Binop (IMPL, e1, e2) -> (* if e1 then e2 else true *) E_Cond (e1, e2, true') |> add_pos_from e |> eval_expr env |: SemanticsRule.BinopImpl (* End *) (* Begin EvalBinop *) | E_Binop (op, e1, e2) -> let*^ m1, env1 = eval_expr env e1 in let*^ m2, new_env = eval_expr env1 e2 in let* v1 = m1 and* v2 = m2 in let* v = B.binop op v1 v2 in return_normal (v, new_env) |: SemanticsRule.Binop (* End *) (* Begin EvalUnop *) | E_Unop (op, e1) -> let** v1, env1 = eval_expr env e1 in let* v = B.unop op v1 in return_normal (v, env1) |: SemanticsRule.Unop (* End *) (* Begin EvalECond *) | E_Cond (e_cond, e1, e2) -> let*^ m_cond, env1 = eval_expr env e_cond in if is_simple_expr e1 && is_simple_expr e2 then let*= v_cond = m_cond in let* v = (* The calls to [eval_expr_sef] are safe because [is_simple_expr] implies [is_pure]. *) B.ternary v_cond (fun () -> eval_expr_sef env1 e1) (fun () -> eval_expr_sef env1 e2) in return_normal (v, env) |: SemanticsRule.ECondSimple else choice_with_branch_effect m_cond e_cond e1 e2 (eval_expr env1) |: SemanticsRule.ECond (* End *) (* Begin EvalESlice *) | E_Slice (e_bv, slices) -> let*^ m_bv, env1 = eval_expr env e_bv in let*^ m_positions, new_env = eval_slices env1 slices in let* v_bv = m_bv and* positions = m_positions in let* v = B.read_from_bitvector positions v_bv in return_normal (v, new_env) |: SemanticsRule.ESlice (* End *) (* Begin EvalECall *) | E_Call { name; params; args } -> (* pass [params] and [args] as labelled arguments to avoid confusion *) let**| ms, new_env = eval_call (to_pos e) name env ~params ~args in let* v = match ms with | [ m ] -> m | _ -> let* vs = sync_list ms in B.create_vector vs in return_normal (v, new_env) |: SemanticsRule.ECall (* End *) (* Begin EvalEGetArray *) | E_GetArray (e_array, e_index) -> let*^ m_array, env1 = eval_expr env e_array in let*^ m_index, new_env = eval_expr env1 e_index in let* v_array = m_array and* v_index = m_index in let i_index = v_to_int ~loc:e v_index in let* v = B.get_index i_index v_array in return_normal (v, new_env) |: SemanticsRule.EGetArray (* End *) (* Begin EvalEGetEnumArray *) | E_GetEnumArray (e_array, e_index) -> let*^ m_array, env1 = eval_expr env e_array in let*^ m_index, new_env = eval_expr env1 e_index in let* v_array = m_array and* v_index = m_index in (* an enumerated array is represented by a record value. *) let label = B.v_to_label v_index in let* v = B.get_field label v_array in return_normal (v, new_env) |: SemanticsRule.EGetEnumArray (* End *) (* Begin EvalEGetTupleItem *) | E_GetItem (e_tuple, index) -> let** v_tuple, new_env = eval_expr env e_tuple in let* v = B.get_index index v_tuple in return_normal (v, new_env) |: SemanticsRule.EGetTupleItem (* End *) (* Begin EvalERecord *) | E_Record (_, e_fields) -> let names, fields = List.split e_fields in let** v_fields, new_env = eval_expr_list env fields in let* v = B.create_record (List.combine names v_fields) in return_normal (v, new_env) |: SemanticsRule.ERecord (* End *) (* Begin EvalEGetField *) | E_GetField (e_record, field_name) -> let** v_record, new_env = eval_expr env e_record in let* v = B.get_field field_name v_record in return_normal (v, new_env) |: SemanticsRule.EGetBitField (* End *) (* Begin EvalEGetFields *) | E_GetFields (e_record, field_names) -> let** v_record, new_env = eval_expr env e_record in let* v_list = List.map (fun field_name -> B.get_field field_name v_record) field_names |> sync_list in let* v = B.concat_bitvectors v_list in return_normal (v, new_env) (* End *) (* Begin EvalETuple *) | E_Tuple e_list -> let** v_list, new_env = eval_expr_list env e_list in let* v = B.create_vector v_list in return_normal (v, new_env) |: SemanticsRule.ETuple (* End *) (* Begin EvalEArray *) | E_Array { length = e_length; value = e_value } -> let** v_value, new_env = eval_expr env e_value in (* The call to [eval_expr_sef] is safe because Typing.annotate_type checks that all expressions on which a type depends are statically evaluable, i.e. side-effect-free. *) let* v_length = eval_expr_sef env e_length in let n_length = v_to_int ~loc:e v_length in let* v = B.create_vector (List.init n_length (Fun.const v_value)) in return_normal (v, new_env) |: SemanticsRule.EArray (* End *) (* Begin EvalEEnumArray *) | E_EnumArray { labels; value = e_value } -> let** v_value, new_env = eval_expr env e_value in let field_inits = List.map (fun l -> (l, v_value)) labels in let* v = B.create_record field_inits in return_normal (v, new_env) |: SemanticsRule.EEnumArray (* End *) (* Begin EvalEArbitrary *) | E_Arbitrary t -> (* The call to [eval_expr_sef] is safe because Typing.annotate_type checks that all expressions on which a type depends are statically evaluable, i.e. side-effect-free. *) let* v = B.v_unknown_of_type ~eval_expr_sef:(eval_expr_sef env) t in return_normal (v, env) |: SemanticsRule.EArbitrary (* End *) (* Begin EvalEPattern *) | E_Pattern (e, p) -> let** v1, new_env = eval_expr env e in let* v = eval_pattern env e v1 p in return_normal (v, new_env) |: SemanticsRule.EPattern (* End *) (* Evaluation of Side-Effect-Free Expressions *) (* ------------------------------------------ *) (** [eval_expr_sef] specifies how to evaluate a side-effect-free expression [e] in an environment [env]. More precisely, [eval_expr_sef env e] is the [eval_expr env e], if e is side-effect-free. *) (* Begin EvalESideEffectFreeExpr *) and eval_expr_sef env e : B.value m = eval_expr env e >>= function | Normal (v, _env) -> return v | Throwing (None, _) -> let msg = Format.asprintf "@[An exception was@ thrown@ when@ evaluating@ %a@]@." PP.pp_expr e in fatal_from e (Error.UnexpectedSideEffect msg) | Throwing (Some (_, ty), _) -> let msg = Format.asprintf "@[An exception of type @[%a@]@ was@ thrown@ when@ \ evaluating@ %a@]@." PP.pp_ty ty PP.pp_expr e in fatal_from e (Error.UnexpectedSideEffect msg) (* End *) (* Runtime checks *) (* -------------- *) (* Begin EvalValOfType *) and is_val_of_type loc env v ty : bool B.m = let big_or = big_op m_false (B.binop BOR) in let rec in_values v ty = match ty.desc with | T_Int UnConstrained -> m_true | T_Int (Parameterized _) -> (* This cannot happen, because: 1. Forgetting now about named types, or any kind of compound types, you cannot ask: [expr as ty] if ty is the unconstrained integer because there is no syntax for it. 2. You cannot construct a type that is an alias for the parameterized integer type. 3. You cannot put the parameterized integer type in a compound type. *) fatal_from loc Error.UnrespectedParserInvariant | T_Bits (e, _) -> (* The call to [eval_expr_sef] is justified since annotate_type checks that all expressions on which a type depends are statically evaluable, i.e. side-effect-free. *) let* v' = eval_expr_sef env e and* v_length = B.bitvector_length v in B.binop EQ_OP v_length v' | T_Int (WellConstrained constraints) -> (* The calls to [eval_expr_sef] are justified since annotate_type checks that all expressions on which a type depends are statically evaluable, i.e., side-effect-free. *) let is_constraint_sat = function | Constraint_Exact e -> let* v' = eval_expr_sef env e in B.binop EQ_OP v v' |: SemanticsRule.IsConstraintSat | Constraint_Range (e1, e2) -> let* v1 = eval_expr_sef env e1 and* v2 = eval_expr_sef env e2 in let* c1 = B.binop LEQ v1 v and* c2 = B.binop LEQ v v2 in B.binop BAND c1 c2 |: SemanticsRule.IsConstraintSat in List.map is_constraint_sat constraints |> big_or | T_Tuple tys -> let fold (i, prev) ty' = let m = let* v' = B.get_index i v in let* here = in_values v' ty' in prev >>= B.binop BAND here in (i + 1, m) in List.fold_left fold (0, m_true) tys |> snd | _ -> fatal_from loc TypeInferenceNeeded in choice (in_values v ty) true false (* End *) (* Evaluation of Left-Hand-Side Expressions *) (* ---------------------------------------- *) (** [eval_lexpr version env le m] is [env[le --> m]]. *) and eval_lexpr ver le env m : env maybe_exception B.m = match le.desc with (* Begin EvalLEDiscard *) | LE_Discard -> return_normal env |: SemanticsRule.LEDiscard (* End *) | LE_Var x -> ( let* v = m in match IEnv.assign x v env with (* Begin EvalLEVar *) | Local env -> let* () = B.on_write_identifier x (IEnv.get_scope env) v in return_normal env |: SemanticsRule.LEVar | Global env -> let* () = B.on_write_identifier x (B.Scope.global ~init:false) v in return_normal env |: SemanticsRule.LEVar (* End *) | NotFound -> ( match ver with (* Begin EvalLEUndefIdentOne *) | V1 -> fatal_from le @@ Error.UndefinedIdentifier x |: SemanticsRule.LEUndefIdentV1 (* End *) (* Begin EvalLEUndefIdentZero *) | V0 -> (* V0 first assignments promoted to local declarations *) declare_local_identifier env x v >>= return_normal |: SemanticsRule.LEUndefIdentV0)) (* End *) (* Begin EvalLESlice *) | LE_Slice (e_bv, slices) -> let*^ m_bv, env1 = expr_of_lexpr e_bv |> eval_expr env in let*^ m_slice_ranges, env2 = eval_slices env1 slices in let new_m_bv = let* v = m and* slice_ranges = m_slice_ranges and* v_bv = m_bv in let* () = check_non_overlapping_slices slices slice_ranges in B.write_to_bitvector slice_ranges v v_bv in eval_lexpr ver e_bv env2 new_m_bv |: SemanticsRule.LESlice (* End *) (* Begin EvalLESetArray *) | LE_SetArray (re_array, e_index) -> let*^ rm_array, env1 = expr_of_lexpr re_array |> eval_expr env in let*^ m_index, env2 = eval_expr env1 e_index in let m1 = let* v = m and* v_index = m_index and* rv_array = rm_array in B.set_index (v_to_int ~loc:e_index v_index) v rv_array in eval_lexpr ver re_array env2 m1 |: SemanticsRule.LESetArray (* End *) (* Begin EvalLESetEnumArray *) | LE_SetEnumArray (re_array, e_index) -> let*^ rm_array, env1 = expr_of_lexpr re_array |> eval_expr env in let*^ m_index, env2 = eval_expr env1 e_index in let m1 = let* v = m and* v_index = m_index and* rv_array = rm_array in (* an enumerated array is represented by a record value. *) let label = B.v_to_label v_index in B.set_field label v rv_array in eval_lexpr ver re_array env2 m1 |: SemanticsRule.LESetEnumArray (* End *) (* Begin EvalLESetField *) | LE_SetField (re_record, field_name) -> let*^ rm_record, env1 = expr_of_lexpr re_record |> eval_expr env in let m1 = let* v = m and* rv_record = rm_record in B.set_field field_name v rv_record in eval_lexpr ver re_record env1 m1 |: SemanticsRule.LESetField (* End *) (* Begin EvalLEDestructuring *) | LE_Destructuring le_list -> (* The index-out-of-bound on the vector are done either in typing, either in [B.get_index]. *) let n = List.length le_list in let nmonads = List.init n (fun i -> m >>= B.get_index i) in multi_assign ver env le_list nmonads |: SemanticsRule.LEDestructuring (* End *) (* Begin EvalLESetFields *) | LE_SetFields (le_record, fields, slices) -> let () = if List.compare_lengths fields slices != 0 then fatal_from le Error.TypeInferenceNeeded in let*^ rm_record, env1 = expr_of_lexpr le_record |> eval_expr env in (* AssignBitvectorFields( *) let m2 = List.fold_left2 (fun m1 field_name (i1, i2) -> let slice = [ (B.v_of_int i1, B.v_of_int i2) ] in let* v_record_slices = m >>= B.read_from_bitvector slice and* rv_record = m1 in B.set_field field_name v_record_slices rv_record) rm_record fields slices (* AssignBitvectorFields) *) in eval_lexpr ver le_record env1 m2 |: SemanticsRule.LESetFields (* End *) (* Evaluation of Expression Lists *) (* ------------------------------ *) (* Begin EvalEExprListM *) and eval_expr_list_m env es = fold_parm_list eval_expr env es |: SemanticsRule.EExprListM (* End *) (* Begin EvalEExprList *) and eval_expr_list env es = fold_par_list eval_expr env es |: SemanticsRule.EExprList (* End *) (* Evaluation of Slices *) (* -------------------- *) (** [eval_slices env slices] is the list of pair [(i_n, l_n)] that corresponds to the start (included) and the length of each slice in [slices]. *) and eval_slices env : slice list -> (B.value_range list * env) maybe_exception m = (* Begin EvalSlice *) let eval_slice env = function | Slice_Single e -> let** v_start, new_env = eval_expr env e in return_normal ((v_start, one), new_env) |: SemanticsRule.Slice | Slice_Length (e_start, e_length) -> let*^ m_start, env1 = eval_expr env e_start in let*^ m_length, new_env = eval_expr env1 e_length in let* v_start = m_start and* v_length = m_length in return_normal ((v_start, v_length), new_env) |: SemanticsRule.Slice | Slice_Range (e_top, e_start) -> let*^ m_top, env1 = eval_expr env e_top in let*^ m_start, new_env = eval_expr env1 e_start in let* v_top = m_top and* v_start = m_start in let* v_length = B.binop MINUS v_top v_start >>= B.binop PLUS one in return_normal ((v_start, v_length), new_env) |: SemanticsRule.Slice | Slice_Star (e_factor, e_length) -> let*^ m_factor, env1 = eval_expr env e_factor in let*^ m_length, new_env = eval_expr env1 e_length in let* v_factor = m_factor and* v_length = m_length in let* v_start = B.binop MUL v_factor v_length in return_normal ((v_start, v_length), new_env) |: SemanticsRule.Slice (* End *) in (* Begin EvalSlices *) fold_par_list eval_slice env |: SemanticsRule.Slices (* End *) (* Evaluation of Patterns *) (* ---------------------- *) (** [eval_pattern env pos v p] determines if [v] matches the pattern [p]. *) and eval_pattern env pos v : pattern -> B.value m = let true_ = B.v_of_literal (L_Bool true) |> return in let false_ = B.v_of_literal (L_Bool false) |> return in let disjunction = big_op false_ (B.binop BOR) and conjunction = big_op true_ (B.binop BAND) in (* The calls to [eval_expr_sef] are justified since annotate_pattern checks that all expressions on which a type depends are statically evaluable, i.e. side-effect-free. *) fun p -> match p.desc with (* Begin EvalPAll *) | Pattern_All -> true_ |: SemanticsRule.PAll (* End *) (* Begin EvalPAny *) | Pattern_Any ps -> let bs = List.map (eval_pattern env pos v) ps in disjunction bs |: SemanticsRule.PAny (* End *) (* Begin EvalPGeq *) | Pattern_Geq e -> let* v1 = eval_expr_sef env e in B.binop GEQ v v1 |: SemanticsRule.PGeq (* End *) (* Begin EvalPLeq *) | Pattern_Leq e -> let* v1 = eval_expr_sef env e in B.binop LEQ v v1 |: SemanticsRule.PLeq (* End *) (* Begin EvalPNot *) | Pattern_Not p1 -> let* b1 = eval_pattern env pos v p1 in B.unop BNOT b1 |: SemanticsRule.PNot (* End *) (* Begin EvalPRange *) | Pattern_Range (e1, e2) -> let* b1 = let* v1 = eval_expr_sef env e1 in B.binop GEQ v v1 and* b2 = let* v2 = eval_expr_sef env e2 in B.binop LEQ v v2 in B.binop BAND b1 b2 |: SemanticsRule.PRange (* End *) (* Begin EvalPSingle *) | Pattern_Single e -> let* v1 = eval_expr_sef env e in B.binop EQ_OP v v1 |: SemanticsRule.PSingle (* End *) (* Begin EvalPMask *) | Pattern_Mask m -> let bv bv = L_BitVector bv |> B.v_of_literal in let m_set = Bitvector.mask_set m and m_unset = Bitvector.mask_unset m in let m_specified = Bitvector.logor m_set m_unset in let* nv = B.unop NOT v in let* v_set = B.binop AND (bv m_set) v and* v_unset = B.binop AND (bv m_unset) nv in let* v_set_or_unset = B.binop OR v_set v_unset in B.binop EQ_OP v_set_or_unset (bv m_specified) |: SemanticsRule.PMask (* End *) (* Begin EvalPTuple *) | Pattern_Tuple ps -> let n = List.length ps in let* vs = List.init n (fun i -> B.get_index i v) |> sync_list in let bs = List.map2 (eval_pattern env pos) vs ps in conjunction bs |: SemanticsRule.PTuple (* End *) (* Evaluation of Local Declarations *) (* -------------------------------- *) and eval_local_decl ldi env m_init : env maybe_exception m = let () = if false then Format.eprintf "Evaluating %a.@." PP.pp_local_decl_item ldi in match ldi with (* Begin EvalLDVar *) | LDI_Var x -> m_init >>= declare_local_identifier env x >>= return_normal |: SemanticsRule.LDVar (* End *) (* Begin EvalLDTuple *) | LDI_Tuple ldis -> let n = List.length ldis in let* vm = m_init in let liv = List.init n (fun i -> B.return vm >>= B.get_index i) in let folder envm x vm = let**| env = envm in vm >>= declare_local_identifier env x >>= return_normal in List.fold_left2 folder (return_normal env) ldis liv |: SemanticsRule.LDTuple (* End *) (* Evaluation of Statements *) (* ------------------------ *) (** [eval_stmt env s] evaluates [s] in [env]. This is either an interruption [Returning vs] or a continuation [env], see [eval_res]. *) and eval_stmt (env : env) s : stmt_eval_type = (if false then match s.desc with | S_Seq _ -> () | _ -> Format.eprintf "@[<3>Eval@ @[%a@]@]@." PP.pp_stmt s); match s.desc with (* Begin EvalSPass *) | S_Pass -> return_continue env |: SemanticsRule.SPass (* End *) (* Begin EvalSAssignCall *) | S_Assign ( { desc = LE_Destructuring les; _ }, { desc = E_Call { name; params; args }; _ } ) when List.for_all lexpr_is_var les -> (* pass [params] and [args] as labelled arguments to avoid confusion *) let**| vms, env1 = eval_call (to_pos s) name env ~params ~args in let**| new_env = protected_multi_assign s.version env1 s les vms in return_continue new_env |: SemanticsRule.SAssignCall (* End *) (* Begin EvalSAssign *) | S_Assign (le, re) -> let*^ m, env1 = eval_expr env re in let**| new_env = eval_lexpr s.version le env1 m in return_continue new_env |: SemanticsRule.SAssign (* End *) (* Begin EvalSReturn *) | S_Return (Some { desc = E_Tuple es; _ }) -> let**| ms, new_env = eval_expr_list_m env es in let scope = IEnv.get_scope new_env in let folder acc m = let*| i, vs = acc in let* v = m in let* () = B.on_write_identifier (return_identifier i) scope v in return (i + 1, v :: vs) in let*| _i, vs = List.fold_left folder (return (0, [])) ms in return_return new_env (List.rev vs) |: SemanticsRule.SReturn | S_Return (Some e) -> let** v, env1 = eval_expr env e in let* () = B.on_write_identifier (return_identifier 0) (IEnv.get_scope env1) v in return_return env1 [ v ] |: SemanticsRule.SReturn | S_Return None -> return_return env [] |: SemanticsRule.SReturn (* End *) (* Begin EvalSSeq *) | S_Seq (s1, s2) -> let*> env1 = eval_stmt env s1 in eval_stmt env1 s2 |: SemanticsRule.SSeq (* End *) (* Begin EvalSCall *) | S_Call { name; params; args } -> (* pass [params] and [args] as labelled arguments to avoid confusion *) let**| returned, env' = eval_call (to_pos s) name env ~params ~args in let () = assert (returned = []) in return_continue env' |: SemanticsRule.SCall (* End *) (* Begin EvalSCond *) | S_Cond (e, s1, s2) -> let*^ v, env' = eval_expr env e in choice_with_branch_effect v e s1 s2 (eval_block env') |: SemanticsRule.SCond (* Begin EvalSAssert *) | S_Assert e -> let*^ v, env1 = eval_expr env e in let*= b = choice v true false in if b then return_continue env1 else fatal_from e @@ Error.AssertionFailed e |: SemanticsRule.SAssert (* End *) (* Begin EvalSWhile *) | S_While (e, e_limit_opt, body) -> let* limit_opt = eval_limit env e_limit_opt in let env = IEnv.tick_push env in eval_loop s true env limit_opt e body |: SemanticsRule.SWhile (* End *) (* Begin EvalSRepeat *) | S_Repeat (body, e, e_limit_opt) -> let* limit_opt1 = eval_limit env e_limit_opt in let* limit_opt2 = tick_loop_limit s limit_opt1 in let*> env1 = eval_block env body in let env2 = IEnv.tick_push_bis env1 in eval_loop s false env2 limit_opt2 e body |: SemanticsRule.SRepeat (* End *) (* Begin EvalSFor *) | S_For { index_name; start_e; dir; end_e; body; limit = e_limit_opt } -> (* The calls to [eval_expr_sef] are safe because Typing.annotate_stmt, S_For case, checks that the bounds are side-effect-free. *) let* start_v = eval_expr_sef env start_e and* end_v = eval_expr_sef env end_e and* limit_opt = eval_limit env e_limit_opt in (* By typing *) let undet = B.is_undetermined start_v || B.is_undetermined end_v in let*| env1 = declare_local_identifier env index_name start_v in let env2 = if undet then IEnv.tick_push_bis env1 else env1 in let loop_msg = if undet then Printf.sprintf "for %s" index_name else Printf.sprintf "for %s = %s %s %s" index_name (B.debug_value start_v) (PP.pp_for_direction dir) (B.debug_value end_v) in let*> env3 = eval_for loop_msg undet env2 index_name limit_opt start_v dir end_v body in let env4 = if undet then IEnv.tick_pop env3 else env3 in IEnv.remove_local index_name env4 |> return_continue |: SemanticsRule.SFor (* End *) (* Begin EvalSThrow *) | S_Throw None -> return (Throwing (None, env)) |: SemanticsRule.SThrow | S_Throw (Some (e, Some t)) -> let** v, new_env = eval_expr env e in let name = throw_identifier () and scope = B.Scope.global ~init:false in let* () = B.on_write_identifier name scope v in return (Throwing (Some ((v, name, scope), t), new_env)) |: SemanticsRule.SThrow | S_Throw (Some (_e, None)) -> fatal_from s Error.TypeInferenceNeeded (* End *) (* Begin EvalSTry *) | S_Try (s1, catchers, otherwise_opt) -> let s_m = eval_block env s1 in eval_catchers env catchers otherwise_opt s_m |: SemanticsRule.STry (* End *) (* Begin EvalSDecl *) | S_Decl (_ldk, ldi, _ty_opt, Some e_init) -> let*^ m_init, env1 = eval_expr env e_init in let**| new_env = eval_local_decl ldi env1 m_init in return_continue new_env |: SemanticsRule.SDecl | S_Decl (_ldk, _ldi, _ty_opt, None) -> fatal_from s TypeInferenceNeeded (* End *) (* Begin EvalSPrint *) | S_Print { args = e_list; newline; debug } -> let** v_list, new_env = eval_expr_list env e_list in let () = if debug then let open Format in let pp_value fmt v = B.debug_value v |> pp_print_string fmt in eprintf "@[@<2>%a:@ @[%a@]@ ->@ %a@]@." PP.pp_pos s (pp_print_list ~pp_sep:pp_print_space PP.pp_expr) e_list (pp_print_list ~pp_sep:pp_print_space pp_value) v_list else ( List.map B.debug_value v_list |> String.concat "" |> print_string; if newline then print_newline () else ()) in return_continue new_env |: SemanticsRule.SPrint (* End *) | S_Pragma _ -> assert false | S_Unreachable -> fatal_from s Error.UnreachableReached (* Evaluation of Blocks *) (* -------------------- *) (* Begin EvalBlock *) and eval_block env stm = let block_env = IEnv.push_scope env in let*> block_env1 = eval_stmt block_env stm in IEnv.pop_scope env block_env1 |> return_continue |: SemanticsRule.Block (* End *) (* Evaluation of while and repeat loops *) (* ------------------------------------ *) (* Evaluation of loop limits *) and eval_limit env e_limit_opt = match e_limit_opt with | None -> return None | Some e_limit -> ( (* The call to [eval_expr_sef] is safe because [Typing.annotate_limit_expr] checks that the limit is statically evaluable. *) let* v_limit = eval_expr_sef env e_limit in match B.v_to_z v_limit with | Some limit -> return (Some limit) | None -> fatal_from e_limit (Error.MismatchType (B.debug_value v_limit, [ integer' ]))) and check_recurse_limit pos name env e_limit_opt = let* limit_opt = eval_limit env e_limit_opt in match limit_opt with | None -> return () | Some limit -> let stack_size = IEnv.get_stack_size name env in if limit < stack_size then fatal_from pos Error.RecursionLimitReached else return () and tick_loop_limit loc limit_opt = match limit_opt with | None -> return None | Some limit -> let new_limit = Z.pred limit in if Z.sign new_limit >= 0 then return (Some new_limit) else fatal_from loc Error.LoopLimitReached (* Begin EvalLoop *) and eval_loop loc is_while env limit_opt e_cond body : stmt_eval_type = (* Name for warn messages. *) let loop_name = if is_while then "while loop" else "repeat loop" in let loop_desc = (loop_name, loc) in (* Continuation in the positive case. *) let loop env = let* limit_opt' = tick_loop_limit loc limit_opt in let*> env1 = eval_block env body in eval_loop loc is_while env1 limit_opt' e_cond body in (* First we evaluate the condition *) let*^ cond_m, env = eval_expr env e_cond in (* Depending if we are in a while or a repeat, we invert that condition. *) let cond_m = if is_while then cond_m else cond_m >>= B.unop BNOT in (* If needs be, we tick the unrolling stack before looping. *) B.delay cond_m @@ fun cond cond_m -> let binder = bind_maybe_unroll loop_desc (B.is_undetermined cond) in (* Real logic: if condition is validated, we loop, otherwise we continue to the next statement. *) choice_with_branch_effect cond_m e_cond loop return_continue (binder (return_continue env)) |: SemanticsRule.Loop (* End *) (* Evaluation of for loops *) (* ----------------------- *) (* Begin EvalFor *) and eval_for loop_msg undet env index_name limit_opt v_start dir v_end body : stmt_eval_type = (* Evaluate the condition: "has the for loop terminated?" *) let* next_limit_opt = tick_loop_limit body limit_opt in let cond_m = let comp_for_dir = match dir with Up -> LT | Down -> GT in let* () = B.on_read_identifier index_name (IEnv.get_scope env) v_start in B.binop comp_for_dir v_end v_start in (* Increase the loop counter *) let step env index_name v_start dir = let op_for_dir = match dir with Up -> PLUS | Down -> MINUS in let* () = B.on_read_identifier index_name (IEnv.get_scope env) v_start in let* v_step = B.binop op_for_dir v_start one in let* new_env = assign_local_identifier env index_name v_step in return (v_step, new_env) in (* Continuation in the positive case. *) let loop env = let loop_desc = ("for loop", body) in bind_maybe_unroll loop_desc undet (eval_block env body) @@ fun env1 -> let*| v_step, env2 = step env1 index_name v_start dir in eval_for loop_msg undet env2 index_name next_limit_opt v_step dir v_end body in (* Real logic: if the condition holds, we continue to the next loop iteration, otherwise we loop. *) choice_with_branch_effect_msg cond_m loop_msg return_continue loop (fun kont -> kont env) |: SemanticsRule.For (* End *) (* Evaluation of Catchers *) (* ---------------------- *) and eval_catchers env catchers otherwise_opt s_m : stmt_eval_type = (* rethrow_implicit handles the implicit throwing logic, that is for statement like: try throw_my_exception () catch when MyException => throw; end It edits the thrown value only in the case of an implicit throw and we have a explicitely thrown exception in the context. More formally: [rethrow_implicit to_throw m] is: - [m] if [m] is [Normal _] - [m] if [m] is [Throwing (Some _, _)] - [Throwing (Some to_throw, g)] if [m] is [Throwing (None, g)] *) (* Begin EvalRethrowImplicit *) let rethrow_implicit (v, v_ty) s_m = B.bind_seq s_m @@ function | Throwing (None, env_throw1) -> Throwing (Some (v, v_ty), env_throw1) |> return | (Normal _ | Throwing (Some _, _)) as res -> return res |: SemanticsRule.RethrowImplicit (* End *) in (* [catcher_matches t c] returns true if the catcher [c] match the raised exception type [t]. *) (* Begin EvalFindCatcher *) let catcher_matches = let static_env = { StaticEnv.empty with global = env.global.static } in fun v_ty (_e_name, e_ty, _stmt) -> subtypes static_env v_ty e_ty |: SemanticsRule.FindCatcher (* End *) in (* Main logic: *) (* If an explicit throw has been made in the [try] block: *) B.bind_seq s_m @@ function (* Begin CatchNoThrow *) | (Normal _ | Throwing (None, _)) as res -> return res |: SemanticsRule.CatchNoThrow (* End *) | Throwing (Some (v, v_ty), env_throw) -> ( (* We compute the environment in which to compute the catch statements. *) match List.find_opt (catcher_matches v_ty) catchers with (* If any catcher matches the exception type: *) | Some catcher -> ( (* Begin EvalCatch *) match catcher with | None, _e_ty, s -> eval_block env_throw s |> rethrow_implicit (v, v_ty) |: SemanticsRule.Catch (* Begin EvalCatchNamed *) | Some name, _e_ty, s -> (* If the exception is declared to be used in the catcher, we update the environment before executing [s]. *) let*| env2 = read_value_from v |> declare_local_identifier_m env_throw name in (let*> env3 = eval_block env2 s in IEnv.remove_local name env3 |> return_continue) |> rethrow_implicit (v, v_ty) |: SemanticsRule.CatchNamed (* End *)) | None -> ( (* Otherwise we try to execute the otherwise statement, or we return the exception. *) match otherwise_opt with (* Begin EvalCatchOtherwise *) | Some s -> eval_block env_throw s |> rethrow_implicit (v, v_ty) |: SemanticsRule.CatchOtherwise (* Begin EvalCatchNone *) | None -> s_m |: SemanticsRule.CatchNone)) (* End *) (* Evaluation of Function Calls *) (* ---------------------------- *) (** [eval_call pos name env ~params ~args] evaluates the call to function [name] with arguments [args] and parameters [params]. The arguments/parameters are labelled to avoid confusion. *) (* Begin EvalCall *) and eval_call pos name env ~params ~args = let*^ vargs, env1 = eval_expr_list_m env args in let*^ vparams, env2 = eval_expr_list_m env1 params in let* vargs = vargs and* vparams = vparams in let genv = IEnv.incr_stack_size name env2.global in let res = eval_subprogram genv name pos ~params:vparams ~args:vargs in B.bind_seq res @@ function | Throwing (v, env_throw) -> let genv2 = IEnv.decr_stack_size name env_throw.global in let new_env = IEnv.{ local = env2.local; global = genv2 } in return (Throwing (v, new_env)) |: SemanticsRule.Call | Normal (ms, global) -> let ms2 = List.map read_value_from ms in let genv2 = IEnv.decr_stack_size name global in let new_env = IEnv.{ local = env2.local; global = genv2 } in return_normal (ms2, new_env) |: SemanticsRule.Call (* End *) (* Evaluation of Subprograms *) (* ----------------------- *) (** [eval_subprogram genv name pos ~params ~args] evaluates the function named [name] in the global environment [genv], with [args] the actual arguments, and [params] the positional parameters. The arguments/parmeters are labelled to avoid confusion. *) and eval_subprogram (genv : IEnv.global) name pos ~params ~(args : B.value m list) : func_eval_type = match IMap.find_opt name genv.static.subprograms with (* Begin EvalFUndefIdent *) | None -> fatal_from pos @@ Error.UndefinedIdentifier name |: SemanticsRule.FUndefIdent (* End *) (* Begin EvalFPrimitive *) | Some ({ body = SB_Primitive _; _ }, _) -> let scope = B.Scope.new_local name in let body = Hashtbl.find primitive_runtimes name in let* ms = body params args in let _, vsm = List.fold_right (fun m (i, acc) -> let x = return_identifier i in let m' = let*| v = let* v = m in let* () = B.on_write_identifier x scope v in return (v, x, scope) and* vs = acc in return (v :: vs) in (i + 1, m')) ms (0, return []) in let*| vs = vsm in return_normal (vs, genv) |: SemanticsRule.FPrimitive (* End *) (* Begin EvalFBadArity *) | Some ({ args = arg_decls; _ }, _) when List.compare_lengths args arg_decls <> 0 -> fatal_from pos @@ Error.BadArity (Dynamic, name, List.length arg_decls, List.length args) |: SemanticsRule.FBadArity | Some ({ parameters = parameter_decls; _ }, _) when List.compare_lengths params parameter_decls <> 0 -> fatal_from pos @@ Error.BadParameterArity (Dynamic, V1, name, List.length parameter_decls, List.length params) |: SemanticsRule.FBadArity (* End *) (* Begin EvalFCall *) | Some ( { body = SB_ASL body; args = arg_decls; parameters = param_decls; recurse_limit; _; }, _ ) -> (let () = if false then Format.eprintf "Evaluating %s.@." name in let scope = B.Scope.new_local name in let env1 = IEnv.{ global = genv; local = local_empty_scoped scope } in let* () = check_recurse_limit pos name env1 recurse_limit in let declare_arg envm x m = declare_local_identifier_mm envm x m in let arg_names = List.map fst arg_decls in let env2 = List.fold_left2 declare_arg (return env1) arg_names args |: SemanticsRule.AssignArgs in let param_names = List.map fst param_decls in let*| env3 = List.fold_left2 declare_arg env2 param_names params in let**| res = eval_stmt env3 body in let () = if false then Format.eprintf "Finished evaluating %s.@." name in match res with | Continuing env4 -> return_normal ([], env4.global) | Returning (xs, ret_genv) -> let vs = List.mapi (fun i v -> (v, return_identifier i, scope)) xs in return_normal (vs, ret_genv)) |: SemanticsRule.FCall (* End *) (** [multi_assign env [le_1; ... ; le_n] [m_1; ... ; m_n]] is [env[le_1 --> m_1] ... [le_n --> m_n]]. *) (* Begin EvalLEMultiAssign *) and multi_assign ver env les monads : env maybe_exception m = let folder envm le vm = let**| env = envm in eval_lexpr ver le env vm in List.fold_left2 folder (return_normal env) les monads |: SemanticsRule.LEMultiAssign (* End *) (** As [multi_assign], but checks that [les] and [monads] have the same length. *) and protected_multi_assign ver env pos les monads : env maybe_exception m = if List.compare_lengths les monads != 0 then fatal_from pos @@ Error.BadArity (Dynamic, "tuple construction", List.length les, List.length monads) else multi_assign ver env les monads (* Begin EvalSpec *) let run_typed_env env (static_env : StaticEnv.global) (ast : AST.t) : B.value m = let*| env = build_genv env eval_expr static_env ast in let*| res = eval_subprogram env "main" dummy_annotated ~params:[] ~args:[] in (match res with | Normal ([ v ], _genv) -> read_value_from v | Normal _ -> Error.(fatal_unknown_pos (MismatchedReturnValue "main")) | Throwing (v_opt, _genv) -> let msg = match v_opt with | None -> "implicitely thrown out of a try-catch." | Some ((v, _, _scope), ty) -> Format.asprintf "%a %s" PP.pp_ty ty (B.debug_value v) in Error.fatal_unknown_pos (Error.UncaughtException msg)) |: SemanticsRule.Spec let run_typed env ast = run_typed_env [] env ast (* End *) end herd-herdtools7-1ca343e/asllib/Interpreter.mli000066400000000000000000000053151475314470400214220ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) (** Reference interpreter for ASL. *) module type S = sig module B : Backend.S module IEnv : Env.S with type v = B.value and module Scope = B.Scope type value_read_from = B.value * AST.identifier * B.Scope.t type 'a maybe_exception = | Normal of 'a | Throwing of (value_read_from * AST.ty) option * IEnv.env val eval_expr : IEnv.env -> AST.expr -> (B.value * IEnv.env) maybe_exception B.m val run_typed_env : (AST.identifier * B.value) list -> StaticEnv.global -> AST.t -> B.value B.m (** [run env0 tenv ast] runs the function main of the ast, in the typing environment [tenv]. However, the (global) identifiers listed in the A-list [env0] will take their initial values from [env0] and _not_ from [ast]. *) val run_typed : StaticEnv.global -> AST.t -> B.value B.m (** [run_typed ast env] runs the function main of the typed-checked [ast], in typed-checking environment [env]. *) end module type Config = sig module Instr : Instrumentation.SEMINSTR val unroll : int (** Loop unrolling threshold *) val error_handling_time : Error.error_handling_time (** When are error filed. *) end module Make (B : Backend.S) (C : Config) : S with module B = B herd-herdtools7-1ca343e/asllib/LICENSE.txt000066400000000000000000000041501475314470400202330ustar00rootroot00000000000000Unless otherwise noted, files in this folder are Copyright 2022-2023 Arm Limited and/or its affiliates and released under the license SPDX-License-Identifier: BSD-3-Clause Notable exceptions to this are the files diet.ml diet.mli which are taken from ocaml-diet "Ocaml Discrete Interval Encoding Trees" https://github.com/mirage/ocaml-diet/blob/master/lib/diet.ml and each of these files contains its own copyright and license statements. Arm acknowledges the contributions of the following people, working under contract with Arm, in the creation of this software: Hadrien Renaud, UCL. Jade Alglave, UCL and Arm. Luc Maranget, INRIA. The BSD-3-Clause license text is below: 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. 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT HOLDER 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. herd-herdtools7-1ca343e/asllib/Lexer.mll000066400000000000000000000255401475314470400202030ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) { open Tokens open Error module type CONFIG = sig (** Allow variables starting with a double underscore (__) *) val allow_double_underscore : bool val allow_unknown : bool end module Make (Config : CONFIG) = struct exception LexerError let new_line lexbuf = Lexing.new_line lexbuf; lexbuf let bitvector_lit lxm = BITVECTOR_LIT (Bitvector.of_string lxm) let mask_lit lxm = MASK_LIT (Bitvector.mask_of_string lxm) let reserved_err s = Error.fatal_unknown_pos @@ (Error.ReservedIdentifier s) let fatal lexbuf desc = AST. { desc; version = V1; pos_start = Lexing.lexeme_start_p lexbuf; pos_end = Lexing.lexeme_end_p lexbuf; } |> Error.fatal let tr_name s = match s with | "AND" -> AND | "array" -> ARRAY | "as" -> AS | "assert" -> ASSERT | "begin" -> BEGIN | "bit" -> BIT | "bits" -> BITS | "boolean" -> BOOLEAN | "case" -> CASE | "catch" -> CATCH | "config" -> CONFIG | "constant" -> CONSTANT | "__debug__" | "__DEBUG__" -> DEBUG | "DIV" -> DIV | "DIVRM" -> DIVRM | "do" -> DO | "downto" -> DOWNTO | "else" -> ELSE | "elsif" -> ELSIF | "end" -> END | "enumeration" -> ENUMERATION | "XOR" -> EOR | "exception" -> EXCEPTION | "FALSE" -> BOOL_LIT false | "for" -> FOR | "func" -> FUNC | "getter" -> GETTER | "if" -> IF | "IN" -> IN | "integer" -> INTEGER | "let" -> LET | "looplimit" -> LOOPLIMIT | "MOD" -> MOD | "NOT" -> NOT | "of" -> OF | "OR" -> OR | "otherwise" -> OTHERWISE | "pass" -> PASS | "pragma" -> PRAGMA | "println" -> PRINTLN | "print" -> PRINT | "real" -> REAL | "record" -> RECORD | "recurselimit" -> RECURSELIMIT | "repeat" -> REPEAT | "return" -> RETURN | "setter" -> SETTER | "string" -> STRING | "subtypes" -> SUBTYPES | "then" -> THEN | "throw" -> THROW | "to" -> TO | "try" -> TRY | "TRUE" -> BOOL_LIT true | "type" -> TYPE | "UNKNOWN" -> if Config.allow_unknown then ARBITRARY else fatal_unknown_pos (Error.ObsoleteSyntax s) | "ARBITRARY" -> ARBITRARY | "Unreachable" -> UNREACHABLE | "until" -> UNTIL | "var" -> VAR | "when" -> WHEN | "where" -> WHERE | "while" -> WHILE | "with" -> WITH (* Reserved identifiers *) | "SAMPLE" | "UNSTABLE" | "_" | "any" | "assume" | "assumes" | "call" | "cast" | "class" | "dict" | "endcase" | "endcatch" | "endclass" | "endevent" | "endfor" | "endfunc" | "endgetter" | "endif" | "endmodule" | "endnamespace" | "endpackage" | "endproperty" | "endrule" | "endsetter" | "endtemplate" | "endtry" | "endwhile" | "event" | "export" | "extends" | "extern" | "feature" | "gives" | "iff" | "implies" | "import" | "intersect" | "intrinsic" | "invariant" | "list" | "map" | "module" | "namespace" | "newevent" | "newmap" | "original" | "package" | "parallel" | "port" | "private" | "profile" | "property" | "protected" | "public" | "requires" | "rethrow" | "rule" | "shared" | "signal" | "template" | "typeof" | "union" | "using" | "ztype" -> reserved_err s | x when not Config.allow_double_underscore && ASTUtils.string_starts_with ~prefix:"__" x -> reserved_err x (* End of reserved identifiers *) | x -> IDENTIFIER x } let digit = ['0'-'9'] let int_lit = digit ('_' | digit)* let hex_alpha = ['a'-'f' 'A'-'F'] let hex_lit = '0' 'x' (digit | hex_alpha) ('_' | digit | hex_alpha)* let real_lit = digit ('_' | digit)* '.' digit ('_' | digit)* let alpha = ['a'-'z' 'A'-'Z'] let string_lit = '"' [^ '"']* '"' let bits = ['0' '1' ' ']* let mask = ['0' '1' 'x' ' ']* let identifier = (alpha | '_') (alpha|digit|'_')* (* Lexing of string literals ========================= We are not using [Scanf.unescaped] because: - [Scanf.unescaped] basically follows the lexical conventions of OCaml, while we follow the lexical conventions of ASL; - if they were to diverge, we would have to re-implement it - they do not support the same escape sequences: - ASL supports only [\\], [\"], [\n], [\t] - From OCaml Manual: escape-sequence ::= \ (\ ∣ " ∣ ' ∣ n ∣ t ∣ b ∣ r ∣ space) ∣  \ (0…9) (0…9) (0…9) ∣  \x (0…9 ∣ A…F ∣ a…f) (0…9 ∣ A…F ∣ a…f) ∣  \o (0…3) (0…7) (0…7) - using [unescaped] is not very explicit - We would still need lexing character by character because ocamllex cannot match negatively on the two string character that escape the end of a string literal. *) rule escaped_string_chars acc = parse | 'n' { Buffer.add_char acc '\n'; string_lit acc lexbuf } | 't' { Buffer.add_char acc '\t'; string_lit acc lexbuf } | '"' { Buffer.add_char acc '"'; string_lit acc lexbuf } | '\\' { Buffer.add_char acc '\\'; string_lit acc lexbuf } | [^ 'n' 't' '"' '\\'] { raise LexerError } and string_lit acc = parse | '"' { STRING_LIT (Buffer.contents acc) } | '\\' { escaped_string_chars acc lexbuf } | '\n' { Buffer.add_char acc '\n'; new_line lexbuf |> string_lit acc } | [^ '"' '\\' '\n']+ as lxm { Buffer.add_string acc lxm; string_lit acc lexbuf } | "" { raise LexerError } (* Lexing of c-style comments ========================== *) and c_comments = parse | "*/" { token lexbuf } | '*' { c_comments lexbuf } | '\n' { new_line lexbuf |> c_comments } | [^ '*' '\n']+ { c_comments lexbuf } | "" { raise LexerError } (* Lexing of ASL tokens ==================== *) and token = parse | '\n' { new_line lexbuf |> token } | [' ''\t''\r']+ { token lexbuf } | "//" [^'\n']* { token lexbuf } | "/*" { c_comments lexbuf } | int_lit as lxm { INT_LIT(Z.of_string lxm) } | hex_lit as lxm { INT_LIT(Z.of_string lxm) } | real_lit as lxm { REAL_LIT(Q.of_string lxm) } | '"' { string_lit (Buffer.create 16) lexbuf } | '\'' (bits as lxm) '\'' { bitvector_lit lxm } | '\'' (mask as lxm) '\'' { mask_lit lxm } (* Warning: masks with no unknown 'x' characters will be lexed as bitvectors. *) | '!' { BNOT } | ',' { COMMA } | '<' { LT } | ">>" { SHR } | "&&" { BAND } | "-->" { IMPL } | "<<" { SHL } | ']' { RBRACKET } | "]]" { RRBRACKET } | ')' { RPAR } | ".." { SLICING } | '=' { EQ } | '{' { LBRACE } | "!=" { NEQ } | '-' { MINUS } | "<->" { BEQ } | '[' { LBRACKET } | "[[" { LLBRACKET } | '(' { LPAR } | '.' { DOT } | "<=" { LEQ } | '^' { POW } | '*' { MUL } | '/' { RDIV } | "==" { EQ_OP } | "||" { BOR } | '+' { PLUS } | ':' { COLON } | "=>" { ARROW } | '}' { RBRACE } | "++" { fatal lexbuf (ObsoleteSyntax "string concatenation with ++") } | "::" { COLON_COLON } | '>' { GT } | "+:" { PLUS_COLON } | "*:" { STAR_COLON } | ';' { SEMI_COLON } | ">=" { GEQ } | "@looplimit" { fatal lexbuf (ObsoleteSyntax "Loop limits with @looplimit") } | identifier as lxm { tr_name lxm } | eof { EOF } | "" { raise LexerError } { end } herd-herdtools7-1ca343e/asllib/Native.ml000066400000000000000000000450721475314470400202000ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) open AST open ASTUtils open Infix let _log = false let list_update i f li = let rec aux acc i li = match (li, i) with | [], _ -> raise (Invalid_argument "list_update") | h :: t, 0 -> List.rev_append acc (f h :: t) | h :: t, i -> aux (h :: acc) (i - 1) t in aux [] i li type native_value = | NV_Literal of AST.literal | NV_Vector of native_value list | NV_Record of native_value ASTUtils.IMap.t let nv_literal l = NV_Literal l let pp_literal f = let open Format in function | L_Int i -> Z.pp_print f i | L_Bool true -> pp_print_string f "TRUE" | L_Bool false -> pp_print_string f "FALSE" | L_Real r -> Q.pp_print f r | L_BitVector bv -> pp_print_string f (Bitvector.to_string_hexa bv) | L_String s -> pp_print_string f s | L_Label l -> pp_print_string f l let rec pp_native_value f = let open Format in let pp_comma f () = fprintf f ",@ " in function | NV_Literal lit -> pp_literal f lit | NV_Vector li -> fprintf f "@[[%a]@]" (pp_print_list ~pp_sep:pp_comma pp_native_value) li | NV_Record map -> IMap.pp_print pp_native_value f map let native_value_to_string = Format.asprintf "%a" pp_native_value let mismatch_type v types = Error.fatal_unknown_pos (Error.MismatchType (native_value_to_string v, types)) module type Config = sig val error_handling_time : Error.error_handling_time end module NoScope : Backend.SCOPE with type t = unit = struct type t = unit let global ~init:_ = () let new_local _ = () end module NativeBackend (C : Config) = struct type 'a m = 'a type value = native_value type value_range = value * value type primitive = value m list -> value m list -> value list m let is_undetermined _ = false let v_of_int i = L_Int (Z.of_int i) |> nv_literal let v_of_literal = nv_literal let debug_value = native_value_to_string let v_to_z = function NV_Literal (L_Int z) -> Some z | _ -> None let v_to_label = function NV_Literal (L_Label l) -> l | _ -> assert false let bind (vm : 'a m) (f : 'a -> 'b m) : 'b m = f vm let prod_par (r1 : 'a m) (r2 : 'b m) : ('a * 'b) m = (r1, r2) let return v = v let cutoffT _msg _v = assert false let bind_data = bind let bind_seq = bind let bind_ctrl = bind let appl_data m f = bind_data m (fun v -> return (f v)) let debugT _s m = m let commit _ : unit m = () let choice (c : value m) (m_true : 'b m) (m_false : 'b m) : 'b m = let open AST in bind c (function | NV_Literal (L_Bool true) -> m_true | NV_Literal (L_Bool false) -> m_false | v -> mismatch_type v [ T_Bool ]) let delay m k = k m m let binop op v1 v2 = match (v1, v2) with | NV_Literal l1, NV_Literal l2 -> Operations.binop_values dummy_annotated C.error_handling_time op l1 l2 |> nv_literal | NV_Literal _, v | v, _ -> mismatch_type v [ T_Bool; integer'; T_Real; default_t_bits ] let ternary = function | NV_Literal (L_Bool true) -> fun m_true _m_false -> m_true () | NV_Literal (L_Bool false) -> fun _m_true m_false -> m_false () | v -> mismatch_type v [ T_Bool ] let unop op v = match v with | NV_Literal l -> Operations.unop_values dummy_annotated C.error_handling_time op l |> nv_literal | _ -> mismatch_type v [ T_Bool; integer'; T_Real; default_t_bits ] module Scope = NoScope let on_write_identifier _ () _ = () let on_read_identifier _ () _ = () let v_tuple li = return (NV_Vector li) let v_record li = return (NV_Record (IMap.of_list li)) let v_exception li = v_record li let non_tuple_exception v = mismatch_type v [ T_Tuple [] ] let bad_index i n = let range = Constraint_Range (expr_of_int 0, expr_of_int (n - 1)) in mismatch_type (v_of_int i) [ T_Int (WellConstrained [ range ]) ] let doesnt_have_fields_exception v = mismatch_type v [ T_Record []; T_Exception [] ] let get_index i vec = match vec with | NV_Vector li -> let n = List.length li in if i >= n then bad_index i n else List.nth li i |> return | v -> non_tuple_exception v let set_index i v vec = match vec with | NV_Vector li -> let n = List.length li in if i >= n then bad_index i n else list_update i (Fun.const v) li |> v_tuple | v -> non_tuple_exception v let get_field name record = match record with | NV_Record map -> IMap.find name map | v -> doesnt_have_fields_exception v let set_field name v record = match record with | NV_Record li -> NV_Record (IMap.add name v li) | v -> doesnt_have_fields_exception v let create_vector = v_tuple let create_record = v_record let create_exception = v_exception let as_bitvector = function | NV_Literal (L_BitVector bits) -> bits | v -> mismatch_type v [ default_t_bits ] let as_int = function | NV_Literal (L_Int i) -> Z.to_int i | v -> mismatch_type v [ integer' ] let bitvector_to_value bv = L_BitVector bv |> nv_literal |> return let int_max x y = if x >= y then x else y let bad_slices positions = let slices = List.map (fun (start, length) -> Slice_Length (expr_of_int start, expr_of_int length)) positions in Error.(fatal_unknown_pos (BadSlices (C.error_handling_time, slices, 0))) let slices_to_positions positions = List.map (fun (start, length) -> let start = as_int start and length = as_int length in if start < 0 || length < 0 then bad_slices [ (start, length) ] else (start, length)) positions |> slices_to_positions Fun.id let read_from_bitvector slices bv = let positions = slices_to_positions slices in let max_pos = List.fold_left int_max 0 positions in let () = List.iter (fun x -> if x < 0 then mismatch_type bv [ default_t_bits ]) positions in let bv = match bv with | NV_Literal (L_BitVector bv) when Bitvector.length bv > max_pos -> bv | NV_Literal (L_Int i) -> Bitvector.of_z (max_pos + 1) i | _ -> mismatch_type bv [ T_Bits ( E_ATC ( E_Var "-" |> add_dummy_annotation, T_Int (WellConstrained [ Constraint_Range (expr_of_int 0, expr_of_int max_pos); ]) |> add_dummy_annotation ) |> add_dummy_annotation, [] ); ] in let res = Bitvector.extract_slice bv positions in bitvector_to_value res let write_to_bitvector slices src dst = let dst = as_bitvector dst and src = as_bitvector src and positions = slices_to_positions slices in Bitvector.write_slice dst src positions |> bitvector_to_value let concat_bitvectors bvs = let bvs = List.map as_bitvector bvs in Bitvector.concat bvs |> bitvector_to_value let bitvector_length bv = let bv = as_bitvector bv in Bitvector.length bv |> v_of_int module Primitives = struct let return_one v = return [ return v ] (* All primitives ignore their parameters *) let uint = function | [ NV_Literal (L_BitVector bv) ] -> L_Int (Bitvector.to_z_unsigned bv) |> nv_literal |> return_one | [ v ] -> mismatch_type v [ default_t_bits ] | li -> Error.fatal_unknown_pos @@ Error.BadArity (Dynamic, "UInt", 1, List.length li) let sint = function | [ NV_Literal (L_BitVector bv) ] -> L_Int (Bitvector.to_z_signed bv) |> nv_literal |> return_one | [ v ] -> mismatch_type v [ default_t_bits ] | li -> Error.fatal_unknown_pos @@ Error.BadArity (Dynamic, "SInt", 1, List.length li) let dec_str = function | [ NV_Literal (L_Int i) ] -> L_String (Z.to_string i) |> nv_literal |> return_one | [ v ] -> mismatch_type v [ integer' ] | li -> Error.fatal_unknown_pos @@ Error.BadArity (Dynamic, "DecStr", 1, List.length li) let hex_str = function | [ NV_Literal (L_Int i) ] -> L_String (Printf.sprintf "%a" Z.sprint i) |> nv_literal |> return_one | [ v ] -> mismatch_type v [ integer' ] | li -> Error.fatal_unknown_pos @@ Error.BadArity (Dynamic, "DecStr", 1, List.length li) let ascii_range = Constraint_Range (!$0, !$127) let ascii_integer = T_Int (WellConstrained [ ascii_range ]) let ascii_str = let open! Z in function | [ NV_Literal (L_Int i) ] when geq zero i && leq ~$127 i -> L_String (char_of_int (Z.to_int i) |> String.make 1) |> nv_literal |> return_one | [ v ] -> mismatch_type v [ ascii_integer ] | li -> Error.fatal_unknown_pos @@ Error.BadArity (Dynamic, "DecStr", 1, List.length li) let log2 = function | [ NV_Literal (L_Int i) ] when Z.gt i Z.zero -> [ L_Int (Z.log2 i |> Z.of_int) |> nv_literal ] | [ v ] -> mismatch_type v [ integer' ] | li -> Error.fatal_unknown_pos @@ Error.BadArity (Dynamic, "Log2", 1, List.length li) let int_to_real = function | [ NV_Literal (L_Int i) ] -> L_Real (Q.of_bigint i) |> nv_literal |> return_one | [ v ] -> mismatch_type v [ integer' ] | li -> Error.fatal_unknown_pos @@ Error.BadArity (Dynamic, "Real", 1, List.length li) let truncate q = Q.to_bigint q let floor q = if Q.sign q = -1 then if Q.den q = Z.one then Q.num q else truncate q |> Z.pred else truncate q let ceiling q = if Q.sign q = 1 then if Q.den q = Z.one then Q.num q else truncate q |> Z.succ else truncate q let wrap_real_to_int name f = function | [ NV_Literal (L_Real q) ] -> L_Int (f q) |> nv_literal |> return_one | [ v ] -> mismatch_type v [ T_Real ] | li -> Error.fatal_unknown_pos @@ Error.BadArity (Dynamic, name, 1, List.length li) let round_down = wrap_real_to_int "RoundDown" floor let round_up = wrap_real_to_int "RoundUp" ceiling let round_towards_zero = wrap_real_to_int "RoundTowardsZero" truncate let primitives = let e_var x = E_Var x |> add_dummy_annotation in let eoi i = expr_of_int i in let binop = ASTUtils.binop in let minus_one e = binop MINUS e (eoi 1) in let pow_2 = binop POW (eoi 2) in let neg e = E_Unop (NEG, e) |> add_pos_from e in (* [t_bits "N"] is the bitvector type of length [N]. *) let t_bits x = T_Bits (e_var x, []) |> add_dummy_annotation in (* [t_int_ctnt e1 e2] is [integer {e1..e2}] *) let t_int_ctnt e1 e2 = T_Int (WellConstrained [ Constraint_Range (e1, e2) ]) |> add_dummy_annotation in (* [p ~parameters ~args ~returns name f] declares a primtive named [name] with body [f], and signature specified by [parameters] [args] and [returns]. *) let p ?(parameters = []) ~args ?returns ?(se = false) name f = let subprogram_type = match returns with None -> ST_Procedure | _ -> ST_Function in let body = SB_Primitive se and return_type = returns and recurse_limit = None in ( { name; parameters; args; body; return_type; subprogram_type; recurse_limit; builtin = true; }, (* All native primitives ignore parameters *) fun _params args -> f args ) in [ (let two_pow_n_minus_one = minus_one (pow_2 (e_var "N")) in let returns = t_int_ctnt (eoi 0) two_pow_n_minus_one in p ~parameters:[ ("N", None) ] ~args:[ ("x", t_bits "N") ] ~returns "UInt" uint); (let two_pow_n_minus_one = pow_2 (minus_one (e_var "N")) in let minus_two_pow_n_minus_one = neg two_pow_n_minus_one and two_pow_n_minus_one_minus_one = minus_one two_pow_n_minus_one in let returns = t_int_ctnt minus_two_pow_n_minus_one two_pow_n_minus_one_minus_one in p ~parameters:[ ("N", None) ] ~args:[ ("x", t_bits "N") ] ~returns "SInt" sint); p ~args:[ ("x", integer) ] ~returns:string "DecStr" dec_str; p ~args:[ ("x", integer) ] ~returns:string "HexStr" hex_str; p ~args:[ ("x", integer) ] ~returns:string "AsciiStr" ascii_str; p ~args:[ ("x", integer) ] ~returns:integer "Log2" log2; p ~args:[ ("x", integer) ] ~returns:real "Real" int_to_real; p ~args:[ ("x", real) ] ~returns:integer "RoundDown" round_down; p ~args:[ ("x", real) ] ~returns:integer "RoundUp" round_up; p ~args:[ ("x", real) ] ~returns:integer "RoundTowardsZero" round_towards_zero; ] end let primitives = Primitives.primitives end module StaticBackend = struct include NativeBackend (struct let error_handling_time = Error.Static end) let v_unknown_of_type ~eval_expr_sef:_ _ty = Printf.eprintf "Cannot evaluate statically UNKNOWN.\n%!"; assert false end let rec unknown_of_aggregate_type unknown_of_singular_type ~eval_expr_sef ty = let unknown_of_type = unknown_of_aggregate_type unknown_of_singular_type ~eval_expr_sef in match ty.desc with | T_Real | T_String | T_Bool | T_Bits _ | T_Int _ -> unknown_of_singular_type ~eval_expr_sef ty | T_Array (length, t_elem) -> ( match length with | ArrayLength_Expr e -> ( match eval_expr_sef e with | NV_Literal (L_Int n) -> let n = Z.to_int n in if n >= 0 then NV_Vector (List.init n (fun _ -> unknown_of_type t_elem)) else Error.(fatal_from ty (UnsupportedExpr (Dynamic, e))) | _ -> (* Bad types *) assert false) | ArrayLength_Enum (_enum, labels) -> let fields = List.map (fun field_name -> (field_name, unknown_of_type t_elem)) labels in NV_Record (IMap.of_list fields)) | T_Record fields | T_Exception fields -> fields |> List.map (fun (field_name, t) -> (field_name, unknown_of_type t)) |> IMap.of_list |> fun record -> NV_Record record | T_Enum li -> let n = List.length li |> expr_of_int in let range = Constraint_Range (expr_of_int 0, n) in let t = T_Int (WellConstrained [ range ]) |> add_pos_from ty in unknown_of_singular_type ~eval_expr_sef t | T_Tuple types -> NV_Vector (List.map (fun t -> unknown_of_type t) types) | T_Named _ -> Error.(fatal_from ty TypeInferenceNeeded) module DeterministicBackend = struct include NativeBackend (struct let error_handling_time = Error.Dynamic end) let rec deterministic_unknown_of_constraints ~eval_expr_sef ty constraints = match constraints with | Constraint_Exact e :: _ -> eval_expr_sef e | Constraint_Range (e1, e2) :: other_constraints -> ( let v1 = eval_expr_sef e1 and v2 = eval_expr_sef e2 in match (v1, v2) with | NV_Literal (L_Int i1), NV_Literal (L_Int i2) -> if Z.leq i1 i2 then v1 else deterministic_unknown_of_constraints ~eval_expr_sef ty other_constraints | _ -> (* Bad types *) assert false) | [] -> Error.(fatal_from ty (ArbitraryEmptyType ty)) let deterministic_unknown_of_singular_type ~eval_expr_sef ty = match ty.desc with | T_Bool -> NV_Literal (L_Bool false) | T_String -> NV_Literal (L_String "") | T_Real -> NV_Literal (L_Real Q.zero) | T_Int UnConstrained -> NV_Literal (L_Int Z.zero) | T_Int (WellConstrained constraints) -> deterministic_unknown_of_constraints ~eval_expr_sef ty constraints | T_Int (Parameterized (_, x)) -> eval_expr_sef (E_Var x |> add_pos_from ty) | T_Bits (e, _) -> ( match eval_expr_sef e with | NV_Literal (L_Int n) -> NV_Literal (L_BitVector (Bitvector.zeros (Z.to_int n))) | _ -> (* Bad types *) assert false) | T_Enum _ | T_Tuple _ | T_Array _ | T_Record _ | T_Exception _ | T_Named _ | T_Int PendingConstrained -> assert false let deterministic_unknown_of_type ~eval_expr_sef = unknown_of_aggregate_type deterministic_unknown_of_singular_type ~eval_expr_sef let v_unknown_of_type ~eval_expr_sef ty = deterministic_unknown_of_type ~eval_expr_sef ty end module DeterministicInterpreter (C : Interpreter.Config) = Interpreter.Make (DeterministicBackend) (C) let exit_value = function | NV_Literal (L_Int i) -> i |> Z.to_int | v -> mismatch_type v [ integer' ] let instrumentation_buffer = function | Some true -> (module Instrumentation.SemanticsSingleSetBuffer : Instrumentation.SEMBUFFER) | Some false | None -> (module Instrumentation.SemanticsNoBuffer : Instrumentation.SEMBUFFER) let interprete ?instrumentation static_env ast = let module B = (val instrumentation_buffer instrumentation) in let module CI : Interpreter.Config = struct let unroll = 0 let error_handling_time = Error.Dynamic module Instr = Instrumentation.SemMake (B) end in let module I = DeterministicInterpreter (CI) in B.reset (); let res = I.run_typed static_env ast in (exit_value res, B.get ()) herd-herdtools7-1ca343e/asllib/Native.mli000066400000000000000000000043641475314470400203500ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) (* Sequential ASL interpreter using straight OCaml values as backend. *) type native_value = | NV_Literal of AST.literal | NV_Vector of native_value list | NV_Record of native_value ASTUtils.IMap.t module NoScope : Backend.SCOPE with type t = unit module StaticBackend : Backend.S with type value = native_value and type 'a m = 'a and module Scope = NoScope module DeterministicBackend : Backend.S with type value = native_value and type 'a m = 'a and module Scope = NoScope module DeterministicInterpreter (C : Interpreter.Config) : Interpreter.S with module B = DeterministicBackend val interprete : ?instrumentation:bool -> StaticEnv.global -> AST.t -> int * Instrumentation.semantics_rule list herd-herdtools7-1ca343e/asllib/Operations.ml000066400000000000000000000122061475314470400210660ustar00rootroot00000000000000open AST open ASTUtils open Error let value_as_int pos = function | L_Int i -> ( try Z.to_int i with Z.Overflow -> failwith "Cannot slice with an integer more than machine size.") | v -> fatal_from pos (Error.MismatchType (PP.literal_to_string v, [ integer' ])) let is_positive z = Z.sign z != -1 let is_strict_positive z = Z.sign z = 1 let bv_same_length b1 b2 = Bitvector.(length b1 = length b2) let exp_real q z = if Q.sign q = 0 then ( assert (Z.sign z >= 0) (* Case handled earlier *); if Z.sign z = 0 then Q.one else Q.zero) else let q, z = if is_positive z then (q, z) else (Q.inv q, Z.neg z) in let num = Q.num q and den = Q.den q in let i = Z.to_int z in let res_num = Z.pow num i and res_den = Z.pow den i in Q.(res_num /// res_den) let binop_values pos t op v1 v2 = match (op, v1, v2) with (* int -> int -> int *) | PLUS, L_Int v1, L_Int v2 -> L_Int (Z.add v1 v2) | MUL, L_Int v1, L_Int v2 -> L_Int (Z.mul v1 v2) | MINUS, L_Int v1, L_Int v2 -> L_Int (Z.sub v1 v2) | DIV, L_Int v1, L_Int v2 when is_strict_positive v2 && Z.divisible v1 v2 -> L_Int (Z.divexact v1 v2) | DIVRM, L_Int v1, L_Int v2 when is_strict_positive v2 -> L_Int (Z.fdiv v1 v2) (* Division rounded towards minus infinity. *) | MOD, L_Int v1, L_Int v2 when is_strict_positive v2 -> L_Int Z.(sub v1 (mul v2 (fdiv v1 v2))) (* We cannot use any rem function in Z as we need the rounded towards minus infinity reminder. *) | POW, L_Int v1, L_Int v2 when is_positive v2 -> L_Int Z.(pow v1 (to_int v2)) | SHL, L_Int v1, L_Int v2 when is_positive v2 -> L_Int Z.(shift_left v1 (to_int v2)) | SHR, L_Int v1, L_Int v2 when is_positive v2 -> L_Int Z.(shift_right v1 (to_int v2)) (* int -> int -> bool*) | EQ_OP, L_Int v1, L_Int v2 -> L_Bool (Z.equal v1 v2) | NEQ, L_Int v1, L_Int v2 -> L_Bool (not (Z.equal v1 v2)) | LEQ, L_Int v1, L_Int v2 -> L_Bool (Z.leq v1 v2) | LT, L_Int v1, L_Int v2 -> L_Bool (Z.lt v1 v2) | GEQ, L_Int v1, L_Int v2 -> L_Bool (Z.geq v1 v2) | GT, L_Int v1, L_Int v2 -> L_Bool (Z.gt v1 v2) (* bool -> bool -> bool *) | BAND, L_Bool b1, L_Bool b2 -> L_Bool (b1 && b2) | BOR, L_Bool b1, L_Bool b2 -> L_Bool (b1 || b2) | BEQ, L_Bool b1, L_Bool b2 -> L_Bool (b1 == b2) | IMPL, L_Bool b1, L_Bool b2 -> L_Bool ((not b1) || b2) | EQ_OP, L_Bool b1, L_Bool b2 -> L_Bool (b1 == b2) | NEQ, L_Bool b1, L_Bool b2 -> L_Bool (b1 <> b2) (* real -> real -> real *) | PLUS, L_Real v1, L_Real v2 -> L_Real (Q.add v1 v2) | MUL, L_Real v1, L_Real v2 -> L_Real (Q.mul v1 v2) | MINUS, L_Real v1, L_Real v2 -> L_Real (Q.sub v1 v2) | RDIV, L_Real v1, L_Real v2 -> L_Real (Q.div v1 v2) | POW, L_Real q1, L_Int z2 when not (Q.sign q1 = 0 && Z.sign z2 < 0) -> (* 0.0 ^ z is not defined for z < 0 *) L_Real (exp_real q1 z2) (* real -> real -> bool *) | EQ_OP, L_Real v1, L_Real v2 -> L_Bool (Q.equal v1 v2) | NEQ, L_Real v1, L_Real v2 -> L_Bool (not (Q.equal v1 v2)) | LEQ, L_Real v1, L_Real v2 -> L_Bool (Q.leq v1 v2) | LT, L_Real v1, L_Real v2 -> L_Bool (Q.lt v1 v2) | GEQ, L_Real v1, L_Real v2 -> L_Bool (Q.geq v1 v2) | GT, L_Real v1, L_Real v2 -> L_Bool (Q.gt v1 v2) (* bits -> bits -> bool *) | EQ_OP, L_BitVector b1, L_BitVector b2 when bv_same_length b1 b2 -> L_Bool (Bitvector.equal b1 b2) | NEQ, L_BitVector b1, L_BitVector b2 when bv_same_length b1 b2 -> L_Bool (not @@ Bitvector.equal b1 b2) (* bits -> bits -> bits *) | OR, L_BitVector b1, L_BitVector b2 when bv_same_length b1 b2 -> L_BitVector (Bitvector.logor b1 b2) | AND, L_BitVector b1, L_BitVector b2 when bv_same_length b1 b2 -> L_BitVector (Bitvector.logand b1 b2) | EOR, L_BitVector b1, L_BitVector b2 when bv_same_length b1 b2 -> L_BitVector (Bitvector.logxor b1 b2) | PLUS, L_BitVector b1, L_BitVector b2 when bv_same_length b1 b2 -> L_BitVector Bitvector.( of_z (length b1) (Z.add (to_z_unsigned b1) (to_z_unsigned b2))) | MINUS, L_BitVector b1, L_BitVector b2 when bv_same_length b1 b2 -> L_BitVector Bitvector.( of_z (length b1) (Z.sub (to_z_unsigned b1) (to_z_unsigned b2))) | BV_CONCAT, L_BitVector b1, L_BitVector b2 -> L_BitVector (Bitvector.concat [ b1; b2 ]) (* bits -> integer -> bits *) | PLUS, L_BitVector b1, L_Int z2 -> L_BitVector Bitvector.(of_z (length b1) (Z.add (to_z_unsigned b1) z2)) | MINUS, L_BitVector b1, L_Int z2 -> L_BitVector Bitvector.(of_z (length b1) (Z.sub (to_z_unsigned b1) z2)) (* string -> string -> bool *) | EQ_OP, L_String s1, L_String s2 -> L_Bool (String.equal s1 s2) | NEQ, L_String s1, L_String s2 -> L_Bool (not (String.equal s1 s2)) (* enum -> enum -> bool *) | EQ_OP, L_Label s1, L_Label s2 -> L_Bool (String.equal s1 s2) | NEQ, L_Label s1, L_Label s2 -> L_Bool (not (String.equal s1 s2)) (* Failure *) | _ -> fatal_from pos (Error.UnsupportedBinop (t, op, v1, v2)) let unop_values pos t op v = match (op, v) with | NEG, L_Int i -> L_Int (Z.neg i) | NEG, L_Real r -> L_Real (Q.neg r) | BNOT, L_Bool b -> L_Bool (not b) | NOT, L_BitVector bv -> L_BitVector (Bitvector.lognot bv) | _ -> fatal_from pos (Error.UnsupportedUnop (t, op, v)) herd-herdtools7-1ca343e/asllib/PP.ml000066400000000000000000000431111475314470400172610ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) open Format open AST type 'a printer = Format.formatter -> 'a -> unit (* Adapted from stdlib >= 4.12.0 *) let pp_print_seq ?(pp_sep = pp_print_cut) pp_v ppf v = let is_first = ref true in let pp_v v = if !is_first then is_first := false else pp_sep ppf (); pp_v ppf v in Seq.iter pp_v v (* Just to display better error messages ... *) let nonstandard_constraint_compare c1 c2 = match (c1, c2) with | Constraint_Exact _, Constraint_Exact _ | Constraint_Range _, Constraint_Range _ -> compare c1 c2 | Constraint_Exact e1, Constraint_Range (e3, e4) -> ( match compare e1 e3 with | 0 -> ( match compare e1 e4 with 0 -> 1 | n -> n) | n -> n) | Constraint_Range (e1, e2), Constraint_Exact e3 -> ( match compare e1 e3 with | 0 -> ( match compare e2 e3 with 0 -> -1 | n -> n) | n -> n) let pp_comma f () = fprintf f ",@ " let pp_comma_list pp_elt f = pp_print_list ~pp_sep:pp_comma pp_elt f let pp_pos f { pos_start; pos_end; _ } = let open Lexing in let pp_char_num f { pos_cnum; pos_bol; _ } = pp_print_int f (pos_cnum - pos_bol) in if pos_start = dummy_pos || pos_end = dummy_pos then () else ( pp_open_hovbox f 2; fprintf f "File %s,@ " pos_start.pos_fname; if String.equal pos_start.pos_fname pos_end.pos_fname then if pos_start.pos_lnum = pos_end.pos_lnum then if pos_start.pos_cnum = pos_end.pos_cnum then fprintf f "line %d,@ character %a" pos_start.pos_lnum pp_char_num pos_start else fprintf f "line %d,@ characters %a to %a" pos_start.pos_lnum pp_char_num pos_start pp_char_num pos_end else fprintf f "line %d,@ character %a@ to@ line %d,@ character %a" pos_start.pos_lnum pp_char_num pos_start pos_end.pos_lnum pp_char_num pos_end else fprintf f "line %d,@ character %a" pos_start.pos_lnum pp_char_num pos_start; pp_close_box f ()) let pp_pos_str withpos = let buf = Buffer.create 16 in let fmt = Format.formatter_of_buffer buf in let () = pp_pos fmt withpos in let () = pp_print_flush fmt () in Buffer.contents buf let pp_pos_str_no_char { pos_start; pos_end } = Printf.sprintf "file %S, line %d to line %d" pos_start.pos_fname pos_start.pos_lnum pos_end.pos_lnum let binop_to_string : binop -> string = function | AND -> "AND" | BAND -> "&&" | BEQ -> "<->" | BOR -> "||" | DIV -> "DIV" | DIVRM -> "DIVRM" | EOR -> "EOR" | EQ_OP -> "==" | GT -> ">" | GEQ -> ">=" | IMPL -> "-->" | LT -> "<" | LEQ -> "<=" | MOD -> "MOD" | MINUS -> "-" | MUL -> "*" | NEQ -> "!=" | OR -> "OR" | PLUS -> "+" | RDIV -> "/" | SHL -> "<<" | SHR -> ">>" | POW -> "^" | BV_CONCAT -> "::" let unop_to_string = function BNOT -> "!" | NEG -> "-" | NOT -> "NOT" let pp_literal f = function | L_Int i -> Z.pp_print f i | L_Bool true -> pp_print_string f "TRUE" | L_Bool false -> pp_print_string f "FALSE" | L_Real r -> fprintf f "(%a.0 / %a.0)" Z.pp_print (Q.num r) Z.pp_print (Q.den r) | L_BitVector bv -> Bitvector.pp_t f bv | L_String s -> fprintf f "%S" s | L_Label l -> fprintf f "%s" l let rec pp_expr f e = match e.desc with | E_Literal v -> pp_literal f v | E_Var x -> pp_print_string f x | E_ATC (e, ty) -> fprintf f "@[%a@ as %a@]" pp_expr e pp_ty ty | E_Binop (b, e1, e2) -> fprintf f "(@[%a@ %s %a@])" pp_expr e1 (binop_to_string b) pp_expr e2 | E_Unop (u, e) -> fprintf f "(%s %a)" (unop_to_string u) pp_expr e | E_Call { name; params = []; args } -> fprintf f "@[%s(%a)@]" name pp_expr_list args | E_Call { name; params; args } -> fprintf f "@[%s{%a}(%a)@]" name pp_expr_list params pp_expr_list args | E_Slice (e, args) -> fprintf f "@[%a[%a]@]" pp_expr e pp_slice_list args | E_GetArray (e1, e2) -> fprintf f "@[%a[[%a]]@]" pp_expr e1 pp_expr e2 | E_GetEnumArray (e1, e2) -> fprintf f "@[%a[[%a]]@]" pp_expr e1 pp_expr e2 | E_Cond (e1, e2, e3) -> fprintf f "@[@[if %a@ then@]@;<1 2>%a@ else@;<1 2>%a@]" pp_expr e1 pp_expr e2 pp_expr e3 | E_GetField (e, x) -> fprintf f "@[%a@,.%s@]" pp_expr e x | E_GetFields (e, xs) -> fprintf f "@[%a@,.[@[%a@]]@]" pp_expr e (pp_comma_list pp_print_string) xs | E_GetItem (e, i) -> fprintf f "@[%a@,.item%d@]" pp_expr e i | E_Record (ty, li) -> let pp_one f (x, e) = fprintf f "@[%s =@ %a@]" x pp_expr e in fprintf f "@[%a {@ %a@;<1 -2>}@]" pp_ty ty (pp_comma_list pp_one) li | E_Tuple es -> fprintf f "@[(%a)@]" pp_expr_list es | E_Array { length; value } -> fprintf f "@[array[[%a]] of %a@]" pp_expr length pp_expr value | E_EnumArray { enum; value } -> fprintf f "@[array[[%s]] of %a@]" enum pp_expr value | E_Arbitrary ty -> fprintf f "@[ARBITRARY :@ %a@]" pp_ty ty | E_Pattern (e, p) -> fprintf f "@[%a@ IN %a@]" pp_expr e pp_pattern p and pp_expr_list f = pp_comma_list pp_expr f and pp_slice f = function | Slice_Single e -> pp_expr f e | Slice_Range (e1, e2) -> fprintf f "@[%a@,:%a@]" pp_expr e1 pp_expr e2 | Slice_Length (e1, e2) -> fprintf f "@[%a@,+:%a@]" pp_expr e1 pp_expr e2 | Slice_Star (e1, e2) -> fprintf f "@[%a@,*:%a@]" pp_expr e1 pp_expr e2 and pp_pattern f p = match p.desc with | Pattern_All -> pp_print_string f "{-}" | Pattern_Any li -> fprintf f "@[{%a}@]" (pp_comma_list pp_pattern) li | Pattern_Geq e -> fprintf f "@[>= %a@]" pp_expr e | Pattern_Leq e -> fprintf f "@[<= %a@]" pp_expr e | Pattern_Mask m -> fprintf f "'%s'" (Bitvector.mask_to_string m) | Pattern_Not { desc = Pattern_Any li; _ } -> fprintf f "@[!{%a}@]" (pp_comma_list pp_pattern) li | Pattern_Not p -> fprintf f "@[!{%a}@]" pp_pattern p | Pattern_Range (e1, e2) -> fprintf f "@[%a .. %a@]" pp_expr e1 pp_expr e2 | Pattern_Single e -> pp_expr f e | Pattern_Tuple li -> fprintf f "@[(%a)@]" (pp_comma_list pp_pattern) li and pp_slice_list f = pp_comma_list pp_slice f and pp_ty f t = match t.desc with | T_Int UnConstrained -> pp_print_string f "integer" | T_Int (WellConstrained cs) -> fprintf f "@[integer {%a}@]" pp_int_constraints cs | T_Int PendingConstrained -> pp_print_string f "integer{-}" | T_Int (Parameterized (_uid, var)) -> fprintf f "@[integer {%s}@]" var | T_Real -> pp_print_string f "real" | T_String -> pp_print_string f "string" | T_Bool -> pp_print_string f "boolean" | T_Bits (width, []) -> fprintf f "@[bits(%a)@]" pp_expr width | T_Bits (width, fields) -> fprintf f "@[bits (%a)@ %a@]" pp_expr width pp_bitfields fields | T_Enum enum_ty -> fprintf f "@[enumeration {@,%a@;<0 -2>}@]" (pp_comma_list pp_print_string) enum_ty | T_Tuple ty_list -> fprintf f "@[(%a)@]" (pp_comma_list pp_ty) ty_list | T_Array (ArrayLength_Expr e, elt_type) -> fprintf f "@[array [[%a]] of %a@]" pp_expr e pp_ty elt_type | T_Array (ArrayLength_Enum (enum, _), elt_type) -> fprintf f "@[array [[%s]] of %a@]" enum pp_ty elt_type | T_Record record_ty -> fprintf f "@[record {@ %a@;<1 -2>}@]" pp_fields record_ty | T_Exception record_ty -> fprintf f "@[exception { %a@;<1 -2>}@]" pp_fields record_ty | T_Named x -> pp_print_string f x and pp_bitfield f = function | BitField_Simple (name, slices) -> fprintf f "@[[%a]@ %s@]" pp_slice_list slices name | BitField_Nested (name, slices, bitfields) -> fprintf f "@[[%a]@ %s@ %a@]" pp_slice_list slices name pp_bitfields bitfields | BitField_Type (name, slices, ty) -> fprintf f "@[[%a]@ %s:@ %a@]" pp_slice_list slices name pp_ty ty and pp_bitfields f bitfields = fprintf f "@[{@ %a@ }@]" (pp_comma_list pp_bitfield) bitfields and pp_fields f = let pp_one f (field_name, field_type) = fprintf f "@[%s:@ %a@]" field_name pp_ty field_type in pp_comma_list pp_one f and pp_int_constraint f = function | Constraint_Exact x -> pp_expr f x | Constraint_Range (x, y) -> fprintf f "@[%a..%a@]" pp_expr x pp_expr y and pp_int_constraints f li = let li = List.sort nonstandard_constraint_compare li in let pp_max_int_constraint_list = 10 in if List.length li < pp_max_int_constraint_list then fprintf f "@[%a@]" (pp_comma_list pp_int_constraint) li else fprintf f "@[%a,@ ...@]" (pp_comma_list pp_int_constraint) (ASTUtils.list_take pp_max_int_constraint_list li) let pp_typed_identifier f (name, ty) = fprintf f "@[%s:@ %a@]" name pp_ty ty let rec pp_lexpr f le = match le.desc with | LE_Var x -> pp_print_string f x | LE_Slice (le, args) -> fprintf f "%a[%a]" pp_lexpr le pp_slice_list args | LE_SetArray (le, e) -> fprintf f "%a[[%a]]" pp_lexpr le pp_expr e | LE_SetEnumArray (le, e) -> fprintf f "%a[[%a]]" pp_lexpr le pp_expr e | LE_SetField (le, x) -> fprintf f "@[%a@,.%s@]" pp_lexpr le x | LE_SetFields (le, li, _) -> fprintf f "@[%a@,.@[[%a]@]@]" pp_lexpr le (pp_comma_list pp_print_string) li | LE_Discard -> pp_print_string f "-" | LE_Destructuring les -> fprintf f "@[( %a )@]" (pp_comma_list pp_lexpr) les let pp_loop_limit = pp_print_option @@ fun f e -> fprintf f "@ @[limit@ %a@]" pp_expr e let pp_for_direction = function Up -> "to" | Down -> "downto" let pp_local_decl_keyword f k = pp_print_string f @@ match k with | LDK_Var -> "var" | LDK_Constant -> "constant" | LDK_Let -> "let" let pp_local_decl_item f = function | LDI_Var x -> pp_print_string f x | LDI_Tuple ldis -> fprintf f "@[(%a)@]" (pp_comma_list pp_print_string) ldis let rec pp_stmt f s = match s.desc with | S_Pass -> pp_print_string f "pass;" | S_Seq (s1, s2) -> fprintf f "%a@ %a" pp_stmt s1 pp_stmt s2 | S_Assign (le, e) -> fprintf f "@[%a =@ %a;@]" pp_lexpr le pp_expr e | S_Call { name; params = []; args } -> fprintf f "@[%s(%a);@]" name pp_expr_list args | S_Call { name; params; args } -> fprintf f "@[%s{%a}(%a);@]" name pp_expr_list params pp_expr_list args | S_Return (Some e) -> fprintf f "return %a;" pp_expr e | S_Return None -> fprintf f "return;" | S_Cond (e, s1, { desc = S_Pass; _ }) -> fprintf f "@[@[if %a@ then@]@;<1 2>@[%a@]@ end;@]" pp_expr e pp_stmt s1 | S_Cond (e, s1, s2) -> fprintf f "@[@[if %a@ then@]@;\ <1 2>@[%a@]@ else@;\ <1 2>@[%a@]@ end;@]" pp_expr e pp_stmt s1 pp_stmt s2 | S_Assert e -> fprintf f "@[<2>assert@ %a;@]" pp_expr e | S_While (e, limit, s) -> fprintf f "@[@[while %a%a@ do@]@;<1 2>@[%a@]@ end;@]" pp_expr e pp_loop_limit limit pp_stmt s | S_Repeat (s, e, limit) -> fprintf f "@[repeat@;<1 2>@[%a@]@;<1 0>@[until@ %a%a;@]@]" pp_stmt s pp_expr e pp_loop_limit limit | S_For { index_name; start_e; end_e; dir; body; limit } -> fprintf f "@[@[for %a = %a %s %a%a@ do@]@;<1 2>@[%a@]@ end@]" pp_print_string index_name pp_expr start_e (pp_for_direction dir) pp_expr end_e pp_loop_limit limit pp_stmt body | S_Decl (ldk, ldi, None, None) -> fprintf f "@[<2>%a %a;@]" pp_local_decl_keyword ldk pp_local_decl_item ldi | S_Decl (ldk, ldi, None, Some e) -> fprintf f "@[<2>%a %a =@ %a;@]" pp_local_decl_keyword ldk pp_local_decl_item ldi pp_expr e | S_Decl (ldk, ldi, Some ty, None) -> fprintf f "@[<2>%a %a:@ %a;@]" pp_local_decl_keyword ldk pp_local_decl_item ldi pp_ty ty | S_Decl (ldk, ldi, Some ty, Some e) -> fprintf f "@[<2>%a %a:@ %a =@ %a;@]" pp_local_decl_keyword ldk pp_local_decl_item ldi pp_ty ty pp_expr e | S_Throw (Some (e, _ty_annotation)) -> fprintf f "@[<2>throw@ %a;@]" pp_expr e | S_Throw None -> fprintf f "throw;" | S_Try (s, catchers, Some s') -> fprintf f "@[@[try@ %a@]@ @[catch@ %a@ @[<2>otherwise =>@ %a@]@]@ end@]" pp_stmt s (pp_print_list ~pp_sep:pp_print_space pp_catcher) catchers pp_stmt s' | S_Try (s, catchers, None) -> fprintf f "@[<2>try@ %a@ catch@ @[%a@]@ end@]" pp_stmt s (pp_print_list ~pp_sep:pp_print_space pp_catcher) catchers | S_Print { args; newline = false; debug = false } -> fprintf f "@[<2>print(%a);@]" (pp_comma_list pp_expr) args | S_Print { args; newline = true; debug = false } -> fprintf f "@[<2>println(%a);@]" (pp_comma_list pp_expr) args | S_Print { args; debug = true } -> fprintf f "@[<2>DEBUG@ %a;@]" (pp_comma_list pp_expr) args | S_Unreachable -> fprintf f "Unreachable();" | S_Pragma (name, args) -> fprintf f "@[<2>pragma@ %a %a;@]" pp_print_string name (pp_comma_list pp_expr) args and pp_catcher f (name, ty, s) = match name with | None -> fprintf f "@[<2>when@ %a@ => %a@]" pp_ty ty pp_stmt s | Some name -> fprintf f "@[<2>when %s@ :@ %a@ => %a@]" name pp_ty ty pp_stmt s let pp_gdk f gdk = pp_print_string f @@ match gdk with | GDK_Var -> "var" | GDK_Config -> "config" | GDK_Let -> "let" | GDK_Constant -> "constant" let pp_decl f = let pp_global_storage f = function | { name; keyword; ty = None; initial_value = Some e } -> fprintf f "%a %s@ = %a" pp_gdk keyword name pp_expr e | { name; keyword; ty = Some t; initial_value = Some e } -> fprintf f "%a %s:@ %a@ = %a" pp_gdk keyword name pp_ty t pp_expr e | { name; keyword; ty = Some t; initial_value = None } -> fprintf f "%a %s:@ %a" pp_gdk keyword name pp_ty t | { name = _; keyword = _; ty = None; initial_value = None } -> assert false in let pp_func_sig f { name; args; return_type; parameters; subprogram_type; body = _ } = let pp_args = pp_comma_list pp_typed_identifier in let pp_return_type_opt f = function | Some return_type -> fprintf f "@;<1 -2>=> %a" pp_ty return_type | None -> () in let pp_parameters f = function | [] -> () | parameters -> let pp_one f = function | name, None -> pp_print_string f name | name, Some t -> pp_typed_identifier f (name, t) in fprintf f "@ {%a}" (pp_comma_list pp_one) parameters in match subprogram_type with | ST_Function | ST_Procedure -> fprintf f "@[func @[%s%a@] (@,%a)%a@]" name pp_parameters parameters pp_args args pp_return_type_opt return_type | ST_Getter -> fprintf f "@[getter %s%a [@,%a]%a@]" name pp_parameters parameters pp_args args pp_return_type_opt return_type | ST_EmptyGetter -> fprintf f "@[getter %s%a@]" name pp_return_type_opt return_type | ST_Setter -> let new_v, args = match args with [] -> assert false | h :: t -> (h, t) in fprintf f "@[setter %s%a [@,%a]@ = %a@]" name pp_parameters parameters pp_args args pp_typed_identifier new_v | ST_EmptySetter -> let new_v = match args with [ h ] -> h | _ -> assert false in fprintf f "@[setter %s@ = %a]" name pp_typed_identifier new_v in let pp_body f = function | SB_ASL s -> pp_stmt f s | SB_Primitive _ -> fprintf f "pass;@ // primitive" in fun d -> match d.desc with | D_Func func -> fprintf f "@[%a@ begin@;<1 2>@[%a@]@ end@]" pp_func_sig func pp_body func.body | D_TypeDecl (x, ty, None) -> fprintf f "@[<2>type %s of %a;@]" x pp_ty ty | D_TypeDecl (x, ty, Some (s, [])) -> fprintf f "@[<2>type %s@ of %a@ subtypes %s;@]" x pp_ty ty s | D_TypeDecl (x, ty, Some (s, fields)) -> fprintf f "@[<2>type %s@ of %a@ subtypes %s@ with @[{@ %a@;<1 -2>}@];@]" x pp_ty ty s pp_fields fields | D_GlobalStorage decl -> fprintf f "@[<2>%a;@]" pp_global_storage decl | D_Pragma (name, args) -> fprintf f "@[<2>pragma@ %a %a;@]" pp_print_string name (pp_comma_list pp_expr) args let pp_t f ast = let pp_blank_line f () = pp_print_space f (); pp_print_cut f () in fprintf f "@[%a@]" (pp_print_list ~pp_sep:pp_blank_line pp_decl) ast let ty_to_string = asprintf "%a" pp_ty let t_to_string ast = asprintf "%a" pp_t ast let literal_to_string = asprintf "%a" pp_literal let pp_version f version = pp_print_string f @@ match version with `ASLv0 -> "ASLv0" | `ASLv1 -> "ASLv1" | `Any -> "any" herd-herdtools7-1ca343e/asllib/PP.mli000066400000000000000000000073301475314470400174350ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) (** Pretty-printers for ASL ASTs. *) open AST (** {1 Utils} *) type 'a printer = Format.formatter -> 'a -> unit (** A general pretty-printer type. *) (* Available from 4.12.0 *) val pp_print_seq : ?pp_sep:unit printer -> 'a printer -> 'a Seq.t printer (** Re-exported from stdlib 4.12, print q sequence from its elements. *) val pp_pos : 'a annotated printer val pp_pos_str : 'a annotated -> string val pp_pos_str_no_char : 'a annotated -> string (** Print a position. *) (** {1 AST pretty-printers} *) val pp_literal : literal printer (** Print a literal from its components.*) val pp_expr : expr printer (** Pretty-print an expression. *) val pp_ty : ty printer (** Pretty-print a type. *) val pp_typed_identifier : typed_identifier printer (** Pretty-print a variable and its type. *) val pp_bitfields : bitfield list printer (** Pretty-print a list of bitfields. *) val pp_lexpr : lexpr printer (** Pretty-print the left-hand side of an assignment. *) val pp_for_direction : for_direction -> string (** Pretty-print keyword of for loop direction *) val pp_stmt : stmt printer (** Pretty-print a statement. *) val pp_slice : slice printer (** Pretty-print a slice. *) val pp_slice_list : slice list printer (** Pretty-print a list of slices. *) val pp_int_constraint : int_constraint printer (** Pretty-print an int constraint. *) val pp_int_constraints : int_constraint list printer (** Pretty-print a list of int constraints. *) val pp_local_decl_item : local_decl_item printer (** Pretty-print a local declaration item. *) val pp_pattern : pattern printer (** Pretty-print a pattern. *) val pp_t : t printer (** Print an AST from printer for a literal *) val pp_version : [ `ASLv0 | `ASLv1 | `Any ] printer (** Print the ASL version. *) (** {1 Pretty-print to strings} *) val literal_to_string : literal -> string (** Converts a literal into a string. *) val binop_to_string : binop -> string (** Writes a binop as an ASL operator. *) val unop_to_string : unop -> string (** Writes a unop as an ASL operator. *) val ty_to_string : ty -> string (** Converts a type into a string. *) val t_to_string : t -> string (** [t_to_string v_to_string ast] is a string representing [ast] with literals printed with [v_to_string].*) herd-herdtools7-1ca343e/asllib/Parser.mly000066400000000000000000000621251475314470400203750ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) (* Goals: - Every valid ASLv1 specification is accepted by this parser. - No warnings should be emitted by menhir. - Being somewhat readable Notations: - [unimplemented_XXX] discards the production by the rule and returns a dummy value. Notes: - In some cases, rules ending with <> are not implemented in the AST yet. *) (* ------------------------------------------------------------------------ Parser Config ------------------------------------------------------------------------- *) %parameter (* ------------------------------------------------------------------------ Helpers ------------------------------------------------------------------------- *) %{ open AST open ASTUtils open Desugar let version = V1 let t_bit = T_Bits (E_Literal (L_Int Z.one) |> add_dummy_annotation ~version, []) let zero = E_Literal (L_Int Z.zero) |> add_dummy_annotation ~version let make_ldi_vars (xs, ty) = let make_one x = S_Decl (LDK_Var, LDI_Var x, Some ty, None) |> add_dummy_annotation ~version in List.map make_one xs |> stmt_from_list |> desc let make_ty_decl_subtype (x, s) = let name, _fields = s.desc in let ty = ASTUtils.add_pos_from s (T_Named name) in D_TypeDecl (x, ty, Some s.desc) let prec = let open AST in function | BOR | BAND | IMPL | BEQ -> 1 | EQ_OP | NEQ -> 2 | PLUS | MINUS | OR | EOR | AND | BV_CONCAT -> 3 | MUL | DIV | DIVRM | RDIV | MOD | SHL | SHR -> 4 | POW -> 5 | GT | GEQ | LT | LEQ -> 0 (* Non assoc *) let check_not_same_prec loc op op' = if prec op = prec op' then Error.(fatal_from loc CannotParse) let check_not_binop_same_prec op e = match e.desc with | E_Binop (op', _, _) when op != op' -> check_not_same_prec e op op' | _ -> () let e_binop (e1, op, e2) = let () = check_not_binop_same_prec op e1 and () = check_not_binop_same_prec op e2 in E_Binop (op, e1, e2) let e_call call = E_Call { call with call_type = ST_Function } let s_call call = S_Call { call with call_type = ST_Procedure } let le_var x = LE_Var x.desc |> add_pos_from x let lhs_access ~base ~index ~fields = { base; index; fields; slices=add_dummy_annotation ~version [] } %} (* ------------------------------------------------------------------------- *) %type spec %start spec (* This start-point is for .opn files in arm-pseudocodes for instructions. *) %type opn %start opn (* Parse statements, as one *) %type stmts %start stmts %% (* ------------------------------------------------------------------------ Helpers ------------------------------------------------------------------------- *) (* Pair matching *) let pared(x) == delimited( LPAR, x, RPAR ) let braced(x) == delimited( LBRACE, x, RBRACE ) let bracketed(x) == delimited(LBRACKET, x, RBRACKET) (* Option handling *) (* [some] returns an option, but ensures it is there. *) let some(x) == ~ = x ; (* We reverse the standard [terminated] to increase clarity on some complex rules. *) let terminated_by(x, y) == terminated(y, x) (* Position annotation *) let annotated(x) == desc = x; { { desc; pos_start=$symbolstartpos; pos_end=$endpos; version } } (* ------------------------------------------------------------------------- *) (* List handling *) (* A non-empty comma-separated list. *) let clist1(x) := | x=x; { [ x ] } | h=x; COMMA; t=clist1(x); { h :: t } (* A comma separated list. *) let clist0(x) := { [] } | clist1(x) (* A comma separated list with at least 2 elements. *) let clist2(x) := ~=x; COMMA; li=clist1(x); { x :: li } (* A comma-separated trailing list. *) let tclist0(x) := { [] } | tclist1(x) (* A comma-separated non-empty trailing list. *) let tclist1(x) := | x=x; ioption(COMMA); { [ x ] } | h=x; COMMA; t=tclist1(x); { h :: t } (* A parenthesised comma-separated list *) let plist0(x) == pared(clist0(x)) (* A parenthesised comma-separated list with at least 2 elements. *) let plist2(x) == pared(clist2(x)) (* A parameterized list with at least 1 element *) let list1(x) := | ~=x; { [ x ] } | ~=x; l=list1(x); { x :: l } let end_semicolon == | END; SEMI_COLON; <> | END; { if not Config.allow_no_end_semicolon then Error.fatal_here $startpos $endpos @@ Error.ObsoleteSyntax "Missing ';' after 'end' keyword."; } (* ------------------------------------------------------------------------ First parsing rules ------------------------------------------------------------------------- *) let value := (* Also called literal_expr in grammar.bnf *) | i=INT_LIT ; < L_Int > | b=BOOL_LIT ; < L_Bool > | r=REAL_LIT ; < L_Real > | b=BITVECTOR_LIT ; < L_BitVector > | s=STRING_LIT ; < L_String > let unop == | BNOT ; { BNOT } | MINUS ; { NEG } | NOT ; { NOT } let binop == | AND ; { AND } | BAND ; { BAND } | BOR ; { BOR } | BEQ ; { EQ_OP } | DIV ; { DIV } | DIVRM ; { DIVRM } | EOR ; { EOR } | EQ_OP ; { EQ_OP } | NEQ ; { NEQ } | GT ; { GT } | GEQ ; { GEQ } | IMPL ; { IMPL } | LT ; { LT } | LEQ ; { LEQ } | PLUS ; { PLUS } | MINUS ; { MINUS } | MOD ; { MOD } | MUL ; { MUL } | OR ; { OR } | RDIV ; { RDIV } | SHL ; { SHL } | SHR ; { SHR } | POW ; { POW } | COLON_COLON ; { BV_CONCAT } (* ------------------------------------------------------------------------ Expressions ------------------------------------------------------------------------- *) let field_assign := separated_pair(IDENTIFIER, EQ, expr) let e_else := | ELSE; expr | annotated ( ELSIF; c=expr; THEN; e=expr; ~=e_else; ) let expr := annotated ( (* A union of cexpr, cexpr_cmp, cexpr_add_sub, cepxr mul_div, cexpr_pow, bexpr, expr_term, expr_atom *) | ~=value ; < E_Literal > | ~=IDENTIFIER ; < E_Var > | e1=expr; op=binop; e2=expr; < e_binop > | op=unop; e=expr; < E_Unop > %prec UNOPS | IF; e1=expr; THEN; e2=expr; ~=e_else; < E_Cond > | ~=call; < e_call > | e=expr; ~=slices; < E_Slice > | e1=expr; LLBRACKET; e2=expr; RRBRACKET; < E_GetArray > | e=expr; DOT; x=IDENTIFIER; < E_GetField > | e=expr; DOT; fs=bracketed(clist1(IDENTIFIER)); < E_GetFields > | ~=expr; AS; ~=ty; < E_ATC > | ~=expr; AS; ~=implicit_t_int; < E_ATC > | ~=expr; IN; ~=pattern_set; < E_Pattern > | ~=expr; EQ_OP; ~=pattern_mask; < E_Pattern > | e=expr; NEQ; p=pattern_mask; { E_Pattern (e, Pattern_Not (p) |> add_pos_from p) } | ARBITRARY; COLON; ~=ty; < E_Arbitrary > | e=pared(expr); { E_Tuple [ e ] } (* For E_Record we use an inlined clist0 to avoid a shift/reduce conflict with elided_param_call's empty case *) | t=annotated(IDENTIFIER); LBRACE; RBRACE; { E_Record (add_pos_from t (T_Named t.desc), []) } | t=annotated(IDENTIFIER); fields=braced(clist1(field_assign)); { E_Record (add_pos_from t (T_Named t.desc), fields) } (* Excluded from expr_pattern *) | ~=plist2(expr); < E_Tuple > ) (* ------------------------------------------------------------------------ Types ------------------------------------------------------------------------- *) (* Constrained types helpers *) let constraint_kind_opt := constraint_kind | { UnConstrained } let constraint_kind := | ~=braced(clist1(int_constraint)); < WellConstrained > | braced(MINUS); { PendingConstrained } let int_constraint := | ~=expr; < Constraint_Exact > | e1=expr; SLICING; e2=expr; < Constraint_Range > let expr_pattern := annotated( (* A union of cexpr, cexpr_cmp, cexpr_add_sub, cepxr mul_div, cexpr_pow, bexpr, expr_term, expr_atom *) | ~=value ; < E_Literal > | ~=IDENTIFIER ; < E_Var > | e1=expr_pattern; op=binop; e2=expr; < e_binop > | op=unop; e=expr; < E_Unop > %prec UNOPS | IF; e1=expr; THEN; e2=expr; ~=e_else; < E_Cond > | ~=call; < e_call > | e=expr_pattern; ~=slices; < E_Slice > | e1=expr_pattern; LLBRACKET; e2=expr; RRBRACKET; < E_GetArray > | e=expr_pattern; DOT; x=IDENTIFIER; < E_GetField > | e=expr_pattern; DOT; fs=bracketed(clist1(IDENTIFIER)); < E_GetFields > | ~=expr_pattern; AS; ~=ty; < E_ATC > | ~=expr_pattern; AS; ~=implicit_t_int; < E_ATC > | ~=expr_pattern; IN; ~=pattern_set; < E_Pattern > | ~=expr_pattern; EQ_OP; ~=pattern_mask; < E_Pattern > | e=expr_pattern; NEQ; p=pattern_mask; { E_Pattern (e, Pattern_Not (p) |> add_pos_from p) } | ARBITRARY; COLON; ~=ty; < E_Arbitrary > | e=pared(expr_pattern); { E_Tuple [ e ] } (* For E_Record we use an inlined clist0 to avoid a shift/reduce conflict with elided_param_call *) | t=annotated(IDENTIFIER); LBRACE; RBRACE; { E_Record (add_pos_from t (T_Named t.desc), []) } | t=annotated(IDENTIFIER); fields=braced(clist1(field_assign)); { E_Record (add_pos_from t (T_Named t.desc), fields) } ) let pattern_mask == annotated(~=MASK_LIT; < Pattern_Mask >) let pattern_list := annotated(~=clist1(pattern); < Pattern_Any >) let pattern := annotated ( | ~=expr_pattern; < Pattern_Single > | e1=expr_pattern; SLICING; e2=expr; < Pattern_Range > | MINUS; { Pattern_All } | LEQ; ~=expr; < Pattern_Leq > | GEQ; ~=expr; < Pattern_Geq > | ~=plist2(pattern); < Pattern_Tuple > ) | pattern_mask | pattern_set let pattern_set := | braced(pattern_list) | annotated ( BNOT; ~=braced(pattern_list); < Pattern_Not > ) let fields := braced(tclist0(typed_identifier)) let fields_opt := { [] } | fields (* Slices *) let slices := bracketed(clist1(slice)) let slice := | ~=expr; < Slice_Single > | e1=expr; COLON; e2=expr; < Slice_Range > | e1=expr; PLUS_COLON; e2=expr; < Slice_Length > | COLON; e=expr; { Slice_Length(zero, e) } | e1=expr; STAR_COLON; e2=expr; < Slice_Star > (* Bitfields *) let bitfields_opt := { [] } | bitfields let bitfields := braced(tclist0(bitfield)) let bitfield := | s=slices ; x=IDENTIFIER ; { BitField_Simple (x, s) } | s=slices ; x=IDENTIFIER ; bf=bitfields ; { BitField_Nested (x, s, bf) } | s=slices ; x=IDENTIFIER ; ty=as_ty ; { BitField_Type (x, s, ty) } (* Also called ty in grammar.bnf *) let ty := annotated ( | INTEGER; c = constraint_kind_opt; < T_Int > | REAL; { T_Real } | BOOLEAN; { T_Bool } | STRING; { T_String } | BIT; { t_bit } | BITS; ~=pared(expr); ~=bitfields_opt; < T_Bits > | l=plist0(ty); < T_Tuple > | name=IDENTIFIER; < T_Named > | ARRAY; LLBRACKET; e=expr; RRBRACKET; OF; t=ty; { T_Array (ArrayLength_Expr e, t) } ) let ty_decl := ty | annotated ( | ENUMERATION; l=braced(tclist1(IDENTIFIER)); < T_Enum > | RECORD; l=fields_opt; < T_Record > | EXCEPTION; l=fields_opt; < T_Exception > ) (* Constructs on ty *) (* Begin AsTy *) let as_ty := COLON; ty (* End *) (* Begin TypedIdentifier *) let typed_identifier := pair(IDENTIFIER, as_ty) (* End *) let ty_opt == ioption(as_ty) let implicit_t_int == annotated ( ~=constraint_kind ; ) (* ------------------------------------------------------------------------ Statements ------------------------------------------------------------------------- *) (* Left-hand-side expressions and helpers *) let basic_lexpr := | base=annotated(IDENTIFIER); fields=nested_fields; { lhs_access ~base ~index:None ~fields } | base=annotated(IDENTIFIER); LLBRACKET; idx=expr; RRBRACKET; fields=nested_fields; { lhs_access ~base ~index:(Some idx) ~fields } let nested_fields := | { [] } | DOT; h=annotated(IDENTIFIER); t=nested_fields; { h :: t } let sliced_basic_lexpr := | ~=basic_lexpr; <> | basic=basic_lexpr; slices=annotated(slices); { {basic with slices} } let discard_or_sliced_basic_lexpr := | MINUS; { None } | ~=sliced_basic_lexpr; < Some > let discard_or_field := | MINUS; { None } | ~=annotated(IDENTIFIER); < Some > let lexpr := | ~=sliced_basic_lexpr; < desugar_lhs_access > | ~=annotated(plist2(discard_or_sliced_basic_lexpr)); < desugar_lhs_tuple > | annotated( | MINUS; { LE_Discard } | x=annotated(IDENTIFIER); DOT; flds=bracketed(clist2(IDENTIFIER)); { LE_SetFields (le_var x, flds, []) } | x=annotated(IDENTIFIER); DOT; flds=pared(clist2(discard_or_field)); { desugar_lhs_fields_tuple x flds } ) (* Decl items are another kind of left-hand-side expressions, which appear only on declarations. They cannot have setter calls or set record fields, they have to declare new variables. *) let discard_or_identifier := | MINUS; { fresh_var "__ldi_discard" } | ~=IDENTIFIER; <> let decl_item := | ~=discard_or_identifier ; < LDI_Var > | ~=plist2(discard_or_identifier) ; < LDI_Tuple > (* ------------------------------------------------------------------------- *) (* Statement helpers *) let local_decl_keyword_non_var := | LET ; { LDK_Let } | CONSTANT ; { LDK_Constant } (* Var is inlined inside stmt as it has differing production choices | VAR ; { LDK_Var } *) let global_decl_keyword_non_var := | LET ; { GDK_Let } | CONSTANT ; { GDK_Constant } | CONFIG ; { GDK_Config } (* Var conflicts with global_uninit_var and as such is inlined in the decl production | VAR ; { GDK_Var } *) let pass == { S_Pass } let assign(x, y) == ~=x ; EQ ; ~=y ; < S_Assign > let direction := | TO; { AST.Up } | DOWNTO; { AST.Down } let case_alt := annotated( WHEN; pattern=pattern_list; where=ioption(WHERE; expr); ARROW; stmt=stmt_list; { { pattern; where; stmt } } ) let case_otherwise == OTHERWISE; ARROW; otherwise_stmt=stmt_list; { otherwise_stmt } let case_alt_list == list1(case_alt) let otherwise == OTHERWISE; ARROW; stmt_list let otherwise_opt := ioption(otherwise) let catcher := WHEN; ~=ioption(terminated(IDENTIFIER, COLON)); ~=ty; ARROW; ~=stmt_list; <> let loop_limit := ioption(LOOPLIMIT; expr) let option_eq_expr := ioption(EQ; expr) let stmt := annotated ( | terminated_by(end_semicolon, | IF; e=expr; THEN; s1=stmt_list; s2=s_else; | CASE; ~=expr; OF; alt=case_alt_list; { desugar_case_stmt expr alt (S_Unreachable |> ASTUtils.add_pos_from expr)} | CASE; ~=expr; OF; alt=case_alt_list; ~=case_otherwise; { desugar_case_stmt expr alt case_otherwise } | WHILE; ~=expr; ~=loop_limit; DO; ~=stmt_list; | FOR; index_name=IDENTIFIER; EQ; start_e=expr; dir=direction; end_e=expr; limit=loop_limit; DO; body=stmt_list; { S_For { index_name; start_e; end_e; dir; body; limit } } | TRY; s=stmt_list; CATCH; c=list1(catcher); o=otherwise_opt; < S_Try > ) | terminated_by(SEMI_COLON, | PASS; pass | RETURN; ~=option(expr); < S_Return > | ~=call; < s_call > | ASSERT; e=expr; < S_Assert > | ~=local_decl_keyword_non_var; ~=decl_item; ~=ty_opt; EQ; ~=some(expr); < S_Decl > | le=lexpr; EQ; e=expr; < S_Assign > | call=annotated(call); EQ; rhs=expr; { desugar_setter call [] rhs } | call=annotated(call); DOT; fld=IDENTIFIER; EQ; rhs=expr; { desugar_setter call [fld] rhs } | call=annotated(call); DOT; flds=bracketed(clist2(IDENTIFIER)); EQ; rhs=expr; { desugar_setter call flds rhs } | ldk=local_decl_keyword_non_var; lhs=decl_item; ty=as_ty; EQ; call=annotated(elided_param_call); { desugar_elided_parameter ldk lhs ty call} | VAR; ldi=decl_item; ty=ty_opt; e=option_eq_expr; { S_Decl (LDK_Var, ldi, ty, e) } | VAR; ~=clist2(IDENTIFIER); ~=as_ty; < make_ldi_vars > | VAR; lhs=decl_item; ty=as_ty; EQ; call=annotated(elided_param_call); { desugar_elided_parameter LDK_Var lhs ty call} | PRINTLN; args=plist0(expr); { S_Print { args; newline = true; debug = false } } | PRINT; args=plist0(expr); { S_Print { args; newline = false; debug = false } } | DEBUG; args=plist0(expr); { S_Print { args; newline = true; debug = true } } | UNREACHABLE; LPAR; RPAR; { S_Unreachable } | REPEAT; ~=stmt_list; UNTIL; ~=expr; ~=loop_limit; < S_Repeat > | THROW; e=expr; { S_Throw (Some (e, None)) } | THROW; { S_Throw None } | PRAGMA; x=IDENTIFIER; e=clist0(expr); < S_Pragma > ) ) let stmt_list := ~ = list1(stmt) ; let s_else := annotated ( | ELSIF; e=expr; THEN; s1=stmt_list; s2=s_else; | pass ) | ELSE; stmt_list (* ------------------------------------------------------------------------ Declarations ------------------------------------------------------------------------- *) let with_opt == { [] } | WITH; ~=fields; <> let subtype := SUBTYPES; ~=IDENTIFIER; ~=with_opt; <> let subtype_opt := ioption(subtype) let opt_typed_identifier := pair(IDENTIFIER, ty_opt) let return_type := ARROW; ty let params_opt := { [] } | braced(clist1(opt_typed_identifier)) (* Uses a dummy call_type, overriden when used above *) let opt_call_args == { [] } | plist0(expr) let call := | name=IDENTIFIER; args=plist0(expr); { { name; params=[]; args; call_type = ST_Function } } | name=IDENTIFIER; params=braced(clist1(expr)); args=opt_call_args; { { name; params; args; call_type = ST_Function } } let elided_param_call := | name=IDENTIFIER; LBRACE; RBRACE; args=plist0(expr); { { name; params=[]; args; call_type = ST_Function } } | name=IDENTIFIER; LBRACE; COMMA; params=clist1(expr); RBRACE; args=opt_call_args; { { name; params; args; call_type = ST_Function } } let func_args := plist0(typed_identifier) let maybe_empty_stmt_list := stmt_list | annotated({ S_Pass }) let func_body == delimited(BEGIN, maybe_empty_stmt_list, end_semicolon) let recurse_limit := ioption(RECURSELIMIT; expr) let ignored_or_identifier := | MINUS; { global_ignored () } | IDENTIFIER let decl := annotated ( (* Begin func_decl *) | FUNC; name=IDENTIFIER; ~=params_opt; ~=func_args; ~=return_type; ~=recurse_limit; body=func_body; { D_Func { name; parameters = params_opt; args = func_args; body = SB_ASL body; return_type = Some return_type; subprogram_type = ST_Function; recurse_limit; builtin = false; } } (* End *) (* Begin procedure_decl *) | FUNC; name=IDENTIFIER; ~=params_opt; ~=func_args; body=func_body; { D_Func { name; parameters = params_opt; args = func_args; body = SB_ASL body; return_type = None; subprogram_type = ST_Procedure; recurse_limit = None; builtin = false; } } (* End *) (* Begin getter *) | GETTER; name=IDENTIFIER; ~=params_opt; ~=func_args; ~=return_type; ~=func_body; { D_Func { name; parameters = params_opt; args = func_args; return_type = Some return_type; body = SB_ASL func_body; subprogram_type = ST_Getter; recurse_limit = None; builtin = false; } } (* End *) (* Begin setter *) | SETTER; name=IDENTIFIER; ~=params_opt; ~=func_args; EQ; v=typed_identifier; ~=func_body; { D_Func { name; parameters = params_opt; args = v :: func_args; return_type = None; body = SB_ASL func_body; subprogram_type = ST_Setter; recurse_limit = None; builtin = false; } } (* End *) | terminated_by(SEMI_COLON, (* Begin type_decl *) | TYPE; x=IDENTIFIER; OF; t=ty_decl; ~=subtype_opt; < D_TypeDecl > (* End *) (* Begin subtype_decl *) | TYPE; x=IDENTIFIER; s=annotated(subtype); < make_ty_decl_subtype > (* End *) (* Begin global_storage *) | keyword=global_decl_keyword_non_var; name=ignored_or_identifier; ty=option(as_ty); EQ; initial_value=some(expr); { D_GlobalStorage { keyword; name; ty; initial_value } } | VAR; name=ignored_or_identifier; ty=option(as_ty); EQ; initial_value=some(expr); { D_GlobalStorage { keyword=GDK_Var; name; ty; initial_value } } (* End *) (* Begin global_uninit_var *) | VAR; name=ignored_or_identifier; ty=some(as_ty); { D_GlobalStorage { keyword=GDK_Var; name; ty; initial_value=None}} (* End *) (* Begin global_pragma *) | PRAGMA; x=IDENTIFIER; e=clist0(expr); < D_Pragma > (* End *) ) ) (* Begin AST *) let spec := terminated(list(decl), EOF) (* End *) let opn := body=stmt; EOF; { [ D_Func { name = "main"; args = []; parameters = []; body = SB_ASL body; return_type = None; subprogram_type = ST_Procedure; recurse_limit = None; builtin = false; } |> ASTUtils.add_pos_from body ] } let stmts := terminated(stmt_list,EOF) herd-herdtools7-1ca343e/asllib/Parser0.mly000066400000000000000000000552231475314470400204560ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) %{ module Prelude = struct open AST open ASTUtils let version = V0 let build_expr_conds = let make_cond { desc = c, e_then; _ } e_else = E_Cond (c, e_then, e_else) in fun (elseifs, e) -> List.fold_right (map2_desc make_cond) elseifs e let build_stmt_conds (s_elsifs, s_else) = let s_else = match s_else with Some s -> s | None -> s_pass in let folder { desc = c, s_then; _ } s_else = S_Cond (c, s_then, s_else) in List.fold_right (map2_desc folder) s_elsifs s_else let t_bit = T_Bits (E_Literal (L_Int Z.one) |> add_dummy_annotation ~version, []) let make_ldi_vars (ty, xs) = let make_one x = S_Decl (LDK_Var, LDI_Var x, Some ty, None) |> add_dummy_annotation ~version in List.map make_one xs |> stmt_from_list |> desc let make_func name args return_type body = let subprogram_type = match return_type with | Some _ -> ST_Function | None -> ST_Procedure and parameters = [] and recurse_limit = None in D_Func { name; args; return_type; body; parameters; subprogram_type; recurse_limit; builtin = false; } let make_concat es = match es with | [] -> E_Literal (L_BitVector Bitvector.empty) | [ bv ] -> bv |> desc | bv :: bvs -> List.fold_left (binop BV_CONCAT) bv bvs |> desc end open Prelude open Desugar %} %token IDENTIFIER STRING_LIT %token MASK_LIT %token BITS_LIT %token INT_LIT %token REAL_LIT %token BOOL_LIT %token QUALIFIER %token AMP %token AMP_AMP %token AND %token ARRAY %token ASSERT %token BANG %token BANG_EQ %token BAR_BAR %token BIT %token BITS %token BOOLEAN %token CARET %token CASE %token CATCH %token COLON %token COMMA %token CONFIG %token CONSTANT %token CONSTRAINED_UNPRED %token DEBUG %token DEDENT %token DIV %token DO %token DOT %token DOT_DOT %token DOWNTO %token ELSE %token ELSIF %token ENUMERATION %token EOF %token EOL %token EOR %token EQ %token EQ_EQ %token EQ_GT %token FOR %token GT %token GT_EQ %token GT_GT %token IF %token IFF %token IMPLEM_DEFINED %token IMPLIES %token IN %token INDENT %token INTEGER %token IS %token LET %token LBRACE %token LBRACE_LBRACE %token LBRACK %token LIMIT %token LPAREN %token LT %token LT_EQ %token LT_LT %token MINUS %token MOD %token NOT %token OF %token OR %token OTHERWISE %token PLUS %token PLUS_COLON %token PLUS_PLUS %token QUOT %token RBRACE %token RBRACE_RBRACE %token RBRACK %token REAL %token RECORD %token REM %token REPEAT %token RETURN %token RPAREN %token SEE %token SEMICOLON %token SLASH %token STAR %token THEN %token THROW %token TO %token TRY %token TYPE %token TYPEOF %token UNDEFINED %token UNKNOWN %token UNPREDICTABLE %token UNTIL %token UU_ARRAY %token UU_BUILTIN %token UU_CONDITIONAL %token UU_CONFIG %token UU_DECODE %token UU_ENCODING %token UU_EVENT %token UU_EXCEPTIONTAKEN %token UU_EXECUTE %token UU_FIELD %token UU_FUNCTION %token UU_GUARD %token UU_INSTRUCTION %token UU_INSTRUCTION_SET %token UU_MAP %token UU_NEWEVENT %token UU_NEWMAP %token UU_NOP %token UU_OPCODE %token UU_OPERATOR_ONE %token UU_OPERATOR_TWO %token UU_POSTDECODE %token UU_READWRITE %token UU_REGISTER %token UU_UNALLOCATED %token UU_UNPREDICTABLE %token UU_UNPREDICTABLE_UNLESS %token UU_WRITE %token WHEN %token WHILE %type simple_stmts %type simple_stmt_list %type stmts %type spec %type opn %start spec %start opn %nonassoc ELSE %left COLON %left AMP_AMP BAR_BAR IMPLIES %left EQ_EQ BANG_EQ %nonassoc GT_EQ LT_EQ LT GT IN %left PLUS MINUS EOR AND OR %left STAR SLASH MOD LT_LT GT_GT DIV %left CARET %nonassoc UNOPS %left LBRACK %left DOT %% let filter(x) == ~=x; { List.filter_map Fun.id x } let some(x) == ~=x; < Some > let spec := list(EOL); terminated (filter(list(decl)), EOF) let opn := list(EOL); body=list(stmts); EOF; { let body = ASTUtils.stmt_from_list body in AST.[ D_Func { name = "main"; args = []; parameters = []; body = SB_ASL body; return_type = None; subprogram_type = ST_Procedure; recurse_limit = None; builtin = false; } |> ASTUtils.add_pos_from body ] } let decl == | variable_decl | function_decl | procedure_decl | getter_decl | setter_decl | type_decl let annotated(x) == desc = x; { AST.{ desc; pos_start=$symbolstartpos; pos_end=$endpos; version }} let unimplemented_decl(x) == x; { None } let unimplemented_ty(x) == x; { AST.(T_Bits (ASTUtils.expr_of_int 0, [])) } let type_decl == some ( annotated ( | terminated_by(SEMICOLON; EOL, | TYPE; x=tidentdecl; EQ; ~=ty; { AST.(D_TypeDecl (x, ty, None)) } | RECORD; x=tidentdecl; fields=annotated(braced(nlist(field))); { AST.(D_TypeDecl (x, ASTUtils.add_pos_from fields (T_Record fields.desc), None)) } | ENUMERATION; x=tidentdecl; li=annotated(braced(ntclist(ident))); { AST.(D_TypeDecl (x, ASTUtils.add_pos_from li (T_Enum li.desc), None)) } | TYPE; t=tidentdecl; ty=annotated(unimplemented_ty(<>)); { AST.D_TypeDecl (t, ty, None) } ) | TYPE; x=tidentdecl; IS; li=annotated(pared(ntclist(field_ns))); EOL; { AST.(D_TypeDecl (x, ASTUtils.add_pos_from li (T_Record li.desc), None)) } ) ) let tidentdecl == | ident | q=QUALIFIER; DOT; i=ident; { q ^ "_" ^ i } let field == terminated(field_ns, SEMICOLON) let field_ns == t=ty; x=ident; { (x, t) } let bracketed(x) == delimited(LBRACK, x, RBRACK) let braced(x) == delimited(LBRACE, x, RBRACE) let pared(x) == delimited(LPAREN, x, RPAREN) let clist(x) == { [] } | nclist(x) let nlist(x) == nonempty_list(x) let nclist(x) == separated_nonempty_list(COMMA, x) let nnclist(x) == h=x; COMMA; t=nclist(x); { h::t } let terminated_by (y, x) == terminated(x, y) let ntclist(x) := | ~=x; ioption(COMMA); { [ x ] } | ~=x; COMMA; t=ntclist(x); { x :: t } let tclist(x) == loption(ntclist(x)) let ty := annotated ( | ty_non_tuple | ~=pared(nnclist(ty)); < AST.T_Tuple > ) let bitfields == braced(tclist(bitfield)) let bitfield == s=nclist(slice); x=ident; { AST.BitField_Simple(x, s) } let ty_non_tuple == | INTEGER; { AST.(T_Int UnConstrained) } | REAL; { AST.T_Real } | BOOLEAN; { AST.T_Bool } | ~=tident; < AST.T_Named > | BIT; { t_bit } | BITS; e=pared(expr); { AST.(T_Bits (e, [])) } | BITS; e=pared(expr); b=bitfields; { AST.(T_Bits (e, b)) } (* | tident; pared(clist(expr)); <> *) | unimplemented_ty ( | TYPEOF; pared(expr); <> | ARRAY; bracketed(ixtype); OF; ty; <> ) let ixtype == | tident; <> | expr; DOT_DOT; expr; <> let tident == | typeident | q=QUALIFIER; DOT; i=typeident; { q ^ "_" ^ i } let typeident == typeid let typeid == ident let ident == IDENTIFIER let ident_plus_record == ident | RECORD; { "record" } let qualident == | q=QUALIFIER; DOT; i=ident; { q ^ "_" ^ i } | ident | RECORD; { "record" } let unimplemented_expr(x) == x; { AST.(E_Literal (L_Bool true)) } let nargs == { [] } let sexpr := binop_expr(sexpr, abinop) let expr := | binop_expr(expr, binop) | annotated ( e1=expr; COLON; e2=expr; { AST.E_Binop (BV_CONCAT, e1, e2) } ) let binop_expr(e, b) == | pared(expr) | annotated ( | ~=literal_expression; < AST.E_Literal > | ~=qualident; < AST.E_Var > | name=qualident; args=pared(clist(expr)); params=nargs; { AST.E_Call { name; args; params; call_type = ST_Function } } | name=qualident; params=braced(clist(expr)); args=pared(clist(expr)); { AST.E_Call { name; args; params; call_type = ST_Function } } | ~=unop; ~=e; < AST.E_Unop > %prec UNOPS | e1=e; op=b; e2=e; { AST.E_Binop (op, e1, e2) } | ~=pared(nnclist(expr)); < AST.E_Tuple > | IF; c=expr; THEN; e=expr; ~=e_else; < AST.E_Cond > | ~=e; DOT; ~=ident; < AST.E_GetField > | ~=e; DOT; ~=bracketed(clist(ident)); < AST.E_GetFields > | ~=e; ~=bracketed(clist(slice)); < AST.E_Slice > | ~=bracketed(clist(expr)); < make_concat > | ~=e; IN; ~=bpattern; < AST.E_Pattern > | ~=e; EQ_EQ; ~=pattern_mask; < AST.E_Pattern > | ~=e; ~=annotated(BANG_EQ; pm=pattern_mask; < AST.Pattern_Not >); < AST.E_Pattern > | ~=annotated(ty_non_tuple); UNKNOWN; < AST.E_Arbitrary > (* | ~=e; LT; ~=clist(slice); GT; < AST.E_Slice > *) | unimplemented_expr( | ty_non_tuple; IMPLEM_DEFINED; ioption(STRING_LIT); <> ) ) let e_elseif == annotated ( ELSIF; c=expr; THEN; e=expr; <> ) let e_else == ~=list(e_elseif); ELSE; ~=expr; < build_expr_conds > let slice == | ~=sexpr; < AST.Slice_Single > | e1=sexpr; COLON; e2=sexpr; < AST.Slice_Range > | e1=sexpr; PLUS_COLON; e2=sexpr; < AST.Slice_Length > let literal_expression == | ~=BOOL_LIT; < AST.L_Bool > | ~=INT_LIT; < AST.L_Int > | ~=REAL_LIT; < AST.L_Real > | ~=BITS_LIT; < AST.L_BitVector > | ~=STRING_LIT; < AST.L_String > let array_length == | expr | expr; DOT_DOT; expr let gdk == | CONSTANT; { AST.GDK_Constant } | CONFIG; { AST.GDK_Config } | { AST.GDK_Var } let variable_decl == terminated_by (SEMICOLON; EOL, | some (annotated ( | gdk=gdk; t=ty; x=qualident; EQ; e=expr; { AST.D_GlobalStorage { keyword = gdk; name = x; initial_value = Some e; ty = Some t; } } | ty=ty; x=qualident; { AST.D_GlobalStorage { keyword = GDK_Var; name = x; ty = Some ty; initial_value = None; }} | ARRAY; ty=ty; x=qualident; e=bracketed(array_length); { AST.(D_GlobalStorage { keyword = GDK_Var; name = x; ty = Some (T_Array (ArrayLength_Expr e, ty) |> ASTUtils.add_dummy_annotation ~version); initial_value = None; })} ))) let function_decl == | some (annotated ( ty=ty; name=qualident; args=pared(clist(formal)); body=indented_block; { make_func name args (Some ty) (SB_ASL body) } )) | some (annotated ( LPAREN; RPAREN; name=qualident; args=pared(clist(formal)); body=indented_block; { make_func name args None (SB_ASL body) } )) | unimplemented_decl ( some(ty); qualident; pared(clist(formal)); ioption(SEMICOLON); EOL ) let getter_decl == | some (annotated ( | ~=ty; name=qualident; body = indented_block; { let open AST in let return_type = Some ty and args = [] and body = SB_ASL body and subprogram_type = ST_EmptyGetter and recurse_limit = None and parameters = [] in D_Func { name; args; return_type; body; parameters; subprogram_type; recurse_limit; builtin = false; } } | ~=ty; name=qualident; body=opt_indented_block; SEMICOLON; EOL; { let open AST in let return_type = Some ty and args = [] and body = SB_ASL body and recurse_limit = None and subprogram_type = ST_EmptyGetter and parameters = [] in D_Func { name; args; return_type; body; parameters; subprogram_type; recurse_limit; builtin = false; } } | ~=ty; name=qualident; args=bracketed(clist(formal)); body=indented_block; { let open AST in let return_type = Some ty and subprogram_type = ST_Getter and recurse_limit = None and body = SB_ASL body and parameters = [] in D_Func { name; args; return_type; body; parameters; subprogram_type; recurse_limit; builtin = false; } } )) | unimplemented_decl ( ty; qualident; bracketed(clist(formal)); ioption(SEMICOLON); EOL ) let setter_args == bracketed(clist(sformal)) let setter_decl == some (annotated ( | name=qualident; EQ; ~=ty; ~=ident; body=indented_block; { let open AST in let return_type = None and parameters = [] and body = SB_ASL body and subprogram_type = ST_EmptySetter and recurse_limit = None and args = [ (ident, ty) ] in D_Func { name; args; return_type; body; parameters; subprogram_type; recurse_limit; builtin = false; } } | name=qualident; args=setter_args; EQ; ~=ty; ~=ident; body=indented_block; { let open AST in let return_type = None and parameters = [] and body = SB_ASL body and subprogram_type = ST_Setter and recurse_limit = None and args = (ident, ty) :: args in D_Func { name; args; return_type; body; parameters; subprogram_type; recurse_limit; builtin = false; } } )) | unimplemented_decl ( qualident; ioption(setter_args); EQ; ty; ident; ioption(SEMICOLON); EOL ) let procedure_decl == | some (annotated ( name=qualident; args=pared(clist(formal)); body=indented_block; { let open AST in let return_type = None and parameters = [] and body = SB_ASL body and recurse_limit = None and subprogram_type = ST_Procedure in D_Func { name; args; return_type; body; parameters; subprogram_type; recurse_limit; builtin = false; } } )) | unimplemented_decl ( qualident; pared(clist(formal)); ioption(SEMICOLON); EOL ) let sformal == t=ty; ioption(AMP); x=ident; { (x, t) } let formal == t=ty; x=ident; { (x, t) } let s_eol == EOL; { ASTUtils.s_pass } let opt_indented_block == | indented_block | s_eol let indented_block == | EOL; INDENT; ~=nlist(stmts); DEDENT; < ASTUtils.stmt_from_list > (* Always terminated by EOL or indented block. *) let possibly_empty_block == | indented_block | simple_stmts | s_eol let unimplemented_stmts(x) == x; { AST.S_Pass } let stmts == | simple_stmts | compound_stmt (* Always terminated by EOL *) let simple_stmts == | annotated ( ~=simple_stmt_list; ~=simple_if_stmt; < AST.S_Seq > ) | terminated(simple_stmt_list, EOL) let simple_stmt_list == ~=nlist(simple_stmt); < ASTUtils.stmt_from_list > let simple_stmt == | assignment_stmt | annotated ( terminated_by (SEMICOLON, | name=qualident; args=pared(clist(expr)); params=nargs; { AST.S_Call { name; args; params ; call_type = ST_Procedure } } | name=qualident; params=braced(nclist(expr)); args=pared(clist(expr)); { AST.S_Call { name; args; params ; call_type = ST_Procedure } } | RETURN; ~=ioption(expr); < AST.S_Return > | ASSERT; ~=expr; < AST.S_Assert > | DEBUG; e=expr; { AST.S_Print { args = [ e ]; newline = true; debug = true } } | unimplemented_stmts ( | UNPREDICTABLE; ioption(pared(<>)); <> | CONSTRAINED_UNPRED; <> | IMPLEM_DEFINED; pared(ident); <> | UNDEFINED; ioption(pared(<>)); <> | IMPLEM_DEFINED; ioption(STRING_LIT); <> | SEE; pared(expr); <> | SEE; STRING_LIT; <> | SEE; ident; <> | THROW; ident; <> ) )) let ident_or_record_or_discard == | ~=ident_plus_record; <> | MINUS; { ASTUtils.fresh_var "__ldi_discard" } let assignment_stmt == annotated ( terminated_by(SEMICOLON, | le=lexpr; EQ; e=expr; < AST.S_Assign > | ty=annotated(ty_non_tuple); x=ident_plus_record; EQ; ~=expr; { AST.(S_Decl (LDK_Var, LDI_Var x, Some ty, Some expr)) } | CONSTANT; ty=annotated(ty_non_tuple); x=ident_plus_record; EQ; ~=expr; { AST.(S_Decl (LDK_Let, LDI_Var x, Some ty, Some expr)) } | CONSTANT; x=ident; EQ; ~=expr; { AST.(S_Decl (LDK_Let, LDI_Var x, None, Some expr)) } | CONSTANT; names=pared(nnclist(ident_or_record_or_discard)); EQ; e=expr; { AST.S_Decl (LDK_Let, LDI_Tuple names, None, Some e) } | t=annotated(ty_non_tuple); li=nclist(ident); < make_ldi_vars > )) let le_var == ~=qualident; < AST.LE_Var > let lexpr_ignore == { AST.LE_Discard } let unimplemented_lexpr(x) == x; lexpr_ignore let lexpr := annotated ( | MINUS; lexpr_ignore | le_var | ~=lexpr; ~=bracketed(clist(slice)); < AST.LE_Slice > | ~=lexpr; LT; ~=clist(slice); GT; < AST.LE_Slice > | ~=pared(nclist(lexpr)); < AST.LE_Destructuring > | ~=lexpr; DOT; ~=ident; < AST.LE_SetField > | l=lexpr; DOT; f=bracketed(clist(ident)); { AST.LE_SetFields (l, f, []) } | unimplemented_lexpr ( | bracketed(nclist(lexpr)); <> ) ) let simple_if_stmt == annotated ( IF; ~=expr; THEN; ~=simple_stmt_list; ~=simple_else_opt; EOL; < AST.S_Cond > ) let simple_else_opt == ~=list(simple_elsif); ~=ioption(ELSE; simple_stmt_list); < build_stmt_conds > let simple_else == ~=list(simple_elsif); ~= some(ELSE; simple_stmt_list); < build_stmt_conds > let simple_elsif == annotated ( ELSIF; ~=expr; THEN; ~=simple_stmt_list; <> ) let compound_stmt == annotated ( | conditional_stmt | repetitive_stmt | unimplemented_stmts ( | catch_stmt; <> ) ) let conditional_stmt == (* The first two cases of asl.ott are united in this simpler rule. *) | IF; ~=expr; THEN; ~=possibly_empty_block; ~=s_else; < AST.S_Cond > | IF; ~=expr; THEN; ~=simple_stmt_list; ~=simple_else; EOL; < AST.S_Cond > | CASE; ~=expr; OF; EOL; INDENT; alts=list(alt); DEDENT; { desugar_case_stmt expr alts (AST.S_Unreachable |> ASTUtils.add_pos_from expr) } let s_elsif == annotated ( ELSIF; ~=expr; THEN; ~=possibly_empty_block; <> ) let s_else == ~=list(s_elsif); ~=ioption(ELSE; possibly_empty_block); < build_stmt_conds > let alt == annotated ( | WHEN; pattern=pattern_list; where=opt_where; stmt=possibly_empty_block; { AST.{ pattern; where; stmt } } | WHEN; pattern=pattern_list; where=opt_where; stmt=simple_if_stmt; { AST.{ pattern; where; stmt } } | loc=annotated(OTHERWISE); stmt=possibly_empty_block; { AST.{ pattern = ASTUtils.add_pos_from loc Pattern_All; where = None; stmt } } ) let opt_where == | { None } | ~=ioption(AND; expr); EQ_GT; <> let otherwise == annotated (OTHERWISE; possibly_empty_block) let pattern_mask == annotated(~=MASK_LIT; ) let pattern_all == annotated(MINUS; { AST.Pattern_All }) let pattern_list == annotated(~=nclist(pattern); < AST.Pattern_Any >) let pattern == | bpattern | pattern_mask | pattern_all | annotated ( | ~=annotated ( | ~=literal_expression; < AST.E_Literal > | ~=qualident; < AST.E_Var > ); < AST.Pattern_Single > ) let bpattern == annotated(braced(~=nclist(apattern); < AST.Pattern_Any >)) let apattern == | annotated ( | ~=expr; < AST.Pattern_Single > | e1=expr; DOT_DOT; e2=expr; < AST.Pattern_Range > ) | pattern_all | pattern_mask let repetitive_stmt == | FOR; index_name=ident; EQ; start_e=expr; dir=direction; end_e=expr; limit=ioption(LIMIT; expr); body=indented_block; { AST.S_For { index_name; start_e; dir; end_e; body; limit } } | WHILE; ~=expr; ~=ioption(LIMIT; expr); DO; ~=indented_block; | REPEAT; ~=indented_block; UNTIL; ~=expr; ~=ioption(LIMIT; expr); SEMICOLON; EOL; let direction == | TO; { AST.Up } | DOWNTO; { AST.Down } let catch_stmt == | TRY; indented_block; CATCH; ident; EOL; INDENT; nlist(catcher); ioption(otherwise); DEDENT; <> let catcher == WHEN; expr; opt_indented_block; <> let unop == | BANG ; { AST.BNOT } | MINUS ; { AST.NEG } | NOT ; { AST.NOT } let unimplemented_binop(x) == x ; { AST.PLUS } let abinop == | AND ; { AST.AND } | AMP_AMP ; { AST.BAND } | BAR_BAR ; { AST.BOR } | DIV ; { AST.DIV } | EOR ; { AST.EOR } | EQ_EQ ; { AST.EQ_OP } | BANG_EQ ; { AST.NEQ } | GT_EQ ; { AST.GEQ } | IMPLIES ; { AST.IMPL } | LT_EQ ; { AST.LEQ } | PLUS ; { AST.PLUS } | MINUS ; { AST.MINUS } | MOD ; { AST.MOD } | STAR ; { AST.MUL } | OR ; { AST.OR } | SLASH ; { AST.RDIV } | LT_LT ; { AST.SHL } | GT_GT ; { AST.SHR } | unimplemented_binop( | CARET ) let binop == | abinop | LT ; { AST.LT } | GT ; { AST.GT } herd-herdtools7-1ca343e/asllib/ParserConfig.mli000066400000000000000000000032451475314470400215010ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) (** The CONFIG module signature for the ASL1 Parser *) module type CONFIG = sig val allow_no_end_semicolon : bool (** Allow no semicolon after [end]. *) end herd-herdtools7-1ca343e/asllib/README.mld000066400000000000000000000106561475314470400200530ustar00rootroot00000000000000{0 Getting started with ASLRef} {1 Disclaimer} This material covers both ASLv0 (viz, the existing ASL pseudocode language which appears in the Arm Architecture Reference Manual) and ASLv1, a new, experimental, and as yet unreleased version of ASL. This material is work in progress, more precisely at pre-Alpha quality as per Arm’s quality standards. In particular, this means that it would be premature to base any production tool development on this material. However, any feedback, question, query and feature request would be most welcome; those can be sent to Arm’s Architecture Formal Team Lead Jade Alglave or by raising issues or PRs to the herdtools7 github repository. {1 Installation} {2 Pre-requisites} The following steps have been tested on Unix. + Install ocaml and opam (ocaml package manager), see {{: https://ocaml.org/docs/up-and-running#installing-ocaml} the manual}. For example on MacOS: {@bash[ $ brew install opam ]} + Install dependencies: {@bash[ $ opam install dune menhir zarith ]} {2 Building} + Clone herdtools7: {@bash[ $ git clone https://github.com/herd/herdtools7.git ]} + Build and install into a location [$PREFIX]: {@bash[ $ make build install PREFIX=$PREFIX ]} It's done! {2 Checking} If [$PREFIX] is in your [$PATH], the following command should return a similar output: {@bash[ $ aslref --version aslref version 7.56+03 rev 7aa9d1f3cee2598ec64f14372f210e008ac5510f ]} Please note that building herdtools7 depends on the installation path [$PREFIX]. If you want to move your installation from [$OLD_PREFIX] to [$NEW_PREFIX], please use: {@bash[ make uninstall PREFIX=$OLD_PREFIX make build install PREFIX=$NEW_PREFIX ]} {1 Running} {2 Basics} If [my-test.asl] contains a valid ASL specification returning 0, the tool [aslref] does not print anything and exit with code 0. {@bash[ $ aslref my-test.asl ]} {2 Version and type-checking flags} For a complete reference of arguments, see [aslref --help]. {3 ASL Version} To use the ASLv0 parser, use the [-0] flag. The default parser is the ASLv1, but you can still specify it with [-1]. {3 Type-checking} There are currently three possible type-checking settings, listed here from the strongest to the weakest: + [--type-check-strict] fails on the first error encountered while type-checking the specification. This is the default setting for ASLv1. + [--type-check-warn] logs every error on the standard error output, but does not fail on any of them. The specification might not be able to run through the interpreter if the type-checking phase failed. + [--no-type-check] only performs minimal type-inference. Tries to fail as little as possible. This is the default for ASLv0. {2 Examples} You can find examples of ASLv1 specifications that [aslref] supports in {{: https://github.com/herd/herdtools7/tree/master/asllib/tests/asl/required} [herdtools7/asllib/tests/asl/required]}. {2 Building HTML pages locally from .mld files} In the directory [herdtools7/]: + Run: {@bash[ $ dune build @doc ]} + Open [_build/default/_doc/_html/herdtools7/aslref.html] {2 Contributing examples and regression tests} We welcome new examples to add to the ASL Reference Document. We use those examples as regression tests also. Therefore, please make sure that each example which appears in an ASL Reference Document also appears in the corresponding asllib test suite, as follows. {3 Contributing dynamic semantics examples to the ASL Reference document and regression suite} In [asllib/tests/ASLSemanticsReference.t]: - add a new example [SemanticsRule.MyNewTest.asl]; - edit [run.t] to mention [SemanticsRule.MyNewTest.asl]. In [herdtools7]: - do: [dune runtest asllib] - if the tests pass, do: [dune promote] In [asllib/ASLSemanticsReference.mld] - add a new section titled [SemanticsRule.MyNewTest.asl]; - add a comment about how the test should behave and why. {3 Contributing typing examples to the ASL Reference document and regression suite} In [asllib/tests/ASLTypingReference.t]: - add a new example [TypingRule.MyNewTest.asl]; - edit [run.t] to mention [TypingRule.MyNewTest.asl]. In [herdtools7]: - do: [dune runtest asllib] - if the tests pass, do: [dune promote] In [asllib/ASLTypingReference.mld] - add a new section titled [TypingRule.MyNewTest.asl]; - add a comment about how the test should behave and why. herd-herdtools7-1ca343e/asllib/Serialize.ml000066400000000000000000000324071475314470400206770ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) open AST open Printf type buffer = Buffer.t type 'a printer = buffer -> 'a -> unit let addb buf s = Buffer.add_string buf s let with_buf f = (* Same default value as Stdlib.Printf *) let b = Buffer.create 64 in let () = f b in Buffer.contents b let pp_list pp_elt buf = let pp_elt_with_sep elt = addb buf "; "; pp_elt buf elt in function | [] -> addb buf "[]" | h :: t -> addb buf "["; pp_elt buf h; List.iter pp_elt_with_sep t; addb buf "]" let pp_option pp_some buf = function | None -> addb buf "None" | Some elt -> bprintf buf "Some (%a)" pp_some elt let pp_pair pp_left pp_right f (left, right) = bprintf f "(%a, %a)" pp_left left pp_right right let pp_pair_list pp_left pp_right = pp_list (pp_pair pp_left pp_right) let pp_string f = bprintf f "%S" let pp_id_assoc pp_elt = pp_pair_list pp_string pp_elt let pp_annotated f buf { desc; _ } = bprintf buf "annot (%a)" f desc let pp_binop : binop -> string = function | AND -> "AND" | BAND -> "BAND" | BEQ -> "BEQ" | BOR -> "BOR" | DIV -> "DIV" | DIVRM -> "DIVRM" | EOR -> "EOR" | EQ_OP -> "EQ_OP" | GT -> "GT" | GEQ -> "GEQ" | IMPL -> "IMPL" | LT -> "LT" | LEQ -> "LEQ" | MOD -> "MOD" | MINUS -> "MINUS" | MUL -> "MUL" | NEQ -> "NEQ" | OR -> "OR" | PLUS -> "PLUS" | RDIV -> "RDIV" | SHL -> "SHL" | SHR -> "SHR" | POW -> "POW" | BV_CONCAT -> "BV_CONCAT" let pp_unop = function BNOT -> "BNOT" | NOT -> "NOT" | NEG -> "NEG" let pp_literal f = function | L_Int i -> bprintf f "L_Int (Z.of_string \"%a\")" Z.bprint i | L_Bool b -> bprintf f "L_Bool %B" b | L_Real r -> bprintf f "L_Real (Q.of_string \"%a\")" Q.bprint r | L_BitVector bv -> bprintf f "L_BitVector (Bitvector.of_string %S)" (Bitvector.to_string bv) | L_String s -> bprintf f "L_String %S" s | L_Label s -> bprintf f "L_Label %S" s let subprogram_type_to_string = function | ST_Function -> "ST_Function" | ST_Procedure -> "ST_Procedure" | ST_Setter -> "ST_Setter" | ST_Getter -> "ST_Getter" | ST_EmptyGetter -> "ST_EmptyGetter" | ST_EmptySetter -> "ST_EmptySetter" let pp_subprogram_type f st = addb f (subprogram_type_to_string st) let rec pp_expr = let pp_desc f = function | E_Literal v -> bprintf f "E_Literal (%a)" pp_literal v | E_Var x -> bprintf f "E_Var %S" x | E_ATC (e, t) -> bprintf f "E_ATC (%a, %a)" pp_expr e pp_ty t | E_Binop (op, e1, e2) -> bprintf f "E_Binop (%s, %a, %a)" (pp_binop op) pp_expr e1 pp_expr e2 | E_Unop (op, e) -> bprintf f "E_Unop (%s, %a)" (pp_unop op) pp_expr e | E_Call { name; args; params; call_type } -> bprintf f "E_Call {name=%S; args=%a; params=%a; call_type=%a}" name pp_expr_list args pp_expr_list params pp_subprogram_type call_type | E_Slice (e, args) -> bprintf f "E_Slice (%a, %a)" pp_expr e pp_slice_list args | E_Cond (e1, e2, e3) -> bprintf f "E_Cond (%a, %a, %a)" pp_expr e1 pp_expr e2 pp_expr e3 | E_GetArray (e1, e2) -> bprintf f "E_GetArray (%a, %a)" pp_expr e1 pp_expr e2 | E_GetEnumArray (e1, e2) -> bprintf f "E_GetEnumArray (%a, %a)" pp_expr e1 pp_expr e2 | E_GetField (e, x) -> bprintf f "E_GetField (%a, %S)" pp_expr e x | E_GetFields (e, x) -> bprintf f "E_GetFields (%a, %a)" pp_expr e (pp_list pp_string) x | E_GetItem (e, i) -> bprintf f "E_GetItem (%a, %d)" pp_expr e i | E_Record (ty, li) -> bprintf f "E_Record (%a, %a)" pp_ty ty (pp_id_assoc pp_expr) li | E_Tuple es -> addb f "E_Tuple "; pp_expr_list f es | E_Array { length; value } -> bprintf f "E_Array { length=(%a); value=(%a) }" pp_expr length pp_expr value | E_EnumArray { enum; labels; value } -> bprintf f "E_EnumArray { enum=%S; labels=(%a); value=(%a) }" enum (pp_list pp_string) labels pp_expr value | E_Arbitrary ty -> bprintf f "E_Arbitrary (%a)" pp_ty ty | E_Pattern (e, p) -> bprintf f "E_Pattern (%a, %a)" pp_expr e pp_pattern p in fun f e -> pp_annotated pp_desc f e and pp_expr_list f = pp_list pp_expr f and pp_slice_list f = pp_list pp_slice f and pp_slice f = function | Slice_Single e -> bprintf f "Slice_Single (%a)" pp_expr e | Slice_Range (e1, e2) -> bprintf f "Slice_Range (%a, %a)" pp_expr e1 pp_expr e2 | Slice_Length (e1, e2) -> bprintf f "Slice_Length (%a, %a)" pp_expr e1 pp_expr e2 | Slice_Star (e1, e2) -> bprintf f "Slice_Star (%a, %a)" pp_expr e1 pp_expr e2 and pp_pattern = let pp_desc f = function | Pattern_All -> addb f "Pattern_All" | Pattern_Any li -> addb f "Pattern_Any "; pp_list pp_pattern f li | Pattern_Geq e -> bprintf f "Pattern_Geq (%a)" pp_expr e | Pattern_Leq e -> bprintf f "Pattern_Leq (%a)" pp_expr e | Pattern_Mask m -> bprintf f "Pattern_Mask (Bitvector.mask_of_string \"%S\")" (Bitvector.mask_to_canonical_string m) | Pattern_Not p -> bprintf f "Pattern_Not (%a)" pp_pattern p | Pattern_Range (e1, e2) -> bprintf f "Pattern_Range (%a, %a)" pp_expr e1 pp_expr e2 | Pattern_Single e -> bprintf f "Pattern_Single (%a)" pp_expr e | Pattern_Tuple li -> addb f "Pattern_Tuple "; pp_list pp_pattern f li in fun f p -> pp_annotated pp_desc f p and pp_ty = let pp_desc f = function | T_Int cs -> bprintf f "T_Int (%a)" pp_int_constraints cs | T_Real -> addb f "T_Real" | T_String -> addb f "T_String" | T_Bool -> addb f "T_Bool" | T_Bits (bits_constraint, fields) -> bprintf f "T_Bits (%a, %a)" pp_expr bits_constraint pp_bitfields fields | T_Enum enum_type_desc -> addb f "T_Enum "; pp_list pp_string f enum_type_desc | T_Tuple li -> addb f "T_Tuple "; pp_list pp_ty f li | T_Array (length, elt_type) -> bprintf f "T_Array (%a, %a)" pp_array_length length pp_ty elt_type | T_Record li -> addb f "T_Record "; pp_id_assoc pp_ty f li | T_Exception li -> addb f "T_Exception "; pp_id_assoc pp_ty f li | T_Named identifier -> bprintf f "T_Named %S" identifier in fun f s -> pp_annotated pp_desc f s and pp_array_length f = function | ArrayLength_Expr e -> bprintf f "ArrayLength_Expr (%a)" pp_expr e | ArrayLength_Enum (enum, labels) -> bprintf f "ArrayLength_Enum (%s, %a)" enum (pp_list pp_string) labels and pp_bitfield f = function | BitField_Simple (name, slices) -> bprintf f "BitField_Simple (%S, %a)" name pp_slice_list slices | BitField_Nested (name, slices, bitfields) -> bprintf f "BitField_Nested (%S, %a, %a)" name pp_slice_list slices pp_bitfields bitfields | BitField_Type (name, slices, ty) -> bprintf f "BitField_Type (%S, %a, %a)" name pp_slice_list slices pp_ty ty and pp_bitfields f bitfields = pp_list pp_bitfield f bitfields and pp_int_constraint f = function | Constraint_Exact e -> bprintf f "Constraint_Exact (%a)" pp_expr e | Constraint_Range (bot, top) -> bprintf f "Constraint_Range (%a, %a)" pp_expr bot pp_expr top and pp_int_constraints f = function | UnConstrained -> addb f "UnConstrained" | WellConstrained cs -> addb f "WellConstrained "; pp_list pp_int_constraint f cs | PendingConstrained -> addb f "PendingConstrained" | Parameterized (i, x) -> bprintf f "Parameterized (%d, %S)" i x let rec pp_lexpr = let pp_desc f = function | LE_Var x -> bprintf f "LE_Var %S" x | LE_Slice (le, args) -> bprintf f "LE_Slice (%a, %a)" pp_lexpr le pp_slice_list args | LE_SetArray (le, e) -> bprintf f "LE_SetArray (%a, %a)" pp_lexpr le pp_expr e | LE_SetEnumArray (le, e) -> bprintf f "LE_SetEnumArray (%a, %a)" pp_lexpr le pp_expr e | LE_SetField (le, x) -> bprintf f "LE_SetField (%a, %S)" pp_lexpr le x | LE_SetFields (le, x, _) -> bprintf f "LE_SetFields (%a, %a)" pp_lexpr le (pp_list pp_string) x | LE_Discard -> addb f "LE_Discard" | LE_Destructuring les -> addb f "LE_Destructuring "; pp_list pp_lexpr f les in fun f le -> pp_annotated pp_desc f le let pp_local_decl_keyboard f k = pp_string f (match k with | LDK_Var -> "LDK_Var" | LDK_Constant -> "LDK_Constant" | LDK_Let -> "LDK_Let") let pp_local_decl_item f = function | LDI_Var s -> bprintf f "LDI_Var %S" s | LDI_Tuple ldis -> bprintf f "LDI_Tuple %a" (pp_list pp_string) ldis let rec pp_stmt = let pp_desc f = function | S_Pass -> addb f "SPass" | S_Seq (s1, s2) -> bprintf f "S_Seq (%a, %a)" pp_stmt s1 pp_stmt s2 | S_Assign (le, e) -> bprintf f "S_Assign (%a, %a)" pp_lexpr le pp_expr e | S_Call { name; args; params; call_type } -> bprintf f "S_Call {name=%S; args=%a; params=%a; call_type=%a}" name pp_expr_list args pp_expr_list params pp_subprogram_type call_type | S_Cond (e, s1, s2) -> bprintf f "S_Cond (%a, %a, %a)" pp_expr e pp_stmt s1 pp_stmt s2 | S_Return e -> bprintf f "S_Return (%a)" (pp_option pp_expr) e | S_Assert e -> bprintf f "S_Assert (%a)" pp_expr e | S_While (e, limit, s) -> bprintf f "S_While(%a, %a, %a)" pp_expr e (pp_option pp_expr) limit pp_stmt s | S_Repeat (s, e, limit) -> bprintf f "S_Repeat(%a, %a, %a)" pp_stmt s pp_expr e (pp_option pp_expr) limit | S_For { index_name; start_e; end_e; body; dir; limit } -> bprintf f "S_For { index_name=%S; start=%a; dir=%s; end_=%a; body=%a; limit=%a \ }" index_name pp_expr start_e (match dir with Up -> "Up" | Down -> "Down") pp_expr end_e pp_stmt body (pp_option pp_expr) limit | S_Decl (ldk, ldi, ty_opt, e_opt) -> bprintf f "S_Decl (%a, %a, %a, %a)" pp_local_decl_keyboard ldk pp_local_decl_item ldi (pp_option pp_ty) ty_opt (pp_option pp_expr) e_opt | S_Throw opt -> bprintf f "S_Throw (%a)" (pp_option (pp_pair pp_expr (pp_option pp_ty))) opt | S_Try (s, catchers, otherwise) -> bprintf f "S_Try (%a, %a, %a)" pp_stmt s (pp_list pp_catcher) catchers (pp_option pp_stmt) otherwise | S_Print { args; newline; debug } -> bprintf f "S_Print { args = %a; newline = %B; debug = %B }" (pp_list pp_expr) args newline debug | S_Unreachable -> addb f "S_Unreachable" | S_Pragma (name, exprs) -> bprintf f "S_Pragma (%S, %a)" name (pp_list pp_expr) exprs in fun f s -> pp_annotated pp_desc f s and pp_catcher f (name, ty, s) = bprintf f "(%a, %a, %a)" (pp_option pp_string) name pp_ty ty pp_stmt s let pp_gdk f gdk = addb f @@ match gdk with | GDK_Config -> "GDK_Config" | GDK_Constant -> "GDK_Constant" | GDK_Let -> "GDK_Let" | GDK_Var -> "GDK_Var" let pp_body f = function | SB_ASL s -> bprintf f "SB_ASL (%a)" pp_stmt s | SB_Primitive b -> bprintf f "SB_Primitive %B" b let pp_decl f d = match d.desc with | D_Func { name; args; body; return_type; parameters; subprogram_type } -> bprintf f "D_Func { name=%S; args=%a; body=%a; return_type=%a; parameters=%a; \ subprogram_type=%a }" name (pp_id_assoc pp_ty) args pp_body body (pp_option pp_ty) return_type (pp_list (pp_pair pp_string (pp_option pp_ty))) parameters pp_subprogram_type subprogram_type | D_GlobalStorage { name; keyword; ty; initial_value } -> bprintf f "D_GlobalConst { name=%S; keyword=%a; ty=%a; initial_value=%a}" name pp_gdk keyword (pp_option pp_ty) ty (pp_option pp_expr) initial_value | D_TypeDecl (name, type_desc, subty_opt) -> bprintf f "D_TypeDecl (%S, %a, %a)" name pp_ty type_desc (pp_option (pp_pair pp_string (pp_id_assoc pp_ty))) subty_opt | D_Pragma (name, exprs) -> bprintf f "D_Pragma (%S, %a)" name (pp_list pp_expr) exprs let pp_t f ast = addb f "let open AST in let annot = ASTUtils.add_dummy_pos in "; pp_list pp_decl f ast let t_to_string ast = with_buf @@ fun b -> pp_t b ast herd-herdtools7-1ca343e/asllib/Serialize.mli000066400000000000000000000035571475314470400210540ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) (** This module converts an AST into a valid ocaml string that represents it. *) open AST val subprogram_type_to_string : subprogram_type -> string type 'a printer = Buffer.t -> 'a -> unit (** Type of printers used here. *) val pp_t : t printer (** Print an AST into the buffer. *) val t_to_string : t -> string (** Converts the AST into an ocaml string. *) herd-herdtools7-1ca343e/asllib/SideEffect.ml000066400000000000000000000473161475314470400207560ustar00rootroot00000000000000type identifier = AST.identifier module ISet = ASTUtils.ISet module IMap = ASTUtils.IMap module TimeFrame = struct type t = Constant | Config | Execution let equal t1 t2 = match (t1, t2) with | Constant, Constant | Config, Config | Execution, Execution -> true | Constant, (Config | Execution) | Config, (Constant | Execution) | Execution, (Config | Constant) -> false let is_before t1 t2 = match (t1, t2) with | Constant, Constant | Config, Config | Execution, Execution -> true | Config, Execution | Constant, (Config | Execution) -> true | Execution, Config | (Config | Execution), Constant -> false let max t1 t2 = if is_before t1 t2 then t2 else t1 let of_ldk = let open AST in function LDK_Constant -> Constant | LDK_Let | LDK_Var -> Execution let of_gdk = let open AST in function | GDK_Constant -> Constant | GDK_Config -> Config | GDK_Let | GDK_Var -> Execution end type read = { name : identifier; time_frame : TimeFrame.t; immutable : bool } type t = | ReadsLocal of read | WritesLocal of identifier | ReadsGlobal of read | WritesGlobal of identifier | ThrowsException of identifier | CallsRecursive of identifier | PerformsAssertions | NonDeterministic type side_effect = t let equal (t1 : t) (t2 : t) : bool = match (t1, t2) with | ReadsLocal { name = s1 }, ReadsLocal { name = s2 } | WritesLocal s1, WritesLocal s2 | ReadsGlobal { name = s1 }, ReadsGlobal { name = s2 } | WritesGlobal s1, WritesGlobal s2 | ThrowsException s1, ThrowsException s2 | CallsRecursive s1, CallsRecursive s2 -> String.equal s1 s2 | PerformsAssertions, PerformsAssertions | NonDeterministic, NonDeterministic -> true | ( ReadsLocal _, ( WritesLocal _ | ReadsGlobal _ | WritesGlobal _ | ThrowsException _ | CallsRecursive _ | PerformsAssertions | NonDeterministic ) ) | ( WritesLocal _, ( ReadsGlobal _ | WritesGlobal _ | ThrowsException _ | CallsRecursive _ | PerformsAssertions | NonDeterministic ) ) | ( ReadsGlobal _, ( WritesGlobal _ | ThrowsException _ | CallsRecursive _ | PerformsAssertions | NonDeterministic ) ) | ( WritesGlobal _, ( ThrowsException _ | CallsRecursive _ | PerformsAssertions | NonDeterministic ) ) | ThrowsException _, (CallsRecursive _ | PerformsAssertions | NonDeterministic) | CallsRecursive _, (PerformsAssertions | NonDeterministic) | PerformsAssertions, NonDeterministic | ( ( WritesLocal _ | ReadsGlobal _ | WritesGlobal _ | ThrowsException _ | CallsRecursive _ | PerformsAssertions | NonDeterministic ), ReadsLocal _ ) | ( ( ReadsGlobal _ | WritesGlobal _ | ThrowsException _ | CallsRecursive _ | PerformsAssertions | NonDeterministic ), WritesLocal _ ) | ( ( WritesGlobal _ | ThrowsException _ | CallsRecursive _ | PerformsAssertions | NonDeterministic ), ReadsGlobal _ ) | ( ( ThrowsException _ | CallsRecursive _ | PerformsAssertions | NonDeterministic ), WritesGlobal _ ) | ( (CallsRecursive _ | PerformsAssertions | NonDeterministic), ThrowsException _ ) | (PerformsAssertions | NonDeterministic), CallsRecursive _ | NonDeterministic, PerformsAssertions -> false let compare (t1 : t) (t2 : t) : int = match (t1, t2) with | ReadsLocal { name = s1 }, ReadsLocal { name = s2 } | WritesLocal s1, WritesLocal s2 | ReadsGlobal { name = s1 }, ReadsGlobal { name = s2 } | WritesGlobal s1, WritesGlobal s2 | ThrowsException s1, ThrowsException s2 | CallsRecursive s1, CallsRecursive s2 -> String.compare s1 s2 | PerformsAssertions, PerformsAssertions | NonDeterministic, NonDeterministic -> 0 | ( ReadsLocal _, ( WritesLocal _ | ReadsGlobal _ | WritesGlobal _ | ThrowsException _ | CallsRecursive _ | PerformsAssertions | NonDeterministic ) ) | ( WritesLocal _, ( ReadsGlobal _ | WritesGlobal _ | ThrowsException _ | CallsRecursive _ | PerformsAssertions | NonDeterministic ) ) | ( ReadsGlobal _, ( WritesGlobal _ | ThrowsException _ | CallsRecursive _ | PerformsAssertions | NonDeterministic ) ) | ( WritesGlobal _, ( ThrowsException _ | CallsRecursive _ | PerformsAssertions | NonDeterministic ) ) | ThrowsException _, (CallsRecursive _ | PerformsAssertions | NonDeterministic) | CallsRecursive _, (PerformsAssertions | NonDeterministic) | PerformsAssertions, NonDeterministic -> 1 | ( ( WritesLocal _ | ReadsGlobal _ | WritesGlobal _ | ThrowsException _ | CallsRecursive _ | PerformsAssertions | NonDeterministic ), ReadsLocal _ ) | ( ( ReadsGlobal _ | WritesGlobal _ | ThrowsException _ | CallsRecursive _ | PerformsAssertions | NonDeterministic ), WritesLocal _ ) | ( ( WritesGlobal _ | ThrowsException _ | CallsRecursive _ | PerformsAssertions | NonDeterministic ), ReadsGlobal _ ) | ( ( ThrowsException _ | CallsRecursive _ | PerformsAssertions | NonDeterministic ), WritesGlobal _ ) | ( (CallsRecursive _ | PerformsAssertions | NonDeterministic), ThrowsException _ ) | (PerformsAssertions | NonDeterministic), CallsRecursive _ | NonDeterministic, PerformsAssertions -> -1 let pp_print f = let open Format in function | ReadsLocal { name = s } -> fprintf f "ReadsLocal %S" s | WritesLocal s -> fprintf f "WritesLocal %S" s | ReadsGlobal { name = s } -> fprintf f "ReadsGlobal %S" s | WritesGlobal s -> fprintf f "WritesGlobal %S" s | ThrowsException s -> fprintf f "ThrowsException %S" s | CallsRecursive s -> fprintf f "CallsRecursive %S" s | PerformsAssertions -> fprintf f "PerformsAssertions" | NonDeterministic -> fprintf f "NonDeterministic" let time_frame = function | ReadsLocal { time_frame } | ReadsGlobal { time_frame } -> time_frame | WritesLocal _ | WritesGlobal _ | NonDeterministic | CallsRecursive _ | ThrowsException _ -> TimeFrame.Execution | PerformsAssertions -> TimeFrame.Constant let is_pure = function | ReadsLocal _ | ReadsGlobal _ | NonDeterministic | PerformsAssertions -> true | WritesLocal _ | WritesGlobal _ | CallsRecursive _ | ThrowsException _ -> false (* Begin IsSymbolicallyEvaluable *) let is_symbolically_evaluable = function | ReadsLocal { immutable } | ReadsGlobal { immutable } -> immutable | WritesLocal _ | WritesGlobal _ | NonDeterministic | CallsRecursive _ | ThrowsException _ | PerformsAssertions -> false (* End *) (* SES = Side Effect Set *) module SES = struct (* This module uses an abstraction over a set of side-effects. *) type t = { (* Decomposition into subsets *) local_reads : ISet.t; (* Only store reads to mutable variables *) local_writes : ISet.t; global_reads : ISet.t; (* Only store reads to mutable variables *) global_writes : ISet.t; thrown_exceptions : ISet.t; calls_recursives : ISet.t; assertions_performed : bool; non_determinism : bool; (* Invariants kept *) max_local_read_time_frame : TimeFrame.t * identifier; max_global_read_time_frame : TimeFrame.t * identifier; } let empty = { local_reads = ISet.empty; local_writes = ISet.empty; global_reads = ISet.empty; global_writes = ISet.empty; thrown_exceptions = ISet.empty; calls_recursives = ISet.empty; assertions_performed = false; non_determinism = false; max_local_read_time_frame = (TimeFrame.Constant, "1"); max_global_read_time_frame = (TimeFrame.Constant, "1"); } let witnessed_time_frame_max ((t1, _w1) as tw1) ((t2, _w2) as tw2) = if TimeFrame.is_before t1 t2 then tw2 else tw1 let max_time_frame ses = if ISet.is_empty ses.local_writes && ISet.is_empty ses.global_writes && ISet.is_empty ses.thrown_exceptions && ISet.is_empty ses.calls_recursives && not ses.non_determinism then TimeFrame.max (fst ses.max_global_read_time_frame) (fst ses.max_local_read_time_frame) else TimeFrame.Execution let is_pure ses = ISet.is_empty ses.local_writes && ISet.is_empty ses.global_writes && ISet.is_empty ses.thrown_exceptions && ISet.is_empty ses.calls_recursives let all_reads_are_immutable ses = ISet.is_empty ses.local_reads && ISet.is_empty ses.global_reads (* Begin SESIsSymbolicallyEvaluable *) let is_symbolically_evaluable ses = is_pure ses && (not ses.non_determinism) && (not ses.assertions_performed) && all_reads_are_immutable ses (* End *) (* Begin SESIsDeterministic *) let is_deterministic ses = not ses.non_determinism (* End *) let add_local_read s time_frame immutable ses = let local_reads = if immutable then ses.local_reads else ISet.add s ses.local_reads and max_local_read_time_frame = witnessed_time_frame_max (time_frame, s) ses.max_local_read_time_frame in { ses with local_reads; max_local_read_time_frame } let add_local_write s ses = { ses with local_writes = ISet.add s ses.local_writes } let add_global_read s time_frame immutable ses = let global_reads = if immutable then ses.global_reads else ISet.add s ses.global_reads and max_global_read_time_frame = witnessed_time_frame_max (time_frame, s) ses.max_global_read_time_frame in { ses with global_reads; max_global_read_time_frame } let add_global_write s ses = { ses with global_writes = ISet.add s ses.global_writes } let add_thrown_exception s ses = { ses with thrown_exceptions = ISet.add s ses.thrown_exceptions } let add_calls_recursive s ses = { ses with calls_recursives = ISet.add s ses.calls_recursives } let add_assertion ses = { ses with assertions_performed = true } let add_non_determinism ses = { ses with non_determinism = true } let add_side_effect se ses = match se with | ReadsLocal { name; time_frame; immutable } -> add_local_read name time_frame immutable ses | ReadsGlobal { name; time_frame; immutable } -> add_global_read name time_frame immutable ses | WritesLocal s -> add_local_write s ses | WritesGlobal s -> add_global_write s ses | ThrowsException s -> add_thrown_exception s ses | CallsRecursive s -> add_calls_recursive s ses | PerformsAssertions -> add_assertion ses | NonDeterministic -> add_non_determinism ses (* Constructors *) let reads_local s t immutable = add_local_read s t immutable empty let writes_local s = add_local_write s empty let reads_global s t immutable = add_global_read s t immutable empty let writes_global s = add_global_write s empty let throws_exception s = add_thrown_exception s empty let calls_recursive s = add_calls_recursive s empty let performs_assertions = add_assertion empty let non_deterministic = add_non_determinism empty let equal ses1 ses2 = ses1 == ses2 || ISet.equal ses1.calls_recursives ses2.calls_recursives && ISet.equal ses1.global_reads ses2.global_reads && ISet.equal ses1.global_writes ses2.global_writes && ISet.equal ses1.local_reads ses2.local_reads && ISet.equal ses1.local_writes ses2.local_writes && ISet.equal ses1.thrown_exceptions ses2.thrown_exceptions && Bool.equal ses1.non_determinism ses2.non_determinism && Bool.equal ses1.assertions_performed ses2.assertions_performed && TimeFrame.equal (fst ses1.max_global_read_time_frame) (fst ses2.max_global_read_time_frame) && TimeFrame.equal (fst ses1.max_global_read_time_frame) (fst ses2.max_global_read_time_frame) let union ses1 ses2 = if ses1 == empty then ses2 else if ses2 == empty then ses1 else { local_reads = ISet.union ses1.local_reads ses2.local_reads; local_writes = ISet.union ses1.local_writes ses2.local_writes; global_reads = ISet.union ses1.global_reads ses2.global_reads; global_writes = ISet.union ses1.global_writes ses2.global_writes; thrown_exceptions = ISet.union ses1.thrown_exceptions ses2.thrown_exceptions; calls_recursives = ISet.union ses1.calls_recursives ses2.calls_recursives; assertions_performed = ses1.assertions_performed || ses2.assertions_performed; non_determinism = ses1.non_determinism || ses2.non_determinism; max_local_read_time_frame = witnessed_time_frame_max ses1.max_local_read_time_frame ses2.max_local_read_time_frame; max_global_read_time_frame = witnessed_time_frame_max ses1.max_global_read_time_frame ses2.max_global_read_time_frame; } (* Properties *) let is_side_effect_free ses = is_pure ses && not ses.assertions_performed let is_side_effect_free_without_global_reads ses = is_side_effect_free ses && ISet.is_empty ses.global_reads let are_non_conflicting ses1 ses2 = if not (ISet.is_empty ses1.calls_recursives) then is_side_effect_free_without_global_reads ses2 else if not (ISet.is_empty ses2.calls_recursives) then is_side_effect_free_without_global_reads ses1 else if not (ISet.is_empty ses1.thrown_exceptions) then is_side_effect_free ses2 else if not (ISet.is_empty ses2.thrown_exceptions) then is_side_effect_free ses1 else ISet.disjoint ses1.global_writes ses2.global_writes && ISet.disjoint ses1.global_writes ses2.global_reads && ISet.disjoint ses1.global_reads ses2.global_writes && ISet.disjoint ses1.local_writes ses2.local_writes && ISet.disjoint ses1.local_writes ses2.local_reads && ISet.disjoint ses1.local_reads ses2.local_writes let choose_side_effect ses = if not (ISet.is_empty ses.global_writes) then WritesGlobal (ISet.choose ses.global_writes) else if not (ISet.is_empty ses.local_writes) then WritesLocal (ISet.choose ses.local_writes) else if not (ISet.is_empty ses.thrown_exceptions) then ThrowsException (ISet.choose ses.thrown_exceptions) else if not (ISet.is_empty ses.calls_recursives) then CallsRecursive (ISet.choose ses.calls_recursives) else if ses.assertions_performed then PerformsAssertions else raise Not_found let make_reads name = { name; time_frame = TimeFrame.Execution; immutable = false } let make_reads_local name = ReadsLocal (make_reads name) let make_reads_global name = ReadsGlobal (make_reads name) let choose_side_effect_with_reads ses = try choose_side_effect ses with Not_found -> if not (ISet.is_empty ses.global_reads) then let name = ISet.choose ses.global_reads in make_reads_global name else if not (ISet.is_empty ses.local_reads) then let name = ISet.choose ses.local_reads in make_reads_global name else raise Not_found let remove_pure ses = { ses with global_reads = ISet.empty; local_reads = ISet.empty } let choose_inter s1 s2 = ISet.inter s1 s2 |> ISet.choose let choose_conflicting_side_effects ses1 ses2 = if not (ISet.is_empty ses1.thrown_exceptions) then ( ThrowsException (ISet.choose ses1.thrown_exceptions), choose_side_effect ses2 ) else if not (ISet.is_empty ses2.thrown_exceptions) then ( choose_side_effect ses1, ThrowsException (ISet.choose ses2.thrown_exceptions) ) else if not (ISet.is_empty ses1.calls_recursives) then ( CallsRecursive (ISet.choose ses1.calls_recursives), choose_side_effect_with_reads ses2 ) else if not (ISet.is_empty ses2.calls_recursives) then ( choose_side_effect_with_reads ses1, CallsRecursive (ISet.choose ses2.calls_recursives) ) else if not (ISet.disjoint ses1.global_writes ses2.global_writes) then let s = choose_inter ses1.global_writes ses2.global_writes in (WritesGlobal s, WritesGlobal s) else if not (ISet.disjoint ses1.global_writes ses2.global_reads) then let name = choose_inter ses1.global_writes ses2.global_reads in (WritesGlobal name, make_reads_global name) else if not (ISet.disjoint ses1.global_reads ses2.global_writes) then let name = choose_inter ses1.global_reads ses2.global_writes in (make_reads_global name, WritesGlobal name) else if not (ISet.disjoint ses1.local_writes ses2.local_writes) then let s = choose_inter ses1.local_writes ses2.local_writes in (WritesLocal s, WritesLocal s) else if not (ISet.disjoint ses1.local_writes ses2.local_reads) then let name = choose_inter ses1.local_writes ses2.local_reads in (WritesLocal name, make_reads_local name) else if not (ISet.disjoint ses1.local_reads ses2.local_writes) then let s = choose_inter ses1.local_reads ses2.local_writes in (make_reads_local s, WritesLocal s) else (choose_side_effect ses1, choose_side_effect ses2) let non_conflicting_union ~fail ses1 ses2 = if ses1 == empty then ses2 else if ses2 == empty then ses1 else if are_non_conflicting ses1 ses2 then union ses1 ses2 else choose_conflicting_side_effects ses1 ses2 |> fail let iterated_union union empty = (* Dichotomic implementation of iterated union. *) (* [unions2 acc [l1; l2; ...; l2n]] is the list [[union l1 l2; union l3 l4; ... union l2n-1 l2n]]. *) let rec unions2 acc = function | [] -> acc | [ h ] -> h :: acc | h1 :: h2 :: t -> unions2 (union h1 h2 :: acc) t in (* [unions li] calls [unions2] on [li] until it only has one element. *) let rec unions = function | [] -> empty | [ h ] -> h | li -> unions2 [] li |> unions in unions let unions = iterated_union union empty let non_conflicting_unions ~fail = iterated_union (non_conflicting_union ~fail) empty let union3 ses1 ses2 ses3 = union ses1 (union ses2 ses3) let get_calls_recursives ses = ses.calls_recursives let remove_locals ses = { ses with local_reads = ISet.empty; local_writes = ISet.empty; max_local_read_time_frame = (TimeFrame.Constant, "1"); } let remove_thrown_exceptions ses = { ses with thrown_exceptions = ISet.empty } let remove_calls_recursives ses = { ses with calls_recursives = ISet.empty } let remove_assertions ses = { ses with assertions_performed = false } let remove_non_determinism ses = { ses with non_determinism = false } let filter_thrown_exceptions f ses = { ses with thrown_exceptions = ISet.filter f ses.thrown_exceptions } let filter_calls_recursives f ses = { ses with calls_recursives = ISet.filter f ses.calls_recursives } module SESet = Set.Make (struct type t = side_effect let compare = compare end) let to_side_effect_list ses = let set_map_to_list f s = ISet.fold (fun elt accu -> f elt :: accu) s in let add_if elt test accu = if test then elt :: accu else accu in let add_from_tf f (t, w) set accu = if TimeFrame.equal t TimeFrame.Constant || ISet.mem w set then accu else f w t :: accu in [] |> add_if PerformsAssertions ses.assertions_performed |> add_if NonDeterministic ses.non_determinism |> add_from_tf (fun name time_frame -> ReadsGlobal { name; time_frame; immutable = true }) ses.max_global_read_time_frame ses.global_reads |> add_from_tf (fun name time_frame -> ReadsLocal { name; time_frame; immutable = true }) ses.max_local_read_time_frame ses.local_reads |> set_map_to_list (fun s -> CallsRecursive s) ses.calls_recursives |> set_map_to_list (fun s -> ThrowsException s) ses.thrown_exceptions |> set_map_to_list (fun s -> WritesGlobal s) ses.global_writes |> set_map_to_list make_reads_global ses.global_reads |> set_map_to_list (fun s -> WritesLocal s) ses.local_writes |> set_map_to_list make_reads_local ses.local_reads let to_side_effect_set ses = to_side_effect_list ses |> SESet.of_list let pp_print f ses = let elements = to_side_effect_list ses in let open Format in let pp_sep f () = fprintf f ",@ " in fprintf f "@[[%a]@]" (pp_print_list ~pp_sep pp_print) elements end herd-herdtools7-1ca343e/asllib/SideEffect.mli000066400000000000000000000066451475314470400211270ustar00rootroot00000000000000type identifier = string module TimeFrame : sig type t = Constant | Config | Execution val is_before : t -> t -> bool val max : t -> t -> t val of_ldk : AST.local_decl_keyword -> t val of_gdk : AST.global_decl_keyword -> t end type read = { name : identifier; time_frame : TimeFrame.t; immutable : bool } (** Data type describing a potential side effect associated with an ASL piece of code. *) type t = | ReadsLocal of read (** Reads the local storage element indicated by its argument. *) | WritesLocal of identifier (** Writes to the local variable indicated by its argument. *) | ReadsGlobal of read (** Reads the global storage element indicated by its argument. *) | WritesGlobal of identifier (** Writes to the global variable indicated by its argument. *) | ThrowsException of identifier (** Throws the exception indicated by its argument. *) | CallsRecursive of identifier (** Calls the function indicated by its argument. Can only happen in a strongly-connected component of mutually recursive functions. *) | PerformsAssertions (** Performs an assertion. *) | NonDeterministic (** Uses a non-deterministic construct such as [ARBITRARY: ty]. *) type side_effect = t val equal : t -> t -> bool val compare : t -> t -> int val pp_print : Format.formatter -> t -> unit val time_frame : t -> TimeFrame.t val is_pure : t -> bool val is_symbolically_evaluable : t -> bool (** The module [SES] provides an abstraction over a set of side-effects. *) module SES : sig type t (** A side-effect set. *) (* Constructors *) val empty : t val reads_local : identifier -> TimeFrame.t -> bool -> t val writes_local : identifier -> t val reads_global : identifier -> TimeFrame.t -> bool -> t val writes_global : identifier -> t val throws_exception : identifier -> t val calls_recursive : identifier -> t val performs_assertions : t val non_deterministic : t (* Properties *) val max_time_frame : t -> TimeFrame.t val is_pure : t -> bool val is_symbolically_evaluable : t -> bool val equal : t -> t -> bool val is_deterministic : t -> bool (* Updates *) val add_local_read : identifier -> TimeFrame.t -> bool -> t -> t val add_local_write : identifier -> t -> t val add_global_read : identifier -> TimeFrame.t -> bool -> t -> t val add_global_write : identifier -> t -> t val add_thrown_exception : identifier -> t -> t val add_calls_recursive : identifier -> t -> t val add_side_effect : side_effect -> t -> t val add_assertion : t -> t val add_non_determinism : t -> t val remove_pure : t -> t val remove_locals : t -> t val remove_thrown_exceptions : t -> t val remove_calls_recursives : t -> t val remove_assertions : t -> t val remove_non_determinism : t -> t val filter_thrown_exceptions : (identifier -> bool) -> t -> t val filter_calls_recursives : (identifier -> bool) -> t -> t (* Operations *) val union : t -> t -> t val unions : t list -> t val union3 : t -> t -> t -> t val non_conflicting_union : fail:(side_effect * side_effect -> t) -> t -> t -> t val non_conflicting_unions : fail:(side_effect * side_effect -> t) -> t list -> t val get_calls_recursives : t -> ASTUtils.ISet.t (* Input & output *) val to_side_effect_list : t -> side_effect list val pp_print : Format.formatter -> t -> unit module SESet : Set.S with type elt = side_effect val to_side_effect_set : t -> SESet.t end herd-herdtools7-1ca343e/asllib/SimpleLexer0.mll000066400000000000000000000233121475314470400214300ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) { open Parser0 (* The type token is defined in parser.mli *) let tr_name = function | "AArch32" -> QUALIFIER "AArch32" | "AArch64" -> QUALIFIER "AArch64" | "AND" -> AND | "CONSTRAINED_UNPREDICTABLE" -> CONSTRAINED_UNPRED | "DIV" -> DIV | "EOR" -> EOR | "IMPLEMENTATION_DEFINED" -> IMPLEM_DEFINED | "IN" -> IN | "IFF" -> IFF | "IMPLIES" -> IMPLIES | "MOD" -> MOD | "NOT" -> NOT | "OR" -> OR | "QUOT" -> QUOT | "REM" -> REM | "SEE" -> SEE | "UNDEFINED" -> UNDEFINED | "UNKNOWN" -> UNKNOWN | "UNPREDICTABLE" -> UNPREDICTABLE | "__ExceptionTaken" -> UU_EXCEPTIONTAKEN | "__NOP" -> UU_NOP | "__UNALLOCATED" -> UU_UNALLOCATED | "__UNPREDICTABLE" -> UU_UNPREDICTABLE | "__array" -> UU_ARRAY | "__builtin" -> UU_BUILTIN | "__conditional" -> UU_CONDITIONAL | "__config" -> UU_CONFIG | "__decode" -> UU_DECODE | "__encoding" -> UU_ENCODING | "__event" -> UU_EVENT | "__execute" -> UU_EXECUTE | "__field" -> UU_FIELD | "__function" -> UU_FUNCTION | "__guard" -> UU_GUARD | "__instruction" -> UU_INSTRUCTION | "__instruction_set" -> UU_INSTRUCTION_SET | "__map" -> UU_MAP | "__newmap" -> UU_NEWMAP | "__newevent" -> UU_NEWEVENT | "__operator1" -> UU_OPERATOR_ONE | "__operator2" -> UU_OPERATOR_TWO | "__opcode" -> UU_OPCODE | "__postdecode" -> UU_POSTDECODE | "__readwrite" -> UU_READWRITE | "__register" -> UU_REGISTER | "__unpredictable_unless" -> UU_UNPREDICTABLE_UNLESS | "__write" -> UU_WRITE | "array" -> ARRAY | "assert" -> ASSERT | "bit" -> BIT | "bits" -> BITS | "boolean" -> BOOLEAN | "case" -> CASE | "catch" -> CATCH | "constant" -> CONSTANT | "config" -> CONFIG | "DEBUG" -> DEBUG | "do" -> DO | "downto" -> DOWNTO | "else" -> ELSE | "elsif" -> ELSIF | "enumeration" -> ENUMERATION | "FALSE" -> BOOL_LIT false | "for" -> FOR | "integer" -> INTEGER | "if" -> IF | "is" -> IS | "let" -> LET | "limit" -> LIMIT | "of" -> OF | "otherwise" -> OTHERWISE | "real" -> REAL | "record" -> RECORD | "repeat" -> REPEAT | "return" -> RETURN | "then" -> THEN | "throw" -> THROW | "to" -> TO | "TRUE" -> BOOL_LIT true | "try" -> TRY | "type" -> TYPE | "typeof" -> TYPEOF | "until" -> UNTIL | "when" -> WHEN | "while" -> WHILE | name -> IDENTIFIER name let string_of_token = function | AND -> "AND" | ARRAY -> "array" | ASSERT -> "assert" | BIT -> "bit" | BITS -> "bits" | BOOLEAN -> "boolean" | CASE -> "case" | CATCH -> "catch" | CONFIG -> "config" | CONSTANT -> "constant" | CONSTRAINED_UNPRED -> "CONSTRAINED_UNPREDICTABLE" | DEBUG -> "DEBUG" | DIV -> "DIV" | DO -> "do" | DOWNTO -> "downto" | ELSE -> "else" | ELSIF -> "elsif" | ENUMERATION -> "enumeration" | EOR -> "EOR" | FOR -> "for" | IF -> "if" | IFF -> "IFF" | IMPLEM_DEFINED -> "IMPLEMENTATION_DEFINED" | IMPLIES -> "IMPLIES" | IN -> "IN" | INTEGER -> "integer" | IS -> "is" | MOD -> "MOD" | NOT -> "NOT" | OF -> "of" | OR -> "OR" | OTHERWISE -> "otherwise" | QUOT -> "QUOT" | REAL -> "real" | RECORD -> "record" | REM -> "REM" | REPEAT -> "repeat" | RETURN -> "return" | SEE -> "SEE" | THEN -> "then" | THROW -> "throw" | TO -> "to" | TRY -> "try" | TYPE -> "type" | TYPEOF -> "typeof" | UNDEFINED -> "UNDEFINED" | UNKNOWN -> "UNKNOWN" | UNPREDICTABLE -> "UNPREDICTABLE" | UNTIL -> "until" | UU_ARRAY -> "__array" | UU_BUILTIN -> "__builtin" | UU_CONDITIONAL -> "__conditional" | UU_CONFIG -> "__config" | UU_DECODE -> "__decode" | UU_ENCODING -> "__encoding" | UU_EVENT -> "__event" | UU_EXCEPTIONTAKEN -> "__ExceptionTaken" | UU_EXECUTE -> "__execute" | UU_FIELD -> "__field" | UU_FUNCTION -> "__function" | UU_GUARD -> "__guard" | UU_INSTRUCTION -> "__instruction" | UU_INSTRUCTION_SET -> "__instruction_set" | UU_MAP -> "__map" | UU_NEWEVENT -> "__newevent" | UU_NEWMAP -> "__newmap" | UU_NOP -> "__NOP" | UU_OPCODE -> "__opcode" | UU_OPERATOR_ONE -> "__operator1" | UU_OPERATOR_TWO -> "__operator2" | UU_POSTDECODE -> "__postdecode" | UU_READWRITE -> "__readwrite" | UU_REGISTER -> "__register" | UU_UNALLOCATED -> "__UNALLOCATED" | UU_UNPREDICTABLE -> "__UNPREDICTABLE" | UU_UNPREDICTABLE_UNLESS -> "__unpredictable_unless" | UU_WRITE -> "__write" | WHEN -> "when" | WHILE -> "while" (* Operators *) | AMP -> "&" | AMP_AMP -> "&&" | BANG -> "!" | BANG_EQ -> "!=" | BAR_BAR -> "||" | CARET -> "^" | COLON -> ":" | COMMA -> "," | DOT -> "." | DOT_DOT -> ".." | EQ -> "=" | EQ_EQ -> "==" | EQ_GT -> "=>" | GT -> ">" | GT_EQ -> ">=" | GT_GT -> ">>" | LBRACE -> "{" | LBRACE_LBRACE -> "{{" | LBRACK -> "[" | LIMIT -> "limit" | LPAREN -> "(" | LT -> "<" | LT_EQ -> "<=" | LT_LT -> "<<" | MINUS -> "-" | PLUS -> "+" | PLUS_COLON -> "+:" | PLUS_PLUS -> "++" | RBRACE -> "}" | RBRACE_RBRACE -> "}}" | RBRACK -> "]" | RPAREN -> ")" | SEMICOLON -> ";" | SLASH -> "/" | STAR -> "*" (* Literals *) | BOOL_LIT b -> if b then "TRUE" else "FALSE" | STRING_LIT s -> "\"" ^ s ^ "\"" | BITS_LIT bv -> Bitvector.to_string bv | MASK_LIT m -> "'" ^ Bitvector.mask_to_string m ^ "'" | INT_LIT i -> Z.to_string i | REAL_LIT r -> Q.to_string r | QUALIFIER s -> s (* Special values *) | INDENT -> "IDENT" | DEDENT -> "DEDENT" | EOF -> "EOF" | EOL -> "EOL" | LET -> "LET" | IDENTIFIER s -> s } let hex_lit = '0''x'['0'-'9' 'A' - 'F' 'a'-'f' '_']+ let identifier = ['a'-'z' 'A'-'Z' '_'] ['a'-'z' 'A'-'Z' '0'-'9' '_']* rule token = parse (* whitespace and comments *) | ['\n'] { Lexing.new_line lexbuf; EOL } | [' ' '\t'] { token lexbuf } | '/' '/' [^'\n']* { token lexbuf } | '#' [^'\n']* { token lexbuf } | '/' '*' { comment 1 lexbuf } (* numbers, strings and identifiers *) | '"' ([^'"']* as s) '"' { STRING_LIT (s) } | '\'' ['0' '1' ' ']* '\'' as lxm { BITS_LIT (Bitvector.of_string lxm) } | '\'' (['0' '1' 'x' ' ']* as s) '\'' { MASK_LIT (Bitvector.mask_of_string s) } | hex_lit as lxm { INT_LIT (Z.of_string lxm) } | ['0'-'9']+ '.' ['0'-'9']+ as lxm { REAL_LIT (Q.of_string lxm) } | ['0'-'9']+ as lxm { INT_LIT (Z.of_string lxm) } | identifier as lxm { tr_name (lxm) } (* delimiters *) | '!' { BANG } | '!' '=' { BANG_EQ } | '&' { AMP } | '&' '&' { AMP_AMP } | '(' { LPAREN } | ')' { RPAREN } | '*' { STAR } | '+' { PLUS } | '+' '+' { PLUS_PLUS } | '+' ':' { PLUS_COLON } | ',' { COMMA } | '-' { MINUS } | '.' { DOT } | '.' '.' { DOT_DOT } | '/' { SLASH } | ':' { COLON } | ';' { SEMICOLON } | '<' { LT } | '<' '<' { LT_LT } | '<' '=' { LT_EQ } | '=' { EQ } | '=' '=' { EQ_EQ } | '=' '>' { EQ_GT } | '>' { GT } | '>' '=' { GT_EQ } | '>' '>' { GT_GT } | '[' { LBRACK } | ']' { RBRACK } | '^' { CARET } | '{' { LBRACE } | '{' '{' { LBRACE_LBRACE } | '|' '|' { BAR_BAR } | '}' { RBRACE } | '}' '}' { RBRACE_RBRACE } | eof { EOF } | _ { let p1 = Lexing.lexeme_start_p lexbuf and p2 = Lexing.lexeme_end_p lexbuf in Error.fatal_here p1 p2 Error.UnknownSymbol } and comment depth = parse '/' '*' { comment (depth+1) lexbuf } | '*' '/' { if depth = 1 then token lexbuf else comment (depth-1) lexbuf } | '\n' { Lexing.new_line lexbuf; comment depth lexbuf } | _ { comment depth lexbuf } { let token_with_debug lexbuf = let tok = token lexbuf in let () = Printf.eprintf "Parsed token %s\n" (string_of_token tok) in tok } herd-herdtools7-1ca343e/asllib/StaticEnv.ml000066400000000000000000000222631475314470400206470ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) open AST open ASTUtils module TimeFrame = SideEffect.TimeFrame module SES = SideEffect.SES module TypingRule = Instrumentation.TypingRule let ( |: ) = Instrumentation.TypingNoInstr.use_with type global = { declared_types : (ty * TimeFrame.t) IMap.t; constant_values : literal Storage.t; storage_types : (ty * global_decl_keyword) IMap.t; subtypes : identifier IMap.t; subprograms : (AST.func * SES.t) IMap.t; overloaded_subprograms : ISet.t IMap.t; expr_equiv : expr IMap.t; } type local = { constant_values : literal Storage.t; storage_types : (ty * local_decl_keyword) IMap.t; expr_equiv : expr IMap.t; return_type : ty option; } type env = { global : global; local : local } module PPEnv = struct open Format let pp_fst pp_elt f (x, _) = pp_elt f x let pp_map pp_elt f m = let pp_sep f () = fprintf f ",@ " in let pp_one f (key, elt) = fprintf f "@[%s |-> @[%a@]@]" key pp_elt elt in fprintf f "@[{@ %a}@]" (PP.pp_print_seq ~pp_sep pp_one) (IMap.to_seq m) let pp_iset f s = let pp_sep f () = fprintf f ",@ " in fprintf f "@[{@ %a}@]" (PP.pp_print_seq ~pp_sep pp_print_string) (ISet.to_seq s) let pp_local f { constant_values; storage_types; return_type; expr_equiv } = fprintf f "@[Local with:@ - @[constants:@ %a@]@ - @[storage:@ %a@]@ - \ @[return type:@ %a@]@ - @[expr equiv:@ %a@]@]" (Storage.pp_print PP.pp_literal) constant_values (pp_map (fun f (t, _) -> PP.pp_ty f t)) storage_types (pp_print_option ~none:(fun f () -> fprintf f "none") PP.pp_ty) return_type (pp_map PP.pp_expr) expr_equiv let pp_subprogram f func_sig = fprintf f "@[%a@ -> %a@]" (pp_print_list ~pp_sep:pp_print_space PP.pp_typed_identifier) func_sig.args (pp_print_option PP.pp_ty) func_sig.return_type let pp_global f { constant_values; storage_types; declared_types; subtypes; subprograms; overloaded_subprograms; expr_equiv; } = fprintf f "@[Global with:@ - @[constants:@ %a@]@ - @[storage:@ %a@]@ - \ @[types:@ %a@]@ - @[subtypes:@ %a@]@ - @[subprograms:@ %a@]@ - \ @[overloaded_subprograms:@ %a@]@ - @[expr equiv:@ %a@]@]" (Storage.pp_print PP.pp_literal) constant_values (pp_map (fun f (t, _) -> PP.pp_ty f t)) storage_types (pp_map (pp_fst PP.pp_ty)) declared_types (pp_map pp_print_string) subtypes (pp_map (fun f (p, _ses) -> pp_subprogram f p)) subprograms (pp_map pp_iset) overloaded_subprograms (pp_map PP.pp_expr) expr_equiv let pp_env f { global; local } = fprintf f "@[Env with:@ - %a@ - %a@]" pp_local local pp_global global end let pp_env = PPEnv.pp_env let pp_global = PPEnv.pp_global let pp_local = PPEnv.pp_local (** An empty global static environment. *) let empty_global = { declared_types = IMap.empty; constant_values = Storage.empty; storage_types = IMap.empty; subtypes = IMap.empty; subprograms = IMap.empty; overloaded_subprograms = IMap.empty; expr_equiv = IMap.empty; } (** An empty local static env. *) let empty_local = { constant_values = Storage.empty; storage_types = IMap.empty; return_type = None; expr_equiv = IMap.empty; } let empty_local_return_type return_type = { empty_local with return_type } (** An empty static env. *) let empty = { local = empty_local; global = empty_global } (* Begin WithEmptyLocal *) let with_empty_local global = { global; local = empty_local } |: TypingRule.WithEmptyLocal (* End *) (** [lookup x env] is the value of x as defined in environment. (* Begin LookupConstant *) @raise Not_found if it is not defined inside. *) let lookup_constants env x = try Storage.find x env.local.constant_values with Not_found -> Storage.find x env.global.constant_values |: TypingRule.LookupConstant (* End *) let lookup_constants_opt env x = try Some (lookup_constants env x) with Not_found -> None (* Begin TypeOf *) (** [type_of env "x"] is the type of ["x"] in the environment [env]. *) let type_of env x = try IMap.find x env.local.storage_types |> fst |: TypingRule.TypeOf with Not_found -> IMap.find x env.global.storage_types |> fst (* End *) let type_of_opt env x = try Some (type_of env x) with Not_found -> None (* Begin LookupImmutableExpr *) let lookup_immutable_expr env x = try IMap.find x env.local.expr_equiv |: TypingRule.LookupImmutableExpr with Not_found -> IMap.find x env.global.expr_equiv (* End *) let lookup_immutable_expr_opt env x = try Some (lookup_immutable_expr env x) with Not_found -> None let mem_constants env x = Storage.mem x env.global.constant_values || Storage.mem x env.local.constant_values let add_subprogram name func_def ses env = let () = if false then Format.eprintf "@[Adding func %s with side effects:@ @[%a]@]@." name SideEffect.SES.pp_print ses in { env with global = { env.global with subprograms = IMap.add name (func_def, ses) env.global.subprograms; }; } let set_renamings name set env = { env with global = { env.global with overloaded_subprograms = IMap.add name set env.global.overloaded_subprograms; }; } let add_global_storage x ty gdk (genv : global) = { genv with storage_types = IMap.add x (ty, gdk) genv.storage_types } let add_type x ty time_frame env = let () = if false then Format.eprintf "Adding type %s as %a.@." x PP.pp_ty ty in { env with global = { env.global with declared_types = IMap.add x (ty, time_frame) env.global.declared_types; }; } (* Begin AddLocalConstant *) let add_local_constant name v env = { env with local = { env.local with constant_values = Storage.add name v env.local.constant_values; }; } (* End *) (* Begin AddGlobalConstant *) let add_global_constant name v (genv : global) = { genv with constant_values = Storage.add name v genv.constant_values } (* End *) let add_local x ty ldk env = let () = if false then Format.eprintf "Adding to env %S <- %a@." x PP.pp_ty ty in { env with local = { env.local with storage_types = IMap.add x (ty, ldk) env.local.storage_types; }; } (* Begin AddLocalImmutableExpr *) let add_local_immutable_expr x e env = let () = if false then Format.eprintf "Adding to env %S <- %a@." x PP.pp_expr e in { env with local = { env.local with expr_equiv = IMap.add x e env.local.expr_equiv }; } |: TypingRule.AddLocalImmutableExpr (* End *) (* Begin AddGlovalImmutableExpr *) let add_global_immutable_expr x e env = let () = if false then Format.eprintf "Adding to env %S <- %a@." x PP.pp_expr e in { env with global = { env.global with expr_equiv = IMap.add x e env.global.expr_equiv }; } |: TypingRule.AddGlobalImmutableExpr (* End *) let add_subtype s t env = { env with global = { env.global with subtypes = IMap.add s t env.global.subtypes }; } (* Begin IsGlobalUndefined *) let is_global_undefined x (genv : global) = (not (IMap.mem x genv.storage_types || IMap.mem x genv.subprograms || IMap.mem x genv.declared_types)) |: TypingRule.IsGlobalUndefined (* End *) (* Begin IsLocalUndefined *) let is_local_undefined x (lenv : local) = (not (IMap.mem x lenv.storage_types)) |: TypingRule.IsLocalUndefined (* End *) (* Begin IsUndefined *) let is_undefined x env = is_global_undefined x env.global && is_local_undefined x env.local |: TypingRule.IsUndefined (* End *) (* Begin IsSubprogram *) let is_subprogram x env = IMap.mem x env.global.subprograms |: TypingRule.IsSubprogram (* End *) herd-herdtools7-1ca343e/asllib/StaticEnv.mli000066400000000000000000000130731475314470400210170ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) open AST open ASTUtils (** Static Environment used for type-checking (cf {!Typing}. *) type global = { declared_types : (ty * SideEffect.TimeFrame.t) IMap.t; (** Maps a type name t to its declaration and its time-frame. As expressions on which a type depends need to be statically evaluable, the only effects allowed in a type are statically evaluable, so need to be reading immutable (global) storage elements. This makes it possible only to store the time-frame of the type, and not the whole side-effect set. *) constant_values : literal Storage.t; (** Maps a global constant name to its value. *) storage_types : (ty * global_decl_keyword) IMap.t; (** Maps global declared storage elements to their types. *) subtypes : identifier IMap.t; (** Maps an identifier s to its parent in the subtype relation. *) subprograms : (AST.func * SideEffect.SES.t) IMap.t; (** Maps each subprogram runtime name to its signature and the side-effects inferred for it. *) overloaded_subprograms : ISet.t IMap.t; (** Maps the name of each declared subprogram to the equivalence class of all the subprogram runtime names that were declared with this name. *) expr_equiv : expr IMap.t; (** Maps every expression to a reduced immutable form. *) } (** Store all the global environment information at compile-time. *) type local = { constant_values : literal Storage.t; (** Maps a local constant to its value. *) storage_types : (ty * local_decl_keyword) IMap.t; (** Maps an locally declared names to their type. *) expr_equiv : expr IMap.t; (** Maps immutable storage to their oldest equivalent expression. *) return_type : ty option; (** Local return type, [None] for procedures, global constants, or setters. *) } (** Store all the local environment information at compile-time. *) type env = { global : global; local : local } (** The static environment type. *) val pp_env : Format.formatter -> env -> unit val pp_global : Format.formatter -> global -> unit val pp_local : Format.formatter -> local -> unit val empty_global : global val empty_local : local val empty_local_return_type : ty option -> local val empty : env val with_empty_local : global -> env val lookup_constants : env -> identifier -> literal (** [lookup x env] is the value of x as defined in environment. @raise Not_found if it is not defined inside. *) val lookup_constants_opt : env -> identifier -> literal option val type_of : env -> identifier -> ty (** [type_of env "x"] is the type of ["x"] in the environment [env]. *) val type_of_opt : env -> identifier -> ty option val lookup_immutable_expr : env -> identifier -> expr val lookup_immutable_expr_opt : env -> identifier -> expr option val mem_constants : env -> identifier -> bool val add_subprogram : identifier -> AST.func -> SideEffect.SES.t -> env -> env val set_renamings : identifier -> ISet.t -> env -> env val add_global_storage : identifier -> ty -> global_decl_keyword -> global -> global val add_type : identifier -> ty -> SideEffect.TimeFrame.t -> env -> env val add_global_constant : identifier -> literal -> global -> global val add_local_constant : identifier -> literal -> env -> env val add_local_immutable_expr : identifier -> expr -> env -> env (** [add_local_immutable_expr x e env] binds [x] to [e] in [env]. [x] is assumed to name an immutable local storage element. [e] is supposed to be the oldest expression corresponding to [x]. *) val add_global_immutable_expr : identifier -> expr -> env -> env (** [add_global_immutable_expr x e env] binds [x] to [e] in [env]. [x] is assumed to name an immutable global storage element. [e] is supposed to be the oldest expression corresponding to [x]. *) val add_local : identifier -> ty -> local_decl_keyword -> env -> env val add_subtype : identifier -> identifier -> env -> env val is_local_undefined : identifier -> local -> bool val is_global_undefined : identifier -> global -> bool val is_undefined : identifier -> env -> bool val is_subprogram : identifier -> env -> bool herd-herdtools7-1ca343e/asllib/StaticInterpreter.ml000066400000000000000000000054571475314470400224300ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) open AST open ASTUtils module SEnv = StaticEnv let ( |: ) = Instrumentation.TypingNoInstr.use_with module InterpConf = struct module Instr = Instrumentation.SemanticsNoInstr let unroll = 0 let error_handling_time = Error.Static end module SB = Native.StaticBackend module SI = Interpreter.Make (Native.StaticBackend) (InterpConf) let eval_from ~loc env e = try SI.eval_expr env e with | Error.(ASLException { pos_start; pos_end; desc; _ }) when pos_start == dummy_pos && pos_end == dummy_pos -> Error.fatal_from loc desc (* Begin StaticEval *) let static_eval (senv : SEnv.env) (e : expr) : literal = let env = let open SI.IEnv in let global = global_from_static senv.global ~storage:(Storage.map SB.v_of_literal senv.SEnv.global.constant_values) and local = local_empty_scoped (SB.Scope.global ~init:true) ~storage:(Storage.map SB.v_of_literal senv.SEnv.local.constant_values) in { global; local } in match eval_from ~loc:e env e with | SI.Normal (Native.NV_Literal l, _env) -> l |: Instrumentation.TypingRule.StaticEval | SI.Normal _ | SI.Throwing _ -> Error.fatal_from e (UnsupportedExpr (Static, e)) (* End *) let static_eval_to_int env e = match static_eval env e with L_Int z -> Z.to_int z | _ -> assert false herd-herdtools7-1ca343e/asllib/StaticInterpreter.mli000066400000000000000000000042551475314470400225740ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) (** Static Interpretation of Expressions. *) module SB = Native.StaticBackend val static_eval : StaticEnv.env -> AST.expr -> AST.literal (** [static_eval env e] statically evaluates [e] in [env] into a literal. @raise ASLException if the a type error is detected or the expression is not one of the following: [E_Literal], [E_Var], [E_Binop], [E_Unop], [E_Slice], or [E_Cond]. @raise UnsupportedExpr if the given expression cannot evaluate to a literal. *) val static_eval_to_int : StaticEnv.env -> AST.expr -> int (** [static_eval_to_int env e] statically evaluates an integer-typed expression [e] in [env] and returns the corresponding integer. *) herd-herdtools7-1ca343e/asllib/StaticModel.ml000066400000000000000000000423411475314470400211560ustar00rootroot00000000000000open AST open ASTUtils open Error exception NotSupported (*---------- Symbolic representation ----------*) module Monomial : sig type t val compare : t -> t -> int val one : t val single_term : identifier -> t val mult : t -> t -> t val divide : t -> t -> t val to_scaled_expr : t -> Q.t -> expr (** Constructs an expression for [factor] * [monos]. *) val pp_with_factor : Format.formatter -> t * Q.t -> unit end = struct module AtomMap = Map.Make (String) (** A map from identifiers. *) type t = int AtomMap.t (** A unitary monomial. They are unitary in the sense that they do not have any factors: {m 3 \times X^2 } is not unitary, while {m x^2 } is. Maps each variable to its exponent. For example: {m X^2 + Y^4 } represented by {m X \to 2, Y \to 4 }, and {m 1 } is represented by the empty map. Invariant: all integer exponents are strictly positive. *) let compare = AtomMap.compare Int.compare let one = AtomMap.empty let single_term atom = AtomMap.singleton atom 1 let mult mono1 mono2 = AtomMap.union (fun _ p1 p2 -> assert (p1 > 0 && p2 > 0); Some (p1 + p2)) mono1 mono2 let divide mono1 mono2 = let divide_unitary a1 a2 = match (a1, a2) with | _, None -> a1 | Some p1, Some p2 when p1 > p2 -> Some (p1 - p2) (* not currently used *) | Some p1, Some p2 when p1 = p2 -> None | _ -> raise NotSupported in AtomMap.merge (fun _ -> divide_unitary) mono1 mono2 let to_scaled_expr monos factor = let start = expr_of_z (Q.num factor) in let numerator = AtomMap.fold (fun atom exponent acc -> mul_expr acc (pow_expr (var_ atom) exponent)) monos start in div_expr numerator (Q.den factor) let pp_with_factor f (monos, factor) = let open Format in if AtomMap.is_empty monos then Q.pp_print f factor else ( pp_open_hbox f (); let pp_sep f () = fprintf f "@ \u{d7} " in if Q.equal factor Q.one then () else ( Q.pp_print f factor; pp_sep f ()); PP.pp_print_seq ~pp_sep (fun f (x, p) -> pp_print_string f x; match p with | 1 -> () | 2 -> pp_print_string f "\u{b2}" | _ -> fprintf f "^%d" p) f (AtomMap.to_seq monos); pp_close_box f ()) end module Polynomial : sig type t val compare : t -> t -> int val single_term : Monomial.t -> Q.t -> t val to_mono : t -> (Monomial.t * Q.t) option val scale : Q.t -> t -> t val neg : t -> t val add : t -> t -> t val mult : t -> t -> t val divide_by_term : t -> Q.t -> Monomial.t -> t val extract_constant_term : t -> Q.t * t val is_constant : t -> Q.t option val to_expr : t -> expr val pp : Format.formatter -> t -> unit end = struct module MonomialMap = Map.Make (Monomial) (** A map from a monomial. *) type t = Q.t MonomialMap.t (** A polynomial. Maps each monomial to its factor. For example, {m X^2 - X + 4 } is represented by {m X^2 \to 1, X \to -1, 1 \to 4 } *) let compare = MonomialMap.compare Q.compare let single_term mono factor = if Q.equal factor Q.zero then MonomialMap.empty else MonomialMap.singleton mono factor let to_mono poly = if MonomialMap.cardinal poly = 1 then Some (MonomialMap.choose poly) else None let add poly1 poly2 = MonomialMap.union (fun _ c1 c2 -> let coeff = Q.add c1 c2 in if Q.equal coeff Q.zero then None else Some coeff) poly1 poly2 let scale factor poly = assert (factor <> Q.zero); MonomialMap.map (Q.mul factor) poly let termwise f poly = MonomialMap.fold (fun mono factor -> add (f factor mono)) poly MonomialMap.empty let mult_mono poly factor mono = termwise (fun f m -> single_term (Monomial.mult m mono) (Q.mul f factor)) poly let neg poly = MonomialMap.map Q.neg poly let mult poly1 poly2 = termwise (mult_mono poly1) poly2 let divide_by_term poly factor mono = termwise (fun f m -> single_term (Monomial.divide m mono) (Q.div f factor)) poly let extract_constant_term poly = let c = try MonomialMap.find Monomial.one poly with Not_found -> Q.zero and p = MonomialMap.remove Monomial.one poly in (c, p) let is_constant poly = if MonomialMap.is_empty poly then Some Q.zero else if MonomialMap.cardinal poly = 1 then MonomialMap.find_opt Monomial.one poly else None let to_expr poly = List.fold_left (fun acc (m, c) -> if ASTUtils.expr_equal (fun _ _ -> false) acc zero_expr then Monomial.to_scaled_expr m c else let e_m = Monomial.to_scaled_expr m (Q.abs c) in add_expr acc (Q.sign c, e_m)) zero_expr (MonomialMap.bindings poly |> List.rev) let pp f poly = let open Format in if MonomialMap.is_empty poly then pp_print_string f "0" else ( pp_open_hvbox f 2; let pp_sep f () = fprintf f "@ + " in PP.pp_print_seq ~pp_sep Monomial.pp_with_factor f (MonomialMap.to_seq poly); pp_close_box f ()) end module Conjunction : sig type eq = Zero | NonZero type t val empty : t val is_bottom : t -> bool val is_empty : t -> bool val of_bool : bool -> t val single_conjunct : Polynomial.t -> eq -> t val conj : t -> t -> t val to_expr : t -> expr option type triviality = TriviallyTrue | TriviallyFalse | NonTrivial val get_triviality : t -> triviality val reduce : t -> t val pp : Format.formatter -> t -> unit end = struct type eq = Zero | NonZero (** A (in)equation for a numerical value. *) let satisfies_eq q eq = let eq_zero = Q.equal q Q.zero in match eq with Zero -> eq_zero | NonZero -> not eq_zero let pp_eq f s = let s = match s with Zero -> "= 0" | NonZero -> "!= 0" in Format.pp_print_string f s let eq_to_op = function Zero -> EQ_OP | NonZero -> NEQ module PolynomialMap = Map.Make (Polynomial) (** Map from polynomials. *) type t = eq PolynomialMap.t option (** A conjunctive logical formula with polynomials. We use the [option] to represent falsity as [None]. [Some map] is then a conjunction of constraints on polynomials, as dictated by [map]. For example, {m X^2 = 0} is represented with {m Some (X^2 \to Zero)}. *) let is_bottom = function None -> true | Some _ -> false let is_empty = function | None -> false | Some map -> PolynomialMap.is_empty map let empty = Some PolynomialMap.empty let of_bool b = if b then empty else None let single_conjunct p eq = Some (PolynomialMap.singleton p eq) let conj c1 c2 = let exception BottomInterrupt in let eq_and eq1 eq2 = if eq1 = eq2 then eq1 else raise_notrace BottomInterrupt in match (c1, c2) with | None, _ | _, None -> None | Some cjs1, Some cjs2 -> ( try Some (PolynomialMap.union (fun _ eq1 eq2 -> Some (eq_and eq1 eq2)) cjs1 cjs2) with BottomInterrupt -> None) let to_expr = let one_to_expr poly eq = let c, p = Polynomial.extract_constant_term poly in binop (eq_to_op eq) (expr_of_rational (Q.neg c)) (Polynomial.to_expr p) in Option.map (fun map -> PolynomialMap.fold (fun p eq e -> conj_expr (one_to_expr p eq) e) map (literal (L_Bool true))) let is_true p eq = match Polynomial.is_constant p with | Some q -> satisfies_eq q eq | None -> false let is_false p eq = match Polynomial.is_constant p with | Some q -> not (satisfies_eq q eq) | None -> false let reduce = function | None -> None | Some cjs -> let non_trivial = PolynomialMap.filter (fun p s -> not (is_true p s)) cjs in if PolynomialMap.exists is_false non_trivial then None else Some non_trivial type triviality = TriviallyTrue | TriviallyFalse | NonTrivial let get_triviality = function | None -> TriviallyFalse | Some cjs -> if PolynomialMap.for_all is_true cjs then TriviallyTrue else if PolynomialMap.exists is_false cjs then TriviallyFalse else NonTrivial let pp f = let open Format in let pp_one f (p, s) = fprintf f "@[%a@ %a@]" Polynomial.pp p pp_eq s in function | None -> pp_print_string f "\u{22a5}" | Some m -> if PolynomialMap.is_empty m then pp_print_string f "\u{22a4}" else let pp_sep f () = fprintf f "@ \u{2227} " in fprintf f "@[%a@]" (PP.pp_print_seq ~pp_sep pp_one) (PolynomialMap.to_seq m) end module IR : sig type t val of_var : identifier -> t val of_int : Z.t -> t val combine : t -> t -> t val cross_combine : (Polynomial.t -> Polynomial.t -> Polynomial.t) -> t -> t -> t val map : (Polynomial.t -> Polynomial.t) -> t -> t val restrict : Conjunction.t list -> t -> t val to_conjuncts : Conjunction.eq -> t -> Conjunction.t list val to_expr : t -> expr val reduce : t -> t val equal_mod_branches : t -> t -> bool val pp : Format.formatter -> t -> unit end = struct type t = (Conjunction.t * Polynomial.t) list (** Case disjunctions: constrained polynomials. This is a branched tree of polynomials. *) (* Wanted invariants for (e : IR.t) : ∀ {c | (c, d) ∈ e } <=> true (I₂) ∀ (cᵢ, eᵢ), (cⱼ, eⱼ) ∈ e, i != j => cⱼ ∩ cⱼ = ∅ (I₃) *) let always e = [ (Conjunction.of_bool true, e) ] let of_var s = Polynomial.single_term (Monomial.single_term s) Q.one |> always let of_int i = Polynomial.single_term Monomial.one (Q.of_bigint i) |> always let combine = ( @ ) let cross_combine f = let on_pair (cjs1, e1) (cjs2, e2) = (Conjunction.conj cjs1 cjs2, f e1 e2) in ASTUtils.list_cross on_pair let map f = List.map (fun (cj, e) -> (cj, f e)) let restrict cjs ir = let restrict_one cjs (cjs', p) = (Conjunction.conj cjs cjs', p) in ASTUtils.list_cross restrict_one cjs ir let to_conjuncts eq ir = List.map (fun (cjs, p) -> Conjunction.conj (Conjunction.single_conjunct p eq) cjs) ir let to_expr = function | [] -> zero_expr | [ (cjs, p) ] -> assert (Conjunction.is_empty cjs); Polynomial.to_expr p | map -> let cannot_happen_expr = zero_expr in List.fold_left (fun e (cjs, p) -> match Conjunction.to_expr cjs with | None -> e | Some condition -> cond_expr condition (Polynomial.to_expr p) e) cannot_happen_expr (List.rev map) let reduce ir = ir |> List.filter_map (fun (cjs, poly) -> let cjs = Conjunction.reduce cjs in if Conjunction.is_bottom cjs then None else Some (cjs, poly)) |> fun ir -> List.fold_right (fun (cjs, poly) acc -> match Conjunction.get_triviality cjs with | TriviallyTrue -> [ (Conjunction.empty, poly) ] | TriviallyFalse -> acc | NonTrivial -> (cjs, poly) :: acc) ir [] let equal_mod_branches ir1 ir2 = let to_cond (cjs1, poly1) (cjs2, poly2) = let equality = let poly = Polynomial.add poly1 (Polynomial.neg poly2) in Conjunction.single_conjunct poly Zero in let cjs = Conjunction.conj cjs1 cjs2 in if Conjunction.is_bottom cjs then Conjunction.empty else let equality = Conjunction.reduce equality in let () = if false then Format.eprintf "@[Gave %a@.@]" Conjunction.pp equality in equality in ASTUtils.list_cross to_cond ir1 ir2 |> List.for_all (fun cjs -> if Conjunction.is_bottom cjs then false else Conjunction.is_empty cjs) let pp f li = let open Format in let pp_one f (cjs, poly) = Format.fprintf f "@[<2>%a@ -> %a@]" Conjunction.pp cjs Polynomial.pp poly in fprintf f "@[%a@]" (pp_print_list ~pp_sep:pp_print_space pp_one) li end (*---------- Converting expressions to symbolic representation ----------*) let rec make_anonymous (env : StaticEnv.env) (ty : ty) : ty = match ty.desc with | T_Named x -> ( match IMap.find_opt x env.global.declared_types with | Some (ty', _) -> make_anonymous env ty' | None -> fatal_from ty (Error.UndefinedIdentifier x)) | _ -> ty (* Begin ToIR *) let rec to_ir env (e : expr) = let of_lit = function L_Int i -> IR.of_int i | _ -> raise NotSupported in match e.desc with | E_Literal (L_Int i) -> IR.of_int i | E_Var s -> ( try StaticEnv.lookup_constants env s |> of_lit with Not_found -> ( try StaticEnv.lookup_immutable_expr env s |> to_ir env with Not_found | NotSupported -> ( let t = try StaticEnv.type_of env s with Not_found -> Error.fatal_from e (UndefinedIdentifier s) in let ty1 = make_anonymous env t in match ty1.desc with | T_Int (WellConstrained [ Constraint_Exact e ]) -> to_ir env e | T_Int _ -> IR.of_var s | _ -> raise NotSupported))) | E_Binop (PLUS, e1, e2) -> let ir1 = to_ir env e1 and ir2 = to_ir env e2 in IR.cross_combine Polynomial.add ir1 ir2 | E_Binop (MINUS, e1, e2) -> let e2 = E_Unop (NEG, e2) |> ASTUtils.add_pos_from_st e2 in E_Binop (PLUS, e1, e2) |> ASTUtils.add_pos_from_st e |> to_ir env | E_Binop (MUL, { desc = E_Binop (DIV, e1, e2); _ }, e3) -> to_ir env (binop DIV (binop MUL e1 e3) e2) | E_Binop (MUL, e1, { desc = E_Binop (DIV, e2, e3); _ }) -> to_ir env (binop DIV (binop MUL e1 e2) e3) | E_Binop (MUL, e1, e2) -> let ir1 = to_ir env e1 and ir2 = to_ir env e2 in IR.cross_combine Polynomial.mult ir1 ir2 | E_Binop (DIV, e1, { desc = E_Literal (L_Int i2); _ }) -> let ir1 = to_ir env e1 and f2 = Q.(Z.one /// i2) in IR.map (Polynomial.scale f2) ir1 | E_Binop (DIV, e1, e2) -> let ir1 = to_ir env e1 and ir2 = to_ir env e2 in IR.cross_combine (fun poly1 poly2 -> match Polynomial.to_mono poly2 with | Some (mono, factor) -> Polynomial.divide_by_term poly1 factor mono | None -> raise NotSupported) ir1 ir2 | E_Binop (SHL, e1, { desc = E_Literal (L_Int i2); _ }) when Z.leq Z.zero i2 -> let ir1 = to_ir env e1 and f2 = Z.to_int i2 |> Z.shift_left Z.one |> Q.of_bigint in IR.map (Polynomial.scale f2) ir1 | E_Binop (op, { desc = E_Literal l1; _ }, { desc = E_Literal l2; _ }) -> Operations.binop_values e Error.Static op l1 l2 |> of_lit | E_Unop (NEG, e0) -> IR.map Polynomial.neg (to_ir env e0) | E_Cond (cond, e1, e2) -> let cjs, neg_cjs = to_cond env cond and ir1 = to_ir env e1 and ir2 = to_ir env e2 in let ir1' = IR.restrict cjs ir1 and ir2' = IR.restrict neg_cjs ir2 in IR.combine ir1' ir2' | E_ATC (e', _) -> to_ir env e' | _ -> raise NotSupported (* End *) and to_cond env (e : expr) : Conjunction.t list * Conjunction.t list = let ( ||| ) = ( @ ) and ( &&& ) = ASTUtils.list_cross Conjunction.conj in match e.desc with | E_Literal (L_Bool b) -> ([ Conjunction.of_bool b ], [ Conjunction.of_bool (not b) ]) | E_Binop (BAND, e1, e2) -> let cjs1, neg_cjs1 = to_cond env e1 and cjs2, neg_cjs2 = to_cond env e2 in (cjs1 &&& cjs2, neg_cjs1 ||| neg_cjs2) | E_Binop (BOR, e1, e2) -> let cjs1, neg_cjs1 = to_cond env e1 and cjs2, neg_cjs2 = to_cond env e2 in (cjs1 ||| cjs2, neg_cjs1 &&& neg_cjs2) | E_Binop (EQ_OP, e1, e2) -> let e' = E_Binop (MINUS, e1, e2) |> ASTUtils.add_pos_from_st e in let ir = to_ir env e' in (IR.to_conjuncts Zero ir, IR.to_conjuncts NonZero ir) | E_Cond (cond, e1, e2) -> let cjs_cond, neg_cjs_cond = to_cond env cond and cjs1, neg_cjs1 = to_cond env e1 and cjs2, neg_cjs2 = to_cond env e2 in ( cjs_cond &&& cjs1 ||| (neg_cjs_cond &&& cjs2), neg_cjs_cond ||| neg_cjs1 &&& (cjs_cond ||| neg_cjs2) ) | _ -> raise NotSupported (*---------- Solving in the symbolic representation ----------*) (* Begin Normalize *) let normalize env e = let { desc } = e |> to_ir env |> IR.reduce |> IR.to_expr in add_pos_from e desc (* End *) let try_normalize env e = try normalize env e with Error.ASLException _ | NotSupported -> e let normalize_opt env e = try Some (normalize env e) with Error.ASLException _ | NotSupported -> None let equal_in_env env e1 e2 = let dbg = false in let () = if dbg then Format.eprintf "@[Are %a@ and %a@ equal?@]@ " PP.pp_expr e1 PP.pp_expr e2 in try let ir1 = to_ir env e1 |> IR.reduce and ir2 = to_ir env e2 |> IR.reduce in let () = if dbg then Format.eprintf "@[Reducing them to@ %a@ and %a.@]@ " IR.pp ir1 IR.pp ir2 in let res = IR.equal_mod_branches ir1 ir2 in let () = if dbg then if res then Format.eprintf "YES@." else Format.eprintf "NO@." in res with NotSupported -> let () = if dbg then Format.eprintf "Cannot answer this question yet." in false let normalize_to_bool_opt env e = try let cond, _ncond = to_cond env e in if List.exists (fun c -> Conjunction.get_triviality c = TriviallyTrue) cond then Some true else if List.for_all (fun c -> Conjunction.get_triviality c = TriviallyFalse) cond then Some false else None with NotSupported -> None (* Begin ReduceToZOpt *) let reduce_to_z_opt env e = match (try_normalize env e).desc with | E_Literal (L_Int z) -> Some z | _ -> None (* End *) herd-herdtools7-1ca343e/asllib/StaticModel.mli000066400000000000000000000006241475314470400213250ustar00rootroot00000000000000val equal_in_env : StaticEnv.env -> AST.expr -> AST.expr -> bool val try_normalize : StaticEnv.env -> AST.expr -> AST.expr val normalize_to_bool_opt : StaticEnv.env -> AST.expr -> bool option val reduce_to_z_opt : StaticEnv.env -> AST.expr -> Z.t option val normalize_opt : StaticEnv.env -> AST.expr -> AST.expr option (* used by tests/static.ml *) val normalize : StaticEnv.env -> AST.expr -> AST.expr herd-herdtools7-1ca343e/asllib/StaticOperations.ml000066400000000000000000000403611475314470400222410ustar00rootroot00000000000000open AST open ASTUtils module TypingRule = Instrumentation.TypingRule let ( |: ) = Instrumentation.TypingNoInstr.use_with let exact e = Constraint_Exact e let range a b = Constraint_Range (a, b) (* Begin ConstraintMod *) let constraint_mod = function | Constraint_Exact e | Constraint_Range (_, e) -> range zero_expr (binop MINUS e one_expr) |: TypingRule.ConstraintMod (* End *) (* Begin PossibleExtremitiesLeft *) (** [possible_extremities_left op a b] is given a range [a..b] the set of needed extremities of intervals for the left-hand-side of an operation [op]. *) let possible_extremities_left op a b = match op with (* MUL is not left-increasing: if c is negative, then the following is not true: if x < y then x op c < y op c This is why we have to add the reversed intervals. We also have to add the intervals (a, a) and (b, b) for the case where a < 0 < b and c < 0 < d. *) | MUL -> [ (a, a); (a, b); (b, a); (b, b) ] |: TypingRule.PossibleExtremitiesLeft (* All the following operations are left-increasing: for any operation op among those, if x < y, and c a valid value for the right-hand side of op, x op c < y op c *) | DIV | DIVRM | SHR | SHL | PLUS | MINUS -> [ (a, b) ] | _ -> assert false (* End *) (* Begin PossibleExtremitiesRIght *) (** [possible_extremities_right op a b] is given a range [a..b] the set of needed extremities of intervals for the right-hand-side of an operation [op]. *) let possible_extremities_right op c d = match op with (* PLUS is right-increasing. *) | PLUS -> [ (c, d) ] |: TypingRule.PossibleExtremitiesRight (* MINUS simply reverse the intervals. *) | MINUS -> [ (d, c) ] (* We need: - the normal interval if the left-hand-side value is positive - the reversed interval if the right-hand-side value is negative - the singletons at bounds for the case where a < 0 < b and c < 0 < d. *) | MUL -> [ (c, c); (c, d); (d, c); (d, d) ] (* For SHR and SHL, we can replace [c] by [0] because this handle the case where c is negative, that will need to be treated anyway. Then if the right-hand side is negative, we need to reverse the intervals. *) | SHL | SHR -> [ (d, zero_expr); (zero_expr, d) ] (* Same as SHR/SHL, but with [1] for divisions. *) | DIV | DIVRM -> [ (one_expr, d); (d, one_expr) ] | _ -> assert false (* End *) (* Begin ApplyBinopExtremities *) (** [apply_binop_extremities op c1 c2] applies [op] to the slices [c1] and [c2]. It produces a list of all possible slices, by using the functions [possible_extremities_left/right], and taking the cartesian product of their results. *) let apply_binop_extremities op c1 c2 = match (c1, c2) with | Constraint_Exact a, Constraint_Exact c -> [ exact (binop op a c) ] |: TypingRule.ApplyBinopExtremities | Constraint_Range (a, b), Constraint_Exact c -> List.map (fun (a', b') -> range (binop op a' c) (binop op b' c)) (possible_extremities_left op a b) | Constraint_Exact a, Constraint_Range (c, d) -> List.map (fun (c', d') -> range (binop op a c') (binop op a d')) (possible_extremities_right op c d) | Constraint_Range (a, b), Constraint_Range (c, d) -> list_cross (fun (a', b') (c', d') -> range (binop op a' c') (binop op b' d')) (possible_extremities_left op a b) (possible_extremities_right op c d) (* End *) (* Begin ConstraintPow *) (** [constraint_pow c1 c2] applies [POW] to [c1] and [c2]. *) let constraint_pow c1 c2 = let pow = binop POW and neg = unop NEG in match (c1, c2) with | Constraint_Exact a, Constraint_Exact c -> [ exact (pow a c) ] |: TypingRule.ConstraintPow | Constraint_Range (a, b), Constraint_Exact c -> (* We need: - the case a positive is included in the case a negative. - 0..b POW c for the positive values - (- ((-a) POW c)) .. ((-a) POW c) for the negative values - the case 0 POW 0 can only happen if c = 0, and then this is included in 0..b POW c *) let mac = pow (neg a) c in [ range zero_expr (pow b c); range (neg mac) mac ] | Constraint_Exact a, Constraint_Range (_c, d) -> (* We need here: - 1 for 0 POW 0 that can be included everywhere and is the only time that POW is very unpredictable - (- ((-a) POW d)) .. ((-a) POW d) for the negative values - 0 .. ad for the positive values *) let mad = pow (neg a) d and ad = pow a d in [ range zero_expr ad; range (neg mad) mad; exact one_expr ] | Constraint_Range (a, b), Constraint_Range (_c, d) -> (* We need here: - 1 for 0 POW 0 that can be included everywhere and is the only time that POW is very unpredictable - (- ((-a) POW d)) .. ((-a) POW d) for the negative values - 0 .. bd for the positive values *) let mad = pow (neg a) d in [ range zero_expr (pow b d); range (neg mad) mad; exact one_expr ] (* End *) (* Begin ConstraintBinop *) let constraint_binop op cs1 cs2 = match op with | DIV | DIVRM | MUL | PLUS | MINUS | SHR | SHL -> list_flat_cross (apply_binop_extremities op) cs1 cs2 |: TypingRule.ConstraintBinop | MOD -> List.map constraint_mod cs2 | POW -> list_flat_cross constraint_pow cs1 cs2 | AND | BAND | BEQ | BOR | EOR | EQ_OP | GT | GEQ | IMPL | LT | LEQ | NEQ | OR | RDIV | BV_CONCAT -> assert false (* End *) (* Begin FilterReduceConstraintDiv *) let filter_reduce_constraint_div = let get_literal_div_opt e = match e.desc with | E_Binop (DIV, a, b) -> ( match (a.desc, b.desc) with | E_Literal (L_Int z1), E_Literal (L_Int z2) -> Some (z1, z2) | _ -> None) | _ -> None in function | Constraint_Exact e as c -> ( match get_literal_div_opt e with | Some (z1, z2) when Z.sign z2 > 0 -> if Z.divisible z1 z2 then Some c else None | _ -> Some c) | Constraint_Range (e1, e2) as c -> ( let z1_opt = match get_literal_div_opt e1 with | Some (z1, z2) when Z.sign z2 > 0 -> let zdiv, zmod = Z.ediv_rem z1 z2 in let zres = if Z.sign zmod = 0 then zdiv else Z.succ zdiv in Some zres | _ -> None and z2_opt = match get_literal_div_opt e2 with | Some (z1, z2) when Z.sign z2 > 0 -> Some (Z.ediv z1 z2) | _ -> None in match (z1_opt, z2_opt) with | Some z1, Some z2 -> let () = if false then Format.eprintf "Reducing %a DIV %a@ got z1=%a and z2=%a@." PP.pp_expr e1 PP.pp_expr e2 Z.pp_print z1 Z.pp_print z2 in if Z.equal z1 z2 then Some (exact (expr_of_z z1)) else if Z.leq z1 z2 then Some (range (expr_of_z z1) (expr_of_z z2)) else None | Some z1, None -> Some (range (expr_of_z z1) e2) | None, Some z2 -> Some (range e1 (expr_of_z z2)) | None, None -> Some c) (* End *) module type CONFIG = sig val fail : unit -> 'a val warn_from : loc:'a annotated -> Error.warning_desc -> unit end module Make (C : CONFIG) = struct let list_filter_map_modified f = let rec aux (accu, flag) = function | [] -> (List.rev accu, flag) | x :: l -> ( match f x with | None -> aux (accu, true) l | Some v -> aux (v :: accu, v <> x || flag) l) in aux ([], false) (* Begin RefineConstraintBySign *) let refine_constraint_by_sign env sign_predicate = function | Constraint_Exact e as c -> ( match StaticModel.reduce_to_z_opt env e with | Some z when sign_predicate (Z.sign z) -> Some c | Some _ -> None | None -> Some c) | Constraint_Range (e1, e2) as c -> ( match ( StaticModel.reduce_to_z_opt env e1, StaticModel.reduce_to_z_opt env e2 ) with | Some z1, Some z2 -> ( match (sign_predicate (Z.sign z1), sign_predicate (Z.sign z2)) with | true, true -> Some c | false, true -> Some (range (if sign_predicate 0 then zero_expr else one_expr) e2) | true, false -> Some (range e1 (if sign_predicate 0 then zero_expr else minus_one_expr)) | false, false -> None) | None, Some z2 -> Some (if sign_predicate (Z.sign z2) then c else range e1 (if sign_predicate 0 then zero_expr else minus_one_expr)) | Some z1, None -> Some (if sign_predicate (Z.sign z1) then c else range (if sign_predicate 0 then zero_expr else one_expr) e2) | None, None -> Some c) (* End *) (* Begin RefineConstraints *) let refine_constraints ~loc op filter constraints = let pp_constraints f cs = Format.fprintf f "@[{%a}@]" PP.pp_int_constraints cs in let constraints', modified = list_filter_map_modified filter constraints in match constraints' with | [] -> let () = Format.eprintf "@[%a:@ All@ values@ in@ constraints@ %a@ would@ fail@ with@ op \ %s,@ operation@ will@ always@ fail.@]@." PP.pp_pos loc pp_constraints constraints PP.(binop_to_string op) in C.fail () | _ -> let () = if modified then C.warn_from ~loc Error.( RemovingValuesFromConstraints { op; prev = constraints; after = constraints' }) else if false then Format.eprintf "Unmodified for op %s: %a = %a@." PP.(binop_to_string op) pp_constraints constraints pp_constraints constraints' in constraints' (* End *) let filter_sign ~loc env op sign_predicate constraints = refine_constraints ~loc op (refine_constraint_by_sign env sign_predicate) constraints (* Begin BinopFilterRight *) (** Filters out values from the right-hand-side operand of [op] that will definitely result in a dynamic error. *) let binop_filter_rhs ~loc env op = match op with | SHL | SHR | POW -> filter_sign ~loc env op @@ fun x -> x >= 0 | MOD | DIV | DIVRM -> filter_sign ~loc env op @@ fun x -> x > 0 | MINUS | MUL | PLUS -> Fun.id | AND | BAND | BEQ | BOR | EOR | EQ_OP | GT | GEQ | IMPL | LT | LEQ | NEQ | OR | RDIV | BV_CONCAT -> assert false (* End *) (* Begin RefineConstraintForDIV *) let refine_constraint_for_div ~loc op cs = match op with | DIV -> ( let res = List.filter_map filter_reduce_constraint_div cs in match res with | [] -> let () = Format.eprintf "@[%a:@ Division@ will@ result@ in@ empty@ constraint@ set,@ \ so@ will@ always@ fail.@]@." PP.pp_pos loc in C.fail () | _ -> res) | _ -> cs (* End *) (* Begin ReduceConstraint *) let reduce_constraint env = function | Constraint_Exact e -> Constraint_Exact (StaticModel.try_normalize env e) | Constraint_Range (e1, e2) -> Constraint_Range (StaticModel.try_normalize env e1, StaticModel.try_normalize env e2) (* End *) let list_remove_duplicates eq = let rec aux prev acc = function | [] -> List.rev acc | x :: li -> if eq prev x then aux prev acc li else aux x (x :: acc) li in function [] -> [] | x :: li -> aux x [ x ] li let simplify_static_constraints = let module DZ = Diet.Z in let to_diets (diets, non_static) = function | Constraint_Exact e as c -> ( match e.desc with | E_Literal (L_Int z) -> (DZ.singleton z :: diets, non_static) | _ -> (diets, c :: non_static)) | Constraint_Range (e1, e2) as c -> ( match (e1.desc, e2.desc) with | E_Literal (L_Int z1), E_Literal (L_Int z2) when Z.leq z1 z2 -> DZ.(add Interval.(make z1 z2) empty :: diets, non_static) | _ -> (diets, c :: non_static)) in let constraint_of_interval interval = let x = DZ.Interval.x interval and y = DZ.Interval.y interval in if Z.equal x y then Constraint_Exact (expr_of_z x) else Constraint_Range (expr_of_z x, expr_of_z y) in fun constraints -> let diets, non_static = List.fold_left to_diets ([], []) constraints in let diet = DZ.unions diets in DZ.fold (fun interval acc -> constraint_of_interval interval :: acc) diet non_static (* Begin ReduceConstraints *) let reduce_constraints env constraints = List.map (reduce_constraint env) constraints |> simplify_static_constraints |> List.sort compare |> list_remove_duplicates (constraint_equal (StaticModel.equal_in_env env)) (* End *) (** [binop_is_exploding op] returns [true] if [constraint_binop op] loses precision on intervals. *) let binop_is_exploding = function | PLUS | MINUS -> false | MUL | SHL | POW | DIV | DIVRM | MOD | SHR -> true | AND | BAND | BEQ | BOR | EOR | EQ_OP | GT | GEQ | IMPL | LT | LEQ | NEQ | OR | RDIV | BV_CONCAT -> assert false let log_max_constraint_size = 17 let max_constraint_size = Z.shift_left Z.one log_max_constraint_size let max_exploded_interval_size = Z.shift_left Z.one 14 (* Begin ExplodeIntervals *) let explode_intervals = let rec make_interval ~loc acc a b = if Z.leq a b then let eb = E_Literal (L_Int b) |> add_pos_from loc in let acc' = Constraint_Exact eb :: acc in make_interval ~loc acc' a (Z.pred b) else acc in let interval_too_large z1 z2 = let expected_size = Z.sub z2 z1 in Z.lt max_exploded_interval_size expected_size in let explode_constraint ~loc env = function | Constraint_Exact _ as c -> [ c ] | Constraint_Range (a, b) as c -> ( match ( StaticModel.reduce_to_z_opt env a, StaticModel.reduce_to_z_opt env b ) with | Some za, Some zb -> if interval_too_large za zb then let () = C.warn_from ~loc Error.(IntervalTooBigToBeExploded (za, zb)) in [ c ] else make_interval [] ~loc za zb | _ -> [ c ]) in fun ~loc env -> list_concat_map (explode_constraint ~loc env) (* End *) (* Begin AnnotateConstraintBinop *) let annotate_constraint_binop ~loc env op cs1 cs2 = match op with | SHL | SHR | POW | MOD | DIVRM | MINUS | MUL | PLUS | DIV -> let cs2_f = binop_filter_rhs ~loc env op cs2 in let () = if false then Format.eprintf "Reduction of binop %s@ on@ constraints@ %a@ and@ %a@." (PP.binop_to_string op) PP.pp_int_constraints cs1 PP.pp_int_constraints cs2 in let cs1_arg, cs2_arg = if binop_is_exploding op then let ex_cs1 = explode_intervals ~loc env cs1 and ex_cs2 = explode_intervals ~loc env cs2_f in let l1 = List.length ex_cs1 and l2 = List.length ex_cs2 in let expected_constraint_length = Z.(if op = MOD then ~$l2 else mul ~$l1 ~$l2) in if Z.leq expected_constraint_length max_constraint_size then (ex_cs1, ex_cs2) else let () = C.warn_from ~loc Error.( ConstraintSetPairToBigToBeExploded { op; left = cs1; right = cs2_f; log_max = log_max_constraint_size; }) in (cs1, cs2_f) else (cs1, cs2_f) in let annotated_cs = constraint_binop op cs1_arg cs2_arg |> refine_constraint_for_div ~loc op |> reduce_constraints env in let () = if false then Format.eprintf "Reduction of binop %s@ on@ constraints@ %a@ and@ %a@ gave@ %a@." (PP.binop_to_string op) PP.pp_int_constraints cs1_arg PP.pp_int_constraints cs2_arg PP.pp_int_constraints annotated_cs in annotated_cs |: TypingRule.AnnotateConstraintBinop | AND | BAND | BEQ | BOR | EOR | EQ_OP | GT | GEQ | IMPL | LT | LEQ | NEQ | OR | RDIV | BV_CONCAT -> assert false (* End *) end herd-herdtools7-1ca343e/asllib/StaticOperations.mli000066400000000000000000000014121475314470400224040ustar00rootroot00000000000000open AST val constraint_binop : binop -> int_constraint list -> int_constraint list -> int_constraint list (** [constraint_binop op cs1 cs2] is the set of constraints given by the element wise application of [op]. Supported [op]s: [DIV], [DIVRM], [MUL], [PLUS], [MINUS], [SHR], [SHL], [MOD], [POW]. *) module type CONFIG = sig val fail : unit -> 'a val warn_from : loc:'a annotated -> Error.warning_desc -> unit end module Make : functor (C : CONFIG) -> sig val annotate_constraint_binop : loc:'a annotated -> StaticEnv.env -> binop -> int_constraint list -> int_constraint list -> int_constraint list end (* Used by asllib/tests/ConstraintBinops.ml *) val filter_reduce_constraint_div : int_constraint -> int_constraint option herd-herdtools7-1ca343e/asllib/Tokens.mly000066400000000000000000000115211475314470400203760ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) (* ------------------------------------------------------------------------ Tokens ------------------------------------------------------------------------- *) %token AND ARRAY ARROW AS ASSERT BAND BEGIN BEQ BIT BITS BNOT BOOLEAN BOR CASE %token CATCH COLON COLON_COLON COMMA CONFIG CONSTANT DEBUG DIV DIVRM DO DOT %token DOWNTO ELSE ELSIF END ENUMERATION EOF EOR EQ EQ_OP EXCEPTION FOR FUNC %token GEQ GETTER GT IF IMPL IN INTEGER LBRACE LBRACKET LEQ LET LOOPLIMIT LPAR %token LT MINUS MOD MUL NEQ NOT OF OR OTHERWISE PASS PLUS PLUS_COLON POW PRAGMA %token PRINTLN PRINT RBRACE RBRACKET RDIV REAL RECORD RECURSELIMIT REPEAT %token RETURN RPAR STAR_COLON SEMI_COLON SETTER SHL SHR SLICING STRING SUBTYPES %token THEN THROW TO TRY TYPE ARBITRARY UNREACHABLE UNTIL VAR WHEN WHERE WHILE %token WITH LLBRACKET RRBRACKET %token IDENTIFIER STRING_LIT %token MASK_LIT %token BITVECTOR_LIT %token INT_LIT %token REAL_LIT %token BOOL_LIT (* ------------------------------------------------------------------------ Associativity and priority ------------------------------------------------------------------------- *) (* This section on associativity uses menhir associativity and priority features. Internally, it is used by menhir to resolve some conflicts that could arrise from different conflicting expressions, e.g. [3 + 4 + 5]. For a quick intro, menhir assigns a priority level to tokens that have a [left], [right], or [nonassoc] declaration in the order in which they are declared. For example, here [PLUS]'s associativity is declared before [MUL] so [3 + 4 * 5] will be parsed as [3 + (4 * 5)]. Associativity is straigh-forward. Priority declarations that follow are created because of the fusion of multiple recursive bnf rules into one, e.g. [expr] is the fusion of [expr] and many others such as [cexpr]. The rule tree that I am translating here into priority rules is the following: expr <-----------------------|IF|----------------------< cexpr cexpr <----|binop_boolean, checked_type_constraint|---< cexpr_cmp cexpr_cmp <-----------|binop_comparison|---------------< cexpr_add_sub cexpr_add_sub <------|binop_add_sub_logic|-------------< cexpr_mul_div cexpr_mul_div <------|binop_mul_div_shift|-------------< cexpr_pow cepxr_pow <---------------|binop_pow|------------------< bexpr bexpr <---------------------|unop|---------------------< expr_term expr_term <------------------|IN|----------------------< expr_atom expr_atom <-----------|DOT, brackets, ...|-------------< expr Note that the token MINUS has two different precedence: one for when it is a binary operator, in that case it has the same precedence as PLUS, and one for when it is a unary operator, in which case it has the same precendence as NOT. *) (* IF *) %nonassoc ELSE (* binop_boolean, checked_type_constraint *) %left BOR BAND IMPL BEQ AS (* binop_comparison *) %left EQ_OP NEQ %nonassoc GT GEQ LT LEQ (* binop_add_sub_logic *) %left PLUS MINUS OR EOR AND COLON_COLON (* binop_mul_div_shift *) %left MUL DIV DIVRM RDIV MOD SHL SHR (* binop_pow *) %left POW (* unop: NOT, BNOT, MINUS *) %nonassoc UNOPS (* IN *) %nonassoc IN (* DOT, brackets, etc. *) %left DOT LBRACKET LLBRACKET %% herd-herdtools7-1ca343e/asllib/TopoSort.ml000066400000000000000000000154721475314470400205440ustar00rootroot00000000000000module type OrderedHashedType = sig include Set.OrderedType include Hashtbl.HashedType with type t := t val to_string : t -> string end module Make (O : OrderedHashedType) = struct type succs = O.t -> O.t list module OSet = Set.Make (O) (* Compatibility layer around Map *) module OMap = struct module M = Map.Make (O) (* Straight out of the stdlib version 5.1, will be overriden by anything if included in Map.Make *) let of_list bs = List.fold_left (fun m (k, v) -> M.add k v m) M.empty bs [@@warning "-32"] include M end module OTbl = Hashtbl.Make (O) module OStack = struct type t = { stack : O.t Stack.t; mutable set : OSet.t } let create () = { stack = Stack.create (); set = OSet.empty } let push o t = t.set <- OSet.add o t.set; Stack.push o t.stack let mem w t = OSet.mem w t.set let pop t = let o = Stack.pop t.stack in t.set <- OSet.remove o t.set; o let pop_until = let rec aux o acc t = let o' = pop t in let acc = o' :: acc in if O.compare o' o = 0 then acc else aux o acc t in fun o t -> aux o [] t end type data = { (* order from which nodes are discovered *) index : int; (* lowest index of nodes in the stack reachable from a node. *) lowlink : int; } (** Book-keeping for each node *) type state = { data : data OTbl.t; stack : OStack.t; index : int ref } (** All book-keeping *) let set_lowlink s v v_data lowlink = let v_data = { v_data with lowlink } in OTbl.replace s.data v v_data; v_data let rec each_successor succs s fold v (acc, v_data) w = let () = if false then Format.eprintf "each_successor of v=%s w=%s@." (O.to_string v) (O.to_string w) in match OTbl.find_opt s.data w with | None -> let acc, w_data = strong_connected succs s fold acc w in if v_data.lowlink > w_data.lowlink then (acc, set_lowlink s v v_data w_data.lowlink) else (acc, v_data) | Some w_data -> if OStack.mem w s.stack && v_data.lowlink > w_data.index then (acc, set_lowlink s v v_data w_data.index) else (acc, v_data) and strong_connected succs s fold acc v = (* Assumption that [s.data] does not contain [v]. *) let () = if false then Format.eprintf "strong_connected %s@." (O.to_string v) in let index = !(s.index) in let v_data = { index; lowlink = index } in let () = OTbl.add s.data v v_data and () = OStack.push v s.stack and () = incr s.index in let acc, v_data = List.fold_left (each_successor succs s fold v) (acc, v_data) (succs v) in let acc = if v_data.index = v_data.lowlink then let connected_component = OStack.pop_until v s.stack in fold connected_component acc else acc in (acc, v_data) let fold_strong_connected ?(size_hint = 16) fold nodes succs acc = let s = { data = OTbl.create size_hint; index = ref 0; stack = OStack.create () } in List.fold_left (fun acc v -> if OTbl.mem s.data v then acc else strong_connected succs s fold acc v |> fst) acc nodes let sort_connected nodes succs = fold_strong_connected List.cons nodes succs [] |> List.rev let index_connected = let indexer nodes (indexes, i) = let indexes = List.fold_left (fun indexes node -> OMap.add node i indexes) indexes nodes in (indexes, succ i) in fun nodes succs -> let indexes, _i = fold_strong_connected indexer nodes succs (OMap.empty, 0) in OMap.bindings indexes module Properties = struct let order_respected (nodes, succs) = let indexes = index_connected nodes succs |> OMap.of_list in let () = if false then ( let open Format in eprintf "@[Indexes:@ "; OMap.iter (fun v i -> eprintf "@[%s:%d@]@ " (O.to_string v) i) indexes; eprintf "@]@.") in List.for_all (fun v -> List.for_all (fun w -> match (OMap.find_opt v indexes, OMap.find_opt w indexes) with | Some i_v, Some i_w -> i_v >= i_w | _ -> false) (succs v)) nodes end end module ASTFold = struct (* Compatibility layer around String. *) module O = struct let hash : string -> int = Hashtbl.hash [@@warning "-32"] include String let to_string s = s end module OSet = ASTUtils.ISet module TS = Make (O) module Tbl = TS.OTbl type t = { nodes : string list; (** [succs(a)] returns the identifiers on which [a] depends. *) succs : string -> string list; decls : AST.decl list Tbl.t; } let tbl_add_set tbl key values = match Tbl.find_opt tbl key with | None -> Tbl.add tbl key values | Some prev -> Tbl.replace tbl key (OSet.union values prev) let tbl_add_list tbl key values = match Tbl.find_opt tbl key with | None -> Tbl.add tbl key values | Some prev -> Tbl.replace tbl key (List.rev_append values prev) let def d = let open AST in match d.desc with | D_Func { name; _ } | D_GlobalStorage { name; _ } | D_TypeDecl (name, _, _) -> name | D_Pragma _ -> assert false let use d = ASTUtils.use_decl d OSet.empty let extra_def d = let open AST in match d.desc with | D_TypeDecl (_, { desc = T_Enum names; _ }, _) -> names | _ -> [] let build ast : t = let add_one (succ_tbl, decl_tbl) d = let v = def d and u = use d in tbl_add_set succ_tbl v u; tbl_add_list decl_tbl v [ d ]; List.iter (fun v' -> tbl_add_set succ_tbl v' (OSet.singleton v); tbl_add_list decl_tbl v' []) (extra_def d); v in let succ_tbl, decls = (Tbl.create 16, Tbl.create 16) in let nodes = List.map (add_one (succ_tbl, decls)) ast in let () = Tbl.filter_map_inplace (fun _v d -> OSet.filter (Tbl.mem decls) d |> Option.some) succ_tbl in let () = if false then ( let open Format in eprintf "@[Dependencies:@ "; Tbl.iter (fun v -> eprintf "@[%s <-- %a@]@ " v OSet.pp_print) succ_tbl; eprintf "@]@.") in let succs s = Tbl.find succ_tbl s |> OSet.elements in { nodes; succs; decls } type step = Single of AST.decl | Recursive of AST.decl list let fold fold ast = let { nodes; succs; decls } = build ast in let folder nodes acc = let ds = ASTUtils.list_concat_map (Tbl.find decls) nodes in match ds with | [] -> acc (* Can happen for phantom dependencies. *) | [ d ] -> fold (Single d) acc | _ -> fold (Recursive ds) acc in let size_hint = Tbl.length decls in TS.fold_strong_connected ~size_hint folder nodes succs end herd-herdtools7-1ca343e/asllib/TopoSort.mli000066400000000000000000000052631475314470400207120ustar00rootroot00000000000000(** This modules implement a strong component analysis. *) (** {1 Topological sorting of ASTs.} *) (** In the following, {i dependencies} are understood in the ASL declaration level. For example, in the following ASL code: {v constant x: integer = 4; constant y: integer = x + 1; v} the type-checker should first type-check [x] and put it in the environment, before type-checking [y], which would otherwise complain about [x] not being defined. We also need strongly connected components analysis for mutually recursive functions, which are allowed in ASL. For example, the following example should be legal: {v func f (x: integer) => integer begin return 2 * g (x - 1); end func g (x: integer) => integer begin return if x <= 0 then -x else 1 + f(x); end v} Those two function should be handled by the type-checker at the same time: both need the declaration of the other to be correctly type-checked. *) (** Entry-point for dependency-ordered iterations on ASTs. *) module ASTFold : sig (** A step in the strongly-connected folder. *) type step = | Single of AST.decl (** A single declaration that is not recursive. *) | Recursive of AST.decl list (** A set of mutually recursive definitions. *) val fold : (step -> 'acc -> 'acc) -> AST.t -> 'acc -> 'acc (** [fold f ast] is the iterations of [f] on all mutually recursive declarations in [ast] ordered by their definitions. *) end (** {1 Abstract implementation of topological sorting} *) (** Signature of the module argument of the [Make] functor. *) module type OrderedHashedType = sig include Set.OrderedType include Hashtbl.HashedType with type t := t val to_string : t -> string (** For debugging purposes. *) end (** Abstract topological sorting module. This implements the Trajan algorithm. *) module Make (O : OrderedHashedType) : sig type succs = O.t -> O.t list (** Type of functions returning the successor of a node. *) val fold_strong_connected : ?size_hint:int -> (O.t list -> 'a -> 'a) -> O.t list -> succs -> 'a -> 'a (** fold the strongly connected components following the derived order given by [succs]. *) val sort_connected : O.t list -> succs -> O.t list list (** Sort the strongly connected components following the derived order given by [succs]. *) val index_connected : O.t list -> succs -> (O.t * int) list (** index all nodes in an order that respects the order given by [succs]. Nodes have the same index if and only if they are in the same strongly connected component. *) module Properties : sig val order_respected : O.t list * succs -> bool end end herd-herdtools7-1ca343e/asllib/Typing.ml000066400000000000000000004713131475314470400202250ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) open AST open ASTUtils open Infix open StaticEnv module TypingRule = Instrumentation.TypingRule module SES = SideEffect.SES module TimeFrame = SideEffect.TimeFrame let ( |: ) = Instrumentation.TypingNoInstr.use_with let fatal_from ~loc = Error.fatal_from loc let undefined_identifier ~loc x = fatal_from ~loc (Error.UndefinedIdentifier x) let invalid_expr e = fatal_from ~loc:e (Error.InvalidExpr e) let add_pos_from ~loc = add_pos_from loc let conflicting_side_effects_error ~loc (s1, s2) = fatal_from ~loc Error.(ConflictingSideEffects (s1, s2)) let ses_non_conflicting_union ~loc = SES.non_conflicting_union ~fail:(conflicting_side_effects_error ~loc) let ses_non_conflicting_unions ~loc = SES.non_conflicting_unions ~fail:(conflicting_side_effects_error ~loc) let conflict ~loc expected provided = fatal_from ~loc (Error.ConflictingTypes (expected, provided)) let plus = binop PLUS let t_bits_bitwidth e = T_Bits (e, []) let rec list_mapi2 f i l1 l2 = match (l1, l2) with | [], [] -> [] | a1 :: l1, a2 :: l2 -> let r = f i a1 a2 in r :: list_mapi2 f (i + 1) l1 l2 | _, _ -> invalid_arg "List.map2" let rec list_mapi3 f i l1 l2 l3 = match (l1, l2, l3) with | [], [], [] -> [] | a1 :: l1, a2 :: l2, a3 :: l3 -> let r = f i a1 a2 a3 in r :: list_mapi3 f (i + 1) l1 l2 l3 | _, _, _ -> invalid_arg "List.mapi3" let sum = function [] -> !$0 | [ x ] -> x | h :: t -> List.fold_left plus h t (* Begin SlicesWidth *) let slices_width env = let minus = binop MINUS in let slice_width = function | Slice_Single _ -> one_expr | Slice_Star (_, e) | Slice_Length (_, e) -> e | Slice_Range (e1, e2) -> plus one_expr (minus e1 e2) in fun li -> List.map slice_width li |> sum |> StaticModel.try_normalize env (* End *) let width_plus env acc w = plus acc w |> StaticModel.try_normalize env (* Begin RenameTyEqs *) let rename_ty_eqs : env -> (AST.identifier * AST.expr) list -> AST.ty -> AST.ty = let subst_expr_normalize env eqs e = subst_expr eqs e |> StaticModel.try_normalize env in let subst_constraint env eqs = function | Constraint_Exact e -> Constraint_Exact (subst_expr_normalize env eqs e) | Constraint_Range (e1, e2) -> Constraint_Range (subst_expr_normalize env eqs e1, subst_expr_normalize env eqs e2) in let subst_constraints env eqs = List.map (subst_constraint env eqs) in let rec rename env eqs ty = let here desc = add_pos_from ~loc:ty desc in match ty.desc with | T_Bits (e, fields) -> T_Bits (subst_expr_normalize env eqs e, fields) |> here | T_Int (WellConstrained constraints) -> let constraints = subst_constraints env eqs constraints in T_Int (WellConstrained constraints) |> here | T_Int (Parameterized (_uid, name)) -> let e = E_Var name |> here |> subst_expr_normalize env eqs in T_Int (WellConstrained [ Constraint_Exact e ]) |> here | T_Tuple tys -> T_Tuple (List.map (rename env eqs) tys) |> here | _ -> ty in rename |: TypingRule.RenameTyEqs (* End *) (* Begin Lit *) let annotate_literal env = function | L_Int _ as v -> integer_exact' (literal v) | L_Bool _ -> T_Bool | L_Real _ -> T_Real | L_String _ -> T_String | L_BitVector bv -> Bitvector.length bv |> expr_of_int |> t_bits_bitwidth | L_Label label -> ( try IMap.find label env.global.declared_types |> fst |> desc with Not_found -> assert false) (* End *) (** [set_filter_map f set] is the list of [y] such that [f x = Some y] for all elements [x] of [set]. *) let set_filter_map f set = let folder e acc = match f e with None -> acc | Some x -> x :: acc in ISet.fold folder set [] (* --------------------------------------------------------------------------- Properties handling ---------------------------------------------------------------------------*) type strictness = Silence | Warn | TypeCheck | TypeCheckNoWarn module type ANNOTATE_CONFIG = sig val check : strictness val output_format : Error.output_format val print_typed : bool val use_field_getter_extension : bool end module type S = sig val type_check_ast : AST.t -> AST.t * global val type_check_ast_in_env : global -> AST.t -> AST.t * global end module Property (C : ANNOTATE_CONFIG) = struct module EP = Error.ErrorPrinter (C) exception TypingAssumptionFailed type ('a, 'b) property = 'a -> 'b type prop = (unit, unit) property let strictness_string = match C.check with | TypeCheck -> "type-checking-strict" | TypeCheckNoWarn -> "type-checking-strict-no-warn" | Warn -> "type-checking-warn" | Silence -> "type-inference" let check : prop -> prop = match C.check with | TypeCheckNoWarn | TypeCheck -> fun f () -> f () | Warn -> ( fun f () -> try f () with Error.ASLException e -> EP.eprintln e) | Silence -> fun _f () -> () let best_effort' : ('a, 'a) property -> ('a, 'a) property = match C.check with | TypeCheckNoWarn | TypeCheck -> fun f x -> f x | Warn -> ( fun f x -> try f x with Error.ASLException e -> EP.eprintln e; x) | Silence -> ( fun f x -> try f x with Error.ASLException _ -> x) let warn_from = match C.check with | TypeCheckNoWarn | Silence -> fun ~loc:_ _ -> () | TypeCheck | Warn -> EP.warn_from let best_effort : 'a -> ('a, 'a) property -> 'a = fun x f -> best_effort' f x let[@inline] ( let+ ) m f = check m () |> f let either (p1 : ('a, 'b) property) (p2 : ('a, 'b) property) x = try p1 x with TypingAssumptionFailed | Error.ASLException _ -> p2 x let assumption_failed () = raise TypingAssumptionFailed [@@inline] let ok () = () [@@inline] let check_true b fail () = if b then () else fail () [@@inline] let check_all2 li1 li2 f () = List.iter2 (fun x1 x2 -> f x1 x2 ()) li1 li2 end (* ------------------------------------------------------------------------- Functional polymorphism ------------------------------------------------------------------------- *) module FunctionRenaming (C : ANNOTATE_CONFIG) = struct open Property (C) (* Begin HasArgClash *) (* Returns true iff type lists type-clash element-wise. *) let has_arg_clash env caller callee = List.compare_lengths caller callee == 0 && List.for_all2 (fun t_caller (_, t_callee) -> Types.type_clashes env t_caller t_callee) caller callee |: TypingRule.HasArgClash (* End *) (* Return true if two subprogram are forbidden with the same argument types. *) let has_subprogram_type_clash s1 s2 = match (s1, s2) with | ST_Getter, ST_Setter | ST_Setter, ST_Getter | ST_EmptyGetter, ST_EmptySetter | ST_EmptySetter, ST_EmptyGetter -> false | _ -> true (* Deduce renamings from match between calling and callee types. *) let deduce_eqs env = (* Here we assume [has_arg_clash env caller callee] *) (* Thus [List.length caller == List.length callee]. *) let folder prev_eqs caller (_name, callee) = match callee.desc with | T_Bits ({ desc = E_Var x; _ }, _) -> ( match (Types.get_structure env caller).desc with | T_Bits (e_caller, _) -> (x, e_caller) :: prev_eqs | _ -> (* We know that callee type_clashes with caller, and that it cannot be a name. *) assert false) | _ -> prev_eqs in List.fold_left2 folder [] (* Begin AddNewFunc *) let add_new_func ~loc env name formals subpgm_type = match IMap.find_opt name env.global.overloaded_subprograms with | None -> let new_env = set_renamings name (ISet.singleton name) env in (new_env, name) | Some other_names -> let new_name = name ^ "-" ^ string_of_int (ISet.cardinal other_names) in let clash = let formal_types = List.map snd formals in (not (ISet.is_empty other_names)) && ISet.exists (fun name' -> let other_func_sig, _ses = IMap.find name' env.global.subprograms in has_subprogram_type_clash subpgm_type other_func_sig.subprogram_type && has_arg_clash env formal_types other_func_sig.args) other_names in let+ () = fun () -> if clash then let () = if false then Format.eprintf "Function %s@[(%a)@] is declared multiple times.@." name Format.( pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") PP.pp_typed_identifier) formals in fatal_from ~loc (Error.AlreadyDeclaredIdentifier name) in let new_env = set_renamings name (ISet.add new_name other_names) env in (new_env, new_name) |: TypingRule.AddNewFunc (* End *) (* Begin SubprogramForName *) let subprogram_for_name ~loc env version name caller_arg_types = let () = if false then Format.eprintf "Trying to rename call to %S@." name in let renaming_set = try IMap.find name env.global.overloaded_subprograms with Not_found -> undefined_identifier ~loc name in let get_func_sig name' = match IMap.find_opt name' env.global.subprograms with | Some (func_sig, ses) when has_arg_clash env caller_arg_types func_sig.args -> Some (name', func_sig, ses) | _ -> None in let matching_renamings = set_filter_map get_func_sig renaming_set in match matching_renamings with | [ (name', func_sig, ses) ] -> ( match version with | V0 -> (deduce_eqs env caller_arg_types func_sig.args, name', func_sig, ses) | V1 -> ([], name', func_sig, ses) |: TypingRule.SubprogramForName) | [] -> fatal_from ~loc (Error.NoCallCandidate (name, caller_arg_types)) | _ :: _ -> fatal_from ~loc (Error.TooManyCallCandidates (name, caller_arg_types)) (* End *) let try_subprogram_for_name = match C.check with | TypeCheckNoWarn | TypeCheck -> subprogram_for_name | Warn | Silence -> ( fun ~loc env version name caller_arg_types -> try subprogram_for_name ~loc env version name caller_arg_types with Error.ASLException _ as error -> ( try match IMap.find_opt name env.global.subprograms with | None -> undefined_identifier ~loc ("function " ^ name) | Some (func_sig, ses) -> if false then Format.eprintf "@[<2>%a:@ No extra arguments for %s@]@." PP.pp_pos loc name; ([], name, func_sig, ses) with Error.ASLException _ -> raise error)) end (* --------------------------------------------------------------------------- Main type-checking module ---------------------------------------------------------------------------*) module Annotate (C : ANNOTATE_CONFIG) : S = struct open Property (C) module Fn = FunctionRenaming (C) module SOp = StaticOperations.Make (struct let fail = assumption_failed let warn_from = warn_from end) (* Begin LDKIsImmutable *) let ldk_is_immutable = function | LDK_Constant | LDK_Let -> true | LDK_Var -> false (* End *) (* Begin GDKIsImmutable *) let gdk_is_immutable = function | GDK_Config | GDK_Constant | GDK_Let -> true | GDK_Var -> false (* End *) (* Begin ShouldReduceToCall *) let should_reduce_to_call env name st = match IMap.find_opt name env.global.overloaded_subprograms with | None -> false | Some set -> ISet.exists (fun name' -> match IMap.find_opt name' env.global.subprograms with | None -> assert false | Some (func_sig, _ses) -> func_sig.subprogram_type = st) set |: TypingRule.ShouldReduceToCall (* End *) (* Begin DisjointSlicesToPositions *) let disjoint_slices_to_positions ~loc env slices = let module DI = Diet.Int in let exception NonStatic in let eval env e = match StaticModel.reduce_to_z_opt env e with | Some z -> Z.to_int z | None -> raise NonStatic in let interval_of_slice env slice = let make_interval x y = if x > y then fatal_from ~loc @@ Error.(BadSlice slice) else DI.Interval.make x y in match slice with | Slice_Single e -> let x = eval env e in make_interval x x |: TypingRule.BitfieldSliceToPositions | Slice_Range (e1, e2) -> let x = eval env e2 and y = eval env e1 in make_interval x y |: TypingRule.BitfieldSliceToPositions | Slice_Length (e1, e2) -> let x = eval env e1 and y = eval env e2 in make_interval x (x + y - 1) |: TypingRule.BitfieldSliceToPositions | Slice_Star (e1, e2) -> let x = eval env e1 and y = eval env e2 in make_interval (x * y) ((x * (y + 1)) - 1) |: TypingRule.BitfieldSliceToPositions in let bitfield_slice_to_positions ~loc env diet slice = try let interval = interval_of_slice env slice in let new_diet = DI.add interval DI.empty in if DI.is_empty (Diet.Int.inter new_diet diet) then DI.add interval diet else fatal_from ~loc Error.(OverlappingSlices (slices, Static)) with NonStatic -> diet in List.fold_left (bitfield_slice_to_positions ~loc env) Diet.Int.empty slices |: TypingRule.DisjointSlicesToPositions (* End *) (* Begin TypingRule.CheckDisjointSlices *) let check_disjoint_slices ~loc env slices = if List.length slices <= 1 then ok else fun () -> let _ = disjoint_slices_to_positions ~loc env slices in () |: TypingRule.CheckDisjointSlices (* End *) exception NoSingleField (** [to_singles env slices] is a list of [Slice_Single] slices for each bit position of each bitfield slice in [slices]. *) let to_singles env = let eval e = match StaticInterpreter.static_eval env e with | L_Int z -> Z.to_int z | _ -> raise NoSingleField in let one slice acc = match slice with | Slice_Single e -> e :: acc | Slice_Length (e1, e2) -> let i1 = eval e1 and i2 = eval e2 in let rec do_rec n = if n >= i2 then acc else let e = E_Literal (L_Int (Z.of_int (i1 + n))) |> add_dummy_annotation in e :: do_rec (n + 1) in do_rec 0 | Slice_Range (e1, e2) -> let i1 = eval e1 and i2 = eval e2 in let rec do_rec i = if i > i1 then acc else let e = E_Literal (L_Int (Z.of_int i)) |> add_dummy_annotation in e :: do_rec (i + 1) in do_rec i2 | Slice_Star _ -> raise NoSingleField in fun slices -> List.fold_right one slices [] (** Retrieves the slices associated with the given bitfield without recursing into nested bitfields. *) let slices_of_bitfield = function | BitField_Simple (_, slices) | BitField_Nested (_, slices, _) | BitField_Type (_, slices, _) -> slices (** Retrieves the slice of [Slice_Single] slices for each position of the bitfield [field], if it is found in [bf]. *) let field_to_single env bf field = match find_bitfield_opt field bf with | Some bitfield -> to_singles env (slices_of_bitfield bitfield) | None -> raise NoSingleField (** Checks that all bitfields listed in [fields] are delcared in the bitvector type [ty]. If so, retrieves a list of [Slice_Single] slices for each bit position of each bitfield slice of each bitfield in [fields]. [name] is passed along, if the result is not [None] for convenience of use. It is an ASLRef extension, guarded by [C.use_field_getter_extension]. *) let should_fields_reduce_to_call env name ty fields = assert C.use_field_getter_extension; match (Types.make_anonymous env ty).desc with | T_Bits (_, bf) -> ( try Some (name, list_concat_map (field_to_single env bf) fields) with NoSingleField -> None) | _ -> None (* End *) (* ------------------------------------------------------------------------- Annotate AST -------------------------------------------------------------------------- *) (* Begin GetBitvectorWidth *) let get_bitvector_width' env t = match (Types.get_structure env t).desc with | T_Bits (n, _) -> n | _ -> assumption_failed () let get_bitvector_width ~loc env t = try get_bitvector_width' env t |: TypingRule.GetBitvectorWidth with TypingAssumptionFailed -> conflict ~loc [ default_t_bits ] t (* End *) (* Begin GetBitvectorConstWidth *) let get_bitvector_const_width ~loc env t = let e_width = get_bitvector_width ~loc env t in match StaticInterpreter.static_eval env e_width with | L_Int z -> Z.to_int z |: TypingRule.GetBitvectorConstWidth | _ -> assert false (* End *) (** [check_type_satisfies t1 t2] if [t1 <: t2]. *) let check_type_satisfies ~loc env t1 t2 () = let () = if false then Format.eprintf "@[Checking %a@ <: %a@]@." PP.pp_ty t1 PP.pp_ty t2 in if Types.type_satisfies env t1 t2 then () else conflict ~loc [ t2.desc ] t1 (* CheckStructureBoolean *) (** [check_structure_boolean env t1] checks that [t1] has the structure of a boolean. *) let check_structure_boolean ~loc env t1 () = match (Types.get_structure env t1).desc with | T_Bool -> () | _ -> conflict ~loc [ T_Bool ] t1 (* End *) (* CheckStructureBits *) let check_structure_bits ~loc env t () = match (Types.get_structure env t).desc with | T_Bits _ -> () | _ -> conflict ~loc [ default_t_bits ] t (* End *) (* Begin CheckStructureInteger *) let check_structure_integer ~loc env t () = let () = if false then Format.eprintf "Checking that %a is an integer.@." PP.pp_ty t in match (Types.make_anonymous env t).desc with | T_Int _ -> () | _ -> conflict ~loc [ integer' ] t (* End *) (* Begin CheckConstrainedInteger *) let check_constrained_integer ~loc env t () = match (Types.make_anonymous env t).desc with | T_Int UnConstrained -> fatal_from ~loc Error.(ConstrainedIntegerExpected t) | T_Int (WellConstrained _ | Parameterized _) -> () | _ -> conflict ~loc [ integer' ] t (* End *) (* Begin CheckStructureException *) let check_structure_exception ~loc env t () = let t_struct = Types.get_structure env t in match t_struct.desc with | T_Exception _ -> () | _ -> conflict ~loc [ T_Exception [] ] t_struct (* End *) (* Begin CheckSymbolicallyEvaluable *) let check_symbolically_evaluable expr_for_error ses () = if SES.is_symbolically_evaluable ses then () |: TypingRule.CheckSymbolicallyEvaluable else fatal_from ~loc:expr_for_error (Error.ImpureExpression (expr_for_error, ses)) (* End *) let check_is_deterministic expr_for_error ses () = if SES.is_deterministic ses then () else fatal_from ~loc:expr_for_error (Error.ImpureExpression (expr_for_error, ses)) let check_is_pure expr_for_error ses () = if SES.is_pure ses then () else fatal_from ~loc:expr_for_error (Error.ImpureExpression (expr_for_error, SES.remove_pure ses)) let leq_config_time ses = TimeFrame.is_before (SES.max_time_frame ses) TimeFrame.Config let check_leq_config_time ~loc (_, e, ses_e) () = if leq_config_time ses_e then () else fatal_from ~loc Error.(ConfigTimeBroken (e, ses_e)) let leq_constant_time ses = TimeFrame.is_before (SES.max_time_frame ses) TimeFrame.Constant let check_leq_constant_time ~loc (_, e, ses_e) () = if leq_constant_time ses_e then () else fatal_from ~loc Error.(ConstantTimeBroken (e, ses_e)) let check_is_time_frame = let open TimeFrame in function | TimeFrame.Constant -> check_leq_constant_time | TimeFrame.Config -> check_leq_config_time | TimeFrame.Execution -> fun ~loc:_ _ -> ok let check_bits_equal_width' env t1 t2 () = let n = get_bitvector_width' env t1 and m = get_bitvector_width' env t2 in if bitwidth_equal (StaticModel.equal_in_env env) n m then () else assumption_failed () (* Begin CheckBitsEqualWidth *) let check_bits_equal_width ~loc env t1 t2 () = try check_bits_equal_width' env t1 t2 () with TypingAssumptionFailed -> fatal_from ~loc (Error.UnreconciliableTypes (t1, t2)) (* End *) let binop_is_ordered = function | BAND | BOR | IMPL -> true | AND | BEQ | DIV | DIVRM | EOR | EQ_OP | GT | GEQ | LT | LEQ | MOD | MINUS | MUL | NEQ | OR | PLUS | POW | RDIV | SHL | SHR | BV_CONCAT -> false (* Begin TypeOfArrayLength *) let type_of_array_length ~loc = function | ArrayLength_Enum (s, _) -> T_Named s |> add_pos_from ~loc | ArrayLength_Expr _ -> integer |: TypingRule.TypeOfArrayLength (* End *) (* Begin ApplyBinopTypes *) let rec apply_binop_types ~loc env op t1 t2 : ty = let () = if false then Format.eprintf "Checking binop %s between %a and %a@." (PP.binop_to_string op) PP.pp_ty t1 PP.pp_ty t2 in let here x = add_pos_from ~loc x in (match (op, (t1.desc, t2.desc)) with | _, (T_Named _, _) | _, (_, T_Named _) -> let t1_anon = Types.make_anonymous env t1 and t2_anon = Types.make_anonymous env t2 in apply_binop_types ~loc env op t1_anon t2_anon | (BAND | BOR | BEQ | IMPL), (T_Bool, T_Bool) -> T_Bool |> here | (AND | OR | EOR | PLUS | MINUS), (T_Bits (w1, _), T_Bits (w2, _)) when bitwidth_equal (StaticModel.equal_in_env env) w1 w2 -> T_Bits (w1, []) |> here | BV_CONCAT, (T_Bits (w1, _), T_Bits (w2, _)) -> T_Bits (width_plus env w1 w2, []) |> here | (PLUS | MINUS), (T_Bits (w, _), T_Int _) -> T_Bits (w, []) |> here | (LEQ | GEQ | GT | LT), (T_Int _, T_Int _ | T_Real, T_Real) | ( (EQ_OP | NEQ), (T_Int _, T_Int _ | T_Bool, T_Bool | T_Real, T_Real | T_String, T_String) ) -> T_Bool |> here | (EQ_OP | NEQ), (T_Bits (w1, _), T_Bits (w2, _)) when bitwidth_equal (StaticModel.equal_in_env env) w1 w2 -> T_Bool |> here | (EQ_OP | NEQ), (T_Enum li1, T_Enum li2) when list_equal String.equal li1 li2 -> T_Bool |> here | ( (MUL | DIV | DIVRM | MOD | SHL | SHR | POW | PLUS | MINUS), (T_Int c1, T_Int c2) ) -> ( match (c1, c2) with | PendingConstrained, _ | _, PendingConstrained -> assert false | UnConstrained, _ | _, UnConstrained -> T_Int UnConstrained |> here | Parameterized _, _ | _, Parameterized _ -> let t1_well_constrained = Types.to_well_constrained t1 and t2_well_constrained = Types.to_well_constrained t2 in apply_binop_types ~loc env op t1_well_constrained t2_well_constrained | WellConstrained cs1, WellConstrained cs2 -> ( best_effort integer @@ fun _ -> try let cs = SOp.annotate_constraint_binop ~loc env op cs1 cs2 in T_Int (WellConstrained cs) |> here with TypingAssumptionFailed -> fatal_from ~loc (Error.BadTypesForBinop (op, t1, t2)))) | (PLUS | MINUS | MUL), (T_Real, T_Real) | POW, (T_Real, T_Int _) | RDIV, (T_Real, T_Real) -> T_Real |> here | _ -> fatal_from ~loc (Error.BadTypesForBinop (op, t1, t2))) |: TypingRule.ApplyBinopTypes (* End *) (* Begin ApplyUnopType *) let apply_unop_type ~loc env op t = let here desc = add_pos_from ~loc desc in match op with | BNOT -> let+ () = check_type_satisfies ~loc env t boolean in T_Bool |> here | NEG -> ( let+ () = either (check_type_satisfies ~loc env t integer) (check_type_satisfies ~loc env t real) in let t_struct = Types.get_well_constrained_structure env t in match t_struct.desc with | T_Int UnConstrained -> T_Int UnConstrained |> here | T_Int (WellConstrained cs) -> let neg e = unop NEG e in let constraint_minus = function | Constraint_Exact e -> Constraint_Exact (neg e) | Constraint_Range (top, bot) -> Constraint_Range (neg bot, neg top) in T_Int (WellConstrained (List.map constraint_minus cs)) |> here | T_Int (Parameterized _) -> assert false (* We used to_well_constrained just before. *) | _ -> (* fail case *) t) | NOT -> let+ () = check_structure_bits ~loc env t in t |: TypingRule.ApplyUnopType (* End *) (* Begin CheckATC *) let rec check_atc ~fail env t1 t2 = if Types.type_equal env t1 t2 then ok else match (t1.desc, t2.desc) with | T_Int _, T_Int _ | T_Bits _, T_Bits _ -> ok | T_Tuple l1, T_Tuple l2 when List.compare_lengths l1 l2 = 0 -> check_all2 l1 l2 (check_atc ~fail env) | T_Named _, _ | _, T_Named _ -> assert false | _ -> fail |: TypingRule.CheckATC (* End *) (* Begin CheckVarNotInEnv *) let check_var_not_in_env ~loc env x () = if is_undefined x env then () |: TypingRule.CheckVarNotInEnv else fatal_from ~loc (Error.AlreadyDeclaredIdentifier x) (* End *) (* Begin CheckVarNotInGEnv *) let check_var_not_in_genv ~loc genv x () = if is_global_undefined x genv then () |: TypingRule.CheckVarNotInGEnv else fatal_from ~loc (Error.AlreadyDeclaredIdentifier x) (* End *) (* Begin GetVariableEnum *) let get_variable_enum' env e = match e.desc with | E_Var x -> ( match IMap.find_opt x env.global.declared_types with | Some (t, _) -> ( match (Types.make_anonymous env t).desc with | T_Enum labels -> Some (x, labels) | _ -> None) | None -> None) | _ -> None (* End *) (* Begin CheckPositionsInWidth *) let check_diet_in_width ~loc slices width diet () = let min_pos = Diet.Int.min_elt diet and max_pos = Diet.Int.max_elt diet in if 0 <= min_pos && max_pos < width then () |: TypingRule.CheckPositionsInWidth else fatal_from ~loc (BadSlices (Error.Static, slices, width)) (* End *) (* Begin CheckSlicesInWidth *) let check_slices_in_width ~loc env width slices () = let diet = disjoint_slices_to_positions ~loc env slices in check_diet_in_width ~loc slices width diet () |: TypingRule.CheckSlicesInWidth (* End *) (** A module for checking that all bitfields of a given bitvector type that share the same name and exist in the same scope (terms defined below) also define the same slice of the bitvector type. *) module CheckCommonBitfieldsAlign : sig val check : loc:'a annotated -> StaticEnv.env -> bitfield list -> int -> unit end = struct type range = int * int (** [(j, i)] is the list of integers from [j] down to [i], inclusive, matching the slice notation [j:i]. Invariant: [j >= i]. *) type absolute_bitfield = { name : identifier; abs_scope : identifier list; abs_slices : range list; } (** An absolute bitfield [abs_f] corresponds to a bitfield [f]. It consists of the following fields: - [name] the name of the bitfield as declared; - [abs_scope] is the list of names of ancestor bitfields, starting from the top; and - [abs_slices] is a list of ranges that represent the sequence of indices, corresponding to the slices defined for [f], relative to the bitvector type that declares [f]. For example in [ type Nested_Type of bits(3) { [2:1] f1 { [0] f2 } }; ] we have the follwing absolute fields: [ {name="f1"; abs_cope=[]; abs_slices=[2:1]} {name="f2"; abs_cope=["f1"]; abs_slices=[1:1]} ] *) let safe_range (hi, lo) = let () = assert (hi >= lo) in (hi, lo) let pp_abs_name fmt abs_name = let abs_name_minus_top = match abs_name with | h :: t -> let () = assert (String.equal h "") in t | _ -> assert false in Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ".") (fun fmt id -> Format.fprintf fmt "%s" id) fmt abs_name_minus_top let pp_abs_slice fmt (hi, lo) = if hi == lo then Format.fprintf fmt "%i" hi else Format.fprintf fmt "%i:%i" hi lo let pp_abs_slices ranges = Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ", ") pp_abs_slice ranges let pp_absolute_bitfield fmt { name; abs_scope; abs_slices } = Format.fprintf fmt "[%a] %a" pp_abs_slices abs_slices pp_abs_name (List.append abs_scope [ name ]) let range_equal (range1 : range) (range2 : range) = let hi1, lo1 = range1 in let hi2, lo2 = range2 in lo1 == lo2 && hi1 == hi2 let do_ranges_intersect (hi1, lo1) (hi2, lo2) = (lo1 >= lo2 && lo1 <= hi2) || (hi1 <= hi2 && hi1 >= lo2) (** Returns the range resulting from intersecting [range1] and [range2], assuming they intersect. *) let intersect_ranges ((hi1, lo1) as range1) ((hi2, lo2) as range2) = let () = assert (do_ranges_intersect range1 range2) in safe_range (min hi1 hi2, max lo1 lo2) let shift_range (hi, lo) amount = (hi + amount, lo + amount) let ranges_equal ranges1 ranges2 = list_equal range_equal ranges1 ranges2 (** Returns the range [(i+w-1, i)], corresponding to [slice = Slice_Length (i, , w)]. *) let slice_to_range env slice : range = match slice with | Slice_Length (i, w) -> let z_i = StaticInterpreter.static_eval_to_int env i in let z_w = StaticInterpreter.static_eval_to_int env w in safe_range (z_i + z_w - 1, z_i) | _ -> (* should have been de-sugared into Slice_Length *) assert false let merge_ranges_if_adjacent (hi1, lo1) (hi2, lo2) = if lo1 == hi2 + 1 then Some (safe_range (hi1, lo2)) else None (** Merges all adjacent ranges. Example 1: {[(10, 4); (3, 2); (1, 0)]} is coalesced into {[(10,0)]}. Example 2: for {[(1, 0); (3, 2)]} there is no coalescing and the result is the input - {[(1, 0); (3, 2)]}. *) let coalesce_ranges ranges = list_coalesce_right merge_ranges_if_adjacent ranges (** Viewing [ranges] as one long list of integers --- the flat list, the result associates each range of [ranges] with a range corresponding to its respective indices in the flat list. Example 1: if {ranges=[(6, 3); (2, 1)]}, the result is {[(5, 2); (1, 0)]} *) let ranges_to_relative_ranges ranges = let relative_ranges, _ = List.fold_right (fun cur_range (res_ranges, last_idx) -> let cur_hi, cur_lo = cur_range in let cur_range_len = cur_hi - cur_lo + 1 in let relative_range = shift_range (cur_range_len - 1, 0) last_idx in (relative_range :: res_ranges, last_idx + cur_range_len)) ranges ([], 0) in relative_ranges (** [absolute_indices] represents a list of indices into the containing vector, given by ranges. We can think of the "flat list" as the concatenation of the individual lists for each range. For example the flat list for [(20, 16); (13, 12); (9, 6)] is [20, 19, 18, 17, 16, 13, 12, 9, 8, 7, 6]. [slice] is a list of ranges where each range consists of indices into the flat list. The result is a list of sub-ranges formed by selecting from each range in [absolute_indices] the integers indicated by [slice], and filtering out empty ranges. To compute the result, we use the notion of relative ranges, which associate to each range in [absolute_indices] the range of its indices in the flat list. For example, the relative ranges for [(20, 16); (13, 12); (9, 6)] are [(10, 6); (5, 4); (3, 0)]. Example 1: if {absolute_indices = [(20, 16); (13, 12); (9, 6)]} and {slice = (4, 2)} then the result is {[(12, 12); (9, 8)]}. To see this, consider the flat list for [absolute_indices], which is [20, 19, 18, 17, 16, 13, 12, 9, 8, 7, 6]. The integers of the flat list at positions [4, 3, 2] correspond to [12, 9, 8]. The integer [12] comes from the range {(13, 12)} and the integers [9, 8] come from the range {(9, 8)}. Therefore, the result is {[(12, 12); (9, 8)]}. Example 2: if {absolute_indices = [(21,18); (9,4)]} and {slice=(7,6)} the flat list is [21, 20, 19, 18, 9, 8, 7, 6, 5, 4] the relative ranges are {[(9,6); (5,0)]} and the result is {[(19, 18)]}. *) let select_indices_by_slice absolute_indices slice = let relative_ranges = ranges_to_relative_ranges absolute_indices in List.fold_right2 (fun cur_range cur_relative acc_ranges -> if do_ranges_intersect slice cur_relative then let common_range = intersect_ranges slice cur_relative in let _, cur_relative_lo = cur_relative in let _, cur_lo = cur_range in let sliced_range = shift_range common_range (-cur_relative_lo + cur_lo) in sliced_range :: acc_ranges else (* filter out empty output range *) acc_ranges) absolute_indices relative_ranges [] (** Viewing [absolute_indices] as one long list of integers --- the flat list, the result is the list of integers selected from the flat list via the indices represented by the ranges in [slices]. The result list is represented by the smallest list of ranges. Example 1: if {absolute_indices = [(12,9); (7,2)]} and {slices = [(5, 2)]}, the flat list is [12, 10, 9, 7, 6, 5, 4, 3, 2] the selected elements of ranges are then [7, 6, 5, 4], which can be represented by the single range {(7, 4)}. *) let select_indices_by_slices ~absolute_indices ~slices = list_concat_map (select_indices_by_slice absolute_indices) slices |> coalesce_ranges (** [either_prefix list1 list2] is true if either [list1] is a prefix of [list2] or [list2] is a prefix of [list1]. *) let rec either_prefix list1 list2 = match (list1, list2) with | [], _ | _, [] -> true | h1 :: t1, h2 :: t2 -> String.equal h1 h2 && either_prefix t1 t2 let exist_in_same_scope abs_f1 abs_f2 = either_prefix abs_f1.abs_scope abs_f2.abs_scope (** {iter_ordered_pairs f [e_1;...;e_k]} applies [f e_i e_j] to every [1 <= i < j <= k]. *) let rec iter_ordered_pairs f l = match l with | [] | [ _ ] -> () | h :: t -> let () = List.iter (fun e_t -> f h e_t) t in iter_ordered_pairs f t (** Returns the list of absolute bitfields for the bitfield [bf] and all bitfields transitively nested unde it, given that [absolute_parent] is the absolute bitfield for the bitfield where [bf] is declared. *) let rec bitfield_to_absolute env bf absolute_parent = let { name; abs_scope = parent_scope; abs_slices = parent_abs_slices } = absolute_parent in let bf_name = bitfield_get_name bf in let bf_abs_scope = List.append parent_scope [ name ] in let bf_slices_as_ranges = List.map (slice_to_range env) (bitfield_get_slices bf) in let bf_abs_slices = select_indices_by_slices ~absolute_indices:parent_abs_slices ~slices:bf_slices_as_ranges in let bf_absolute = { name = bf_name; abs_scope = bf_abs_scope; abs_slices = bf_abs_slices } in let bf_nested = bitfield_get_nested bf in bf_absolute :: bitfields_to_absolute env bf_nested bf_absolute (** Returns the list of absolute bitfields corresponding to [bitfields], given that [absolute_parent] is the absolute bitfield where [bitfields] are declared. The order of the absolute fields is unimportant. *) and bitfields_to_absolute env bitfields absolute_parent = list_concat_map (fun bf -> bitfield_to_absolute env bf absolute_parent) bitfields (** Tests whether absolute bitfields [f1] and [f2] are aligned. If the two fields don't share a name or don't exist in the same scope, the result is true. *) let absolute_bitfields_align f1 f2 = if String.equal f1.name f2.name && exist_in_same_scope f1 f2 then let { abs_slices = indices1 } = f1 in let { abs_slices = indices2 } = f2 in ranges_equal indices1 indices2 else true (* Begin TypingRule.CheckCommonBitfieldsAlign *) let check ~loc env bitfields width = (* define a fake absolute field representing the entire bitvector. *) let top_absolute = { name = ""; abs_scope = []; abs_slices = [ safe_range (width - 1, 0) ]; } in let absolute_bitfields = bitfields_to_absolute env bitfields top_absolute in let () = if false then List.iter (fun f -> Format.eprintf "absolute field %a@." pp_absolute_bitfield f) absolute_bitfields in iter_ordered_pairs (fun f1 f2 -> let () = if false then Format.eprintf "checking %a and %a | same scope: %b | same name: %b | equal \ slices: %b@." pp_absolute_bitfield f1 pp_absolute_bitfield f2 (exist_in_same_scope f1 f2) (String.equal f1.name f2.name) (ranges_equal f1.abs_slices f2.abs_slices) in if not (absolute_bitfields_align f1 f2) then let abs_name1 = f1.abs_scope @ [ f1.name ] in let abs_name2 = f2.abs_scope @ [ f2.name ] in let abs_name1_str = Format.asprintf "%a" pp_abs_name abs_name1 in let abs_name2_str = Format.asprintf "%a" pp_abs_name abs_name2 in let indices1_str = Format.asprintf "[%a]" pp_abs_slices f1.abs_slices in let indices2_str = Format.asprintf "[%a]" pp_abs_slices f2.abs_slices in fatal_from ~loc (Error.BitfieldsDontAlign { field1_absname = abs_name1_str; field2_absname = abs_name2_str; field1_absslices = indices1_str; field2_absslices = indices2_str; })) absolute_bitfields (* End *) (* Unit tests *) let test_do_ranges_intersect () = assert (do_ranges_intersect (4, 2) (3, 0)); assert (do_ranges_intersect (4, 2) (5, 4)); assert (do_ranges_intersect (4, 2) (10, 6) == false) let test_coalesce_ranges () = assert ( ranges_equal (coalesce_ranges [ (10, 4); (3, 2); (1, 0) ]) [ (10, 0) ]); assert ( ranges_equal (coalesce_ranges [ (1, 0); (3, 2) ]) [ (1, 0); (3, 2) ]); assert ( ranges_equal (coalesce_ranges [ (21, 11); (10, 5); (3, 2); (1, 0) ]) [ (21, 5); (3, 0) ]); assert ( ranges_equal (coalesce_ranges [ (21, 11); (10, 5); (3, 2) ]) [ (21, 5); (3, 2) ]) let test_ranges_to_relative_ranges () = let ranges = [ (6, 3); (2, 1) ] in let relative_ranges = ranges_to_relative_ranges ranges in let () = assert (ranges_equal relative_ranges [ (5, 2); (1, 0) ]) in (* Shifting the ranges shouldn't affect the result *) let ranges = [ shift_range (6, 3) 500; shift_range (2, 1) 1000 ] in let relative_ranges = ranges_to_relative_ranges ranges in assert (ranges_equal relative_ranges [ (5, 2); (1, 0) ]) let test_select_by_slice () = (* Example 1 *) let ranges = [ (20, 16); (13, 12); (9, 6) ] in (* 20, 19, 18, 17, 16, 13, 12, 9, 8, 7, 6 *) let slice = (4, 2) in let selected = select_indices_by_slice ranges slice in let () = assert (ranges_equal selected [ (12, 12); (9, 8) ]) in (* Example 2 *) let ranges = [ (21, 18); (9, 4) ] in let slice = (7, 6) in let selected = select_indices_by_slice ranges slice in assert (ranges_equal selected [ (19, 18) ]) let check_common_bitfields_align_unit_tests _ = Format.printf "Running unit tests for CheckCommonBitfieldsAlign@."; test_do_ranges_intersect (); test_coalesce_ranges (); test_ranges_to_relative_ranges (); test_select_by_slice () let () = if false then check_common_bitfields_align_unit_tests () end (** Check for a standard library declaration name{n}(bits(n), ...) or name{m,n}(bits(n), ...). *) let can_omit_stdlib_param func_sig = func_sig.builtin && let declared_param = (* parameter N, declared as {N} or {M,N} *) match func_sig.parameters with | [ (n, _) ] | [ _; (n, _) ] -> Some n | _ -> None and declared_first_arg_width = (* first argument, declared as bits(N') *) match func_sig.args with | (_, { desc = T_Bits ({ desc = E_Var n' }, _) }) :: _ -> Some n' | _ -> None in match (declared_param, declared_first_arg_width) with | Some n, Some n' -> String.equal n n' | _ -> false (** Special treatment to infer the single input parameter [N] of a stdlib/primitive function with a first argument of type [bits(N)]. *) let insert_stdlib_param ~loc env func_sig ~params ~arg_types = if can_omit_stdlib_param func_sig && List.compare_lengths params func_sig.parameters < 0 && not (list_is_empty arg_types) then let width = get_bitvector_width ~loc env (List.hd arg_types) in let param_type = integer_exact' width |> add_pos_from ~loc:width in let ses_param = (* This is enough as the bitvector width is statically evaluable and its timeframe is earlier than the argument itself. *) SES.empty in params @ [ (param_type, width, ses_param) ] else params (* Begin TBitField *) let rec annotate_bitfield ~loc env width bitfield : bitfield * SES.t = match bitfield with | BitField_Simple (name, slices) -> let slices1, ses_slices = annotate_slices ~loc env slices in let+ () = check_slices_in_width ~loc env width slices1 in (BitField_Simple (name, slices1), ses_slices) |: TypingRule.TBitField | BitField_Nested (name, slices, bitfields') -> let slices1, ses_slices = annotate_slices ~loc env slices in let diet = disjoint_slices_to_positions ~loc env slices1 in let+ () = check_diet_in_width ~loc slices1 width diet in let width' = Diet.Int.cardinal diet |> expr_of_int in let new_bitfields, ses_bitfields = annotate_bitfields ~loc env width' bitfields' in let ses = SES.union ses_slices ses_bitfields in (BitField_Nested (name, slices1, new_bitfields), ses) |: TypingRule.TBitField | BitField_Type (name, slices, ty) -> let ty', ses_ty = annotate_type ~loc env ty in let slices1, ses_slices = annotate_slices ~loc env slices in let diet = disjoint_slices_to_positions ~loc env slices1 in let+ () = check_diet_in_width ~loc slices1 width diet in let width' = Diet.Int.cardinal diet |> expr_of_int in let+ () = t_bits_bitwidth width' |> add_dummy_annotation |> check_bits_equal_width ~loc env ty in let ses = SES.union ses_ty ses_slices in (BitField_Type (name, slices1, ty'), ses) |: TypingRule.TBitField (* End *) (* Begin TBitFields *) and annotate_bitfields ~loc env e_width bitfields = let+ () = match get_first_duplicate (List.map bitfield_get_name bitfields) with | None -> ok | Some x -> fun () -> fatal_from ~loc (Error.AlreadyDeclaredIdentifier x) in let width = let v = StaticInterpreter.static_eval env e_width in match v with L_Int i -> Z.to_int i | _ -> assert false in let new_bitfields, sess = list_map_split (annotate_bitfield ~loc env width) bitfields in let ses = ses_non_conflicting_unions ~loc sess in (new_bitfields, ses) |: TypingRule.TBitFields (* End *) and annotate_type ?(decl = false) ~(loc : 'a annotated) env ty : ty * SES.t = let () = if false then Format.eprintf "Annotating@ %a@ in env:@ %a@." PP.pp_ty ty pp_env env in let here t = add_pos_from ~loc:ty t in best_effort (ty, SES.empty) @@ fun _ -> match ty.desc with (* Begin TString *) | T_String -> (ty, SES.empty) |: TypingRule.TString (* Begin TReal *) | T_Real -> (ty, SES.empty) |: TypingRule.TReal (* Begin TBool *) | T_Bool -> (ty, SES.empty) |: TypingRule.TBool (* Begin TNamed *) | T_Named x -> let ses = (* As expression on which types depend are statically evaluable, using a named type is as reading a global immutable storage element. *) let time_frame = match IMap.find_opt x env.global.declared_types with | Some (_, t) -> t | None -> undefined_identifier ~loc x and immutable = true in SES.reads_global x time_frame immutable in (ty, ses) |: TypingRule.TNamed (* Begin TInt *) | T_Int constraints -> (match constraints with | PendingConstrained -> fatal_from ~loc Error.UnexpectedPendingConstrained | WellConstrained [] -> fatal_from ~loc Error.EmptyConstraints | WellConstrained constraints -> let new_constraints, sess = list_map_split (annotate_constraint ~loc env) constraints in let ses = SES.unions sess in (T_Int (WellConstrained new_constraints) |> here, ses) | Parameterized (_, name) -> (ty, SES.reads_local name TimeFrame.Constant true) | UnConstrained -> (ty, SES.empty)) |: TypingRule.TInt (* Begin TBits *) | T_Bits (e_width, bitfields) -> let t_width, e_width', ses_width = annotate_expr env e_width in let+ () = check_symbolically_evaluable e_width ses_width in let+ () = check_constrained_integer ~loc:e_width env t_width in let bitfields', ses_bitfields = if bitfields = [] then (bitfields, SES.empty) else let annotated_bitfields, ses_bitfields = annotate_bitfields ~loc env e_width' bitfields in let () = let width = match StaticInterpreter.static_eval env e_width' with | L_Int i -> Z.to_int i | _ -> assert false in CheckCommonBitfieldsAlign.check ~loc:ty env annotated_bitfields width |: TypingRule.CheckCommonBitfieldsAlign in (annotated_bitfields, ses_bitfields) in let ses = SES.union ses_width ses_bitfields in (T_Bits (e_width', bitfields') |> here, ses) |: TypingRule.TBits (* Begin TTuple *) | T_Tuple tys -> let tys', sess = list_map_split (annotate_type ~loc env) tys in let ses = SES.unions sess in (T_Tuple tys' |> here, ses) |: TypingRule.TTuple (* Begin TArray *) | T_Array (index, t) -> let t', ses_t = annotate_type ~loc env t and index', ses_index = match index with | ArrayLength_Expr e -> ( match get_variable_enum' env e with | Some (s, labels) -> (ArrayLength_Enum (s, labels), SES.empty) | None -> let e', ses = annotate_symbolic_integer ~loc env e in (ArrayLength_Expr e', ses)) | ArrayLength_Enum (_, _) -> assert (* Enumerated indices only exist in the typed AST. *) false in let ses = SES.union ses_t ses_index in (T_Array (index', t') |> here, ses) |: TypingRule.TArray (* Begin TStructuredDecl *) | (T_Record fields | T_Exception fields) when decl -> ( let+ () = match get_first_duplicate (List.map fst fields) with | None -> ok | Some x -> fun () -> fatal_from ~loc (Error.AlreadyDeclaredIdentifier x) in let fields', sess = list_map_split (fun (x, ty) -> let ty', ses = annotate_type ~loc env ty in ((x, ty'), ses)) fields in let ses = SES.unions sess in match ty.desc with | T_Record _ -> (T_Record fields' |> here, ses) |: TypingRule.TStructuredDecl | T_Exception _ -> (T_Exception fields' |> here, ses) |: TypingRule.TStructuredDecl | _ -> assert false (* Begin TEnumDecl *)) | T_Enum li when decl -> let+ () = match get_first_duplicate li with | None -> ok | Some x -> fun () -> fatal_from ~loc (Error.AlreadyDeclaredIdentifier x) in let+ () = fun () -> List.iter (fun s -> check_var_not_in_genv ~loc env.global s ()) li in (ty, SES.empty) |: TypingRule.TEnumDecl (* Begin TNonDecl *) | T_Enum _ | T_Record _ | T_Exception _ -> if decl then assert false else fatal_from ~loc (Error.NotYetImplemented " Cannot use non anonymous form of enumerations, record, or \ exception here.") |: TypingRule.TNonDecl (* End *) (* Begin AnnotateSymbolicallyEvaluableExpr *) and annotate_symbolically_evaluable_expr env e = let t, e', ses = annotate_expr env e in let+ () = check_symbolically_evaluable e ses in (t, e', ses) (* End *) (* Begin AnnotateSymbolicInteger *) and annotate_symbolic_integer ~(loc : 'a annotated) env e = let t, e', ses = annotate_symbolically_evaluable_expr env e in let+ () = check_structure_integer ~loc env t in (StaticModel.try_normalize env e', ses) (* End *) (* Begin SymbolicConstrainedInteger *) and annotate_symbolic_constrained_integer ~(loc : 'a annotated) env e = let t, e', ses = annotate_symbolically_evaluable_expr env e in let+ () = check_constrained_integer ~loc env t in (StaticModel.try_normalize env e', ses) (* End *) (* Begin AnnotateConstraint *) and annotate_constraint ~loc env = function | Constraint_Exact e -> let e', ses = annotate_symbolic_constrained_integer ~loc env e in (Constraint_Exact e', ses) | Constraint_Range (e1, e2) -> let e1', ses1 = annotate_symbolic_constrained_integer ~loc env e1 and e2', ses2 = annotate_symbolic_constrained_integer ~loc env e2 in let ses = SES.union ses1 ses2 in (Constraint_Range (e1', e2'), ses) (* End *) and annotate_slices env ~loc = (* Rules: - Rule WZCS: The width of a bitslice must be any non-negative, statically evaluable integer expression (including zero). *) (* Begin Slice *) let rec annotate_slice s = let () = if false then Format.eprintf "Annotating slice %a@." PP.pp_slice_list [ s ] in match s with | Slice_Single i -> (* LRM R_GXKG: The notation b[i] is syntactic sugar for b[i +: 1]. *) annotate_slice (Slice_Length (i, one_expr)) |: TypingRule.Slice | Slice_Length (offset, length) -> let t_offset, offset', ses_offset = annotate_expr env offset and length', ses_length = annotate_symbolic_constrained_integer ~loc env length in let+ () = check_structure_integer ~loc:offset env t_offset in let ses = SES.union ses_length ses_offset in (Slice_Length (offset', length'), ses |: TypingRule.Slice) | Slice_Range (j, i) -> (* LRM R_GXKG: The notation b[j:i] is syntactic sugar for b[i +: j-i+1]. *) let pre_length = binop MINUS j i |> binop PLUS !$1 in annotate_slice (Slice_Length (i, pre_length)) |: TypingRule.Slice | Slice_Star (factor, pre_length) -> (* LRM R_GXQG: The notation b[i *: n] is syntactic sugar for b[i*n +: n] *) let pre_offset = binop MUL factor pre_length in annotate_slice (Slice_Length (pre_offset, pre_length)) |: TypingRule.Slice (* End *) in fun slices -> let slices, sess = list_map_split annotate_slice slices in let ses = ses_non_conflicting_unions ~loc sess in (slices, ses) and annotate_pattern ~loc env t p = let here = add_pos_from ~loc:p in match p.desc with (* Begin PAll *) | Pattern_All -> (p, SES.empty) |: TypingRule.PAll (* End *) (* Begin PAny *) | Pattern_Any li -> let new_li, sess = list_map_split (annotate_pattern ~loc env t) li in let ses = (* They can't be conflicting because they are statically evaluable *) SES.unions sess in (Pattern_Any new_li |> here, ses) |: TypingRule.PAny (* End *) (* Begin PNot *) | Pattern_Not q -> let new_q, ses = annotate_pattern ~loc env t q in (Pattern_Not new_q |> here, ses) |: TypingRule.PNot (* End *) (* Begin PSingle *) | Pattern_Single e -> let t_e, e', ses = annotate_expr env e in let+ () = check_symbolically_evaluable e ses in let+ () = fun () -> let t_struct = Types.make_anonymous env t and t_e_struct = Types.make_anonymous env t_e in match (t_struct.desc, t_e_struct.desc) with | T_Bool, T_Bool | T_Real, T_Real | T_Int _, T_Int _ | T_String, T_String -> () | T_Bits _, T_Bits _ -> check_bits_equal_width ~loc env t_struct t_e_struct () | T_Enum li1, T_Enum li2 when list_equal String.equal li1 li2 -> () | _ -> fatal_from ~loc (Error.BadPattern (p, t)) in (Pattern_Single e' |> here, ses) |: TypingRule.PSingle (* End *) (* Begin PGeq *) | Pattern_Geq e -> let t_e, e', ses = annotate_expr env e in let+ () = check_symbolically_evaluable e ses in let+ () = fun () -> let t_struct = Types.get_structure env t and t_e_struct = Types.get_structure env t_e in match (t_struct.desc, t_e_struct.desc) with | T_Real, T_Real | T_Int _, T_Int _ -> () | _ -> fatal_from ~loc (Error.BadPattern (p, t)) in (Pattern_Geq e' |> here, ses) |: TypingRule.PGeq (* End *) (* Begin PLeq *) | Pattern_Leq e -> let t_e, e', ses = annotate_expr env e in let+ () = check_symbolically_evaluable e ses in let+ () = fun () -> let t_anon = Types.make_anonymous env t and t_e_anon = Types.make_anonymous env t_e in match (t_anon.desc, t_e_anon.desc) with | T_Real, T_Real | T_Int _, T_Int _ -> () | _ -> fatal_from ~loc (Error.BadPattern (p, t)) in (Pattern_Leq e' |> here, ses) |: TypingRule.PLeq (* End *) (* Begin PRange *) | Pattern_Range (e1, e2) -> let t_e1, e1', ses1 = annotate_symbolically_evaluable_expr env e1 and t_e2, e2', ses2 = annotate_symbolically_evaluable_expr env e2 in let ses = (* They can't be conflicting because they are statically evaluable *) SES.union ses1 ses2 in let+ () = fun () -> let t_anon = Types.make_anonymous env t and t_e1_anon = Types.make_anonymous env t_e1 and t_e2_anon = Types.make_anonymous env t_e2 in match (t_anon.desc, t_e1_anon.desc, t_e2_anon.desc) with | T_Real, T_Real, T_Real | T_Int _, T_Int _, T_Int _ -> () | _ -> fatal_from ~loc (Error.BadPattern (p, t)) in (Pattern_Range (e1', e2') |> here, ses) |: TypingRule.PRange (* End *) (* Begin PMask *) | Pattern_Mask m -> let+ () = check_structure_bits ~loc env t in let+ () = let n = !$(Bitvector.mask_length m) in let t_m = T_Bits (n, []) |> add_pos_from ~loc in check_type_satisfies ~loc env t t_m in (p, SES.empty) |: TypingRule.PMask (* End *) (* Begin PTuple *) | Pattern_Tuple li -> ( let t_struct = Types.get_structure env t in match t_struct.desc with | T_Tuple ts when List.compare_lengths li ts != 0 -> fatal_from ~loc (Error.BadArity ( Static, "pattern matching on tuples", List.length li, List.length ts )) | T_Tuple ts -> let new_li, sess = List.map2 (annotate_pattern ~loc env) ts li |> List.split in let ses = SES.unions (* They can't be conflicting because they are static *) sess in (Pattern_Tuple new_li |> here, ses) |: TypingRule.PTuple | _ -> conflict ~loc [ T_Tuple [] ] t (* End *)) (* Begin AnnotateCall *) and annotate_call ~loc env (call_info : call) = let () = if false then Format.eprintf "Annotating call to %S (%s) at %a.@." call_info.name (Serialize.subprogram_type_to_string call_info.call_type) PP.pp_pos loc in let args = List.map (annotate_expr env) call_info.args in match (loc.version, call_info.params) with | V0, [] -> let () = assert (List.length call_info.params = 0) in annotate_call_v0 ~loc env call_info.name args call_info.call_type | (V1 | V0), _ -> let params = List.map (annotate_expr env) call_info.params in annotate_call_v1 ~loc env call_info.name ~params ~args ~call_type:call_info.call_type |: TypingRule.AnnotateCall (* End *) (* Begin AnnotateCallActualsTyped *) and annotate_call_v1 ~loc env name ~params ~args ~call_type = let arg_types, args, sess_args = list_split3 args in let ses_args = ses_non_conflicting_unions ~loc sess_args in let _, name, func_sig, ses_call = Fn.try_subprogram_for_name ~loc env V1 name arg_types in let ses = SES.union ses_args ses_call in (* Check call and subprogram types match *) let+ () = check_true (func_sig.subprogram_type = call_type (* Getters are syntactically identical to functions in V1 - so what looks like a function call may really be a getter call *) || (func_sig.subprogram_type = ST_Getter && call_type = ST_Function)) @@ fun () -> fatal_from ~loc (MismatchedReturnValue name) in (* Insert omitted parameter for standard library call *) let params = insert_stdlib_param ~loc env func_sig ~params ~arg_types in (* Check correct number of parameters/arguments supplied *) let () = if List.compare_lengths func_sig.parameters params != 0 then fatal_from ~loc @@ Error.BadParameterArity ( Static, V1, name, List.length func_sig.parameters, List.length params ) else if List.compare_lengths func_sig.args args != 0 then fatal_from ~loc @@ Error.BadArity (Static, name, List.length func_sig.args, List.length args) in (* Check that call parameters are statically evaluable and type-satisfy the declaration parameters *) let () = (* CheckParamsTypeSat( *) List.iter2 (fun (name, ty_declared_opt) (ty_actual, e_actual, ses_actual) -> let+ () = check_symbolically_evaluable e_actual ses_actual in (* That's enough of a check on Side Effects for parameters: - parameters can't conflict with anything once they are statically evaluable; - the time-frame of parameters has to be earlier than the arguments that use their types. *) let+ () = check_constrained_integer ~loc env ty_actual in match ty_declared_opt with | None -> (* declared parameters have already been elaborated *) assert false | Some { desc = T_Int (Parameterized (_, name')) } when String.equal name name' -> () | Some ty_declared -> let+ () = check_type_satisfies ~loc env ty_actual ty_declared in ()) func_sig.parameters params (* CheckParamsTypeSat) *) in (* Check that call arguments type-satisfy the declared arguments *) let eqs = List.map2 (fun (name, _) (_, e, _) -> (name, e)) func_sig.parameters params in (* CheckArgsTypeSat( *) let () = List.iter2 (fun (_, declared_ty) actual_ty -> let expected_ty = rename_ty_eqs env eqs declared_ty in let+ () = check_type_satisfies ~loc env actual_ty expected_ty in ()) func_sig.args arg_types (* CheckArgsTypeSat) *) in (* Check the function returns as expected, and substitute parameters into the return type *) let return_type = match (call_type, func_sig.return_type) with | (ST_Function | ST_Getter), Some ty -> Some (rename_ty_eqs env eqs ty) | (ST_Procedure | ST_Setter), None -> None | _ -> fatal_from ~loc @@ Error.MismatchedReturnValue name in ( { name; args; params = List.map (fun (_, e, _) -> e) params; call_type = func_sig.subprogram_type; }, return_type, ses ) (* End *) and annotate_call_v0 ~loc env name caller_args_typed call_type = let caller_arg_types, args1, sess = list_split3 caller_args_typed in let ses1 = ses_non_conflicting_unions ~loc sess in let eqs1, name1, callee, ses2 = Fn.try_subprogram_for_name ~loc env V0 name caller_arg_types in let ses3 = SES.union ses1 ses2 in let () = if false then Format.eprintf "@[Found candidate decl:@ @[%a@]@]@." PP.pp_t [ D_Func callee |> add_dummy_annotation ] in let+ () = check_true (callee.subprogram_type = call_type) @@ fun () -> fatal_from ~loc (MismatchedReturnValue name) in let () = if false then let open Format in eprintf "Parameters for this call: %a@." (pp_print_list ~pp_sep:pp_print_space (fun f (name, e) -> fprintf f "%S<--%a" name (pp_print_option PP.pp_ty) e)) callee.parameters in let () = if false then match eqs1 with | [] -> () | _ -> Format.eprintf "@[<2>%a: Adding@ @[{%a}@]@ to call of %s@." PP.pp_pos loc (Format.pp_print_list ~pp_sep:(fun f () -> Format.fprintf f ";@ ") (fun f (n, e) -> Format.fprintf f "@[%s@ <- %a@]" n PP.pp_expr e)) eqs1 name in let () = if List.compare_lengths callee.args args1 != 0 then fatal_from ~loc @@ Error.BadArity (Static, name, List.length callee.args, List.length args1) in let eqs2 = let folder acc (_x, ty) (t_e, _e, _ses) = match ty.desc with | T_Bits ({ desc = E_Var param_name; _ }, _) -> ( match (Types.make_anonymous env t_e).desc with | T_Bits (param_actual_e, _) -> ( (* If param has another defining expression, we need to check that they are equal. *) match List.assoc_opt param_name acc with | Some param_actual_e2 when StaticModel.equal_in_env env param_actual_e param_actual_e2 -> (* If they are, we can ignore the other expression. *) acc | Some _ (* If they are not equal, the parameter satisfaction later will fail. *) | None (* If there are no other defining expression, there is nothing to check. *) -> (* We don't need to check that param_actual_e is a static constrained integer, because it comes from a bitvector type. *) (param_name, param_actual_e) :: acc) | _ -> acc) | _ -> acc in match C.check with | TypeCheckNoWarn | TypeCheck -> eqs1 | Warn | Silence -> List.fold_left2 folder eqs1 callee.args caller_args_typed in let eqs3 = (* Checking that all parameter-defining arguments are static constrained integers. *) List.fold_left2 (fun eqs (callee_x, _) (caller_ty, caller_e, caller_ses) -> (* If [callee_x] is a parameter-defining argument. *) if List.exists (fun (p_name, _ty) -> String.equal callee_x p_name) callee.parameters then let+ () = check_symbolically_evaluable caller_e caller_ses in let+ () = check_constrained_integer ~loc env caller_ty in (callee_x, caller_e) :: eqs else eqs) eqs2 callee.args caller_args_typed in let () = if false then let open Format in eprintf "@[Eqs for this call are: %a@]@." (pp_print_list ~pp_sep:pp_print_space (fun f (name, e) -> fprintf f "%S<--%a" name PP.pp_expr e)) eqs3 in (* check that the caller argument types type-satisfy their corresponding callee formal types. *) let () = List.iter2 (fun (callee_arg_name, callee_arg) caller_arg -> let callee_arg1 = rename_ty_eqs env eqs3 callee_arg in let () = if false then Format.eprintf "Checking calling arg %s from %a to %a@." callee_arg_name PP.pp_ty caller_arg PP.pp_ty callee_arg1 in let+ () = check_type_satisfies ~loc env caller_arg callee_arg1 in ()) callee.args caller_arg_types in let () = if false && not (String.equal name name1) then Format.eprintf "Renaming call from %s to %s@ at %a.@." name name1 PP.pp_pos loc in (* check_callee_params: check that the callee parameters are correctly typed with respect to the parameter expressions. *) let () = List.iter (function | _, None -> () | s, Some { desc = T_Int (Parameterized (_, s')); _ } when String.equal s' s -> () | callee_param_name, Some callee_param_t -> let callee_param_t_renamed = rename_ty_eqs env eqs3 callee_param_t in let caller_param_e = match List.assoc_opt callee_param_name eqs3 with | None -> assert false (* Bad behaviour, there should be a defining expression *) | Some e -> e in let caller_param_t, _, _ = annotate_symbolically_evaluable_expr env caller_param_e in let () = if false then Format.eprintf "Checking calling param %s from %a to %a (i.e. %a)@." callee_param_name PP.pp_ty caller_param_t PP.pp_ty callee_param_t PP.pp_ty callee_param_t_renamed in let+ () = check_type_satisfies ~loc env caller_param_t callee_param_t_renamed in ()) callee.parameters in (* check that the formal return type matches [call_type] and substitute actual parameter arguments in the formal return type. *) let ret_ty_opt = match (call_type, callee.return_type) with | (ST_Function | ST_Getter | ST_EmptyGetter), Some ty -> Some (rename_ty_eqs env eqs3 ty) | (ST_Setter | ST_EmptySetter | ST_Procedure), None -> None | _ -> fatal_from ~loc @@ Error.MismatchedReturnValue name in let () = if false then Format.eprintf "Annotated call to %S.@." name1 in let params = List.filter_map (fun (name, _) -> List.assoc_opt name eqs3) callee.parameters in let+ () = check_true (List.length params = List.length callee.parameters) @@ fun () -> fatal_from ~loc (Error.BadParameterArity (Static, V0, name, List.length callee.parameters, List.length params)) in ( { name = name1; args = args1; params; call_type = callee.subprogram_type }, ret_ty_opt, ses3 ) and annotate_expr env (e : expr) : ty * expr * SES.t = let () = if false then Format.eprintf "@[Annotating %a@]@." PP.pp_expr e in let here x = add_pos_from ~loc:e x and loc = to_pos e in match e.desc with (* Begin ELit *) | E_Literal v -> (annotate_literal env v |> here, e, SES.empty) |: TypingRule.ELit (* End *) (* Begin ATC *) | E_ATC (e', ty) -> let t, e'', ses_e = annotate_expr env e' in let t_struct = Types.get_structure env t in let ty', ses_ty = annotate_type ~loc env ty in let ty_struct = Types.get_structure env ty' in let+ () = check_atc env t_struct ty_struct ~fail:(fun () -> fatal_from ~loc (BadATC (t, ty))) in let ses = SES.union ses_ty @@ SES.add_assertion ses_e in (if Types.subtype_satisfies env t_struct ty_struct then (ty', e'', ses_e) else (ty', E_ATC (e'', ty_struct) |> here, ses)) |: TypingRule.ATC (* End *) (* Begin EVar *) | E_Var x -> ( let () = if false then Format.eprintf "Looking at %S.@." x in if e.version = V0 && should_reduce_to_call env x ST_EmptyGetter then let () = if false then Format.eprintf "@[Reducing getter %S@ at %a@]@." x PP.pp_pos e in let call_type = ST_EmptyGetter in let call, ty, ses = annotate_call ~loc:(to_pos e) env { name = x; params = []; args = []; call_type } in let ty = match ty with Some ty -> ty | None -> assert false in (ty, E_Call call |> here, ses) else let () = if false then Format.eprintf "@[Choosing not to reduce var %S@ at @[%a@]@]@." x PP.pp_pos e in try match IMap.find x env.local.storage_types with | ty, LDK_Constant when Storage.mem x env.local.constant_values -> let v = Storage.find x env.local.constant_values in (ty, E_Literal v |> here, SES.empty) |: TypingRule.EVar | ty, ldk -> let ses = SES.reads_local x (TimeFrame.of_ldk ldk) (ldk_is_immutable ldk) in (ty, e, ses) |: TypingRule.EVar with Not_found -> ( try match IMap.find x env.global.storage_types with | ty, GDK_Constant when Storage.mem x env.global.constant_values -> let v = Storage.find x env.global.constant_values in (ty, E_Literal v |> here, SES.empty) |: TypingRule.EVar | ty, gdk -> let ses = SES.reads_global x (TimeFrame.of_gdk gdk) (gdk_is_immutable gdk) in (ty, e, ses) |: TypingRule.EVar with Not_found -> let () = if false then Format.eprintf "@[Cannot find %s in env@ %a.@]@." x pp_env env in undefined_identifier ~loc:e x |: TypingRule.EVar)) (* End *) (* Begin Binop *) | E_Binop (op, e1, e2) -> let t1, e1', ses1 = annotate_expr env e1 in let t2, e2', ses2 = annotate_expr env e2 in let t = apply_binop_types ~loc env op t1 t2 in let ses = if binop_is_ordered op then SES.union ses1 ses2 else ses_non_conflicting_union ~loc ses1 ses2 in (t, E_Binop (op, e1', e2') |> here, ses) |: TypingRule.Binop (* End *) (* Begin Unop *) | E_Unop (op, e') -> let t'', e'', ses = annotate_expr env e' in let t = apply_unop_type ~loc env op t'' in (t, E_Unop (op, e'') |> here, ses) |: TypingRule.Unop (* End *) (* Begin ECall *) | E_Call call -> let call, ret_ty_opt, ses = annotate_call ~loc:(to_pos e) env call in let t = match ret_ty_opt with Some ty -> ty | None -> assert false in (t, E_Call call |> here, ses) |: TypingRule.ECall (* End *) (* Begin ECond *) | E_Cond (e_cond, e_true, e_false) -> let t_cond, e_cond', ses_cond = annotate_expr env e_cond in let+ () = check_structure_boolean ~loc env t_cond in let t_true, e_true', ses_true = annotate_expr env e_true and t_false, e_false', ses_false = annotate_expr env e_false in let t = best_effort t_true (fun _ -> match Types.lowest_common_ancestor env t_true t_false with | None -> fatal_from ~loc (Error.UnreconciliableTypes (t_true, t_false)) | Some t -> t) in let ses = SES.union3 ses_cond ses_true ses_false in (t, E_Cond (e_cond', e_true', e_false') |> here, ses) |: TypingRule.ECond (* End *) | E_Tuple [ e ] -> annotate_expr env e (* Begin ETuple *) | E_Tuple li -> let ts, es, sess = List.map (annotate_expr env) li |> list_split3 in let ses = ses_non_conflicting_unions ~loc sess in (T_Tuple ts |> here, E_Tuple es |> here, ses) |: TypingRule.ETuple (* End *) | E_Array _ -> fatal_from ~loc UnrespectedParserInvariant (* Begin ERecord *) | E_Record (ty, fields) -> (* Rule WBCQ: The identifier in a record expression must be a named type with the structure of a record type, and whose fields have the values given in the field_assignment_list. Rule WZWC: The identifier in a exception expression must be a named type with the structure of an exception type, and whose fields have the values given in the field_assignment_list. *) let+ () = check_true (Types.is_named ty) (fun () -> failwith "Typing error: should be a named type") in best_effort (ty, e, SES.empty) @@ fun _ -> let field_types = match (Types.make_anonymous env ty).desc with | T_Exception fields | T_Record fields -> fields | _ -> conflict ~loc [ T_Record [] ] ty in (* Rule DYQZ: A record expression shall assign every field of the record. *) let () = if List.for_all (fun (name, _) -> List.mem_assoc name fields) field_types then () else fatal_from ~loc (Error.MissingField (List.map fst fields, ty)) (* and whose fields have the values given in the field_assignment_list. *) in let+ () = match get_first_duplicate (List.map fst fields) with | None -> ok | Some x -> fun () -> fatal_from ~loc (Error.AlreadyDeclaredIdentifier x) in let annotate_field_init (name, e') = let t', e'', ses = annotate_expr env e' in let t_spec' = match List.assoc_opt name field_types with | None -> fatal_from ~loc (Error.BadField (name, ty)) | Some t_spec' -> t_spec' in let+ () = check_type_satisfies ~loc env t' t_spec' in ((name, e''), ses) |: TypingRule.AnnotateFieldInit in let fields', sess = list_map_split annotate_field_init fields in let ses = ses_non_conflicting_unions ~loc sess in (ty, E_Record (ty, fields') |> here, ses) |: TypingRule.ERecord (* End *) (* Begin EArbitrary *) | E_Arbitrary ty -> let ty1, ses_ty = annotate_type ~loc env ty in let ty2 = Types.get_structure env ty1 in let ses = SES.add_non_determinism ses_ty in (ty1, E_Arbitrary ty2 |> here, ses) |: TypingRule.EArbitrary (* End *) | E_Slice (e', slices) -> ( match e'.desc with | E_Var name when e'.version = V0 && should_reduce_to_call env name ST_Getter && List.for_all slice_is_single slices -> let args = try List.map slice_as_single slices with Invalid_argument _ -> assert false in let call, ty, ses = annotate_call ~loc:(to_pos e) env { name; params = []; args; call_type = ST_Getter } in let ty = match ty with Some ty -> ty | None -> assert false in (ty, E_Call call |> here, ses) | _ -> ( let t_e', e'', ses1 = annotate_expr env e' in let struct_t_e' = Types.make_anonymous env t_e' in match struct_t_e'.desc with (* Begin ESlice *) | T_Int _ | T_Bits _ -> let+ () = check_true (not (list_is_empty slices)) @@ fun () -> fatal_from ~loc Error.EmptySlice in (* TODO: check that: - Rule SNQJ: An expression or subexpression which may result in a zero-length bitvector must not be side-effecting. *) let slices', ses2 = best_effort (slices, SES.empty) (fun _ -> annotate_slices env slices ~loc) in let w = slices_width env slices' in let ses = SES.union ses1 ses2 in (T_Bits (w, []) |> here, E_Slice (e'', slices') |> here, ses) |: TypingRule.ESlice (* End *) | T_Array (size, ty') when e'.version = V0 -> ( match slices with | [ Slice_Single e_index ] -> annotate_get_array ~loc env (size, ty') (e'', ses1, e_index) | _ -> conflict ~loc [ integer'; default_t_bits ] t_e') (* Begin ESliceError *) | _ -> conflict ~loc [ integer'; default_t_bits ] t_e' |: TypingRule.ESliceError (* End *))) | E_GetField (e1, field_name) -> ( let reduced = if e1.version = V0 && C.use_field_getter_extension then reduce_getfields_to_slices env e1 [ field_name ] else None in match reduced with | Some (name, args) -> let call, ty, ses = annotate_call ~loc:(to_pos e) env { name; params = []; args; call_type = ST_Getter } in let ty = match ty with Some ty -> ty | None -> assert false in (ty, E_Call call |> here, ses) | None -> ( let t_e2, e2, ses1 = annotate_expr env e1 in match (Types.make_anonymous env t_e2).desc with | T_Exception fields | T_Record fields -> ( match List.assoc_opt field_name fields with (* Begin EGetBadRecordField *) | None -> fatal_from ~loc (Error.BadField (field_name, t_e2)) |: TypingRule.EGetBadRecordField (* End *) (* Begin EGetRecordField *) | Some t -> (t, E_GetField (e2, field_name) |> here, ses1) |: TypingRule.EGetRecordField (* End *)) | T_Bits (_, bitfields) -> ( match find_bitfield_opt field_name bitfields with (* Begin EGetBadBitField *) | None -> fatal_from ~loc (Error.BadField (field_name, t_e2)) |: TypingRule.EGetBadBitField (* End *) (* Begin EGetBitField *) | Some (BitField_Simple (_field, slices)) -> let e3 = E_Slice (e1, slices) |> here in annotate_expr env e3 |: TypingRule.EGetBitField (* End *) (* Begin EGetBitFieldNested *) | Some (BitField_Nested (_field, slices, bitfields')) -> let e3 = E_Slice (e1, slices) |> here in let t_e4, new_e, ses_new = annotate_expr env e3 in let t_e5 = match t_e4.desc with | T_Bits (width, _bitfields) -> T_Bits (width, bitfields') |> add_pos_from ~loc:t_e2 | _ -> assert false in (t_e5, new_e, ses_new) |: TypingRule.EGetBitFieldNested (* End *) (* Begin EGetBitFieldTyped *) | Some (BitField_Type (_field, slices, t)) -> let e3 = E_Slice (e1, slices) |> here in let t_e4, new_e, ses_new = annotate_expr env e3 in let+ () = check_type_satisfies ~loc env t_e4 t in (t, new_e, ses_new) |: TypingRule.EGetBitFieldTyped (* End *)) (* Begin EGetTupleItem *) | T_Tuple tys -> let index = try Scanf.sscanf field_name "item%u" Fun.id with Scanf.Scan_failure _ | Failure _ | End_of_file -> fatal_from ~loc (Error.BadField (field_name, t_e2)) in if 0 <= index && index < List.length tys then ( List.nth tys index, E_GetItem (e2, index) |> add_pos_from ~loc:e, ses1 ) else fatal_from ~loc (Error.BadField (field_name, t_e2)) |: TypingRule.EGetTupleItem (* End *) (* Begin EGetBadField *) | _ -> fatal_from ~loc (Error.BadField (field_name, t_e2)) |: TypingRule.EGetBadField) (* End *)) (* Begin E_GetFields *) | E_GetFields (e_base, fields) -> ( let reduced = if e_base.version = V0 && C.use_field_getter_extension then reduce_getfields_to_slices env e_base fields else None in match reduced with | Some (name, args) -> let call, ret_ty_opt, ses = annotate_call ~loc:(to_pos e) env { name; params = []; args; call_type = ST_Getter } in let ty = match ret_ty_opt with Some ty -> ty | None -> assert false in (ty, E_Call call |> here, ses) | None -> ( let t_base_annot, e_base_annot, ses_base = annotate_expr env e_base in match (Types.make_anonymous env t_base_annot).desc with | T_Bits (_, bitfields) -> let one_field field = match find_bitfields_slices_opt field bitfields with | None -> fatal_from ~loc (Error.BadField (field, t_base_annot)) | Some slices -> slices in E_Slice (e_base, list_concat_map one_field fields) |> here |> annotate_expr env |: TypingRule.EGetFields | T_Record base_fields -> let get_bitfield_width name = match List.assoc_opt name base_fields with | None -> fatal_from ~loc (Error.BadField (name, t_base_annot)) | Some t -> get_bitvector_width ~loc env t in let widths = List.map get_bitfield_width fields in let e_slice_width = let wh = List.hd widths and wts = List.tl widths in List.fold_left (width_plus env) wh wts in ( T_Bits (e_slice_width, []) |> here, E_GetFields (e_base_annot, fields) |> here, ses_base ) |: TypingRule.EGetFields | _ -> conflict ~loc [ default_t_bits ] t_base_annot)) (* End *) (* Begin EPattern *) | E_Pattern (e1, pat) -> (* Rule ZNDL states that The IN operator is equivalent to testing its first operand for equality against each value in the (possibly infinite) set denoted by the second operand, and taking the logical OR of the result. Values denoted by a bitmask_lit comprise all bitvectors that could match the bit-mask. It is not an error if any or all of the values denoted by the first operand can be statically determined to never compare equal with the second operand. e IN pattern is sugar for "-" -> TRUE | e1=expr -> e == e1 | bitmask_lit -> not yet implemented | e1=expr ".." e2=expr -> e1 <= e && e <= e2 | "<=" e1=expr -> e <= e1 | ">=" e1=expr -> e >= e1 | { p0 , ... pN } -> e IN p0 || ... e IN pN | !{ p0 , ... pN } -> not (e IN p0) && ... e IN pN We cannot reduce them here (as otherwise e might be evaluated a bad number of times), but we will apply the same typing rules as for those desugared expressions. *) let t_e2, e2, ses_e = annotate_expr env e1 in let pat', ses_pat = best_effort (pat, SES.empty) (fun _ -> annotate_pattern ~loc env t_e2 pat) in let ses = SES.union ses_pat ses_e (* e1 is evaluated before the pattern, so they are not concurrent. *) in (T_Bool |> here, E_Pattern (e2, pat') |> here, ses) |: TypingRule.EPattern (* End *) (* Begin EGetArray *) | E_GetArray (e_base, e_index) -> ( let t_base, e_base', ses_base = annotate_expr env e_base in let t_anon_base = Types.make_anonymous env t_base in match t_anon_base.desc with | T_Array (size, t_elem) -> annotate_get_array ~loc env (size, t_elem) (e_base', ses_base, e_index) | _ -> conflict ~loc [ default_array_ty ] t_base |: TypingRule.EGetArray ) (* End *) | E_GetItem _ | E_EnumArray _ | E_GetEnumArray _ -> assert false (* Begin AnnotateGetArray *) and annotate_get_array ~loc env (size, t_elem) (e_base, ses_base, e_index) = let t_index', e_index', ses_index = annotate_expr env e_index in let wanted_t_index = type_of_array_length ~loc size in let+ () = check_type_satisfies ~loc env t_index' wanted_t_index in let ses = ses_non_conflicting_union ~loc ses_index ses_base in let new_e = match size with | ArrayLength_Enum _ -> E_GetEnumArray (e_base, e_index') | ArrayLength_Expr _ -> E_GetArray (e_base, e_index') in (t_elem, new_e |> add_pos_from ~loc, ses) |: TypingRule.AnnotateGetArray (* End *) (** For an expression of the form [e1.[f1,...,fn]], if [e1] represents a call to a getter then this function returns a list of slices needed to read the bitfields [f1...fn]. Otherwise, the result is [None]. It is an ASLRef extension, guarded by [C.use_field_getter_extension]. *) and reduce_getfields_to_slices env e1 fields = assert (e1.version = V0 && C.use_field_getter_extension); match e1.desc with | E_Var name when should_reduce_to_call env name ST_Getter -> let empty_getter = E_Slice (e1, []) |> add_pos_from ~loc:e1 in let ty, _, _ = annotate_expr env empty_getter in should_fields_reduce_to_call env name ty fields | _ -> None (* ListMinAbs( *) let list_min_abs_z = let min_abs acc z = match Z.compare (Z.abs acc) (Z.abs z) with | -1 -> acc | 1 -> z | 0 -> if Z.sign acc >= 0 then acc else z (* bias towards positive *) | _ -> assert false in function | [] -> raise (Invalid_argument "list_min_abs_z") | h :: t -> List.fold_left min_abs h t (* ListMinAbs) *) (* Begin BaseValue *) (** [base_value_v1 ~loc env t] returns an expression building the base value of the type [t] in [env]. The base value expression can be used to initialize variables of type [t] in [env]. This expression is side-effect free, and is a literal for singular types. If a base value cannot be statically determined (e.g. for parameterized integer types), a type error is thrown, at the ~location [loc]. *) let rec base_value_v1 ~loc env t : expr = let here = add_pos_from ~loc in let lit v = here (E_Literal v) in let fatal_non_static e = fatal_from ~loc (Error.BaseValueNonStatic (t, e)) in let fatal_is_empty () = fatal_from ~loc (Error.BaseValueEmptyType t) in let reduce_to_z e = match StaticModel.reduce_to_z_opt env e with | None -> fatal_non_static e | Some i -> i in match t.desc with | T_Bool -> L_Bool false |> lit | T_Bits (e, _) -> let length = reduce_to_z e |> Z.to_int in L_BitVector (Bitvector.zeros length) |> lit | T_Enum [] -> assert false | T_Enum (name :: _) -> lookup_constants env name |> lit | T_Int UnConstrained -> L_Int Z.zero |> lit | T_Int (Parameterized (_, id)) -> E_Var id |> here |> fatal_non_static | T_Int PendingConstrained -> assert false | T_Int (WellConstrained cs) -> let constraint_abs_min = function | Constraint_Exact e -> Some (reduce_to_z e) | Constraint_Range (e1, e2) -> let v1 = reduce_to_z e1 in let v2 = reduce_to_z e2 in if v1 <= v2 then match Z.(sign v1, sign v2) with | -1, -1 -> (* v1 <= v2 < 0 *) Some v2 | -1, _ -> (* v1 < 0 <= v2 *) Some Z.zero | _, _ -> (* 0 <= v1 <= v2 *) Some v1 else None in let z_min_list = List.filter_map constraint_abs_min cs in if list_is_empty z_min_list then fatal_is_empty () else let z_min = list_min_abs_z z_min_list in L_Int z_min |> lit | T_Named _ -> Types.make_anonymous env t |> base_value_v1 ~loc env | T_Real -> L_Real Q.zero |> lit | T_Exception fields | T_Record fields -> let one_field (name, t_field) = (name, base_value_v1 ~loc env t_field) in E_Record (t, List.map one_field fields) |> here | T_String -> L_String "" |> lit | T_Tuple li -> let exprs = List.map (base_value_v1 ~loc env) li in E_Tuple exprs |> here | T_Array (index, ty) -> ( let value = base_value_v1 ~loc env ty in match index with | ArrayLength_Enum (enum, labels) -> E_EnumArray { enum; labels; value } |> here | ArrayLength_Expr length -> E_Array { length; value } |> here) (* End *) let rec base_value_v0 ~loc env t : expr = assert (loc.version = V0); let here = add_pos_from ~loc in match t.desc with | T_Bool | T_Int UnConstrained | T_Real | T_String | T_Enum _ -> base_value_v1 ~loc env t | T_Bits (width, _) -> let e = E_Call { name = "Zeros"; params = []; args = [ width ]; call_type = ST_Function; } in let _, e', _ = annotate_expr env (here e) in e' | T_Int (Parameterized (_, id)) -> E_Var id |> here | T_Int (WellConstrained [] | PendingConstrained) -> assert false | T_Int (WellConstrained ((Constraint_Exact e | Constraint_Range (e, _)) :: _)) -> e | T_Tuple li -> E_Tuple (List.map (base_value_v0 ~loc env) li) |> here | T_Exception fields | T_Record fields -> let fields = List.map (fun (name, t_field) -> (name, base_value_v0 ~loc env t_field)) fields in E_Record (t, fields) |> here | T_Array (length, ty) -> ( let value = base_value_v0 ~loc env ty in match length with | ArrayLength_Enum (enum, labels) -> E_EnumArray { enum; labels; value } |> here | ArrayLength_Expr length -> E_Array { length; value } |> here) | T_Named _id -> let t = Types.make_anonymous env t in base_value_v0 ~loc env t (** [base_value ~loc env e] is [base_value_v1 ~loc env e] if running for ASLv1, or [base_value_v0 ~loc env e] if running for ASLv0. *) let base_value ~loc env e = match loc.version with | V0 -> base_value_v0 ~loc env e | V1 -> base_value_v1 ~loc env e (* Begin AnnotateSetArray *) let annotate_set_array ~loc env (size, t_elem) rhs_ty (e_base, ses_base, e_index) = let+ () = check_type_satisfies ~loc env rhs_ty t_elem in let t_index', e_index', ses_index = annotate_expr env e_index in let wanted_t_index = type_of_array_length ~loc:e_base size in let+ () = check_type_satisfies ~loc env t_index' wanted_t_index in let ses = ses_non_conflicting_union ~loc ses_base ses_index in let new_le = match size with | ArrayLength_Enum _ -> LE_SetEnumArray (e_base, e_index') | ArrayLength_Expr _ -> LE_SetArray (e_base, e_index') in (new_le |> add_pos_from ~loc, ses) |: TypingRule.AnnotateSetArray (* End *) let rec annotate_lexpr env le t_e = let () = if false then Format.eprintf "Typing lexpr: @[%a@] to @[%a@]@." PP.pp_lexpr le PP.pp_ty t_e in let loc = to_pos le in let here x = add_pos_from ~loc x in match le.desc with (* Begin LEDiscard *) | LE_Discard -> (le, SES.empty) |: TypingRule.LEDiscard (* End *) (* Begin LEVar *) | LE_Var x -> let ty, ses = match IMap.find_opt x env.local.storage_types with | Some (ty, LDK_Var) -> (ty, SES.writes_local x) | Some _ -> fatal_from ~loc @@ Error.AssignToImmutable x | None -> ( match IMap.find_opt x env.global.storage_types with | Some (ty, GDK_Var) -> (ty, SES.writes_global x) | Some _ -> fatal_from ~loc @@ Error.AssignToImmutable x | None -> undefined_identifier ~loc x) in let+ () = check_type_satisfies ~loc env t_e ty in (le, ses) |: TypingRule.LEVar (* End *) (* Begin LEDestructuring *) | LE_Destructuring les -> (match t_e.desc with | T_Tuple tys -> if List.compare_lengths tys les != 0 then Error.fatal_from le (Error.BadArity (Static, "LEDestructuring", List.length tys, List.length les)) else let les', sess = List.map2 (annotate_lexpr env) les tys |> List.split in let ses = (* TODO left-hand-side conflicting union *) SES.unions sess in (LE_Destructuring les' |> here, ses) | _ -> conflict ~loc [ T_Tuple [] ] t_e) |: TypingRule.LEDestructuring (* End *) | LE_Slice (le1, slices) -> ( let t_le1, _, _ = expr_of_lexpr le1 |> annotate_expr env in let t_le1_anon = Types.make_anonymous env t_le1 in (* Begin LESlice *) match t_le1_anon.desc with | T_Bits _ -> let le2, ses1 = annotate_lexpr env le1 t_le1 in let+ () = fun () -> let width = slices_width env slices |> StaticModel.try_normalize env in let t = T_Bits (width, []) |> here in check_type_satisfies ~loc env t_e t () in let slices2, ses2 = best_effort (slices, SES.empty) @@ fun _ -> annotate_slices env slices ~loc in let+ () = check_disjoint_slices ~loc env slices2 in let+ () = check_true (not (list_is_empty slices)) @@ fun () -> fatal_from ~loc Error.EmptySlice in let ses = ses_non_conflicting_union ~loc ses1 ses2 in (LE_Slice (le2, slices2) |> here, ses |: TypingRule.LESlice) | T_Array (size, t) when le.version = V0 -> ( match slices with | [ Slice_Single e_index ] -> let le2, ses2 = annotate_lexpr env le1 t_le1 in annotate_set_array ~loc:le env (size, t) t_e (le2, ses2, e_index) | _ -> invalid_expr (expr_of_lexpr le1)) | _ -> conflict ~loc:le1 [ default_t_bits ] t_le1 (* End *)) | LE_SetField (le1, field) -> (let t_le1, _, _ = expr_of_lexpr le1 |> annotate_expr env in let le2, ses = annotate_lexpr env le1 t_le1 in let t_le1_anon = Types.make_anonymous env t_le1 in match t_le1_anon.desc with (* Begin LESetStructuredField *) | T_Exception fields | T_Record fields -> let t = match List.assoc_opt field fields with | None -> fatal_from ~loc (Error.BadField (field, t_le1)) | Some t -> t in let+ () = check_type_satisfies ~loc env t_e t in ( LE_SetField (le2, field) |> here, ses |: TypingRule.LESetStructuredField ) (* End *) (* Begin LESetBitField *) | T_Bits (_, bitfields) -> let bits slices bitfields = T_Bits (slices_width env slices, bitfields) |> here in let t, slices = match find_bitfield_opt field bitfields with | None -> fatal_from ~loc:le1 (Error.BadField (field, t_le1_anon)) | Some (BitField_Simple (_field, slices)) -> (bits slices [], slices) | Some (BitField_Nested (_field, slices, bitfields')) -> (bits slices bitfields', slices) | Some (BitField_Type (_field, slices, t)) -> let t' = bits slices [] in let+ () = check_type_satisfies ~loc env t' t in (t, slices) in let+ () = check_type_satisfies ~loc:le1 env t_e t in let le3 = LE_Slice (le1, slices) |> here in annotate_lexpr env le3 t_e |: TypingRule.LESetBitField (* End *) (* Begin LESetBadField *) | _ -> conflict ~loc:le1 [ default_t_bits; T_Record []; T_Exception [] ] t_e) |: TypingRule.LESetBadField (* End *) (* Begin LESetFields *) | LE_SetFields (le_base, le_fields, []) -> ( let t_base, _, _ = expr_of_lexpr le_base |> annotate_expr env in let le_base_annot, ses_base = annotate_lexpr env le_base t_base in let t_base_anon = Types.make_anonymous env t_base in match t_base_anon.desc with | T_Bits (_, bitfields) -> let slices_of_bitfield field = match find_bitfields_slices_opt field bitfields with | None -> fatal_from ~loc (Error.BadField (field, t_base_anon)) | Some slices -> slices in let le_slice = LE_Slice (le_base_annot, list_concat_map slices_of_bitfield le_fields) |> here in annotate_lexpr env le_slice t_e |: TypingRule.LESetFields | T_Record base_fields -> let fold_bitvector_fields field (start, slices) = match List.assoc_opt field base_fields with | None -> fatal_from ~loc (Error.BadField (field, t_base_anon)) | Some t_field -> let field_width = get_bitvector_const_width ~loc env t_field in (start + field_width, (start, field_width) :: slices) in let length, slices = List.fold_right fold_bitvector_fields le_fields (0, []) in let t_lhs = T_Bits (expr_of_int length, []) |> here in let+ () = check_type_satisfies ~loc env t_e t_lhs in (LE_SetFields (le_base_annot, le_fields, slices) |> here, ses_base) | _ -> conflict ~loc [ default_t_bits ] t_base |: TypingRule.LESetFields ) (* End *) (* Begin LESetArray *) | LE_SetArray (e_base, e_index) -> ( let t_base, _, _ = expr_of_lexpr e_base |> annotate_expr env in let t_anon_base = Types.make_anonymous env t_base in match t_anon_base.desc with | T_Array (size, t_elem) -> let e_base', ses_base = annotate_lexpr env e_base t_base in annotate_set_array ~loc env (size, t_elem) t_e (e_base', ses_base, e_index) | _ -> conflict ~loc [ default_array_ty ] t_base) (* End *) | LE_SetFields (_, _, _ :: _) | LE_SetEnumArray _ -> assert false (* Begin CheckCanBeInitializedWith *) let can_be_initialized_with env s t = (* Rules: - ZCVD: It is illegal for a storage element whose type has the structure of the parameterized integer to be initialized with a value whose type has the structure of the parameterized integer, unless the type is omitted from the declaration (and therefore the type can be unambiguously inferred) or the initialization expression is omitted (and therefore the type is not omitted from the declaration). - LXQZ: A storage element of type S, where S is any type that does not have the structure of the parameterized integer type, may only be assigned or initialized with a value of type T if T type-satisfies S) *) let s_struct = Types.get_structure env s in match s_struct.desc with | T_Int (Parameterized _) -> assert false | _ -> Types.type_satisfies env t s let check_can_be_initialized_with ~loc env s t () = if can_be_initialized_with env s t then () else conflict ~loc [ s.desc ] t (* End *) (* Begin ShouldRememberImmutableExpression *) let should_remember_immutable_expression ses = let ses_non_assert = SES.remove_assertions ses in SES.is_symbolically_evaluable ses_non_assert |: TypingRule.ShouldRememberImmutableExpression (* End *) (* Begin AddImmutableExpression *) let add_immutable_expression env ldk typed_e_opt x = match (ldk, typed_e_opt) with | (LDK_Constant | LDK_Let), Some (_, e, ses_e) when should_remember_immutable_expression ses_e -> ( match StaticModel.normalize_opt env e with | Some e' -> add_local_immutable_expr x e' env |: TypingRule.AddImmutableExpression | None -> env) | _ -> env (* End *) let rec inherit_integer_constraints ~loc lhs_ty rhs_ty = match (lhs_ty.desc, rhs_ty.desc) with | T_Int PendingConstrained, T_Int (WellConstrained _) -> rhs_ty | T_Int PendingConstrained, _ -> fatal_from ~loc (Error.ConstrainedIntegerExpected rhs_ty) | T_Tuple lhs_tys, T_Tuple rhs_tys -> if List.compare_lengths lhs_tys rhs_tys != 0 then fatal_from ~loc (Error.BadArity ( Static, "tuple initialization", List.length rhs_tys, List.length lhs_tys )) else let lhs_tys' = List.map2 (inherit_integer_constraints ~loc:(to_pos lhs_ty)) lhs_tys rhs_tys in T_Tuple lhs_tys' |> add_pos_from ~loc:lhs_ty | _ -> lhs_ty let annotate_local_decl_item ~loc (env : env) ty ldk ?e ldi = let () = if false then Format.eprintf "Annotating %a.@." PP.pp_local_decl_item ldi in match ldi with (* Begin LDVar *) | LDI_Var x -> (* Rule LCFD: A ~local declaration shall not declare an identifier which is already in scope at the point of declaration. *) let+ () = check_var_not_in_env ~loc env x in let env2 = add_local x ty ldk env in let new_env = add_immutable_expression env2 ldk e x in new_env |: TypingRule.LDVar (* End *) (* Begin LDTuple *) | LDI_Tuple names -> let tys = match (Types.make_anonymous env ty).desc with | T_Tuple tys when List.compare_lengths tys names = 0 -> tys | T_Tuple tys -> fatal_from ~loc (Error.BadArity ( Static, "tuple initialization", List.length tys, List.length names )) | _ -> conflict ~loc [ T_Tuple [] ] ty in let new_env = List.fold_right2 (fun ty' name env' -> let+ () = check_var_not_in_env ~loc env' name in add_local name ty' ldk env') tys names env in new_env |: TypingRule.LDTuple (* End *) (* Begin DeclareLocalConstant *) let declare_local_constant env v = function | LDI_Var x -> add_local_constant x v env | LDI_Tuple _ -> (* Not yet implemented *) env (* End *) let rec annotate_stmt env s : stmt * env * SES.t = let () = if false then match s.desc with | S_Seq _ -> () | _ -> Format.eprintf "@[<3>Annotating@ @[%a@]@]@." PP.pp_stmt s in let here x = add_pos_from ~loc:s x and loc = to_pos s in match s.desc with (* Begin SPass *) | S_Pass -> (s, env, SES.empty) |: TypingRule.SPass (* Begin SSeq *) | S_Seq (s1, s2) -> let new_s1, env1, ses1 = try_annotate_stmt env s1 in let new_s2, env2, ses2 = try_annotate_stmt env1 s2 in let ses = SES.union ses1 ses2 in (S_Seq (new_s1, new_s2) |> here, env2, ses) |: TypingRule.SSeq (* Begin SAssign *) | S_Assign (le, re) -> (let () = if false then Format.eprintf "@[<3>Annotating assignment@ @[%a@]@]@." PP.pp_stmt s in let ((t_re, re1, ses_re) as typed_re) = annotate_expr env re in match s.version with | V1 -> let le1, ses_le = annotate_lexpr env le t_re in let ses = SES.union ses_re ses_le in (S_Assign (le1, re1) |> here, env, ses) | V0 -> ( let reduced = setter_should_reduce_to_call_s env le typed_re in match reduced with | Some (new_s, ses_s) -> (new_s, env, ses_s) | None -> let env1 = (* * In version V0, variable declaration is optional, * As a result typing will be partial and some * function calls may lack extra parameters. * Fix this by typing first assignments of * undeclared variables as declarations. *) match ASTUtils.ldi_of_lexpr le with | None -> env | Some ldi -> let undefined = function | LDI_Var x -> is_undefined x env | LDI_Tuple names -> List.for_all (fun x -> is_undefined x env) names in if undefined ldi then let () = if false then Format.eprintf "@[<3>Assignment@ @[%a@] as declaration@]@." PP.pp_stmt s in let ldk = LDK_Var in let env2 = annotate_local_decl_item ~loc env t_re ldk ldi in env2 else env in let le1, ses_le = annotate_lexpr env1 le t_re in let ses = SES.union ses_re ses_le in (S_Assign (le1, re1) |> here, env1, ses))) |: TypingRule.SAssign (* End *) (* Begin SCall *) | S_Call call -> let call, ty, ses = annotate_call ~loc env call in let () = assert (ty = None) in (S_Call call |> here, env, ses) |: TypingRule.SCall (* End *) (* Begin SReturn *) | S_Return e_opt -> (* Rule NYWH: A return statement appearing in a setter or procedure must have no return value expression. *) (* Rule PHNZ: A return statement appearing in a getter or function requires a return value expression that type-satisfies the return type of the subprogram. *) (match (env.local.return_type, e_opt) with | None, Some _ | Some _, None -> fatal_from ~loc (Error.BadReturnStmt env.local.return_type) |: TypingRule.SReturn | None, None -> (S_Return None |> here, env, SES.empty) |: TypingRule.SReturn | Some t, Some e -> let t_e', e', ses = annotate_expr env e in let () = if false then Format.eprintf "Can I return %a(of type %a) when return_type = %a?@." PP.pp_expr e PP.pp_ty t_e' PP.pp_ty t in let+ () = check_type_satisfies ~loc env t_e' t in (S_Return (Some e') |> here, env, ses)) |: TypingRule.SReturn (* End *) (* Begin SCond *) | S_Cond (e, s1, s2) -> let t_cond, e_cond, ses_cond = annotate_expr env e in let+ () = check_type_satisfies ~loc:e_cond env t_cond boolean in let s1', ses1 = try_annotate_block env s1 in let s2', ses2 = try_annotate_block env s2 in let ses = SES.union3 ses_cond ses1 ses2 in (S_Cond (e_cond, s1', s2') |> here, env, ses) |: TypingRule.SCond (* End *) (* Begin SAssert *) | S_Assert e -> let t_e', e', ses_e = annotate_expr env e in let+ () = check_is_pure e ses_e in let+ () = check_type_satisfies ~loc env t_e' boolean in let ses = SES.add_assertion ses_e in (S_Assert e' |> here, env, ses) |: TypingRule.SAssert (* End *) (* Begin SWhile *) | S_While (e1, limit1, s1) -> let t, e2, ses_e = annotate_expr env e1 in let limit2, ses_limit = annotate_limit_expr ~loc env limit1 in let+ () = check_type_satisfies ~loc:e2 env t boolean in let s2, ses_block = try_annotate_block env s1 in let ses = SES.union3 ses_e ses_block ses_limit in (S_While (e2, limit2, s2) |> here, env, ses) |: TypingRule.SWhile (* End *) (* Begin SRepeat *) | S_Repeat (s1, e1, limit1) -> let s2, ses_block = try_annotate_block env s1 in let limit2, ses_limit = annotate_limit_expr ~loc env limit1 in let t, e2, ses_e = annotate_expr env e1 in let+ () = check_type_satisfies ~loc:e2 env t boolean in let ses = SES.union3 ses_block ses_e ses_limit in (S_Repeat (s2, e2, limit2) |> here, env, ses) |: TypingRule.SRepeat (* End *) (* Begin SFor *) | S_For { index_name; start_e; end_e; dir; body; limit } -> let start_t, start_e', ses_start = annotate_expr env start_e and end_t, end_e', ses_end = annotate_expr env end_e and limit', ses_limit = annotate_limit_expr ~warn:false ~loc env limit in let+ () = check_is_pure start_e ses_start in let+ () = check_is_deterministic start_e ses_start in let+ () = check_is_pure end_e ses_end in let+ () = check_is_deterministic end_e ses_end in let ses_cond = SES.union3 ses_start ses_end ses_limit in let start_struct = Types.make_anonymous env start_t and end_struct = Types.make_anonymous env end_t in (* TypingRule.ForConstraint( *) let cs = match (start_struct.desc, end_struct.desc) with | T_Int UnConstrained, T_Int _ | T_Int _, T_Int UnConstrained -> UnConstrained | T_Int _, T_Int _ -> let start_n = StaticModel.try_normalize env start_e' and end_n = StaticModel.try_normalize env end_e' in let e_bot, e_top = match dir with | Up -> (start_n, end_n) | Down -> (end_n, start_n) in WellConstrained [ Constraint_Range (e_bot, e_top) ] | T_Int _, _ -> conflict ~loc [ integer' ] end_t | _, _ -> conflict ~loc [ integer' ] start_t (* only happens in relaxed type-checking mode because of check_structure_integer earlier. *) (* TypingRule.ForConstraint) *) in let ty = T_Int cs |> here in let body', ses_block = let+ () = check_var_not_in_env ~loc env index_name in let env' = add_local index_name ty LDK_Let env in try_annotate_block env' body in let ses = ses_non_conflicting_union ~loc ses_cond ses_block in ( S_For { index_name; dir; start_e = start_e'; end_e = end_e'; body = body'; limit = limit'; } |> here, env, ses ) |: TypingRule.SFor (* End *) (* Begin SDecl *) | S_Decl (ldk, ldi, ty_opt, e_opt) -> ( match (ldk, e_opt) with (* SDecl.Some( *) | _, Some e -> let ((t_e, e', ses_e) as typed_e) = annotate_expr env e in let () = if false then Format.eprintf "Found rhs side-effects: %a@." SES.pp_print ses_e in let env1, ty_opt', ses_ldi = match ty_opt with | None -> let env1 = annotate_local_decl_item ~loc env t_e ldk ~e:typed_e ldi in (* When [print_typed] is specified, wrap untyped items with their inferred type. *) let ty_opt = if C.print_typed then Some t_e else None in (env1, ty_opt, SES.empty) | Some t -> let t_e' = Types.get_structure env t_e in let t = inherit_integer_constraints ~loc t t_e' in let t', ses_t = annotate_type ~loc env t in let+ () = check_can_be_initialized_with ~loc env t' t_e in let env1 = annotate_local_decl_item ~loc env t' ldk ~e:typed_e ldi in (env1, Some t', ses_t) in let ses = SES.union ses_e ses_ldi in let new_env = match ldk with | LDK_Let | LDK_Var -> env1 | LDK_Constant -> ( let+ () = check_leq_constant_time ~loc:s typed_e in try let v = StaticInterpreter.static_eval env1 e in declare_local_constant env1 v ldi with Error.(ASLException _) -> env1) in (S_Decl (ldk, ldi, ty_opt', Some e') |> here, new_env, ses) |: TypingRule.SDecl (* SDecl.Some) *) (* SDecl.None( *) | LDK_Var, None -> (match ty_opt with | None -> fatal_from ~loc (Error.BadLDI ldi) |: TypingRule.LDUninitialisedVar | Some t -> let t', ses_t' = annotate_type ~loc env t in let e_init = base_value ~loc env t' in let new_env = annotate_local_decl_item ~loc env t' LDK_Var ldi in ( S_Decl (LDK_Var, ldi, Some t', Some e_init) |> here, new_env, ses_t' ) |: TypingRule.LDUninitialisedTyped) |: TypingRule.SDecl | (LDK_Constant | LDK_Let), None -> fatal_from ~loc UnrespectedParserInvariant) (* SDecl.None) *) (* End *) (* Begin SThrow *) | S_Throw (Some (e, _)) -> let t_e, e', ses1 = annotate_expr env e in let+ () = check_structure_exception ~loc env t_e in let exn_name = match t_e.desc with T_Named s -> s | _ -> assert false in let ses2 = SES.add_thrown_exception exn_name ses1 in (S_Throw (Some (e', Some t_e)) |> here, env, ses2) |: TypingRule.SThrow | S_Throw None -> (* TODO: verify that this is allowed? *) (s, env, SES.throws_exception "TODO") |: TypingRule.SThrow (* End *) (* Begin STry *) | S_Try (s', catchers, otherwise) -> let s'', ses1 = try_annotate_block env s' in let ses2, catchers_and_ses = list_fold_left_map (annotate_catcher ~loc env) ses1 catchers in let () = if false then Format.eprintf "After catchers, I have side effects:@ %a@." SES.pp_print ses2 in let catchers', catchers_sess = List.split catchers_and_ses in let ses_catchers = SES.unions catchers_sess in let otherwise', ses3, ses_otherwise = match otherwise with | None -> (None, ses2, SES.empty) | Some block -> let block', ses_block = try_annotate_block env block in (Some block', SES.remove_thrown_exceptions ses2, ses_block) in let ses = SES.union3 ses3 ses_catchers ses_otherwise in (S_Try (s'', catchers', otherwise') |> here, env, ses) |: TypingRule.STry (* End *) (* Begin SPrint *) | S_Print { args; newline; debug } -> let args', sess = List.map (fun e -> let ty, annot_e, ses_e = annotate_expr env e in let+ () = check_true (Types.is_singular env ty) @@ fun () -> Error.fatal_from e (Error.BadPrintType ty) in (annot_e, ses_e)) args |> List.split in let ses = SES.non_conflicting_unions sess ~fail:(conflicting_side_effects_error ~loc) in (S_Print { args = args'; newline; debug } |> here, env, ses) |: TypingRule.SPrint (* End *) (* Begin SPragma *) | S_Pragma (id, args) -> let () = warn_from ~loc (Error.PragmaUse id) in let _, _, sess = List.map (annotate_expr env) args |> list_split3 in let ses = SES.non_conflicting_unions sess ~fail:(conflicting_side_effects_error ~loc) in (S_Pass |> here, env, ses) |: TypingRule.SPragma (* End *) | S_Unreachable -> (s, env, SES.empty) (* Begin AnnotateLimitExpr *) and annotate_limit_expr ?(warn = true) ~loc env = function | None -> let () = if warn then warn_from ~loc Error.NoLoopLimit in (None, SES.empty) | Some limit -> let new_limit, ses = annotate_symbolic_constrained_integer ~loc env limit in (Some new_limit, ses) |: TypingRule.AnnotateLimitExpr (* End *) (* Begin Catcher *) and annotate_catcher ~loc env ses_in (name_opt, ty, stmt) = let ty', ses_ty = annotate_type ~loc env ty in let+ () = check_structure_exception ~loc:ty' env ty' in let new_stmt, ses_block = let env' = match name_opt with | None -> env | Some name -> let+ () = check_var_not_in_env ~loc:stmt env name in add_local name ty LDK_Let env in try_annotate_block env' stmt and ses_filtered = let ty_name = match ty'.desc with T_Named s -> s | _ -> assert false in SES.filter_thrown_exceptions (fun s -> not (Types.subtypes_names env s ty_name)) ses_in in let ses = SES.union ses_block ses_ty in (ses_filtered, ((name_opt, ty, new_stmt), ses)) |: TypingRule.Catcher (* End *) (* Begin Block *) and try_annotate_block env s = (* See rule JFRD: A ~local identifier declared with var, let or constant is in scope from the point immediately after its declaration until the end of the immediately enclosing block. From that follows that we can discard the environment at the end of an enclosing block. *) ( best_effort (s, SES.empty) @@ fun _ -> let s, _env, ses = annotate_stmt env s in (s, ses) ) |: TypingRule.Block (* End *) and try_annotate_stmt env s = best_effort (s, env, SES.empty) (fun _ -> annotate_stmt env s) (* ASLRef extension that allows reduction of a form [MyGetter.[fieldA, fieldB] to [MyGetter([sliceA], [sliceB])]]. It is guarded by [C.use_getter_field_extension]. *) and set_fields_should_reduce_to_call ~loc env x fields (t_e, e, ses_e) = (* * Field indices are extracted from the return type * of "associated" getter. *) assert (loc.version = V0 && C.use_field_getter_extension); let ( let* ) = Option.bind in let _, _, callee, _ = try Fn.try_subprogram_for_name ~loc env V0 x [] with Error.ASLException _ -> assert false in let* ty = callee.return_type in let ty = Types.make_anonymous env ty in let* name, args = should_fields_reduce_to_call env x ty fields in let typed_args = (t_e, e, ses_e) :: List.map (annotate_expr env) args in let call, ret_ty, ses_call = annotate_call_v0 ~loc env name typed_args ST_Setter in let _, _, sess_args = list_split3 typed_args in let ses = SES.union ses_call @@ ses_non_conflicting_unions ~loc sess_args in let () = assert (ret_ty = None) in Some (S_Call call |> add_pos_from ~loc, ses) and setter_should_reduce_to_call_recurse ~loc env typed_e make_old_le sub_le = let () = assert (loc.version = V0) in let x = fresh_var "__setter_setfield" in let here le = add_pos_from ~loc le in let t_sub_re, sub_re, ses_sub_re = expr_of_lexpr sub_le |> annotate_expr env in let ldi_x = LDI_Var x in let env1 = annotate_local_decl_item ~loc env t_sub_re LDK_Var ldi_x in let s1, ses_s1 = (S_Decl (LDK_Var, ldi_x, None, Some sub_re) |> here, ses_sub_re) in let s2, ses_s2 = let t_e, e, ses_e = typed_e in let old_le = make_old_le (LE_Var x |> here) in let old_le', ses_old_le = annotate_lexpr env1 old_le t_e in (S_Assign (old_le', e) |> here, SES.union ses_old_le ses_e) in let typed_e_x = annotate_expr env1 (E_Var x |> here) in match setter_should_reduce_to_call_s env1 sub_le typed_e_x with | None -> None | Some (s, ses_s) -> Some (s_then (s_then s1 s2) s, SES.union3 ses_s1 ses_s2 ses_s) and setter_should_reduce_to_call_s env le typed_e : (stmt * SES.t) option = let () = assert (le.version = V0) in let t_e, e, ses_e = typed_e in let () = if false then Format.eprintf "@[<2>setter_..._s@ @[%a@]@ @[%a@]@]@." PP.pp_lexpr le PP.pp_expr e in let loc = to_pos le in let here d = add_pos_from ~loc d in (if false then (fun o -> let none f () = Format.fprintf f "no reduction." in let pp_fst pp f (x, _y) = pp f x in Format.eprintf "@[<2>Setter@ @[%a@ = %a@]@ gave @[%a@]@.@]" PP.pp_lexpr le PP.pp_expr e (Format.pp_print_option ~none (pp_fst PP.pp_stmt)) o; o) else Fun.id) @@ match le.desc with | LE_Discard -> None | LE_SetField (sub_le, field) -> ( match sub_le.desc with | LE_Var x when C.use_field_getter_extension && should_reduce_to_call env x ST_Setter -> set_fields_should_reduce_to_call env ~loc x [ field ] typed_e | _ -> let old_le le' = LE_SetField (le', field) |> here in setter_should_reduce_to_call_recurse ~loc env typed_e old_le sub_le) | LE_SetFields (sub_le, fields, slices) -> ( match sub_le.desc with | LE_Var x when C.use_field_getter_extension && should_reduce_to_call env x ST_Setter -> set_fields_should_reduce_to_call env ~loc x fields typed_e | _ -> let old_le le' = LE_SetFields (le', fields, slices) |> here in setter_should_reduce_to_call_recurse ~loc env typed_e old_le sub_le) | LE_Slice (sub_le, slices) -> ( match sub_le.desc with | LE_Var x when should_reduce_to_call env x ST_Setter && List.for_all slice_is_single slices -> let args = try List.map slice_as_single slices with Invalid_argument _ -> assert false in let typed_args = typed_e :: List.map (annotate_expr env) args in let call, ret_ty, ses_call = annotate_call_v0 ~loc env x typed_args ST_Setter in let _, _, sess_args = list_split3 typed_args in let ses = SES.union ses_call @@ ses_non_conflicting_unions ~loc sess_args in let () = assert (ret_ty = None) in Some (S_Call call |> here, ses) | _ -> let old_le le' = LE_Slice (le', slices) |> here in setter_should_reduce_to_call_recurse ~loc env typed_e old_le sub_le) | LE_Destructuring les -> ( match (Types.make_anonymous env t_e).desc with | T_Tuple t_es when List.compare_lengths les t_es = 0 -> let x = fresh_var "__setter_destructuring" in let ldi_x = LDI_Var x in let env1 = annotate_local_decl_item ~loc env t_e LDK_Let ~e:typed_e ldi_x in let sub_e i = E_GetItem (E_Var x |> here, i) |> here in let recurse_one i sub_le t_sub_e = setter_should_reduce_to_call_s env1 sub_le (t_sub_e, sub_e i, SES.empty) in let subs = list_mapi2 recurse_one 0 les t_es in if List.for_all Option.is_none subs then None else let s0 = S_Decl (LDK_Let, ldi_x, None, Some e) |> here in let produce_one i sub_le t_sub_e_i = function | None -> let sub_le', sub_le_ses = annotate_lexpr env sub_le t_sub_e_i in (S_Assign (sub_le', sub_e i) |> here, sub_le_ses) | Some (s, ses) -> (s, ses) in let stmts, sess = list_mapi3 produce_one 0 les t_es subs |> List.split in let s = stmt_from_list (s0 :: stmts) and ses = SES.unions (ses_e :: sess) in Some (s, ses) | _ -> None) | LE_Var x -> let st = ST_EmptySetter in if should_reduce_to_call env x st then let args = [ typed_e ] in let call, ret_ty, ses_call = annotate_call_v0 ~loc env x args st in let () = assert (ret_ty = None) in let ses = SES.union ses_call ses_e in Some (S_Call call |> here, ses) else None | LE_SetArray _ | LE_SetEnumArray _ -> assert false (** [func_sig_types f] returns a list of the types in the signature [f]. The return type is first, followed by the argument types in order. *) let func_sig_types func_sig = let arg_types = List.map snd func_sig.args in let return_type = match func_sig.return_type with None -> [] | Some ty -> [ ty ] in return_type @ arg_types (** The parameters in a function signature, in order. *) let extract_parameters ~env func_sig = let rec parameters_of_expr ~env e = match e.desc with | E_Var x -> if is_undefined x env then [ x ] else [] | E_Binop (_, e1, e2) -> parameters_of_expr ~env e1 @ parameters_of_expr ~env e2 | E_Unop (_, e) -> parameters_of_expr ~env e | E_Literal _ -> [] | _ -> Error.fatal_from (to_pos e) (Error.UnsupportedExpr (Static, e)) in let parameters_of_constraint ~env c = match c with | Constraint_Exact e -> parameters_of_expr ~env e | Constraint_Range (e1, e2) -> parameters_of_expr ~env e1 @ parameters_of_expr ~env e2 in let rec parameters_of_ty ~env ty = match ty.desc with | T_Bits (e, _) -> parameters_of_expr ~env e | T_Tuple tys -> list_concat_map (parameters_of_ty ~env) tys | T_Int (WellConstrained cs) -> list_concat_map (parameters_of_constraint ~env) cs | T_Int UnConstrained | T_Real | T_String | T_Bool | T_Array _ | T_Named _ -> [] | _ -> Error.fatal_from (to_pos ty) (Error.UnsupportedTy (Static, ty)) in let types = func_sig_types func_sig in let all_parameters = list_concat_map (parameters_of_ty ~env) types in uniq all_parameters (** The set of variables which could define a parameter in a function signature. *) let extract_parameter_defining ~env f = let rec defining_of_ty ~env acc ty = match ty.desc with | T_Bits ({ desc = E_Var x; _ }, _) -> if is_undefined x env then ISet.add x acc else acc | T_Tuple tys -> List.fold_left (defining_of_ty ~env) acc tys | _ -> acc in let types = func_sig_types f in List.fold_left (defining_of_ty ~env) (ISet.of_list (List.map fst f.args)) types let annotate_func_sig_v1 ~loc genv func_sig = let env = with_empty_local genv in (* Check recursion limit *) let recurse_limit, ses_recurse_limit = annotate_limit_expr ~warn:false ~loc env func_sig.recurse_limit in (* Annotate and declare parameters *) let (env_with_params, ses_with_params), parameters = let declare_parameter (new_env, new_ses) (x, ty_opt) = let ty, ses_ty = match ty_opt with | None | Some { desc = T_Int UnConstrained; _ } -> (Types.parameterized_ty x, SES.empty) | Some ty -> (* valid in environment which has no parameters declared *) annotate_type ~loc env ty in let+ () = check_constrained_integer ~loc env ty in let+ () = check_var_not_in_env ~loc new_env x in let new_env' = add_local x ty LDK_Let new_env and ses = SES.union new_ses ses_ty in ((new_env', ses), (x, Some ty)) in list_fold_left_map declare_parameter (env, ses_recurse_limit) func_sig.parameters in (* Check parameters are declared correctly - in order and unique *) let+ () = let inferred_parameters = extract_parameters ~env func_sig in let declared_parameters = List.map fst func_sig.parameters in let all_parameters_declared = list_equal String.equal inferred_parameters declared_parameters in check_true all_parameters_declared @@ fun () -> fatal_from ~loc (BadParameterDecl (func_sig.name, inferred_parameters, declared_parameters)) in (* Annotate and declare arguments *) let (env_with_args, ses_with_args), args = let declare_argument (new_env, new_ses) (x, ty) = (* valid in environment with only parameters declared *) let ty, ses_ty = annotate_type ~loc env_with_params ty in let+ () = check_var_not_in_env ~loc new_env x in let new_env = add_local x ty LDK_Let new_env and ses = SES.union new_ses ses_ty in ((new_env, ses), (x, ty)) in list_fold_left_map declare_argument (env_with_params, ses_with_params) func_sig.args in (* Annotate return type *) let env_with_return, return_type, ses_with_return = match func_sig.return_type with | None -> (env_with_args, None, ses_with_args) | Some ty -> (* valid in environment with parameters declared *) let new_ty, ses_ty = annotate_type ~loc env_with_params ty in let return_type = Some new_ty in let local_env = { env_with_args.local with return_type } in let new_ses = SES.union ses_ty ses_with_args in ({ env_with_args with local = local_env }, return_type, new_ses) in let ses = SES.remove_locals ses_with_return in ( env_with_return, { func_sig with parameters; args; return_type; recurse_limit }, ses ) let annotate_func_sig_v0 ~loc genv func_sig = let env = with_empty_local genv in (* Check recursion limit *) let recurse_limit, ses_with_limit = annotate_limit_expr ~warn:false ~loc env func_sig.recurse_limit in (* Check parameters have defining arguments *) let inferred_parameters = extract_parameters ~env func_sig in let+ () = let defining = extract_parameter_defining ~env func_sig in let undefined_parameters = List.filter (fun x -> not (ISet.mem x defining)) inferred_parameters in check_true (list_is_empty undefined_parameters) @@ fun () -> fatal_from ~loc (ParameterWithoutDecl (List.hd undefined_parameters)) in (* Annotate and declare parameters from arguments *) let (env_with_params, ses_with_params), typed_parameters = let declare_parameter (new_env, new_ses) x = let ty, ses_ty = match List.assoc_opt x func_sig.args with | None | Some { desc = T_Int UnConstrained } -> (Types.parameterized_ty x, SES.empty) | Some ty -> (* valid in environment which has no parameters declared *) annotate_type ~loc env ty in let+ () = check_constrained_integer ~loc env ty in let+ () = check_var_not_in_env ~loc new_env x in let new_ses = SES.union new_ses ses_ty and new_env = add_local x ty LDK_Let new_env in ((new_env, new_ses), (x, ty)) in list_fold_left_map declare_parameter (env, ses_with_limit) inferred_parameters in let parameters = List.map (fun (x, ty) -> (x, Some ty)) typed_parameters in (* Annotate and declare remaining arguments *) let (env_with_args, ses_with_args), args = let declare_argument (new_env, new_ses) (x, ty) = match List.assoc_opt x typed_parameters with | Some ({ desc = T_Int (Parameterized _) } as loc) -> ((new_env, new_ses), (x, T_Int UnConstrained |> add_pos_from ~loc)) | Some ty -> ((new_env, new_ses), (x, ty)) | None -> let ty, ses_ty = annotate_type ~loc env_with_params ty in let+ () = check_var_not_in_env ~loc new_env x in let new_ses = SES.union new_ses ses_ty and new_env = add_local x ty LDK_Let new_env in ((new_env, new_ses), (x, ty)) in list_fold_left_map declare_argument (env_with_params, ses_with_params) func_sig.args in (* Annotate return type *) let env_with_return, return_type, ses_with_return = match func_sig.return_type with | None -> (env_with_args, None, ses_with_args) | Some ty -> (* valid in environment with parameters declared *) let new_ty, ses_ty = annotate_type ~loc env_with_params ty in let return_type = Some new_ty in let local_env = { env_with_args.local with return_type } in let new_ses = SES.union ses_ty ses_with_args in ({ env_with_args with local = local_env }, return_type, new_ses) in ( env_with_return, { func_sig with parameters; args; return_type; recurse_limit }, ses_with_return ) let annotate_func_sig ~loc genv func_sig = match loc.version with | V0 -> annotate_func_sig_v0 ~loc genv func_sig | V1 -> annotate_func_sig_v1 ~loc genv func_sig module ControlFlow : sig val check_stmt_returns_or_throws : identifier -> stmt_desc annotated -> prop (** [check_stmt_interrupts name env body] checks that the function named [name] with the statement body [body] returns a value or throws an exception. *) end = struct (** Possible Control-Flow actions of a statement. *) type t = | Interrupt (** Throwing an exception or returning a value. *) | AssertedNotInterrupt (** Assert that this control-flow path is unused. *) | MayNotInterrupt (** Among all control-flow path in a statement, there is one that will not throw an exception nor return a value. *) (* Begin ControlFlowSeq *) (** Sequencial combination of two control flows. *) let seq t1 t2 = if t1 = MayNotInterrupt then t2 else t1 |: TypingRule.ControlFlowSeq (* End *) (* Begin ControlFlowJoin *) (** [join t1 t2] corresponds to the parallel combination of [t1] and [t2]. More precisely, it is the maximal element in the ordering AssertedNotInterrupt < Interrupt < MayNotInterrupt *) let join t1 t2 = match (t1, t2) with | MayNotInterrupt, _ | _, MayNotInterrupt -> MayNotInterrupt |: TypingRule.ControlFlowJoin | AssertedNotInterrupt, t | t, AssertedNotInterrupt -> t (* Assertion that the condition always holds *) | Interrupt, Interrupt -> Interrupt (* End *) (* Begin ControlFlowFromStmt *) (** [get_from_stmt env s] builds the control-flow analysis on [s] in [env]. *) let rec from_stmt s = match s.desc with | S_Pass | S_Decl _ | S_Assign _ | S_Assert _ | S_Call _ | S_Print _ | S_Pragma _ -> MayNotInterrupt |: TypingRule.ControlFlowFromStmt | S_Unreachable -> AssertedNotInterrupt | S_Return _ | S_Throw _ -> Interrupt | S_Seq (s1, s2) -> seq (from_stmt s1) (from_stmt s2) | S_Cond (_, s1, s2) -> join (from_stmt s1) (from_stmt s2) | S_Repeat (body, _, _) -> from_stmt body | S_While _ | S_For _ -> MayNotInterrupt | S_Try (body, catchers, otherwise) -> let res0 = from_stmt body in let res1 = match otherwise with | None -> res0 | Some s -> join (from_stmt s) res0 in List.fold_left (fun res (_, _, s) -> join res (from_stmt s)) res1 catchers (* End *) (** [check_stmt_interrupts name env body] checks that the function named [name] with the statement body [body] returns a value or throws an exception. *) let check_stmt_returns_or_throws name s () = match from_stmt s with | AssertedNotInterrupt | Interrupt -> () | MayNotInterrupt -> fatal_from ~loc:s (Error.NonReturningFunction name) end (* Begin Subprogram *) let annotate_subprogram (env : env) (f : AST.func) ses_func_sig : AST.func * SES.t = let () = if false then Format.eprintf "@[Annotating body in env:@ %a@]@." pp_env env in (* Annotate body *) let body = match f.body with SB_ASL body -> body | SB_Primitive _ -> assert false in let new_body, ses_body = try_annotate_block env body in let ses = SES.union ses_func_sig @@ SES.remove_locals ses_body in let () = if false then Format.eprintf "@[For program %s, I got side-effects:@ %a@]@." f.name SES.pp_print ses in let+ () = match f.return_type with | None -> ok | Some _ -> ControlFlow.check_stmt_returns_or_throws f.name new_body in ({ f with body = SB_ASL new_body }, ses) |: TypingRule.Subprogram (* End *) let try_annotate_subprogram env f ses_func_sig = best_effort (f, ses_func_sig) @@ fun _ -> annotate_subprogram env f ses_func_sig (******************************************************************************) (* *) (* Global env and funcs *) (* *) (******************************************************************************) (* Begin CheckSetterHasGetter *) let check_setter_has_getter ~loc env (func_sig : AST.func) = let fail () = fatal_from ~loc (Error.SetterWithoutCorrespondingGetter func_sig) in let check_true thing = check_true thing fail in match func_sig.subprogram_type with | ST_Getter | ST_EmptyGetter | ST_Function | ST_Procedure -> ok | ST_EmptySetter | ST_Setter -> let ret_type, arg_types = match func_sig.args with | [] -> fatal_from ~loc Error.UnrespectedParserInvariant | (_, ret_type) :: args -> (ret_type, List.map snd args) in let _, _, func_sig', _ = try Fn.subprogram_for_name ~loc env V1 func_sig.name arg_types with | Error.( ASLException { desc = NoCallCandidate _ | TooManyCallCandidates _; _ }) -> fail () in (* Check that func_sig' is a getter *) let wanted_getter_type = match func_sig.subprogram_type with | ST_Setter -> ST_Getter | ST_EmptySetter -> ST_EmptyGetter | _ -> assert false in let+ () = check_true (func_sig'.subprogram_type = wanted_getter_type) in let+ () = (* Check that args match *) let () = assert (List.compare_lengths func_sig'.args arg_types = 0) in check_true @@ List.for_all2 (fun (_, t1) t2 -> Types.type_equal env t1 t2) func_sig'.args arg_types in let+ () = (* Check that return types match. *) match func_sig'.return_type with | None -> assert false (* By type-checking invariant: func_sig' is a getter. *) | Some t -> check_true @@ Types.type_equal env ret_type t in ok |: TypingRule.CheckSetterHasGetter (* End *) (* Begin DeclareOneFunc *) let declare_one_func ~loc (func_sig : AST.func) ses_func_sig env = let env1, name' = best_effort (env, func_sig.name) @@ fun _ -> Fn.add_new_func ~loc env func_sig.name func_sig.args func_sig.subprogram_type in let () = if false then let open Format in eprintf "@[Adding function %s to env with@ return-type: %a@ and \ argtypes:@ %a@." name' (pp_print_option PP.pp_ty) func_sig.return_type (pp_print_list ~pp_sep:pp_print_space PP.pp_typed_identifier) func_sig.args in let+ () = check_var_not_in_genv ~loc env1.global name' in let+ () = check_setter_has_getter ~loc env1 func_sig in let new_func_sig = { func_sig with name = name' } in let init_ses = match func_sig.body with | SB_ASL _ | SB_Primitive true -> SES.add_calls_recursive name' ses_func_sig | SB_Primitive false -> ses_func_sig in (add_subprogram name' new_func_sig init_ses env1, new_func_sig) |: TypingRule.DeclareOneFunc (* End *) (* Begin AnnotateAndDeclareFunc *) let annotate_and_declare_func ~loc func_sig genv = let env1, func_sig1, ses_f1 = annotate_func_sig ~loc genv func_sig in (declare_one_func ~loc func_sig1 ses_f1 env1, ses_f1) |: TypingRule.AnnotateAndDeclareFunc (* End *) (* Begin AddGlobalStorage *) let add_global_storage ~loc name keyword genv ty = if is_global_ignored name then genv else let+ () = check_var_not_in_genv ~loc genv name in add_global_storage name ty keyword genv |: TypingRule.AddGlobalStorage (* End *) (* Begin DeclareConst *) let declare_const ~loc name t v genv = add_global_storage ~loc name GDK_Constant genv t |> add_global_constant name v |: TypingRule.DeclareConst (* End *) (* Begin DeclareType *) let declare_type ~loc name ty s genv = let () = if false then Format.eprintf "Declaring type %s of %a@." name PP.pp_ty ty in let here x = add_pos_from ~loc:ty x in let+ () = check_var_not_in_genv ~loc genv name in let env = with_empty_local genv in let env1, t1 = match s with (* AnnotateExtraFields( *) | None -> (env, ty) | Some (super, extra_fields) -> let+ () = fun () -> if Types.subtype_satisfies env ty (T_Named super |> here) then () else conflict ~loc [ T_Named super ] ty in let new_ty = if extra_fields = [] then ty else match IMap.find_opt super genv.declared_types with | Some ({ desc = T_Record fields; _ }, _) -> T_Record (fields @ extra_fields) |> here | Some ({ desc = T_Exception fields; _ }, _) -> T_Exception (fields @ extra_fields) |> here | Some _ -> conflict ~loc [ T_Record []; T_Exception [] ] ty | None -> undefined_identifier ~loc super and env = add_subtype name super env in (env, new_ty) (* AnnotateExtraFields) *) in let t2, ses_t = annotate_type ~decl:true ~loc env1 t1 in let time_frame = SES.max_time_frame ses_t in let env2 = add_type name t2 time_frame env1 in let new_tenv = match t2.desc with | T_Enum ids -> let t = T_Named name |> here in let declare_one env2 label = declare_const ~loc label t (L_Label label) env2 in let genv3 = List.fold_left declare_one env2.global ids in { env2 with global = genv3 } | _ -> env2 in let () = if false then Format.eprintf "Declared %s.@." name in new_tenv.global (* End *) (* Begin TryAddGlobalConstant *) let try_add_global_constant name env e = try let v = StaticInterpreter.static_eval env e in { env with global = add_global_constant name v env.global } with Error.(ASLException { desc = UnsupportedExpr _; _ }) -> env (* End *) (* Begin DeclareGlobalStorage *) let declare_global_storage ~loc gsd genv = let () = if false then Format.eprintf "Declaring %s@." gsd.name in best_effort (gsd, genv) @@ fun _ -> let here x = add_pos_from ~loc x in let { keyword; initial_value; ty = ty_opt; name } = gsd in let+ () = check_var_not_in_genv ~loc genv name in let env = with_empty_local genv in let target_time_frame = TimeFrame.of_gdk keyword in let typed_initial_value, ty_opt', declared_t = (* AnnotateTyOptInitialValue( *) match (ty_opt, initial_value) with | Some t, Some e -> let t', ses_t = annotate_type ~loc env t and ((t_e, _e', _vses_e) as typed_e) = annotate_expr env e in let+ () = check_type_satisfies ~loc env t_e t' in let+ () = let fake_e_for_error = E_ATC (e, t') |> here in check_is_time_frame ~loc target_time_frame (t', fake_e_for_error, ses_t) in (typed_e, Some t', t') | Some t, None -> let t', ses_t = annotate_type ~loc env t in let+ () = let fake_e_for_error = E_ATC (E_Var "-" |> here, t') |> here in check_is_time_frame ~loc target_time_frame (t', fake_e_for_error, ses_t) in let e' = base_value ~loc env t' in ((t', e', SES.empty), Some t', t') | None, Some e -> let ((t_e, _e', _ses_e) as typed_e) = annotate_expr env e in (typed_e, None, t_e) | None, None -> fatal_from ~loc UnrespectedParserInvariant (* AnnotateTyOptInitialValue) *) in let genv1 = add_global_storage ~loc name keyword genv declared_t in let env1 = with_empty_local genv1 in let _, initial_value', ses_initial_value = typed_initial_value in (* UpdateGlobalStorage( *) let env2 = match keyword with | GDK_Constant -> let+ () = check_leq_constant_time ~loc typed_initial_value in try_add_global_constant name env1 initial_value' | GDK_Let when should_remember_immutable_expression ses_initial_value -> ( match StaticModel.normalize_opt env1 initial_value' with | Some e' -> add_global_immutable_expr name e' env1 | None -> env1) | GDK_Config -> let+ () = check_leq_config_time ~loc typed_initial_value in env1 | _ -> env1 (* UpdateGlobalStorage) *) in let () = assert (env2.local == empty_local) in (* If C.print_typed is specified pass [declared_t] to make sure the storage element is type-annotated. *) let ty_opt' = if C.print_typed then Some declared_t else ty_opt' in ({ gsd with ty = ty_opt'; initial_value = Some initial_value' }, env2.global) |: TypingRule.DeclareGlobalStorage (* End *) (******************************************************************************) (* *) (* Entry point *) (* *) (******************************************************************************) let type_check_decl d (acc, genv) = let here = add_pos_from_st d and loc = to_pos d in let () = if false then Format.eprintf "@[Typing with %s in env:@ %a@]@." strictness_string pp_global genv else if false then Format.eprintf "@[Typing %a.@]@." PP.pp_t [ d ] in let new_d, new_genv = match d.desc with (* Begin TypecheckDecl *) | D_Func ({ body = SB_ASL _; _ } as f) -> let (env1, f1), ses_func_sig = annotate_and_declare_func ~loc f genv in let new_f, ses_f = try_annotate_subprogram env1 f1 ses_func_sig in let () = if ISet.mem f.name (SES.get_calls_recursives ses_f) && Option.is_none f.recurse_limit then warn_from ~loc Error.(NoRecursionLimit [ f.name ]) in let ses_f = SES.remove_calls_recursives ses_f in let new_d = D_Func new_f |> here and new_env = StaticEnv.add_subprogram new_f.name new_f ses_f env1 in (new_d, new_env.global) |: TypingRule.TypecheckDecl | D_Func ({ body = SB_Primitive _; _ } as f) -> let (new_env, new_f), _ = annotate_and_declare_func ~loc f genv in let new_d = D_Func new_f |> here in (new_d, new_env.global) | D_GlobalStorage gsd -> let gsd', new_genv = declare_global_storage ~loc gsd genv in let new_d = D_GlobalStorage gsd' |> here in (new_d, new_genv) |: TypingRule.TypecheckDecl | D_TypeDecl (x, ty, s) -> let new_genv = declare_type ~loc x ty s genv in (d, new_genv) |: TypingRule.TypecheckDecl (* End *) | D_Pragma _ -> assert false in (new_d :: acc, new_genv) (* Being CheckGlobalPragma *) let check_global_pragma genv d = let loc = to_pos d in match d.desc with | D_Pragma (id, args) -> let () = warn_from ~loc (Error.PragmaUse id) in List.iter (fun e -> annotate_expr (with_empty_local genv) e |> ignore) args |: TypingRule.CheckGlobalPragma | _ -> assert false (* End *) (* Begin PropagateRecursiveCallsSess *) let propagate_recursive_calls_sess (sess : (func * SES.t) list) : (func * SES.t) list = let () = if false then let open Format in let pp_sep f () = fprintf f ";@ " in let pp f ((func_sig : func), ses) = fprintf f "@[%s:@ %a@]" func_sig.name SES.pp_print ses in eprintf "@[Propagating side-effects from:@ @[[%a]@]@]@." (pp_print_list ~pp_sep pp) sess in let map0 = List.map (fun ((f : func), ses) -> (f.name, ses)) sess |> IMap.of_list in let call_graph = IMap.map (fun ses -> SES.get_calls_recursives ses) map0 in let transitive_call_graph = transitive_closure call_graph in let map0_without_recursive_calls = IMap.map (fun ses -> SES.remove_calls_recursives ses) map0 in let res = List.map (fun ((func : func), ses) -> let callees = IMap.find func.name transitive_call_graph |> ISet.elements in let sess = List.map (fun x -> IMap.find x map0_without_recursive_calls) callees in (func, SES.unions (SES.remove_calls_recursives ses :: sess))) sess in let () = if false then let open Format in let pp_sep f () = fprintf f ";@ " in let pp f ((func_sig : func), ses) = fprintf f "@[%s:@ %a@]" func_sig.name SES.pp_print ses in eprintf "@[Propagating side-effects from:@ @[[%a]@]@]@." (pp_print_list ~pp_sep pp) res in res (* End *) (** [check_recursive_limit_annotations locs sess] emits a warning if there a cycle in the call-graph described by [sess] without static annotations. The argument [locs] is only used for identifying an location in which to print the error. *) let check_recursive_limit_annotations locs sess = let call_graph_without_annotated_functions = List.filter_map (function | { recurse_limit = None; body = SB_ASL _; name }, ses -> Some (name, SES.get_calls_recursives ses) | _ -> None) sess |> IMap.of_list in match get_cycle call_graph_without_annotated_functions with | None -> () | Some [] -> assert false | Some (x :: _ as cycle) -> let loc = List.find (fun d -> String.equal x (identifier_of_decl d)) locs in warn_from ~loc Error.(NoRecursionLimit cycle) (* Begin TypeCheckMutuallyRec *) let type_check_mutually_rec ds (acc, genv0) = let () = if false then let open Format in eprintf "@[Type-checking@ mutually@ recursive@ declarations:@ %a@]@." (pp_print_list ~pp_sep:pp_print_space pp_print_string) (List.map identifier_of_decl ds) in let env_and_fs = List.map (fun d -> let loc = to_pos d in match d.desc with | D_Func f -> let env', f, ses_f = annotate_func_sig ~loc genv0 f in (env'.local, f, ses_f, loc) | _ -> fatal_from ~loc (Error.BadRecursiveDecls (List.map ASTUtils.identifier_of_decl ds))) ds in let env_and_fs1 = (* Setters last as they need getters declared. *) let setters, others = List.partition (fun (_, f, _, _) -> match f.subprogram_type with | ST_Setter | ST_EmptySetter -> true | _ -> false) env_and_fs in List.rev_append others setters in (* DeclareSubprograms( *) let genv2, env_and_fs2 = list_fold_left_map (fun genv (lenv, f, ses_f, loc) -> let env = { global = genv; local = lenv } in let env1, f1 = declare_one_func ~loc f ses_f env in (env1.global, (env1.local, f1, ses_f, loc))) genv0 env_and_fs1 |: TypingRule.DeclareSubprograms (* DeclareSubprograms) *) in let ds, sess = list_map_split (fun (lenv2, f, ses_f, loc) -> let env2 = { local = lenv2; global = genv2 } in let here d = add_pos_from ~loc d in match f.body with | SB_ASL _ -> let () = if false then Format.eprintf "@[Analysing decl %s.@]@." f.name in let new_f, ses_f = try_annotate_subprogram env2 f ses_f in (D_Func new_f |> here, (new_f, ses_f)) | SB_Primitive side_effecting -> let ses = if side_effecting then SES.calls_recursive f.name else SES.empty in (D_Func f |> here, (f, ses))) env_and_fs2 in let () = check_recursive_limit_annotations ds sess in let env3 = let sess_prop = propagate_recursive_calls_sess sess in (* AddSubprogramDecls( *) List.fold_left (fun env2 ((new_f : func), ses_f) -> StaticEnv.add_subprogram new_f.name new_f ses_f env2) (StaticEnv.with_empty_local genv2) sess_prop (* AddSubprogramDecls) *) in (List.rev_append ds acc, env3.global) |: TypingRule.TypeCheckMutuallyRec (* End *) (* Begin TypeCheckAST *) let type_check_ast_in_env = let fold = function | TopoSort.ASTFold.Single d -> type_check_decl d | TopoSort.ASTFold.Recursive ds -> type_check_mutually_rec ds in let fold = if false then (fun d e -> let res = fold d e in Format.eprintf "Ended type-checking of this declaration.@."; res) else fold in let fold_topo ast acc = TopoSort.ASTFold.fold fold ast acc in fun env ast -> (* Type check D_Pragma declarations separately from the main AST We can do this because no other declaration depends on a pragma *) let is_pragma d = match d.desc with D_Pragma _ -> true | _ -> false in let pragmas, others = List.partition is_pragma ast in let ast_rev, env = fold_topo others ([], env) in let () = List.iter (check_global_pragma env) pragmas in (List.rev ast_rev, env) let type_check_ast ast = type_check_ast_in_env empty_global ast end (* End *) module TypeCheckDefault = Annotate (struct let check = TypeCheck let output_format = Error.HumanReadable let print_typed = false let use_field_getter_extension = false end) let type_and_run ?instrumentation ast = let ast, static_env = Builder.with_stdlib ast |> Builder.with_primitives Native.DeterministicBackend.primitives |> TypeCheckDefault.type_check_ast in Native.interprete ?instrumentation static_env ast herd-herdtools7-1ca343e/asllib/Typing.mli000066400000000000000000000045621475314470400203740ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) (** The Typing module is yet a single-entry-point module. It only exports the function [annotate_ast] which fills type-annotations holes in the AST. It should provide enough information to disambiguate any type-dependent behaviour. *) (** Possible strictness of type-checking. *) type strictness = Silence | Warn | TypeCheck | TypeCheckNoWarn module type ANNOTATE_CONFIG = sig val check : strictness val output_format : Error.output_format val print_typed : bool val use_field_getter_extension : bool end module type S = sig val type_check_ast : AST.t -> AST.t * StaticEnv.global val type_check_ast_in_env : StaticEnv.global -> AST.t -> AST.t * StaticEnv.global end module Annotate : functor (C : ANNOTATE_CONFIG) -> S module TypeCheckDefault : S val type_and_run : ?instrumentation:bool -> AST.t -> int * Instrumentation.semantics_rule list herd-herdtools7-1ca343e/asllib/aslref.ml000066400000000000000000000225031475314470400202200ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) open Asllib open Typing type file_type = NormalV1 | NormalV0 | PatchV1 | PatchV0 type args = { exec : bool; files : (file_type * string) list; opn : string option; allow_no_end_semicolon : bool; allow_double_underscore : bool; allow_unknown : bool; print_ast : bool; print_serialized : bool; print_typed : bool; show_rules : bool; strictness : strictness; output_format : Error.output_format; use_field_getter_extension : bool; } let push thing ref = ref := thing :: !ref let parse_args () = let show_rules = ref false in let target_files = ref [] in let exec = ref true in let allow_no_end_semicolon = ref false in let allow_double_underscore = ref false in let allow_unknown = ref false in let print_ast = ref false in let print_serialized = ref false in let print_typed = ref false in let opn = ref "" in let strictness : strictness ref = ref TypeCheck in let set_strictness s () = strictness := s in let show_version = ref false in let push_file file_type s = target_files := (file_type, s) :: !target_files in let output_format = ref Error.HumanReadable in let use_field_getter_extension = ref false in let speclist = [ ("--exec", Arg.Set exec, " Execute the asl program (default)."); ("--no-exec", Arg.Clear exec, " Don't execute the asl program."); ( "--allow-no-end-semicolon", Arg.Set allow_no_end_semicolon, " Allow block statements to terminate with 'end' instead of 'end;'." ); ( "--allow-double-underscore", Arg.Set allow_double_underscore, " Allow the usage of variables beginning with double underscores \ ('__')." ); ( "--allow-unknown", Arg.Set allow_unknown, " Allow the usage of 'UNKNOWN' instead of 'ARBITRARY'." ); ( "--print", Arg.Set print_ast, " Print the parsed AST to stdout before executing it." ); ( "--serialize", Arg.Set print_serialized, " Print the parsed AST to stdout in the serialized format." ); ( "--print-typed", Arg.Set print_typed, " Print the parsed AST after typing and before executing it." ); ( "--format-csv", Arg.Unit (fun () -> output_format := Error.CSV), " Output the errors in a CSV format." ); ( "--opn", Arg.Set_string opn, "OPN_FILE Parse the following opn file as main." ); ( "--no-type-check", Arg.Unit (set_strictness Silence), " Do not type-check, only perform minimal type-inference. Default for \ v0." ); ( "--type-check-warn", Arg.Unit (set_strictness Warn), " Do not type-check, only perform minimal type-inference. Log typing \ errors on stderr." ); ( "--type-check-strict", Arg.Unit (set_strictness TypeCheck), " Perform type-checking, Fatal on any type-checking error. Default for \ v1." ); ( "--type-check-no-warn", Arg.Unit (set_strictness TypeCheckNoWarn), " Perform type-checking, fatal on any type-checking error, but don't \ show any warnings." ); ( "--use-field-getter-extension", Arg.Set use_field_getter_extension, " Instruct the type-checker to use the field getter extension." ); ( "--show-rules", Arg.Set show_rules, " Instrument the interpreter and log to std rules used." ); ( "--patch", Arg.String (push_file PatchV1), "Pass patches to the built AST." ); ( "--patch0", Arg.String (push_file PatchV0), "Pass patches to the built AST." ); ("-0", Arg.String (push_file NormalV0), "Use ASLv0 parser for this file."); ( "-1", Arg.String (push_file NormalV1), "Use ASLv1 parser for this file. (default)" ); ("--version", Arg.Set show_version, " Print version and exit."); ] |> Arg.align ?limit:None in let anon_fun = push_file NormalV1 in let prog = if Array.length Sys.argv > 0 then Filename.basename Sys.argv.(0) else "aslref" in let usage_msg = Printf.sprintf "ASL parser and interpreter.\n\nUSAGE:\n\t%s [OPTIONS] [FILE]\n" prog in let () = Arg.parse speclist anon_fun usage_msg in let args = { exec = !exec; files = !target_files; opn = (match !opn with "" -> None | s -> Some s); allow_no_end_semicolon = !allow_no_end_semicolon; allow_double_underscore = !allow_double_underscore; allow_unknown = !allow_unknown; print_ast = !print_ast; print_serialized = !print_serialized; print_typed = !print_typed; strictness = !strictness; show_rules = !show_rules; output_format = !output_format; use_field_getter_extension = !use_field_getter_extension; } in let () = let ensure_exists s = if Sys.file_exists s then () else let () = Printf.eprintf "%s cannot find file %S\n%!" prog s in (* Arg.usage speclist usage_msg; *) exit 1 in List.iter (fun (_, s) -> ensure_exists s) args.files; Option.iter ensure_exists args.opn in let () = if !show_version then let () = Printf.printf "aslref version %s rev %s\n%!" Version.version Version.rev in exit 0 in args let or_exit f = if Printexc.backtrace_status () then f () else match Error.intercept f () with | Ok res -> res | Error e -> Format.eprintf "%a@." Error.pp_error e; exit 1 let () = let args = parse_args () in let parser_config = let allow_no_end_semicolon = args.allow_no_end_semicolon in let allow_double_underscore = args.allow_double_underscore in let allow_unknown = args.allow_unknown in let open Builder in { allow_no_end_semicolon; allow_double_underscore; allow_unknown } in let extra_main = match args.opn with | None -> [] | Some fname -> or_exit @@ fun () -> Builder.from_file ~ast_type:`Opn ~parser_config `ASLv1 fname in let ast = let folder (ft, fname) ast = let version = match ft with | NormalV0 | PatchV0 -> `ASLv0 | NormalV1 | PatchV1 -> `ASLv1 in let this_ast = Builder.from_file ~parser_config version fname in match ft with | NormalV0 | NormalV1 -> List.rev_append this_ast ast | PatchV1 | PatchV0 -> ASTUtils.patch ~src:ast ~patches:this_ast in or_exit @@ fun () -> List.fold_right folder args.files [] in let ast = List.rev_append extra_main ast in let () = if args.print_ast then Format.printf "%a@." PP.pp_t ast in let () = if args.print_serialized then print_string (Serialize.t_to_string ast) in let ast = let open Builder in with_primitives Native.DeterministicBackend.primitives ast |> with_stdlib in let () = if false then Format.eprintf "%a@." PP.pp_t ast in let () = match args.output_format with | Error.CSV -> Printf.eprintf {|"File","Start line","Start col","End line","End col","Exception label","Exception" |} | Error.HumanReadable -> () in let typed_ast, static_env = let module C = struct let output_format = args.output_format let check = args.strictness let print_typed = args.print_typed let use_field_getter_extension = args.use_field_getter_extension end in let module T = Annotate (C) in or_exit @@ fun () -> T.type_check_ast ast in let () = if args.print_typed then Format.printf "@[Typed AST:@ %a@]@." PP.pp_t typed_ast in let exit_code, used_rules = if args.exec then let instrumentation = if args.show_rules then true else false in or_exit @@ fun () -> Native.interprete ~instrumentation static_env typed_ast else (0, []) in let () = if args.show_rules then let open Format in printf "@[Used rules:@ %a@]@." (pp_print_list ~pp_sep:pp_print_cut Instrumentation.SemanticsRule.pp) used_rules in exit exit_code herd-herdtools7-1ca343e/asllib/backend.mli000066400000000000000000000166711475314470400205150ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) (** Signature module of the backend of {!Interpreter}. *) module type SCOPE = sig type t (** Data making a subprogram call unique, if needed. *) val global : init:bool -> t (** The global scope during runtime or init, depending on [init] flag. *) val new_local : AST.identifier -> t (** [new_local_scope subprogram_name] returns a new identifier for the call to the function named [subprogram_name]. *) end (** This module is the signature of any backend of the ASL interpreter. *) module type S = sig (* Value constructors *) (*--------------------*) type value (** The runtime values that the interpreter should use. *) val debug_value : value -> string (** A printer for value, should only be used for debugging. *) val is_undetermined : value -> bool (** [is_undetermined v] returns true when [c] is a non-constant value *) val v_of_literal : AST.literal -> value (** [v_of_parsed_v] constructs a value from a parsed value. Note that the prefered method to create records or any complex values is [create_vector], and should be used for constructing complex values. *) val v_of_int : int -> value (** [v_of_int] is used to convert raw integers arising from the interpretation, and not parsed values. *) val v_to_z : value -> Z.t option (** [v_to_z v] returns, if possible, an integer corresponding to the value. Should be called only on values of type integer. *) val v_to_label : value -> string (** [v_to_label v] returns the identifier of the label nested in the literal inside [v]. Should be called only on values of type [NV_Literal] where the literal is of type [L_Label]. *) (* Monadic operators *) (*-------------------*) type 'a m (** Main monad type to chain operations done by the interpreter. *) val return : 'a -> 'a m (** Monadic constructor. *) val cutoffT : string -> 'a -> 'a m (** Flag loop unrolling pruning *) val bind_data : 'a m -> ('a -> 'b m) -> 'b m (** Monadic bind operation, used when data from the first operation is needed to compute the second operation. *) val bind_seq : 'a m -> ('a -> 'b m) -> 'b m (** Monadic bind operation, but that only passes internal interpreter data. This should not create any data-dependency. *) val bind_ctrl : 'a m -> ('a -> 'b m) -> 'b m (** Monadic bind operation, but that creates a control dependency between the first argument and the result of the second one. *) val prod_par : 'a m -> 'b m -> ('a * 'b) m (** Monadic product operation, two monads are combined "in parallel".*) val appl_data : 'a m -> ('a -> 'b) -> 'b m (** Applicative map. Creates a data dependency between the output events and the input events of the argument in the resulting monad. *) val debugT : string -> 'a m -> 'a m (** Print representation of monad on stderr *) val commit : string option -> unit m (** Branching event *) val choice : value m -> 'b m -> 'b m -> 'b m (** choice is a boolean if operator. *) val delay : 'a m -> ('a -> 'a m -> 'b m) -> 'b m (** delay operator spits monad into result ['a] and hidden structure. This permits deciding on the monad value, while using hidden structure later *) (** Special operations with vectors *) (* --------------------------------*) val create_vector : value list -> value m (** Creates a vector with this values. *) val create_record : (AST.identifier * value) list -> value m (** Creates a record, with the indicated names. *) val create_exception : (AST.identifier * value) list -> value m (** Creates an exception, with the indicated names. *) val get_index : int -> value -> value m (** [get_i i vec] returns value at index [i] inside [vec].*) val set_index : int -> value -> value -> value m (** [set_i i v vec] returns [vec] with index [i] replaced by [v].*) val get_field : string -> value -> value m (** [get_field "foo" v] is the value mapped by "foo" in the record [v]. *) val set_field : string -> value -> value -> value m (** [set_field "foo" v record] is [record] with "foo" mapping to [v]. *) (** Other operations *) (* -----------------*) val v_unknown_of_type : eval_expr_sef:(AST.expr -> value m) -> AST.ty -> value m (** [v_unknown_of_type ~eval_expr_sef t] constructs an arbitrary value from a type. *) val binop : AST.binop -> value -> value -> value m (** Evaluates the binary operation on those two values. *) val unop : AST.unop -> value -> value m (** Evaluate this unary operation on this value. *) val ternary : value -> (unit -> value m) -> (unit -> value m) -> value m (** [ternary v w1 w2] is w1 if v is true and w2 if v is false *) module Scope : SCOPE val on_read_identifier : AST.identifier -> Scope.t -> value -> unit m (** [on_read_identifier] is called when a value is read from the local environment.*) val on_write_identifier : AST.identifier -> Scope.t -> value -> unit m (** [on_write_identifier] is called when a value is read from the local environment.*) type value_range = value * value (** Represents a range by its first accessed index and its length. *) val read_from_bitvector : value_range list -> value -> value m (** Read a slice (represented by a list of value ranges) from a bitvector. *) val write_to_bitvector : value_range list -> value -> value -> value m (** [write_to_bitvector value_ranges w v] writes the bits of [w] into [v] at the positions specified by [value_range]. *) val concat_bitvectors : value list -> value m (** Similar to Bitvector.concat, but monadic style obviously. *) val bitvector_length : value -> value m (** Get the length of a bitvector. *) type primitive = value m list -> value m list -> value m list m (** primitive types that go with this AST. First argument is list of parameters, second argument is list of arguments. *) val primitives : (AST.func * primitive) list (** The list of primitives that a backend provides. *) end herd-herdtools7-1ca343e/asllib/bitvector.ml000066400000000000000000000530721475314470400207520ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) (* BitVector type *) (* Notations: - A type t is named (length, data) or bv - b is a bit - n = length / 8 : ~the length of data~ - m = length mod 8 : the number of bits of the trailing character. *) (* -------------------------------------------------------------------------- Main type definition --------------------------------------------------------------------------*) type t = int * string (** A bitvector is given by its length in bits and its containing data. Note that the stored data is a string, but only for performance and immutability of values reasons. This should not be printed as is, and users should use the dedicated printing primitives. Invariant: For a value (length, data), we have String.length data = length / 8 + 1 *) (* Accessors. *) let length = fst let data = snd (* -------------------------------------------------------------------------- Helpers --------------------------------------------------------------------------*) (* Constant. *) let code_0 = Char.code '0' let char_0 = Char.chr 0 let char_ff = Char.chr 0xff (* Mask for the last character, given by [length mod 8]. *) let last_char_mask m = (1 lsl m) - 1 (* [read_bit_raw i c] reads bit at index [i] in character [c]. *) let read_bit_raw i c = (Char.code c lsr i) land 1 (* [read_bit i c] is the printable character representing bit [i] in character [c]. *) let read_bit i c = Char.chr (read_bit_raw i c + code_0) (* [set_bit_raw i dst b] sets the [i]-th bit of [dst] to [b]. *) let set_bit_raw i dst b = dst land lnot (1 lsl i) lor (b lsl i) (* [set_bit src_pos dst_pos src dst] sets the [dst_pos]-th bit of [pos] to the [src_pos]-th bit of [src]. *) let set_bit src_pos dst_pos src dst = read_bit_raw src_pos src |> set_bit_raw dst_pos dst |> Char.chr (* Debug printer. *) let _pp_data f (length, data) = let open Format in pp_print_int f length; pp_print_char f 'x'; String.iter (fun c -> fprintf f "%x" @@ Char.code c) data let create_data_bytes length = Bytes.create ((length + 7) / 8) (** [String.for_all] taken directly out of stdlib version 4.13 . *) let string_for_all p s = let n = String.length s in let rec loop i = if i = n then true else if p (String.unsafe_get s i) then loop (succ i) else false in loop 0 (** [remask bv] ensures that the extra bits on the trailing character are '0'. It edits in place the string, so to use with prudence. *) let remask (length, data) = let n = length / 8 and m = length mod 8 in if m == 0 then (length, data) else let trailing_d = String.get data n |> Char.code in let masked_d = trailing_d land last_char_mask m in let new_c = Char.chr masked_d in let buf = Bytes.unsafe_of_string data in let () = Bytes.set buf n new_c in let data = Bytes.unsafe_to_string buf in (length, data) (* -------------------------------------------------------------------------- Signs and extensions --------------------------------------------------------------------------*) let sign_bit (length, data) = match length with | 0 -> 0 | _ -> let n = length / 8 and m = length mod 8 in let data_pos = if m = 0 then n - 1 else n in let bit_index = (m + 7) mod 8 in String.get data data_pos |> read_bit_raw bit_index let extend signed nbytes (length, data) = let to_length = 8 * nbytes in let data_length = String.length data in if length > to_length then (to_length, String.sub data 0 nbytes) else if length = to_length then (length, data) else let result = Bytes.extend (Bytes.unsafe_of_string data) 0 (nbytes - data_length) in let neg = signed && sign_bit (length, data) = 1 in let () = if neg then let n = length / 8 and m = length mod 8 in let sign_bit_pos = if m = 0 then n - 1 else n in String.get data sign_bit_pos |> Char.code |> Int.logor [| 0; 0xff; 0xfe; 0xfc; 0xf8; 0xf0; 0xe0; 0xc0 |].(m) |> Char.chr |> Bytes.set result sign_bit_pos in Bytes.fill result data_length (nbytes - data_length) (if neg then char_ff else char_0); (to_length, Bytes.unsafe_to_string result) let zero_extend = extend false let sign_extend = extend true (* -------------------------------------------------------------------------- Printers and conversions --------------------------------------------------------------------------*) let pp_t = let open Format in fun f (length, data) -> pp_print_char f '\''; pp_open_hbox f (); let n = length / 8 and m = length mod 8 in if m <> 0 then let c = String.get data n in for j = m - 1 downto 0 do read_bit j c |> Format.pp_print_char f done else (); for i = n - 1 downto 0 do let c = String.get data i in for j = 7 downto 0 do read_bit j c |> Format.pp_print_char f done done; pp_close_box f (); pp_print_char f '\'' let to_string (length, data) = let result = Buffer.create (length + 2) in let n = length / 8 and m = length mod 8 in Buffer.add_char result '\''; if m <> 0 then let c = String.get data n in for j = m - 1 downto 0 do read_bit j c |> Buffer.add_char result done else (); for i = n - 1 downto 0 do let c = String.get data i in for j = 7 downto 0 do read_bit j c |> Buffer.add_char result done done; Buffer.add_char result '\''; Buffer.contents result let hex_number = Array.get [| '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9'; 'a'; 'b'; 'c'; 'd'; 'e'; 'f'; |] let buffer_add_hex result y = y mod 16 |> hex_number |> Buffer.add_char result let write_char_hex result c = let x = Char.code c in buffer_add_hex result (x lsr 4); buffer_add_hex result x let to_string_hexa (length, data) = let result = Buffer.create (2 * (length + 2)) in let n = length / 8 and m = length mod 8 in Buffer.add_string result "0x"; (if m <> 0 then let c = String.get data n in if m > 4 then write_char_hex result c else c |> Char.code |> buffer_add_hex result); for i = n - 1 downto 0 do String.get data i |> write_char_hex result done; Buffer.contents result let to_int (length, data) = let result = ref 0 in let n = length / 8 and m = length mod 8 in for i = 0 to n - 1 do let c = String.get data i |> Char.code in result := !result lor (c lsl (i * 8)) done; if m != 0 then let c = String.get data n |> Char.code |> ( land ) (last_char_mask m) in result := !result lor (c lsl (n * 8)) else (); !result let to_int64_raw (length, data) = let result = ref Int64.zero in let n = length / 8 and m = length mod 8 in for i = 0 to n - 1 do let c = String.get data i |> Char.code in result := Int64.logor !result (c lsl (i * 8) |> Int64.of_int) done; if m != 0 then let c = String.get data n |> Char.code |> ( land ) (last_char_mask m) in result := Int64.logor !result (c lsl (n * 8) |> Int64.of_int) else (); !result let to_int64_signed bv = bv |> sign_extend 8 |> to_int64_raw let to_int64_unsigned (length, data) = let _, data = zero_extend 8 (length, data) in let _, data = remask (63, data) in to_int64_raw (64, data) let to_z_unsigned (_, data) = Z.of_bits data let to_z_signed ((sz, _) as bv) = let sgn = sign_bit bv in let r = to_z_unsigned bv in if sgn = 0 then r else Z.sub r (Z.shift_left Z.one sz) let z63 = Z.shift_left Z.one 63 let z64 = Z.shift_left Z.one 64 let printable bv = let z = to_z_signed bv in if Z.geq z z63 then Z.sub z z64 else z let of_string s = let result = Buffer.create ((String.length s / 8) + 1) in let lengthr = ref 0 in let last_char = ref 0 in for i = String.length s - 1 downto 0 do match String.get s i with | ('0' | '1') as b -> let length = !lengthr in let () = lengthr := length + 1 in let m = length mod 8 in let c = !last_char in let c = if b = '1' then c lor (1 lsl m) else c in if m = 7 then ( Buffer.add_char result (Char.chr c); last_char := 0) else last_char := c | _ -> () done; let length = !lengthr in let m = length mod 8 in if m <> 0 then let c = !last_char land last_char_mask m in Buffer.add_char result (Char.chr c) else (); (length, Buffer.contents result) let of_int64 s = let result = create_data_bytes 64 in for i = 0 to 7 do Int64.shift_right_logical s (8 * i) |> Int64.logand 255L |> Int64.to_int |> Char.chr |> Bytes.set result i done; (64, Bytes.unsafe_to_string result) let of_int x = of_int64 (Int64.of_int x) let of_z sz z = let n = (sz + 7) / 8 and m = sz mod 8 in let result = Bytes.make n char_0 in let rec do_rec msk i = if i >= 0 then ( let c = Z.extract z (i * 8) 8 |> Z.to_int |> ( land ) msk |> Char.chr in Bytes.unsafe_set result i c; do_rec 0xFF (i - 1)) in let msk = last_char_mask (if m = 0 then 8 else m) in do_rec msk (n - 1); (sz, Bytes.unsafe_to_string result) let of_int_sized sz i = of_z sz (Z.of_int i) (* -------------------------------------------------------------------------- Operations --------------------------------------------------------------------------*) let ensure_equal_length length1 length2 = if length1 = length2 then length1 else raise (Invalid_argument "bitwise_op") (* [bitwise_op Int.logand bv1 bv2] computes the bitwise and on bv1 and bv2. *) let bitwise_op int_op (length1, data1) (length2, data2) = let length = ensure_equal_length length1 length2 in let n = length / 8 and m = length mod 8 in let result = create_data_bytes length in for i = 0 to n - 1 do let d1 = String.get data1 i |> Char.code and d2 = String.get data2 i |> Char.code in let c = int_op d1 d2 |> Char.chr in Bytes.set result i c done; if m <> 0 then let mask = last_char_mask m in let d1 = String.get data1 n |> Char.code |> ( land ) mask and d2 = String.get data2 n |> Char.code |> ( land ) mask in let c = int_op d1 d2 |> ( land ) mask |> Char.chr in Bytes.set result n c else (); (length, Bytes.unsafe_to_string result) let lognot (length, data) = let bnot c = c |> Char.code |> lnot |> ( land ) 0xff |> Char.chr in let ndata = String.map bnot data in remask (length, ndata) let logand = bitwise_op ( land ) let logor = bitwise_op ( lor ) let logxor bv1 bv2 = bitwise_op ( lxor ) bv1 bv2 |> remask let equal bv1 bv2 = if false then Format.eprintf "@[%a =@ %a@]@." _pp_data bv1 _pp_data bv2; length bv1 == length bv2 && (* let bv1 = remask bv1 and bv2 = remask bv2 in *) String.equal (data bv1) (data bv2) let compare bv1 bv2 = match Int.compare (length bv1) (length bv2) with | 0 -> (* let bv1 = remask bv1 and bv2 = remask bv2 in *) String.compare (data bv1) (data bv2) | i -> i let string_fold_left f init s = let state = ref init in for i = 0 to String.length s - 1 do state := f !state @@ String.get s i done; !state let bitcount (_length, data) = (* Inspired by both https://graphics.stanford.edu/~seander/bithacks.html#CountBitsSetKernighan https://github.com/backtracking/bitv/blob/master/bitv.ml#L351 *) let rec one_byte x = if x = 0 then 0 else 1 + one_byte (x land (x - 1)) in (* Here Filliatre caches the count in an array, but we are not yet there. *) let folder acc c = acc + one_byte (Char.code c) in string_fold_left folder 0 data let log2 = let rec loop acc i = if i <= 0 then acc else loop (acc + 1) (i lsr 1) in loop 0 let highest_set_bit (_length, data) = let rec loop i = if i < 0 then 0 else let c = String.get data i |> Char.code in if c != 0 then log2 c + (8 * i) else loop (i - 1) in loop (String.length data - 1) let to_int_signed (length, data) = if length = 0 then 0 else if sign_bit (length, data) = 1 then -to_int (lognot (length - 1, data)) - 1 else to_int (length - 1, data) (* -------------------------------------------------------------------------- Slices --------------------------------------------------------------------------*) (* Write into dst at position pos_dst the bit of src at position pos_src. *) let copy_bit dst src pos_src pos_dst = let c_src = String.get src (pos_src / 8) and c_dst = Bytes.get dst (pos_dst / 8) |> Char.code in let new_char_dst = set_bit (pos_src mod 8) (pos_dst mod 8) c_src c_dst in Bytes.set dst (pos_dst / 8) new_char_dst let prefix (len, s) dst_len = assert (dst_len <= len); let sz8 = (dst_len + 7) / 8 in let dst_s = String.sub s 0 sz8 in (dst_len, dst_s) let extract_slice (_length_src, data_src) positions = try let length = List.length positions in let result = create_data_bytes length in (* Same effect than [List.rev positions], as we build those from the end. *) let copy_bit_here i pos = copy_bit result data_src pos (length - 1 - i) in let () = List.iteri copy_bit_here positions in remask (length, Bytes.unsafe_to_string result) with Invalid_argument msg -> raise (Invalid_argument (Printf.sprintf "extract_sliced (%s)" msg)) let write_slice (length_dst, data_dst) (length_src, data_src) positions = let min x y = if x <= y then x else y in let length_src = min (List.length positions) length_src in let result = Bytes.of_string data_dst in (* Same effect as [List.rev positions], since we build those from the end. *) let copy_bit_here i pos = copy_bit result data_src (length_src - 1 - i) pos in let () = List.iteri copy_bit_here positions in remask (length_dst, Bytes.unsafe_to_string result) (* Retuns length of destination *) let pp (l, bs) = Printf.sprintf "%s<%d>" (to_string (l, Bytes.to_string bs)) l let pp_bytes n dst = let sz = (n + 1) * 8 in pp (sz, dst) (* [mix_chars_start off low_c high_c] return a char, whose off lower order bits are from low_c and the 8-off higher order bits are the 8-off lower order bits of high_c *) let mix_chars_start off low_c high_c = let low_bits = ((1 lsl off) - 1) land Char.code low_c and high_bits = Char.code high_c lsl off in low_bits lor high_bits |> ( land ) 0xff |> Char.chr (* [mix_chars_body off low_c high_c] return a char, whose off lower order bits are the off higher order bits of low_c and the 8-off higher order bits are the 8-off lower order bits of high_c *) let mix_chars_body off low_c high_c = let low_bits = Char.code low_c lsr (8 - off) and high_bits = Char.code high_c lsl off in low_bits lor high_bits |> ( land ) 0xff |> Char.chr (* [mix_chars_final off c] return a char, whose sz lower order bits are the sz bits of c at possition off. *) let mix_char_final off sz c = (Char.code c lsr off) land ((1 lsl sz) - 1) |> Char.chr let copy_into dst ((length_src, data_src) as b) offset = let () = if false then Printf.eprintf "copy_into %s + %s, offset=%d\n%!" (to_string b) (pp (offset, dst)) offset in let length_dst = offset + length_src in if length_src <= 0 then length_dst else let n_off = offset / 8 and m_off = offset mod 8 in let () = if m_off = 0 then Bytes.blit_string data_src 0 dst n_off (String.length data_src) else (* * First handle the first written char: * The 8-m_off low order bits of src.[0] are * copied into the 8-m_off high order_bits of * dst.[n_off] *) let prec_c = Bytes.get dst n_off and next_c = String.get data_src 0 in mix_chars_start m_off prec_c next_c |> Bytes.set dst n_off; let () = if false then Printf.eprintf "Start: %s\n%!" (pp_bytes n_off dst) in (* * Now, loop. * At each step, 8-off bits are taken from * the higher order bits of some source char, * while the off higher order bits are taken from the * lower order bits of the next_char *) (* Number of bits still to write *) let rem_bits = length_src - (8 - m_off) in (* Useful string length *) let src_str_len = (length_src + 7) / 8 in let rec do_rec i_src i_dst rem_bits = if i_src + 1 >= src_str_len then (i_src, i_dst, rem_bits) else let prec_c = String.get data_src i_src in let next_c = String.get data_src (i_src + 1) in mix_chars_body m_off prec_c next_c |> Bytes.set dst i_dst; let () = if false then Printf.eprintf "Body -> %s\n%!" (pp_bytes i_dst dst) in do_rec (i_src + 1) (i_dst + 1) (rem_bits - 8) in let i_src, i_dst, rem_bits = do_rec 0 (n_off + 1) rem_bits in let () = if false then Printf.eprintf "i_src=%d, i_dst=%d, rem_bits=%d\n%!" i_src i_dst rem_bits in if rem_bits > 0 then let c = String.get data_src i_src in mix_char_final (8 - m_off) rem_bits c |> Bytes.set dst i_dst in let () = if false then Printf.eprintf "copy_into %s + %s ->%s\n%!" (to_string b) (pp (offset, dst)) (pp (length_dst, dst)) in length_dst let concat bvs = (if false then let pp = List.map to_string bvs in Printf.eprintf "Concat %s\n%!" (String.concat "," pp)); let length = List.fold_left (fun acc bv -> acc + length bv) 0 bvs in let result = create_data_bytes length in let _ = List.fold_right (copy_into result) bvs 0 in (length, Bytes.unsafe_to_string result) (* -------------------------------------------------------------------------- Small utils --------------------------------------------------------------------------*) let zeros length = let n = length / 8 and m = length mod 8 in let data = String.make (if m = 0 then n else n + 1) char_0 in (length, data) let ones length = let n = length / 8 and m = length mod 8 in let data = String.make (if m = 0 then n else n + 1) char_ff in remask (length, data) let zero = zeros 1 let one = ones 1 let empty = (0, "") let is_zeros bv = let _length, data = remask bv in string_for_all (( = ) char_0) data let is_ones bv = length bv |> ones |> equal bv type mask = { length : int; set : string; unset : string; specified : string; initial_string : string; } let mask_length mask = mask.length let mask_of_string s = let length_set, set = String.map (function 'x' -> '0' | '0' -> '0' | '1' -> '1' | c -> c) s |> of_string and length_unset, unset = String.map (function 'x' -> '0' | '0' -> '1' | '1' -> '0' | c -> c) s |> of_string and length_specified, specified = String.map (function 'x' -> '0' | '0' -> '1' | '1' -> '1' | c -> c) s |> of_string in let () = if false then Format.eprintf "Parsing %s gave %a and %a@." s _pp_data (length_set, set) _pp_data (length_unset, unset) in if length_set != length_unset || length_set != length_specified then raise (Invalid_argument "Mask") else { length = length_set; set; unset; specified; initial_string = s } let mask_of_bitvector ((length, data) as bv) = let set = data and _, unset = lognot bv and _, specified = ones length and initial_string = to_string bv in { length; set; unset; specified; initial_string } let matches bv mask = if length bv != mask.length then raise (Invalid_argument "mask_matches"); equal (mask.length, mask.specified) (logor (logand bv (mask.length, mask.set)) (logand (lognot bv) (mask.length, mask.unset))) let mask_to_string mask = mask.initial_string let mask_to_canonical_string mask = let set = to_string (mask.length, mask.set) and unset = to_string (mask.length, mask.unset) in let result = Bytes.create (String.length set) in for i = 0 to String.length set - 1 do let b = match (String.get set i, String.get unset i) with | '0', '0' -> 'x' | '1', _ -> '1' | _, '1' -> '0' | c, _ -> c in Bytes.set result i b done; Bytes.unsafe_to_string result let mask_set mask = (mask.length, mask.set) let mask_unset mask = (mask.length, mask.unset) let mask_specified mask = (mask.length, mask.specified) herd-herdtools7-1ca343e/asllib/bitvector.mli000066400000000000000000000175301475314470400211220ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) (** This module provide an interface to ASL bitvector, and main operations on it. *) type t (** Represent a bitvector. *) val length : t -> int (** The length of the bitvector. *) (* --------------------------------------------------------------------------*) (** {2 Constructors} *) val one : t (** A length 1 bitvector with a 1 bit inside. *) val zero : t (** A length 1 bitvector with a 0 bit inside. *) val empty : t (** A length 0 bitvector. *) val ones : int -> t (** [ones n] is a bitvector of length [n] with every bit set. *) val zeros : int -> t (** [zeros n] is a bitvector of length [n] without any bit set. *) val of_string : string -> t (** [of_string s] interpretes [s] as a right-indexed representation of a bitvector. Characters others than '0' or '1' are ignored. The length of [of_string s] is equal to the number of such characters in [s]. *) val of_int : int -> t (** [of_int i] is the bitvector of length [Sys.int_size] (e.g. 63) that corresponds to [i] in little-endian, i.e. index 0 (for slicing operations corresponds to [i mod 2]. *) val of_int_sized : int -> int -> t (** [of_int n i] is the bitvector of length [n] that corresponds to [i] in little-endian, i.e. index 0 (for slicing operations corresponds to [i mod 2]. *) val of_int64 : int64 -> t (** [of_int i] is the bitvector of length 64 that corresponds to [i] in little-endian, i.e. index 0 (for slicing operations corresponds to [i mod 2]. *) val of_z : int -> Z.t -> t (** [of_int sz i] is the bitvector of length [sz] that corresponds to [i] in little-endian. *) (* --------------------------------------------------------------------------*) (** {2 Exports} *) val pp_t : Format.formatter -> t -> unit (** Print the bitvector, indexed from the right, as a serie of '0' and '1', delimited by apostrophes. Inside a horizontal box. *) val to_string : t -> string (** Returns a string representing the bitvector, indexed from the right and delimited by apostrophes. *) val to_string_hexa : t -> string (** Returns a string representing the bitvector in hexadecimal, indexed from the right and preceded by '0x'. *) val to_int : t -> int (** Returns an integer representing the bitvector, little-endian. Result unspecified if [length > Sys.int_size]. *) val to_int_signed : t -> int (** Returns a signed integer representing the bitvector. *) val to_int64_unsigned : t -> int64 (** Returns an integer representing the bitvector, little-endian. Result unspecified if [length > 64]. *) val to_int64_signed : t -> int64 (** Returns an integer representing the bitvector, little-endian. Result unspecified if [length > 64]. *) val to_z_unsigned : t -> Z.t val to_z_signed : t -> Z.t val printable : t -> Z.t (* --------------------------------------------------------------------------*) (** {2 Operations on bitvectors} *) val lognot : t -> t (** Bitwise not operation. @raise Invalid_argument if lengths are different. *) val logand : t -> t -> t (** Bitwise and operation. @raise Invalid_argument if lengths are different. *) val logor : t -> t -> t (** Bitwise or operation. @raise Invalid_argument if lengths are different. *) val logxor : t -> t -> t (** Bitwise xor operation. @raise Invalid_argument if lengths are different. *) val equal : t -> t -> bool (** [equal b1 b2] is [true] if and only if [b1] and [b2] are bitwise equal. *) val compare : t -> t -> int (** The comparison function for bitvectors, with the same specification as [Stdlib.compare]. *) val sign_extend : int -> t -> t (** [sign_extend nbytes bv] returns a copy of bv of length [8*nbytes], left-padded with [bv]'s bit-sign. *) val bitcount : t -> int (** Returns the number of bits set to 1. *) val highest_set_bit : t -> int (** Returns the index of the highest set bit. *) val prefix : t -> int -> t (** [prefix src len] returns the prefix of size [len] of bitvector [src]. Will crash if [len] is strictly more then the size of [src]. *) val extract_slice : t -> int list -> t (** [extract_slice src positions] returns a bitvector whose [i]-th bit is the bit of [src] whose index is the [i]-th element of [positions]. @raise Invalid_argument if any index in positions is greater or equal to the length of [src]. *) val write_slice : t -> t -> int list -> t (** [write_slice dst src positions] is a copy of [dst] where each bit at index [i] in [src] has been written in [dst] at the index given by the [i]-th element of [positions]. @raise Invalid_argument if [positions] has not the same length as [src], or any of the indexes in [positions] is greater than the length of [dst]. *) val concat : t list -> t (** [concat [bv2; bv1; bv0]] is the concatenation of [bv0], [bv1], and [bv2], in this order, i.e. if [bv0] is not empty, the following is true: {[ equal (extract_slice (concat [bv1; bv0]) [ 0 ]) (extract_slice bv0 [ 0 ]) ]} *) val is_zeros : t -> bool (** [is_zeros bv] is true if every bit of bv is unset. *) val is_ones : t -> bool (** [is_ones bv] is true if every bit of bv is set. *) (* --------------------------------------------------------------------------*) (** {2 Bitvector masks} Bitvector in ASL can be matched against masks, that have the same syntax than bitvectors, with an extra possible bit: ['x']. This bits indicates that the mask would match against any bit at this position. For example: {[ assert ('01' IN {'01'}) == TRUE; assert ('01' IN {'0x'}) == TRUE; assert ('10' IN {'0x'}) == FALSE; ]} *) type mask (** Internal representation of a mask. *) val mask_length : mask -> int (** Returns the length of bitvectors matched by this mask. *) val mask_of_string : string -> mask (** Build a mask from its ASL representation. *) val mask_of_bitvector : t -> mask (** Build a mask that matches a bitvector. *) val matches : t -> mask -> bool (** [matches mask bv] is true iff [bv] matches [mask]. *) val mask_to_string : mask -> string (** Returns an ASL string matching its value. *) val mask_to_canonical_string : mask -> string (** Returns a unique ASL string matching its value. *) val mask_set : mask -> t (** [mask_set m]'s set bits are those required set by [m]. *) val mask_unset : mask -> t (** [mask_unset m]'s set bits are those required unset by [m]. *) val mask_specified : mask -> t (** [mask_specified m]'s set bits are those require set or unset by [m]. *) herd-herdtools7-1ca343e/asllib/builder.ml000066400000000000000000000161541475314470400203770ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) open Lexing let _debug = false type token = Tokens.token type ast_type = [ `Opn | `Ast ] type version = [ `ASLv0 | `ASLv1 ] type parser_config = { allow_no_end_semicolon : bool; allow_double_underscore : bool; allow_unknown : bool; } type version_selector = [ `ASLv0 | `ASLv1 | `Any ] let default_parser_config = { allow_no_end_semicolon = false; allow_double_underscore = false; allow_unknown = false; } let select_type ~opn ~ast = function | Some `Opn -> opn | Some `Ast -> ast | None -> ast let _ast_type_to_string = select_type ~opn:"Opn" ~ast:"Ast" let lexbuf_set_filename lexbuf pos_fname = lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname }; lexbuf.lex_start_p <- { lexbuf.lex_start_p with pos_fname } let from_lexbuf ast_type parser_config version (lexbuf : lexbuf) = let open Error in let () = if _debug then Format.eprintf "Parsing %s from file %s@." (_ast_type_to_string ast_type) lexbuf.lex_curr_p.pos_fname in let cannot_parse lexbuf = fatal_here lexbuf.lex_start_p lexbuf.lex_curr_p CannotParse in let unknown_symbol lexbuf = fatal_here lexbuf.lex_start_p lexbuf.lex_curr_p UnknownSymbol in match version with | `ASLv1 -> ( let module Parser = Parser.Make (struct let allow_no_end_semicolon = parser_config.allow_no_end_semicolon end) in let module Lexer = Lexer.Make (struct let allow_double_underscore = parser_config.allow_double_underscore let allow_unknown = parser_config.allow_unknown end) in let parse = select_type ~opn:Parser.opn ~ast:Parser.spec ast_type in try parse Lexer.token lexbuf with | Parser.Error -> cannot_parse lexbuf | Lexer.LexerError -> unknown_symbol lexbuf) | `ASLv0 -> ( let parse = select_type ~opn:Gparser0.opn ~ast:Gparser0.ast ast_type and lexer0 = Lexer0.token () in try parse lexer0 lexbuf with Parser0.Error -> cannot_parse lexbuf) let from_lexbuf' ast_type parser_config version lexbuf () = from_lexbuf ast_type parser_config version lexbuf let close_after chan f = try let res = f () in close_in chan; res with e -> close_in_noerr chan; raise e let open_file filename = let chan = open_in filename in let lexbuf = from_channel chan in lexbuf_set_filename lexbuf filename; (lexbuf, chan) let from_file ?ast_type ?(parser_config = default_parser_config) version f = let lexbuf, chan = open_file f in close_after chan @@ from_lexbuf' ast_type parser_config version lexbuf let from_file_result ?ast_type ?(parser_config = default_parser_config) version f = let lexbuf, chan = open_file f in close_after chan @@ Error.intercept @@ from_lexbuf' ast_type parser_config version lexbuf let from_lexer_lexbuf ?ast_type ?(parser_config = default_parser_config) version _lexer lexbuf = Error.intercept (from_lexbuf' ast_type parser_config version lexbuf) () let from_file_multi_version ?ast_type ?parser_config = function | `Any -> ( fun fname -> match from_file_result ?ast_type ?parser_config `ASLv0 fname with | Error e -> let () = Format.eprintf "@[Ignoring error on parser v0: %a.@ Trying with parser v1 \ ...@]@." Error.pp_error e in from_file_result ?ast_type ?parser_config `ASLv1 fname | Ok ast -> Ok ast) | (`ASLv0 | `ASLv1) as version -> from_file_result ?ast_type ?parser_config version let from_string ~filename ~ast_string version ast_type parser_config = let lexbuf = Lexing.from_string ~with_positions:true ast_string in lexbuf_set_filename lexbuf filename; from_lexbuf ast_type parser_config version lexbuf let obfuscate prefix = ASTUtils.rename_locals (( ^ ) prefix) let make_builtin d = let open AST in match d.desc with | D_Func f -> D_Func { f with builtin = true } |> ASTUtils.add_pos_from d | D_TypeDecl _ -> prerr_string "Type declaration cannot be builtin"; exit 1 | D_GlobalStorage _ -> prerr_string "Storage declaration cannot be builtin"; exit 1 | D_Pragma _ -> prerr_string "Pragma declaration cannot be builtin"; exit 1 let stdlib = let filename = "ASL Standard Library" and ast_string = Asl_stdlib.stdlib in lazy (from_string ~filename ~ast_string `ASLv1 (Some `Ast) default_parser_config |> obfuscate "__stdlib_local_" |> List.map make_builtin) let stdlib0 = let filename = "ASL Standard Library (V0 compatibility)" and ast_string = Asl_stdlib.stdlib0 in lazy (from_string ~filename ~ast_string `ASLv0 (Some `Ast) default_parser_config |> obfuscate "__stdlib_local_" |> List.map make_builtin) let with_stdlib ast = ast |> List.rev_append (Lazy.force stdlib) |> List.rev_append (Lazy.force stdlib0) let extract_name k d = let open AST in match d.desc with | D_Func { name; _ } -> name :: k | D_TypeDecl _ -> prerr_string "Type declaration in stdlib.asl"; exit 1 | D_GlobalStorage _ -> prerr_string "Storage declaration in stdlib.asl"; exit 1 | D_Pragma _ -> prerr_string "Pragma declaration in stdlib.asl"; exit 1 let is_stdlib_name = let open ASTUtils in let set = lazy (let extract_names ds = List.fold_left extract_name [] ds |> ISet.of_list in Lazy.force stdlib |> extract_names) in fun name -> ISet.mem name (Lazy.force set) let with_primitives ?(loc = ASTUtils.dummy_annotated) primitives = List.map AST.( fun (f, _) -> D_Func { f with builtin = true } |> ASTUtils.add_pos_from loc) primitives |> obfuscate "__primitive_local_" |> List.rev_append herd-herdtools7-1ca343e/asllib/builder.mli000066400000000000000000000053461475314470400205510ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) open Lexing (** Builds an {!AST.t} from some files. *) type token = Tokens.token type ast_type = [ `Opn | `Ast ] type version = [ `ASLv0 | `ASLv1 ] type version_selector = [ `ASLv0 | `ASLv1 | `Any ] type parser_config = { allow_no_end_semicolon : bool; allow_double_underscore : bool; allow_unknown : bool; } val default_parser_config : parser_config (** The default parser configuration. It sets the following: allow_no_end_semicolon = false allow_double_underscore = false allow_unknown = false *) val from_file_result : ?ast_type:ast_type -> ?parser_config:parser_config -> version -> string -> AST.t Error.result val from_file : ?ast_type:ast_type -> ?parser_config:parser_config -> version -> string -> AST.t val from_lexer_lexbuf : ?ast_type:ast_type -> ?parser_config:parser_config -> version -> 'a -> lexbuf -> AST.t Error.result val from_file_multi_version : ?ast_type:ast_type -> ?parser_config:parser_config -> version_selector -> string -> AST.t Error.result val stdlib : AST.t Lazy.t val with_stdlib : AST.t -> AST.t val is_stdlib_name : AST.identifier -> bool val with_primitives : ?loc:unit AST.annotated -> (AST.func * 'a) list -> AST.t -> AST.t herd-herdtools7-1ca343e/asllib/bundler.ml000066400000000000000000000167061475314470400204070ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) open Asllib module IMap = ASTUtils.IMap module ISet = ASTUtils.ISet type identifier_state = | NotYetHandled | NotFound | Parsed of AST.t | BlackListed type bundler_state = identifier_state IMap.t let to_look_dirs = ref [] let instr_dir = ref "" let outdir = ref @@ Sys.getcwd () let ( // ) = Filename.concat let whitelist = ref [] let blacklist = ref ISet.empty let is_interesting name filename = String.equal name @@ Filename.remove_extension filename let build_ast_from_file ?(is_opn = false) f = (* Taken from herdtools7/lib/Pos.ml *) let pp_pos chan pos = let open Lexing in Printf.fprintf chan "File \"%s\", line %i, character %i" pos.pos_fname pos.pos_lnum (pos.pos_cnum - pos.pos_bol) in (* For now expect the ASL input to adhere to the spec. *) let module Parser = Parser.Make (struct let allow_no_end_semicolon = false end) in let module Lexer = Lexer.Make (struct let allow_double_underscore = false let allow_unknown = false end) in let parse = if is_opn then Parser.opn else Parser.spec in let chan = open_in f in let lexbuf = Lexing.from_channel chan in let () = lexbuf.Lexing.lex_curr_p <- { lexbuf.Lexing.lex_curr_p with Lexing.pos_fname = f } in let res = try Some (parse Lexer.token lexbuf) with | Parser.Error -> Printf.eprintf "%s:%a: Cannot parse. Ignoring file.\n" f pp_pos lexbuf.Lexing.lex_curr_p; None | Lexer.LexerError -> Printf.eprintf "%s:%a: unknown token. Ignoring file.\n" f pp_pos lexbuf.Lexing.lex_curr_p; None in close_in chan; res let add_if_not_there = function None -> Some NotYetHandled | Some t -> Some t let has_been_handled state name = match IMap.find_opt name state with | None | Some NotYetHandled -> false | Some (Parsed _) | Some NotFound | Some BlackListed -> true let update_state_and_queue_from_ast ast (state, queue) = let uses = ASTUtils.used_identifiers ast in let state = ISet.fold (fun name -> IMap.update name add_if_not_there) uses state and queue = ISet.fold (fun name queue -> if has_been_handled state name then queue else name :: queue) uses queue in (state, queue) let handle_one (state, queue) name = let interesting_filenames_in dir = Sys.readdir dir |> Array.to_seq |> Seq.filter (is_interesting name) |> Seq.map (Filename.concat dir) in let ast = List.to_seq !to_look_dirs |> Seq.flat_map interesting_filenames_in |> Seq.filter_map (build_ast_from_file ~is_opn:false) |> Seq.flat_map List.to_seq |> List.of_seq in match ast with | _ :: _ -> let () = Printf.eprintf "Adding ast from %s.\n" name in update_state_and_queue_from_ast ast (IMap.add name (Parsed ast) state, queue) | [] -> let () = Printf.eprintf "No AST found for identifier %s.\n" name in (IMap.add name NotFound state, queue) let rec handle_max (state, queue) = match queue with | [] -> state | name :: queue -> if has_been_handled state name then handle_max (state, queue) else if ISet.mem name !blacklist then handle_max (IMap.add name BlackListed state, queue) else handle_max @@ handle_one (state, queue) name let init instr_name = let filename = !instr_dir // instr_name // (instr_name ^ ".opn") in let ast = match build_ast_from_file filename ~is_opn:true with | None -> failwith "Cannot find instruction %s" | Some ast -> ast in update_state_and_queue_from_ast ast (IMap.singleton "main" (Parsed ast), !whitelist) let check_all_dirs_exists () = let dir_exists s = Sys.file_exists s && Sys.is_directory s in to_look_dirs := List.filter dir_exists !to_look_dirs; if not (dir_exists !outdir) then failwith ("Cannot find output directory: " ^ !outdir); if String.equal !instr_dir "" then instr_dir := Sys.getcwd () else if not (dir_exists !instr_dir) then failwith ("Cannot find instruction directory: %s." ^ !instr_dir) let parse_args () = let add_to_ref r s = r := s :: !r in let add_to_ref_set r s = r := ISet.add s !r in let instrs = ref [] in let set_pseudocode_dir s = to_look_dirs := (s // "functions") :: (s // "defs") :: !to_look_dirs; if String.equal !instr_dir "" then instr_dir := s // "instrs" in let speclist = [ ( "--pseudocode-dir", Arg.String set_pseudocode_dir, "If they exist, add the subdirs 'functions', 'defs' and 'instrs' to \ the parsed dirs." ); ( "--dirs", Arg.String (add_to_ref to_look_dirs), "Add the following dir to the parsed dirs." ); ("--instr-dir", Arg.Set_string instr_dir, "Set the instruction directory."); ( "-o", Arg.Set_string outdir, "Directory in which write the files. Default to current." ); ("-i", Arg.String (add_to_ref_set blacklist), "Ignore this identifier."); ( "-a", Arg.String (add_to_ref whitelist), "Add this file and all dependencies." ); ] in let usage = Printf.sprintf "Usage: %s OPTIONS INSTRS ...\n\n\ INSTRS is a list of instruction names that can be found under the name \ INSTR_DIR/INSTR/INSTR.opn\n\n\ OPTIONS" (Filename.basename Sys.executable_name) in let anon_fun = add_to_ref instrs in let () = Arg.parse speclist anon_fun usage in let () = check_all_dirs_exists () in !instrs let write_ast_to instr_name ast = let chan = open_out (!outdir // (instr_name ^ ".asl")) in let formatter = Format.formatter_of_out_channel chan in Format.pp_set_margin formatter 100; PP.pp_t formatter ast; Format.pp_print_flush formatter (); close_out chan let main instr_name = let final_state = init instr_name |> handle_max in let folder _key = function | Parsed ast -> List.rev_append ast | NotFound | BlackListed -> Fun.id | NotYetHandled -> assert false in let final_ast = IMap.fold folder final_state [] |> List.rev in write_ast_to instr_name final_ast let () = let instrs = parse_args () in List.iter main instrs herd-herdtools7-1ca343e/asllib/carpenter/000077500000000000000000000000001475314470400203735ustar00rootroot00000000000000herd-herdtools7-1ca343e/asllib/carpenter/ASTEnums.ml000066400000000000000000000400331475314470400223640ustar00rootroot00000000000000(****************************************************************************************************************) (* SPDX-FileCopyrightText: Copyright 2022-2024 Arm Limited and/or its affiliates *) (* SPDX-License-Identifier: BSD-3-Clause *) (****************************************************************************************************************) let filter_none li = List.filter_map Fun.id li module Make (C : Config.S) = struct open Asllib open AST open Feat open Enum let annot desc = ASTUtils.add_dummy_annotation desc (* Util not to forget to pay ==> make payment mandatory on recursion. *) let fix f = Fix.Memoize.Int.fix (fun blah -> f (pay blah)) let enum_from_seq seq = seq |> Seq.map just |> Seq.fold_left ( ++ ) empty let rec payn n thing = if n <= 0 then thing else payn (n - 1) (pay thing) let scaled_finite li = let rec loop acc = function | [] -> acc | h :: t -> loop (just h ++ pay acc) t in match li with [] -> empty | h :: t -> loop (just h) t let unops : unop enum = scaled_finite [ NEG; BNOT; NOT ] let iterated (op : 'a -> 'a -> 'a) (li : 'a list) : 'a = let rec double_add acc = function | [] -> acc | [ x ] -> x :: acc | x1 :: x2 :: t -> double_add (op x1 x2 :: acc) t in let rec iterated = function | [] -> raise (Invalid_argument "iterated op") | [ x ] -> x | _ :: _ :: _ as li -> double_add [] li |> iterated in iterated li let oneof li = iterated sum li let option e = just None ++ pay (map Option.some e) let tuple3 x y z = x ** y ** z |> map (fun (x, (y, z)) -> (x, y, z)) let nonempty_list x = x ** list x |> map (fun (x, li) -> x :: li) let binops : binop enum = [ (if C.Syntax.plus then Some PLUS else None); (if C.Syntax.and_ then Some AND else None); (if C.Syntax.band then Some BAND else None); (if C.Syntax.beq then Some BEQ else None); (if C.Syntax.bor then Some BOR else None); (if C.Syntax.div then Some DIV else None); (if C.Syntax.eor then Some EOR else None); (if C.Syntax.eq_op then Some EQ_OP else None); (if C.Syntax.gt then Some GT else None); (if C.Syntax.geq then Some GEQ else None); (if C.Syntax.impl then Some IMPL else None); (if C.Syntax.lt then Some LT else None); (if C.Syntax.leq then Some LEQ else None); (if C.Syntax.mod_ then Some MOD else None); (if C.Syntax.minus then Some MINUS else None); (if C.Syntax.mul then Some MUL else None); (if C.Syntax.neq then Some NEQ else None); (if C.Syntax.or_ then Some OR else None); (if C.Syntax.rdiv then Some RDIV else None); (if C.Syntax.shl then Some SHL else None); (if C.Syntax.shr then Some SHR else None); (if C.Syntax.bv_concat then Some BV_CONCAT else None); ] |> filter_none |> scaled_finite let ints : int enum = fun i -> IFSeq.up (~-i + 1) i let uints : int enum = fun i -> IFSeq.up 0 i let nuints : int enum = fun i -> if i > 0 then IFSeq.up 1 i else IFSeq.empty let literals : literal enum = let l_ints = map (fun i -> L_Int (Z.of_int i)) ints and l_bools = finite [ L_Bool true; L_Bool false ] and l_reals = map (fun (i, j) -> L_Real Q.(i // j)) (uints ** nuints) and l_bvs = map (fun s -> L_BitVector (Bitvector.of_string ("'" ^ s ^ "'"))) (fix (fun ss -> just "" ++ map (( ^ ) "0") ss ++ map (( ^ ) "1") ss)) and l_strings = finite [ L_String "This is a string"; L_String "This is another string" ] in [ (if C.Syntax.l_int then Some l_ints else None); (if C.Syntax.l_bool then Some l_bools else None); (if C.Syntax.l_real then Some l_reals else None); (if C.Syntax.l_bitvector then Some l_bvs else None); (if C.Syntax.l_string then Some l_strings else None); ] |> filter_none |> oneof let _make_vari i = "x" ^ string_of_int i let vars : identifier enum = finite [ "x"; "y" ] ++ pay (map _make_vari uints) let char_names = '_' :: List.init 26 Char.(fun i -> i + code 'a' |> chr) let list1 enum = enum ** list enum |> map (fun (x, xs) -> x :: xs) |> pay let list2 enum = (enum ** enum) ** list enum |> map (fun ((x, y), xs) -> x :: y :: xs) |> pay |> pay let names : identifier enum = let make li = li |> List.to_seq |> String.of_seq in list1 (scaled_finite char_names) |> map make let non_rec_ty = let t_string = just T_String and t_bool = just T_Bool and t_real = just T_Real in oneof [ t_string; t_bool; t_real ] let t_named s = T_Named s |> annot let slices exprs : slice list enum = let slice_single = let make_slice_single e = Slice_Single e in exprs |> map make_slice_single and slice_range = let make_slice_range (e1, e2) = Slice_Range (e1, e2) in exprs ** exprs |> map make_slice_range and slice_length = let make_slice_length (e1, e2) = Slice_Length (e1, e2) in exprs ** exprs |> map make_slice_length and slice_star = let make_slice_star (e1, e2) = Slice_Star (e1, e2) in exprs ** exprs |> map make_slice_star in [ (if C.Syntax.slice_single then Some slice_single else None); (if C.Syntax.slice_range then Some slice_range else None); (if C.Syntax.slice_length then Some slice_length else None); (if C.Syntax.slice_star then Some slice_star else None); ] |> filter_none |> oneof |> list1 let exprs : expr enum = fix @@ fun exprs -> let e_unops = let make_unop (op, expr) = E_Unop (op, expr) in unops ** exprs |> map make_unop and e_ctc = let make_e_ctc (e, s) = E_ATC (e, t_named s) in exprs ** names |> map make_e_ctc and e_binops = let make_binop (op, (e1, e2)) = E_Binop (op, e1, e2) in binops ** exprs ** exprs |> map make_binop and e_literals = let make_literal v = E_Literal v in literals |> map make_literal and e_vars = let make_var s = E_Var s in vars |> map make_var and e_conds = let make_cond (e1, (e2, e3)) = E_Cond (e1, e2, e3) in exprs ** exprs ** exprs |> map make_cond and e_slices = let make_slices (e, slices) = E_Slice (e, slices) in exprs ** slices exprs |> map make_slices and e_call = let make_e_call (name, args) = E_Call { name; args; params = []; call_type = ST_Function } in names ** list exprs |> map make_e_call and e_get_array = let make_e_get_array (e1, e2) = E_GetArray (e1, e2) in exprs ** exprs |> map make_e_get_array and e_get_field = let make_e_get_field (e, name) = E_GetField (e, name) in exprs ** names |> map make_e_get_field and e_get_fields = let make_e_get_fields (e, names) = E_GetFields (e, names) in exprs ** list2 names |> map make_e_get_fields and e_record = let make_record (name, fields) = E_Record (t_named name, fields) in names ** list (names ** exprs) |> map make_record and e_tuple = let make_tuple es = E_Tuple es in list2 exprs |> map make_tuple and e_arbitrary = let make_arbitrary name = E_Arbitrary (t_named name) in names |> map make_arbitrary and e_pattern = empty (* TODO *) in [ (if C.Syntax.e_unop then Some e_unops else None); (if C.Syntax.e_binop then Some e_binops else None); (if C.Syntax.e_literal then Some e_literals else None); (if C.Syntax.e_var then Some e_vars else None); (if C.Syntax.e_cond then Some e_conds else None); (if C.Syntax.e_slice then Some e_slices else None); (if C.Syntax.e_ctc then Some e_ctc else None); (if C.Syntax.e_call then Some e_call else None); (if C.Syntax.e_getarray then Some e_get_array else None); (if C.Syntax.e_getfield then Some e_get_field else None); (if C.Syntax.e_getfields then Some e_get_fields else None); (if C.Syntax.e_record then Some e_record else None); (if C.Syntax.e_tuple then Some e_tuple else None); (if C.Syntax.e_arbitrary then Some e_arbitrary else None); (if C.Syntax.e_pattern then Some e_pattern else None); ] |> filter_none |> oneof |> map annot let slices = slices exprs let tys = fix @@ fun tys -> let t_string = just T_String and t_bool = just T_Bool and t_real = just T_Real and t_integer = let make_t_integer cs = T_Int (WellConstrained cs) in let cntt_range = let make_cntt_range (e1, e2) = Constraint_Range (e1, e2) in exprs ** exprs |> map make_cntt_range and cntt_single = let make_cntt_single e = Constraint_Exact e in exprs |> map make_cntt_single in just (T_Int UnConstrained) ++ (list1 (cntt_range ++ cntt_single) |> map make_t_integer) and t_tuple = let make_t_tuple li = T_Tuple li in list2 tys |> map make_t_tuple and t_record = let make_t_record li = T_Record li in names ** tys |> list |> map make_t_record and t_bits = let make_t_bits e = T_Bits (e, []) in exprs |> map make_t_bits |> pay and t_enum = let make_t_enum ss = T_Enum ss in nonempty_list names |> map make_t_enum and t_named = let make_t_named s = T_Named s in names |> map make_t_named in [ (if C.Syntax.t_int then Some t_integer else None); (if C.Syntax.t_string then Some t_string else None); (if C.Syntax.t_bool then Some t_bool else None); (if C.Syntax.t_real then Some t_real else None); (if C.Syntax.t_bits then Some t_bits else None); (if C.Syntax.t_tuple then Some t_tuple else None); (if C.Syntax.t_record then Some t_record else None); (if C.Syntax.t_named then Some t_named else None); (if C.Syntax.t_enum then Some t_enum else None); ] |> filter_none |> oneof |> map annot let lexprs : lexpr enum = fix @@ fun lexprs -> let le_vars = let make_var s = LE_Var s in vars |> map make_var and le_ignore = just LE_Discard and le_fields = let make_le_field (le, s) = LE_SetFields (le, s, []) in lexprs ** list2 names |> map make_le_field and le_field = let make_le_field (le, s) = LE_SetField (le, s) in lexprs ** names |> map make_le_field and le_destructuring = let make_destructuring les = LE_Destructuring les in list2 lexprs |> map make_destructuring and le_set_array = let make_le_set_array (le, e) = LE_SetArray (le, e) in lexprs ** exprs |> map make_le_set_array and le_slices = let make_le_slices (le, slices) = LE_Slice (le, slices) in lexprs ** slices |> map make_le_slices in [ (if C.Syntax.le_var then Some le_vars else None); (if C.Syntax.le_discard then Some le_ignore else None); (if C.Syntax.le_setfield then Some le_field else None); (if C.Syntax.le_setfields then Some le_fields else None); (if C.Syntax.le_destructuring then Some le_destructuring else None); (if C.Syntax.le_setarray then Some le_set_array else None); (if C.Syntax.le_slice then Some le_slices else None); ] |> filter_none |> oneof |> map annot let ldks = scaled_finite [ LDK_Constant; LDK_Var; LDK_Let ] let ldis = let ldi_var = let make_ldi_var s = LDI_Var s in vars |> map make_ldi_var and ldi_tuple = let make_ldi_tuple ldis = LDI_Tuple ldis in list2 names |> map make_ldi_tuple in [ (if C.Syntax.ldi_var then Some ldi_var else None); (if C.Syntax.ldi_tuple then Some ldi_tuple else None); ] |> filter_none |> oneof let stmt_lists (stmts : stmt enum) : stmt enum = list stmts |> map ASTUtils.stmt_from_list let _make_mains_of_stmts = let make_main stmt = let name = "main" and args = [] and parameters = [] and subprogram_type = ST_Function and body = SB_ASL stmt and recurse_limit = None and return_type = Some ASTUtils.integer in [ D_Func { body; name; args; parameters; return_type; subprogram_type; recurse_limit; builtin = false; } |> annot; ] in map make_main let stmts : stmt enum = fix @@ fun stmts -> let block = stmt_lists stmts in let s_assigns = let make_assign (le, e) = S_Assign (le, e) in lexprs ** exprs |> map make_assign and s_conds = let make_cond (e, (s1, s2)) = S_Cond (e, s1, s2) in exprs ** block ** block |> map make_cond and s_assert = let make_assert e = S_Assert e in exprs |> map make_assert and s_call = let make_s_call (name, args) = S_Call { name; args; params = []; call_type = ST_Procedure } in names ** list exprs |> map make_s_call and s_return = let make_s_return expr = S_Return expr in option exprs |> map make_s_return and s_decl = let make_s_decl (ldk, (ldi, (ty_opt, expr_opt))) = S_Decl (ldk, ldi, ty_opt, expr_opt) in ldks ** ldis ** option tys ** option exprs |> map make_s_decl and s_for = let make_s_for (index_name, (start_e, (dir, (end_e, body)))) = S_For { index_name; start_e; dir; end_e; body; limit = None } in names ** exprs ** finite [ Up; Down ] ** exprs ** block |> map make_s_for and s_while = let make_s_while (e, s) = S_While (e, None, s) in exprs ** block |> map make_s_while |> pay and s_repeat = let make_s_repeat (s, e) = S_Repeat (s, e, None) in block ** exprs |> map make_s_repeat |> pay and s_throw = let make_s_throw opt = S_Throw opt in option (exprs ** option tys) |> map make_s_throw |> pay and s_try = let make_s_try (s, (catchers, s_opt)) = S_Try (s, catchers, s_opt) in let catcher = tuple3 (option names) tys block in block ** list catcher ** option block |> map make_s_try |> pay in [ (if C.Syntax.s_assign then Some s_assigns else None); (if C.Syntax.s_cond then Some s_conds else None); (if C.Syntax.s_call then Some s_call else None); (if C.Syntax.s_assert then Some s_assert else None); (if C.Syntax.s_return then Some s_return else None); (if C.Syntax.s_decl then Some s_decl else None); (if C.Syntax.s_for then Some s_for else None); (if C.Syntax.s_while then Some s_while else None); (if C.Syntax.s_repeat then Some s_repeat else None); (if C.Syntax.s_throw then Some s_throw else None); (if C.Syntax.s_try then Some s_try else None); ] |> filter_none |> oneof |> map annot let mains : AST.t enum = _make_mains_of_stmts (stmt_lists stmts) let no_double_none a b = let a = pay (map Option.some a) and b = pay (map Option.some b) in (a ** b) ++ (a ** just None) ++ (just None ** b) let gdks = scaled_finite [ GDK_Config; GDK_Let; GDK_Constant; GDK_Var ] let decls = let d_func = let make_func (name, (body, (return_type, (args, subprogram_type)))) = let parameters = [] and body = SB_ASL body and recurse_limit = None in D_Func { name; parameters; args; body; return_type; subprogram_type; recurse_limit; builtin = false; } in let args = vars ** tys in let subpgm_types = let setters = nonempty_list args ** just ST_Setter in let with_args typ = list args ** just typ in [ payn 3 setters; payn 2 (with_args ST_Getter); pay (with_args ST_Procedure); with_args ST_Function; ] |> oneof in names ** stmt_lists stmts ** option tys ** subpgm_types |> map make_func and d_global_storage = let make_global_decl (keyword, (name, (ty, initial_value))) = D_GlobalStorage { keyword; name; ty; initial_value } in gdks ** vars ** no_double_none tys exprs |> map make_global_decl and d_type_decl = let make_type_decl (name, ty) = D_TypeDecl (name, ty, None) in names ** tys |> map make_type_decl in d_func ++ d_global_storage ++ d_type_decl |> map annot let asts = list decls end herd-herdtools7-1ca343e/asllib/carpenter/BInterp.ml000066400000000000000000000145771475314470400223060ustar00rootroot00000000000000(****************************************************************************************************************) (* SPDX-FileCopyrightText: Copyright 2022-2024 Arm Limited and/or its affiliates *) (* SPDX-License-Identifier: BSD-3-Clause *) (****************************************************************************************************************) type binterp_interface = { binterp_in : out_channel; binterp_out : in_channel; base_pickled : string; pid : int; } (* Triggers character level stderr logging - to use with caution. *) let _dbg = false let _log_src = Logs.Src.create ~doc:"BInterp Ex Runner for carpenter" "carpenter.binterp" let debug logs = Logs.debug ~src:_log_src logs let info logs = Logs.info ~src:_log_src logs let exception_regex = Re.compile Re.( seq [ bol; alt [ str "Syntax error"; str "Exception"; seq [ rep any; str "error" ]; ]; rep space; rep any; stop; ]) let parse_output output_std = match Re.Seq.matches exception_regex output_std () with | Seq.Nil -> debug (fun m -> m "Output did not match regex."); Ok () | Seq.Cons (h, _) -> debug (fun m -> m "Output matched regex."); Error h let until_prompt = let rec loop iter in_channel = match input_char in_channel with | '\n' -> on_new_line iter in_channel | c -> iter c; loop iter in_channel and on_new_line iter in_channel = match input_char in_channel with | '>' -> on_chevron iter in_channel | c -> iter '\n'; iter c; loop iter in_channel and on_chevron iter in_channel = match input_char in_channel with | ' ' -> () | c -> iter '\n'; iter '>'; iter c; loop iter in_channel and entry_point iter in_channel = match input_char in_channel with | '>' -> on_chevron iter in_channel | c -> iter c; loop iter in_channel in fun iter in_channel -> if _dbg then Printf.eprintf "Waiting for prompt ...\n%!"; try entry_point iter in_channel with End_of_file -> () let get_until_prompt state = if _dbg then Printf.eprintf "Getting output: \"%!"; let buf = Buffer.create 16 in let iter c = Buffer.add_char buf c in let iter = if _dbg then (fun c -> Printf.eprintf "%c%!" c; iter c) else iter in until_prompt iter state.binterp_out; if _dbg then Printf.eprintf "\".\n%!"; Buffer.contents buf let ignore_until_prompt state = if _dbg then Printf.eprintf "Ignoring output: \"%!"; let iter = if _dbg then fun c -> Printf.eprintf "%c%!" c else fun _c -> () in until_prompt iter state.binterp_out; if _dbg then Printf.eprintf "\".\n%!" let run_command state cmd = debug (fun m -> m "Running command %S" cmd); let oc = state.binterp_in in output_string oc cmd; output_char oc '\n'; flush oc; () let run_command_and_ignore state cmd = run_command state cmd; ignore_until_prompt state; () let run_command_and_get_output state cmd = run_command state cmd; let output = get_until_prompt state in debug (fun m -> m "Got output from command: %S." output); output let run_commands_and_ignore state cmds = List.iter (run_command_and_ignore state) cmds let prepare_binterp_state state = info (fun m -> m "Start preparing BInterp initial state."); ignore_until_prompt state; run_commands_and_ignore state [ ":set asl=1.0"; ":pickle " ^ state.base_pickled ]; info (fun m -> m "Finished preparing BInterp initial state."); () let reset_binterp_state state = debug (fun m -> m "Start resetting BInterp state."); run_commands_and_ignore state [ ":reset"; ":unpickle " ^ state.base_pickled ]; debug (fun m -> m "Finished resetting BInterp state."); () let quit_binterp state () = info (fun m -> m "Start quitting BInterp."); debug (fun m -> m "Removing %s" state.base_pickled); Sys.remove state.base_pickled; run_command state ":quit"; debug (fun m -> m "Waiting for BInterp to quit."); let _pid', _status = UnixLabels.waitpid ~mode:[] state.pid in debug (fun m -> m "BInterp quitted. Removing pipes."); close_out state.binterp_in; close_in state.binterp_out; info (fun m -> m "BInterp quitted."); () let create_binterp binterp_path = info (fun m -> m "Spawning new BInterp thread from %s." binterp_path); let base_pickled = Filename.temp_file "binterp-base-state" ".tmp" in debug (fun m -> m "BInterp initial state will be pickled at %s." base_pickled); let open UnixLabels in let stdin, binterp_in = let i, o = pipe () in (i, out_channel_of_descr o) and stdout, stderr, binterp_out = let i, o = pipe () in (o, dup o, in_channel_of_descr i) and prog = binterp_path and args = [||] in let pid = create_process ~prog ~args ~stdin ~stdout ~stderr in info (fun m -> m "BInterp process spawned."); debug (fun m -> m "BInterp thread spawned with PID %d." pid); { binterp_out; binterp_in; base_pickled; pid } let with_binterp binterp_path f = let state = create_binterp binterp_path in Fun.protect ~finally:(quit_binterp state) @@ fun () -> prepare_binterp_state state; f state let run_one state type_only asl_file = debug (fun m -> m "BInterp loading file at %s." asl_file); let output = run_command_and_get_output state (":load " ^ asl_file) in let parsed_output = parse_output output in match (type_only, parsed_output) with | true, _ | _, Error _ -> debug (fun m -> if type_only then m "BInterp loaded file." else m "Error while type-checking. BInterp runner will not execute this \ file."); reset_binterp_state state; parsed_output | false, Ok () -> debug (fun m -> m "File type-checked successfully, running it."); let output = run_command_and_get_output state "assert main () == 0; print(\"\\\\n\");" in debug (fun m -> m "File ran."); reset_binterp_state state; parse_output output let run_one_ast state type_only ast = let asl_file, out = Filename.open_temp_file "gen-ast" ".asl" in debug (fun m -> m "Writing ast at %s" asl_file); let fmt = Format.formatter_of_out_channel out in Asllib.PP.pp_t fmt ast; Format.pp_print_flush fmt (); close_out out; debug (fun m -> m "Done."); run_one state type_only asl_file herd-herdtools7-1ca343e/asllib/carpenter/README.md000066400000000000000000000025761475314470400216640ustar00rootroot00000000000000# ASL Carpenter Carpenter is an AST generator for ASL, working in two different modes: 1. Enumeration of all ASTs by increasing size; 2. Random generation of ASTs following type-checking constraints. Both modes support constraints on syntax nodes available, and on execution or type-checking rules used by ASLRef to execute it. It can also serve as a fuzzing tool, or a mass execution tool. ## Installation Dependencies: ```bash opam install dune menhir qcheck zarith re feat fix cmdliner logs ``` Then: ```bash dune build asllib/carpenter ``` ## Usage See `dune exec carpenter -- --help` for a detailed view of options. Generating 10 tests and writing them in the `tmp` directory (which is supposed to exist): ```bash dune exec carpenter -- generate random -o tmp --small 10 ``` Executing them: ```bash dune exec carpenter -- execute $(find tmp -name "$(date +"%Y-%m-%dT%H")*.asl") ``` This should print a list of results for each file, for example: ``` // results for file: tmp/2024-03-19T10:51:29-0000.asl Error: ASL Error: Mismatched use of return value from call to 'main' // end of results for file: tmp/2024-03-19T10:51:29-0000.asl ... ``` Fuzzing ASLRef on itself on 1000 tests: ```bash dune exec carpenter -- fuzz enum -o tmp 1000 ``` If this does not print anything and returns with a normal exit code, everything is fine; otherwise, you've found a bug in carpenter or in ASLRef! herd-herdtools7-1ca343e/asllib/carpenter/RandomAST.ml000066400000000000000000001072511475314470400225230ustar00rootroot00000000000000(****************************************************************************************************************) (* SPDX-FileCopyrightText: Copyright 2022-2024 Arm Limited and/or its affiliates *) (* SPDX-License-Identifier: BSD-3-Clause *) (****************************************************************************************************************) open Asllib open AST open ASTUtils open QCheck2.Gen module SES = SideEffect.SES let _dbg = false let annot desc = ASTUtils.add_dummy_annotation desc type 'a gen = 'a QCheck2.Gen.t type 'a sgen = 'a QCheck2.Gen.sized type env = StaticEnv.env let filter li = List.filter_map Fun.id li let filter_oneof li = filter li |> oneof let filter_oneofl li = filter li |> oneofl let protected_oneofl = function [] -> None | li -> Some (oneofl li) let protected_oneof = function [] -> None | li -> Some (oneof li) let protected_filter_oneofl li = filter li |> protected_oneofl let protected_filter_oneof li = filter li |> protected_oneof let names = string_size ~gen:(char_range 'a' 'z') (1 -- 20) let pay n = if n <= 0 then 0 else n - 1 let rec ensure_satisfies p t = let* v = t in if p v then return v else ensure_satisfies p t let bind f t = t >>= f let mapo f t = Option.map (map f) t let ( >|== ) t f = mapo f t let ( let** ) t f = Option.map (bind f) t module Untyped (C : Config.S) = struct let unop : unop gen option = [ (if C.Syntax.neg then Some NEG else None); (if C.Syntax.not then Some NOT else None); (if C.Syntax.bnot then Some BNOT else None); ] |> protected_filter_oneofl let binop : binop gen option = [ (if C.Syntax.plus then Some PLUS else None); (if C.Syntax.and_ then Some AND else None); (if C.Syntax.band then Some BAND else None); (if C.Syntax.beq then Some BEQ else None); (if C.Syntax.bor then Some BOR else None); (if C.Syntax.div then Some DIV else None); (if C.Syntax.divrm then Some DIVRM else None); (if C.Syntax.eor then Some EOR else None); (if C.Syntax.eq_op then Some EQ_OP else None); (if C.Syntax.gt then Some GT else None); (if C.Syntax.geq then Some GEQ else None); (if C.Syntax.impl then Some IMPL else None); (if C.Syntax.lt then Some LT else None); (if C.Syntax.leq then Some LEQ else None); (if C.Syntax.mod_ then Some MOD else None); (if C.Syntax.minus then Some MINUS else None); (if C.Syntax.mul then Some MUL else None); (if C.Syntax.neq then Some NEQ else None); (if C.Syntax.or_ then Some OR else None); (if C.Syntax.pow then Some POW else None); (if C.Syntax.rdiv then Some RDIV else None); (if C.Syntax.shl then Some SHL else None); (if C.Syntax.shr then Some SHR else None); (if C.Syntax.bv_concat then Some BV_CONCAT else None); ] |> protected_filter_oneofl let literal : literal gen option = let l_int = small_nat >|= fun i -> L_Int (Z.of_int i) and l_bool = bool >|= fun b -> L_Bool b and l_real = float >|= fun r -> L_Real (Q.of_float r) and l_bv = let bit = oneofa [| '0'; '1' |] in string_of bit >|= fun s -> L_BitVector (Bitvector.of_string ("'" ^ s ^ "'")) and l_string = string_small_of printable >|= fun s -> L_String s in [ (if C.Syntax.l_int then Some l_int else None); (if C.Syntax.l_bool then Some l_bool else None); (if C.Syntax.l_bitvector then Some l_bv else None); (if C.Syntax.l_real then Some l_real else None); (if C.Syntax.l_string then Some l_string else None); ] |> protected_filter_oneof let ty_basic = let t_bool = T_Bool |> annot |> pure and t_integer = T_Int UnConstrained |> annot |> pure and t_real = T_Real |> annot |> pure and t_string = T_String |> annot |> pure and t_named = let+ name = names in T_Named name |> annot in [ (if C.Syntax.t_bool then Some t_bool else None); (if C.Syntax.t_int then Some t_integer else None); (if C.Syntax.t_real then Some t_real else None); (if C.Syntax.t_named then Some t_named else None); (if C.Syntax.t_string then Some t_string else None); ] |> protected_filter_oneof let slices expr = let slice_single n = let+ e = expr n in Slice_Single e and slice_range n = let* n1, n2 = Nat.split2 n in let+ e1 = expr n1 and+ e2 = expr n2 in Slice_Range (e1, e2) and slice_length n = let* n1, n2 = Nat.split2 n in let+ e1 = expr n1 and+ e2 = expr n2 in Slice_Length (e1, e2) and slice_star n = let* n1, n2 = Nat.split2 n in let+ e1 = expr n1 and+ e2 = expr n2 in Slice_Star (e1, e2) in let slice n = [ (if C.Syntax.slice_single then Some (slice_single n) else None); (if C.Syntax.slice_range then Some (slice_range n) else None); (if C.Syntax.slice_length then Some (slice_length n) else None); (if C.Syntax.slice_star then Some (slice_star n) else None); ] |> filter_oneof in fun n -> if n >= 1 then Nat.list_sized slice (n - 1) else slice_single n >|= fun x -> [ x ] let expr : expr sgen = let e_literal = literal >|== fun l -> E_Literal l |> annot in let e_var = names >|= fun s -> E_Var s |> annot in let e_tuple expr n = Nat.list_sized expr n >|= fun li -> E_Tuple li |> annot and e_binop expr n = let** op = binop in let* n1, n2 = Nat.split2 n in let+ e1 = expr n1 and+ e2 = expr n2 in E_Binop (op, e1, e2) |> annot and e_unop expr n = let** op = unop in let+ e = expr n in E_Unop (op, e) |> annot and e_cond expr n = let* n1, n2, n3 = Nat.split3 n in let+ e1 = expr n1 and+ e2 = expr n2 and+ e3 = expr n3 in E_Cond (e1, e2, e3) |> annot and e_slice expr n = let* n1, n2 = Nat.split2 n in let+ e = expr n1 and+ slices = slices expr n2 in E_Slice (e, slices) |> annot in fix @@ fun expr n -> let n = pay n in [ (if C.Syntax.e_literal then e_literal else None); (if C.Syntax.e_var then Some e_var else None); (if C.Syntax.e_unop && n >= 0 then e_unop expr n else None); (if C.Syntax.e_binop && n >= 2 then e_binop expr n else None); (if C.Syntax.e_tuple && n >= 2 then Some (e_tuple expr n) else None); (if C.Syntax.e_cond && n >= 3 then Some (e_cond expr n) else None); (if C.Syntax.e_slice && n >= 1 then Some (e_slice expr n) else None); ] |> filter |> function | [] -> failwith "cannot construct expressions" | li -> oneof li let slices n = slices expr n let ctnt : int_constraint sgen option = let exact n = let+ e = expr n in Constraint_Exact e and range n = let* n1, n2 = Nat.split2 n in let+ e1 = expr n1 and+ e2 = expr n2 in Constraint_Range (e1, e2) in [ (if C.Syntax.constraint_exact then Some exact else None); (if C.Syntax.constraint_range then Some range else None); ] |> filter |> function | [] -> None | li -> Some (fun n -> let n = pay n in List.map (fun sgen -> sgen n) li |> oneof) let ty : ty sgen = let field ty n = pair names (ty n) in let fields ty n = Nat.list_sized (field ty) n in let t_tuple ty n = let+ li = Nat.list_sized ty n in T_Tuple li |> annot and t_record ty n = let+ li = fields ty n in T_Record li |> annot and t_exception ty n = let+ li = fields ty n in T_Exception li |> annot and t_enum n = let+ names = list_repeat n names in T_Enum names |> annot and t_int n = Fun.flip Option.map ctnt @@ fun ctnt -> let+ ctnts = Nat.list_sized ctnt n in T_Int (WellConstrained ctnts) |> annot and t_bits n = let+ width = expr n and+ bitfields = pure [] (* TODO *) in T_Bits (width, bitfields) |> annot in fix @@ fun ty n -> let n = pay n in [ ty_basic; (if C.Syntax.t_int && n >= 1 then t_int n else None); (if C.Syntax.t_bits then Some (t_bits n) else None); (if C.Syntax.t_record && n >= 2 then Some (t_record ty n) else None); (if C.Syntax.t_enum && n >= 2 then Some (t_enum n) else None); (if C.Syntax.t_tuple && n >= 2 then Some (t_tuple ty n) else None); (if C.Syntax.t_exception && n >= 2 then Some (t_exception ty n) else None); ] |> function | [] -> failwith "cannot construct types" | li -> filter_oneof li let ldi : local_decl_item sgen = let ldi_var = let+ name = names in LDI_Var name and ldi_tuple n = let+ names = list_repeat n names in LDI_Tuple names in fun n -> let n = pay n in [ (if C.Syntax.ldi_var then Some ldi_var else None); (if C.Syntax.ldi_tuple && n >= 2 then Some (ldi_tuple n) else None); ] |> filter_oneof let ldk = oneofa [| LDK_Var; LDK_Constant; LDK_Let |] let lexpr : lexpr sgen = let le_ignore = LE_Discard |> annot |> pure and le_var = names >|= fun s -> LE_Var s |> annot and le_set_field lexpr n = let+ le = lexpr n and+ name = names in LE_SetField (le, name) |> annot and le_set_fields lexpr n = let* n1, n2 = Nat.split2 n in let+ le = lexpr n1 and+ names = list_repeat n2 names in LE_SetFields (le, names, []) |> annot and le_destructuring lexpr n = let+ les = Nat.list_sized lexpr n in LE_Destructuring les |> annot and le_slice lexpr n = let* n1, n2 = Nat.split2 n in let+ le = lexpr n1 and+ slices = slices n2 in LE_Slice (le, slices) |> annot and le_setarray lexpr n = let* n1, n2 = Nat.split2 n in let+ le = lexpr n1 and+ e = expr n2 in LE_SetArray (le, e) |> annot in fix @@ fun lexpr n -> let n = pay n in [ (if C.Syntax.le_discard then Some le_ignore else None); (if C.Syntax.le_var then Some le_var else None); (if C.Syntax.le_setfield then Some (le_set_field lexpr n) else None); (if C.Syntax.le_setfields && n >= 2 then Some (le_set_fields lexpr n) else None); (if C.Syntax.le_destructuring && n >= 1 then Some (le_destructuring lexpr n) else None); (if C.Syntax.le_slice && n >= 1 then Some (le_slice lexpr n) else None); (if C.Syntax.le_setarray && n >= 1 then Some (le_setarray lexpr n) else None); ] |> filter_oneof let stmt : stmt sgen = let s_block stmt n = Nat.list_sized stmt n >|= ASTUtils.stmt_from_list in let s_cond stmt n = let* n1, n2, n3 = Nat.split3 n in let+ e1 = expr n1 and+ s2 = s_block stmt n2 and+ s3 = s_block stmt n3 in S_Cond (e1, s2, s3) |> annot in let s_decl n = let* n1, n2, n3 = Nat.split3 n in let+ e = expr n1 |> option and+ ldi = ldi n2 and+ ty = ty n3 |> option and+ ldk = ldk in S_Decl (ldk, ldi, ty, e) |> annot in let s_assert n = let+ e = expr n in S_Assert e |> annot in let s_assign n = let* n1, n2 = Nat.split2 n in let+ le = lexpr n1 and+ e = expr n2 in S_Assign (le, e) |> annot in fix @@ fun stmt n -> let n = pay n in [ (if C.Syntax.s_assert then Some (s_assert n) else None); (if C.Syntax.s_cond && n >= 2 then Some (s_cond stmt n) else None); (if C.Syntax.s_decl && n >= 3 then Some (s_decl n) else None); (if C.Syntax.s_assign && n >= 2 then Some (s_assign n) else None); ] |> filter_oneof let gdk = oneofa [| GDK_Constant; GDK_Config; GDK_Let; GDK_Var |] let subprogram_type = oneofa [| ST_Procedure; ST_Function; ST_Getter; ST_Setter |] let decl : decl sgen = let type_decl n = let+ ty = ty n and+ name = names in D_TypeDecl (name, ty, None) |> annot and global_decl n = let* n1, n2 = Nat.split2 n in let+ name = names and+ keyword = gdk and+ ty = ty n1 |> option and+ initial_value = expr n2 |> option in D_GlobalStorage { name; keyword; ty; initial_value } |> annot and func n = let* n1, n2, n3 = Nat.split3 n in let parameters = [] and recurse_limit = None in let+ name = names and+ args = Nat.list_sized (fun n -> pair names (ty n)) n1 and+ body = stmt n2 >|= fun s -> SB_ASL s and+ return_type = ty n3 |> option and+ subprogram_type = subprogram_type in D_Func { name; parameters; args; body; return_type; subprogram_type; recurse_limit; builtin = false; } |> annot in fun n -> [ type_decl n ] |> (if n >= 2 then List.cons (global_decl n) else Fun.id) |> (if n >= 3 then List.cons (func n) else Fun.id) |> oneof let ast : AST.t sgen = Nat.list_sized decl end module Typed (C : Config.S) = struct module Untyped = Untyped (C) let can_construct_literal env ty = Types.is_singular env ty let add_with f acc elt = acc + f elt let list_sum ?(init = 0) (f : 'a -> int) (li : 'a list) : int = List.fold_left (add_with f) init li let rec minimal_direct_fuel_ty env ty = let () = if _dbg && true then Format.eprintf "Getting minimal_direct_fuel of %a@." PP.pp_ty ty in match (Types.make_anonymous env ty).desc with | T_Int _ | T_Bool | T_Bits _ | T_Enum _ | T_Real | T_String -> 1 | T_Named _ -> assert false | T_Array _ -> 1000000000 | T_Tuple li -> list_sum ~init:2 (minimal_direct_fuel_ty env) li | T_Record fields | T_Exception fields -> list_sum ~init:2 (fun (_, ty) -> minimal_direct_fuel_ty env ty) fields let literal ty : literal gen = match ty.desc with | T_Named _ -> failwith "Not yet implemented: named types." | T_Int _ -> small_nat >|= fun i -> L_Int (Z.of_int i) | T_Bool -> bool >|= fun b -> L_Bool b | T_Real -> float >|= fun r -> L_Real (Q.of_float (Float.abs r)) | T_String -> string_small_of printable >|= fun s -> L_String s | T_Bits _ -> let+ n = small_nat and+ i = nat in L_BitVector (Bitvector.of_int_sized n i) | _ -> failwith "Cannot construct a literal of this type" let fresh_name env = ensure_satisfies (fun s -> StaticEnv.is_undefined s env) names let t_bits : ty gen = let+ width = small_nat in T_Bits (E_Literal (L_Int (Z.of_int width)) |> annot, []) |> annot let slice expr env n : slice gen = let n = pay n in let* n1, n2 = Nat.split2 n in let int n = expr (env, integer, n) in [ (if C.Syntax.slice_single then Some (int n >|= fun e -> Slice_Single e) else None); (if C.Syntax.slice_range then Some (pair (int n1) (int n2) >|= fun (e1, e2) -> Slice_Range (e1, e2)) else None); (if C.Syntax.slice_range then Some (pair (int n1) (int n2) >|= fun (e1, e2) -> Slice_Length (e1, e2)) else None); (if C.Syntax.slice_range then Some (pair (int n1) (int n2) >|= fun (e1, e2) -> Slice_Star (e1, e2)) else None); ] |> filter_oneof let slices expr env = Nat.list_sized_non_empty (slice expr env) let expr : env -> ty -> expr sgen = let e_literal ty = match ty.desc with | T_Enum li -> oneofl li >|= fun s -> E_Var s |> annot | _ -> literal ty >|= fun l -> E_Literal l |> annot in let e_var env ty = let folder name (t, _) vars = if Types.subtype_satisfies env t ty then (E_Var name |> annot) :: vars else vars in [] |> ASTUtils.IMap.fold folder env.StaticEnv.local.storage_types |> ASTUtils.IMap.fold folder env.StaticEnv.global.storage_types |> protected_oneofl in let e_cond expr env ty n = let min = minimal_direct_fuel_ty env ty in if n <= min * 2 then None else Some (let* n1 = min -- n in let* n2 = min -- (n - min) in let+ e1 = expr (env, ty, n1) and+ e2 = expr (env, ty, n2) and+ e_cond = expr (env, boolean, n - n1 - n2) in E_Cond (e_cond, e1, e2) |> annot) in let e_ctc expr env ty ty_anon n = match ty.desc with | T_Int _ -> Some (let+ e' = expr (env, T_Int UnConstrained |> annot, n) in E_ATC (e', ty) |> annot) | T_Named _ when Types.is_singular env ty_anon -> Some (expr (env, ty_anon, n - 1)) | _ -> None in let e_call expr env ty n = let funcs = ASTUtils.IMap.fold (fun name (func_sig, _) funcs -> match func_sig.return_type with | Some t -> if Types.subtype_satisfies env t ty && List.length func_sig.args <= n then (name, func_sig) :: funcs else funcs | _ -> funcs) env.StaticEnv.global.subprograms [] in let one_func (name, func_sig) = let* arg_sizes = Nat.split ~size:(List.length func_sig.args) n in let+ args = List.map2 (fun (_, ty) n -> expr (env, ty, n)) func_sig.args arg_sizes |> flatten_l in E_Call { name; args; params = []; call_type = ST_Function } |> annot in protected_oneofl funcs |> Option.map (bind one_func) in let can_construct_binop ty = match ty.desc with | T_Int _ | T_Real | T_Bits _ | T_Bool -> true | _ -> false in let e_binop expr env ty n = let* n1, n2 = Nat.split2 n in let* op, t1, t2 = match ty.desc with | T_Int _ -> [| PLUS; MINUS; MUL; DIV; DIVRM; MOD; SHL; SHR; POW |] |> oneofa |> map (fun op -> (op, integer, integer)) | T_Bool -> [ [| BAND; BOR; BEQ; IMPL |] |> oneofa |> map (fun op -> (op, boolean, boolean)); (let+ op = [| EQ_OP; NEQ |] |> oneofa and+ t = [| integer; boolean; real |] |> oneofa in (op, t, t)); (let+ op = [| LEQ; GEQ; GT; LT |] |> oneofa and+ t = [| integer; real |] |> oneofa in (op, t, t)); ] |> oneof | T_Real -> [| PLUS; MINUS; MUL |] |> oneofa |> map (fun op -> (op, real, real)) | T_Bits _ -> [ [| AND; OR; EOR; BV_CONCAT |] |> oneofa |> map (fun op -> (op, ty, ty)); [| PLUS; MINUS |] |> oneofa |> map (fun op -> (op, ty, integer)); ] |> oneof | _ -> assert false in let+ e1 = expr (env, t1, n1) and+ e2 = expr (env, t2, n2) in E_Binop (op, e1, e2) |> annot in let can_construct_unop ty = match ty.desc with | T_Int _ | T_Real | T_Bool | T_Bits _ -> true | _ -> false in let e_unop expr env ty n = let op = match ty.desc with | T_Int _ | T_Real -> NEG | T_Bits _ -> NOT | T_Bool -> BNOT | _ -> assert false in expr (env, ty, n) >|= fun e -> E_Unop (op, e) |> annot in let e_tuple expr env ty n = match ty.desc with | T_Tuple li -> let size = List.length li in if size > n then None else Some (let* sizes = Nat.split ~size n in List.map2 (fun ty n -> expr (env, ty, n)) li sizes |> flatten_l >|= fun li -> E_Tuple li |> annot) | _ -> None in let e_record expr env ty fields n = let* sizes = Nat.split ~size:(List.length fields) n in List.map2 (fun (name, ty) n -> expr (env, ty, n) >|= fun e -> (name, e)) fields sizes |> flatten_l >|= fun fields -> E_Record (ty, fields) |> annot in let e_get_array = (* TODO *) None in let e_get_fields = (* TODO *) None in let e_pattern = (* TODO *) None in let e_arbitrary ty = E_Arbitrary ty |> annot |> pure |> Option.some in let is_bits ty = match ty.desc with T_Bits _ -> true | _ -> false in let e_slices expr env n : expr gen = let* n2 = 1 -- n in let n1 = n - n2 in let+ e' = let* t = t_bits in expr (env, t, n1) and+ slices = slices expr env n2 in E_Slice (e', slices) |> annot in let e_get_field expr env ty n : expr gen option = let field_folder new_ty acc (field_name, field_ty) = if Types.subtype_satisfies env field_ty ty then (let+ e' = expr (env, new_ty, n) in E_GetField (e', field_name) |> annot) :: acc else acc in let type_folder name (ty', _) acc : expr gen list = let ty' = Types.make_anonymous env ty' in match ty'.desc with | T_Record fields | T_Exception fields -> let new_ty = T_Named name |> annot in if minimal_direct_fuel_ty env ty' <= n then List.fold_left (field_folder new_ty) acc fields else acc | _ -> acc in IMap.fold type_folder env.StaticEnv.global.declared_types [] |> function | [] -> None | li -> Some (oneof li) in let expr' = fix @@ fun expr (env, ty, n) -> let () = if _dbg then Printf.eprintf "Generating an expr of size %d\n%!" n in let n = pay n in let ty_anon = Types.make_anonymous env ty in [ (if C.Syntax.e_literal && can_construct_literal env ty_anon then Some (e_literal ty_anon) else None); (if C.Syntax.e_arbitrary then e_arbitrary ty else None); (if C.Syntax.e_getarray then e_get_array else None); (if C.Syntax.e_getfields then e_get_fields else None); (if C.Syntax.e_pattern then e_pattern else None); (if C.Syntax.e_var then e_var env ty else None); (if C.Syntax.e_call then e_call expr env ty n else None); (if C.Syntax.e_binop && n >= 1 && can_construct_binop ty_anon then Some (e_binop expr env ty_anon n) else None); (if C.Syntax.e_unop && can_construct_unop ty_anon then Some (e_unop expr env ty_anon n) else None); (if C.Syntax.e_tuple && n >= 1 then e_tuple expr env ty_anon n else None); (if C.Syntax.e_slice && n >= 1 && is_bits ty_anon then Some (e_slices expr env n) else None); (if C.Syntax.e_ctc then e_ctc expr env ty ty_anon n else None); (if C.Syntax.e_record && n >= 2 then match (ty_anon.desc, ty.desc) with | (T_Record fields | T_Exception fields), T_Named _ when List.length fields <= n -> Some (e_record expr env ty fields n) | _ -> None else None); (if C.Syntax.e_cond && n >= 3 then e_cond expr env ty n else None); (if C.Syntax.e_getfield && n >= 1 then e_get_field expr env ty n else None); ] |> filter |> function | [] -> if _dbg || false then Format.eprintf "@[<2>Cannot construct with fuel %d type@ %a@]@." n PP.pp_ty ty; expr (env, ty, minimal_direct_fuel_ty env ty) | li -> let res = oneof li in let () = if _dbg then Printf.eprintf "Generated expr.\n%!" in res in fun env ty n -> expr' (env, ty, n) let slices = slices (fun (env, ty, n) -> expr env ty n) let fields_maxed ty env ~max n = let* ns = Nat.list_sized_min_no_gen 1 n in let rec loop i max prevs = function | [] -> return prevs | n :: ns -> let* ty = ty (false, env, Some (max + i - n), n) and* name = string in let prevs = (name, ty) :: prevs and max = max - minimal_direct_fuel_ty env ty in loop (succ i) max prevs ns in loop 0 max [] ns let fields_unbounded ty env n = Nat.list_sized_non_empty (fun n -> pair names (ty (false, env, None, n))) n let fields env ty = function | Some max -> fields_maxed ty env ~max | None -> fields_unbounded ty env let ty : bool -> env -> ?max:int -> ty sgen = let t_bool = T_Bool |> annot |> pure and t_integer env max n : ty gen = let cnt_exact = if C.Syntax.constraint_exact then Option.some @@ fun n -> let+ e = expr env integer n in Constraint_Exact e else None and cnt_range = if C.Syntax.constraint_range then Option.some @@ fun n -> let* n1, n2 = Nat.split2 n in let+ e1 = expr env integer n1 and+ e2 = expr env integer n2 in Constraint_Range (e1, e2) else None in let cnt = [ cnt_exact; cnt_range ] |> filter |> function | [] -> None | li -> Some (fun n -> List.map (fun gen -> gen n) li |> oneof) in let cnts = Option.map Nat.list_sized_non_empty cnt in [ Some (T_Int UnConstrained |> annot |> pure); (if n >= 1 && max = None then Fun.flip Option.map cnts @@ fun cnts -> let+ cnts = cnts n in T_Int (WellConstrained cnts) |> annot else None); ] |> filter_oneof and t_real = T_Real |> annot |> pure and t_tuple ty env max n = let+ fields = fields env ty max n in T_Tuple (List.map snd fields) |> annot and t_record ty env max n = let+ fields = fields env ty max n in T_Record fields |> annot and t_exception ty env max n = let+ fields = fields env ty max n in T_Exception fields |> annot and t_enum n = let+ names = list_repeat n names in T_Enum names |> annot and t_named env max = let folder name (ty', _) prevs = let ty = T_Named name |> annot in match max with | None -> ty :: prevs | Some max -> if minimal_direct_fuel_ty env ty' <= max then ty :: prevs else prevs in IMap.fold folder env.StaticEnv.global.declared_types [] |> protected_oneofl and t_array = None (* TODO *) in let ty' = fix @@ fun ty (is_decl, env, max, n) -> let () = if _dbg then Printf.eprintf "Generating ty of size %d\n%!" n in let n = pay n in [ (if C.Syntax.t_bool then Some t_bool else None); (if C.Syntax.t_int then Some (t_integer env max n) else None); (if C.Syntax.t_real then Some t_real else None); (if C.Syntax.t_bits then Some t_bits else None); (if C.Syntax.t_array then t_array else None); (if C.Syntax.t_record && n >= 1 && is_decl then Some (t_record ty env max n) else None); (if C.Syntax.t_exception && n >= 1 && is_decl then Some (t_exception ty env max n) else None); (if C.Syntax.t_enum && n >= 1 && is_decl then Some (t_enum n) else None); (if C.Syntax.t_tuple && n > 2 && is_decl then Some (t_tuple ty env max n) else None); (if C.Syntax.t_named then t_named env max else None); ] |> filter_oneof |> if _dbg then (fun res -> Printf.eprintf "type generated.\n%!"; res) else Fun.id in fun is_decl env ?max n -> ty' (is_decl, env, max, n) let lexpr : env -> ty -> lexpr sgen = let lexpr' = let le_discard = LE_Discard |> annot |> pure and le_var env ty = let folder name (t, _) vars = if Types.subtype_satisfies env t ty then (LE_Var name |> annot) :: vars else vars in [] |> ASTUtils.IMap.fold folder env.StaticEnv.local.storage_types |> ASTUtils.IMap.fold folder env.StaticEnv.global.storage_types |> protected_oneofl and le_tuple lexpr env ty n = match ty.desc with | T_Tuple li -> let size = List.length li in if n < size then None else Some (let* sizes = Nat.split ~size n in List.map2 (fun ty n -> lexpr (env, ty, n)) li sizes |> flatten_l >|= fun li -> LE_Destructuring li |> annot) | _ -> None and le_set_field lexpr env ty n = let field_folder new_ty acc (field_name, field_ty) = if Types.subtype_satisfies env field_ty ty then (let+ le' = lexpr (env, new_ty, n) in LE_SetField (le', field_name) |> annot) :: acc else acc in let type_folder name (ty', _) acc : lexpr gen list = let ty' = Types.make_anonymous env ty' in match ty'.desc with | T_Record fields | T_Exception fields -> let new_ty = T_Named name |> annot in if minimal_direct_fuel_ty env ty' <= n then List.fold_left (field_folder new_ty) acc fields else acc | _ -> acc in IMap.fold type_folder env.StaticEnv.global.declared_types [] |> function | [] -> None | li -> Some (oneof li) and le_slices lexpr env ty n = match ty.desc with | T_Bits _ -> Some (let* n2 = 1 -- n in let n1 = n - n2 in let+ le' = lexpr (env, ty, n1) and+ slices = slices env n2 in LE_Slice (le', slices) |> annot) | _ -> None in fix @@ fun lexpr (env, ty, n) -> let () = if _dbg then Printf.eprintf "Generating lexpr of size %d\n%!" n in let n = pay n in let ty_anon = Types.make_anonymous env ty in [ (if C.Syntax.le_discard then Some le_discard else None); (if C.Syntax.le_var then le_var env ty_anon else None); (if C.Syntax.le_destructuring then le_tuple lexpr env ty_anon n else None); (if C.Syntax.le_setfield && n >= 1 then le_set_field lexpr env ty_anon n else None); (if C.Syntax.le_slice && n >= 1 then le_slices lexpr env ty_anon n else None); ] |> filter_oneof in fun env ty n -> lexpr' (env, ty, n) let stmt : env -> (stmt * env) sgen = let s_block stmt env n = if n <= 0 then pure (S_Pass |> annot, env) else let* n_elements = 1 -- n in let* sizes = Nat.split ~size:n_elements n in let* env, prevs = List.fold_left (fun m n -> let* env, prevs = m in let* s, env = stmt (env, n) in return (env, s :: prevs)) (pure (env, [])) sizes in let s = List.rev prevs |> stmt_from_list in return (s, env) in let s_assert env n = let+ e = expr env boolean n in (S_Assert e |> annot, env) in let s_assign env n = let* n1 = 1 -- (n / 3) in let* ty = ty false env ~max:n1 n1 in let min = minimal_direct_fuel_ty env ty in let* n2 = min -- (n - min) in let n3 = n - n1 - n2 in let+ le = lexpr env ty n2 and+ e = expr env ty n3 in (S_Assign (le, e) |> annot, env) in let s_decl env n = let* n1, n2 = Nat.split2 n in let* ty = ty false env ~max:n2 n1 in let+ e = expr env ty n2 and+ ldk = Untyped.ldk and+ name = fresh_name env in ( S_Decl (ldk, LDI_Var name, Some ty, Some e) |> annot, StaticEnv.add_local name ty ldk env ) in let s_return env n = match env.StaticEnv.local.return_type with | Some t -> let+ e = expr env t n in (S_Return (Some e) |> annot, env) | None -> pure (S_Return None |> annot, env) in let s_cond stmt env n = let* n1, n2, n3 = Nat.split3 n in let+ e1 = expr env boolean n1 and+ s2, _env2 = stmt (env, n2) and+ s3, _env3 = stmt (env, n3) in (S_Cond (e1, s2, s3) |> annot, env) in let stmt' = fix @@ fun stmt (env, n) -> let () = if _dbg then Printf.eprintf "Generating a stmt of size %d\n%!" n in let n = pay n in [ (if C.Syntax.s_decl then Some (s_decl env n) else None); (if C.Syntax.s_assert then Some (s_assert env n) else None); (if C.Syntax.s_return then Some (s_return env n) else None); (if C.Syntax.s_pass then Some (s_block stmt env n) else None); (if C.Syntax.s_assign && n >= 3 then Some (s_assign env n) else None); (if C.Syntax.s_cond && n >= 3 then Some (s_cond stmt env n) else None); ] |> filter_oneof in fun env n -> stmt' (env, n) let decl : env -> (decl * env) sgen = let type_decl env n : (decl * env) gen = let+ ty = ty true env n and+ name = fresh_name env in ( D_TypeDecl (name, ty, None) |> annot, StaticEnv.add_type name ty SideEffect.TimeFrame.Constant env ) and global_decl env n : (decl * env) gen = let* n1, n2 = Nat.split2 n in let* ty = ty false env ~max:n2 n1 in let+ name = fresh_name env and+ keyword = Untyped.gdk and+ initial_value = expr env ty n2 |> option in ( D_GlobalStorage { name; keyword; ty = Some ty; initial_value } |> annot, StaticEnv. { global = add_global_storage name ty keyword env.global; local = env.local; } ) and func env n : (decl * env) gen = let* n2 = int_bound ((n / 2) + 1) in let* n3 = int_bound ((n / 4) + 1) in let n1 = n - n2 - n3 in let parameters = [] and recurse_limit = None in let* return_type = ty false env n3 |> option in let env' = StaticEnv. { global = env.global; local = empty_local_return_type return_type } in let* args, env' = let* n_args = int_bound n2 in let* arg_sizes = Nat.split ~size:n_args n2 in List.fold_left (fun acc n -> let* prevs, env = acc in let+ name = fresh_name env and+ ty = ty false env n in ((name, ty) :: prevs, StaticEnv.add_local name ty LDK_Let env)) (pure ([], env')) arg_sizes in let+ name = names and+ (body : subprogram_body) = stmt env' n1 >|= fun (s, _env') -> SB_ASL s and+ subprogram_type = match return_type with | Some _ -> oneofa [| ST_Function; ST_Getter |] | None -> if List.length args > 0 then oneofa [| ST_Procedure; ST_Setter |] else pure ST_Procedure in let func_sig = { name; parameters; args; body; return_type; subprogram_type; recurse_limit; builtin = false; } in ( D_Func func_sig |> annot, StaticEnv.add_subprogram name func_sig SES.empty env ) in fun env n -> let () = if _dbg then Printf.eprintf "Generating a decl of size %d\n%!" n in let n = pay n in [ type_decl env n ] |> (if n >= 2 then List.cons (global_decl env n) else Fun.id) |> (if n >= 3 then List.cons (func env n) else Fun.id) |> oneof let main = let parameters = [] and args = [] and return_type = Some integer and subprogram_type = ST_Procedure and recurse_limit = None and name = "main" in fun env n -> let n = pay n in let env' = StaticEnv. { global = env.global; local = empty_local_return_type return_type } in let+ body = stmt env' n >|= fun (s, _env') -> SB_ASL s in let func_sig = { name; parameters; args; body; return_type; subprogram_type; recurse_limit; builtin = false; } in D_Func func_sig |> annot let ast : AST.t sgen = function | 0 -> pure [] | n -> let () = if _dbg then Printf.eprintf "Generating ast of size %d\n%!" n in let* n_main = 1 -- ((n + 4) / 5) in let n = n - n_main in let* n_decl = if n = 0 then pure 0 else 1 -- ((n + 4) / 5) in let* sizes = Nat.split ~size:n_decl n in let* decls, env = List.fold_left (fun acc n -> let* prevs, env = acc in let+ d, env = decl env n in (d :: prevs, env)) (return ([], StaticEnv.empty)) sizes in let+ main = main env n_main in let () = if _dbg then Printf.eprintf "Generated ast.\n%!" in List.rev (main :: decls) end herd-herdtools7-1ca343e/asllib/carpenter/comparator.ml000066400000000000000000000053501475314470400230770ustar00rootroot00000000000000(****************************************************************************************************************) (* SPDX-FileCopyrightText: Copyright 2022-2024 Arm Limited and/or its affiliates *) (* SPDX-License-Identifier: BSD-3-Clause *) (****************************************************************************************************************) let _log_src = Logs.Src.create ~doc:"Comparaison between different interpreter results." "carpenter.comparator" let set_log_level = Logs.Src.set_level _log_src let info f = Logs.info ~src:_log_src f let debug f = Logs.debug ~src:_log_src f let get_ref_result ast = let open Asllib in try match Typing.type_and_run ast with | 0, _ -> Ok () | i, _ -> Error ("Bad return code: " ^ string_of_int i) with | Error.ASLException e -> Error (Error.error_to_string e) | e -> let msg = Printf.sprintf "ASLRef failed with uncaught error: %s." (Printexc.to_string e) in failwith msg let get_ref_result_instr = let open Asllib in let open Native in let module B = Instrumentation.SemanticsSingleSetBuffer in let module C : Interpreter.Config = struct let unroll = 0 let error_handling_time = Error.Dynamic module Instr = Instrumentation.SemMake (B) end in let module I = DeterministicInterpreter (C) in fun ast -> B.reset (); let res = try let ast = Builder.with_primitives Native.DeterministicBackend.primitives ast in let ast, static_env = Typing.TypeCheckDefault.type_check_ast ast in match I.run_typed static_env ast with | NV_Literal (L_Int z) when Z.equal z Z.zero -> Ok () | NV_Literal (L_Int z) -> Error ("Bad return code: " ^ Z.to_string z) | _ -> Error "Bad return code (not integer)." with | Error.ASLException e -> Error (Error.error_to_string e) | e -> let msg = Printf.sprintf "ASLRef failed with uncaught error: %s." (Printexc.to_string e) in Error msg in (res, B.get ()) let compare_results ~ref_result ~binterp_result = match (ref_result, binterp_result) with | Ok (), Ok () -> debug (fun m -> m "Executions successful --> probably no mismatch."); true | Error ref_s, Error binterp_s -> debug (fun m -> m "Error comparison between %S and %S. Considered true.\n%!" ref_s binterp_s); true (* TODO *) | _ -> debug (fun m -> m "Result mismatch --> probable discrepancy."); false let compare_with_ref ast binterp_result = let ref_result = get_ref_result ast in compare_results ~ref_result ~binterp_result herd-herdtools7-1ca343e/asllib/carpenter/config.ml000066400000000000000000000362001475314470400221730ustar00rootroot00000000000000(****************************************************************************************************************) (* SPDX-FileCopyrightText: Copyright 2022-2024 Arm Limited and/or its affiliates *) (* SPDX-License-Identifier: BSD-3-Clause *) (****************************************************************************************************************) module type Syntax = sig val bnot : bool val neg : bool val not : bool val and_ : bool val band : bool val beq : bool val bor : bool val div : bool val divrm : bool val eor : bool val eq_op : bool val gt : bool val geq : bool val impl : bool val lt : bool val leq : bool val mod_ : bool val minus : bool val mul : bool val neq : bool val or_ : bool val plus : bool val pow : bool val rdiv : bool val shl : bool val shr : bool val bv_concat : bool val l_int : bool val l_bool : bool val l_real : bool val l_bitvector : bool val l_string : bool val e_literal : bool val e_var : bool val e_ctc : bool val e_binop : bool val e_unop : bool val e_call : bool val e_slice : bool val e_cond : bool val e_getarray : bool val e_getfield : bool val e_getfields : bool val e_record : bool val e_tuple : bool val e_arbitrary : bool val e_pattern : bool val pattern_all : bool val pattern_any : bool val pattern_geq : bool val pattern_leq : bool val pattern_mask : bool val pattern_not : bool val pattern_range : bool val pattern_single : bool val pattern_tuple : bool val slice_single : bool val slice_range : bool val slice_length : bool val slice_star : bool val t_int : bool val t_bits : bool val t_real : bool val t_string : bool val t_bool : bool val t_enum : bool val t_tuple : bool val t_array : bool val t_record : bool val t_exception : bool val t_named : bool val constraint_exact : bool val constraint_range : bool val unconstrained : bool val wellconstrained : bool val underconstrained : bool val bitfield_simple : bool val bitfield_nested : bool val bitfield_type : bool val le_discard : bool val le_var : bool val le_slice : bool val le_setarray : bool val le_setfield : bool val le_setfields : bool val le_destructuring : bool val ldk_var : bool val ldk_let : bool val ldk_constant : bool val ldi_var : bool val ldi_tuple : bool val up : bool val down : bool val s_pass : bool val s_seq : bool val s_decl : bool val s_assign : bool val s_call : bool val s_return : bool val s_cond : bool val s_case : bool val s_assert : bool val s_for : bool val s_while : bool val s_repeat : bool val s_throw : bool val s_try : bool val s_print : bool val st_procedure : bool val st_function : bool val st_getter : bool val st_setter : bool end module type S = sig module Syntax : Syntax end module All : Syntax = struct let bnot = true let neg = true let not = true let and_ = true let band = true let beq = true let bor = true let div = true let divrm = true let eor = true let eq_op = true let gt = true let geq = true let impl = true let lt = true let leq = true let mod_ = true let minus = true let mul = true let neq = true let or_ = true let plus = true let pow = true let rdiv = true let shl = true let shr = true let bv_concat = true let l_int = true let l_bool = true let l_real = true let l_bitvector = true let l_string = true let e_literal = true let e_var = true let e_ctc = true let e_binop = true let e_unop = true let e_call = true let e_slice = true let e_cond = true let e_getarray = true let e_getfield = true let e_getfields = true let e_record = true let e_tuple = true let e_arbitrary = true let e_pattern = true let pattern_all = true let pattern_any = true let pattern_geq = true let pattern_leq = true let pattern_mask = true let pattern_not = true let pattern_range = true let pattern_single = true let pattern_tuple = true let slice_single = true let slice_range = true let slice_length = true let slice_star = true let t_int = true let t_bits = true let t_real = true let t_string = true let t_bool = true let t_enum = true let t_tuple = true let t_array = true let t_record = true let t_exception = true let t_named = true let constraint_exact = true let constraint_range = true let unconstrained = true let wellconstrained = true let underconstrained = true let bitfield_simple = true let bitfield_nested = true let bitfield_type = true let le_discard = true let le_var = true let le_slice = true let le_setarray = true let le_setfield = true let le_setfields = true let le_destructuring = true let ldk_var = true let ldk_let = true let ldk_constant = true let ldi_var = true let ldi_tuple = true let up = true let down = true let s_pass = true let s_seq = true let s_decl = true let s_assign = true let s_call = true let s_return = true let s_cond = true let s_case = true let s_assert = true let s_for = true let s_while = true let s_repeat = true let s_throw = true let s_try = true let s_print = true let st_procedure = true let st_function = true let st_getter = true let st_setter = true end module Stable : Syntax = struct include All let e_arbitrary = false let e_getarray = false let le_setarray = false end let default_config = (module struct module Syntax = Stable end : S) module Parse = struct module Tbl = Hashtbl.Make (String) let default_hashtbl = let tbl : bool Tbl.t = Tbl.create 128 in let () = [ ("bnot", true); ("neg", true); ("not", true); ("and", true); ("band", true); ("beq", true); ("bor", true); ("div", true); ("divrm", true); ("eor", true); ("eq_op", true); ("gt", true); ("geq", true); ("impl", true); ("lt", true); ("leq", true); ("mod", true); ("minus", true); ("mul", true); ("neq", true); ("or", true); ("plus", true); ("pow", true); ("rdiv", true); ("shl", true); ("shr", true); ("bv_concat", true); ("l_int", true); ("l_bool", true); ("l_real", true); ("l_bitvector", true); ("l_string", true); ("e_literal", true); ("e_var", true); ("e_ctc", true); ("e_binop", true); ("e_unop", true); ("e_call", true); ("e_slice", true); ("e_cond", true); ("e_getarray", true); ("e_getfield", true); ("e_getfields", true); ("e_record", true); ("e_tuple", true); ("e_arbitrary", true); ("e_pattern", true); ("pattern_all", true); ("pattern_any", true); ("pattern_geq", true); ("pattern_leq", true); ("pattern_mask", true); ("pattern_not", true); ("pattern_range", true); ("pattern_single", true); ("pattern_tuple", true); ("slice_single", true); ("slice_range", true); ("slice_length", true); ("slice_star", true); ("t_int", true); ("t_bits", true); ("t_real", true); ("t_string", true); ("t_bool", true); ("t_enum", true); ("t_tuple", true); ("t_array", true); ("t_record", true); ("t_exception", true); ("t_named", true); ("constraint_exact", true); ("constraint_range", true); ("unconstrained", true); ("wellconstrained", true); ("underconstrained", true); ("bitfield_simple", true); ("bitfield_nested", true); ("bitfield_type", true); ("le_discard", true); ("le_var", true); ("le_slice", true); ("le_setarray", true); ("le_setfield", true); ("le_setfields", true); ("le_destructuring", true); ("ldk_var", true); ("ldk_let", true); ("ldk_constant", true); ("ldi_var", true); ("ldi_tuple", true); ("up", true); ("down", true); ("s_pass", true); ("s_seq", true); ("s_decl", true); ("s_assign", true); ("s_call", true); ("s_return", true); ("s_cond", true); ("s_case", true); ("s_assert", true); ("s_for", true); ("s_while", true); ("s_repeat", true); ("s_throw", true); ("s_try", true); ("s_print", true); ("st_procedure", true); ("st_function", true); ("st_getter", true); ("st_setter", true); ] |> List.to_seq |> Tbl.add_seq tbl in tbl let of_hashtbl tbl = let module M = struct let bnot = Tbl.find tbl "bnot" let neg = Tbl.find tbl "neg" let not = Tbl.find tbl "not" let and_ = Tbl.find tbl "and" let band = Tbl.find tbl "band" let beq = Tbl.find tbl "beq" let bor = Tbl.find tbl "bor" let div = Tbl.find tbl "div" let divrm = Tbl.find tbl "divrm" let eor = Tbl.find tbl "eor" let eq_op = Tbl.find tbl "eq_op" let gt = Tbl.find tbl "gt" let geq = Tbl.find tbl "geq" let impl = Tbl.find tbl "impl" let lt = Tbl.find tbl "lt" let leq = Tbl.find tbl "leq" let mod_ = Tbl.find tbl "mod" let minus = Tbl.find tbl "minus" let mul = Tbl.find tbl "mul" let neq = Tbl.find tbl "neq" let or_ = Tbl.find tbl "or" let plus = Tbl.find tbl "plus" let pow = Tbl.find tbl "pow" let rdiv = Tbl.find tbl "rdiv" let shl = Tbl.find tbl "shl" let shr = Tbl.find tbl "shr" let bv_concat = Tbl.find tbl "bv_concat" let l_int = Tbl.find tbl "l_int" let l_bool = Tbl.find tbl "l_bool" let l_real = Tbl.find tbl "l_real" let l_bitvector = Tbl.find tbl "l_bitvector" let l_string = Tbl.find tbl "l_string" let e_literal = Tbl.find tbl "e_literal" let e_var = Tbl.find tbl "e_var" let e_ctc = Tbl.find tbl "e_ctc" let e_binop = Tbl.find tbl "e_binop" let e_unop = Tbl.find tbl "e_unop" let e_call = Tbl.find tbl "e_call" let e_slice = Tbl.find tbl "e_slice" let e_cond = Tbl.find tbl "e_cond" let e_getarray = Tbl.find tbl "e_getarray" let e_getfield = Tbl.find tbl "e_getfield" let e_getfields = Tbl.find tbl "e_getfields" let e_record = Tbl.find tbl "e_record" let e_tuple = Tbl.find tbl "e_tuple" let e_arbitrary = Tbl.find tbl "e_arbitrary" let e_pattern = Tbl.find tbl "e_pattern" let pattern_all = Tbl.find tbl "pattern_all" let pattern_any = Tbl.find tbl "pattern_any" let pattern_geq = Tbl.find tbl "pattern_geq" let pattern_leq = Tbl.find tbl "pattern_leq" let pattern_mask = Tbl.find tbl "pattern_mask" let pattern_not = Tbl.find tbl "pattern_not" let pattern_range = Tbl.find tbl "pattern_range" let pattern_single = Tbl.find tbl "pattern_single" let pattern_tuple = Tbl.find tbl "pattern_tuple" let slice_single = Tbl.find tbl "slice_single" let slice_range = Tbl.find tbl "slice_range" let slice_length = Tbl.find tbl "slice_length" let slice_star = Tbl.find tbl "slice_star" let t_int = Tbl.find tbl "t_int" let t_bits = Tbl.find tbl "t_bits" let t_real = Tbl.find tbl "t_real" let t_string = Tbl.find tbl "t_string" let t_bool = Tbl.find tbl "t_bool" let t_enum = Tbl.find tbl "t_enum" let t_tuple = Tbl.find tbl "t_tuple" let t_array = Tbl.find tbl "t_array" let t_record = Tbl.find tbl "t_record" let t_exception = Tbl.find tbl "t_exception" let t_named = Tbl.find tbl "t_named" let constraint_exact = Tbl.find tbl "constraint_exact" let constraint_range = Tbl.find tbl "constraint_range" let unconstrained = Tbl.find tbl "unconstrained" let wellconstrained = Tbl.find tbl "wellconstrained" let underconstrained = Tbl.find tbl "underconstrained" let bitfield_simple = Tbl.find tbl "bitfield_simple" let bitfield_nested = Tbl.find tbl "bitfield_nested" let bitfield_type = Tbl.find tbl "bitfield_type" let le_discard = Tbl.find tbl "le_discard" let le_var = Tbl.find tbl "le_var" let le_slice = Tbl.find tbl "le_slice" let le_setarray = Tbl.find tbl "le_setarray" let le_setfield = Tbl.find tbl "le_setfield" let le_setfields = Tbl.find tbl "le_setfields" let le_destructuring = Tbl.find tbl "le_destructuring" let ldk_var = Tbl.find tbl "ldk_var" let ldk_let = Tbl.find tbl "ldk_let" let ldk_constant = Tbl.find tbl "ldk_constant" let ldi_var = Tbl.find tbl "ldi_var" let ldi_tuple = Tbl.find tbl "ldi_tuple" let up = Tbl.find tbl "up" let down = Tbl.find tbl "down" let s_pass = Tbl.find tbl "s_pass" let s_seq = Tbl.find tbl "s_seq" let s_decl = Tbl.find tbl "s_decl" let s_assign = Tbl.find tbl "s_assign" let s_call = Tbl.find tbl "s_call" let s_return = Tbl.find tbl "s_return" let s_cond = Tbl.find tbl "s_cond" let s_case = Tbl.find tbl "s_case" let s_assert = Tbl.find tbl "s_assert" let s_for = Tbl.find tbl "s_for" let s_while = Tbl.find tbl "s_while" let s_repeat = Tbl.find tbl "s_repeat" let s_throw = Tbl.find tbl "s_throw" let s_try = Tbl.find tbl "s_try" let s_print = Tbl.find tbl "s_print" let st_procedure = Tbl.find tbl "st_procedure" let st_function = Tbl.find tbl "st_function" let st_getter = Tbl.find tbl "st_getter" let st_setter = Tbl.find tbl "st_setter" end in (module struct module Syntax = M end : S) (** [iteri_lines filename cont] calls [cont lineno line] for every line in the file. If [cont lineno line], it interrupts the iteration without any error message. *) let iter_lines filename cont = let chan = Scanf.Scanning.from_file filename in let rec loop () = Scanf.bscanf chan "%l%[^\n]\n" (fun lineno line -> cont (lineno + 1) line); loop () in try loop () with End_of_file -> () let of_file filename = let eprintf = Printf.eprintf in let update_tbl tbl lineno name value = let () = if false then eprintf "Scanned line: %s <-- %B\n" name value in let name = String.lowercase_ascii name in if Tbl.mem tbl name then Tbl.replace tbl name value else eprintf "Ignoring line %d: unknown key %S.\n%!" lineno name in let parse_one_line tbl lineno line = let () = if false then eprintf "Scanned line: %S\n" line in try Scanf.sscanf line "%s %_[=:] %B" (update_tbl tbl lineno) with | Scanf.Scan_failure s -> eprintf "Config file scanning failure at line %d: %s\n%!" lineno s | End_of_file -> if String.length line > 0 then eprintf "Ignoring unparsable line %d: %S\n%!" lineno line in let tbl = Tbl.copy default_hashtbl in if false then eprintf "Scanning config from file %S.\n" filename; iter_lines filename (parse_one_line tbl); if false then eprintf "End parsing.\n"; of_hashtbl tbl end herd-herdtools7-1ca343e/asllib/carpenter/dune000066400000000000000000000005261475314470400212540ustar00rootroot00000000000000(library (name carpenter_lib) (flags (:standard -w -40-42-44-48)) (modules :standard \ main) (optional) (libraries herdtools7.asllib qcheck-core zarith re feat fix logs)) (executable (public_name carpenter) (name main) (flags (:standard -w -40-42-44-48)) (modules main) (optional) (libraries cmdliner carpenter_lib logs.cli)) herd-herdtools7-1ca343e/asllib/carpenter/main.ml000066400000000000000000000366551475314470400216700ustar00rootroot00000000000000(****************************************************************************************************************) (* SPDX-FileCopyrightText: Copyright 2022-2024 Arm Limited and/or its affiliates *) (* SPDX-License-Identifier: BSD-3-Clause *) (****************************************************************************************************************) open Carpenter_lib open Asllib type 'a target = Itself | BInterp of 'a let pp_target fmt = function | Itself -> Format.fprintf fmt "no" | BInterp s -> Format.fprintf fmt "BInterp at %s" s let isatty chan = Unix.descr_of_out_channel chan |> Unix.isatty let progress_frequency = 1 let print_progress should_progress = if should_progress then fun i n -> if i mod progress_frequency == 0 then Printf.eprintf "\r%d/%d%!" i n else () else fun _i _n -> () let hide_progress should_progress () = if should_progress then Printf.eprintf "\r \r%!" let setup_logs lvl = let open Logs in set_level lvl; set_reporter (format_reporter ()); debug (fun m -> m "Logs initialized at level %a" (Format.pp_print_option pp_level) lvl); () let setup_random = let print seed = Printf.printf "SEED: 0x%x\n%!" seed in fun print_seed -> let open Random in function | None -> self_init (); if print_seed then ( let seed = bits64 () |> Int64.to_int in print seed; init seed) | Some seed -> if print_seed then print seed; init seed (* -------------------------------------------------------------------------- Do the real work --------------------------------------------------------------------------*) let print_ast filename ast = Logs.info (fun m -> m "Printing AST in %s" filename); let oc = open_out filename in let fmt = Format.formatter_of_out_channel oc in PP.pp_t fmt ast; Format.pp_print_flush fmt (); close_out oc let filename = let timestamp = let open Unix in let now = localtime (time ()) in Printf.sprintf "%d-%02d-%02dT%02d:%02d:%02d" (1900 + now.tm_year) (now.tm_mon + 1) now.tm_mday now.tm_hour now.tm_min now.tm_sec in fun o i -> Printf.sprintf "%s-%04d.asl" timestamp i |> Filename.concat o let print_one progress o n i ast = print_progress progress i n; print_ast (filename o i) ast let filter_instr = function | Some i -> fun ast -> Logs.debug (fun m -> m "@[Generated AST:@ %a@]" PP.pp_t ast); let _res, used_rules = Comparator.get_ref_result_instr ast in let res = List.mem i used_rules in if not res then Logs.debug (fun m -> m "Did not use rule %a. Ignoring." Instrumentation.SemanticsRule.pp i); res | None -> Fun.const true let random_asts (small : bool) config : AST.t Seq.t = let asts = let module Generator = RandomAST.Typed ((val config : Config.S)) in let open QCheck2.Gen in let sizes = if small then small_nat else nat in sized_size sizes Generator.ast in let gen_one = let rand = Random.State.make_self_init () in fun () -> QCheck2.Gen.generate1 ~rand asts in Seq.forever gen_one let smallests_asts config : AST.t Seq.t = let module IFSeq = Feat.Enum.IFSeq in let module Enums = ASTEnums.Make ((val config : Config.S)) in let asts_of_size n = IFSeq.to_seq (Enums.asts n) Seq.empty in Seq.flat_map asts_of_size (Seq.ints 0) let generalized_generate asts (config, instr, o, progress) n = asts config |> Seq.filter (filter_instr instr) |> Seq.take n |> Seq.iteri (print_one progress o n); hide_progress progress () let generate_enum c = generalized_generate smallests_asts c let generate_random small c = generalized_generate (random_asts small) c let generalized_fuzz (asts : 'a Seq.t) (on_ast : 'a -> AST.t option) progress o n = let do_one (i, counter) ast = print_progress progress i n; match on_ast ast with | None -> (succ i, counter) | Some ast -> Logs.info (fun m -> m "Discrepancy found."); let filename = filename o counter in print_ast filename ast; (succ i, succ counter) in let _i = asts |> Seq.take n |> Seq.fold_left do_one (0, 0) in hide_progress progress () let random_trees config small = let asts = let module Generator = RandomAST.Typed ((val config : Config.S)) in let open QCheck2.Gen in let sizes = if small then small_int else int in sized_size sizes Generator.ast in let gen_one () = QCheck2.Gen.generate_tree asts in Seq.forever gen_one let read_files files = List.to_seq files |> Seq.filter_map (fun file -> try Some (Builder.from_file `ASLv1 file) with _ -> None) let get_ref_result instr ast = match instr with | Some i -> let res, used_rules = Comparator.get_ref_result_instr ast in (res, List.mem i used_rules) | None -> (Comparator.get_ref_result ast, true) let on_ast_itself instr _type_only ast = Logs.debug (fun m -> m "@[Trying a new AST:@ %a@]" PP.pp_t ast); try match get_ref_result instr ast with | _, false -> None | Error msg, true -> if String.starts_with ~prefix:"Uncaught exception" msg then Some ast else None | Ok (), true -> None with _ -> Some ast let on_ast_binterp binterp instr type_only ast = Logs.debug (fun m -> m "Analyzing generated AST with BInterp."); let ref_result, instr_match = match instr with | Some i -> let res, used_rules = Comparator.get_ref_result_instr ast in (res, List.mem i used_rules) | None -> (Comparator.get_ref_result ast, true) in if not instr_match then None else let binterp_result = BInterp.run_one_ast binterp type_only ast in if Comparator.compare_results ~ref_result ~binterp_result then None else Some ast let with_on_ast target f = match target with | Itself -> f on_ast_itself | BInterp binterp_path -> BInterp.with_binterp binterp_path @@ fun binterp -> f (on_ast_binterp binterp) let rec on_ast_tree on_ast ast_tree = let ast = QCheck2.Tree.root ast_tree in match on_ast ast with | None -> None | Some ast1 -> (* Generate all the children *) QCheck2.Tree.children ast_tree |> (* Lazily execute them *) Seq.map (on_ast_tree on_ast) |> (* Append at the end our previous error *) Fun.flip Seq.append (Seq.return (Some ast1)) |> (* Find the first child that has an error. *) Seq.find_map Fun.id let fuzz small (config, instr, type_only, target, o, progress) n = with_on_ast target @@ fun on_ast -> generalized_fuzz (random_asts small config) (on_ast instr type_only) progress o n let bet (config, instr, type_only, target, o, progress) n = with_on_ast target @@ fun on_ast -> generalized_fuzz (smallests_asts config) (on_ast instr type_only) progress o n let quickcheck small (config, instr, type_only, target, o, progress) n = with_on_ast target @@ fun on_ast -> let on_ast = on_ast_tree (on_ast instr type_only) in generalized_fuzz (random_trees config small) on_ast progress o n let fuzz_files (_config, instr, type_only, target, o, progress) files = with_on_ast target @@ fun on_ast -> generalized_fuzz (read_files files) (on_ast instr type_only) progress o (List.length files + 1) let execute () type_only target files = let open Format in let log_result res = printf "%a@\n" (pp_print_result ~ok:(fun f () -> pp_print_string f "ok") ~error:(fun f s -> fprintf f "Error: %s" s)) res in let on_filename run file = printf "// results for file: %s@\n" file; file |> run |> log_result; printf "// end of results for file: %s@\n@\n" file in match target with | Itself -> let on_file file = file |> Asllib.Builder.from_file `ASLv1 |> Comparator.get_ref_result in List.iter (on_filename on_file) files | BInterp binterp_path -> BInterp.with_binterp binterp_path @@ fun binterp -> List.iter (on_filename (BInterp.run_one binterp type_only)) files (* -------------------------------------------------------------------------- Command line interface --------------------------------------------------------------------------*) module Cmd = struct open Cmdliner (* ----------------------------------------------------------------------- *) (* Arguments *) let o = let doc = "Output directory." in let docs = Manpage.s_common_options in Arg.( value & opt dir "." & info [ "o"; "output-dir" ] ~docv:"DIR" ~doc ~docs) let n = let doc = "Number of test to generate." in Arg.(required & pos 0 (some int) None & info [] ~docv:"N" ~doc) let files = let doc = "Files to run." in Arg.(value & pos_all non_dir_file [] & info [] ~docv:"FILES" ~doc) let instr = let doc = "Instrument ASLRef execution and filter-out ASTs that do not need \ $(docv) to execute." and docs = Manpage.s_common_options and docv = "RULE" and parse s = try Ok (Instrumentation.SemanticsRule.of_string s) with Not_found -> Error ("Cannot find instrumentation rule " ^ s) and print = Instrumentation.SemanticsRule.pp in let open Arg in let c = some & conv' ~docv (parse, print) in value & opt c None & info [ "instrument"; "rule" ] ~docs ~docv ~doc let binterp_path = let doc = "Path for the BInterp executable." in let docs = Manpage.s_common_options in let binterp c = let make_binterp s = BInterp s in let parse s = Arg.conv_parser c s |> Result.map make_binterp and print = pp_target in Arg.conv (parse, print) in let open Arg in value & opt (binterp non_dir_file) Itself & info [ "binterp" ] ~docv:"BINTERP" ~doc ~docs let type_only = let doc = "Only test the type-checker and do not run the ASTs." in let docs = Manpage.s_common_options in Arg.(value & flag & info [ "type-only" ] ~doc ~docs) let small = let doc = "Generate ASTs of smaller sizes." in Arg.(value & flag & info [ "small" ] ~doc) let log_level = let docs = Manpage.s_common_options in Logs_cli.level ~docs () let print_seed = let doc = "Print seed before running." in let docs = Manpage.s_common_options in Arg.(value & flag & info [ "print-seed" ] ~doc ~docs) let seed = let doc = "Set seed to $(docv) before running. If absent, uses system-dependant \ random sources (e.g. /dev/urandom if available)." and docs = Manpage.s_common_options and docv = "SEED" in Arg.(value & opt (some int) None & info [ "seed" ] ~doc ~docs ~docv) let config = let doc = "File to parse to set generation properties." and docs = Manpage.s_common_options and docv = "CONFIG_FILE" in Arg.( value & opt (some non_dir_file) None & info [ "c"; "config"; "config-file" ] ~doc ~docs ~docv) let progress = let open Arg in let docv = "PROGRESS" and docs = Manpage.s_common_options in let progress = let doc = "Show a progress number as output. (default to true on a tty)" in (true, info [ "progress" ] ~doc ~docs ~docv) and no_progress = let doc = "Do not show a progress number as output. (default to false on a tty)" in (false, info [ "no-progress" ] ~doc ~docs ~docv) in let default = isatty stderr in value & vflag default [ progress; no_progress ] (* -----------------------------------------------------------------------*) (* Terms *) let setup_logs = Term.(const setup_logs $ log_level) let setup_random = Term.(const setup_random $ print_seed $ seed) let common_options = let make_config = function | Some f -> Config.Parse.of_file f | None -> Config.default_config in let make () () progress config instr o = (make_config config, instr, o, progress) in Term.( const make $ setup_logs $ setup_random $ progress $ config $ instr $ o) let generate_random = Term.(const generate_random $ small $ common_options $ n) let generate_enum = Term.(const generate_enum $ common_options $ n) let fuzzing_options = let t type_only binterp_path (config, instr, o, progress) = (config, instr, type_only, binterp_path, o, progress) in Term.(const t $ type_only $ binterp_path $ common_options) let fuzz = Term.(const fuzz $ small $ fuzzing_options $ n) let bet = Term.(const bet $ fuzzing_options $ n) let quickcheck = Term.(const quickcheck $ small $ fuzzing_options $ n) let fuzz_files = Term.(const fuzz_files $ fuzzing_options $ files) let execute = Term.(const execute $ setup_logs $ type_only $ binterp_path $ files) (* -----------------------------------------------------------------------*) (* Commands *) let cmd_default = let help _o = `Help (`Auto, None) in Term.(const help $ common_options |> ret) let cmd_fuzz_default = let help _ = `Help (`Auto, Some "fuzz") in Term.(const help $ fuzzing_options |> ret) let cmd_generate_random = let doc = "Generate N randoms ASTs and write them to DIR." in let info = Cmd.info "random" ~doc in Cmd.v info generate_random let cmd_generate_enum = let doc = "Generate the N smallest ASTs and write them to DIR." in let info = Cmd.info "enum" ~doc in Cmd.v info generate_enum let cmd_generate = let doc = "ASL programs generation." in let info = Cmd.info "generate" ~doc in let default = cmd_default in Cmd.group ~default info [ cmd_generate_random; cmd_generate_enum ] let cmd_fuzz_random = let doc = "Fuzz BInterp w.r.t. ASLRef using randomly generated ASTs." in let info = Cmd.info "random" ~doc in Cmd.v info fuzz let cmd_fuzz_enum = let doc = "Fuzz BInterp w.r.t. ASLRef using an enumeration of ASTs of increasing \ size." in let info = Cmd.info "enum" ~doc in Cmd.v info bet let cmd_fuzz_quickcheck = let doc = "QuickCheck style fuzzing for BInterp w.r.t. ASLRef using randomly \ generated ASTs. Once a discrepancy is found, the tool will iterate over \ all the possible sub-trees until it finds a local minima for the \ discrepancy" in let info = Cmd.info "quickcheck" ~doc in Cmd.v info quickcheck let cmd_fuzz_files = let doc = "Fuzz on the tests passed as command line. Usual filters apply.\n\n\ Current limitation: files will be reprocessed by ASLRef before passed \ to any other interpreter, so any test that is not parsable by ASLRef \ will be ignored." in let info = Cmd.info "files" ~doc in Cmd.v info fuzz_files let cmd_fuzz = let doc = "Fuzz BInterp w.r.t. ASLRef." in let info = Cmd.info "fuzz" ~doc in let default = cmd_fuzz_default in Cmd.group ~default info [ cmd_fuzz_random; cmd_fuzz_enum; cmd_fuzz_quickcheck; cmd_fuzz_files ] let cmd_execute = let doc = "Execute tests with BInterp." in let info = Cmd.info "execute" ~doc in Cmd.v info execute let cmd = let doc = "Test generation and fuzzing for ASL." and man = let config_file_text = "Configuration for the generated ASTs. Mostly constrains the generated \ AST by removing/allowing certain constructors." in [ `Blocks [ `S Manpage.s_files; `I ("CONFIG_FILE", config_file_text) ] ] in let info = Cmd.info "carpenter" ~doc ~man in let default = cmd_default in Cmd.group ~default info [ cmd_generate; cmd_fuzz; cmd_execute ] let main () = Cmd.eval cmd end let () = exit (Cmd.main ()) herd-herdtools7-1ca343e/asllib/carpenter/nat.ml000066400000000000000000000052141475314470400215110ustar00rootroot00000000000000(****************************************************************************************************************) (* SPDX-FileCopyrightText: Copyright 2022-2024 Arm Limited and/or its affiliates *) (* SPDX-License-Identifier: BSD-3-Clause *) (****************************************************************************************************************) open QCheck2.Gen (** Module adapted from [random_generator.Gen.Nat] *) let split2 n = let+ k = int_bound n in (k, n - k) (** Builds a random subset of size [size] of the interval [start, limit]. *) let subset ~size start limit = let stop = limit + 1 in let range = stop - start in if not (0 <= size && size <= range) then invalid_arg "Gen.Nat.subset"; (* The algorithm below is attributed to Floyd, see for example https://eyalsch.wordpress.com/2010/04/01/random-sample/ https://math.stackexchange.com/questions/178690 *) let module ISet = Set.Make (Int) in let rec fill set i = if i = stop then return set else let* pos = start -- i in let choice = if ISet.mem pos set then i else pos in fill (ISet.add choice set) (i + 1) in let+ set = fill ISet.empty (stop - size) in ISet.elements set let pos_split ~size:k n = (* To split n into n{0}+n{1}+..+n{k-1}, we draw distinct "boundaries" b{-1}..b{k-1}, with b{-1}=0 and b{k-1} = n and the k-1 intermediate boundaries b{0}..b{k-2} chosen randomly distinct in [1;n-1]. Then each n{i} is defined as b{i}-b{i-1}. *) let+ b = subset ~size:(k - 1) 1 (n - 1) in let b = Array.of_list b in List.init k (fun i -> if i = 0 then b.(0) else if i = k - 1 then n - b.(i - 1) else b.(i) - b.(i - 1)) let split ~size:k n = if k > n then raise (Invalid_argument "split"); match k with | 0 -> pure [] | 1 -> pure [ n ] | 2 -> let+ k, k' = split2 n in [ k; k' ] | _ -> let+ ns = pos_split ~size:k (n + k) in List.map (fun v -> v - 1) ns let split3 n = split ~size:3 n >|= function | [ n1; n2; n3 ] -> (n1, n2, n3) | _ -> assert false let list_sized_min_no_gen ?(fun_name = "list_sized_min_no_gen") min size = if min > size then raise (Invalid_argument fun_name); let* length = min -- size in split ~size:length size let list_sized_min ?(fun_name = "list_sized_min") min elt size = let* sizes = list_sized_min_no_gen ~fun_name min size in List.map elt sizes |> flatten_l let list_sized elt size = list_sized_min ~fun_name:"list_sized" 0 elt size let list_sized_non_empty elt size = list_sized_min ~fun_name:"list_sized_non_empty" 1 elt size herd-herdtools7-1ca343e/asllib/carpenter/test/000077500000000000000000000000001475314470400213525ustar00rootroot00000000000000herd-herdtools7-1ca343e/asllib/carpenter/test/aslref.ml000066400000000000000000000035271475314470400231670ustar00rootroot00000000000000(****************************************************************************************************************) (* SPDX-FileCopyrightText: Copyright 2022-2024 Arm Limited and/or its affiliates *) (* SPDX-License-Identifier: BSD-3-Clause *) (****************************************************************************************************************) let check_no_strange_error ast = let open Asllib in try let _ = Typing.type_and_run ast in true with | Error.ASLException _ -> true | _ -> false let no_strange_error ast = let open Asllib in try let _ = Typing.type_and_run ast in () with | Error.ASLException _ -> () | e -> Format.eprintf "@[Found an error with:@ %a@]@." PP.pp_t ast; raise e module C = struct module Syntax = struct include Carpenter_lib.Config.Stable let s_while = false let s_repeat = false end end module RandomTypedAST = Carpenter_lib.RandomAST.Typed (C) module EnumAST = Carpenter_lib.ASTEnums.Make (C) let no_unsupported_error_random = QCheck2.Test.make ~count:1000 ~name:"aslref doesn't raise strange errors" ~print:Asllib.PP.t_to_string (QCheck2.Gen.sized RandomTypedAST.ast) check_no_strange_error let () = if false then QCheck_runner.run_tests ~long:true [ no_unsupported_error_random ] |> exit let no_unsupported_error_enum () = let count = Z.of_int 10000 in let module IFSeq = Feat.IFSeq in let rec loop n count acc = let seq = EnumAST.asts n in let len = IFSeq.length seq in if Z.leq len count then loop (succ n) Z.(sub count len) (IFSeq.to_seq seq acc) else IFSeq.sample (Z.to_int count) seq acc in let alls = loop 0 count Seq.empty in Seq.iter no_strange_error alls let () = no_unsupported_error_enum () herd-herdtools7-1ca343e/asllib/carpenter/test/dune000066400000000000000000000002751475314470400222340ustar00rootroot00000000000000(test (name aslref) (modules aslref) (enabled_if (and %{lib-available:carpenter_lib} %{lib-available:feat} %{lib-available:qcheck})) (libraries carpenter_lib feat qcheck asllib)) herd-herdtools7-1ca343e/asllib/desugar.ml000066400000000000000000000140061475314470400203750ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) open AST open ASTUtils let desugar_setter call fields rhs = let loc = to_pos call and { desc = { name; params; args } } = call in let () = assert (loc.version = V1) in let here desc = add_pos_from loc desc in match fields with | [] -> (* Setter(rhs, ...); *) S_Call { name; args = rhs :: args; params; call_type = ST_Setter } | _ -> let temp = fresh_var "__setter_v1_temporary" in (* temp = Getter(...); *) let read = let getter_call = E_Call { name; args; params; call_type = ST_Getter } |> here in S_Decl (LDK_Var, LDI_Var temp, None, Some getter_call) |> here in (* temp.field = rhs OR temp.[field1, field2, ...] = rhs; *) let modify = let temp_le = LE_Var temp |> here in let lhs = match fields with | [ field ] -> LE_SetField (temp_le, field) | _ -> LE_SetFields (temp_le, fields, []) in S_Assign (lhs |> here, rhs) |> here in (* Setter(rhs, ...); *) let write = let temp_e = E_Var temp |> here in S_Call { name; args = temp_e :: args; params; call_type = ST_Setter } |> here in S_Seq (s_then read modify, write) let desugar_elided_parameter ldk lhs ty (call : call annotated) = let bits_e = match ty.desc with | T_Bits (bits_e, []) -> bits_e | _ -> (* For example, let x = foo{,M}(args); cannot be desugared as there is no bits(_) annotation on the left-hand side *) Error.fatal_from (to_pos call) CannotParse in let params = bits_e :: call.desc.params in let rhs = E_Call { call.desc with params } |> add_pos_from call in S_Decl (ldk, lhs, Some ty, Some rhs) (* ------------------------------------------------------------------------- Left-hand sides ------------------------------------------------------------------------- *) type lhs_field = identifier annotated type lhs_access = { base : identifier annotated; index : expr option; fields : lhs_field list; (** empty means no fields *) slices : slice list annotated; (** empty means no slices*) } let desugar_lhs_access { base; index; fields; slices } = let var = LE_Var base.desc |> add_pos_from base in let with_index = match index with | None -> var | Some idx -> LE_SetArray (var, idx) |> add_pos_from idx in let with_fields = List.fold_left (fun acc field -> LE_SetField (acc, field.desc) |> add_pos_from field) with_index fields in let with_slices = match slices.desc with | [] -> with_fields | _ -> LE_Slice (with_fields, slices.desc) |> add_pos_from slices in with_slices let desugar_lhs_tuple laccess_opts = let bases = List.filter_map (Option.map (fun { base } -> base.desc)) laccess_opts.desc in match get_first_duplicate bases with | Some dup -> Error.fatal_from (to_pos laccess_opts) (MultipleWrites dup) | None -> let desugar_one = function | None -> LE_Discard |> add_pos_from laccess_opts | Some laccess -> desugar_lhs_access laccess in LE_Destructuring (List.map desugar_one laccess_opts.desc) |> add_pos_from laccess_opts let desugar_lhs_fields_tuple base field_opts = let fields = List.filter_map (Option.map (fun fld -> fld.desc)) field_opts in match get_first_duplicate fields with | Some dup -> Error.fatal_from (to_pos base) (MultipleWrites (base.desc ^ "." ^ dup)) | None -> let desugar_one = function | None -> LE_Discard |> add_pos_from base | Some fld -> let var = LE_Var base.desc |> add_pos_from base in LE_SetField (var, fld.desc) |> add_pos_from fld in LE_Destructuring (List.map desugar_one field_opts) let desugar_case_stmt e0 cases otherwise = (* Begin CaseToCond *) let case_to_cond e0 case tail = let { pattern; where; stmt } = case.desc in let e_pattern = E_Pattern (e0, pattern) |> add_pos_from pattern in let cond = match where with | None -> e_pattern | Some e_where -> binop BAND e_pattern e_where in S_Cond (cond, stmt, tail) |> add_pos_from case (* End *) in (* Begin CasesToCond *) let cases_to_cond e0 cases = List.fold_right (case_to_cond e0) cases otherwise (* End *) in (* Begin DesugarCaseStmt *) match e0.desc with | E_Var _ -> (cases_to_cond e0 cases).desc | _ -> let x = fresh_var "__case__linearisation" in let decl_x = S_Decl (LDK_Let, LDI_Var x, None, Some e0) in S_Seq (decl_x |> add_pos_from e0, cases_to_cond (var_ x) cases) (* End *) herd-herdtools7-1ca343e/asllib/desugar.mli000066400000000000000000000103001475314470400205370ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) open AST val desugar_setter : call annotated -> identifier list -> expr -> stmt_desc (** Desugar a setter call, in particular: {[ Setter(args) = rhs; --> Setter(rhs, args); Setter(args).fld = rhs; --> var temp = Getter(args); temp.fld = rhs; Setter(temp, args); Setter(args).[fld1,fld2] = rhs; --> var temp = Getter(args); temp.[fld1,fld2] = rhs; Setter(temp, args); ]} *) val desugar_elided_parameter : local_decl_keyword -> local_decl_item -> ty -> call annotated -> stmt_desc (** Desugar an elided parameter, in particular: {[ let x : bits(e) = MyFunc{}(args) --> ... = MyFunc{e}(args) let x : bits(e) = MyFunc{,e1}(args) --> ... = MyFunc{e,e1}(args) ]} Similarly for [var] and [constant]. *) (* ------------------------------------------------------------------------- Left-hand sides ------------------------------------------------------------------------- *) (* Types to represent valid left-hand sides produced by parsing. *) type lhs_field = identifier annotated type lhs_access = { base : identifier annotated; index : expr option; fields : lhs_field list; (** empty means no fields *) slices : slice list annotated; (** empty means no slices *) } (** An access has a [base] variable, optionally followed by an array [index], nested field accesses [fields], and [slices]: [base[[index]].field1.field2[slices]] *) val desugar_lhs_access : lhs_access -> lexpr (** Desugar an [lhs_access] to an [lexpr]. *) val desugar_lhs_tuple : lhs_access option list annotated -> lexpr (** Desugar a list of [lhs_access] options to an [LE_Destructuring]. The [None] entries turn in to [LE_Discard], and the [Some] entries are desugared using [desugar_lhs_access]. Also check that none of the entries share a base variable, i.e. none of them attempt to write the the same variable. *) val desugar_lhs_fields_tuple : identifier annotated -> lhs_field option list -> lexpr_desc (** [desugar_lhs_fields_tuple x flds] desugars a left-hand side of the form [x.(fld1, ..., fldk)] to [(x.fld1, ..., x.fldk)], ensuring that the [flds] are unique. *) val desugar_case_stmt : expr_desc annotated -> case_alt_desc annotated list -> stmt -> stmt_desc (** [desugar_case_stmt e0 cases otherwise] desugars a case statement for the discriminant expression [e0], case alternatives [cases], and otherwise statement [otherwise]. The result is a conditional statement, possibly preceded by an assignment of the condition [e0] to a fresh variable). *) herd-herdtools7-1ca343e/asllib/diet.ml000066400000000000000000000371271475314470400177010ustar00rootroot00000000000000(* * Copyright (C) 2016 David Scott * * Permission to use, copy, modify, and distribute this software for any * purpose with or without fee is hereby granted, provided that the above * copyright notice and this permission notice appear in all copies. * * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. * *) [@@@warning "-44"] module type ELT = sig type t val compare : t -> t -> int val zero : t val pred : t -> t val succ : t -> t val sub : t -> t -> t val add : t -> t -> t val to_string : t -> string end module type INTERVAL_SET = sig type elt type interval module Interval : sig val make : elt -> elt -> interval val x : interval -> elt val y : interval -> elt end type t val equal : t -> t -> bool val compare : t -> t -> int val pp : Format.formatter -> t -> unit val empty : t val is_empty : t -> bool val singleton : elt -> t val cardinal : t -> elt val mem : elt -> t -> bool val fold : (interval -> 'a -> 'a) -> t -> 'a -> 'a val fold_individual : (elt -> 'a -> 'a) -> t -> 'a -> 'a val filter_map_individual : (elt -> elt option) -> t -> t val iter : (interval -> unit) -> t -> unit val add : interval -> t -> t val remove : interval -> t -> t val min_elt : t -> elt val max_elt : t -> elt val min_interval : t -> interval val max_interval : t -> interval val choose : t -> interval val take : t -> elt -> (t * t) option val union : t -> t -> t val unions : t list -> t val diff : t -> t -> t val inter : t -> t -> t val subset : t -> t -> bool val cross_filter_map_individual : (elt -> elt -> elt option) -> t -> t -> t val find_next_gap : elt -> t -> elt val elements : t -> interval list val elements_individual : t -> elt list val of_list : elt list -> t val check_invariants : t -> (unit, string) result val height : t -> int end module Make (Elt : ELT) = struct type elt = Elt.t module Elt = struct include Elt let ( - ) = sub let ( + ) = add end type interval = elt * elt module Interval = struct let make x y = if x > y then invalid_arg "Interval.make"; (x, y) let x = fst let y = snd end let ( > ) x y = Elt.compare x y > 0 let ( >= ) x y = Elt.compare x y >= 0 let ( < ) x y = Elt.compare x y < 0 let ( <= ) x y = Elt.compare x y <= 0 let eq x y = Elt.compare x y = 0 let succ, pred = (Elt.succ, Elt.pred) type t = Empty | Node : node -> t and node = { x : elt; y : elt; l : t; r : t; h : int; cardinal : elt } let rec cons_enum t enum = match t with | Empty -> enum | Node ({ l; _ } as node) -> cons_enum l (node :: enum) let compare_with_invariant { x; y; _ } { x = x'; y = y'; _ } = if eq x x' && eq y y' then 0 else if y < x' then -1 else 1 let rec compare_aux enum enum' = match (enum, enum') with | [], [] -> 0 | [], _ -> -1 | _, [] -> 1 | node :: enum, node' :: enum' -> ( match compare_with_invariant node node' with | 0 -> compare_aux (cons_enum node.r enum) (cons_enum node'.r enum') | c -> c) let compare t t' = compare_aux (cons_enum t []) (cons_enum t' []) let equal t t' = compare t t' = 0 let rec pp fmt = function | Empty -> Format.fprintf fmt "Empty" | Node n -> pp_node fmt n and pp_node fmt { x; y; l; r; h; cardinal } = Format.pp_open_vbox fmt 0; Format.fprintf fmt "x: %s@," (Elt.to_string x); Format.fprintf fmt "y: %s@," (Elt.to_string y); Format.fprintf fmt "l:@[@\n%a@]@," pp l; Format.fprintf fmt "r:@[@\n%a@]@," pp r; Format.fprintf fmt "h: %d@," h; Format.fprintf fmt "cardinal: %s" (Elt.to_string cardinal); Format.pp_close_box fmt () let height = function Empty -> 0 | Node n -> n.h let cardinal = function Empty -> Elt.zero | Node n -> n.cardinal let create x y l r = let h = max (height l) (height r) + 1 in let cardinal = Elt.(succ (y - x) + cardinal l + cardinal r) in Node { x; y; l; r; h; cardinal } let rec node x y l r = let hl = height l and hr = height r in let open Stdlib in if hl > hr + 2 then match l with | Empty -> assert false | Node { x = lx; y = ly; l = ll; r = lr; _ } -> ( if height ll >= height lr then node lx ly ll (node x y lr r) else match lr with | Empty -> assert false | Node { x = lrx; y = lry; l = lrl; r = lrr; _ } -> node lrx lry (node lx ly ll lrl) (node x y lrr r)) else if hr > hl + 2 then match r with | Empty -> assert false | Node { x = rx; y = ry; l = rl; r = rr; _ } -> ( if height rr >= height rl then node rx ry (node x y l rl) rr else match rl with | Empty -> assert false | Node { x = rlx; y = rly; l = rll; r = rlr; _ } -> node rlx rly (node x y l rll) (node rx ry rlr rr)) else create x y l r let depth tree = let rec depth tree k = match tree with | Empty -> k 0 | Node n -> depth n.l (fun dl -> depth n.r (fun dr -> k (1 + max dl dr))) in depth tree (fun d -> d) module Invariant = struct let ( >>= ) xr f = match xr with Ok x -> f x | e -> e let ensure b msg t = if b then Ok () else Error (Format.asprintf "%s: %a" msg pp t) let rec on_every_node d f = match d with | Empty -> Ok () | Node n -> f n d >>= fun () -> on_every_node n.l f >>= fun () -> on_every_node n.r f (* The pairs (x, y) in each interval are ordered such that x <= y *) let ordered { x; y; _ } = ensure (x <= y) "Pairs within each interval should be ordered" (* The intervals don't overlap *) let no_overlap { x; y; l; r; _ } n = let error = "Intervals should be ordered without overlap" in (match l with Empty -> Ok () | Node left -> ensure (left.y < x) error n) >>= fun () -> match r with Empty -> Ok () | Node right -> ensure (right.x > y) error n let no_adjacent { x; y; l; r; _ } n = let error = "Intervals should not be adjacent" in (match l with | Empty -> Ok () | Node left -> ensure (Elt.succ left.y < x) error n) >>= fun () -> match r with | Empty -> Ok () | Node right -> ensure (Elt.pred right.x > y) error n let node_height n = n.h let node_depth n = depth (Node n) (* The height is being stored correctly *) let height_equals_depth n = ensure (node_height n = node_depth n) "The height is not being maintained correctly" let balanced { l; r; _ } = let diff = height l - height r in let open Stdlib in ensure (-2 <= diff && diff <= 2) "The tree has become imbalanced" let check_cardinal { x; y; l; r; cardinal = c; _ } = ensure Elt.(c - cardinal l - cardinal r - y + x = succ zero) "The cardinal value stored in the node is wrong" let check t = on_every_node t ordered >>= fun () -> on_every_node t no_overlap >>= fun () -> on_every_node t height_equals_depth >>= fun () -> on_every_node t balanced >>= fun () -> on_every_node t check_cardinal >>= fun () -> on_every_node t no_adjacent end let empty = Empty let is_empty = function Empty -> true | _ -> false let rec mem elt = function | Empty -> false | Node n -> (* consider this interval *) (elt >= n.x && elt <= n.y) || (* or search left or search right *) if elt < n.x then mem elt n.l else mem elt n.r let rec min_interval = function | Empty -> raise Not_found | Node { x; y; l = Empty; _ } -> (x, y) | Node { l; _ } -> min_interval l let rec max_interval = function | Empty -> raise Not_found | Node { x; y; r = Empty; _ } -> (x, y) | Node { r; _ } -> max_interval r let min_elt t = min_interval t |> Interval.x let max_elt t = max_interval t |> Interval.y let choose = function Empty -> raise Not_found | Node { x; y; _ } -> (x, y) (* fold over the maximal contiguous intervals *) let rec fold f t acc = match t with | Empty -> acc | Node n -> let acc = fold f n.l acc in let acc = f (n.x, n.y) acc in fold f n.r acc (* fold over individual elements *) let fold_individual f t acc = let range (from, upto) acc = let rec loop acc x = if eq x (succ upto) then acc else loop (f x acc) (succ x) in loop acc from in fold range t acc let elements t = fold List.cons t [] let elements_individual t = fold_individual List.cons t [] (* iterate over maximal contiguous intervals *) let iter f t = let f' itl () = f itl in fold f' t () (* return (x, y, l) where (x, y) is the maximal interval and [l] is the rest of the tree on the left (whose intervals are all smaller). *) let rec splitMax = function | { x; y; l; r = Empty; _ } -> (x, y, l) | { r = Node r; _ } as n -> let u, v, r' = splitMax r in (u, v, node n.x n.y n.l r') (* return (x, y, r) where (x, y) is the minimal interval and [r] is the rest of the tree on the right (whose intervals are all larger) *) let rec splitMin = function | { x; y; l = Empty; r; _ } -> (x, y, r) | { l = Node l; _ } as n -> let u, v, l' = splitMin l in (u, v, node n.x n.y l' n.r) let addL = function | { l = Empty; _ } as n -> n | { l = Node l; _ } as n -> (* we might have to merge the new element with the maximal interval from the left *) let x', y', l' = splitMax l in if eq (succ y') n.x then { n with x = x'; l = l' } else n let addR = function | { r = Empty; _ } as n -> n | { r = Node r; _ } as n -> (* we might have to merge the new element with the minimal interval on the right *) let x', y', r' = splitMin r in if eq (succ n.y) x' then { n with y = y'; r = r' } else n let rec add (x, y) t = if y < x then invalid_arg "interval reversed"; match t with | Empty -> node x y Empty Empty (* completely to the left *) | Node n when y < Elt.pred n.x -> let l = add (x, y) n.l in node n.x n.y l n.r (* completely to the right *) | Node n when Elt.succ n.y < x -> let r = add (x, y) n.r in node n.x n.y n.l r (* overlap on the left only *) | Node n when x < n.x && y <= n.y -> let l = add (x, pred n.x) n.l in let n = addL { n with l } in node n.x n.y n.l n.r (* overlap on the right only *) | Node n when y > n.y && x >= n.x -> let r = add (succ n.y, y) n.r in let n = addR { n with r } in node n.x n.y n.l n.r (* overlap on both sides *) | Node n when x < n.x && y > n.y -> let l = add (x, pred n.x) n.l in let r = add (succ n.y, y) n.r in let n = addL { (addR { n with r }) with l } in node n.x n.y n.l n.r (* completely within *) | Node n -> Node n let union a b = let a' = cardinal a and b' = cardinal b in if a' > b' then fold add b a else fold add a b (* Added by Hadrien Renaud *) let rec pairwise_unions acc = function | [] -> acc | x :: [] -> x :: acc | x :: y :: li -> pairwise_unions (union x y :: acc) li let rec unions = function | [] -> empty | x :: [] -> x | li -> pairwise_unions [] li |> unions (* End added by Hadrien Renaud *) let merge l r = match (l, r) with | l, Empty -> l | Empty, r -> r | Node l, r -> let x, y, l' = splitMax l in node x y l' r let rec remove (x, y) t = if y < x then invalid_arg "interval reversed"; match t with | Empty -> Empty (* completely to the left *) | Node n when y < n.x -> let l = remove (x, y) n.l in node n.x n.y l n.r (* completely to the right *) | Node n when n.y < x -> let r = remove (x, y) n.r in node n.x n.y n.l r (* overlap on the left only *) | Node n when x < n.x && y < n.y -> let n' = node (succ y) n.y n.l n.r in remove (x, pred n.x) n' (* overlap on the right only *) | Node n when y > n.y && x > n.x -> let n' = node n.x (pred x) n.l n.r in remove (succ n.y, y) n' (* overlap on both sides *) | Node n when x <= n.x && y >= n.y -> let l = remove (x, n.x) n.l in let r = remove (n.y, y) n.r in merge l r (* completely within *) | Node n when eq y n.y -> node n.x (pred x) n.l n.r | Node n when eq x n.x -> node (succ y) n.y n.l n.r | Node n -> assert (n.x <= pred x); assert (succ y <= n.y); let r = node (succ y) n.y Empty n.r in node n.x (pred x) n.l r let diff a b = fold remove b a let inter a b = diff a (diff a b) let subset a b = is_empty (diff a b) let rec find_next_gap from = function | Empty -> from | Node n -> (* consider this interval *) if from >= n.x && from <= n.y then succ n.y (* or search left *) else if from < n.x then find_next_gap from n.l (* or search right *) else find_next_gap from n.r let take t n = let rec loop acc free n = if n = Elt.zero then Some (acc, free) else match try let i = choose free in let x, y = Interval.(x i, y i) in let len = Elt.(succ @@ (y - x)) in let will_use = if Stdlib.(Elt.compare n len < 0) then n else len in let i' = Interval.make x Elt.(pred @@ (x + will_use)) in Some (add i' acc, remove i' free, Elt.(n - will_use)) with Not_found -> None with | Some (acc', free', n') -> loop acc' free' n' | None -> None in loop empty t n let of_sorted_list = let rec loop acc x y = function | [] -> add (Interval.make x y) acc | z :: t -> let y' = Elt.succ y in if eq y' z then loop acc x y' t else loop (add (Interval.make x y) acc) z z t in function [] -> empty | x :: t -> loop empty x x t let of_list li = List.sort_uniq Elt.compare li |> of_sorted_list let filter_map_individual f t = fold_individual (fun x acc -> match f x with Some z -> z :: acc | None -> acc) t [] |> of_list let cross_filter_map_individual f t1 t2 = fold_individual (fun x -> fold_individual (fun y acc -> match f x y with Some z -> z :: acc | None -> acc) t2) t1 [] |> of_list let check_invariants = Invariant.check let singleton x = add (Interval.make x x) empty let pp_interval fmt i = let x, y = Interval.(x i, y i) in if eq x y then Format.fprintf fmt "{%s}" (Elt.to_string x) else Format.fprintf fmt "[%s, %s]" (Elt.to_string x) (Elt.to_string y) let pp fmt = let open Format in function | Empty -> fprintf fmt "∅" | t -> let m = min_interval t in let t = remove m t in pp_open_hovbox fmt 0; pp_interval fmt m; iter (fun i -> fprintf fmt "@ \u{222a} "; pp_interval fmt i) t; pp_close_box fmt () end module Int_elt = struct type t = int let compare a b = compare (a : int) b let zero = 0 let pred = pred let succ = succ let sub = ( - ) let add = ( + ) let to_string = string_of_int end module Int = Make (Int_elt) module Int64 = Make (Int64) module Z = Make (Z) herd-herdtools7-1ca343e/asllib/diet.mli000066400000000000000000000125341475314470400200450ustar00rootroot00000000000000(* * Copyright (C) 2016 David Scott * * Permission to use, copy, modify, and distribute this software for any * purpose with or without fee is hereby granted, provided that the above * copyright notice and this permission notice appear in all copies. * * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. * *) (** An interval set implementation using diets. *) module type ELT = sig type t (** The type of the set elements. *) include Set.OrderedType with type t := t val zero : t (** The zeroth element *) val pred : t -> t (** Predecessor of an element *) val succ : t -> t (** Successor of an element *) val sub : t -> t -> t (** [sub a b] returns [a] - [b] *) val add : t -> t -> t (** [add a b] returns [a] + [b] *) val to_string : t -> string (** Display an element. *) end module type INTERVAL_SET = sig type elt (** The type of the set elements *) type interval (** An interval: a range (x, y) of set values where all the elements from x to y inclusive are in the set *) module Interval : sig val make : elt -> elt -> interval (** [make first last] construct an interval describing all the elements from [first] to [last] inclusive. *) val x : interval -> elt (** the starting element of the interval *) val y : interval -> elt (** the ending element of the interval *) end type t (** The type of sets *) val equal : t -> t -> bool (** Equality over sets *) val compare : t -> t -> int (** Comparison over sets *) val pp : Format.formatter -> t -> unit (** Pretty-print a set *) val empty : t (** The empty set *) val is_empty : t -> bool (** Test whether a set is empty or not *) val singleton : elt -> t (** [singleton x] is the set containing just [x]. *) val cardinal : t -> elt (** [cardinal t] is the number of elements in the set [t] *) val mem : elt -> t -> bool (** [mem elt t] tests whether [elt] is in set [t] *) val fold : (interval -> 'a -> 'a) -> t -> 'a -> 'a (** [fold f t acc] folds [f] across all the intervals in [t] *) val fold_individual : (elt -> 'a -> 'a) -> t -> 'a -> 'a (** [fold_individual f t acc] folds [f] across all the individual elements of [t] *) val filter_map_individual : (elt -> elt option) -> t -> t (** [filter_map_individual f t] is the set of all [f(x)] for [x] in [t]. *) val iter : (interval -> unit) -> t -> unit (** [iter f t] iterates [f] across all the intervals in [t] *) val add : interval -> t -> t (** [add interval t] returns the set consisting of [t] plus [interval] *) val remove : interval -> t -> t (** [remove interval t] returns the set consisting of [t] minus [interval] *) val min_elt : t -> elt (** [min_elt t] returns the smallest (in terms of the ordering) element in [t], or raises [Not_found] if the set is empty. *) val max_elt : t -> elt (** [max_elt t] returns the largest (in terms of the ordering) element in [t], or raises [Not_found] if the set is empty. *) val min_interval : t -> interval (** [min_interval t] returns the smallest (in terms of the ordering) interval in [t], or raises [Not_found] if the set is empty. *) val max_interval : t -> interval (** [max_interval t] returns the largest (in terms of the ordering) interval in [t], or raises [Not_found] if the set is empty. *) val choose : t -> interval (** [choose t] returns one interval, or raises Not_found if the set is empty *) val take : t -> elt -> (t * t) option (** [take n] returns [Some a, b] where [cardinal a = n] and [diff t a = b] or [None] if [cardinal t < n] *) val union : t -> t -> t (** set union *) val unions : t list -> t (** Iterated set union. *) val diff : t -> t -> t (** set difference *) val inter : t -> t -> t (** set intersection *) val subset : t -> t -> bool (** subsets *) val cross_filter_map_individual : (elt -> elt -> elt option) -> t -> t -> t (** Cross product on all elements of sets *) val find_next_gap : elt -> t -> elt (** [find_next_gap from t] returns the next element that's absent in set [t] and greater than or equal to [from] **) val elements : t -> interval list (** [elements t] returns the list of intervals in the set [t]. *) val elements_individual : t -> elt list (** [elements_individual t] returns the list of elements in the set [t]. *) val of_list : elt list -> t (** [of_list li] returns the set of elements in the list [li]. *) (**/**) val check_invariants : t -> (unit, string) result (** [check_invariants t] returns [Ok ()] if the underlying invariants hold, or an error message. *) val height : t -> int (** [height t] return the height of the corresponding tree. *) end module Make (Elt : ELT) : INTERVAL_SET with type elt = Elt.t module Int : INTERVAL_SET with type elt = int module Int64 : INTERVAL_SET with type elt = int64 module Z : INTERVAL_SET with type elt = Z.t herd-herdtools7-1ca343e/asllib/dune000066400000000000000000000020631475314470400172670ustar00rootroot00000000000000(rule (copy ../Version.ml Version.ml)) (ocamllex Lexer) (ocamllex SimpleLexer0) (ocamllex splitasl) (menhir (modules Tokens) (flags --only-tokens)) (menhir (modules Tokens Parser) (merge_into Parser) (flags --external-tokens Tokens)) (menhir (modules Parser0) (flags --unused-tokens --table)) (rule (deps (:v1 libdir/stdlib.asl) (:v0 libdir/stdlib0.asl)) (target asl_stdlib.ml) (action (with-stdout-to %{target} (progn (echo "let stdlib = {|") (cat %{v1}) (echo "|}") (echo "let stdlib0 = {|") (cat %{v0}) (echo "|}"))))) (library (name asllib) (modules (:standard \ aslref bundler)) (public_name herdtools7.asllib) (private_modules Parser0 Gparser0 Lexer0 SimpleLexer0 RepeatableLexer) (modules_without_implementation Backend AST ParserConfig) (flags (:standard -w -40-42-48)) (libraries menhirLib zarith)) (documentation) (executable (name aslref) (public_name aslref) (libraries asllib) (modules aslref)) (executable (public_name aslbundler) (name bundler) (libraries asllib) (modules bundler)) herd-herdtools7-1ca343e/asllib/env.ml000066400000000000000000000164541475314470400175440ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) open AST open ASTUtils module type RunTimeConf = sig module Scope : Backend.SCOPE type v val unroll : int end module type S = sig type v module Scope : Backend.SCOPE type global = { static : StaticEnv.global; storage : v Storage.t; stack_size : Z.t IMap.t; } type local type env = { global : global; local : local } val to_static : env -> StaticEnv.env val local_empty_scoped : ?storage:v Storage.t -> Scope.t -> local val global_from_static : ?storage:v Storage.t -> StaticEnv.global -> global type 'a env_result = Local of 'a | Global of 'a | NotFound val find : identifier -> env -> v env_result val mem : identifier -> env -> bool val declare_local : identifier -> v -> env -> env val assign_local : identifier -> v -> env -> env val declare_global : identifier -> v -> env -> env val assign_global : identifier -> v -> env -> env val remove_local : identifier -> env -> env val assign : identifier -> v -> env -> env env_result val tick_push : env -> env val tick_push_bis : env -> env val tick_pop : env -> env val tick_decr : env -> bool * env val get_scope : env -> Scope.t val push_scope : env -> env val pop_scope : env -> env -> env val get_stack_size : identifier -> env -> Z.t val incr_stack_size : identifier -> global -> global val decr_stack_size : identifier -> global -> global end module RunTime (C : RunTimeConf) = struct module Scope = C.Scope type v = C.v type global = { static : StaticEnv.global; storage : C.v Storage.t; stack_size : Z.t IMap.t; } type int_stack = int list type local = { storage : C.v Storage.t; scope : Scope.t; unroll : int_stack; declared : identifier list; } type env = { global : global; local : local } let local_empty_scoped ?(storage = Storage.empty) scope = { scope; storage; unroll = []; declared = [] } let global_from_static ?(storage = Storage.empty) static = { static; storage; stack_size = IMap.empty } let get_scope env = env.local.scope let to_static env = let global = env.global.static in StaticEnv.{ empty with global } (* --------------------------------------------------------------------------*) (* Loop unrolling controls. *) let set_unroll env unroll = { env with local = { env.local with unroll } } (** [tick_push env] is [env] with [C.unroll] pushed on its unrolling stack. *) let tick_push env = set_unroll env (C.unroll :: env.local.unroll) (** [tick_push_bis env] is [env] with [C.unroll -1] pushed on its unrolling stack. *) let tick_push_bis env = set_unroll env ((C.unroll - 1) :: env.local.unroll) (** [tick_pop env] is [env] with removed the unrolling stack first element. *) let tick_pop env = match env.local.unroll with | [] -> assert false | _ :: unroll -> set_unroll env unroll (** [tick_decr env] decrements the unrolling stack of env and returns wheather it has poped something or not. *) let tick_decr env = match env.local.unroll with | [] -> assert false | x :: xs -> let x = x - 1 in if x <= 0 then (true, set_unroll env xs) else (false, set_unroll env (x :: xs)) (* --------------------------------------------------------------------------*) (* Retrieval utils *) type 'a env_result = Local of 'a | Global of 'a | NotFound (* Begin SemanticsRule.EnvFind *) let find x env = try Local (Storage.find x env.local.storage) with Not_found -> ( try Global (Storage.find x env.global.storage) with Not_found -> NotFound) (* End *) let mem x env = Storage.mem x env.local.storage || Storage.mem x env.global.storage (* --------------------------------------------------------------------------*) (* Assignments utils *) let declare_local x v env = { env with local = { env.local with storage = Storage.add x v env.local.storage; declared = x :: env.local.declared; }; } let assign_local x v env = { env with local = { env.local with storage = Storage.assign x v env.local.storage }; } let declare_global x v env = { env with global = { env.global with storage = Storage.add x v env.global.storage }; } let assign_global x v env = { env with global = { env.global with storage = Storage.assign x v env.global.storage }; } let remove_local x env = { env with local = { env.local with storage = Storage.remove x env.local.storage; declared = List.filter (fun s -> not (String.equal s x)) env.local.declared; }; } let assign x v env = try Local (assign_local x v env) with Not_found -> ( try Global (assign_global x v env) with Not_found -> NotFound) (* --------------------------------------------------------------------------*) (* Scope swapping utils *) let push_scope env = { env with local = { env.local with declared = [] } } let pop_scope parent child = let local_storage = Storage.patch_mem ~t_env:parent.local.storage ~t_mem:child.local.storage child.local.declared in { child with local = { parent.local with storage = local_storage } } let get_stack_size name env = try IMap.find name env.global.stack_size with Not_found -> Z.zero let set_stack_size name value global = let stack_size = IMap.add name value global.stack_size in { global with stack_size } let incr_stack_size name global = let prev = try IMap.find name global.stack_size with Not_found -> Z.zero in set_stack_size name (Z.succ prev) global let decr_stack_size name global = let prev = try IMap.find name global.stack_size with Not_found -> assert false in assert (Z.sign prev > 0); set_stack_size name (Z.pred prev) global end herd-herdtools7-1ca343e/asllib/env.mli000066400000000000000000000146631475314470400177150ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) open AST open ASTUtils (** The runtime environment used by {!Interpreter}. *) module type RunTimeConf = sig module Scope : Backend.SCOPE (** Scopes for interpretation: make local storage identifiers unique accross function calls, if needed. *) type v (** Stored elements of the environment. *) val unroll : int (** [unroll] is the number of time a loop can be unrolled. *) end module type S = sig (** Internal representation for subprograms. *) type v (** Stored elements of the environment. *) module Scope : Backend.SCOPE (** Scopes for interpretation: make local storage identifiers unique accross function calls, if needed. *) (* -------------------------------------------------------------------------*) (** {2 Types and constructors.} *) type global = { static : StaticEnv.global; (** References the static environment. *) storage : v Storage.t; (** Binds global variables to their names. *) stack_size : Z.t IMap.t; (** Current number of recursive calls open for each subprogram. *) } (** The global part of an environment. *) type local (** The local part of an environment. *) type env = { global : global; local : local } (** The environment type. *) val to_static : env -> StaticEnv.env (** Builds a static environment, with an empty local part. *) val local_empty_scoped : ?storage:v Storage.t -> Scope.t -> local (** [empty_scoped scope] is an empty local environment in the scope [scope]. *) val global_from_static : ?storage:v Storage.t -> StaticEnv.global -> global (** [global_from_static static_env] is an empty global environment with the static environment [static_env]. *) (* -------------------------------------------------------------------------*) (** {2 Accessors} *) type 'a env_result = | Local of 'a | Global of 'a | NotFound (** Indicates if the value returned was bound in the global or local namespace. *) val find : identifier -> env -> v env_result (** Fetches an identifier from the environment. *) val mem : identifier -> env -> bool (** [mem x env] is true iff [x] is bound in [env]. *) val declare_local : identifier -> v -> env -> env (** [declare_local x v env] is [env] where [x] is now bound to [v]. This binding will be discarded by the call to [pop_scope] corresponding to the last call to [push_scope] before this declaration. *) val assign_local : identifier -> v -> env -> env (** [assign_local x v env] is [env] where [x] is now bound to [v]. It is assumed to be already bound in [env]. *) val declare_global : identifier -> v -> env -> env (** [declare_global x v env] is [env] where [x] is now bound to [v]. It is supposed that [x] is not bound in [env]. *) val assign_global : identifier -> v -> env -> env (** [assign_global x v env] is [env] where [x] is now bound to [v]. It is assumed to be already bound in [env]. *) val remove_local : identifier -> env -> env (** [remove_local x env] is [env] where [x] is not bound. *) val assign : identifier -> v -> env -> env env_result (** [assign x v env] assigns [x] to [v] in [env], and returns if [x] was declared as a local or global identifier. *) (* -------------------------------------------------------------------------*) (** {2 Loop unrolling} *) val tick_push : env -> env (** Push a new unrolling counter on the stack. The associated loop will be unrolled [C.unroll] times. *) val tick_push_bis : env -> env (** Push a new unrolling counter on the stack. The associated loop will be unrolled [C.unroll - 1] times. *) val tick_pop : env -> env (** Discards the last unrolling counter of the stack. *) val tick_decr : env -> bool * env (** [tick_decr env] is [(stop, env')] where - if the last counter is lower or equal to 1, [stop] is true and the last counter is discarded. - if the last counter is bigger or equal to 2, [stop] is false and the counter is decremented of 1. *) (* -------------------------------------------------------------------------*) (** {2 Scope handling} *) val get_scope : env -> Scope.t (** Returns the local scope of that environment. *) val push_scope : env -> env (** Push a new scope on the declaration stack. Variables declared here will be stored until the corresponding [pop_scope]. *) val pop_scope : env -> env -> env (** [pop_scope old new] restores the variable bindings of [old], with the updated values of [new]. *) val get_stack_size : identifier -> env -> Z.t (** [get_stack_size name env] returns the [stack_size] for [name]. *) val incr_stack_size : identifier -> global -> global (** [incr_stack_size name env] increases the stack size for [name]. *) val decr_stack_size : identifier -> global -> global (** [decr_stack_size name env] decreases the stack size for [name]. *) end module RunTime (C : RunTimeConf) : S with type v = C.v and module Scope = C.Scope herd-herdtools7-1ca343e/asllib/error.ml000066400000000000000000000565371475314470400201130ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) open AST (** Error handling for {!Asllib}. *) type error_handling_time = Static | Dynamic type error_desc = | ReservedIdentifier of string | BadField of string * ty | MissingField of string list * ty | BadSlices of error_handling_time * slice list * int | BadSlice of slice | EmptySlice | TypeInferenceNeeded | UndefinedIdentifier of identifier | MismatchedReturnValue of string | BadArity of error_handling_time * identifier * int * int | BadParameterArity of error_handling_time * version * identifier * int * int | UnsupportedBinop of error_handling_time * binop * literal * literal | UnsupportedUnop of error_handling_time * unop * literal | UnsupportedExpr of error_handling_time * expr | UnsupportedTy of error_handling_time * ty | InvalidExpr of expr | MismatchType of string * type_desc list | NotYetImplemented of string | ObsoleteSyntax of string | ConflictingTypes of type_desc list * ty | AssertionFailed of expr | CannotParse | UnknownSymbol | NoCallCandidate of string * ty list | TooManyCallCandidates of string * ty list | BadTypesForBinop of binop * ty * ty | CircularDeclarations of string | ImpureExpression of expr * SideEffect.SES.t | UnreconciliableTypes of ty * ty | AssignToImmutable of string | AlreadyDeclaredIdentifier of string | BadReturnStmt of ty option | UnexpectedSideEffect of string | UncaughtException of string | OverlappingSlices of slice list * error_handling_time | BadLDI of AST.local_decl_item | BadRecursiveDecls of identifier list | UnrespectedParserInvariant | BadATC of ty * ty (** asserting, asserted *) | BadPattern of pattern * ty | ConstrainedIntegerExpected of ty | ParameterWithoutDecl of identifier | BadParameterDecl of identifier * identifier list * identifier list (** name, expected, actual *) | BaseValueEmptyType of ty | ArbitraryEmptyType of ty | BaseValueNonStatic of ty * expr | SettingIntersectingSlices of bitfield list | SetterWithoutCorrespondingGetter of func | NonReturningFunction of identifier | ConflictingSideEffects of SideEffect.t * SideEffect.t | UnexpectedATC | UnreachableReached | LoopLimitReached | RecursionLimitReached | EmptyConstraints | UnexpectedPendingConstrained | BitfieldsDontAlign of { field1_absname : string; field2_absname : string; field1_absslices : string; field2_absslices : string; } | BadPrintType of ty | ConfigTimeBroken of expr * SideEffect.SES.t | ConstantTimeBroken of expr * SideEffect.SES.t | MultipleWrites of identifier | UnexpectedInitialisationThrow of ty * identifier (* Exception type and global storage element name. *) type error = error_desc annotated exception ASLException of error type 'a result = ('a, error) Result.t let fatal e = raise (ASLException e) let fatal_from pos e = fatal (ASTUtils.add_pos_from pos e) let fatal_here pos_start pos_end e = fatal (ASTUtils.annotated e pos_start pos_end ASTUtils.default_version) let fatal_unknown_pos e = fatal (ASTUtils.add_dummy_annotation e) let intercept f () = try Ok (f ()) with ASLException e -> Error e let error_handling_time_to_string = function | Static -> "Static" | Dynamic -> "Dynamic" type warning_desc = | NoRecursionLimit of identifier list | NoLoopLimit | IntervalTooBigToBeExploded of Z.t * Z.t | ConstraintSetPairToBigToBeExploded of { op : binop; left : int_constraint list; right : int_constraint list; log_max : int; (** Maximum size breached by this constraint set pair. *) } | RemovingValuesFromConstraints of { op : binop; prev : int_constraint list; after : int_constraint list; } | PragmaUse of identifier type warning = warning_desc annotated let error_label = function | ReservedIdentifier _ -> "ReservedIdentifier" | BadField _ -> "BadField" | BadPattern _ -> "BadPattern" | MissingField _ -> "MissingField" | BadSlices _ -> "BadSlices" | BadSlice _ -> "BadSlice" | EmptySlice -> "EmptySlice" | TypeInferenceNeeded -> "TypeInferenceNeeded" | UndefinedIdentifier _ -> "UndefinedIdentifier" | MismatchedReturnValue _ -> "MismatchedReturnValue" | BadArity _ -> "BadArity" | BadParameterArity _ -> "BadParameterArity" | UnsupportedBinop _ -> "UnsupportedBinop" | UnsupportedUnop _ -> "UnsupportedUnop" | UnsupportedExpr _ -> "UnsupportedExpr" | UnsupportedTy _ -> "UnsupportedTy" | InvalidExpr _ -> "InvalidExpr" | MismatchType _ -> "MismatchType" | NotYetImplemented _ -> "NotYetImplemented" | ObsoleteSyntax _ -> "ObsoleteSyntax" | ConflictingTypes _ -> "ConflictingTypes" | AssertionFailed _ -> "AssertionFailed" | CannotParse -> "CannotParse" | UnknownSymbol -> "UnknownSymbol" | NoCallCandidate _ -> "NoCallCandidate" | TooManyCallCandidates _ -> "TooManyCallCandidates" | BadTypesForBinop _ -> "BadTypesForBinop" | CircularDeclarations _ -> "CircularDeclarations" | ImpureExpression _ -> "ImpureExpression" | UnreconciliableTypes _ -> "UnreconciliableTypes" | AssignToImmutable _ -> "AssignToImmutable" | AlreadyDeclaredIdentifier _ -> "AlreadyDeclaredIdentifier" | BadReturnStmt _ -> "BadReturnStmt" | UnexpectedSideEffect _ -> "UnexpectedSideEffect" | UncaughtException _ -> "UncaughtException" | OverlappingSlices _ -> "OverlappingSlices" | BadLDI _ -> "BadLDI" | BadRecursiveDecls _ -> "BadRecursiveDecls" | UnrespectedParserInvariant -> "UnrespectedParserInvariant" | BadATC _ -> "BadATC" | ConstrainedIntegerExpected _ -> "ConstrainedIntegerExpected" | ParameterWithoutDecl _ -> "ParameterWithoutDecl" | BadParameterDecl _ -> "BadParameterDecl" | BaseValueEmptyType _ -> "BaseValueEmptyType" | ArbitraryEmptyType _ -> "ArbitraryEmptyType" | BaseValueNonStatic _ -> "BaseValueNonStatic" | SettingIntersectingSlices _ -> "SettingIntersectingSlices" | SetterWithoutCorrespondingGetter _ -> "SetterWithoutCorrespondingGetter" | NonReturningFunction _ -> "NonReturningFunction" | UnexpectedATC -> "UnexpectedATC" | UnreachableReached -> "UnreachableReached" | LoopLimitReached -> "LoopLimitReached" | RecursionLimitReached -> "RecursionLimitReached" | EmptyConstraints -> "EmptyConstraints" | UnexpectedPendingConstrained -> "UnexpectedPendingConstrained" | BitfieldsDontAlign _ -> "BitfieldsDontAlign" | BadPrintType _ -> "BadPrintType" | ConflictingSideEffects _ -> "ConflictingSideEffects" | ConfigTimeBroken _ -> "ConfigTimeBroken" | ConstantTimeBroken _ -> "ConstantTimeBroken" | MultipleWrites _ -> "MultipleWrites" | UnexpectedInitialisationThrow _ -> "UnexpectedInitialisationThrow" let warning_label = function | NoLoopLimit -> "NoLoopLimit" | IntervalTooBigToBeExploded _ -> "IntervalTooBigToBeExploded" | ConstraintSetPairToBigToBeExploded _ -> "ConstraintSetPairToBigToBeExploded" | RemovingValuesFromConstraints _ -> "RemovingValuesFromConstraints" | NoRecursionLimit _ -> "NoRecursionLimit" | PragmaUse _ -> "PragmaUse" module PPrint = struct open Format open PP let pp_comma_list pp_elt f li = pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") pp_elt f li let pp_type_desc f ty = pp_ty f (ASTUtils.add_dummy_annotation ty) let pp_error_desc f e = pp_open_hovbox f 2; (match e.desc with | ReservedIdentifier id -> fprintf f "ASL Lexical error: %S is a reserved keyword." id | UnsupportedBinop (t, op, v1, v2) -> fprintf f "ASL %s error: Illegal application of operator %s for values@ %a@ \ and %a." (error_handling_time_to_string t) (binop_to_string op) pp_literal v1 pp_literal v2 | UnsupportedUnop (t, op, v) -> fprintf f "ASL %s error: Illegal application of operator %s for value@ %a." (error_handling_time_to_string t) (unop_to_string op) pp_literal v | UnsupportedExpr (t, e) -> fprintf f "ASL %s Error: Unsupported expression %a." (error_handling_time_to_string t) pp_expr e | UnsupportedTy (t, ty) -> fprintf f "ASL %s Error: Unsupported type %a." (error_handling_time_to_string t) pp_ty ty | InvalidExpr e -> fprintf f "ASL Error: invalid expression %a." pp_expr e | MismatchType (v, [ ty ]) -> fprintf f "ASL Execution error: Mismatch type:@ value %s does not belong to \ type %a." v pp_type_desc ty | MismatchType (v, li) -> fprintf f "ASL Execution error: Mismatch type:@ value %s@ does not subtype any \ of those types:@ %a" v (pp_comma_list pp_type_desc) li | BadField (s, ty) -> fprintf f "ASL Error: There is no field '%s'@ on type %a." s pp_ty ty | MissingField (fields, ty) -> fprintf f "ASL Error: Fields mismatch for creating a value of type %a@ -- \ Passed fields are:@ %a" pp_ty ty (pp_print_list ~pp_sep:pp_print_space pp_print_string) fields | EmptySlice -> assert (e.version = V0); pp_print_text f "ASL Static Error: cannot slice with empty slicing operator. This \ might also be due to an incorrect getter/setter invocation." | BadSlices (t, slices, length) -> fprintf f "ASL %s error: Cannot extract from bitvector of length %d slice %a." (error_handling_time_to_string t) length pp_slice_list slices | BadSlice slice -> fprintf f "ASL Static error: invalid slice %a." pp_slice slice | TypeInferenceNeeded -> pp_print_text f "ASL Internal error: Interpreter blocked. Type inference needed." | UndefinedIdentifier s -> fprintf f "ASL Error: Undefined identifier:@ '%s'" s | MismatchedReturnValue s -> fprintf f "ASL Error: Mismatched use of return value from call to '%s'." s | BadArity (t, name, expected, provided) -> fprintf f "ASL %s Error: Arity error while calling '%s':@ %d arguments \ expected and %d provided." (error_handling_time_to_string t) name expected provided | BadParameterArity (t, version, name, expected, provided) -> ( match (t, version) with | Static, V0 -> fprintf f "ASL %s Error: Could not infer all parameters while calling \ '%s':@ %d parameters expected and %d inferred" (error_handling_time_to_string t) name expected provided | _ -> fprintf f "ASL %s Error: Arity error while calling '%s':@ %d parameters \ expected and %d provided" (error_handling_time_to_string t) name expected provided) | NotYetImplemented s -> pp_print_text f @@ "ASL Internal error: Not yet implemented: " ^ s | ObsoleteSyntax s -> fprintf f "%a@ %s" pp_print_text "ASL Grammar error: Obsolete syntax:" s | ConflictingTypes ([ expected ], provided) -> fprintf f "ASL Typing error:@ a subtype of@ %a@ was expected,@ provided %a." pp_type_desc expected pp_ty provided | ConflictingTypes (expected, provided) -> fprintf f "ASL Typing error:@ %a does@ not@ subtype@ any@ of:@ %a." pp_ty provided (pp_comma_list pp_type_desc) expected | AssertionFailed e -> fprintf f "ASL Execution error: Assertion failed:@ %a." pp_expr e | CannotParse -> pp_print_string f "ASL Error: Cannot parse." | UnknownSymbol -> pp_print_string f "ASL Error: Unknown symbol." | NoCallCandidate (name, types) -> fprintf f "ASL Typing error: No subprogram declaration matches the \ invocation:@ %s(%a)." name (pp_comma_list pp_ty) types | TooManyCallCandidates (name, types) -> fprintf f "ASL Typing error: Too many subprogram declaration match the \ invocation:@ %s(%a)." name (pp_comma_list pp_ty) types | BadTypesForBinop (op, t1, t2) -> fprintf f "ASL Typing error: Illegal application of operator %s on types@ %a@ \ and %a." (binop_to_string op) pp_ty t1 pp_ty t2 | CircularDeclarations x -> fprintf f "ASL Evaluation error: circular definition of constants, including \ %S." x | ImpureExpression (e, ses) -> fprintf f "ASL Typing error:@ a pure expression was expected,@ found %a,@ \ which@ produces@ the@ following@ side-effects:@ %a." pp_expr e SideEffect.SES.pp_print ses | UnreconciliableTypes (t1, t2) -> fprintf f "ASL Typing error:@ cannot@ find@ a@ common@ ancestor@ to@ those@ \ two@ types@ %a@ and@ %a." pp_ty t1 pp_ty t2 | AssignToImmutable x -> fprintf f "ASL Typing error:@ cannot@ assign@ to@ immutable@ storage@ %S." x | AlreadyDeclaredIdentifier x -> fprintf f "ASL Typing error:@ cannot@ declare@ already@ declared@ element@ %S." x | BadReturnStmt None -> pp_print_text f "ASL Typing error: cannot return something from a procedure." | UnexpectedSideEffect s -> fprintf f "Unexpected side-effect: %s." s | UncaughtException s -> fprintf f "Uncaught exception: %s." s | OverlappingSlices (slices, t) -> fprintf f "ASL %s error:@ overlapping slices@ @[%a@]." (error_handling_time_to_string t) pp_slice_list slices | BadLDI ldi -> fprintf f "Unsupported declaration:@ @[%a@]." pp_local_decl_item ldi | BadRecursiveDecls decls -> fprintf f "ASL Typing error:@ multiple recursive declarations:@ @[%a@]." (pp_comma_list (fun f -> fprintf f "%S")) decls | UnrespectedParserInvariant -> fprintf f "Parser invariant broke." | ConstrainedIntegerExpected t -> fprintf f "ASL Typing error:@ constrained@ integer@ expected,@ provided@ %a." pp_ty t | ParameterWithoutDecl s -> fprintf f "ASL Typing error:@ explicit@ parameter@ %S@ does@ not@ have@ a@ \ corresponding@ defining@ argument." s | BadParameterDecl (name, expected, actual) -> fprintf f "ASL Typing error:@ incorrect@ parameter@ declaration@ for@ %S,@ \ expected@ @[{%a}@]@ but@ @[{%a}@]@ provided" name (pp_comma_list pp_print_string) expected (pp_comma_list pp_print_string) actual | ArbitraryEmptyType t -> fprintf f "ASL Execution error: ARBITRARY of empty type %a." pp_ty t | BaseValueEmptyType t -> fprintf f "ASL Typing error: base value of empty type %a." pp_ty t | BaseValueNonStatic (t, e) -> fprintf f "ASL Typing error:@ base@ value@ of@ type@ %a@ cannot@ be@ \ statically@ determined@ since@ it@ consists@ of@ %a." pp_ty t pp_expr e | BadATC (t1, t2) -> fprintf f "ASL Typing error:@ cannot@ perform@ Asserted@ Type@ Conversion@ on@ \ %a@ by@ %a." pp_ty t1 pp_ty t2 | SettingIntersectingSlices bitfields -> fprintf f "ASL Typing error:@ setting@ intersecting@ bitfields@ [%a]." pp_bitfields bitfields | SetterWithoutCorrespondingGetter func -> let ret, args = match func.args with | (_, ret) :: args -> (ret, List.map snd args) | _ -> assert false in fprintf f "ASL Typing error:@ setter@ \"%s\"@ does@ not@ have@ a@ \ corresponding@ getter@ of@ signature@ @[@[%a@]@ ->@ %a@]." func.name (pp_comma_list pp_ty) args pp_ty ret | UnexpectedATC -> pp_print_text f "ASL Typing error: unexpected ATC." | BadPattern (p, t) -> fprintf f "ASL Typing error:@ Erroneous@ pattern@ %a@ for@ expression@ of@ \ type@ %a." pp_pattern p pp_ty t | UnreachableReached -> pp_print_text f "ASL Dynamic error: Unreachable reached." | NonReturningFunction name -> fprintf f "ASL Typing error:@ the@ function %S@ %a." name pp_print_text "may not terminate by returning a value or raising an exception." | RecursionLimitReached -> pp_print_text f "ASL Dynamic error: recursion limit reached." | LoopLimitReached -> pp_print_text f "ASL Dynamic error: loop limit reached." | ConflictingSideEffects (s1, s2) -> fprintf f "ASL Typing error: conflicting side effects %a and %a" SideEffect.pp_print s1 SideEffect.pp_print s2 | ConfigTimeBroken (e, ses) -> fprintf f "ASL Typing error:@ expected@ config-time@ expression,@ got@ %a,@ \ which@ produces@ the@ following@ side-effects:@ %a." pp_expr e SideEffect.SES.pp_print ses | ConstantTimeBroken (e, ses) -> fprintf f "ASL Typing error:@ expected@ constant-time@ expression,@ got@ %a,@ \ which@ produces@ the@ following@ side-effects:@ %a." pp_expr e SideEffect.SES.pp_print ses | BadReturnStmt (Some t) -> fprintf f "ASL Typing error:@ cannot@ return@ nothing@ from@ a@ function,@ an@ \ expression@ of@ type@ %a@ is@ expected." pp_ty t | EmptyConstraints -> pp_print_text f "ASL Typing error: a well-constrained integer cannot have empty \ constraints." | BadPrintType t -> fprintf f "ASL Typing error:@ %a@ %a." pp_print_text "print and println only accept singular types, found" pp_ty t | UnexpectedPendingConstrained -> pp_print_text f "ASL Typing error: a pending constrained integer is illegal here." | BitfieldsDontAlign { field1_absname; field2_absname; field1_absslices; field2_absslices } -> fprintf f "ASL Typing error:@ bitfields `%s` and `%s` are in the same scope \ but define different slices of the containing bitvector type: %s \ and %s, respectively." field1_absname field2_absname field1_absslices field2_absslices | UnexpectedInitialisationThrow (exception_ty, global_storage_element_name) -> fprintf f "ASL Execution error:@ unexpected@ exception@ %a@ thrown@ during@ \ the@ evaluation@ of@ the@ initialisation@ of@ the global@ storage@ \ element@ %S." pp_ty exception_ty global_storage_element_name | MultipleWrites id -> fprintf f "ASL Typing error:@ multiple@ writes@ to@ %S." id); pp_close_box f () let pp_warning_desc f w = match w.desc with | NoRecursionLimit [ name ] -> fprintf f "@[ASL Warning:@ the recursive function %s%a@]" name pp_print_text " has no recursive limit annotation." | NoRecursionLimit li -> fprintf f "@[ASL Warning:@ the mutually-recursive functions @[%a@]%a@]" (pp_comma_list pp_print_string) li pp_print_text " have no recursive limit annotation." | NoLoopLimit -> fprintf f "@[%a@]" pp_print_text "ASL Warning: Loop does not have a limit." | ConstraintSetPairToBigToBeExploded { op; left; right; log_max } -> fprintf f "@[%a@ %s@ %a%d@ with@ constraints@ %a@ and@ %a.@ %a@]" pp_print_text "Exploding sets for the binary operation" (binop_to_string op) pp_print_text "could result in a constraint set bigger than 2^" log_max PP.pp_int_constraints left PP.pp_int_constraints right pp_print_text "Continuing with the non-expanded constraints." | IntervalTooBigToBeExploded (za, zb) -> fprintf f "@[Interval too large: @[[ %a .. %a ]@].@ Keeping it as an \ interval.@]" Z.pp_print za Z.pp_print zb | RemovingValuesFromConstraints { op; prev; after } -> fprintf f "@[Warning:@ Removing@ some@ values@ that@ would@ fail@ with@ op %s@ \ from@ constraint@ set@ @[{%a}@]@ gave@ @[{%a}@].@ Continuing@ \ with@ this@ constraint@ set.@]" (binop_to_string op) PP.pp_int_constraints prev PP.pp_int_constraints after | PragmaUse id -> fprintf f "@[ASL Warning:@ pragma %s%a@]" id pp_print_text " will be ignored." let pp_pos_begin f pos = if pos.pos_end != Lexing.dummy_pos && pos.pos_start != Lexing.dummy_pos then fprintf f "@[%a:@]@ " pp_pos pos let pp_error f e = fprintf f "@[%a%a@]" pp_pos_begin e pp_error_desc e let pp_warning f e = fprintf f "@[%a%a@]" pp_pos_begin e pp_warning_desc e let error_desc_to_string = asprintf "%a" pp_error_desc let desc_to_string_inf pp_desc = asprintf "%a" @@ fun f e -> pp_set_margin f 1_000_000_000; pp_desc f e let error_to_string = asprintf "%a" pp_error end include PPrint let escape s = let b = Buffer.create (String.length s) in String.iter (function | '"' -> Buffer.add_char b '"'; Buffer.add_char b '"' | c -> Buffer.add_char b c) s; Buffer.contents b let pp_csv pp_desc label = let pos_in_line pos = Lexing.(pos.pos_cnum - pos.pos_bol) in fun f pos -> Printf.fprintf f "\"%s\",%d,%d,%d,%d,%s,\"%s\"" (escape pos.pos_start.pos_fname) pos.pos_start.pos_lnum (pos_in_line pos.pos_start) pos.pos_end.pos_lnum (pos_in_line pos.pos_end) (label pos.desc) (desc_to_string_inf pp_desc pos |> escape) let pp_error_csv f e = pp_csv pp_error_desc error_label f e let pp_warning_csv f w = pp_csv pp_warning_desc warning_label f w type output_format = HumanReadable | CSV module type ERROR_PRINTER_CONFIG = sig val output_format : output_format end module ErrorPrinter (C : ERROR_PRINTER_CONFIG) = struct let eprintln e = match C.output_format with | HumanReadable -> Format.eprintf "@[<2>%a@]@." pp_error e | CSV -> Printf.eprintf "%a\n" pp_error_csv e let warn w = match C.output_format with | HumanReadable -> Format.eprintf "@[<2>%a@]@." pp_warning w | CSV -> Printf.eprintf "%a\n" pp_warning_csv w let warn_from ~loc w = ASTUtils.add_pos_from loc w |> warn end let () = Printexc.register_printer @@ function | ASLException e -> Some (error_to_string e) | _ -> None herd-herdtools7-1ca343e/asllib/gparser0.ml000066400000000000000000000203341475314470400204670ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) (* This Module implements some sort of a GLR parser for ASLv0. Such work is needed because ASLv0 is not a LR language, as the following statements show: if A < B && C > then ... if A < B && C > D then ... (some_type, some_type, some_type, some_type) result = ... (some_var_, some_var_, some_var_, some_var_) = ... The following replacements have been found, and implemented: - LT --> RBRACK, LT - GT --> LBRACK, GT The following replacements have been found, but not implemented - LPAREN --> LPAREN, - RPAREN --> RPAREN, It tries to work as follows: - for each possible ambiguous token, we try the possible tokens in order of most used path. - If an error is found, we try the next possible token - If it is accepted, we accept the constructed ast. For backtracking to be possible, the lexer should be repeatable. This has been implemented in the lexer_state module, that uses a mutable record to store both the lexer past tokens. Assumptions: - Finding if a replacement works or not should be quick (i.e. if it does not work, it fails after a few steps), as it should at most go to the end of the current statement. - The parser rules should be completely functionnal (or at least repeating them would not break anything). - Lexing should not fail eagerly. *) open Parser0 open Lexing module I = MenhirInterpreter module RL = RepeatableLexer type token_pos = token * position * position type lexer_state = token RL.state type 'a result = 'a Error.result let _dbg = false let toks = SimpleLexer0.string_of_token let is_eof = function EOF -> true | _ -> false let _max_lines = Hashtbl.create ~random:false 3 let _min_err e1 e2 = let open Error in let open AST in match (e1.desc, e2.desc) with | CannotParse, CannotParse -> if e1.pos_start.pos_lnum > e2.pos_start.pos_lnum then e1 else e2 | _ -> e2 let list_first (f : 'a -> 'b result) : 'a list -> 'b result = let rec aux e1 : 'a list -> 'b result = function | [] -> Error e1 | x :: t -> ( match f x with Ok res -> Ok res | Error e2 -> aux (_min_err e1 e2) t) in function | [] -> assert false | x :: t -> ( match f x with Ok res -> Ok res | Error e1 -> aux e1 t) let try_in_order (process : lexer_state -> token -> AST.t) lexer_state : token list -> AST.t = let one_possibility tok = if _dbg then Format.eprintf "@[Trying %s :@ @[" (toks tok); try let res = process (RL.copy lexer_state) tok in if _dbg then Format.eprintf "@]"; Ok res with Error.ASLException e -> if _dbg then Format.eprintf "@]@ Did not work (%S).@]@ " (toks tok); Error e in fun tokens -> let () = if _dbg then Format.eprintf "@]@ " in match list_first one_possibility tokens with | Ok res -> res | Error e -> Error.fatal e (** Main loop of the interpreter. Inspired by menhir documentation. *) let rec loop lexer_state (p1, p2) : 'a I.checkpoint -> AST.t = function | I.InputNeeded _ as cpt -> ( let tok, p1, p2 = RL.get lexer_state in let () = if false then Format.eprintf "@[<3>Reading token %s@ at position@ @[%a@]@]@." (SimpleLexer0.string_of_token tok) PP.pp_pos (ASTUtils.annotated () p1 p2 V0) in let continue = continue cpt (p1, p2) in match tok with | LT -> try_in_order continue lexer_state [ LBRACK; LT ] | GT -> try_in_order continue lexer_state [ RBRACK; GT ] | RETURN -> let () = if false then Format.eprintf "Seen pos %a@ " PP.pp_pos (ASTUtils.annotated () p1 p2 V0) in continue lexer_state tok | tok -> continue lexer_state tok) | (I.Shifting _ | I.AboutToReduce _) as checkpoint -> loop lexer_state (p1, p2) (I.resume checkpoint) | I.HandlingError _ -> let () = if true then match Hashtbl.find_opt _max_lines p1.pos_fname with | None -> Hashtbl.add _max_lines p1.pos_fname p1 | Some p -> if false && p.pos_lnum < p1.pos_lnum then ( Hashtbl.add _max_lines p1.pos_fname p1; Format.eprintf "@[%a:@ Found error.@]@." PP.pp_pos (ASTUtils.annotated () p1 p2 V0)) in Error.fatal_here p1 p2 Error.CannotParse | I.Accepted ast -> ast | I.Rejected -> assert false (** Continuation for [try_in_order] *) and continue cpt (p1, p2) lexer_state tok = let () = if false && _dbg then Format.eprintf "%s@ " (toks tok) in loop lexer_state (p1, p2) @@ I.offer cpt (tok, p1, p2) (** Alternative entry-point for this module. This one take directly a repeatableLexer. *) let parse_repeatable parse lexer_state lexbuf : AST.t = if _dbg then Format.eprintf "@[Starting parsing...@ @["; let first_checkpoint = parse lexbuf.lex_curr_p in let res = loop lexer_state (lexbuf.lex_start_p, lexbuf.lex_curr_p) first_checkpoint in let () = if _dbg then Format.eprintf "@]@." in res let ast_chunk lexbuf = let lexer = Lexer0.token () in let lexer_state = RL.of_lexer_lexbuf is_eof lexer lexbuf in let r = parse_repeatable Parser0.Incremental.spec lexer_state lexbuf in if false then Printf.eprintf "Chunk of size %d\n" (List.length r); r (** The main entry-point for this module. Should be usable as a drop-in replacement for [Parser0.spec]. *) (* Set [as_chunks] to false parsing ASL files as a whole *) let as_chunks = true let ast (lexer : lexbuf -> token) (lexbuf : lexbuf) : AST.t = if as_chunks then let fname = lexbuf.Lexing.lex_curr_p.Lexing.pos_fname in let asts = Seq.fold_left (fun k (start, chunk) -> if false then Printf.eprintf "Chunk (line %d, file %s) ***\n%s\n***\n%!" start fname chunk; let lexbuf = Lexing.from_string chunk in let lcp = lexbuf.Lexing.lex_curr_p in let lcp = { lcp with Lexing.pos_fname = fname; Lexing.pos_lnum = start } in let lexbuf = { lexbuf with lex_curr_p = lcp } in let ast = ast_chunk lexbuf in ast :: k) [] (Splitasl.split lexbuf) in List.concat (List.rev asts) else let lexer_state = RL.of_lexer_lexbuf is_eof lexer lexbuf in parse_repeatable Parser0.Incremental.spec lexer_state lexbuf let opn (lexer : lexbuf -> token) (lexbuf : lexbuf) : AST.t = let () = if _dbg then Format.eprintf "Starting parsing opn in file %s@." lexbuf.lex_curr_p.pos_fname in let lexer_state = RL.of_lexer_lexbuf is_eof lexer lexbuf in let res = parse_repeatable Parser0.Incremental.opn lexer_state lexbuf in let () = if _dbg then Format.eprintf "Parsed opn.@." in res herd-herdtools7-1ca343e/asllib/index.html000066400000000000000000000007311475314470400204060ustar00rootroot00000000000000
herd-herdtools7-1ca343e/asllib/instrumentation.ml000066400000000000000000000615001475314470400222070ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) (** Provide some instrumentation backends for {!Interpreter} and {!Typing}. *) module SemanticsRule = struct type t = | ELit | Call | ATC | EExprList | EExprListM | ESideEffectFreeExpr | EVar | Binop | BinopAnd | BinopOr | BinopImpl | Unop | ECondSimple | ECond | ESlice | ECall | EGetArray | EGetEnumArray | ESliceError | ERecord | EGetBitField | EGetBitFields | EGetTupleItem | EConcat | ETuple | EArray | EEnumArray | EArbitrary | EPattern | LEDiscard | LEVar | LEMultiAssign | LEUndefIdentV0 | LEUndefIdentV1 | LESlice | LESetArray | LESetEnumArray | LESetField | LESetFields | LEDestructuring | Slices | Slice | PAll | PAny | PGeq | PLeq | PNot | PRange | PSingle | PMask | PTuple | LDDiscard | LDVar | LDTuple | SPass | SAssignCall | SAssign | SReturn | SSeq | SCall | SCond | SCase | SAssert | SWhile | SRepeat | SFor | SThrow | STry | SDecl | SPrint | FUndefIdent | FPrimitive | FBadArity | FCall | Block | Loop | For | Catch | CatchNamed | CatchOtherwise | CatchNone | CatchNoThrow | Spec | FindCatcher | RethrowImplicit | ReadValueFrom | BuildGlobalEnv | IsConstraintSat | AssignArgs let to_string : t -> string = function | ELit -> "ELit" | Call -> "Call" | ATC -> "CTC" | EExprList -> "EExprList" | EExprListM -> "EExprListM" | ESideEffectFreeExpr -> "ESideEffectFreeExpr" | EVar -> "EVar" | Binop -> "Binop" | BinopAnd -> "BinopAnd" | BinopOr -> "BinopOr" | BinopImpl -> "BinopImpl" | Unop -> "Unop" | ECond -> "ECond" | ESlice -> "ESlice" | ECall -> "ECall" | ERecord -> "ERecord" | EGetBitField -> "EGetBitField" | EGetBitFields -> "EGetBitFields" | EGetTupleItem -> "EGetTupleItem" | EConcat -> "EConcat" | ETuple -> "ETuple" | EArray -> "EArray" | EEnumArray -> "EEnumArray" | ECondSimple -> "ECondSimple" | EGetArray -> "EGetArray" | EGetEnumArray -> "EGetEnumArray" | ESliceError -> "ESliceError" | EArbitrary -> "EArbitrary" | EPattern -> "EPattern" | LEDiscard -> "LEDiscard" | LEVar -> "LEVar" | LEMultiAssign -> "LEMultiAssign" | LESlice -> "LESlice" | LESetArray -> "LESetArray" | LESetEnumArray -> "LESetEnumArray" | LESetField -> "LESetField" | LESetFields -> "LESetFields" | LEDestructuring -> "LEDestructuring" | LEUndefIdentV0 -> "LEUndefIdentV0" | LEUndefIdentV1 -> "LEUndefIdentV1" | Slices -> "Slices" | Slice -> "Slice" | PAll -> "PAll" | PAny -> "PAny" | PGeq -> "PGeq" | PLeq -> "PLeq" | PNot -> "PNot" | PRange -> "PRange" | PSingle -> "PSingle" | PMask -> "PMask" | PTuple -> "PTuple" | LDDiscard -> "LDDiscard" | LDVar -> "LDVar" | LDTuple -> "LDTuple" | SPass -> "SPass" | SAssignCall -> "SAssignCall" | SAssign -> "SAssign" | SReturn -> "SReturn" | SSeq -> "SThen" | SCall -> "SCall" | SCond -> "SCond" | SCase -> "SCase" | SAssert -> "SAssert" | SWhile -> "SWhile" | SRepeat -> "SRepeat" | SFor -> "SFor" | SThrow -> "SThrow" | STry -> "STry" | SDecl -> "SDecl" | SPrint -> "SPrint" | FUndefIdent -> "FUndefIdent" | FPrimitive -> "FPrimitive" | FBadArity -> "FBadArity" | FCall -> "FCall" | Block -> "Block" | Loop -> "Loop" | For -> "For" | Catch -> "Catch" | CatchNamed -> "CatchNamed" | CatchOtherwise -> "CatchOtherwise" | CatchNone -> "CatchNone" | CatchNoThrow -> "CatchNoThrow" | Spec -> "Spec" | FindCatcher -> "FindCatcher" | RethrowImplicit -> "RethrowImplicit" | ReadValueFrom -> "ReadValueFrom" | BuildGlobalEnv -> "BuildGlobalEnv" | IsConstraintSat -> "IsConstraintSat" | AssignArgs -> "AssignArgs" let pp f r = to_string r |> Format.pp_print_string f let all = [ ELit; Call; ATC; EExprList; EExprListM; ESideEffectFreeExpr; EVar; Binop; BinopAnd; BinopOr; BinopImpl; Unop; ECondSimple; ECond; ESlice; ECall; EGetArray; EGetEnumArray; ESliceError; ERecord; EGetBitField; EGetBitFields; EGetTupleItem; EConcat; ETuple; EArray; EEnumArray; EArbitrary; EPattern; LEDiscard; LEVar; LEMultiAssign; LEUndefIdentV0; LEUndefIdentV1; LESlice; LESetArray; LESetEnumArray; LESetField; LESetFields; LEDestructuring; Slices; Slice; PAll; PAny; PGeq; PLeq; PNot; PRange; PSingle; PMask; PTuple; LDDiscard; LDVar; LDTuple; SPass; SAssignCall; SAssign; SReturn; SSeq; SCall; SCond; SCase; SAssert; SWhile; SRepeat; SFor; SThrow; STry; SDecl; SPrint; FUndefIdent; FPrimitive; FBadArity; FCall; Block; Loop; For; Catch; CatchNamed; CatchOtherwise; CatchNone; CatchNoThrow; Spec; FindCatcher; RethrowImplicit; ReadValueFrom; BuildGlobalEnv; IsConstraintSat; AssignArgs; ] let all_nb = List.length all let index = let tbl : (t, int) Hashtbl.t = Hashtbl.create all_nb in let () = List.iteri (fun i r -> Hashtbl.add tbl r i) all in Hashtbl.find tbl let of_string = let tbl : (string, t) Hashtbl.t = Hashtbl.create all_nb in let () = List.iter (fun r -> Hashtbl.add tbl (to_string r |> String.lowercase_ascii) r) all in fun s -> Hashtbl.find tbl (String.lowercase_ascii s) end type semantics_rule = SemanticsRule.t module SemanticsCmp : Set.OrderedType with type t = semantics_rule = struct type t = semantics_rule let compare = compare end module TypingRule = struct type t = | BuiltinSingularType | BuiltinAggregateType | BuiltinSingularOrAggregate | NamedType | AnonymousType | SingularType | AggregateType | NonPrimitiveType | PrimitiveType | Structure | Canonical | Domain | Subtype | StructuralSubtypeSatisfaction | DomainSubtypeSatisfaction | SubtypeSatisfaction | TypeSatisfaction | TypeClash | LowestCommonAncestor | ApplyUnopType | ApplyBinopTypes | ELit | ATC | EVar | Binop | Unop | ECondSimple | ECond | ESlice | ECall | ESetter | EGetArray | ESliceError | ERecord | EGetRecordField | EGetBitField | EGetBadField | EGetBadBitField | EGetBadRecordField | EGetBitFieldNested | EGetBitFieldTyped | EGetTupleItem | EGetFields | EConcat | ETuple | EArbitrary | EPattern | LEDiscard | LEVar | LEUndefIdentV0 | LEUndefIdentV1 | LEDestructuring | LESlice | LESetArray | LESetStructuredField | LESetBadBitField | LESetBitField | LESetBadField | LESetFields | LEConcat | Slice | PAll | PAny | PGeq | PLeq | PNot | PRange | PSingle | PMask | PTuple | LDDiscard | LDVar | LDTuple | LDUninitialisedVar | LDUninitialisedTyped | SPass | SAssignCall | SAssign | SReturn | SSeq | SCall | SCond | SCase | SAssert | SWhile | SRepeat | SFor | SThrow | STry | SDecl | SPrint | SPragma | FUndefIdent | FPrimitive | FBadArity | FindCheckDeduce | AnnotateCall | AnnotateCallArgTyped | Block | Loop | For | Catcher | Subprogram | DeclareOneFunc | DeclareGlobalStorage | DeclareTypeDecl | Specification | TString | TReal | TBool | TNamed | TInt | TBits | TTuple | TArray | TEnumDecl | TStructuredDecl | TNonDecl | TBitField | TBitFields | ReduceSlicesToCall | TypeOfArrayLength | TypecheckDecl | CheckGlobalPragma | AnnotateAndDeclareFunc | AnnotateFuncSig | CheckSetterHasGetter | AddNewFunc | SubprogramForName | HasArgClash | GetUndeclaredDefining | AnnotateOneParam | AnnotateParams | ArgsAsParams | AnnotateArgs | StaticEval | ReduceConstants | Normalize | RenameTyEqs | TypeCheckMutuallyRec | DeclareSubprograms | AnnotateLimitExpr | CheckATC | CheckSlicesInWidth | DisjointSlicesToPositions | BitfieldSliceToPositions | CheckPositionsInWidth | ShouldReduceToCall | IsSymbolicallyEvaluable | CheckSymbolicallyEvaluable | ShouldRememberImmutableExpression | AddImmutableExpression | SymIntSetSubset | SymDomIsSubset | ApproxConstraint | ApproxConstraints | LEBitSlice | AddLocalImmutableExpr | AddGlobalImmutableExpr | DeclareConst | AddGlobalStorage | LookupConstant | TypeOf | LookupImmutableExpr | WithEmptyLocal | IsGlobalUndefined | IsLocalUndefined | IsUndefined | IsSubprogram | CheckVarNotInEnv | CheckVarNotInGEnv | CheckDisjointSlices | ControlFlowFromStmt | AnnotateConstraintBinop | ConstraintBinop | ConstraintMod | ConstraintPow | ApplyBinopExtremities | PossibleExtremitiesLeft | PossibleExtremitiesRight | ControlFlowSeq | ControlFlowJoin | CheckCommonBitfieldsAlign | AnnotateFieldInit | AnnotateGetArray | AnnotateSetArray | GetBitvectorWidth | GetBitvectorConstWidth let to_string : t -> string = function | BuiltinSingularType -> "BuiltinSingularType" | BuiltinAggregateType -> "BuiltinAggregateType" | BuiltinSingularOrAggregate -> "BuiltinSingularOrAggregate" | NamedType -> "NamedType" | AnonymousType -> "AnonymousType" | SingularType -> "SingularType" | AggregateType -> "AggregateType" | NonPrimitiveType -> "NonPrimitiveType" | PrimitiveType -> "PrimitiveType" | Canonical -> "Canonical" | Domain -> "Domain" | Structure -> "Structure" | Subtype -> "Subtype" | StructuralSubtypeSatisfaction -> "StructuralSubtypeSatisfaction" | DomainSubtypeSatisfaction -> "DomainSubtypeSatisfaction" | SubtypeSatisfaction -> "SubtypeSatisfaction" | TypeSatisfaction -> "TypeSatisfaction" | TypeClash -> "TypeClash" | ApplyUnopType -> "ApplyUnopType" | ApplyBinopTypes -> "ApplyBinopTypes" | LowestCommonAncestor -> "LowestCommonAncestor" | ELit -> "ELit" | ATC -> "ATC" | EVar -> "EVar" | Binop -> "Binop" | Unop -> "Unop" | ECond -> "ECond" | ESlice -> "ESlice" | ECall -> "ECall" | ESetter -> "ESetter" | ERecord -> "ERecord" | EGetRecordField -> "EGetRecordField" | EGetBitField -> "EGetBitField" | EGetBadField -> "EGetBadField" | EGetBadBitField -> "EGetBadBitField" | EGetBadRecordField -> "EGetBadRecordField" | EGetBitFieldNested -> "EGetBitFieldNested" | EGetBitFieldTyped -> "EGetBitFieldTyped" | EGetTupleItem -> "EGetTupleItem" | EGetFields -> "EGetFields" | EConcat -> "EConcat" | ETuple -> "ETuple" | ECondSimple -> "ECondSimple" | EGetArray -> "EGetArray" | ESliceError -> "ESliceError" | EArbitrary -> "EArbitrary" | EPattern -> "EPattern" | LEDiscard -> "LEDiscard" | LEVar -> "LEVar" | LESlice -> "LESlice" | LESetArray -> "LESetArray" | LESetStructuredField -> "LESetStructuredField" | LESetBadBitField -> "LESetBadBitField" | LESetBitField -> "LESetBitField" | LESetBadField -> "LESetBadField" | LESetFields -> "LESetFields" | LEConcat -> "LEConcat" | LEDestructuring -> "LEDestructuring" | LEUndefIdentV0 -> "LEUndefIdentV0" | LEUndefIdentV1 -> "LEUndefIdentV1" | Slice -> "Slice" | PAll -> "PAll" | PAny -> "PAny" | PGeq -> "PGeq" | PLeq -> "PLeq" | PNot -> "PNot" | PRange -> "PRange" | PSingle -> "PSingle" | PMask -> "PMask" | PTuple -> "PTuple" | LDDiscard -> "LDDiscardNone" | LDVar -> "LDVar" | LDUninitialisedVar -> "LDUninitialisedVar" | LDUninitialisedTyped -> "LDUninitialisedTyped" | LDTuple -> "LDTuple" | SPass -> "SPass" | SAssignCall -> "SAssignCall" | SAssign -> "SAssign" | SReturn -> "SReturn" | SSeq -> "SThen" | SCall -> "SCall" | SCond -> "SCond" | SCase -> "SCase" | SAssert -> "SAssert" | SWhile -> "SWhile" | SRepeat -> "SRepeat" | SFor -> "SFor" | SThrow -> "SThrow" | STry -> "STry" | SDecl -> "SDecl" | SPrint -> "SPrint" | SPragma -> "SPragma" | FUndefIdent -> "FUndefIdent" | FPrimitive -> "FPrimitive" | FBadArity -> "FBadArity" | FindCheckDeduce -> "FindCheckDeduce" | AnnotateCall -> "AnnotateCall" | AnnotateCallArgTyped -> "AnnotateCallArgTyped" | Block -> "Block" | Loop -> "Loop" | For -> "For" | Catcher -> "Catcher" | Subprogram -> "Subprogram" | DeclareOneFunc -> "DeclareOneFunc" | DeclareGlobalStorage -> "DeclareGlobalStorage" | DeclareTypeDecl -> "DeclareTypeDecl" | Specification -> "Specification" | TString -> "TString" | TReal -> "TReal" | TBool -> "TBool" | TNamed -> "TNamed" | TInt -> "TInt" | TBits -> "TBits" | TTuple -> "TTuple" | TArray -> "TArray" | TEnumDecl -> "TEnumDecl" | TStructuredDecl -> "TStructuredDecl" | TNonDecl -> "TNonDecl" | TBitField -> "TBitField" | TBitFields -> "TBitFields" | ReduceSlicesToCall -> "ReduceSlicesToCall" | TypeOfArrayLength -> "TypeOfArrayLength" | TypecheckDecl -> "TypecheckDecl" | CheckGlobalPragma -> "CheckGlobalPragmas" | AnnotateAndDeclareFunc -> "AnnotateAndDeclareFunc" | AnnotateFuncSig -> "AnnotateFuncSig" | CheckSetterHasGetter -> "CheckSetterHasGetter" | AddNewFunc -> "AddNewFunc" | SubprogramForName -> "SubprogramForName" | HasArgClash -> "HasArgClash" | GetUndeclaredDefining -> "GetUndeclaredDefining" | AnnotateOneParam -> "AnnotateOneParam" | AnnotateParams -> "AnnotateParams" | ArgsAsParams -> "ArgsAsParams" | AnnotateArgs -> "AnnotateArgs" | StaticEval -> "StaticEval" | ReduceConstants -> "ReduceConstants" | Normalize -> "Normalize" | RenameTyEqs -> "RenameTyEqs" | TypeCheckMutuallyRec -> "TypeCheckMutuallyRec" | DeclareSubprograms -> "DeclareSubprograms" | AnnotateLimitExpr -> "AnnotateLimitExpr" | CheckATC -> "CheckATC" | CheckSlicesInWidth -> "CheckSlicesInWidth" | DisjointSlicesToPositions -> "DisjointSlicesToPositions" | BitfieldSliceToPositions -> "BitfieldSliceToPositions" | CheckPositionsInWidth -> "CheckPositionsInWidth" | ShouldReduceToCall -> "ShouldReduceToCall" | IsSymbolicallyEvaluable -> "IsSymbolicallyEvaluable" | CheckSymbolicallyEvaluable -> "CheckSymbolicallyEvaluable" | ShouldRememberImmutableExpression -> "ShouldRememberImmutableExpression" | AddImmutableExpression -> "AddImmutableExpression" | SymIntSetSubset -> "SymIntSetSubset" | SymDomIsSubset -> "SymDomIsSubset" | ApproxConstraint -> "ApproxConstraint" | ApproxConstraints -> "ApproxConstraints" | LEBitSlice -> "LEBitSlice" | AddLocalImmutableExpr -> "AddLocalImmutableExpr" | AddGlobalImmutableExpr -> "AddLocalImmutableExpr" | DeclareConst -> "DeclareConst" | AddGlobalStorage -> "AddGlobalStorage" | LookupConstant -> "LookupConstant" | TypeOf -> "TypeOf" | LookupImmutableExpr -> "LookupImmutableExpr" | WithEmptyLocal -> "WithEmptyLocal" | IsGlobalUndefined -> "IsGlobalUndefined" | IsLocalUndefined -> "IsLocalUndefined" | IsUndefined -> "IsUndefined" | IsSubprogram -> "IsSubprogram" | CheckVarNotInEnv -> "CheckVarNotInEnv" | CheckVarNotInGEnv -> "CheckVarNotInGEnv" | CheckDisjointSlices -> "CheckDisjointSlices" | ControlFlowFromStmt -> "ControlFlowFromStmt" | AnnotateConstraintBinop -> "AnnotateConstraintBinop" | ConstraintBinop -> "ConstraintBinop" | ConstraintMod -> "ConstraintMod" | ConstraintPow -> "ConstraintPow" | ApplyBinopExtremities -> "ApplyBinopExtremities" | PossibleExtremitiesLeft -> "PossibleExtremitiesLeft" | PossibleExtremitiesRight -> "PossibleExtremitiesRight" | ControlFlowSeq -> "ControlFlowSeq" | ControlFlowJoin -> "ControlFlowJoin" | CheckCommonBitfieldsAlign -> "CheckCommonBitfieldsAlign" | AnnotateFieldInit -> "AnnotateFieldInit" | AnnotateGetArray -> "AnnotateGetArray" | AnnotateSetArray -> "AnnotateSetArray" | GetBitvectorWidth -> "GetBitvectorWidth" | GetBitvectorConstWidth -> "GetBitvectorConstWidth" let pp f r = to_string r |> Format.pp_print_string f let all = [ BuiltinSingularType; BuiltinAggregateType; BuiltinSingularOrAggregate; SingularType; AggregateType; NamedType; AnonymousType; NonPrimitiveType; PrimitiveType; Canonical; Domain; Structure; Subtype; DomainSubtypeSatisfaction; StructuralSubtypeSatisfaction; SubtypeSatisfaction; TypeSatisfaction; TypeClash; ApplyUnopType; ApplyBinopTypes; LowestCommonAncestor; ELit; ATC; EVar; Binop; Unop; ECond; ESlice; ECall; ESetter; ERecord; EGetRecordField; EGetBadField; EGetBadBitField; EGetBadRecordField; EGetBitField; EGetBitFieldNested; EGetBitFieldTyped; EGetTupleItem; EGetFields; EArbitrary; EPattern; EGetArray; ESliceError; ECondSimple; EConcat; ETuple; LEDiscard; LEVar; LESlice; LESetArray; LESetStructuredField; LESetBadBitField; LESetBitField; LESetBadField; LESetFields; LESetFields; LEDestructuring; LEConcat; Slice; SPass; SAssignCall; SAssign; SReturn; SSeq; SCall; SCond; SCase; SAssert; SWhile; SRepeat; SFor; SThrow; STry; SDecl; SPrint; SPragma; FUndefIdent; FPrimitive; FBadArity; FindCheckDeduce; AnnotateCall; AnnotateCallArgTyped; Block; Loop; For; Catcher; Subprogram; TString; TReal; TBool; TNamed; TInt; TBits; TTuple; TArray; TEnumDecl; TStructuredDecl; TNonDecl; TBitField; TBitFields; ReduceSlicesToCall; TypeOfArrayLength; TypecheckDecl; CheckGlobalPragma; AnnotateAndDeclareFunc; AnnotateFuncSig; CheckSetterHasGetter; AddNewFunc; SubprogramForName; HasArgClash; GetUndeclaredDefining; AnnotateOneParam; AnnotateParams; ArgsAsParams; AnnotateArgs; StaticEval; ReduceConstants; Normalize; RenameTyEqs; TypeCheckMutuallyRec; DeclareSubprograms; AnnotateLimitExpr; CheckATC; CheckSlicesInWidth; DisjointSlicesToPositions; BitfieldSliceToPositions; CheckPositionsInWidth; ShouldReduceToCall; IsSymbolicallyEvaluable; CheckSymbolicallyEvaluable; ShouldRememberImmutableExpression; AddImmutableExpression; SymIntSetSubset; SymDomIsSubset; ApproxConstraint; ApproxConstraints; LEBitSlice; AddLocalImmutableExpr; AddGlobalImmutableExpr; DeclareConst; AddGlobalStorage; LookupConstant; TypeOf; LookupImmutableExpr; WithEmptyLocal; IsGlobalUndefined; IsLocalUndefined; IsUndefined; IsSubprogram; CheckVarNotInEnv; CheckVarNotInGEnv; CheckDisjointSlices; BitfieldSliceToPositions; ControlFlowFromStmt; AnnotateConstraintBinop; ConstraintBinop; ConstraintPow; ApplyBinopExtremities; PossibleExtremitiesLeft; PossibleExtremitiesRight; ControlFlowSeq; ControlFlowJoin; CheckCommonBitfieldsAlign; AnnotateFieldInit; AnnotateGetArray; AnnotateSetArray; GetBitvectorWidth; GetBitvectorConstWidth; ] let all_nb = List.length all let index = let tbl : (t, int) Hashtbl.t = Hashtbl.create all_nb in let () = List.iteri (fun i r -> Hashtbl.add tbl r i) all in Hashtbl.find tbl let of_string = let tbl : (string, t) Hashtbl.t = Hashtbl.create all_nb in let () = List.iter (fun r -> Hashtbl.add tbl (to_string r |> String.lowercase_ascii) r) all in fun s -> Hashtbl.find tbl (String.lowercase_ascii s) end type typing_rule = TypingRule.t module TypingCmp : Set.OrderedType with type t = typing_rule = struct type t = typing_rule let compare = compare end module SemanticsSet = Set.Make (SemanticsCmp) module TypingSet = Set.Make (TypingCmp) module SemanticsMap = Map.Make (SemanticsCmp) module TypingsMap = Map.Make (TypingCmp) module type SEMINSTR = sig val use : semantics_rule -> unit val use_with : 'a -> semantics_rule -> 'a end module type TYPINSTR = sig val use : typing_rule -> unit val use_with : 'a -> typing_rule -> 'a end module type SEMBUFFER = sig val push : semantics_rule -> unit val reset : unit -> unit val get : unit -> semantics_rule list end module type TYPBUFFER = sig val push : typing_rule -> unit val reset : unit -> unit val get : unit -> typing_rule list end module SemMake (Buffer : SEMBUFFER) : SEMINSTR = struct let use = Buffer.push let use_with (x : 'a) r : 'a = Buffer.push r; x end module TypMake (Buffer : TYPBUFFER) : TYPINSTR = struct let use = Buffer.push let use_with (x : 'a) r : 'a = Buffer.push r; x end module SemanticsNoBuffer : SEMBUFFER = struct let push = Fun.const () let reset () = () let get () = [] end module TypingNoBuffer : TYPBUFFER = struct let push = Fun.const () let reset () = () let get () = [] end module SemanticsSingleBuffer : SEMBUFFER = struct let _buffer : semantics_rule list ref = ref [] let reset () = _buffer := [] let get () = !_buffer let push r = _buffer := r :: !_buffer end module TypingSingleBuffer : TYPBUFFER = struct let _buffer : typing_rule list ref = ref [] let reset () = _buffer := [] let get () = !_buffer let push r = _buffer := r :: !_buffer end module SemanticsSingleSetBuffer : SEMBUFFER = struct let _semantics_buffer : (semantics_rule, unit) Hashtbl.t = Hashtbl.create SemanticsRule.all_nb let push r = Hashtbl.replace _semantics_buffer r () let reset () = Hashtbl.clear _semantics_buffer let get () = Hashtbl.to_seq_keys _semantics_buffer |> List.of_seq end module TypingSingleSetBuffer : TYPBUFFER = struct let _typing_buffer : (typing_rule, unit) Hashtbl.t = Hashtbl.create TypingRule.all_nb let push r = Hashtbl.replace _typing_buffer r () let reset () = Hashtbl.clear _typing_buffer let get () = Hashtbl.to_seq_keys _typing_buffer |> List.of_seq end module SemanticsNoInstr = SemMake (SemanticsNoBuffer) module TypingNoInstr = TypMake (TypingNoBuffer) module SemanticsSingleInstr = SemMake (SemanticsSingleBuffer) module TypingSingleInstr = TypMake (TypingSingleBuffer) module SemanticsSingleSetInstr = SemMake (SemanticsSingleSetBuffer) module TypingSingleSetInstr = TypMake (TypingSingleSetBuffer) let ( |: ) = TypingNoInstr.use_with herd-herdtools7-1ca343e/asllib/lexer0.ml000066400000000000000000000067531475314470400201540ustar00rootroot00000000000000(* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (**************************************************************** * ASL lexer support * * Copyright Arm Limited (c) 2017-2019 * SPDX-Licence-Identifier: BSD-3-Clause ****************************************************************) (** ASL lexer support *) open Lexing open Parser0 let print_position outx lexbuf = let pos = lexbuf.lex_curr_p in Printf.fprintf outx "%s:%d:%d" pos.pos_fname pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1) let starters : Parser0.token list = [ LPAREN; LBRACK; LBRACE; IF; ELSIF; WHILE ] let enders : Parser0.token list = [ RPAREN; RBRACK; RBRACE; THEN; DO ] type offside_state = { mutable stack : int list; (* indentation history *) mutable parens : int; (* number of outstanding openers *) mutable newline : bool; (* processing newline *) mutable next : Parser0.token; (* next token *) } let token () : Lexing.lexbuf -> Parser0.token = let state = { stack = [ 0 ]; parens = 0; newline = false; next = EOL } in let pushStack (col : int) : Parser0.token = state.stack <- col :: state.stack; INDENT in let getToken (buf : Lexing.lexbuf) : Parser0.token = let useToken _ : Parser0.token = let tok : Parser0.token = state.next in if List.mem tok starters then state.parens <- state.parens + 1 else if state.parens > 0 && List.mem tok enders then state.parens <- state.parens - 1; state.next <- SimpleLexer0.token buf; (* Printf.eprintf "Got token: %s\n" (SimpleLexer0.string_of_token tok); *) tok in let res = if state.parens > 0 then ( (* In parentheses: ignore EOL tokens *) while state.next = EOL do ignore (useToken ()) done; useToken ()) else if state.next = EOF then ( (* End of file: emit outstanding DEDENT tokens *) match state.stack with | [] | [ _ ] -> EOF | _d :: ds -> state.stack <- ds; DEDENT) else if state.next = EOL then ( while state.next = EOL do state.newline <- true; ignore (useToken ()) done; EOL) else if state.newline then let prev_col = List.hd state.stack in let pos = lexeme_start_p buf in let new_column = pos.pos_cnum - pos.pos_bol in if new_column > prev_col then ( state.newline <- false; pushStack new_column) else if new_column = prev_col then ( state.newline <- false; useToken ()) else ( state.stack <- List.tl state.stack; let target_column = List.hd state.stack in (* state.newline <- false; *) state.newline <- new_column <> target_column; (* This gives spurious warnings when indentation is * decremented in two steps. * * if new_column < target_column then begin * Printf.printf "Warning: incorrect indentation %d: %d %d\n" * buf.lex_curr_p.pos_lnum * new_column target_column * end; *) DEDENT) else useToken () in let () = if false then Printf.eprintf "Producing token %s\n" (SimpleLexer0.string_of_token res) in res in getToken (**************************************************************** * End ****************************************************************) herd-herdtools7-1ca343e/asllib/libdir/000077500000000000000000000000001475314470400176555ustar00rootroot00000000000000herd-herdtools7-1ca343e/asllib/libdir/stdlib.asl000066400000000000000000000304641475314470400216460ustar00rootroot00000000000000//------------------------------------------------------------------------------ // // ASL standard lib // //----------------------------------------------------------------------------- //------------------------------------------------------------------------------ // Externals // UInt // SInt //------------------------------------------------------------------------------ // Standard integer functions and procedures // SInt // UInt func Min(a: integer, b: integer) => integer begin return if a < b then a else b; end; func Max(a: integer, b: integer) => integer begin return if a > b then a else b; end; func Abs(x: integer) => integer begin return if x < 0 then -x else x; end; // Log2 // Return true if integer is even (0 modulo 2). func IsEven(a: integer) => boolean begin return (a MOD 2) == 0; end; // Return true if integer is odd (1 modulo 2). func IsOdd(a: integer) => boolean begin return (a MOD 2) == 1; end; // FloorPow2() // =========== // For a strictly positive integer x, returns the largest power of 2 that is // less than or equal to x func FloorPow2(x : integer) => integer begin assert x > 0; // p2 stores twice the result until last line where it is divided by 2 var p2 : integer = 2; while x >= p2 looplimit 2^128 do // i.e. unbounded p2 = p2 * 2; end; return p2 DIV 2; end; // CeilPow2() // ========== // For a positive integer x, returns the smallest power of 2 that is greater or // equal to x. func CeilPow2(x : integer) => integer begin assert x >= 0; if x <= 1 then return 1; end; return FloorPow2(x - 1) * 2; end; // IsPow2() // ======== // Return TRUE if integer X is positive and a power of 2. Otherwise, // return FALSE. func IsPow2(x : integer) => boolean begin if x <= 0 then return FALSE; end; return FloorPow2(x) == CeilPow2(x); end; // AlignDownSize() // =============== // For a non-negative integer x and positive integer size, returns the greatest // multiple of size that is less than or equal to x. func AlignDownSize(x: integer, size: integer) => integer begin assert size > 0; return (x DIVRM size) * size; end; // AlignUpSize() // ============= // For a non-negative integer x and positive integer size, returns the smallest // multiple of size that is greater than or equal to x. func AlignUpSize(x: integer, size: integer) => integer begin assert size > 0; return AlignDownSize(x + (size - 1), size); end; // AlignDownP2() // ============= // For non-negative integers x and p2, returns the greatest multiple of 2^p2 // that is less than or equal to x. func AlignDownP2(x: integer, p2: integer) => integer begin assert p2 >= 0; return AlignDownSize(x, 2^p2); end; // AlignUpP2() // =========== // For non-negative integers x and p2, returns the smallest multiple of 2^p2 // that is greater than or equal to x. func AlignUpP2(x: integer, p2: integer) => integer begin assert p2 >= 0; return AlignUpSize(x, 2^p2); end; //------------------------------------------------------------------------------ // Functions on reals // Convert integer to rational value. // func Real(x: integer) => real; // Nearest integer, rounding towards negative infinity. // func RoundDown(x: real) => integer; // Nearest integer, rounding towards positive infinity. // func RoundUp(x: real) => integer; // Nearest integer, rounding towards zero. // func RoundTowardsZero(x: real) => integer; // Absolute value. func Abs(x: real) => real begin return if x >= 0.0 then x else -x; end; // Maximum of reals. func Max(a: real, b: real) => real begin return if a>b then a else b; end; // Minimum of reals. func Min(a: real, b: real) => real begin return if a integer begin assert value > 0.0; var val : real = Abs(value); var low : integer; var high : integer; // Exponential search to find upper/lower power-of-2 exponent range if val >= 1.0 then low = 0; high = 1; while 2.0 ^ high <= val looplimit 2^128 do low = high; high = high * 2; end; else low = -1; high = 0; while 2.0 ^ low > val looplimit 2^128 do high = low; low = low * 2; end; end; // Binary search between low and high while low + 1 < high looplimit 2^128 do var mid = (low + high) DIVRM 2; if 2.0 ^ mid > val then high = mid; else low = mid; end; end; return low; end; // SqrtRounded() // ============= // Compute square root of VALUE with FRACBITS bits of precision after // the leading 1, rounding inexact values to Odd // Round to Odd (RO) preserves any leftover fraction in the least significant // bit (LSB) so a subsequent IEEE rounding (RN/RZ/RP/RM) to a lower precision // yields the same final result as a direct single-step rounding would have. It // also ensures an Inexact flag is correctly signaled, as RO explicitly marks // all inexact intermediates by setting the LSB to 1, which cannot be // represented exactly when rounding to lower precision. func SqrtRounded(value : real, fracbits : integer) => real begin assert value >= 0.0 && fracbits > 0; if value == 0.0 then return 0.0; end; // Normalize value to the form 1.nnnn... x 2^exp var exp : integer = ILog2(value); var mant : real = value / (2.0 ^ exp); // Require value = 2.0^exp * mant, where exp is even and 1 <= mant < 4 if exp MOD 2 != 0 then mant = 2.0 * mant; exp = exp - 1; end; // Set root to sqrt(mant) truncated to fracbits-1 bits var root = 1.0; var prec = 1.0; for n = 1 to fracbits - 1 do prec = prec / 2.0; if (root + prec) ^ 2 <= mant then root = root + prec; end; end; // prec == 2^(1-fracbits) // Final value of root is odd-rounded to fracbits bits if root ^ 2 < mant then root = root + (prec / 2.0); end; // Return sqrt(value) odd-rounded to fracbits bits return (2.0 ^ (exp DIV 2)) * root; end; //------------------------------------------------------------------------------ // Standard bitvector functions and procedures // For most of these functions, some implicitely dependently typed version // exists in the specification. We do not yet support those. // Externals func ReplicateBit{N}(isZero: boolean) => bits(N) begin return if isZero then Zeros{N} else Ones{N}; end; // Returns a bitvector of width N, containing (N DIV M) copies of input bit // vector x of width M. N must be exactly divisible by M. func Replicate{N,M}(x: bits(M)) => bits(N) begin if M == 1 then return (if x[0] == '1' then Ones{N} else Zeros{N}); else let items = N DIV M; // must be exact var result = Zeros{N}; for i = 0 to items - 1 do result[i*:M] = x; end; return result; end; end; func Len{N}(x: bits(N)) => integer {N} begin return N; end; func BitCount{N}(x: bits(N)) => integer{0..N} begin var result: integer = 0; for i = 0 to N-1 do if x[i] == '1' then result = result + 1; end; end; return result as integer {0..N}; end; func LowestSetBit{N}(x: bits(N)) => integer{0..N} begin for i = 0 to N-1 do if x[i] == '1' then return i as integer{0..N}; end; end; return N as integer {0..N}; end; func HighestSetBit{N}(x: bits(N)) => integer{-1..N-1} begin for i = N-1 downto 0 do if x[i] == '1' then return i as integer {-1..N-1}; end; end; return -1 as {-1..N-1}; end; func Zeros{N}() => bits(N) begin return 0[N-1:0]; end; func Ones{N}() => bits(N) begin return NOT Zeros{N}; end; func IsZero{N}(x: bits(N)) => boolean begin return x == Zeros{N}; end; func IsOnes{N}(x: bits(N)) => boolean begin return x == Ones{N}; end; func SignExtend {N,M} (x: bits(M)) => bits(N) begin assert N >= M; return Replicate{N-M}(x[M-1]) :: x; end; func ZeroExtend {N,M} (x: bits(M)) => bits(N) begin assert N >= M; return Zeros{N - M} :: x; end; func Extend {N,M} (x: bits(M), unsigned: boolean) => bits(N) begin return if unsigned then ZeroExtend{N}(x) else SignExtend{N}(x); end; func CountLeadingZeroBits{N}(x: bits(N)) => integer {0..N} begin return N - 1 - HighestSetBit(x); end; // Leading sign bits in a bitvector. Count the number of consecutive // bits following the leading bit, that are equal to it. func CountLeadingSignBits{N}(x: bits(N)) => integer{0..N-1} begin return CountLeadingZeroBits(x[N-1:1] XOR x[N-2:0]); end; // Treating input as an integer, align down to nearest multiple of 2^y. func AlignDown{N}(x: bits(N), y: integer{1..N}) => bits(N) begin return x[N-1:y] :: Zeros{y}; end; // Treating input as an integer, align up to nearest multiple of 2^y. // Returns zero if the result is not representable in N bits. func AlignUp{N}(x: bits(N), y: integer{1..N}) => bits(N) begin if IsZero(x[y-1:0]) then return x; else return (x[N-1:y]+1) :: Zeros{y}; end; end; // Bitvector alignment functions // ============================= // AlignDownSize() // =============== // A variant of AlignDownSize where the bitvector x is viewed as an unsigned // integer and the resulting integer is represented by its first N bits. func AlignDownSize{N}(x: bits(N), size: integer {1..2^N}) => bits(N) begin return AlignDownSize(UInt(x), size)[:N]; end; // AlignUpSize() // ============= // A variant of AlignUpSize where the bitvector x is viewed as an unsigned // integer and the resulting integer is represented by its first N bits. func AlignUpSize{N}(x: bits(N), size: integer {1..2^N}) => bits(N) begin return AlignUpSize(UInt(x), size)[:N]; end; // AlignDownP2() // ============= // A variant of AlignDownP2 where the bitvector x is viewed as an unsigned // integer and the resulting integer is represented by its first N bits. func AlignDownP2{N}(x: bits(N), p2: integer {0..N}) => bits(N) begin if N == 0 then return x; end; return x[N-1:p2] :: Zeros{p2}; end; // AlignUpP2() // =========== // A variant of AlignUpP2 where the bitvector x is viewed as an unsigned // integer and the resulting integer is represented by its first N bits. func AlignUpP2{N}(x: bits(N), p2: integer {0..N}) => bits(N) begin return AlignDownP2{N}(x + (2^p2 - 1), p2); end; // The shift functions LSL, LSR, ASR and ROR accept a non-negative shift amount. // The shift functions LSL_C, LSR_C, ASR_C and ROR_C accept a non-zero positive shift amount. // Logical left shift func LSL{N}(x: bits(N), shift: integer) => bits(N) begin assert shift >= 0; if shift < N then let bshift = shift as integer{0..N-1}; return x[(N-bshift)-1:0] :: Zeros{bshift}; else return Zeros{N}; end; end; // Logical left shift with carry out. func LSL_C{N}(x: bits(N), shift: integer) => (bits(N), bit) begin assert shift > 0; if shift <= N then return (LSL{N}(x, shift), x[N-shift]); else return (Zeros{N}, '0'); end; end; // Logical right shift, shifting zeroes into higher bits. func LSR{N}(x: bits(N), shift: integer) => bits(N) begin assert shift >= 0; if shift < N then let bshift = shift as integer{0..N-1}; return ZeroExtend{N}(x[N-1:bshift]); else return Zeros{N}; end; end; // Logical right shift with carry out. func LSR_C{N}(x: bits(N), shift: integer) => (bits(N), bit) begin assert shift > 0; if shift <= N then return (LSR{N}(x, shift), x[shift-1]); else return (Zeros{N}, '0'); end; end; // Arithmetic right shift, shifting sign bits into higher bits. func ASR{N}(x: bits(N), shift: integer) => bits(N) begin assert shift >= 0; let bshift = Min(shift, N-1) as integer{0..N-1}; return SignExtend{N}(x[N-1:bshift]); end; // Arithmetic right shift with carry out. func ASR_C{N}(x: bits(N), shift: integer) => (bits(N), bit) begin assert shift > 0; return (ASR{N}(x, shift), x[Min(shift-1, N-1)]); end; // Rotate right. // This function shifts by [shift] bits to the right, the bits deleted are // reinserted on the left. This makes it operate effectively modulo N. func ROR{N}(x: bits(N), shift: integer) => bits(N) begin assert shift >= 0; let cshift = (shift MOD N) as integer{0..N-1}; return x[0+:cshift] :: x[N-1:cshift]; end; // Rotate right with carry out. // As ROR, the function effectively operates modulo N. func ROR_C{N}(x: bits(N), shift: integer) => (bits(N), bit) begin assert shift > 0; let cpos = (shift-1) MOD N; return (ROR{N}(x, shift), x[cpos]); end; herd-herdtools7-1ca343e/asllib/libdir/stdlib0.asl000066400000000000000000000011271475314470400217200ustar00rootroot00000000000000//------------------------------------------------------------------------------ // Backwards compatibility for ASLv0 bits(N) ReplicateBit(boolean isZero, integer N) return ReplicateBit{N}(isZero); bits(M*N) Replicate(bits(M) x, integer N) return Replicate{M*N,M}(x); bits(N) Zeros(integer N) return Zeros{N}(); bits(N) Ones(integer N) return Ones{N}(); bits(N) SignExtend(bits(M) x, integer N) return SignExtend{N,M}(x); bits(N) ZeroExtend(bits(M) x, integer N) return ZeroExtend{N,M}(x); bits(N) Extend(bits(M) x, integer N, boolean unsigned) return Extend{N,M}(x, unsigned); herd-herdtools7-1ca343e/asllib/repeatableLexer.ml000066400000000000000000000053321475314470400220510ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) open Lexing type 't with_pos = 't * position * position type 't state = 't with_pos array * int ref type 't lexer = lexbuf -> 't type 't supplier = unit -> 't with_pos let get_unsafe ((tokens, i) : 't state) : 't with_pos = let res = tokens.(!i) in incr i; res let get ((tokens, i) : 't state) : 't with_pos = if !i < Array.length tokens then get_unsafe (tokens, i) else raise (Invalid_argument "empty lexer") let of_lexer_lexbuf (is_eof : 't -> bool) (lexer : 't lexer) (lexbuf : lexbuf) : 't state = let rec loop acc = let tok = lexer lexbuf in let p1 = lexbuf.lex_start_p and p2 = lexbuf.lex_curr_p in let acc = (tok, p1, p2) :: acc in if is_eof tok then acc |> List.rev |> Array.of_list else loop @@ acc in (loop [], ref 0) let to_lexer (state : 't state) : 't lexer = fun lexbuf -> let tok, p1, p2 = get state in lexbuf.lex_start_p <- p1; lexbuf.lex_curr_p <- p2; tok let to_supplier (state : 't state) : 't supplier = fun () -> get state let copy ((tokens, i) : 't state) : 't state = (tokens, ref !i) let double_lexer is_eof lexer lexbuf : 't lexer * 't lexer = let init_state = of_lexer_lexbuf is_eof lexer lexbuf in (to_lexer (copy init_state), to_lexer (copy init_state)) herd-herdtools7-1ca343e/asllib/splitasl.mli000066400000000000000000000031561475314470400207530ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) (** Split (ASL) lexbuffer at "// =======..." limits *) val split : Lexing.lexbuf -> (int * string) Seq.t herd-herdtools7-1ca343e/asllib/splitasl.mll000066400000000000000000000044511475314470400207550ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) { let dump _n start k = start, String.concat "" (List.rev_map (fun line -> Printf.sprintf "%s\n" line) k) let get_lnum lb = lb.Lexing.lex_curr_p.Lexing.pos_lnum } rule main n st k = parse | "//" ' '+ '='+ '\n' { let new_st = get_lnum lexbuf in Lexing.new_line lexbuf ; let chunk = dump n st k in fun () -> Seq.Cons (chunk,main (n+1) new_st [""] lexbuf) } | "//" [^'\n']* '\n' { Lexing.new_line lexbuf ; main n st (""::k) lexbuf } | [^'\n']* as line '\n' { Lexing.new_line lexbuf ; main n st (line::k) lexbuf } | [^'\n']* as line eof { let k = match line with | "" -> k | _ -> line::k in match k with | [] -> Seq.empty | _::_ -> Seq.return (dump n st k) } { let split lexbuf = main 1 (get_lnum lexbuf) [] lexbuf } herd-herdtools7-1ca343e/asllib/storage.ml000066400000000000000000000074121475314470400204120ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) open ASTUtils let _runtime_assertions = true type pointer = int module PMap = struct module PM = Map.Make (Int) let[@warning "-32"] of_list li = List.fold_left (fun acc (key, value) -> PM.add key value acc) PM.empty li include PM end module PSet = Set.Make (Int) type 'v t = { env : pointer IMap.t; mem : 'v PMap.t } let alloc = let next = ref 0 in fun () -> let r = !next in next := r + 1; r let empty = { env = IMap.empty; mem = PMap.empty } let mem x t = IMap.mem x t.env let assign x v t = let p = IMap.find x t.env in { t with mem = PMap.add p v t.mem } let declare x v t = let () = if _runtime_assertions && mem x t then let () = Printf.eprintf "Storage element %s already declared in env.\n%!" x in assert false in let p = alloc () in { env = IMap.add x p t.env; mem = PMap.add p v t.mem } let of_v_map map = let mem_list = ref [] in let env = IMap.map (fun v -> let p = alloc () in mem_list := (p, v) :: !mem_list; p) map in let mem = PMap.of_list !mem_list in { env; mem } let add x v t = try assign x v t with Not_found -> declare x v t let find x t = let p = IMap.find x t.env in PMap.find p t.mem let find_opt x t = try Some (find x t) with Not_found -> None let remove x t = try let p = IMap.find x t.env in { mem = PMap.remove p t.mem; env = IMap.remove x t.env } with Not_found -> t let patch_mem ~t_env ~t_mem to_avoid = let env = t_env.env and mem = try List.fold_left (fun mem x -> let p = IMap.find x t_mem.env in PMap.remove p mem) t_mem.mem to_avoid with Not_found -> let () = Printf.eprintf "Bug in unsetting one of "; List.iter (fun s -> Printf.eprintf "%s, " s) to_avoid; Printf.eprintf "\n%!" in assert false in { env; mem } let to_seq t = IMap.to_seq t.env |> Seq.map (fun (name, pointer) -> (name, PMap.find pointer t.mem)) let pp_print pp_elt = let open Format in let pp_sep f () = fprintf f ",@ " in let pp_one f (key, elt) = fprintf f "@[%s |-> @[%a@]@]" key pp_elt elt in fun f t -> fprintf f "@[{@ %a}@]" (PP.pp_print_seq ~pp_sep pp_one) (to_seq t) let map f t = { t with mem = PMap.map f t.mem } herd-herdtools7-1ca343e/asllib/storage.mli000066400000000000000000000172401475314470400205630ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) (** This module produces an map like interface to model memory storage. *) open AST (** {1 Introduction to scopes, mutability and blocks} The usual implementation and semantics of variables is based on "maps", i.e. functions from variables to values with a finite domain. We note [env] such a map. As in ASL, to evaluate a program, we distinguish between expressions and statements: + function [eval_expr] takes as argument an environment and an expression and returns a value. For instance, here is the evaluation of a variable: {[ eval_expr env = function | E_Var x -> Map.find x env ]} + function [eval_stmt] takes as argument an environment and a statement and returns an environment. For instance here is the execution of a variable declaration: {[ eval_stmt env = function | S_Decl (x, e) -> let v = eval_expr x e in Map.add x v env ]} In a simplified setting, the above scheme suffices to implement mutable variables, mostly because the [eval_stmt] returns the environment, as illustrated by the rule for assignment, which is the same as the declaration rule. {[ eval_stmt env = function | S_Assign (x, e) -> let v = eval_expr env e in Map.add x v env ]} Notice that the new binding overwrites the old one, which is no longer accessible. The scheme still works in case all variables are global and when expression can perform side effects. Function [eval_expr] will now return a pair of a value and of an environment, For instance, assume expression [E_Incr x] that increments the contents of [x] and return the new value: {[ eval_expr env = function | E_Incr x -> let v = Map.find x env in let v = v + 1 in (v, Map.add x v env) ]} Things get more complicated in the presence of scopes. The root reason is what happens to bindings at scope end. Consider the following ASL code: {v var s = 0; var i = 0; while i < n do var c = i*i ; s = s + c; i = i + 1; end // 'c' is mo longer available, 's' is. v} According to ASL semantics the variable [c] exists from its declaration to the end of its enclosing block. One simple implementation for executing a block is as follows: {[ let eval_stmt env = function | S_Block stmt -> ignore (eval_stmt env stmt); env ]} All extensions performed by the statement [stmt] from inside the block are discarded. However, some variable defined before the block can be assigned inside the block (this is the case of [s] above), and those modifications have to survive the end of the block... This would lead to the following contradictory implementation: {[ let eval_stmt env = function | S_Block stmt -> eval_stmt env stmt ]} One solution is adding an indirection in environments. En environment is now made of two maps: one for bindings from variables to {i pointers} and another for the "heap" from pointers to values. {[ type env = { bds : pointer VarMap.t; heap : value PointerMap.t; } ]} The rule for blocks can now discard the bindings and retain the heap: {[ let eval_stmt old_env = function | S_Block stmt -> let new_env = eval_stmt env stmt in { bds = old_env.bds; heap = new_env.heap; } ]} One may notice that the heap can be purged of the slots associated to the discarded bindings, some kind of garbage collection. This can be done easily by an additional field in environment 'declared' that records the variables declared in a block - this technique is used in the interpreter. The rule for evaluating a variable now performs two successive searches, one for retrieving the pointer and then the value: {[ let eval_expr env = function | E_Var x -> let pointer = VarMap.find x env.bds in PointerMap.find pointer env.heap ]} The rules for declarations and assignments also change, there are now different: + The declaration {i allocates} a fresh pointer. That way if a binding for the same variable exists the underlying heap slot is preserved. + The assignment retrieve the pointer associated to the variable, which must exist. {1 Storage module} This module implements the storage type presented above, and present a simple interface to this. *) type 'v t (** The type [t] stores an association between names and ['v] values. *) val empty : 'a t (** An empty storage. *) val mem : identifier -> 'a t -> bool (** [mem x t] is true iff [x] is bound in [t]. *) val add : identifier -> 'a -> 'a t -> 'a t (** [add x v t] is [t] with [x] bound to [v], over-riding previous bind but not deleting values from memory. *) val assign : identifier -> 'a -> 'a t -> 'a t (** [assign x v t] is [t] with [x] bound to [v], replacing the previous value bound for [x]. If [x] is not bound in [t], raise [Not_found]. *) val declare : identifier -> 'a -> 'a t -> 'a t (** [declare x v t] is [t] with [x] bound to [v], creating a new memory cell for [v]. *) val find : identifier -> 'a t -> 'a (** [find x t] is [v] if [x] is bound to [v] in [t], raising [Not_found] otherwise. *) val find_opt : identifier -> 'a t -> 'a option (** [find_opt x t] is [Some v] if [x] is bound to [v] in [t], [None] otherwise. *) val remove : identifier -> 'a t -> 'a t (** [remove x t] is [t] with [x] not bound to anything. Memory is freed. *) val patch_mem : t_env:'a t -> t_mem:'a t -> identifier list -> 'a t (** [patch_mem ~t_env ~t_mem to_avoid] is the storage formed with the bindings of [t_env], the memory of [t_mem] except for the cells bound to the variables in [to_avoid]. *) val of_v_map : 'a ASTUtils.IMap.t -> 'a t (** [of_v_map map] declare all elements of map. Equivalent of [IMap.fold declare map empty]. *) val pp_print : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit (** [pp_print pp_elt f t] pretty-print [t] with [pp_elt] on the formatter [f]. *) val map : ('a -> 'b) -> 'a t -> 'b t (** [map f t] binds [s] to [f x] for all [s] bound to [x] in [t]. *) herd-herdtools7-1ca343e/asllib/tests/000077500000000000000000000000001475314470400175525ustar00rootroot00000000000000herd-herdtools7-1ca343e/asllib/tests/ASLDefinition.t/000077500000000000000000000000001475314470400224445ustar00rootroot00000000000000herd-herdtools7-1ca343e/asllib/tests/ASLDefinition.t/Bitfields.asl000066400000000000000000000001151475314470400250470ustar00rootroot00000000000000var myData: bits(16) { [4] flag, [3:0, 8:5] data, [9:0] value }; herd-herdtools7-1ca343e/asllib/tests/ASLDefinition.t/Bitfields_nested.asl000066400000000000000000000026331475314470400264200ustar00rootroot00000000000000type Nested_Type of bits(32) { // absolute fields [31:16] fmt0 { // [31:16] fmt0 [15] common, // [31:31] fmt0.common [14:13, 12:2, 1, 0] layer1 { // [30:16] fmt0.layer1 [14:13] remainder { // [30:29] fmt0.layer1.remainder [1] moving, // [30:30] fmt0.layer1.remainder.moving [0] extra // [29:29] fmt0.layer1.remainder.extra }, }, [13] extra // [29:29] fmt0.extra }, [31:16] fmt1 { // [31:16] fmt1 [15] common, // [31:31] fmt1.common [0] moving // [16:16] fmt1.moving }, [31] common, // [31:31] common [0] fmt // [0:0] fmt }; var nested : Nested_Type = '10101010101010101010101010101010'; // select the correct view of moving // nested.fmt is '0' // nested.fmt0.moving is nested[30] // nested.fmt is '1' // nested.fmt1.moving is nested[16] let moving = if nested.fmt == '0' then nested.fmt0.layer1.remainder.moving else nested.fmt1.moving; func main() => integer begin // below are all equivalent to nested[31] let common = nested.common; let common_fmt0 = nested.fmt0.common; let common_fmt1 = nested.fmt1.common; assert common == common_fmt0; assert common == common_fmt1; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLDefinition.t/Bitvector_slices.asl000066400000000000000000000007351475314470400264550ustar00rootroot00000000000000func main() => integer begin let bv : bits(6) = '110010'; assert bv[5] == '1' && bv[4] == '1' && bv[3] == '0' && bv[2] == '0' && bv[1] == '1' && bv[0] == '0'; assert bv == bv[5,4,3,2,1,0]; assert bv != bv[0,1,2,3,4,5]; assert bv == bv[5:0]; assert bv == bv[:6]; assert bv[3:0] == bv[:4]; assert bv == bv[5:5] :: bv[4:4] :: bv[3:3] :: bv[2:2] :: bv[1:1] :: bv[0:0]; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLDefinition.t/run.t000066400000000000000000000003431475314470400234350ustar00rootroot00000000000000Examples used in ASL High-level Definition: $ aslref --no-exec spec1.asl $ aslref --no-exec spec2.asl $ aslref spec3.asl $ aslref --no-exec Bitfields.asl $ aslref Bitfields_nested.asl $ aslref Bitvector_slices.asl herd-herdtools7-1ca343e/asllib/tests/ASLDefinition.t/spec1.asl000066400000000000000000000003071475314470400241600ustar00rootroot00000000000000var R0: bits(4) = '0001'; var R1: bits(4) = '0010'; var R2: bits(4); func MyOR{M}(x: bits(M), y: bits(M)) => bits(M) begin return x OR y; end; func reset() begin R2 = MyOR{4}(R0, R1); end; herd-herdtools7-1ca343e/asllib/tests/ASLDefinition.t/spec2.asl000066400000000000000000000002341475314470400241600ustar00rootroot00000000000000var COUNT: integer; func ColdReset() begin COUNT = 0; end; func Step() begin assert COUNT >= 0; COUNT = COUNT + 1; assert COUNT > 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLDefinition.t/spec3.asl000066400000000000000000000011271475314470400241630ustar00rootroot00000000000000func Dot8{N}(a: bits(N), b: bits(N)) => bits(N) begin var n: integer = 0; for i = 0 to (N DIV 8) - 1 do n = n + UInt(a[i*:8]) * UInt(b[i*:8]); end; return n[0 +: N]; end; var X: bits(16) = '1010 1111 0101 0000'; var COUNT: integer = 0; func Fib(n: integer) => integer recurselimit 1000 begin COUNT = COUNT + 1; if n < 2 then return 1; else let fib_n_1 = Fib (n-1); let fib_n_2 = Fib (n-2); return fib_n_1 + fib_n_2; end; end; func main() => integer begin X = Dot8{16}(X, X); var fib10 = Fib(10); return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/000077500000000000000000000000001475314470400241215ustar00rootroot00000000000000herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/EvalCatchers.asl000066400000000000000000000005031475314470400271640ustar00rootroot00000000000000type MyExceptionType of exception{}; var g : integer = 0; func update_and_throw() begin var x = 5; g = 1; throw MyExceptionType{}; end; func main() => integer begin var x = 2; try update_and_throw(); catch when MyExceptionType => println(x, g); end; return 0; end; SemanticsRule.ATCNotDynamicErrorIfFalse.asl000066400000000000000000000004541475314470400341640ustar00rootroot00000000000000herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.tfunc f1() => boolean begin return FALSE; end; func f2(y: integer {2, 4, 8}) => boolean begin return y == 2; end; func checkY (y: integer) begin if (f1() && f2(y as integer {2,4,8})) then pass; end; end; func main () => integer begin checkY(0); checkY(1); checkY(2); return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.ATCValue.asl000066400000000000000000000003431475314470400310030ustar00rootroot00000000000000func main () => integer begin let my_unconstrained_integer = 3 as integer; assert my_unconstrained_integer == 3; let my_constrained_integer = 3 as integer {3..5}; assert my_constrained_integer == 3; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.ATCVariousErrors.asl000066400000000000000000000005761475314470400325640ustar00rootroot00000000000000func ErrorExample() begin var a: integer{1, 2, 3} = 2 as integer{1, 2, 3}; // Legal var b: integer{4, 5, 6} = 2; // A type error var c: integer{4, 5, 6} = 2 as integer{4, 5, 6}; // A dynamic error if FALSE then var d: integer{4, 5, 6} = 2; // A type error // A dynamic error var e: integer{4, 5, 6} = 2 as integer{4, 5, 6}; end; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.Block.asl000066400000000000000000000002411475314470400304260ustar00rootroot00000000000000func main() => integer begin var x : integer = 1; if TRUE then x = 2; let y = 2; end; let y = 1; assert (x == 2 && y == 1); return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.Catch.asl000066400000000000000000000004031475314470400304160ustar00rootroot00000000000000type MyExceptionType of exception{}; func main () => integer begin try throw MyExceptionType {}; assert FALSE; catch when MyExceptionType => assert TRUE; otherwise => assert FALSE; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.CatchNamed.asl000066400000000000000000000004171475314470400313700ustar00rootroot00000000000000type MyExceptionType of exception{ msg: integer }; func main () => integer begin try throw MyExceptionType { msg=42 }; catch when exn: MyExceptionType => assert exn.msg == 42; otherwise => assert FALSE; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.CatchNoThrow.asl000066400000000000000000000004061475314470400317420ustar00rootroot00000000000000type MyExceptionType of exception{}; func main () => integer begin try assert TRUE; catch when MyExceptionType => assert FALSE; otherwise => assert FALSE; end; println("No exception raised"); return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.CatchNone.asl000066400000000000000000000005041475314470400312400ustar00rootroot00000000000000type MyExceptionType1 of exception{}; type MyExceptionType2 of exception{}; func main () => integer begin try try throw MyExceptionType1 {}; assert FALSE; catch when MyExceptionType2 => assert FALSE; end; catch MyExceptionType1; assert TRUE; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.CatchOtherwise.asl000066400000000000000000000004751475314470400323210ustar00rootroot00000000000000type MyExceptionType1 of exception{}; type MyExceptionType2 of exception{}; func main () => integer begin try throw MyExceptionType1 {}; assert FALSE; catch when MyExceptionType2 => assert FALSE; otherwise => println("Otherwise"); end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.EArbitraryArray.asl000066400000000000000000000004771475314470400324520ustar00rootroot00000000000000type Enum of enumeration {A, B, C}; type Arr of array[[Enum]] of integer; func main () => integer begin var int_array = ARBITRARY : array[[3]] of integer; int_array[[2]] = 1; assert int_array[[2]] == 1; var enum_array = ARBITRARY : Arr; enum_array[[A]] = 7; assert enum_array[[A]] == 7; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.EArbitraryInteger0.asl000066400000000000000000000001401475314470400330340ustar00rootroot00000000000000func main () => integer begin let x = ARBITRARY:integer; assert x == 0; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.EArbitraryInteger3.asl000066400000000000000000000001361475314470400330440ustar00rootroot00000000000000func main () => integer begin let x = ARBITRARY:integer; assert x==3; return 0; end; SemanticsRule.EArbitraryIntegerRange3-42-3.asl000066400000000000000000000001461475314470400343260ustar00rootroot00000000000000herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.tfunc main () => integer begin let x = ARBITRARY:integer {3, 42}; assert x==3; return 0; end; SemanticsRule.EArbitraryIntegerRange3-42-42.asl000066400000000000000000000001471475314470400344120ustar00rootroot00000000000000herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.tfunc main () => integer begin let x = ARBITRARY:integer {3, 42}; assert x==42; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.EBinopAndFalse.asl000066400000000000000000000002421475314470400321470ustar00rootroot00000000000000func fail() => boolean begin assert FALSE; return TRUE; end; func main () => integer begin let b = FALSE && fail(); assert b == FALSE; return 0; end; SemanticsRule.EBinopDIVBackendDefinedError.asl000066400000000000000000000001051475314470400345740ustar00rootroot00000000000000herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.tfunc main () => integer begin let x = 3 DIV 0; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.EBinopImplExFalso.asl000066400000000000000000000001351475314470400326560ustar00rootroot00000000000000func main () => integer begin let b = (0 == 1) --> (1 == 0); assert b; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.EBinopOrTrue.asl000066400000000000000000000001341475314470400317120ustar00rootroot00000000000000func main () => integer begin let b = (0 == 1) || (1 == 1); assert b; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.EBinopPlusAssert.asl000066400000000000000000000001221475314470400325740ustar00rootroot00000000000000func main () => integer begin let x = 3 + 2; assert x==5; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.EBinopPlusPrint.asl000066400000000000000000000001211475314470400324260ustar00rootroot00000000000000func main () => integer begin let x = 3 + 2; println(x); return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.ECall.asl000066400000000000000000000002171475314470400303570ustar00rootroot00000000000000func Return42() => integer begin return 42; end; func main () => integer begin let x = Return42(); assert x == 42; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.EConcat.asl000066400000000000000000000002041475314470400307070ustar00rootroot00000000000000func main () => integer begin let x = '10' :: '11'; assert x=='1011'; let y = '' :: ''; assert y == ''; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.EConcat2.asl000066400000000000000000000001461475314470400307760ustar00rootroot00000000000000var T: boolean = ( '1111' :: '0000' ) == '11110000'; func main () => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.ECondARBITRARY3or42.asl000066400000000000000000000002561475314470400324440ustar00rootroot00000000000000func Return42() => integer begin return 42; end; func main () => integer begin let x = if ARBITRARY: boolean then 3 else Return42(); assert x==3; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.ECondFALSE.asl000066400000000000000000000002411475314470400311370ustar00rootroot00000000000000func Return42() => integer begin return 42; end; func main () => integer begin let x = if FALSE then Return42() else 3; assert x==3; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.EGetArray.asl000066400000000000000000000002531475314470400312220ustar00rootroot00000000000000type MyArrayType of array [[3]] of integer; var my_array : MyArrayType; func main () => integer begin my_array[[2]]=42; assert my_array[[2]]==42; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.EGetArrayTooSmall.asl000066400000000000000000000002231475314470400326720ustar00rootroot00000000000000type MyArrayType of array [[3]] of integer; var my_array : MyArrayType; func main () => integer begin println(my_array[[3]]); return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.EGetEnumArray.asl000066400000000000000000000003541475314470400320510ustar00rootroot00000000000000type Enum of enumeration {A, B, C}; type Arr of array[[Enum]] of integer; func main () => integer begin var arr: Arr; arr[[A]] = 32; arr[[B]] = 64; arr[[C]] = 128; assert 2 * arr[[A]] + arr[[B]] == arr[[C]]; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.EGlobalVar.asl000066400000000000000000000001551475314470400313560ustar00rootroot00000000000000var global_x: integer = 3; func main () => integer begin assert global_x == 3; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.EGlobalVarError.asl000066400000000000000000000001271475314470400323670ustar00rootroot00000000000000var x: integer = 3; func main () => integer begin assert x == 3; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.ELocalVar.asl000066400000000000000000000001311475314470400312020ustar00rootroot00000000000000func main () => integer begin var x: integer = 3; assert x == 3; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.EPattern.asl000066400000000000000000000002711475314470400311210ustar00rootroot00000000000000func main () => integer begin let match_true = 42 IN {0..3, 42}; assert match_true == TRUE; let match_false = 42 IN {0..3, -4}; assert match_false == FALSE; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.ERecord.asl000066400000000000000000000002571475314470400307260ustar00rootroot00000000000000type MyRecordType of record {a: integer, b: integer}; func main () => integer begin let my_record = MyRecordType{a=3, b=42}; assert my_record.a == 3; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.ESlice.asl000066400000000000000000000001431475314470400305410ustar00rootroot00000000000000func main () => integer begin let x = '11110000'[6:3]; assert x == '1110'; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.ETuple.asl000066400000000000000000000002511475314470400305730ustar00rootroot00000000000000func Return42() => integer begin return 42; end; func main () => integer begin let (x,y) = (3, Return42()); assert x == 3; assert y == 42; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.EUndefIdent.asl000066400000000000000000000001161475314470400315270ustar00rootroot00000000000000func main () => integer begin let x = 42; assert y; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.EUnopAssert.asl000066400000000000000000000001341475314470400316050ustar00rootroot00000000000000func main () => integer begin let x = NOT '1010'; assert x=='0101'; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.FCall.asl000066400000000000000000000003111475314470400303530ustar00rootroot00000000000000func foo (x : integer) => integer begin return x + 1; end; func bar (x : integer) begin assert x == 3; end; func main () => integer begin assert foo(2) == 3; bar(3); return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.FUndefIdent.asl000066400000000000000000000000761475314470400315350ustar00rootroot00000000000000func main () => integer begin foo (); return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.For.asl000066400000000000000000000001371475314470400301260ustar00rootroot00000000000000func main () => integer begin for i = 0 to 3 do assert i <= 3; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.LDDiscard.asl000066400000000000000000000001231475314470400311640ustar00rootroot00000000000000func main () => integer begin var - : integer; assert TRUE; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.LDTuple.asl000066400000000000000000000001641475314470400307110ustar00rootroot00000000000000func main () => integer begin var (x, y, z) = (1, 2, 3); assert x == 1 && y == 2 && z == 3; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.LDTyped.asl000066400000000000000000000001331475314470400307010ustar00rootroot00000000000000func main () => integer begin var x: integer = 42; assert x == 42; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.LDTypedTuple.asl000066400000000000000000000001601475314470400317130ustar00rootroot00000000000000func main () => integer begin var x,y,z : integer; assert x == 0 && y == 0 && z == 0; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.LDTypedVar.asl000066400000000000000000000001251475314470400313530ustar00rootroot00000000000000func main () => integer begin var x: integer; assert x == 0; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.LDUninitialisedTyped.asl000066400000000000000000000001341475314470400334240ustar00rootroot00000000000000func main () => integer begin var x: integer {3..42}; assert x == 3; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.LDVar1.asl000066400000000000000000000001321475314470400304240ustar00rootroot00000000000000func main () => integer begin var x : integer = 3; assert x == 3; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.LEDestructuring.asl000066400000000000000000000002221475314470400324560ustar00rootroot00000000000000func main () => integer begin var x: integer = 42; var y: integer = 3; (x, y) = (3, 42); assert x == 3 && y == 42; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.LEDiscard.asl000066400000000000000000000001121475314470400311630ustar00rootroot00000000000000func main () => integer begin - = 42; assert TRUE; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.LEGlobalVar.asl000066400000000000000000000001401475314470400314640ustar00rootroot00000000000000var x: integer = 3; func main () => integer begin x = 42; assert x==42; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.LELocalVar.asl000066400000000000000000000001431475314470400313210ustar00rootroot00000000000000func main () => integer begin var x: integer = 3; x = 42; assert x == 42; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.LESetArray.asl000066400000000000000000000002161475314470400313510ustar00rootroot00000000000000func main () => integer begin var my_array: array [[42]] of integer; my_array[[3]] = 53; assert my_array[[3]] == 53; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.LESetField.asl000066400000000000000000000003431475314470400313170ustar00rootroot00000000000000type MyRecordType of record { a: integer, b: integer }; func main () => integer begin var my_record = MyRecordType { a = 3, b = 100 }; my_record.a = 42; assert my_record.a == 42 && my_record.b == 100; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.LESlice.asl000066400000000000000000000001641475314470400306600ustar00rootroot00000000000000func main () => integer begin var x = '11111111'; x[3:0] = '0000'; assert x == '11110000'; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.LEUndefIdentV0.asl000066400000000000000000000001131475314470400320460ustar00rootroot00000000000000integer main () x = 42; y = 3; assert y == 3 && x == 42; return 0; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.LEUndefIdentV1.asl000066400000000000000000000001101475314470400320440ustar00rootroot00000000000000func main () => integer begin let x = 42; y = 3; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.Lit.asl000066400000000000000000000001021475314470400301200ustar00rootroot00000000000000func main () => integer begin assert 3 == 3; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.Loop.asl000066400000000000000000000002171475314470400303100ustar00rootroot00000000000000func main () => integer begin var i: integer = 0; while i <= 3 looplimit 4 do assert i <= 3; i = i + 1; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.PAll.asl000066400000000000000000000001521475314470400302250ustar00rootroot00000000000000func main () => integer begin let match_me = 42 IN { - }; assert match_me == TRUE; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.PAny.asl000066400000000000000000000002661475314470400302520ustar00rootroot00000000000000func main () => integer begin let match_true = 42 IN { 3, 42 }; assert match_true == TRUE; let match_false = 42 IN { 3, 4 }; assert match_false == FALSE; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.PGeq.asl000066400000000000000000000002651475314470400302360ustar00rootroot00000000000000func main () => integer begin let match_true = 42 IN { >= 3 }; assert match_true == TRUE; let match_false = 3 IN { >= 42 }; assert match_false == FALSE; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.PLeq.asl000066400000000000000000000002651475314470400302430ustar00rootroot00000000000000func main () => integer begin let match_true = 3 IN { <= 42 }; assert match_true == TRUE; let match_false = 42 IN { <= 3 }; assert match_false == FALSE; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.PMask.asl000066400000000000000000000003061475314470400304110ustar00rootroot00000000000000func main () => integer begin let match_true = '101010' IN {'xx1010'}; assert match_true == TRUE; let match_false = '101010' IN {'0x1010' }; assert match_false == FALSE; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.PNot.asl000066400000000000000000000002621475314470400302570ustar00rootroot00000000000000func main () => integer begin let match_true = 42 IN !{ 3 }; assert match_true == TRUE; let match_false = 42 IN !{ 42 }; assert match_false == FALSE; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.PRange.asl000066400000000000000000000002621475314470400305530ustar00rootroot00000000000000func main () => integer begin let match_true = 42 IN {3..42}; assert match_true == TRUE; let match_false = 1 IN {3..42}; assert match_false == FALSE; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.PSingle.asl000066400000000000000000000002601475314470400307360ustar00rootroot00000000000000func main () => integer begin let match_true = 42 IN { 42 }; assert match_true == TRUE; let match_false = 42 IN { 3 }; assert match_false == FALSE; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.PTuple.asl000066400000000000000000000003431475314470400306100ustar00rootroot00000000000000func main () => integer begin let match_true = (3, '101010') IN {( <= 42, 'xx1010')}; assert match_true == TRUE; let match_false = (3, '101010') IN {( >= 42, 'xx1010')}; assert match_false == FALSE; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.SAssertNo.asl000066400000000000000000000001051475314470400312540ustar00rootroot00000000000000func main () => integer begin assert (42 == 3); return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.SAssertOk.asl000066400000000000000000000001051475314470400312510ustar00rootroot00000000000000func main () => integer begin assert (42 != 3); return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.SAssign.asl000066400000000000000000000001441475314470400307450ustar00rootroot00000000000000func main () => integer begin var x : integer = 42; x = 3; assert x == 3; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.SAssignCall.asl000066400000000000000000000003071475314470400315420ustar00rootroot00000000000000func f(x: integer) => (integer, integer, integer) begin return (x, x+1, x+2); end; func main() => integer begin var a, b : integer; (a, b, -) = f(1); assert (a + b == 3); return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.SAssignTuple.asl000066400000000000000000000002051475314470400317550ustar00rootroot00000000000000func main () => integer begin var x : integer; var b : boolean; (b,x) = (TRUE,42); assert (b && x == 42); return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.SCall.asl000066400000000000000000000001151475314470400303720ustar00rootroot00000000000000func main () => integer begin assert Zeros{3} == '000'; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.SCase.asl000066400000000000000000000002371475314470400303770ustar00rootroot00000000000000func main () => integer begin case 3 of when 42 => assert FALSE; when <= 42 => assert TRUE; otherwise => assert FALSE; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.SCond.asl000066400000000000000000000001611475314470400304030ustar00rootroot00000000000000func main () => integer begin if TRUE then assert TRUE; else assert FALSE; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.SCond2.asl000066400000000000000000000002521475314470400304660ustar00rootroot00000000000000func main () => integer begin var x: integer; var y: integer; if x > y then return 1; elsif x < y then return -1; else return 0; end; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.SCond3.asl000066400000000000000000000003121475314470400304640ustar00rootroot00000000000000func UNPREDICTABLE () begin assert FALSE; end; func main () => integer begin var d:integer; var n:integer; if d IN {13,15} || n IN {13,15} then UNPREDICTABLE(); end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.SCond4.asl000066400000000000000000000002621475314470400304710ustar00rootroot00000000000000func main () => integer begin var size:bits(2); var esize:integer; var elements:integer; if size == '01' then esize = 16; elements = 4; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.SDeclNone.asl000066400000000000000000000001251475314470400312070ustar00rootroot00000000000000func main () => integer begin var x: integer; assert x == 0; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.SDeclSome.asl000066400000000000000000000001201475314470400312060ustar00rootroot00000000000000func main () => integer begin let x = 3; assert x == 3; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.SFor.asl000066400000000000000000000001571475314470400302530ustar00rootroot00000000000000func main () => integer begin for i = 0 to 3 do assert i <= 3; println(i); end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.SPass.asl000066400000000000000000000000711475314470400304260ustar00rootroot00000000000000func main () => integer begin pass; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.SRepeat.asl000066400000000000000000000002351475314470400307420ustar00rootroot00000000000000func main () => integer begin var i: integer = 0; repeat assert i <= 3; println(i); i = i + 1; until i > 3 looplimit 4; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.SReturnNone.asl000066400000000000000000000002731475314470400316230ustar00rootroot00000000000000func println_me () begin for i = 0 to 42 do if i >= 3 then return; end; end; assert FALSE; end; func main () => integer begin println_me (); return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.SReturnOne.asl000066400000000000000000000004311475314470400314410ustar00rootroot00000000000000func f () => integer begin var x : integer = 0; for i = 0 to 5 do x = x + 1; assert x == 1; // Only the first loop iteration is ever executed return 3; end; assert FALSE; return -1; end; func main () => integer begin assert f () == 3; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.SReturnSome.asl000066400000000000000000000005141475314470400316250ustar00rootroot00000000000000func f () => (integer, integer) begin var x: integer = 0; for i = 0 to 5 do x = x + 1; assert x == 1; // Only the first loop iteration is ever executed return (3, 42); end; assert FALSE; return (-1, -1); end; func main () => integer begin let (x, y) = f (); assert x == 3 && y == 42; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.SSeq.asl000066400000000000000000000001531475314470400302510ustar00rootroot00000000000000func main () => integer begin let x = 3; let y = x + 1; assert x == 3 && y == 4; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.SThrowNone.asl000066400000000000000000000005601475314470400314460ustar00rootroot00000000000000type MyExceptionType of exception{ a: integer }; func main () => integer begin try try throw MyExceptionType { a = 42 }; catch when MyExceptionType => throw; otherwise => assert FALSE; end; assert FALSE; catch when exn: MyExceptionType => assert exn.a == 42; otherwise => assert FALSE; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.SThrowSomeTyped.asl000066400000000000000000000003701475314470400324570ustar00rootroot00000000000000type MyExceptionType of exception{ a: integer }; func main () => integer begin try throw MyExceptionType { a = 42 }; catch when exn: MyExceptionType => assert exn.a == 42; otherwise => assert FALSE; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.STry.asl000066400000000000000000000003601475314470400302770ustar00rootroot00000000000000type MyExceptionType of exception{ a: integer }; func main () => integer begin try throw MyExceptionType { a = 42 }; catch when MyExceptionType => assert TRUE; otherwise => assert FALSE; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.SWhile.asl000066400000000000000000000002171475314470400305720ustar00rootroot00000000000000func main () => integer begin var i: integer = 0; while i <= 3 looplimit 4 do assert i <= 3; i = i + 1; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.SliceLength.asl000066400000000000000000000001431475314470400315760ustar00rootroot00000000000000func main () => integer begin let x = '00011100'; assert x[2+:3] == '111'; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.SliceRange.asl000066400000000000000000000001421475314470400314100ustar00rootroot00000000000000func main () => integer begin let x = '00011100'; assert x[4:2] == '111'; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.SliceSingle.asl000066400000000000000000000001351475314470400315770ustar00rootroot00000000000000func main () => integer begin let x = '00000100'; assert x[2] == '1'; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/SemanticsRule.SliceStar.asl000066400000000000000000000001421475314470400312650ustar00rootroot00000000000000func main () => integer begin let x = '11000000'; assert x[3*:2] == '11'; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/hello_world.asl000066400000000000000000000001121475314470400271260ustar00rootroot00000000000000func main() => integer begin println("Hello, world!"); return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSemanticsReference.t/run.t000066400000000000000000000136151475314470400251200ustar00rootroot00000000000000Hello world should work: $ aslref hello_world.asl Hello, world! ASL Semantics Tests: $ aslref SemanticsRule.Lit.asl $ aslref SemanticsRule.ELocalVar.asl $ aslref SemanticsRule.EGlobalVar.asl $ aslref SemanticsRule.EGlobalVarError.asl $ aslref SemanticsRule.EUndefIdent.asl File SemanticsRule.EUndefIdent.asl, line 5, characters 9 to 10: ASL Error: Undefined identifier: 'y' [1] // $ aslref SemanticsRule.EBinopPlusPrint.asl $ aslref SemanticsRule.EBinopPlusAssert.asl $ aslref SemanticsRule.EBinopDIVBackendDefinedError.asl File SemanticsRule.EBinopDIVBackendDefinedError.asl, line 4, characters 10 to 17: All values in constraints {0} would fail with op DIV, operation will always fail. File SemanticsRule.EBinopDIVBackendDefinedError.asl, line 4, characters 10 to 17: ASL Typing error: Illegal application of operator DIV on types integer {3} and integer {0}. [1] $ aslref --no-type-check SemanticsRule.EBinopDIVBackendDefinedError.asl File SemanticsRule.EBinopDIVBackendDefinedError.asl, line 4, characters 10 to 17: All values in constraints {0} would fail with op DIV, operation will always fail. ASL Dynamic error: Illegal application of operator DIV for values 3 and 0. [1] $ aslref SemanticsRule.EUnopAssert.asl $ aslref SemanticsRule.ECondFALSE.asl $ aslref SemanticsRule.ECondARBITRARY3or42.asl File SemanticsRule.ECondARBITRARY3or42.asl, line 10, characters 9 to 13: ASL Execution error: Assertion failed: (x == 3). [1] $ aslref SemanticsRule.ESlice.asl $ aslref SemanticsRule.ECall.asl $ aslref SemanticsRule.EGetArray.asl $ aslref SemanticsRule.EGetArrayTooSmall.asl ASL Execution error: Mismatch type: value 3 does not belong to type integer {0..2}. [1] $ aslref SemanticsRule.ERecord.asl $ aslref SemanticsRule.EConcat.asl $ aslref SemanticsRule.ETuple.asl $ aslref SemanticsRule.EArbitraryInteger0.asl $ aslref SemanticsRule.EArbitraryInteger3.asl File SemanticsRule.EArbitraryInteger3.asl, line 5, characters 9 to 13: ASL Execution error: Assertion failed: (x == 3). [1] $ aslref SemanticsRule.EArbitraryIntegerRange3-42-3.asl $ aslref SemanticsRule.EArbitraryIntegerRange3-42-42.asl File SemanticsRule.EArbitraryIntegerRange3-42-42.asl, line 5, characters 9 to 14: ASL Execution error: Assertion failed: (x == 42). [1] $ aslref SemanticsRule.EArbitraryArray.asl $ aslref SemanticsRule.EPattern.asl $ aslref SemanticsRule.LELocalVar.asl $ aslref SemanticsRule.LESetArray.asl $ aslref SemanticsRule.SReturnNone.asl $ aslref SemanticsRule.SCond.asl $ aslref SemanticsRule.SCase.asl $ aslref SemanticsRule.SWhile.asl $ aslref SemanticsRule.SRepeat.asl 0 1 2 3 $ aslref SemanticsRule.SFor.asl 0 1 2 3 $ aslref SemanticsRule.SThrowNone.asl $ aslref SemanticsRule.SThrowSomeTyped.asl $ aslref SemanticsRule.SThrowSTry.asl aslref cannot find file "SemanticsRule.SThrowSTry.asl" [1] $ aslref SemanticsRule.Loop.asl $ aslref SemanticsRule.For.asl $ aslref SemanticsRule.Catch.asl $ aslref SemanticsRule.CatchNamed.asl $ aslref SemanticsRule.CatchOtherwise.asl Otherwise $ aslref SemanticsRule.CatchNone.asl File SemanticsRule.CatchNone.asl, line 15, characters 8 to 24: ASL Error: Cannot parse. [1] $ aslref SemanticsRule.FUndefIdent.asl File SemanticsRule.FUndefIdent.asl, line 4, characters 5 to 12: ASL Error: Undefined identifier: 'foo' [1] $ aslref SemanticsRule.FCall.asl $ aslref SemanticsRule.PAll.asl $ aslref SemanticsRule.PAny.asl $ aslref SemanticsRule.PGeq.asl $ aslref SemanticsRule.PLeq.asl $ aslref SemanticsRule.PNot.asl $ aslref SemanticsRule.PRange.asl $ aslref SemanticsRule.PSingle.asl $ aslref SemanticsRule.PMask.asl $ aslref SemanticsRule.PTuple.asl $ aslref SemanticsRule.ATCValue.asl $ aslref -0 SemanticsRule.LEUndefIdentV0.asl $ aslref SemanticsRule.LEUndefIdentV1.asl File SemanticsRule.LEUndefIdentV1.asl, line 5, characters 2 to 3: ASL Error: Undefined identifier: 'y' [1] $ aslref SemanticsRule.LESlice.asl $ aslref SemanticsRule.LESetField.asl $ aslref SemanticsRule.LEDestructuring.asl $ aslref SemanticsRule.LDVar1.asl $ aslref SemanticsRule.SliceSingle.asl $ aslref SemanticsRule.SliceLength.asl $ aslref SemanticsRule.SliceRange.asl $ aslref SemanticsRule.SliceStar.asl $ aslref SemanticsRule.LDTuple.asl $ aslref SemanticsRule.LDTypedTuple.asl $ aslref SemanticsRule.LDTypedVar.asl $ aslref SemanticsRule.LDTyped.asl $ aslref SemanticsRule.LDUninitialisedTyped.asl $ aslref SemanticsRule.SAssign.asl $ aslref SemanticsRule.SCall.asl $ aslref SemanticsRule.SDeclNone.asl $ aslref SemanticsRule.SDeclSome.asl $ aslref SemanticsRule.SPass.asl $ aslref SemanticsRule.SReturnOne.asl $ aslref SemanticsRule.SReturnSome.asl $ aslref SemanticsRule.SSeq.asl $ aslref SemanticsRule.Block.asl $ aslref SemanticsRule.SAssignCall.asl $ aslref SemanticsRule.SAssignTuple.asl $ aslref SemanticsRule.EBinopImplExFalso.asl $ aslref SemanticsRule.EBinopOrTrue.asl $ aslref SemanticsRule.EBinopAndFalse.asl $ aslref SemanticsRule.SAssertOk.asl $ aslref SemanticsRule.SAssertNo.asl File SemanticsRule.SAssertNo.asl, line 4, characters 10 to 17: ASL Execution error: Assertion failed: (42 == 3). [1] $ aslref SemanticsRule.LEDiscard.asl $ aslref SemanticsRule.LDDiscard.asl $ aslref EvalCatchers.asl 21 $ aslref SemanticsRule.ATCNotDynamicErrorIfFalse.asl $ aslref SemanticsRule.ATCVariousErrors.asl File SemanticsRule.ATCVariousErrors.asl, line 4, characters 2 to 30: ASL Typing error: a subtype of integer {4, 5, 6} was expected, provided integer {2}. [1] $ aslref SemanticsRule.CatchNoThrow.asl No exception raised $ aslref SemanticsRule.EConcat2.asl $ aslref SemanticsRule.LEGlobalVar.asl $ aslref SemanticsRule.SCond2.asl $ aslref SemanticsRule.SCond3.asl $ aslref SemanticsRule.SCond4.asl $ aslref SemanticsRule.STry.asl $ aslref SemanticsRule.EGetEnumArray.asl herd-herdtools7-1ca343e/asllib/tests/ASLSyntaxReference.t/000077500000000000000000000000001475314470400234615ustar00rootroot00000000000000herd-herdtools7-1ca343e/asllib/tests/ASLSyntaxReference.t/ASTRule.Desugar_SCase1.asl000066400000000000000000000005641475314470400301760ustar00rootroot00000000000000func main () => integer begin var x : integer = ARBITRARY: integer; // The following case statement: case x of when 42 => x = 42; when <= 42 => x = 0; otherwise => x = 43; end; // can be desugared into the following condition statement: if x IN {42} then x = 42; else if x IN {<= 42} then x = 0; else x = 43; end; end; return x; end;herd-herdtools7-1ca343e/asllib/tests/ASLSyntaxReference.t/ASTRule.Desugar_SCase2.asl000066400000000000000000000006361475314470400301770ustar00rootroot00000000000000func main () => integer begin var x : integer; // The following case statement: case 3 of when 42 => x = 42; when <= 42 => x = 0; end; // can be desugared into the following statement: let discriminant_var: integer {3} = 3; if discriminant_var IN {42} then x = 42; else if discriminant_var IN {<= 42} then x = 0; else Unreachable(); end; end; return x; end;herd-herdtools7-1ca343e/asllib/tests/ASLSyntaxReference.t/expr1.asl000066400000000000000000000017701475314470400252260ustar00rootroot00000000000000type point of record{x: bits(4), y: bits(4)}; type except of exception; func main() => integer begin var v: integer = 4; // E_Var: v is a variable expression. var - = v; var b0 = '1111 1000'[3:1, 0]; // E_Slice 1: a bitvector slice. var b1 = 0xF8[3:1, 0]; // E_Slice 2: an integer slice. var bits_arr : array [[1]] of bits(4); // E_Binop 1: b0 == b1 is a binary expression for ==. // E_Cond 1: the right-hand side of the assignment is // a conditional expression. bits_arr[[0]] = if (b0 == b1) then '1000' else '0000'; // E_Slice 3: bits_arr[[0]] stands for an array access assert b0 == bits_arr[[0]]; // E_Unop 1: (NOT b8) negates the bits of b8. // E_Binop 2: the right-hand side of the assignment is // a binay AND expression. // E_Concat 1: b0 :: b1 concatenates two bitvectors. // E_Arbitrary 1: ARBITRARY: bits(8) represents an arbitrary // 8-bits bitvector var b8 = b0 :: b1; b8 = (NOT b8) AND ARBITRARY: bits(8); return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSyntaxReference.t/expr2.asl000066400000000000000000000015211475314470400252210ustar00rootroot00000000000000getter g0_bits() => bits(4) begin return '1000'; end; getter g1_bits(p: integer) => bits(4) begin return '1000'[p, 2:0]; end; type point of record{x: bits(4), y: bits(4)}; type except of exception; func main() => integer begin // E_Record 1: a record construction expression. var p = point{x = '1111', y = '0000'}; // E_GetField 1: reading a single field. var b0 = p.x; // E_GetFields 1: reading multiple fields. var b8: bits(8) = p.[x, y]; // E_Concat 1: b0 :: b1 concatenates two bitvectors. b8 = b0 :: b0; // E_Tuple 1: constructing a pair of two 4-bit bitvectors. var t2 = (b0, b0); // E_GetField 2: reading the first tuple item. // E_Pattern 1: the condition in side the if is a pattern. if (t2.item0 IN {'1110'}) then // E_Record 2: an exception construction. throw except{}; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLSyntaxReference.t/run.t000066400000000000000000000002531475314470400244520ustar00rootroot00000000000000Examples used to test syntax and AST building rules: $ aslref expr1.asl $ aslref expr2.asl $ aslref ASTRule.Desugar_SCase1.asl $ aslref ASTRule.Desugar_SCase2.asl herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/000077500000000000000000000000001475314470400234455ustar00rootroot00000000000000herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.AnnotateFuncSig.asl000066400000000000000000000002471475314470400313020ustar00rootroot00000000000000constant W = 4; func signature_example{A,B}( bv: bits(A), bv2: bits(W), bv3: bits(A+B), C: integer) => bits(A+B) begin return bv :: Ones{B}; end; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.ApplyBinopTypes.asl000066400000000000000000000002471475314470400313540ustar00rootroot00000000000000func main() => integer begin var a: bits(10); var b: bits(10); var c: bits(10) = a XOR b; // Check that XOR operator is recognized by the lexer. return 0; end;herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.BuiltinAggregateTypes.asl000066400000000000000000000006321475314470400325120ustar00rootroot00000000000000type Pair of (integer, boolean); type T of array [[3]] of real; type Coord of enumeration { CX, CY, CZ }; type PointArray of array [[Coord]] of real; type PointRecord of record { x : real, y : real, z : real }; func main () => integer begin let p = (0, FALSE); var t1 : T; var t2 : PointArray; t1[[0]] = t2[[CX]]; let o = PointRecord { x=0.0, y=0.0, z=0.0 }; t2[[CZ]] = o.z; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.BuiltinExceptionType.asl000066400000000000000000000003701475314470400323760ustar00rootroot00000000000000type Not_found of exception; type SyntaxException of exception { message:string }; func main () => integer begin if ARBITRARY : boolean then throw Not_found {}; else throw SyntaxException { message="syntax" }; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.BuiltinSingularTypes.asl000066400000000000000000000003101475314470400324010ustar00rootroot00000000000000func main () => integer begin let i : integer = 0; let r : real = 0.0; let s : string = "0.0"; let b : boolean = TRUE; let z4 : bits(4) = '0000'; let o2 : bits(2) = '11'; return 0; end; TypingRule.CheckCommonBitfieldsAlign.Error.asl000066400000000000000000000001361475314470400342470ustar00rootroot00000000000000herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.ttype Nested_Type of bits(2) { [1:0] sub { [0,1] common }, [1:0] common }; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.ConstraintMod.bad.asl000066400000000000000000000003201475314470400315530ustar00rootroot00000000000000func main() => integer begin var x : integer{0..10}; var y = 3; var z = x MOD y; z = 0; z = 1; z = 2; z = 3; // Illegal: the type inferred for z is integer{0..2} return 0; end;TypingRule.EConcatUnresolvableToInteger.asl000066400000000000000000000010051475314470400337030ustar00rootroot00000000000000herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.tfunc foo{N}(x: bits(N)) => bit begin return x[0]; end; config LIMIT1: integer = 2; config LIMIT2: integer{1, 2, 3, 4, 5, 6, 7, 8, 9, 10} = 7; func bar() => integer{1, 2, 3, 4, 5, 6, 7, 8, 9, 10} begin var ret: integer = 0; while ret < LIMIT1 do ret = ret + ret * 2; end; return ret as integer{1, 2, 3, 4, 5, 6, 7, 8, 9, 10}; end; func main() => integer begin let N = bar(); let M = LIMIT2; let x = Zeros(N); let y = Zeros(M); let z = foo([x, y]); return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.EnumerationType.asl000066400000000000000000000001641475314470400314000ustar00rootroot00000000000000type Color of enumeration { RED, BLACK } ; func main () => integer begin assert (RED != BLACK); return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.LDDiscard.asl000066400000000000000000000001441475314470400300370ustar00rootroot00000000000000func main () => integer begin let - = 42; let - = "abc"; let - = '101010'; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.LDTuple.asl000066400000000000000000000002271475314470400275610ustar00rootroot00000000000000type MyT of (integer, integer {0..4}, boolean); func main() => integer begin let (x, -, y) = (5, 3, TRUE); assert x == 5 && y; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.LDTyped.asl000066400000000000000000000003271475314470400275560ustar00rootroot00000000000000type MyT of integer; func foo (t: MyT) => integer begin return t as integer; end; func main () => integer begin let x: MyT = 42; var z: MyT; assert foo (x) == 42; assert foo (z) == 0; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.LDVar.asl000066400000000000000000000001161475314470400272150ustar00rootroot00000000000000func main () => integer begin let x = 3; assert x == 3; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.Lit.asl000066400000000000000000000012031475314470400267730ustar00rootroot00000000000000type MyEnum of enumeration { LABEL_A, LABEL_B, LABEL_C }; func main () => integer begin var n1 = 5; // type: integer{5} var n2 = 1_000__000; // type integer{1000000} var n4 = 0xa_b_c_d_e_f__A__B__C__D__E__F__0___12345567890; // type integer{53170898287292728730499578000} var btrue = TRUE; // type: boolean var bfalse = FALSE; // type: boolean var rzero = 1234567890.0123456789; // type: real var s1 = "hello\\world \n\t \"here I am \""; // type: string var s2 = ""; // type: string var bv1 = '11 01'; // type: bits(4) var bv2 = ''; // type: bits(0) var l1 : MyEnum = LABEL_B; // type: MyEnum return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.TArray.asl000066400000000000000000000010231475314470400274450ustar00rootroot00000000000000// Declare an array of reals from arr1[[0]] to arr1[[3]] type arr1 of array [[4]] of real; // Declare an array with two entries arr2[[big]] and arr2[[little]] type labels of enumeration {big, little}; type arr2 of array [[labels]] of bits(4); func foo(x: array [[4]] of integer) => array [[4]] of integer begin var y = x; y[[3]] = 2; return y; end; func main () => integer begin var x: array [[4]] of integer; x[[1]] = 1; x = foo (x as array [[4]] of integer); let y: array [[4]] of integer = x; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.TBitField.asl000066400000000000000000000005701475314470400300570ustar00rootroot00000000000000type MyType of bits(4) { [3:2] A, [1] B }; func foo (x: bits(4) { [3:2] A, [1] B }) => bits(4) { [3:2] A, [1] B } begin return x; end; func main () => integer begin var x: bits(4) { [3:2] A, [1] B }; x = '1010'; x = foo (x as bits(4) { [3:2] A, [1] B }); let y: bits(4) { [3:2] A, [1] B } = x; assert x as bits(4) { [3:2] A, [1] B } == x; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.TBits.asl000066400000000000000000000003701475314470400272740ustar00rootroot00000000000000type MyType of bits(4); func foo (x: bits(4)) => bits(4) begin return NOT x; end; func main () => integer begin var x: bits(4); x = '1010'; x = foo (x as bits(4)); let y: bits(4) = x; assert x as bits(4) == x; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.TBool.asl000066400000000000000000000004001475314470400272600ustar00rootroot00000000000000type MyType of boolean; func foo (x: boolean) => boolean begin return FALSE --> x; end; func main () => integer begin var x: boolean; x = TRUE; x = foo (x as boolean); let y: boolean = x && x; assert x as boolean == x; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.TEnumDecl.asl000066400000000000000000000000501475314470400300620ustar00rootroot00000000000000type MyEnum of enumeration { A, B, C }; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.TIntParameterized.asl000066400000000000000000000003331475314470400316410ustar00rootroot00000000000000func foo {N} (x: bits(N)) => integer begin return N; end; func bar{N}() => bits(N) begin return Zeros{N}; end; func main() => integer begin assert 3 == foo{3}('101'); assert bar{3} == '000'; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.TIntUnConstrained.asl000066400000000000000000000003571475314470400316270ustar00rootroot00000000000000type MyType of integer; func foo (x: integer) => integer begin return x; end; func main () => integer begin var x: integer; x = 4; x = foo (x as integer); let y: integer = x; assert x as integer == x; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.TIntWellConstrained.asl000066400000000000000000000004661475314470400321510ustar00rootroot00000000000000type MyType of integer {1..12}; func foo (x: integer {1..12}) => integer {1..12} begin return x; end; func main () => integer begin var x: integer {1..12}; x = 4; x = foo (x as integer {1..12}); let y: integer {1..12} = x; let x2 = x as integer {1..11}; assert x2 == x; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.TNamed.asl000066400000000000000000000003511475314470400274160ustar00rootroot00000000000000type MyType of integer; func foo (x: MyType) => MyType begin return x; end; func main () => integer begin var x: MyType; x = 4; x = foo (x as MyType); let y: MyType = x; assert x as MyType == x; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.TNonDecl.asl000066400000000000000000000001141475314470400277110ustar00rootroot00000000000000func (x: record { a: integer, b: boolean }) => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.TReal.asl000066400000000000000000000003531475314470400272570ustar00rootroot00000000000000type MyType of real; func foo (x: real) => real begin return x + 1.0; end; func main () => integer begin var x: real; x = 3.141592; x = foo (x as real); let y: real = x + x; assert x as real == x; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.TRecordExceptionDecl.asl000066400000000000000000000002351475314470400322600ustar00rootroot00000000000000type MyRecord of record { a: integer, b: boolean }; type MyException of exception { a: integer, b: boolean }; func main () => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.TString.asl000066400000000000000000000003531475314470400276420ustar00rootroot00000000000000type MyType of string; func foo (x: string) => string begin return x; end; func main () => integer begin var x: string; x = "foo"; x = foo (x as string); let y: string = x; assert x as string == x; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.TTuple.asl000066400000000000000000000006371475314470400274720ustar00rootroot00000000000000type MyType of (integer, boolean); func foo (x: (integer, boolean)) => (integer, boolean) begin let (z, y): (integer, boolean) = x; return (z + 1, FALSE --> y); end; func main () => integer begin var x: (integer, boolean); x = (3, TRUE); x = foo (x as (integer, boolean)); let y: (integer, boolean) = x; let (x0, x1) = x as (integer, boolean); assert x0 == 4 && x1 == TRUE; return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.TypeSatisfaction1.asl000066400000000000000000000006711475314470400316250ustar00rootroot00000000000000type T1 of integer; // the named type `T1` whose structure is integer type T2 of integer; // the named type `T2` whose structure is integer type pairT of (integer, T1); // the named type `pairT` whose structure is (integer, integer) func main() => integer begin var dataT1: T1; var pair: pairT = (1, dataT1); // legal since the right hand side has anonymous, non-primitive type (integer, T1) return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.TypeSatisfaction2.asl000066400000000000000000000007761475314470400316340ustar00rootroot00000000000000type T1 of integer; // the named type `T1` whose structure is integer type T2 of integer; // the named type `T2` whose structure is integer type pairT of (integer, T1); // the named type `pairT` whose structure is (integer, integer) func main() => integer begin var dataT1: T1; var pair: pairT = (1,dataT1); let dataAsInt: integer = dataT1; pair = (1, dataAsInt); // legal since the right-hand-side has anonymous, // primitive type (integer, integer) return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/TypingRule.TypeSatisfaction3.asl000066400000000000000000000010451475314470400316230ustar00rootroot00000000000000type T1 of integer; // the named type `T1` whose structure is integer type T2 of integer; // the named type `T2` whose structure is integer type pairT of (integer, T1); // the named type `pairT` whose structure is (integer, integer) func main() => integer begin var dataT1: T1; var pair: pairT = (1,dataT1); let dataT2: T2 = 10; pair = (1, dataT2); // illegal since the right-hand-side has anonymous, // non-primitive type (integer, T2) // which does not subtype-satisfy named type pairT return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/hello_world.asl000066400000000000000000000001121475314470400264520ustar00rootroot00000000000000func main() => integer begin println("Hello, world!"); return 0; end; herd-herdtools7-1ca343e/asllib/tests/ASLTypingReference.t/run.t000066400000000000000000000040621475314470400244400ustar00rootroot00000000000000Hello world should work: $ aslref hello_world.asl Hello, world! ASL Typing Tests: $ aslref TypingRule.TypeSatisfaction1.asl $ aslref TypingRule.TypeSatisfaction2.asl $ aslref TypingRule.TypeSatisfaction3.asl File TypingRule.TypeSatisfaction3.asl, line 14, characters 2 to 6: ASL Typing error: a subtype of pairT was expected, provided (integer {1}, T2). [1] // $ aslref TypingRule.EConcatUnresolvableToInteger.asl $ aslref TypingRule.ApplyBinopTypes.asl $ aslref TypingRule.LDDiscard.asl $ aslref TypingRule.LDVar.asl $ aslref TypingRule.LDTyped.asl $ aslref TypingRule.LDTuple.asl $ aslref TypingRule.Lit.asl $ aslref TypingRule.CheckCommonBitfieldsAlign.Error.asl File TypingRule.CheckCommonBitfieldsAlign.Error.asl, line 1, character 20 to line 6, character 1: ASL Typing error: bitfields `sub.common` and `common` are in the same scope but define different slices of the containing bitvector type: [0, 1] and [1:0], respectively. [1] ASL Typing Tests / annotating types: $ aslref TypingRule.TReal.asl $ aslref TypingRule.TBool.asl $ aslref TypingRule.TNamed.asl $ aslref TypingRule.TIntUnConstrained.asl $ aslref TypingRule.TIntWellConstrained.asl $ aslref TypingRule.TIntParameterized.asl $ aslref TypingRule.TBits.asl $ aslref TypingRule.TTuple.asl $ aslref TypingRule.TArray.asl $ aslref --no-exec TypingRule.TEnumDecl.asl $ aslref TypingRule.TRecordExceptionDecl.asl $ aslref TypingRule.TNonDecl.asl File TypingRule.TNonDecl.asl, line 1, characters 5 to 6: ASL Error: Cannot parse. [1] $ aslref TypingRule.TBitField.asl $ aslref --no-exec TypingRule.AnnotateFuncSig.asl $ aslref TypingRule.BuiltinAggregateTypes.asl $ aslref --no-exec TypingRule.BuiltinExceptionType.asl $ aslref TypingRule.BuiltinSingularTypes.asl $ aslref TypingRule.EnumerationType.asl $ aslref TypingRule.TString.asl $ aslref TypingRule.ConstraintMod.bad.asl File TypingRule.ConstraintMod.bad.asl, line 9, characters 4 to 5: ASL Typing error: a subtype of integer {0..2} was expected, provided integer {3}. [1] herd-herdtools7-1ca343e/asllib/tests/ConstraintBinops.ml000066400000000000000000000114011475314470400234000ustar00rootroot00000000000000open Asllib open AST let eval_binop x op y = let pos = ASTUtils.dummy_annotated and t = Error.Static in match Operations.binop_values pos t op (L_Int x) (L_Int y) with | L_Int z -> z | _ -> assert false let eval_expr e = match StaticInterpreter.static_eval StaticEnv.empty e with | L_Int z -> z | _ -> assert false let try_eval_expr e = try eval_expr e |> ASTUtils.expr_of_z with _ -> e let z_in_constraint z c = match StaticOperations.filter_reduce_constraint_div c |> Option.value ~default:c with | Constraint_Exact e -> ( try Z.equal z (eval_expr e) with _ -> false) | Constraint_Range (e1, e2) -> ( try let z1 = eval_expr e1 and z2 = eval_expr e2 in Z.leq z1 z && Z.leq z z2 with _ -> false) let z_in_constraints z cs = List.exists (z_in_constraint z) cs let property op (x, y, cs1, cs2) = assert (z_in_constraints x cs1); assert (z_in_constraints y cs2); (match op with | SHR | SHL | POW -> assert (Z.sign y >= 0) | DIV | DIVRM | MOD -> assert (Z.sign y > 0) | _ -> ()); z_in_constraints (eval_binop x op y) (StaticOperations.constraint_binop op cs1 cs2) let gen_xy op = let open QCheck2.Gen in let base_nat = small_nat in let strict_positive_nat = base_nat >|= ( + ) 1 in let signed_nat = oneof [ base_nat; base_nat >|= ( ~- ) ] in match op with | SHR | SHL | POW -> pair signed_nat base_nat | DIV -> let* y = strict_positive_nat in let+ x = signed_nat >|= ( * ) y in (x, y) | DIVRM | MOD -> pair signed_nat strict_positive_nat | _ -> pair signed_nat signed_nat let gen_cs x = let open QCheck2.Gen in let+ a = small_nat >|= ( - ) x and+ b = small_nat >|= ( + ) x in assert (a <= x); assert (x <= b); (ASTUtils.expr_of_int a, ASTUtils.expr_of_int b) let gen_test_abcd op = let open QCheck2.Gen in let* x, y = gen_xy op in let+ a, b = gen_cs x and+ c, d = gen_cs y in ( Z.of_int x, Z.of_int y, [ Constraint_Range (a, b) ], [ Constraint_Range (c, d) ] ) let gen_test_abc op = let open QCheck2.Gen in let* x, y = gen_xy op in let+ a, b = gen_cs x in let c = ASTUtils.expr_of_int y in (Z.of_int x, Z.of_int y, [ Constraint_Range (a, b) ], [ Constraint_Exact c ]) let gen_test_acd op = let open QCheck2.Gen in let* x, y = gen_xy op in let+ c, d = gen_cs y in let a = ASTUtils.expr_of_int x in (Z.of_int x, Z.of_int y, [ Constraint_Exact a ], [ Constraint_Range (c, d) ]) let print_test op (x, y, cs1, cs2) = try let res = eval_binop x op y in let cs = StaticOperations.constraint_binop op cs1 cs2 in let reduced_cs = List.filter_map StaticOperations.filter_reduce_constraint_div cs |> List.map (function | Constraint_Exact e -> Constraint_Exact (try_eval_expr e) | Constraint_Range (e1, e2) -> Constraint_Range (try_eval_expr e1, try_eval_expr e2)) in Format.asprintf "@[<2>@[%a %s %a = %a@]@ is@ not@ in@ @[<2>[%a] %s [%a]@ = [%a]@ = [%a]@]" Z.pp_print x (PP.binop_to_string op) Z.pp_print y Z.pp_print res PP.pp_int_constraints cs1 (PP.binop_to_string op) PP.pp_int_constraints cs2 PP.pp_int_constraints cs PP.pp_int_constraints reduced_cs with _ -> Format.asprintf "(x=%a, y=%a, cs1=%a, cs2=%a) with op %s resulted in an error" Z.pp_print x Z.pp_print y PP.pp_int_constraints cs1 PP.pp_int_constraints cs2 (PP.binop_to_string op) let long_factor = 1000 let base_count = 10000 let test_abcd op = let count = base_count and name = Printf.sprintf "constraint_binop [a..b] %s [c..d] is sound" (PP.binop_to_string op) in QCheck2.Test.make ~count ~long_factor ~print:(print_test op) ~name (gen_test_abcd op) (property op) let test_abc op = let count = base_count and name = Printf.sprintf "constraint_binop [a..b] %s [c] is sound" (PP.binop_to_string op) in QCheck2.Test.make ~count ~long_factor ~print:(print_test op) ~name (gen_test_abc op) (property op) let test_acd op = let count = base_count and name = Printf.sprintf "constraint_binop [a] %s [c..d] is sound" (PP.binop_to_string op) in QCheck2.Test.make ~count ~long_factor ~print:(print_test op) ~name (gen_test_acd op) (property op) let () = QCheck_runner.run_tests_main [ test_abcd PLUS; test_acd PLUS; test_abc PLUS; test_abcd MINUS; test_acd MINUS; test_abc MINUS; test_abcd MUL; test_acd MUL; test_abc MUL; test_abcd DIV; test_acd DIV; test_abc DIV; test_abcd DIVRM; test_acd DIVRM; test_abc DIVRM; test_abcd MOD; test_acd MOD; test_abc MOD; test_abcd SHR; test_acd SHR; test_abc SHR; test_abcd SHL; test_acd SHL; test_abc SHL; test_abcd POW; test_acd POW; test_abc POW; ] herd-herdtools7-1ca343e/asllib/tests/allow_no_end_semicolon.t000066400000000000000000000006561475314470400244560ustar00rootroot00000000000000We should be able to make semicolons after 'end' optional $ cat >no_semicolon.asl < func main () => integer > begin > if TRUE then > print("test"); > end > return 0; > end > EOF $ aslref no_semicolon.asl File no_semicolon.asl, line 5, characters 2 to 5: ASL Grammar error: Obsolete syntax: Missing ';' after 'end' keyword. [1] $ aslref --allow-no-end-semicolon no_semicolon.asl test herd-herdtools7-1ca343e/asllib/tests/atcs.t000066400000000000000000000050731475314470400206760ustar00rootroot00000000000000Deferred to execution ATCs $ cat >atcs1.asl < func main () => integer begin > let x = (3 as integer {42}); > return 0; > end; > EOF $ aslref atcs1.asl File atcs1.asl, line 2, characters 11 to 12: ASL Execution error: Mismatch type: value 3 does not belong to type integer {42}. [1] Bad structure ATCs $ cat >atcs2.asl < func main () => integer begin > let x = (3 as boolean); > return 0; > end; > EOF $ aslref atcs2.asl File atcs2.asl, line 2, characters 11 to 23: ASL Typing error: cannot perform Asserted Type Conversion on integer {3} by boolean. [1] ATCs on other types $ cat >atcs3.asl < func main () => integer begin > let x = ("a string" as string); > return 0; > end; > EOF $ aslref atcs3.asl $ cat >atcs4.asl < type myty of record { a: integer, b: bits(4)}; > func main () => integer begin > let x = (myty { a = 4, b = Zeros{4} }) as myty; > return 0; > end; > EOF $ aslref atcs4.asl $ cat >atcs5.asl < type myty of record { a: integer, b: bits(4)}; > type myty2 of record { a: integer { 0..10 }, b: bits(4)}; > func main () => integer begin > let x = (myty { a = 4, b = Zeros{4} }) as myty; > let y = x as myty2; > return 0; > end; > EOF $ aslref atcs5.asl File atcs5.asl, line 5, characters 10 to 20: ASL Typing error: cannot perform Asserted Type Conversion on myty by myty2. [1] $ cat > atcs6.asl < type myty of (integer {0..10}, bits(4)); > func main () => integer begin > let x = ((42, Zeros{4}) as myty); > return 0; > end; > EOF $ aslref atcs6.asl File atcs6.asl, line 3, characters 11 to 25: ASL Execution error: Mismatch type: value [42, 0x0] does not belong to type (integer {0..10}, bits(4)). [1] $ cat > atcs7.asl < type myty of (integer {42}, bits(4)); > func main () => integer begin > let x = ((42, Zeros{4}) as myty); > return 0; > end; > EOF $ aslref atcs7.asl $ cat > atcs8.asl < type A of record{ a: integer}; > type B subtypes A; > func main () => integer > begin > let x: A = B { a = 0 }; > var a: array[[10]] of B; > let b = a as array[[10]] of A; > return 0; > end; > EOF $ aslref atcs8.asl ATCs in types: $ cat > atcs9.asl < let bv : bits(1 as integer{2}) = Ones(1); > EOF $ aslref atcs9.asl File atcs9.asl, line 1, characters 14 to 29: ASL Typing error: a pure expression was expected, found 1 as integer {2}, which produces the following side-effects: [PerformsAssertions]. [1] herd-herdtools7-1ca343e/asllib/tests/bad-types.t000066400000000000000000000044631475314470400216360ustar00rootroot00000000000000Bad enumeration $ cat >bad-types1.asl < type t of enumeration {}; > EOF $ aslref bad-types1.asl File bad-types1.asl, line 1, characters 23 to 24: ASL Error: Cannot parse. [1] Invalid bitfields ================== Bad fields $ cat >bad-types2.asl < type t of bits(12) { > [10: 3] a, > [2+:1] a, > }; > EOF $ aslref bad-types2.asl File bad-types2.asl, line 1, character 0 to line 4, character 2: ASL Typing error: cannot declare already declared element "a". [1] Overlapping slices $ cat >bad-types3.asl < type t of bits(64) { > [23: 0] a, > [10: 0, 3+: 2] b, > }; > EOF $ aslref bad-types3.asl File bad-types3.asl, line 1, character 0 to line 4, character 2: ASL Static error: overlapping slices 0+:11, 3+:2. [1] Bad slices $ cat >bad-types4.asl < type t of bits(12) { > [10: 3] a, > [14:12] b, > }; > EOF $ aslref bad-types4.asl File bad-types4.asl, line 1, character 0 to line 4, character 2: ASL Static error: Cannot extract from bitvector of length 12 slice 12+:3. [1] $ cat >bad-types5.asl < type t of bits(12) { > [10: 3] a, > [-2+:1] b, > }; > EOF $ aslref bad-types5.asl File bad-types5.asl, line 1, character 0 to line 4, character 2: ASL Static error: Cannot extract from bitvector of length 12 slice (- 2)+:1. [1] $ cat >bad-types6.asl < type t of bits(12) { > [10: 3] a, > [7+:3] b { > [1] d, > [10:8] c, > }, > }; > EOF $ aslref bad-types6.asl File bad-types6.asl, line 1, character 0 to line 7, character 2: ASL Static error: Cannot extract from bitvector of length 3 slice 8+:3. [1] Empty types =========== Arbitrary of empty type $ cat >bad-types7.asl < func main () => integer > begin > let b: integer {1..0} = ARBITRARY: integer {1..0}; > return 0; > end; > EOF $ aslref bad-types7.asl File bad-types7.asl, line 3, characters 38 to 52: ASL Execution error: ARBITRARY of empty type integer {1..0}. [1] Base value of empty type $ cat >bad-types8.asl < func main () => integer > begin > var b: integer {1..0}; > return 0; > end; > EOF $ aslref bad-types8.asl File bad-types8.asl, line 3, characters 2 to 24: ASL Typing error: base value of empty type integer {1..0}. [1] herd-herdtools7-1ca343e/asllib/tests/bitfield-alignment.t/000077500000000000000000000000001475314470400235525ustar00rootroot00000000000000herd-herdtools7-1ca343e/asllib/tests/bitfield-alignment.t/bad-scope1.asl000066400000000000000000000001071475314470400261670ustar00rootroot00000000000000type Nested_Type of bits(2) { [1:0] sub { [0] sub } }; herd-herdtools7-1ca343e/asllib/tests/bitfield-alignment.t/bad-scope2.asl000066400000000000000000000001511475314470400261670ustar00rootroot00000000000000type Nested_Type of bits(2) { [1:0] sub { [1:0] sub { [1] sub } } }; herd-herdtools7-1ca343e/asllib/tests/bitfield-alignment.t/bad-scope3.asl000066400000000000000000000002011475314470400261640ustar00rootroot00000000000000type Nested_Type of bits(2) { [1:0] sub { [1:0] sub { [0,1] lowest } }, [1,0] lowest }; herd-herdtools7-1ca343e/asllib/tests/bitfield-alignment.t/good-scope1.asl000066400000000000000000000002011475314470400263640ustar00rootroot00000000000000type Nested_Type of bits(2) { [1:0] sub { [1:0] sub { [1,0] lowest } }, [1:0] lowest }; herd-herdtools7-1ca343e/asllib/tests/bitfield-alignment.t/good-slice_equivalence.asl000066400000000000000000000006551475314470400306670ustar00rootroot00000000000000type Nested_Type of bits(16) { [15, 14, 13, 12, 11, 10, 9, 8, 7, 6, 5, 4, 3, 2, 1, 0] all, // [12, 11, 10, 9] [7, 6, 5, 4, 3, 2] [12:9, 7:2] slices { // slices = [12:9, 7:2] [5:2, 9:8, 7:6] sub // [7:4][12:9] slices.sub }, // [12, 11, 10, 9] [7, 6, 5, 4, 3, 2] [9+:4, 2+:6] slices1 { // slices1 = [12:9, 7:2] [5:2, 9:8, 7:6] sub // [7:4][12:9] slices1.sub }, [7:4, 12:9] sub }; herd-herdtools7-1ca343e/asllib/tests/bitfield-alignment.t/run.t000066400000000000000000000016501475314470400245450ustar00rootroot00000000000000 $ aslref --no-exec good-slice_equivalence.asl $ aslref --no-exec good-scope1.asl $ aslref --no-exec bad-scope1.asl File bad-scope1.asl, line 1, character 20 to line 5, character 1: ASL Typing error: bitfields `sub` and `sub.sub` are in the same scope but define different slices of the containing bitvector type: [1:0] and [0], respectively. [1] $ aslref --no-exec bad-scope2.asl File bad-scope2.asl, line 1, character 20 to line 7, character 1: ASL Typing error: bitfields `sub` and `sub.sub.sub` are in the same scope but define different slices of the containing bitvector type: [1:0] and [1], respectively. [1] $ aslref --no-exec bad-scope3.asl File bad-scope3.asl, line 1, character 20 to line 9, character 1: ASL Typing error: bitfields `sub.sub.lowest` and `lowest` are in the same scope but define different slices of the containing bitvector type: [0, 1] and [1:0], respectively. [1] herd-herdtools7-1ca343e/asllib/tests/bitvector.ml000066400000000000000000000261651475314470400221170ustar00rootroot00000000000000open Helpers module BV = Asllib.Bitvector let _debug = false let of_string_to_string () = let one s = let res = s |> BV.of_string |> BV.to_string in assert (String.equal s res) in List.iter one [ "'1100'"; "'10110101'"; "''"; "'1010101010101010'"; "'11001100101'"; "'1110000000001101'"; "'11110000111100001111'"; ] let test_not () = let one (s1, s2) = let res = s1 |> BV.of_string |> BV.lognot |> BV.to_string in assert (String.equal res s2) in List.iter one [ ("''", "''"); ("'0'", "'1'"); ("'1'", "'0'"); ("'1010'", "'0101'"); ("'11110000'", "'00001111'"); ("'111100001111'", "'000011110000'"); ("'11110000111100001111'", "'00001111000011110000'"); ] let test_equal () = let one (b, s1, s2) = let bv1 = BV.of_string s1 and bv2 = BV.of_string s2 in let res = BV.equal bv1 bv2 in let () = if _debug then Format.( eprintf "@[%a %s %a@]@." BV.pp_t bv1 (if res then "==" else "!=") BV.pp_t bv2) in assert (b = res) in List.iter one [ (true, "''", "''"); (true, "'1'", "'1'"); (false, "'1'", "'0'"); (false, "'10'", "'11'"); (true, "'10'", "'10'"); (true, "'1010'", "'1010'"); (false, "'1010'", "'1011'"); (true, "'11110000'", "'11110000'"); (false, "'11110000'", "'10110000'"); (true, "'111100001111'", "'111100001111'"); (false, "'111100001111'", "'111100001110'"); (false, "'111100001111'", "'111101001111'"); (false, "'111100001111'", "'101100001111'"); (true, "'11110000111100001111'", "'11110000111100001111'"); (false, "'11110000111100001111'", "'11110000111000001111'"); (false, "'11110000111100001111'", "'11110000111101001111'"); (false, "'11110000111100001111'", "'11110000111100001101'"); (false, "'11110000111100001111'", "'11010000111100001111'"); (false, "'11110000111100001111'", "'11110010111100001111'"); ] let test_and () = let one (s1, s2, s3) = let bv1 = BV.of_string s1 and bv2 = BV.of_string s2 and bv3 = BV.of_string s3 in let res = BV.logand bv1 bv2 in let () = if _debug then Format.( eprintf "@[%a /\\ %a = %a (expected: %a)@]@." BV.pp_t bv1 BV.pp_t bv2 BV.pp_t res BV.pp_t bv3) in assert (BV.equal res bv3) in List.iter one [ ("'1'", "'1'", "'1'"); ("'1'", "'0'", "'0'"); ("'0'", "'1'", "'0'"); ("'0'", "'0'", "'0'"); ("'10'", "'11'", "'10'"); ("'10'", "'01'", "'00'"); ("'11110000'", "'11001100'", "'11000000'"); ("'111100001111'", "'110011001100'", "'110000001100'"); ("'1111000011001100'", "'1100110011110000'", "'1100000011000000'"); ] let test_with_ints () = let one (i, s) = let () = if _debug then Format.eprintf "Comparing %d and %a => %d@." i BV.pp_t (BV.of_string s) (BV.to_int (BV.of_string s)) in (* assert (BV.equal (BV.of_int i) (BV.of_string s)); *) (* assert (String.equal (BV.to_string (BV.of_int i)) s); *) assert (Int.equal i (BV.to_int (BV.of_string s))); assert (Int.equal i (BV.to_int (BV.of_int i))) in List.iter one [ (0x0, "''"); (0x0, "'0'"); (0x0, "'000'"); (0x1, "'1'"); (0x1, "'01'"); (0x1, "'0000000001'"); (0x100, "'100000000'"); (0x100, "'00100000000'"); (0x502, "'10100000010'"); (0x30502, "'110000010100000010'"); (0x20502, "'100000010100000010'"); ] let test_with_int64 () = let one (i, s) = let s = Printf.sprintf "'%64s'" s in let s = String.map (function ' ' -> '0' | c -> c) s in let () = if _debug then Format.eprintf "Comparing %s to %s (%a to %a)@." (Int64.to_string i) s BV.pp_t (BV.of_int64 i) BV.pp_t (BV.of_string s) in assert (BV.equal (BV.of_int64 i) (BV.of_string s)); assert (String.equal (BV.to_string (BV.of_int64 i)) s); assert (Int64.equal i (BV.to_int64_unsigned (BV.of_string s))); assert (Int64.equal i (BV.to_int64_unsigned (BV.of_int64 i))) in List.iter one [ (0x0L, ""); (0x0L, "0"); (0x0L, "000"); (0x1L, "1"); (0x1L, "01"); (0x1L, "0000000001"); (0x100L, "100000000"); (0x100L, "00100000000"); (0x502L, "10100000010"); (0x30502L, "110000010100000010"); (0x20502L, "100000010100000010"); (0xffffffffL, "11111111111111111111111111111111"); (0xfffffffeL, "11111111111111111111111111111110"); (0x2L, "00000000000000000000000000000010"); ] let test_with_z () = let one (i, s) = let len = String.length s in let () = if _debug then Printf.eprintf "Comparing %s to %s\nand %s to %s\nand %s and %s\n%!" (Z.to_string i) s (BV.to_string (BV.of_z len i)) s (Z.to_string i) (Z.to_string (BV.to_z_unsigned (BV.of_string s))) in assert (BV.equal (BV.of_z len i) (BV.of_string s)); assert (String.equal (BV.to_string (BV.of_z len i)) ("'" ^ s ^ "'")); assert (Z.equal i (BV.to_z_unsigned (BV.of_string s))); assert (Z.equal i (BV.to_z_unsigned (BV.of_z len i))) in List.iter one [ (Z.of_string "0x0", ""); (Z.of_string "0x0", "0"); (Z.of_string "0x0", "000"); (Z.of_string "0x1", "1"); (Z.of_string "0x1", "01"); (Z.of_string "0x1", "0000000001"); (Z.of_string "0x100", "100000000"); (Z.of_string "0x100", "00100000000"); (Z.of_string "0x502", "10100000010"); (Z.of_string "0x30502", "110000010100000010"); (Z.of_string "0x20502", "100000010100000010"); (Z.of_string "0xffff", "1111111111111111"); (Z.of_string "0xffffffff", "11111111111111111111111111111111"); (Z.of_string "0xfffffffe", "11111111111111111111111111111110"); (Z.of_string "0x2", "00000000000000000000000000000010"); ]; assert (Z.equal Z.one (BV.to_z_unsigned (BV.of_string "1"))); for i = 1 to 17 do let x = BV.of_z i Z.minus_one and y = BV.of_z i (Z.add Z.minus_one (Z.shift_left Z.one i)) in if _debug then Format.eprintf "%a - %a@." BV.pp_t x BV.pp_t y; assert (String.equal (BV.to_string x) (BV.to_string y)); assert (BV.equal y x); () done; () let test_with_int64_signed () = let one (i, s) = let of_s = BV.to_int64_signed (BV.of_string s) in let of_i = BV.to_int64_signed (BV.of_int64 i) in let () = if _debug then Format.eprintf "Comparing %s to %a(i=%s) and %a(s=%s)@." (Int64.to_string i) BV.pp_t (BV.of_int64 i) (Int64.to_string of_i) BV.pp_t (BV.of_string s) (Int64.to_string of_s) in assert (Int64.equal i of_s); assert (Int64.equal i of_i) in List.iter one [ (-0x1L, "11111111111111111111111111111111"); (-0x2L, "11111111111111111111111111111110"); (0x2L, "00000000000000000000000000000010"); ] let test_read_slice () = let one (src, positions, expected) = let src = BV.of_string src and expected = BV.of_string expected in let result = BV.extract_slice src positions in let () = if _debug then Format.eprintf "@[Reading %a at positions @[[%a]@]@ --> %a (%B)@]@." BV.pp_t src Format.(pp_print_list ~pp_sep:pp_print_space pp_print_int) positions BV.pp_t result (BV.equal expected result) in assert (BV.equal expected result) in List.iter one [ ("1111000011001100", [], ""); ("1111000011001100", [ 2 ], "1"); ("1111000011001100", [ 1 ], "0"); ("1111000011001100", [ 10 ], "0"); ("1111000011001100", [ 12 ], "1"); ("1111000011001100", [ 0; 1; 2; 3 ], "0011"); ("1111000011001100", [ 3; 2; 1; 0 ], "1100"); ("1111000011001100", [ 4; 3; 2; 1 ], "0110"); ("1111000011001100", [ 9; 8; 7; 6 ], "0011"); ("1111000011001100", [ 15; 0; 15; 0 ], "1010"); ] let test_write_slice () = let one (dst, positions, src, expected) = let src = BV.of_string src and dst = BV.of_string dst and expected = BV.of_string expected in let result = BV.write_slice dst src positions in let () = if _debug then Format.( eprintf "@[Writing %a to positions @[[%a]@]@ into %a@ gave %a@;\ <1 4>(%a was expected).@]@." BV.pp_t src (pp_print_list ~pp_sep:pp_print_space pp_print_int) positions BV.pp_t dst BV.pp_t result BV.pp_t expected) in assert (BV.equal expected result) in List.iter one [ ("1111000011001100", [], "", "1111000011001100"); ("1111000011001100", [ 0 ], "0", "1111000011001100"); ("1111000011001100", [ 0 ], "1", "1111000011001101"); ("1111000011001100", [ 3 ], "0", "1111000011000100"); ("1111000011001100", [ 12 ], "0", "1110000011001100"); ("1111000011001100", [ 3; 2; 1; 0 ], "0011", "1111000011000011"); ("1111000011001100", [ 0; 1; 2; 3 ], "1100", "1111000011000011"); ("1111000011001100", [ 15; 9; 8; 7 ], "0110", "0111001101001100"); ] let test_concat () = let one args = let expected = String.concat "" args in let result = BV.concat @@ List.map BV.of_string args in let expected = BV.of_string expected in let () = if _debug then Format.eprintf "Assert %a = %a@." BV.pp_t result BV.pp_t expected in assert (BV.equal result expected) in List.iter one [ []; [ "1100" ]; [ "1100"; "11110000" ]; [ "11110000"; "101" ]; [ "0011110000"; "11" ]; [ "11"; "010"; "10"; "110011001"; "10" ]; [ "11"; "0011001"; "1111" ]; [ "11"; "110011001"; "11" ]; [ "11"; "00110011001"; "11" ]; [ "11"; "101011001"; "11" ]; [ "11"; "011001"; "11" ]; [ "11110000"; "0101"; "1010"; "0011" ]; [ "11110000"; "0101"; "1010"; "011" ]; ] let test_mask () = let one (s, m, b) = let () = if _debug then Format.eprintf "Assert %s %s match %s@." s (if b then "does" else "doesn't") m in assert (b == BV.matches (BV.of_string s) (BV.mask_of_string m)) in List.iter one [ ("10", "xx", true); ("10", "10", true); ("10", "1x", true); ("10", "11", false); ("1", "1", true); ("0", "0", true); ("0", "1", false); ("1", "0", false); ("1", "x", true); ("0", "x", true); ] let test_of_int_sized () = let left = BV.of_int_sized 64 ~-1 in let right = BV.ones 64 in let () = if _debug then Format.eprintf "Assert %a == %a@." BV.pp_t left BV.pp_t right in assert (BV.equal (BV.of_int_sized 64 ~-1) (BV.ones 64)) let () = exec_tests [ ("bitvector/of_string_to_string", of_string_to_string); ("bitvector/not", test_not); ("bitvector/equal", test_equal); ("bitvector/and", test_and); ("bitvector/with_ints", test_with_ints); ("bitvector/with_int64", test_with_int64); ("bitvector/with_z", test_with_z); ("bitvector/read_slice", test_read_slice); ("bitvector/write_slice", test_write_slice); ("bitvector/concat", test_concat); ("bitvector/signed_int64", test_with_int64_signed); ("bitvector/masks", test_mask); ("bitvector/of_int_sized", test_of_int_sized); ] herd-herdtools7-1ca343e/asllib/tests/check-no-missing-file-in-run.sh000077500000000000000000000006471475314470400254010ustar00rootroot00000000000000#!/bin/bash set -o errexit # Used to exit upon error, avoiding cascading errors set -o nounset # Exposes unset variables counter=0 for d in "$1"/asllib/tests/*.t/; do for f in $(git ls-files HEAD "$d*.asl"); do if ! grep -q "${f##*/}" "${d}run.t"; then echo "ASL file committed and not run: $f"; counter=$counter+1; fi; done done if [[ $counter -gt 0 ]]; then exit 1; else exit 0; fi; herd-herdtools7-1ca343e/asllib/tests/control-flow.t/000077500000000000000000000000001475314470400224415ustar00rootroot00000000000000herd-herdtools7-1ca343e/asllib/tests/control-flow.t/always-throw.asl000066400000000000000000000003661475314470400256100ustar00rootroot00000000000000type E of exception {}; func always_throws () => integer begin throw E {}; end; func main () => integer begin var y: integer = 0; try let x = always_throws (); catch when E => y = 42; end; assert y == 42; return 0; end; herd-herdtools7-1ca343e/asllib/tests/control-flow.t/if-return-if.asl000066400000000000000000000003701475314470400254510ustar00rootroot00000000000000func sign (n: integer) => integer begin if n <= 0 then return -1; else if n >= 0 then return 1; end; end; end; func main () => integer begin assert (sign (-1) == -1); assert (sign (-2) == -1); assert (sign (2) == 1); return 0; end; herd-herdtools7-1ca343e/asllib/tests/control-flow.t/if-return-return.asl000066400000000000000000000003441475314470400263730ustar00rootroot00000000000000func sign (n: integer) => integer begin if n <= 0 then return -1; else return 1; end; end; func main () => integer begin assert (sign (-1) == -1); assert (sign (-2) == -1); assert (sign (2) == 1); return 0; end; herd-herdtools7-1ca343e/asllib/tests/control-flow.t/if-return-throw.asl000066400000000000000000000003771475314470400262250ustar00rootroot00000000000000type E of exception {}; func foo (x: integer) => integer begin if x >= 0 then return x; else throw E {}; end; end; func main () => integer begin let res2 = foo (2); let res3 = foo (3); assert res2 == 2; assert res3 == 3; return 0; end; herd-herdtools7-1ca343e/asllib/tests/control-flow.t/if-return.asl000066400000000000000000000001151475314470400250520ustar00rootroot00000000000000func sign (n: integer) => integer begin if n >= 0 then return 1; end; end; herd-herdtools7-1ca343e/asllib/tests/control-flow.t/inherited-always-throw.asl000066400000000000000000000005231475314470400275540ustar00rootroot00000000000000type E of exception {}; func always_throws () => integer begin throw E {}; end; func inherited_always_throws () => integer begin let - = always_throws (); end; func main () => integer begin var y: integer = 0; try let x = inherited_always_throws (); catch when E => y = 42; end; assert y == 42; return 0; end; herd-herdtools7-1ca343e/asllib/tests/control-flow.t/no-return.asl000066400000000000000000000000431475314470400250700ustar00rootroot00000000000000func main () => integer begin end; herd-herdtools7-1ca343e/asllib/tests/control-flow.t/run.t000066400000000000000000000034411475314470400234340ustar00rootroot00000000000000 $ aslref no-return.asl File no-return.asl, line 2, character 5: ASL Typing error: the function "main" may not terminate by returning a value or raising an exception.. [1] $ aslref with-return.asl $ aslref always-throw.asl $ aslref inherited-always-throw.asl File inherited-always-throw.asl, line 10, characters 2 to 27: ASL Typing error: the function "inherited_always_throws" may not terminate by returning a value or raising an exception.. [1] $ aslref if-return.asl File if-return.asl, line 3, characters 2 to 31: ASL Typing error: the function "sign" may not terminate by returning a value or raising an exception.. [1] $ aslref if-return-return.asl $ aslref if-return-throw.asl $ aslref if-return-if.asl File if-return-if.asl, line 3, character 2 to line 5, character 6: ASL Typing error: the function "sign" may not terminate by returning a value or raising an exception.. [1] $ aslref try-00.asl $ aslref try-01.asl File try-01.asl, line 5, character 2 to line 6, character 41: ASL Typing error: the function "test0" may not terminate by returning a value or raising an exception.. [1] $ aslref try-02.asl $ aslref try-03.asl $ aslref try-04.asl File try-04.asl, line 5, character 2 to line 9, character 6: ASL Typing error: the function "test0" may not terminate by returning a value or raising an exception.. [1] $ aslref try-05.asl File try-05.asl, line 6, character 2 to line 11, character 6: ASL Typing error: the function "test0" may not terminate by returning a value or raising an exception.. [1] $ aslref try-06.asl File try-06.asl, line 5, character 2 to line 9, character 6: ASL Typing error: the function "test0" may not terminate by returning a value or raising an exception.. [1] herd-herdtools7-1ca343e/asllib/tests/control-flow.t/try-00.asl000066400000000000000000000003071475314470400241750ustar00rootroot00000000000000type E of exception {}; func test0 () => integer begin try return 0; catch when E => return 1; end; end; func main () => integer begin let res = test0(); assert res == 0; return 0; end; herd-herdtools7-1ca343e/asllib/tests/control-flow.t/try-01.asl000066400000000000000000000003201475314470400241710ustar00rootroot00000000000000type E of exception {}; func test0 () => integer begin try return 0; catch when E => print("caught E"); end; end; func main () => integer begin let res = test0(); assert res == 0; return 0; end; herd-herdtools7-1ca343e/asllib/tests/control-flow.t/try-02.asl000066400000000000000000000003111475314470400241720ustar00rootroot00000000000000type E of exception {}; func test0 () => integer begin try throw E {}; catch when E => return 1; end; end; func main () => integer begin let res = test0(); assert res == 1; return 0; end; herd-herdtools7-1ca343e/asllib/tests/control-flow.t/try-03.asl000066400000000000000000000003521475314470400242000ustar00rootroot00000000000000type E of exception {}; func test0 () => integer begin try return 0; catch when E => return 1; otherwise => throw E {}; end; end; func main () => integer begin let res = test0(); assert res == 0; return 0; end; herd-herdtools7-1ca343e/asllib/tests/control-flow.t/try-04.asl000066400000000000000000000003641475314470400242040ustar00rootroot00000000000000type E of exception {}; func test0 () => integer begin try return 0; catch when E => return 1; otherwise => println("Otherwise"); end; end; func main () => integer begin let res = test0(); assert res == 0; return 0; end; herd-herdtools7-1ca343e/asllib/tests/control-flow.t/try-05.asl000066400000000000000000000004471475314470400242070ustar00rootroot00000000000000type E of exception {}; type F of exception {}; func test0 () => integer begin try throw E {}; catch when E => return 1; when F => println("Caught F"); otherwise => throw E {}; end; end; func main () => integer begin let res = test0(); assert res == 0; return 0; end; herd-herdtools7-1ca343e/asllib/tests/control-flow.t/try-06.asl000066400000000000000000000003571475314470400242100ustar00rootroot00000000000000type E of exception {}; func test0 () => integer begin try print("body"); catch when E => return 1; otherwise => throw E {}; end; end; func main () => integer begin let res = test0(); assert res == 0; return 0; end; herd-herdtools7-1ca343e/asllib/tests/control-flow.t/with-return.asl000066400000000000000000000000571475314470400254340ustar00rootroot00000000000000func main () => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/division.t/000077500000000000000000000000001475314470400216405ustar00rootroot00000000000000herd-herdtools7-1ca343e/asllib/tests/division.t/TNegative9-1.asl000066400000000000000000000006041475314470400244560ustar00rootroot00000000000000func negative9(N : integer {8,16}, M : integer {8,16}, X : integer) begin let testB : bits(N) = Zeros{N DIV 4} :: Zeros{N DIV 2}; // bits(3N/4) != bits(N) // Type of Zeros{N} its bits(N), not bits(M), so this is illegal regardless of the fact that N and M have the same domain, // they could have different runtime values so we must evaluate the type safety symbolically end; herd-herdtools7-1ca343e/asllib/tests/division.t/TPositive9.asl000066400000000000000000000003201475314470400243530ustar00rootroot00000000000000func positive9(N : integer {8,16}, M : integer {8,16}) begin let testF : bits(N) = Zeros{N DIV 2} :: Zeros{N DIV 2}; // type system must work out that [bits(N/2), bits(N/2)] is the same as bits(N) end; herd-herdtools7-1ca343e/asllib/tests/division.t/div-by-param.asl000066400000000000000000000002161475314470400246300ustar00rootroot00000000000000func foo {N} (x: bits(N)) begin let y = 5 DIV (N + 1); end; func main () => integer begin foo {1}('1'); foo {0}(''); return 0; end; herd-herdtools7-1ca343e/asllib/tests/division.t/div-constants.asl000066400000000000000000000001771475314470400251420ustar00rootroot00000000000000constant x: integer = 1; constant y: integer = 2; constant z: integer = x DIV y; func main () => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/division.t/div-multi-slices-zero.asl000066400000000000000000000002051475314470400265050ustar00rootroot00000000000000func main() => integer begin let x: integer {2, 4, 8} = 8; let y: integer {0, 1, 2} = 1; let z = x DIV y; return 0; end; herd-herdtools7-1ca343e/asllib/tests/division.t/div-multi-slices.asl000066400000000000000000000002011475314470400255240ustar00rootroot00000000000000func main() => integer begin let x: integer {2, 4, 8} = 8; let y: integer {1, 2} = 1; let z = x DIV y; return 0; end; herd-herdtools7-1ca343e/asllib/tests/division.t/dynamic-div-neg.asl000066400000000000000000000001601475314470400253110ustar00rootroot00000000000000func main () => integer begin let x: integer = 6; let y: integer = -3; let z = x DIV y; return 0; end; herd-herdtools7-1ca343e/asllib/tests/division.t/dynamic-div-undiv.asl000066400000000000000000000001571475314470400256730ustar00rootroot00000000000000func main () => integer begin let x: integer = 5; let y: integer = 3; let z = x DIV y; return 0; end; herd-herdtools7-1ca343e/asllib/tests/division.t/dynamic-div-zero.asl000066400000000000000000000001571475314470400255250ustar00rootroot00000000000000func main () => integer begin let x: integer = 6; let y: integer = 0; let z = x DIV y; return 0; end; herd-herdtools7-1ca343e/asllib/tests/division.t/dynamic-divrm-neg.asl000066400000000000000000000001621475314470400256520ustar00rootroot00000000000000func main () => integer begin let x: integer = 6; let y: integer = -3; let z = x DIVRM y; return 0; end; herd-herdtools7-1ca343e/asllib/tests/division.t/dynamic-divrm-zero.asl000066400000000000000000000001611475314470400260570ustar00rootroot00000000000000func main () => integer begin let x: integer = 6; let y: integer = 0; let z = x DIVRM y; return 0; end; herd-herdtools7-1ca343e/asllib/tests/division.t/dynamic-mod-neg.asl000066400000000000000000000001601475314470400253060ustar00rootroot00000000000000func main () => integer begin let x: integer = 6; let y: integer = -3; let z = x MOD y; return 0; end; herd-herdtools7-1ca343e/asllib/tests/division.t/dynamic-mod-zero.asl000066400000000000000000000001571475314470400255220ustar00rootroot00000000000000func main () => integer begin let x: integer = 6; let y: integer = 0; let z = x MOD y; return 0; end; herd-herdtools7-1ca343e/asllib/tests/division.t/examples.asl000066400000000000000000000004531475314470400241610ustar00rootroot00000000000000func main () => integer begin assert 6 DIV 3 == 2; assert 6 DIVRM 3 == 2; assert 6 MOD 3 == 0; assert -6 DIV 3 == -2; assert -6 DIVRM 3 == -2; assert -6 MOD 3 == 0; assert 5 DIVRM 3 == 1; assert 5 MOD 3 == 2; assert -5 DIVRM 3 == -2; assert -5 MOD 3 == 1; return 0; end; herd-herdtools7-1ca343e/asllib/tests/division.t/param-div-2.asl000066400000000000000000000004221475314470400243560ustar00rootroot00000000000000func foo {N} (bv: bits(N)) => bits(N) begin let y = Ones {N DIV 2}; return Zeros{N DIV 2} :: y; end; func main () => integer begin // This one should work assert foo{2}('10') == '01'; // This one should fail at runtime let - = foo{3}('101'); return 0; end; herd-herdtools7-1ca343e/asllib/tests/division.t/rat-poly-00.asl000066400000000000000000000004541475314470400243300ustar00rootroot00000000000000func FirstHalf {N} (bv: bits(N)) => bits (N DIV 2) begin return bv[0+:N DIV 2]; end; func main () => integer begin let a = FirstHalf{4}(Ones{4}); assert a == '11'; let b = FirstHalf{0}(Zeros{0}); assert b == ''; let c = FirstHalf{7}(Zeros{7}); assert c == '000'; return 0; end; herd-herdtools7-1ca343e/asllib/tests/division.t/rat-poly-01.asl000066400000000000000000000004411475314470400243250ustar00rootroot00000000000000func foo {N} (x: bits(N)) => bits(N) begin let y = Zeros{2 * ((N DIV 2) - 5)}; let z = Zeros{10}; return y :: z; end; func main () => integer begin let a = foo{20}(Zeros{20}); let b = foo{10}(Zeros{10}); let c = foo{8}(Zeros{8}); let d = foo{9}(Zeros{9}); return 0; end; herd-herdtools7-1ca343e/asllib/tests/division.t/run.t000066400000000000000000000132661475314470400226410ustar00rootroot00000000000000Simple division checks: $ aslref examples.asl Division by zero: $ aslref static-div-zero.asl File static-div-zero.asl, line 3, characters 19 to 26: All values in constraints {0} would fail with op DIV, operation will always fail. File static-div-zero.asl, line 3, characters 19 to 26: ASL Typing error: Illegal application of operator DIV on types integer {6} and integer {0}. [1] $ aslref static-divrm-zero.asl File static-divrm-zero.asl, line 3, characters 19 to 28: All values in constraints {0} would fail with op DIVRM, operation will always fail. File static-divrm-zero.asl, line 3, characters 19 to 28: ASL Typing error: Illegal application of operator DIVRM on types integer {6} and integer {0}. [1] $ aslref static-mod-zero.asl File static-mod-zero.asl, line 3, characters 19 to 26: All values in constraints {0} would fail with op MOD, operation will always fail. File static-mod-zero.asl, line 3, characters 19 to 26: ASL Typing error: Illegal application of operator MOD on types integer {6} and integer {0}. [1] Unsupported divisions (caught at type-checking time): $ aslref static-div-neg.asl File static-div-neg.asl, line 3, characters 19 to 27: All values in constraints {(- 3)} would fail with op DIV, operation will always fail. File static-div-neg.asl, line 3, characters 19 to 27: ASL Typing error: Illegal application of operator DIV on types integer {6} and integer {(- 3)}. [1] $ aslref static-divrm-neg.asl File static-divrm-neg.asl, line 3, characters 19 to 29: All values in constraints {(- 3)} would fail with op DIVRM, operation will always fail. File static-divrm-neg.asl, line 3, characters 19 to 29: ASL Typing error: Illegal application of operator DIVRM on types integer {6} and integer {(- 3)}. [1] $ aslref static-mod-neg.asl File static-mod-neg.asl, line 3, characters 19 to 27: All values in constraints {(- 3)} would fail with op MOD, operation will always fail. File static-mod-neg.asl, line 3, characters 19 to 27: ASL Typing error: Illegal application of operator MOD on types integer {6} and integer {(- 3)}. [1] $ aslref --no-exec static-div-undiv.asl File static-div-undiv.asl, line 3, characters 19 to 26: Division will result in empty constraint set, so will always fail. File static-div-undiv.asl, line 3, characters 19 to 26: ASL Typing error: Illegal application of operator DIV on types integer {5} and integer {3}. [1] $ aslref --no-exec static-div-undiv-bis.asl File static-div-undiv-bis.asl, line 3, characters 11 to 18: Division will result in empty constraint set, so will always fail. File static-div-undiv-bis.asl, line 3, characters 11 to 18: ASL Typing error: Illegal application of operator DIV on types integer {1} and integer {2}. [1] $ aslref static-div-undiv-bis.asl File static-div-undiv-bis.asl, line 3, characters 11 to 18: Division will result in empty constraint set, so will always fail. File static-div-undiv-bis.asl, line 3, characters 11 to 18: ASL Typing error: Illegal application of operator DIV on types integer {1} and integer {2}. [1] $ aslref --no-exec static-div-undiv-ter.asl $ aslref --no-exec static-div-intervals.asl $ aslref --no-exec static-mod-intervals.asl For completeness, those operations are dynamic errors: $ aslref dynamic-div-neg.asl ASL Dynamic error: Illegal application of operator DIV for values 6 and -3. [1] $ aslref dynamic-divrm-neg.asl ASL Dynamic error: Illegal application of operator DIVRM for values 6 and -3. [1] $ aslref dynamic-mod-neg.asl ASL Dynamic error: Illegal application of operator MOD for values 6 and -3. [1] $ aslref dynamic-div-zero.asl ASL Dynamic error: Illegal application of operator DIV for values 6 and 0. [1] $ aslref dynamic-divrm-zero.asl ASL Dynamic error: Illegal application of operator DIVRM for values 6 and 0. [1] $ aslref dynamic-mod-zero.asl ASL Dynamic error: Illegal application of operator MOD for values 6 and 0. [1] $ aslref dynamic-div-undiv.asl ASL Dynamic error: Illegal application of operator DIV for values 5 and 3. [1] Parametric examples: $ aslref param-div-2.asl ASL Dynamic error: Illegal application of operator DIV for values 3 and 2. [1] More complicated examples ========================= Fails because N typing cannot infer that N + 1 is strictly positive. $ aslref div-by-param.asl ASL Dynamic error: Illegal application of operator DIV for values 5 and 2. [1] Examples with multiple constraints in slices: $ aslref div-multi-slices.asl $ aslref div-multi-slices-zero.asl File div-multi-slices-zero.asl, line 6, characters 10 to 17: Warning: Removing some values that would fail with op DIV from constraint set {0, 1, 2} gave {1, 2}. Continuing with this constraint set. Example with constant: $ aslref div-constants.asl File div-constants.asl, line 3, characters 22 to 29: ASL Static error: Illegal application of operator DIV for values 1 and 2. [1] Other example from typing.t: $ aslref --no-exec TNegative9-1.asl File TNegative9-1.asl, line 3, characters 4 to 59: ASL Typing error: a subtype of bits(N) was expected, provided bits(((3 * N) DIV 4)). [1] $ aslref --no-exec TPositive9.asl Other polynomial equations: $ aslref rat-poly-00.asl File rat-poly-00.asl, line 15, characters 9 to 19: ASL Typing error: Illegal application of operator == on types bits((7 DIV 2)) and bits(3). [1] $ aslref rat-poly-01.asl ASL Dynamic error: Cannot extract from bitvector of length 0 slice 0+:-2. [1] Division as POW: $ aslref zero-pow-neg.asl ASL Dynamic error: Illegal application of operator ^ for values (0.0 / 1.0) and -1. [1] $ aslref zero-pow-zero.asl herd-herdtools7-1ca343e/asllib/tests/division.t/static-div-intervals.asl000066400000000000000000000004071475314470400264160ustar00rootroot00000000000000func foo () begin let a = ARBITRARY: integer {2..5}; let b = ARBITRARY: integer {3..6}; let c: integer {0..10} = a DIV b; let d : integer {10} = 10; let e : integer {10..20} = 10; let f: integer {1..2} = e DIV d; let g: integer {1} = d DIV e; end; herd-herdtools7-1ca343e/asllib/tests/division.t/static-div-neg.asl000066400000000000000000000001151475314470400251540ustar00rootroot00000000000000func main () => integer begin let x: integer = 6 DIV -3; return 0; end; herd-herdtools7-1ca343e/asllib/tests/division.t/static-div-undiv-bis.asl000066400000000000000000000001271475314470400263060ustar00rootroot00000000000000func main () => integer begin let x = (1 DIV 2) as integer {3, 4}; return 0; end; herd-herdtools7-1ca343e/asllib/tests/division.t/static-div-undiv-ter.asl000066400000000000000000000001711475314470400263220ustar00rootroot00000000000000func main () => integer begin let a = ARBITRARY : integer {2, 3}; let b = a DIV 2 as integer {1}; return 0; end; herd-herdtools7-1ca343e/asllib/tests/division.t/static-div-undiv.asl000066400000000000000000000001141475314470400255270ustar00rootroot00000000000000func main () => integer begin let x: integer = 5 DIV 3; return 0; end; herd-herdtools7-1ca343e/asllib/tests/division.t/static-div-zero.asl000066400000000000000000000001141475314470400253610ustar00rootroot00000000000000func main () => integer begin let x: integer = 6 DIV 0; return 0; end; herd-herdtools7-1ca343e/asllib/tests/division.t/static-divrm-neg.asl000066400000000000000000000001171475314470400255150ustar00rootroot00000000000000func main () => integer begin let x: integer = 6 DIVRM -3; return 0; end; herd-herdtools7-1ca343e/asllib/tests/division.t/static-divrm-zero.asl000066400000000000000000000001161475314470400257220ustar00rootroot00000000000000func main () => integer begin let x: integer = 6 DIVRM 0; return 0; end; herd-herdtools7-1ca343e/asllib/tests/division.t/static-mod-intervals.asl000066400000000000000000000003311475314470400264070ustar00rootroot00000000000000func foo () begin let a = ARBITRARY: integer {10..20}; let b = ARBITRARY: integer {a}; let c = ARBITRARY: integer {-1000..1000}; let d: integer {0..20-1} = c MOD a; let e: integer {0..a-1} = c MOD b; end; herd-herdtools7-1ca343e/asllib/tests/division.t/static-mod-neg.asl000066400000000000000000000001151475314470400251510ustar00rootroot00000000000000func main () => integer begin let x: integer = 6 MOD -3; return 0; end; herd-herdtools7-1ca343e/asllib/tests/division.t/static-mod-zero.asl000066400000000000000000000001141475314470400253560ustar00rootroot00000000000000func main () => integer begin let x: integer = 6 MOD 0; return 0; end; herd-herdtools7-1ca343e/asllib/tests/division.t/zero-pow-neg.asl000066400000000000000000000001241475314470400246670ustar00rootroot00000000000000func main () => integer begin assert (0.0 ^ -1 == 1.0); return 0; end; herd-herdtools7-1ca343e/asllib/tests/division.t/zero-pow-zero.asl000066400000000000000000000001241475314470400250750ustar00rootroot00000000000000func main () => integer begin assert (0.0 ^ 0 == 1.0); return 0; end; herd-herdtools7-1ca343e/asllib/tests/dune000066400000000000000000000007551475314470400204370ustar00rootroot00000000000000(tests (names toposort ConstraintBinops) (modes native) (enabled_if %{lib-available:qcheck}) (libraries asllib qcheck) (modules toposort ConstraintBinops)) (tests (names static bitvector types) (modes native) (deps (:standard ../libdir/stdlib.asl)) (libraries asllib zarith) (modules (:standard \ toposort ConstraintBinops)) (flags (:standard -w -40-42)) (action (setenv ASL_LIBDIR %{project_root}/asllib/libdir/ (run %{test} -e)))) (cram (deps %{bin:aslref})) herd-herdtools7-1ca343e/asllib/tests/explicit-parameters.t/000077500000000000000000000000001475314470400237765ustar00rootroot00000000000000herd-herdtools7-1ca343e/asllib/tests/explicit-parameters.t/bad-argument-omission.asl000066400000000000000000000002441475314470400307030ustar00rootroot00000000000000func bad_elide_empty_argument_list() begin let - : bits(64) = Foo{}; // tries to construct empty record `Foo` end; func main() => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/explicit-parameters.t/bad-declaration-order.asl000066400000000000000000000003751475314470400306260ustar00rootroot00000000000000// Parameters are declared as they appear textually left-to-right in return // type then argument types func Bad{D,E,A,B,C}(x: bits(D), y: bits(E)) => bits(A * B + C) begin return Zeros{A * B + C}; end; func main() => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/explicit-parameters.t/bad-elided-parameter.asl000066400000000000000000000002671475314470400304340ustar00rootroot00000000000000func Foo{N}(x: integer) => bits(N) begin return Zeros{N}; end; func bad_elide_parameter() begin let - : bits(4) = Foo{,3}(0); end; func main() => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/explicit-parameters.t/duplicate-parameter.asl000066400000000000000000000001751475314470400304320ustar00rootroot00000000000000func BadDuplicated{N}(N: integer{3}) => bits(N) begin return Zeros{N}; end; func main() => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/explicit-parameters.t/explicit-parameters.asl000066400000000000000000000063631475314470400304710ustar00rootroot00000000000000// Helper functions func Foo{N}() => bits(N) begin return Zeros{N}; end; func Bar{N,M}(x: bits(M)) => bits(N) begin return Zeros{N}; end; func main() => integer begin return 0; end; /*----------*/ // Parameters are declared as they appear textually left-to-right in return // type then argument types func ParameterOrder{A,B,C,D,E}(x: bits(D), y: bits(E)) => bits(A * B + C) begin return Zeros{A * B + C}; end; // Parameters must be used func GoodInput{N}(x: bits(N)) => integer begin return 0; end; func GoodOutput{N}(x: integer) => bits(N) begin return Zeros{N}; end; func GoodInputOutput{N}(x: bits(N)) => bits(N) begin return x; end; // We do not need to provide () at a call site if we have explicit parameters func elide_empty_argument_list() begin let - = Foo{64}(); let - = Foo{64}; // This can combine with eliding parameters, but only as follows: let - : bits(64) = Foo{}(); end; // We can elide parameters on right-hand sides func elide_parameters() begin let - : bits(4) = Foo{}(); let - : bits(4) = Bar{,3}('111'); end; // We can parametrise accessors var _R : array [[31]] of bits(64); getter X{N}(regno: integer) => bits(N) begin assert N == 64; assert 0 <= regno && regno <= 31; return _R[[regno]][0+:N]; end; setter X{N}(regno: integer) = value : bits(N) begin assert N == 64; assert 0 <= regno && regno <= 31; _R[[regno]] = value as bits(64); end; func good() begin let - = X{64}(0); let - : bits(64) = X{}(1); X{64}(2) = Zeros{64}; end; // Standard library functions have special treatment: we need not specify their // input parameters func omit_lone_parameter_single_arity() begin // Explicit versions: let - = UInt{2}('11'); let - = SInt{2}('11'); let - = Len{2}('11'); let - = BitCount{2}('11'); let - = LowestSetBit{2}('11'); let - = HighestSetBit{2}('11'); let - = IsZero{2}('11'); let - = IsOnes{2}('11'); let - = CountLeadingZeroBits{2}('11'); let - = CountLeadingSignBits{2}('11'); // Equivalent to: let - = UInt('11'); let - = SInt('11'); let - = Len('11'); let - = BitCount('11'); let - = LowestSetBit('11'); let - = HighestSetBit('11'); let - = IsZero('11'); let - = IsOnes('11'); let - = CountLeadingZeroBits('11'); let - = CountLeadingSignBits('11'); end; func omit_lone_parameter_two_arity() begin // Explicit versions: let - = AlignDown{3}('111', 1); let - = AlignUp{3}('111', 1); let - = LSL{3}('111', 1); let - = LSL_C{3}('111', 1); let - = LSR{3}('111', 1); let - = LSR_C{3}('111', 1); let - = ASR{3}('111', 1); let - = ASR_C{3}('111', 1); let - = ROR{3}('111', 1); let - = ROR_C{3}('111', 1); // Equivalent to: let - = AlignDown('111', 1); let - = AlignUp('111', 1); let - = LSL('111', 1); let - = LSL_C('111', 1); let - = LSR('111', 1); let - = LSR_C('111', 1); let - = ASR('111', 1); let - = ASR_C('111', 1); let - = ROR('111', 1); let - = ROR_C('111', 1); end; func omit_one_of_two_parameters() begin let - : bits(64) = SignExtend{64}('1111'); let - : bits(64) = ZeroExtend{64}('1111'); let - : bits(64) = Extend{64}('1111', TRUE); end; func elide_output_parameters() begin let - : bits(64) = SignExtend{}('1111'); let - : bits(64) = ZeroExtend{}('1111'); let - : bits(64) = Extend{}('1111', TRUE); end; herd-herdtools7-1ca343e/asllib/tests/explicit-parameters.t/omit-output-stdlib-param.asl000066400000000000000000000002051475314470400313570ustar00rootroot00000000000000func omit_too_many_parameters() begin let - : bits(64) = Extend('1111', TRUE); end; func main() => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/explicit-parameters.t/run.t000066400000000000000000000032031475314470400247650ustar00rootroot00000000000000Explicit parameter tests: $ aslref explicit-parameters.asl $ aslref bad-declaration-order.asl File bad-declaration-order.asl, line 4, character 0 to line 7, character 4: ASL Typing error: incorrect parameter declaration for "Bad", expected {A, B, C, D, E} but {D, E, A, B, C} provided [1] $ aslref unused-parameter.asl File unused-parameter.asl, line 1, character 0 to line 4, character 4: ASL Typing error: incorrect parameter declaration for "BadUnused", expected {} but {N} provided [1] $ aslref undeclared-parameter.asl File undeclared-parameter.asl, line 1, character 0 to line 4, character 4: ASL Typing error: incorrect parameter declaration for "BadUndeclared", expected {N} but {} provided [1] $ aslref duplicate-parameter.asl File duplicate-parameter.asl, line 1, character 0 to line 4, character 4: ASL Typing error: cannot declare already declared element "N". [1] $ aslref bad-argument-omission.asl File bad-argument-omission.asl, line 3, characters 21 to 24: ASL Error: Undefined identifier: 'Foo' [1] $ aslref bad-elided-parameter.asl File bad-elided-parameter.asl, line 8, characters 20 to 30: ASL Static Error: Arity error while calling 'Foo': 1 parameters expected and 2 provided [1] $ aslref omit-output-stdlib-param.asl File omit-output-stdlib-param.asl, line 3, characters 21 to 41: ASL Static Error: Arity error while calling 'Extend-1': 2 parameters expected and 1 provided [1] $ aslref shadowed-parameter.asl File shadowed-parameter.asl, line 3, character 0 to line 6, character 4: ASL Typing error: cannot declare already declared element "N". [1] herd-herdtools7-1ca343e/asllib/tests/explicit-parameters.t/shadowed-parameter.asl000066400000000000000000000001471475314470400302550ustar00rootroot00000000000000constant N: integer {1,3} = 1; func MyBits{N}(x: bits(N)) => integer {N+1} begin return N + 1; end; herd-herdtools7-1ca343e/asllib/tests/explicit-parameters.t/undeclared-parameter.asl000066400000000000000000000001721475314470400305630ustar00rootroot00000000000000func BadUndeclared(N: integer{3}) => bits(N) begin return Zeros{N}; end; func main() => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/explicit-parameters.t/unused-parameter.asl000066400000000000000000000001571475314470400277630ustar00rootroot00000000000000func BadUnused{N}(x: integer) => integer begin return 0; end; func main() => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/helpers.ml000066400000000000000000000020151475314470400215440ustar00rootroot00000000000000open Asllib module Infix = struct open AST include ASTUtils.Infix let ( !! ) e = ASTUtils.add_dummy_annotation e let ( !% ) x = !!(E_Var x) end let exec_tests = let exec_one_test any_failed (name, f) = let on_fail e = let () = match e with | Error.ASLException e -> Format.eprintf "@[Test@ %s@ failed@ with@ the@ following@ error:@ %a.@." name Error.pp_error e | _ -> () in any_failed := Some e in if false then f () else try f () with e -> on_fail e in fun li -> let any_failed = ref None in List.iter (exec_one_test any_failed) li; match !any_failed with Some e -> raise e | None -> () let build_ast_from_file filename = match Builder.from_file_result `ASLv1 filename with | Error e -> ( match Builder.from_file_result `ASLv0 filename with | Ok ast -> (ast, `ASLv0) | Error _ -> Format.eprintf "%a@." Error.pp_error e; Error.fatal e) | Ok ast -> (ast, `ASLv1) herd-herdtools7-1ca343e/asllib/tests/intersecting_slices.t000066400000000000000000000035511475314470400240030ustar00rootroot00000000000000One slice cannot intersect itself: $ cat >intersecting_slices1.asl < func main () => integer > begin > var x = Zeros{4}; > var i: integer; > x[i] = '1'; > print (x); > return 0; > end; > EOF $ aslref intersecting_slices1.asl 0x1 Two intersecting slices... $ cat >intersecting_slices2.asl < func main () => integer > begin > var x = Zeros{4}; > let i = 0; let j = 0; > x[i, j] = '10'; > print (x); > return 0; > end; > EOF $ aslref intersecting_slices2.asl File intersecting_slices2.asl, line 5, characters 3 to 9: ASL Static error: overlapping slices i+:1, j+:1. [1] Two maybe intersecting slices... $ cat >intersecting_slices3.asl < func main () => integer > begin > var x = Zeros{4}; > let i = 0; > var j: integer; > x[i, j] = '10'; > print (x); > return 0; > end; > EOF $ aslref intersecting_slices3.asl ASL Dynamic error: overlapping slices i+:1, j+:1. [1] $ cat>intersecting_slices3b.asl < func set_unset{N}(bv: bits(N), x: integer, y: integer) => bits(N) > begin > var bv2 = bv; > bv2[x,y] = '10'; // Should fail dynamically for x == y > return bv2; > end; > func main () => integer > begin > print (set_unset{4}('1111', 2, 3)); > print (set_unset{4}('1111', 2, 2)); > return 0; > end; > EOF $ aslref intersecting_slices3b.asl ASL Dynamic error: overlapping slices x+:1, y+:1. 0x7 [1] Two intersecting bitfields $ cat >intersecting_slices4.asl < type myty of bits (4) { [0] f1, [0] f2 }; > func main () => integer > begin > var x = Zeros{4} as myty; > x.[f1, f2] = '10'; > print (x); > return 0; > end; > EOF $ aslref intersecting_slices4.asl File intersecting_slices4.asl, line 5, characters 2 to 12: ASL Static error: overlapping slices 0+:1, 0+:1. [1] herd-herdtools7-1ca343e/asllib/tests/lca.t000066400000000000000000000111231475314470400204740ustar00rootroot00000000000000 $ cat >lca1.asl < func main () => integer > begin > let x = if ARBITRARY: boolean then 2 else 3; > let -: integer = x; > let -: integer {2, 3} = x; > let -: real = x; > end; > EOF $ aslref lca1.asl File lca1.asl, line 6, characters 2 to 18: ASL Typing error: a subtype of real was expected, provided integer {2, 3}. [1] $ cat >lca2.asl < func main () => integer > begin > let x = if ARBITRARY: boolean then 2 as integer else 3; > let -: integer = x; > let -: integer {2, 3} = x; > end; > EOF $ aslref lca2.asl File lca2.asl, line 5, characters 2 to 28: ASL Typing error: a subtype of integer {2, 3} was expected, provided integer. [1] $ cat >lca3.asl < func main {N} (bv: bits(N)) => integer > begin > let x = if ARBITRARY: boolean then N else 3; > let -: integer = x; > let -: integer {N} = x; > end; > EOF $ aslref lca3.asl File lca3.asl, line 5, characters 2 to 25: ASL Typing error: a subtype of integer {N} was expected, provided integer {3, N}. [1] $ cat >lca4.asl < func main {N} (bv: bits(N)) => integer > begin > let x = if ARBITRARY: boolean then 3 as integer {0..N} else 3; > let -: real = x; > end; > EOF $ aslref lca4.asl File lca4.asl, line 4, characters 2 to 18: ASL Typing error: a subtype of real was expected, provided integer {0..N, 3}. [1] $ cat >lca5.asl < func main () => integer > begin > let x = if ARBITRARY: boolean then TRUE else 3; > end; > EOF $ aslref lca5.asl File lca5.asl, line 3, characters 10 to 48: ASL Typing error: cannot find a common ancestor to those two types boolean and integer {3}. [1] $ cat >lca6.asl < type T1 of integer; > type T2 of T1; > type T3 of T1; > func main () => integer > begin > let x = if ARBITRARY: boolean then 3 as T3 else 2 as T2; > let -: real = x; > end; > EOF $ aslref lca6.asl File lca6.asl, line 7, characters 2 to 18: ASL Typing error: a subtype of real was expected, provided integer. [1] $ cat >lca7.asl < type T1 of integer; > type T2 of boolean; > func main () => integer > begin > let - = if ARBITRARY: boolean then 3 as T1 else 2 as T2; > end; > EOF $ aslref lca7.asl File lca7.asl, line 5, characters 50 to 57: ASL Typing error: cannot perform Asserted Type Conversion on integer {2} by T2. [1] $ cat >lca8.asl < type T1 of bits (3) { [2] b1 }; > func main () => integer > begin > let x = if ARBITRARY: boolean then '101' as T1 else '101' as bits(3); > let -: real = x; > end; > EOF $ aslref lca8.asl File lca8.asl, line 5, characters 2 to 18: ASL Typing error: a subtype of real was expected, provided bits(3). [1] $ cat >lca9.asl < type T1 of bits (3) { [2] b1 }; > func main () => integer > begin > let x = if ARBITRARY: boolean then '101' as T1 else '101' as bits (3) { [2] b1 }; > let -: bits(3) { [2] b1 } = x; > let -: real = x; > end; > EOF $ aslref lca9.asl File lca9.asl, line 6, characters 2 to 18: ASL Typing error: a subtype of real was expected, provided T1. [1] $ cat >lca10.asl < type T1 of integer; > type T2 of integer; > func main () => integer > begin > let x = if ARBITRARY: boolean then 3 as T1 else 2 as T2; > let -: integer = x; > let -: real = x; > end; > EOF $ aslref lca10.asl File lca10.asl, line 7, characters 2 to 18: ASL Typing error: a subtype of real was expected, provided integer. [1] $ cat >lca11.asl < type T1 of integer; > func main () => integer > begin > let x = if ARBITRARY: boolean then 3 as T1 else 2 as integer; > let -: T1 = x; > return 0; > end; > EOF $ aslref lca11.asl $ cat >lca12.asl < type T1 of integer; > func main () => integer > begin > let x = if ARBITRARY: boolean then (3 as integer, 2 as T1) else (3 as T1, 2 as integer); > let -: (T1, T1) = x; > return 0; > end; > EOF $ aslref lca12.asl $ cat >lca13.asl < func main () => integer > begin > let v : (integer{3,1}, integer{2,4}) = if ARBITRARY: boolean then (3, 2) else (1, 4); > return 0; > end; > EOF $ aslref lca13.asl $ cat >lca14.asl < type T1 of integer; > func main () => integer > begin > var a: array[[4]] of integer; > var b: array[[4]] of T1; > let x = if ARBITRARY: boolean then a else b; > let -: real = x; > end; > EOF $ aslref lca14.asl File lca14.asl, line 7, characters 2 to 18: ASL Typing error: a subtype of real was expected, provided array [[4]] of T1. [1] herd-herdtools7-1ca343e/asllib/tests/lexer.t000066400000000000000000000061641475314470400210650ustar00rootroot00000000000000 $ cat >println1.asl < constant msg = "old pond\\nfrog leaps in\\nwater's sound"; > func main () => integer begin println(msg); return 0; end; > EOF $ aslref println1.asl old pond frog leaps in water's sound $ cat >println2.asl < constant msg = "old pond\\n\\tfrog\\tleaps in\\nwater's\\tsound"; > func main () => integer begin println(msg); return 0; end; > EOF $ aslref println2.asl old pond frog leaps in water's sound $ cat >println3.asl < constant msg = "Check out this haiku:\\n\\t\\"old pond\\n\\tfrog leaps in\\n\\twater's sound\\""; > func main () => integer begin println(msg); return 0; end; > EOF $ aslref println3.asl Check out this haiku: "old pond frog leaps in water's sound" $ cat >println4.asl < constant msg = "Something with \\\\ backslashes."; > func main () => integer begin println(msg); return 0; end; > EOF $ aslref println4.asl Something with \ backslashes. $ cat >println5.asl < constant msg = "Something with \\p bad characters."; > func main () => integer begin println(msg); return 0; end; > EOF $ aslref println5.asl File println5.asl, line 1, characters 32 to 33: ASL Error: Unknown symbol. [1] $ cat >println6.asl < constant msg = "Some unterminated string; > func main () => integer begin println(msg); return 0; end; > EOF $ aslref println6.asl File println6.asl, line 3, character 0: ASL Error: Unknown symbol. [1] C-Style comments $ cat >comments1.asl < func /* this is a /* test */ main () => integer > begin /* > let's try a multi-line comment /* > which finishes here */ constant msg = "/* a comment inside a string? */"; /* another comment > that finishes somewhere **/ println (msg); // but not here! */ > return 0; /* oh a new one */ > // /* when in a commented line, it doesn't count! > end; > EOF $ aslref comments1.asl /* a comment inside a string? */ $ cat >comments2.asl < /* > > > > */ > > let foo = "sigjrshgrsas > kgjrgsoirjggsr > fsoirjgrsig"; > > let a = b; > EOF $ aslref comments2.asl File comments2.asl, line 11, characters 8 to 9: ASL Error: Undefined identifier: 'b' [1] Some problems with bitvectors and bitmasks: $ cat >masks0.asl < func main() => integer > begin > var b = ''; > let expr_a = '' IN {'1'}; > let expr_b = '1' IN {''}; > let expr_c = '' IN {'0'}; > let expr_d = '0' IN {''}; > return 0; > end; > EOF $ aslref masks0.asl File masks0.asl, line 4, characters 17 to 28: ASL Typing error: cannot find a common ancestor to those two types bits(0) and bits(1). [1] Check that variables starting with `__` are reserved: $ cat >reserved0.asl < var pattern: bits(4) = '0001'; > var _okay: integer = 1; > var __reserved: integer = 2; > func main() => integer > begin > println(pattern); > println(_okay); > println(__reserved); > return 0; > end; > EOF $ aslref reserved0.asl ASL Lexical error: "__reserved" is a reserved keyword. [1] $ aslref --allow-double-underscore reserved0.asl 0x1 1 2 herd-herdtools7-1ca343e/asllib/tests/loop-limits.t/000077500000000000000000000000001475314470400222645ustar00rootroot00000000000000herd-herdtools7-1ca343e/asllib/tests/loop-limits.t/double-while-correct-correct.asl000066400000000000000000000003341475314470400304430ustar00rootroot00000000000000func main () => integer begin var i: integer = 0; var j: integer = 0; while (i < 10) looplimit 20 do i = i + 1; j = 0; while (j < 10) looplimit 20 do j = j + 1; end; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/loop-limits.t/double-while-correct-incorrect.asl000066400000000000000000000003331475314470400307710ustar00rootroot00000000000000func main () => integer begin var i: integer = 0; var j: integer = 0; while (i < 10) looplimit 20 do i = i + 1; j = 0; while (j < 10) looplimit 5 do j = j + 1; end; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/loop-limits.t/double-while-incorrect-correct.asl000066400000000000000000000003331475314470400307710ustar00rootroot00000000000000func main () => integer begin var i: integer = 0; var j: integer = 0; while (i < 10) looplimit 5 do i = i + 1; j = 0; while (j < 10) looplimit 20 do j = j + 1; end; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/loop-limits.t/double-while-incorrect-incorrect.asl000066400000000000000000000003321475314470400313170ustar00rootroot00000000000000func main () => integer begin var i: integer = 0; var j: integer = 0; while (i < 10) looplimit 5 do i = i + 1; j = 0; while (j < 10) looplimit 5 do j = j + 1; end; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/loop-limits.t/for-correct.asl000066400000000000000000000003351475314470400252130ustar00rootroot00000000000000func run_for (n: integer) begin var counter : integer = 0; for i = 1 to n looplimit 10 do counter = counter + 1; end; assert counter == n; end; func main () => integer begin run_for (5); return 0; end; herd-herdtools7-1ca343e/asllib/tests/loop-limits.t/for-exact-minus-one.asl000066400000000000000000000003361475314470400265670ustar00rootroot00000000000000func run_for (n: integer) begin var counter : integer = 0; for i = 1 to n looplimit 10 do counter = counter + 1; end; assert counter == n; end; func main () => integer begin run_for (9); return 0; end; herd-herdtools7-1ca343e/asllib/tests/loop-limits.t/for-exact.asl000066400000000000000000000003361475314470400246570ustar00rootroot00000000000000func run_for (n: integer) begin var counter : integer = 0; for i = 1 to n looplimit 10 do counter = counter + 1; end; assert counter == n; end; func main () => integer begin run_for (10); return 0; end; herd-herdtools7-1ca343e/asllib/tests/loop-limits.t/for-incorrect.asl000066400000000000000000000003361475314470400255430ustar00rootroot00000000000000func run_for (n: integer) begin var counter : integer = 0; for i = 1 to n looplimit 10 do counter = counter + 1; end; assert counter == n; end; func main () => integer begin run_for (20); return 0; end; herd-herdtools7-1ca343e/asllib/tests/loop-limits.t/for-no-limit.asl000066400000000000000000000003221475314470400252760ustar00rootroot00000000000000func run_for (n: integer) begin var counter : integer = 0; for i = 1 to n do counter = counter + 1; end; assert counter == n; end; func main () => integer begin run_for (20); return 0; end; herd-herdtools7-1ca343e/asllib/tests/loop-limits.t/recursion-correct.asl000066400000000000000000000004161475314470400264360ustar00rootroot00000000000000func recurse (n: integer) => integer recurselimit 20 begin if n >= 10 then return 1; else return 1 + recurse (n+1); end; end; func main () => integer begin println("Number of calls: ", recurse (0)); println("Number of calls: ", recurse (0)); return 0; end; herd-herdtools7-1ca343e/asllib/tests/loop-limits.t/recursion-exact-minus-one.asl000066400000000000000000000004161475314470400300110ustar00rootroot00000000000000func recurse (n: integer) => integer recurselimit 10 begin if n >= 10 then return 1; else return 1 + recurse (n+1); end; end; func main () => integer begin println("Number of calls: ", recurse (0)); println("Number of calls: ", recurse (0)); return 0; end; herd-herdtools7-1ca343e/asllib/tests/loop-limits.t/recursion-exact.asl000066400000000000000000000004161475314470400261010ustar00rootroot00000000000000func recurse (n: integer) => integer recurselimit 11 begin if n >= 10 then return 1; else return 1 + recurse (n+1); end; end; func main () => integer begin println("Number of calls: ", recurse (0)); println("Number of calls: ", recurse (0)); return 0; end; herd-herdtools7-1ca343e/asllib/tests/loop-limits.t/recursion-incorrect.asl000066400000000000000000000004341475314470400267650ustar00rootroot00000000000000func recurse (n: integer) => integer recurselimit 5 begin println (n); if n >= 10 then return 1; else return 1 + recurse (n+1); end; end; func main () => integer begin println("Number of calls: ", recurse (0)); println("Number of calls: ", recurse (0)); return 0; end; herd-herdtools7-1ca343e/asllib/tests/loop-limits.t/recursion-no-limit.asl000066400000000000000000000003761475314470400265320ustar00rootroot00000000000000func recurse (n: integer) => integer begin if n >= 10 then return 1; else return 1 + recurse (n+1); end; end; func main () => integer begin println("Number of calls: ", recurse (0)); println("Number of calls: ", recurse (0)); return 0; end; herd-herdtools7-1ca343e/asllib/tests/loop-limits.t/repeat-correct.asl000066400000000000000000000001761475314470400257100ustar00rootroot00000000000000func main () => integer begin var i: integer = 0; repeat i = i + 1; until (i >= 10) looplimit 20; return 0; end; herd-herdtools7-1ca343e/asllib/tests/loop-limits.t/repeat-exact-minus-one.asl000066400000000000000000000002001475314470400272470ustar00rootroot00000000000000func main () => integer begin var i: integer = 0; repeat i = i + 1; until (i >= 10) looplimit 9; return 0; end; herd-herdtools7-1ca343e/asllib/tests/loop-limits.t/repeat-exact.asl000066400000000000000000000001771475314470400253540ustar00rootroot00000000000000func main () => integer begin var i: integer = 0; repeat i = i + 1; until (i >= 10) looplimit 10; return 0; end; herd-herdtools7-1ca343e/asllib/tests/loop-limits.t/repeat-incorrect.asl000066400000000000000000000002161475314470400262320ustar00rootroot00000000000000func main () => integer begin var i: integer = 0; repeat i = i + 1; println(i); until (i >= 10) looplimit 5; return 0; end; herd-herdtools7-1ca343e/asllib/tests/loop-limits.t/repeat-no-limit.asl000066400000000000000000000001621475314470400257720ustar00rootroot00000000000000func main () => integer begin var i: integer = 0; repeat i = i + 1; until (i >= 10); return 0; end; herd-herdtools7-1ca343e/asllib/tests/loop-limits.t/run.t000066400000000000000000000054651475314470400232670ustar00rootroot00000000000000Loop limits =========== While loops: $ aslref while-correct.asl $ aslref while-incorrect.asl 1 2 3 4 5 File while-incorrect.asl, line 4, character 2 to line 7, character 6: ASL Dynamic error: loop limit reached. [1] $ aslref while-exact.asl $ aslref while-exact-minus-one.asl File while-exact-minus-one.asl, line 4, character 2 to line 6, character 6: ASL Dynamic error: loop limit reached. [1] $ aslref while-no-limit.asl File while-no-limit.asl, line 4, character 2 to line 6, character 6: ASL Warning: Loop does not have a limit. Repeat loops: $ aslref repeat-correct.asl $ aslref repeat-incorrect.asl 1 2 3 4 5 File repeat-incorrect.asl, line 4, character 2 to line 7, character 30: ASL Dynamic error: loop limit reached. [1] $ aslref repeat-exact.asl $ aslref repeat-exact-minus-one.asl File repeat-exact-minus-one.asl, line 4, character 2 to line 6, character 30: ASL Dynamic error: loop limit reached. [1] $ aslref repeat-no-limit.asl File repeat-no-limit.asl, line 4, character 2 to line 6, character 18: ASL Warning: Loop does not have a limit. Double loops $ aslref double-while-correct-correct.asl $ aslref double-while-correct-incorrect.asl File double-while-correct-incorrect.asl, line 9, character 4 to line 11, character 8: ASL Dynamic error: loop limit reached. [1] $ aslref double-while-incorrect-correct.asl File double-while-incorrect-correct.asl, line 6, character 2 to line 12, character 6: ASL Dynamic error: loop limit reached. [1] $ aslref double-while-incorrect-incorrect.asl File double-while-incorrect-incorrect.asl, line 9, character 4 to line 11, character 8: ASL Dynamic error: loop limit reached. [1] For loops $ aslref for-correct.asl $ aslref for-incorrect.asl File for-incorrect.asl, line 5, characters 4 to 26: ASL Dynamic error: loop limit reached. [1] $ aslref for-exact.asl File for-exact.asl, line 5, characters 4 to 26: ASL Dynamic error: loop limit reached. [1] $ aslref for-exact-minus-one.asl $ aslref for-no-limit.asl Recursion limits: ================= $ aslref recursion-no-limit.asl File recursion-no-limit.asl, line 1, character 0 to line 5, character 4: ASL Warning: the recursive function recurse has no recursive limit annotation. Number of calls: 11 Number of calls: 11 $ aslref recursion-correct.asl Number of calls: 11 Number of calls: 11 $ aslref recursion-incorrect.asl 0 1 2 3 4 File recursion-incorrect.asl, line 6, characters 18 to 31: ASL Dynamic error: recursion limit reached. [1] $ aslref recursion-exact.asl Number of calls: 11 Number of calls: 11 $ aslref recursion-exact-minus-one.asl File recursion-exact-minus-one.asl, line 5, characters 18 to 31: ASL Dynamic error: recursion limit reached. [1] herd-herdtools7-1ca343e/asllib/tests/loop-limits.t/while-correct.asl000066400000000000000000000001751475314470400255370ustar00rootroot00000000000000func main () => integer begin var i: integer = 0; while (i < 10) looplimit 20 do i = i + 1; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/loop-limits.t/while-exact-minus-one.asl000066400000000000000000000001771475314470400271140ustar00rootroot00000000000000func main () => integer begin var i: integer = 0; while (i < 10) looplimit 9 do i = i + 1; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/loop-limits.t/while-exact.asl000066400000000000000000000001761475314470400252030ustar00rootroot00000000000000func main () => integer begin var i: integer = 0; while (i < 10) looplimit 10 do i = i + 1; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/loop-limits.t/while-incorrect.asl000066400000000000000000000002151475314470400260610ustar00rootroot00000000000000func main () => integer begin var i: integer = 0; while (i < 10) looplimit 5 do i = i + 1; println(i); end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/loop-limits.t/while-no-limit.asl000066400000000000000000000001611475314470400256210ustar00rootroot00000000000000func main () => integer begin var i: integer = 0; while (i < 10) do i = i + 1; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/performance.t/000077500000000000000000000000001475314470400223155ustar00rootroot00000000000000herd-herdtools7-1ca343e/asllib/tests/performance.t/constraint-mul-00.asl000066400000000000000000000006241475314470400262140ustar00rootroot00000000000000constant A = 1 << 2; constant B = 1 << 2; func myfunction(a : integer{0..A}, b : integer{0..B}) begin let n = a DIVRM b; // 10 DIVRM 3 == 3 var b1 = n * b; b1 = 4; b1 = A * B; b1 = (A * B) - 1; // Test if discrete or interval representation end; func main() => integer begin myfunction(0, 1); myfunction(A, 1); myfunction(A DIVRM 2, B DIVRM 4); return 0; end; herd-herdtools7-1ca343e/asllib/tests/performance.t/constraint-mul-01.asl000066400000000000000000000006241475314470400262150ustar00rootroot00000000000000constant A = 1 << 4; constant B = 1 << 4; func myfunction(a : integer{0..A}, b : integer{0..B}) begin let n = a DIVRM b; // 10 DIVRM 3 == 3 var b1 = n * b; b1 = 4; b1 = A * B; b1 = (A * B) - 1; // Test if discrete or interval representation end; func main() => integer begin myfunction(0, 1); myfunction(A, 1); myfunction(A DIVRM 2, B DIVRM 4); return 0; end; herd-herdtools7-1ca343e/asllib/tests/performance.t/constraint-mul-02.asl000066400000000000000000000006241475314470400262160ustar00rootroot00000000000000constant A = 1 << 5; constant B = 1 << 5; func myfunction(a : integer{0..A}, b : integer{0..B}) begin let n = a DIVRM b; // 10 DIVRM 3 == 3 var b1 = n * b; b1 = 4; b1 = A * B; b1 = (A * B) - 1; // Test if discrete or interval representation end; func main() => integer begin myfunction(0, 1); myfunction(A, 1); myfunction(A DIVRM 2, B DIVRM 4); return 0; end; herd-herdtools7-1ca343e/asllib/tests/performance.t/constraint-mul-03.asl000066400000000000000000000006241475314470400262170ustar00rootroot00000000000000constant A = 1 << 6; constant B = 1 << 6; func myfunction(a : integer{0..A}, b : integer{0..B}) begin let n = a DIVRM b; // 10 DIVRM 3 == 3 var b1 = n * b; b1 = 4; b1 = A * B; b1 = (A * B) - 1; // Test if discrete or interval representation end; func main() => integer begin myfunction(0, 1); myfunction(A, 1); myfunction(A DIVRM 2, B DIVRM 4); return 0; end; herd-herdtools7-1ca343e/asllib/tests/performance.t/constraint-mul-04.asl000066400000000000000000000006241475314470400262200ustar00rootroot00000000000000constant A = 1 << 7; constant B = 1 << 7; func myfunction(a : integer{0..A}, b : integer{0..B}) begin let n = a DIVRM b; // 10 DIVRM 3 == 3 var b1 = n * b; b1 = 4; b1 = A * B; b1 = (A * B) - 1; // Test if discrete or interval representation end; func main() => integer begin myfunction(0, 1); myfunction(A, 1); myfunction(A DIVRM 2, B DIVRM 4); return 0; end; herd-herdtools7-1ca343e/asllib/tests/performance.t/constraint-mul-05.asl000066400000000000000000000006241475314470400262210ustar00rootroot00000000000000constant A = 1 << 8; constant B = 1 << 8; func myfunction(a : integer{0..A}, b : integer{0..B}) begin let n = a DIVRM b; // 10 DIVRM 3 == 3 var b1 = n * b; b1 = 4; b1 = A * B; b1 = (A * B) - 1; // Test if discrete or interval representation end; func main() => integer begin myfunction(0, 1); myfunction(A, 1); myfunction(A DIVRM 2, B DIVRM 4); return 0; end; herd-herdtools7-1ca343e/asllib/tests/performance.t/constraint-mul-06.asl000066400000000000000000000006241475314470400262220ustar00rootroot00000000000000constant A = 1 << 9; constant B = 1 << 9; func myfunction(a : integer{0..A}, b : integer{0..B}) begin let n = a DIVRM b; // 10 DIVRM 3 == 3 var b1 = n * b; b1 = 4; b1 = A * B; b1 = (A * B) - 1; // Test if discrete or interval representation end; func main() => integer begin myfunction(0, 1); myfunction(A, 1); myfunction(A DIVRM 2, B DIVRM 4); return 0; end; herd-herdtools7-1ca343e/asllib/tests/performance.t/constraint-mul-07.asl000066400000000000000000000006261475314470400262250ustar00rootroot00000000000000constant A = 1 << 10; constant B = 1 << 10; func myfunction(a : integer{0..A}, b : integer{0..B}) begin let n = a DIVRM b; // 10 DIVRM 3 == 3 var b1 = n * b; b1 = 4; b1 = A * B; b1 = (A * B) - 1; // Test if discrete or interval representation end; func main() => integer begin myfunction(0, 1); myfunction(A, 1); myfunction(A DIVRM 2, B DIVRM 4); return 0; end; herd-herdtools7-1ca343e/asllib/tests/performance.t/constraint-mul-08.asl000066400000000000000000000006261475314470400262260ustar00rootroot00000000000000constant A = 1 << 11; constant B = 1 << 11; func myfunction(a : integer{0..A}, b : integer{0..B}) begin let n = a DIVRM b; // 10 DIVRM 3 == 3 var b1 = n * b; b1 = 4; b1 = A * B; b1 = (A * B) - 1; // Test if discrete or interval representation end; func main() => integer begin myfunction(0, 1); myfunction(A, 1); myfunction(A DIVRM 2, B DIVRM 4); return 0; end; herd-herdtools7-1ca343e/asllib/tests/performance.t/constraint-mul-09.asl000066400000000000000000000006261475314470400262270ustar00rootroot00000000000000constant A = 1 << 12; constant B = 1 << 12; func myfunction(a : integer{0..A}, b : integer{0..B}) begin let n = a DIVRM b; // 10 DIVRM 3 == 3 var b1 = n * b; b1 = 4; b1 = A * B; b1 = (A * B) - 1; // Test if discrete or interval representation end; func main() => integer begin myfunction(0, 1); myfunction(A, 1); myfunction(A DIVRM 2, B DIVRM 4); return 0; end; herd-herdtools7-1ca343e/asllib/tests/performance.t/constraint-mul-10.asl000066400000000000000000000006261475314470400262170ustar00rootroot00000000000000constant A = 1 << 13; constant B = 1 << 13; func myfunction(a : integer{0..A}, b : integer{0..B}) begin let n = a DIVRM b; // 10 DIVRM 3 == 3 var b1 = n * b; b1 = 4; b1 = A * B; b1 = (A * B) - 1; // Test if discrete or interval representation end; func main() => integer begin myfunction(0, 1); myfunction(A, 1); myfunction(A DIVRM 2, B DIVRM 4); return 0; end; herd-herdtools7-1ca343e/asllib/tests/performance.t/run.t000066400000000000000000000145111475314470400233100ustar00rootroot00000000000000(* Constraint multiplication *) $ aslref constraint-mul-00.asl File constraint-mul-00.asl, line 6, characters 12 to 21: Warning: Removing some values that would fail with op DIVRM from constraint set {0..4} gave {1..4}. Continuing with this constraint set. File constraint-mul-00.asl, line 10, characters 4 to 6: ASL Typing error: a subtype of integer {0..4, 6, 8..9, 12, 16} was expected, provided integer {15}. [1] $ aslref constraint-mul-01.asl File constraint-mul-01.asl, line 6, characters 12 to 21: Warning: Removing some values that would fail with op DIVRM from constraint set {0..16} gave {1..16}. Continuing with this constraint set. File constraint-mul-01.asl, line 10, characters 4 to 6: ASL Typing error: a subtype of integer {0..16, 18, 20..22, 24..28, 30, 32..33, 35..36, 39..40, 42, 44..45, ...} was expected, provided integer {255}. [1] $ aslref constraint-mul-02.asl File constraint-mul-02.asl, line 6, characters 12 to 21: Warning: Removing some values that would fail with op DIVRM from constraint set {0..32} gave {1..32}. Continuing with this constraint set. File constraint-mul-02.asl, line 10, characters 4 to 6: ASL Typing error: a subtype of integer {0..36, 38..40, 42, 44..46, 48..52, 54..58, 60, 62..66, 68..70, 72, ...} was expected, provided integer {1023}. [1] $ aslref constraint-mul-03.asl File constraint-mul-03.asl, line 6, characters 12 to 21: Warning: Removing some values that would fail with op DIVRM from constraint set {0..64} gave {1..64}. Continuing with this constraint set. File constraint-mul-03.asl, line 10, characters 4 to 6: ASL Typing error: a subtype of integer {0..66, 68..70, 72, 74..78, 80..82, 84..88, 90..96, 98..100, 102, 104..106, ...} was expected, provided integer {4095}. [1] $ aslref constraint-mul-04.asl File constraint-mul-04.asl, line 6, characters 12 to 21: Warning: Removing some values that would fail with op DIVRM from constraint set {0..128} gave {1..128}. Continuing with this constraint set. File constraint-mul-04.asl, line 10, characters 4 to 6: ASL Typing error: a subtype of integer {0..130, 132..136, 138, 140..148, 150, 152..156, 158..162, 164..166, 168..172, 174..178, ...} was expected, provided integer {16383}. [1] $ aslref constraint-mul-05.asl File constraint-mul-05.asl, line 6, characters 12 to 21: Warning: Removing some values that would fail with op DIVRM from constraint set {0..256} gave {1..256}. Continuing with this constraint set. File constraint-mul-05.asl, line 10, characters 4 to 6: ASL Typing error: a subtype of integer {0..256, 258..262, 264..268, 270, 272..276, 278..280, 282, 284..292, 294..306, 308..310, ...} was expected, provided integer {65535}. [1] $ aslref constraint-mul-06.asl File constraint-mul-06.asl, line 6, characters 12 to 21: Warning: Removing some values that would fail with op DIVRM from constraint set {0..512} gave {1..512}. Continuing with this constraint set. File constraint-mul-06.asl, line 6, characters 12 to 21: Exploding sets for the binary operation DIVRM could result in a constraint set bigger than 2^17 with constraints 0..512 and 1..512. Continuing with the non-expanded constraints. File constraint-mul-06.asl, line 7, characters 13 to 18: Exploding sets for the binary operation * could result in a constraint set bigger than 2^17 with constraints 0..512 and 0..512. Continuing with the non-expanded constraints. $ aslref constraint-mul-07.asl File constraint-mul-07.asl, line 6, characters 12 to 21: Warning: Removing some values that would fail with op DIVRM from constraint set {0..1024} gave {1..1024}. Continuing with this constraint set. File constraint-mul-07.asl, line 6, characters 12 to 21: Exploding sets for the binary operation DIVRM could result in a constraint set bigger than 2^17 with constraints 0..1024 and 1..1024. Continuing with the non-expanded constraints. File constraint-mul-07.asl, line 7, characters 13 to 18: Exploding sets for the binary operation * could result in a constraint set bigger than 2^17 with constraints 0..1024 and 0..1024. Continuing with the non-expanded constraints. $ aslref constraint-mul-08.asl File constraint-mul-08.asl, line 6, characters 12 to 21: Warning: Removing some values that would fail with op DIVRM from constraint set {0..2048} gave {1..2048}. Continuing with this constraint set. File constraint-mul-08.asl, line 6, characters 12 to 21: Exploding sets for the binary operation DIVRM could result in a constraint set bigger than 2^17 with constraints 0..2048 and 1..2048. Continuing with the non-expanded constraints. File constraint-mul-08.asl, line 7, characters 13 to 18: Exploding sets for the binary operation * could result in a constraint set bigger than 2^17 with constraints 0..2048 and 0..2048. Continuing with the non-expanded constraints. $ aslref constraint-mul-09.asl File constraint-mul-09.asl, line 6, characters 12 to 21: Warning: Removing some values that would fail with op DIVRM from constraint set {0..4096} gave {1..4096}. Continuing with this constraint set. File constraint-mul-09.asl, line 6, characters 12 to 21: Exploding sets for the binary operation DIVRM could result in a constraint set bigger than 2^17 with constraints 0..4096 and 1..4096. Continuing with the non-expanded constraints. File constraint-mul-09.asl, line 7, characters 13 to 18: Exploding sets for the binary operation * could result in a constraint set bigger than 2^17 with constraints 0..4096 and 0..4096. Continuing with the non-expanded constraints. $ aslref constraint-mul-10.asl File constraint-mul-10.asl, line 6, characters 12 to 21: Warning: Removing some values that would fail with op DIVRM from constraint set {0..8192} gave {1..8192}. Continuing with this constraint set. File constraint-mul-10.asl, line 6, characters 12 to 21: Exploding sets for the binary operation DIVRM could result in a constraint set bigger than 2^17 with constraints 0..8192 and 1..8192. Continuing with the non-expanded constraints. File constraint-mul-10.asl, line 7, characters 13 to 18: Exploding sets for the binary operation * could result in a constraint set bigger than 2^17 with constraints 0..8192 and 0..8192. Continuing with the non-expanded constraints. herd-herdtools7-1ca343e/asllib/tests/pragma.t/000077500000000000000000000000001475314470400212635ustar00rootroot00000000000000herd-herdtools7-1ca343e/asllib/tests/pragma.t/pragma.asl000066400000000000000000000003461475314470400232360ustar00rootroot00000000000000func test() => integer begin pragma p1 "with arg"; pragma p2; pragma p3 "multi arg", TRUE; return 1; end; pragma p1; pragma p2 TRUE; pragma p3 TRUE, 2 + 2, test(); func main() => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/pragma.t/pragma_invalid.asl000066400000000000000000000001051475314470400247350ustar00rootroot00000000000000pragma p1 2 + TRUE; func main() => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/pragma.t/pragma_invalid_stmt.asl000066400000000000000000000001141475314470400260040ustar00rootroot00000000000000func main() => integer begin pragma fail "test" + 1; return 0; end; herd-herdtools7-1ca343e/asllib/tests/pragma.t/run.t000066400000000000000000000022111475314470400222500ustar00rootroot00000000000000Simple pragma examples $ aslref pragma.asl File pragma.asl, line 3, characters 4 to 25: ASL Warning: pragma p1 will be ignored. File pragma.asl, line 4, characters 4 to 14: ASL Warning: pragma p2 will be ignored. File pragma.asl, line 5, characters 4 to 32: ASL Warning: pragma p3 will be ignored. File pragma.asl, line 11, characters 0 to 30: ASL Warning: pragma p3 will be ignored. File pragma.asl, line 10, characters 0 to 15: ASL Warning: pragma p2 will be ignored. File pragma.asl, line 9, characters 0 to 10: ASL Warning: pragma p1 will be ignored. $ aslref pragma_invalid.asl File pragma_invalid.asl, line 1, characters 0 to 19: ASL Warning: pragma p1 will be ignored. File pragma_invalid.asl, line 1, characters 10 to 18: ASL Typing error: Illegal application of operator + on types integer {2} and boolean. [1] $ aslref pragma_invalid_stmt.asl File pragma_invalid_stmt.asl, line 3, characters 4 to 27: ASL Warning: pragma fail will be ignored. File pragma_invalid_stmt.asl, line 3, characters 21 to 26: ASL Typing error: Illegal application of operator + on types string and integer {1}. [1] herd-herdtools7-1ca343e/asllib/tests/print.t000066400000000000000000000027301475314470400210750ustar00rootroot00000000000000 $ cat >printer1.asl < func main () => integer begin > print ("Wow", 2, 3.14, "some other string"); > print ("no type-checking"); > print (32); > return 0; > end; > EOF $ aslref printer1.asl Wow2157/50some other stringno type-checking32 $ cat >printer2.asl < func main () => integer begin > print ("Wow", 2 + 3.14, "some other string"); > print ("no type-checking"); > print (32); > return 0; > end; > EOF $ aslref printer2.asl File printer2.asl, line 2, characters 16 to 24: ASL Typing error: Illegal application of operator + on types integer {2} and real. [1] $ cat >printer3.asl < type MyEnum of enumeration { HELLOWORLD_ENUM }; > type MyInteger of integer {0..100}; > func main () => integer begin > println ("helloworld"); > println (1234); > println ('011'); > println (TRUE); > println (0.5); > println (1.0); > println (-1.0); > println (0.0); > println (HELLOWORLD_ENUM); > var abc: MyInteger = 20; > println (abc); > return 0; > end; > EOF $ aslref printer3.asl helloworld 1234 0x3 TRUE 1/2 1 -1 0 HELLOWORLD_ENUM 20 $ cat >print4.asl < func main () => integer begin > println ((1, 2)); > return 0; > end; > EOF $ aslref print4.asl File print4.asl, line 2, characters 11 to 17: ASL Typing error: print and println only accept singular types, found (integer {1}, integer {2}). [1] herd-herdtools7-1ca343e/asllib/tests/recursive.t/000077500000000000000000000000001475314470400220235ustar00rootroot00000000000000herd-herdtools7-1ca343e/asllib/tests/recursive.t/double-recursive-constant.asl000066400000000000000000000001311475314470400276250ustar00rootroot00000000000000constant x = y + 3; constant y = x + 2; func main () => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/recursive.t/double-recursive-types.asl000066400000000000000000000001511475314470400271420ustar00rootroot00000000000000type tree of (node, node); type node of (integer, tree); func main () => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/recursive.t/double-recursive-without-limit.asl000066400000000000000000000005141475314470400306200ustar00rootroot00000000000000func f (x: integer) => integer begin if x >= 0 then return 1 + g (x - 1); else return 0; end; end; func g (x: integer) => integer begin return f (x); end; func main () => integer begin let f0 = f(0); assert f0 == 1; for i = -1 to 20 do let fi = f(i); assert fi == i + 1; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/recursive.t/double-recursive.asl000066400000000000000000000005321475314470400260030ustar00rootroot00000000000000func f (x: integer) => integer recurselimit 1000 begin if x >= 0 then return 1 + g (x - 1); else return 0; end; end; func g (x: integer) => integer begin return f (x); end; func main () => integer begin let f0 = f(0); assert f0 == 1; for i = -1 to 20 do let fi = f(i); assert fi == i + 1; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/recursive.t/enum-fn-recursive.asl000066400000000000000000000003331475314470400260750ustar00rootroot00000000000000type MyEnum of enumeration { A, B, C }; func foo (x: integer) => integer begin var e = B; var f = D; return x; end; type MyEnum2 of enumeration { D, E, F }; func main () => integer begin return foo(0); end; herd-herdtools7-1ca343e/asllib/tests/recursive.t/fn-val-recursive.asl000066400000000000000000000002151475314470400257120ustar00rootroot00000000000000var x = f (4, 5); func f (y: integer, z: integer) => integer begin return x + y + z; end; func main () => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/recursive.t/recursive-constant.asl000066400000000000000000000001041475314470400263550ustar00rootroot00000000000000constant x = x + 3; func main () => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/recursive.t/recursive-type.asl000066400000000000000000000001241475314470400255070ustar00rootroot00000000000000type tree of (tree, integer, tree); func main () => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/recursive.t/run.t000066400000000000000000000027271475314470400230240ustar00rootroot00000000000000 $ aslref simple-recursive.asl $ aslref simple-recursive-without-limit.asl File simple-recursive-without-limit.asl, line 1, character 0 to line 8, character 4: ASL Warning: the recursive function f has no recursive limit annotation. $ aslref double-recursive.asl $ aslref double-recursive-without-limit.asl File double-recursive-without-limit.asl, line 10, character 0 to line 13, character 4: ASL Warning: the mutually-recursive functions g, f have no recursive limit annotation. $ aslref recursive-constant.asl File recursive-constant.asl, line 1, characters 13 to 14: ASL Error: Undefined identifier: 'x' [1] $ aslref double-recursive-constant.asl File double-recursive-constant.asl, line 2, characters 0 to 19: ASL Typing error: multiple recursive declarations: "y", "x". [1] $ aslref recursive-type.asl File recursive-type.asl, line 1, characters 0 to 35: ASL Error: Undefined identifier: 'tree' [1] $ aslref double-recursive-types.asl File double-recursive-types.asl, line 2, characters 0 to 29: ASL Typing error: multiple recursive declarations: "node", "tree". [1] $ aslref fn-val-recursive.asl File fn-val-recursive.asl, line 1, characters 0 to 17: ASL Typing error: multiple recursive declarations: "f", "x". [1] $ aslref type-val-recursive.asl File type-val-recursive.asl, line 3, characters 0 to 24: ASL Typing error: multiple recursive declarations: "MyT", "x". [1] $ aslref enum-fn-recursive.asl herd-herdtools7-1ca343e/asllib/tests/recursive.t/simple-recursive-without-limit.asl000066400000000000000000000004201475314470400306330ustar00rootroot00000000000000func f (x: integer) => integer begin if x >= 0 then return 1 + f (x - 1); else return 0; end; end; func main () => integer begin let f0 = f(0); assert f0 == 1; for i = -1 to 20 do let fi = f(i); assert fi == i + 1; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/recursive.t/simple-recursive.asl000066400000000000000000000004421475314470400260220ustar00rootroot00000000000000func f (x: integer) => integer recurselimit 1000 begin if x >= 0 then return 1 + f (x - 1); else return 0; end; end; func main () => integer begin let f0 = f(0); assert f0 == 1; for i = -1 to 20 do let fi = f(i); assert fi == i + 1; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/recursive.t/type-val-recursive.asl000066400000000000000000000001401475314470400262650ustar00rootroot00000000000000constant x: MyT = 4; type MyT of integer {x}; func main () => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/000077500000000000000000000000001475314470400223575ustar00rootroot00000000000000herd-herdtools7-1ca343e/asllib/tests/regressions.t/anonymous-types-example-success.asl000066400000000000000000000016471475314470400313610ustar00rootroot00000000000000type T1 of integer; // the named type `T1` whose structure is integer type T2 of integer; // the named type `T2` whose structure is integer type pairT of (integer, T1); // the named type `pairT` whose structure is (integer, integer) func tsub01() begin var dataT1: T1; var pair: pairT = (1, dataT1); // legal since right hand side has anonymous, non-primitive type (integer, T1)w let dataAsInt: integer = dataT1; pair = (1, dataAsInt); // legal since right hand side has anonymous, primitive type (integer, integer) let dataT2: T2 = 10; // pair = (1, dataT2); // illegal since right hand side has anonymous, non-primitive type (integer, T2) // which does not subtype-satisfy named type pairT end; func main () => integer begin pass; tsub01(); return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set +syntax:aslv1_colon_colon' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/anonymous-types-example.asl000066400000000000000000000014251475314470400277050ustar00rootroot00000000000000type T1 of integer; // the named type `T1` whose structure is integer type T2 of integer; // the named type `T2` whose structure is integer type pairT of (integer, T1); // the named type `pairT` whose structure is (integer, integer) func tsub01() begin var dataT1: T1; var pair: pairT = (1, dataT1); // legal since right hand side has anonymous, non-primitive type (integer, T1)w let dataAsInt: integer = dataT1; pair = (1, dataAsInt); // legal since right hand side has anonymous, primitive type (integer, integer) let dataT2: T2 = 10; pair = (1, dataT2); // illegal since right hand side has anonymous, non-primitive type (integer, T2) // which does not subtype-satisfy named type pairT end; func main () => integer begin pass; tsub01(); return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/arg-as-param-call.asl000066400000000000000000000001761475314470400262450ustar00rootroot00000000000000func test{N: integer}(a: bits(N)) begin pass; end; func main() => integer begin test{10}('1111'); return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/array-index-error.asl000066400000000000000000000002221475314470400264260ustar00rootroot00000000000000func main () => integer begin var arr: array[[5]] of integer; // Legal arr[[2]] = 0; // Illegal let x = arr[[14]]; return 1; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/array-lca.asl000066400000000000000000000003061475314470400247320ustar00rootroot00000000000000type A of integer; func main() => integer begin var b = ARBITRARY: boolean; var a : array[[5]] of integer; var c : array[[5]] of A; var x = if (b) then a else c; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/array-with-enums.asl000066400000000000000000000005261475314470400262770ustar00rootroot00000000000000type MyEnum of enumeration { MyEnumA, MyEnumB, MyEnumC, }; type MyArray of array [[ MyEnum ]] of integer; var myArray : MyArray; func main () => integer begin myArray[[MyEnumA]] = 3; assert myArray[[MyEnumA]] == 3; myArray[[MyEnumB]] = 4; assert myArray[[MyEnumA]] == 3; assert myArray[[MyEnumB]] == 4; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/array.asl000066400000000000000000000004431475314470400241770ustar00rootroot00000000000000type a of array [[4]] of integer; var global_a: a; func get_2(local_a: a) => integer begin return local_a[[2]]; end; func main () => integer begin global_a [[1]] = 3; assert global_a[[1]] == 3; var local_a: a; local_a[[2]] = 5; assert get_2(local_a) == 5; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/asl0-patterns.asl000066400000000000000000000005101475314470400255510ustar00rootroot00000000000000integer main() bits(64) x = Zeros(64); y = x[1+:10]; // this would be invalid ASL0, but we use it in the XML if x IN {'10x1101010'} then z = 1; // valid if x == '10x1101010' then z = 1; // valid if x != '10x1101010' then z = 1; // valid if x[0+:4] IN '10x1' then // invalid z = 1; return 1; herd-herdtools7-1ca343e/asllib/tests/regressions.t/assign-to-global-immutable.asl000066400000000000000000000001621475314470400301760ustar00rootroot00000000000000let my_immutable_global: integer = 3; func main () => integer begin my_immutable_global = 4; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/assign-v0.asl000066400000000000000000000001121475314470400246610ustar00rootroot00000000000000integer main() x = 1; (y,z) = (2,3); assert x+y+z == 6; return 0; herd-herdtools7-1ca343e/asllib/tests/regressions.t/assign1.asl000066400000000000000000000003431475314470400244250ustar00rootroot00000000000000func main() => integer begin let x = 3; assert x == 3; return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set +syntax:aslv1_colon_colon' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/atc-in-types.asl000066400000000000000000000000521475314470400253720ustar00rootroot00000000000000let bv : bits(1 as integer{2}) = Ones(1); herd-herdtools7-1ca343e/asllib/tests/regressions.t/bad-equality.asl000066400000000000000000000001131475314470400254340ustar00rootroot00000000000000func main () => integer begin println((1, 2) == (1,2)); return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/bad-inclusion-in-symbolic-type.asl000066400000000000000000000000721475314470400310100ustar00rootroot00000000000000config A : integer{1..2} = 1; var ah: integer{2..A} = 1; herd-herdtools7-1ca343e/asllib/tests/regressions.t/bad-pattern.asl000066400000000000000000000001411475314470400252550ustar00rootroot00000000000000func main () => integer begin case 3 of when '101' => println ("Cannot happen"); end; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/bad-shift.asl000066400000000000000000000001451475314470400247210ustar00rootroot00000000000000func main() => integer begin let a = '11011' ; let b = LSL(a,10); println(b); return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/bad-slices.asl000066400000000000000000000001321475314470400250620ustar00rootroot00000000000000func main () => integer begin let x = '11110000'; let y = x[-20:4]; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/bad-underconstrained-call-02.asl000066400000000000000000000003051475314470400303010ustar00rootroot00000000000000func foo {N} (x: bits(N), i: integer {N}) begin assert Len(x) == i; end; func bar {M} (x: bits(M)) begin foo{M}(x, 3); end; func main () => integer begin bar{6}('101010'); return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/bad-underconstrained-call-03.asl000066400000000000000000000003121475314470400303000ustar00rootroot00000000000000func foo {N} (x: bits(N), i: integer {N}) begin assert Len(x) == i; end; func bar {M} (x: bits(M)) begin foo{M}(x, M + 1); end; func main () => integer begin bar{6}('101010'); return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/bad-underconstrained-call.asl000066400000000000000000000004451475314470400300670ustar00rootroot00000000000000func GetBitAt{N}(x: bits(N), i: integer {0..N-1}) => bits(1) begin return x[i]; end; func GetMiddleBit{M}(x: bits(M)) => bits(1) begin // return GetBitAt(x, M DIVRM 2); return GetBitAt{M}(x, M); end; func main() => integer begin let - = GetMiddleBit{8}('11110000'); return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/bad-underconstrained-ctc.asl000066400000000000000000000002541475314470400277230ustar00rootroot00000000000000func GetLastBit {N} (x: bits(N)) => bits(1) begin return x[(N as integer {N - 1})]; end; func main () => integer begin let - = GetLastBit{4}('1111'); return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/bad-underconstrained-return-02.asl000066400000000000000000000002361475314470400307100ustar00rootroot00000000000000func BadBitCount {N} (x: bits(N)) => integer {0..N} begin return 5; end; func main() => integer begin assert BadBitCount ('101') == 2; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/bad-underconstrained-return.asl000066400000000000000000000002411475314470400304650ustar00rootroot00000000000000func BadBitCount {N} (x: bits(N)) => integer {0..N} begin return N + 1; end; func main() => integer begin assert BadBitCount ('101') == 2; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/base_values.asl000066400000000000000000000021561475314470400253550ustar00rootroot00000000000000type my_enum of enumeration { MyEnum1, MyEnum2 }; func foo {N, M} (bv: bits(N), bv2: bits(M)) => integer {N..M, 42} begin var x: integer {N..M, 42}; return x; end; func main () => integer begin var x0: integer; assert x0 == 0; var x1: integer {3..5}; assert x1 == 3; var x2: integer {-6, 16}; assert x2 == -6; var x3: integer {2..5, -4..-3}; assert x3 == 2; var x3_bis: integer {3..5, 2}; assert x3_bis == 2; var x4: integer {2, -2}; println ("base value of {2, -2} is", x4); var x4_bis: integer {-2, 2}; println ("base value of {-2, 2} is", x4_bis); var x5: integer {-2..2}; assert x5 == 0; var x6: integer {5..3, 42}; assert x6 == 42; let x7 = foo ('00', '0000'); assert x7 == 2; let x7_bis = foo ('00', '00'); assert x7_bis == 2; let x7_ter = foo ('00', '0'); assert x7_ter == 42; let x7_quatro = foo (Zeros(64), Zeros(128)); assert x7_quatro == 42; var y: boolean; assert y == FALSE; var z: bits(3); assert z == '000'; var a: string; assert a == ""; var b: real; assert b == 0.0; var c: my_enum; assert c == MyEnum1; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/base_values_empty.asl000066400000000000000000000004771475314470400265770ustar00rootroot00000000000000func foo {N, M} (bv: bits(N), bv2: bits(M)) => integer {N..M} begin var x: integer {N..M}; return x; end; func main () => integer begin let x0 = foo ('00', '0000'); assert x0 == 2; let x1 = foo ('00', '00'); assert x1 == 2; let x2 = foo ('00', '0'); assert FALSE; // Should have failed earlier! end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/base_values_tuple.asl000066400000000000000000000001641475314470400265630ustar00rootroot00000000000000func main () => integer begin var (x, y) : (integer, boolean); assert x == 0 && y == FALSE; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/big-ints.asl000066400000000000000000000002161475314470400245730ustar00rootroot00000000000000func main () => integer begin assert (0x12345678123456789 > 0); // assert (UInt(0x2a2345678123456789[127:64]) == 42); return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/bitfields.asl000066400000000000000000000021221475314470400250220ustar00rootroot00000000000000 type MyBitVector of bits (5) { [2:0] first_three, [0 ] first, [4:0] everything, [0, 1, 2, 3, 4] reversed, [1:0, 2, 4:3] swapped, }; func build_one() => MyBitVector begin return '10111'; end; func set_first(bv:MyBitVector, b:bits(1)) => MyBitVector begin var bv_bis = bv; bv_bis.first = b; return bv_bis; end; func get_first_three(bv:MyBitVector) => bits(3) begin return bv.first_three; end; func as_MyBitVector(x:bits(5)) => MyBitVector begin return x; end; func main () => integer begin let bv = build_one (); assert set_first(bv, '0') == '10110'; assert set_first(set_first(bv, '1'), '0') == '10110'; assert get_first_three('11100') == '100'; assert get_first_three('11101') == '101'; assert as_MyBitVector('10010').everything == '10010'; assert as_MyBitVector('10010').reversed == '01001'; assert as_MyBitVector('10010').swapped == '10010'; assert as_MyBitVector('11010').swapped == '10011'; return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set +syntax:aslv1_colon_colon' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/bitvectors.asl000066400000000000000000000004331475314470400252440ustar00rootroot00000000000000func main() => integer begin var a = '101'; let b = a[1, 0]; a[0] = '0'; assert a == '100'; assert b == '01'; return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set +syntax:aslv1_colon_colon' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/bug1.asl000066400000000000000000000001731475314470400237170ustar00rootroot00000000000000func main () => integer begin let x: integer = 4; let y: integer = 5; let foo: bits(x) = Zeros{y}; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/bug2.asl000066400000000000000000000001571475314470400237220ustar00rootroot00000000000000func main () => integer begin let x: integer = 4; let y: integer = 5; let t = y[x: 0]; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/bug3.asl000066400000000000000000000001321475314470400237140ustar00rootroot00000000000000func main () => integer begin let x: integer = 4; let t = Zeros{x}; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/bug4.asl000066400000000000000000000002141475314470400237160ustar00rootroot00000000000000func main() => integer begin let a: integer {3, 4} = 3; let b: integer {3, 4} = 4; let pb = Zeros{a} OR Zeros{b}; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/case.asl000066400000000000000000000005251475314470400237750ustar00rootroot00000000000000func inv(i: integer) => integer begin case i of when 0 => return 1; when 1 => return 0; end; end; func main() => integer begin assert 1 == inv(0); assert 0 == inv(1); return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set -syntax:case_implies' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/cases_where.asl000066400000000000000000000004001475314470400253420ustar00rootroot00000000000000func main () => integer begin var x: integer; case x of when 2 => assert FALSE; when 0 where FALSE => assert FALSE; when 1 => assert FALSE; when 0 where 1 + 1 == 2 => assert TRUE; otherwise => assert FALSE; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/concat-empty.asl000066400000000000000000000001371475314470400254640ustar00rootroot00000000000000func main() => integer begin let empty_concatenation_should_not_parse = []; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/concat01.asl000066400000000000000000000006661475314470400245000ustar00rootroot00000000000000func main() => integer begin let o13 = Ones{13}; let o26 = o13 :: o13; assert o26 =='11111111111111111111111111'; let o5 = Ones{5}; let o11 = Ones{11}; let o16 = o5 :: o11; let p16 = o11 :: o5; assert o16 == p16; let o15 = Ones{15}; let o20 = o5 :: o15; let p20 = o15 :: o5; assert o20 == p20; let o8 = Ones{8}; let o6 = Ones{6}; let o14 = o8 :: o6; let p14 = o6 :: o8; assert o14 == p14; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/concat02.asl000066400000000000000000000004401475314470400244670ustar00rootroot00000000000000func main() => integer begin let a = '01'; let b = '10'; let a5 = '1' :: a :: a; let b14 = Replicate{14}(b); let b15 = '0' :: b14; let x20 = b15 :: a5; let a15 = '1' :: Replicate{14}(a); let b5 = '0' :: b :: b; let y20 = b5 :: a15; assert x20 == y20; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/concat03.asl000066400000000000000000000002051475314470400244670ustar00rootroot00000000000000func main() => integer begin let a = '11110000'; let b = '101'; let c = a :: b; assert c == '11110000101'; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/constant-functions.asl000066400000000000000000000003651475314470400267230ustar00rootroot00000000000000func double (x: integer) => integer begin return x * 2; end; constant A = double(32) as integer {0..1000}; constant C = double(double(16)) as integer {0..1000}; constant D: bits(A) = Zeros{C}; func main () => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/constant-zeros.asl000066400000000000000000000001521475314470400260470ustar00rootroot00000000000000constant z = Zeros{15}; func main () => integer begin assert z == '000000000000000'; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/constrained-integer-types-example.asl000066400000000000000000000043451475314470400316250ustar00rootroot00000000000000type Ity of integer {2,4,8}; func tsub02() begin var A = ARBITRARY: integer {2,4,8}; var B = ARBITRARY: integer {2,4}; // A and B have anonymous types A = B; // legal: FMXK clause 2 // B = A; // illegal: domain of B's type is not a subset of domain of A's type var I: Ity; I = A; // legal: FMXK clause 2 I = B; // legal: FMXK clause 2 // B = I; // illegal: subtype-satisfaction fails due to domains A = I; // legal: FMXK clause 2 end; var gInt: integer; // unconstrained global integer func f1() begin var myInt : integer = gInt; // Legal var myIntA: integer {1..10} = myInt as integer {1..10}; // Legal: incurs execution-time check that (myInt IN {1..10}) var myIntB: integer {0..20} = myIntA; // Legal: type satisfaction due to domains (no execution-time check required) // myIntA = myIntB; // Type check fail even if smart compiler believes myIntB holds // a value from myInt_A since // `integer {0..20}` does not type satisfy // `integer {1..10}` due to domains end; func wid1() => integer {8,16} begin return 8; // someWid1; end; func wid2() => integer {4,8} begin return 8; // someWid2; end; func f2() begin let w1: integer {2,4,8,16} = wid1(); // RHS is not statically evaluable so the only thing the type // checker can deduce is that w1==>w1 // We do not constrain w1 based on the return type of wid1 // since this may be intentional to avoid checked type conversions later // e.g. to ensure b1 has the correct type. let w2: integer {4,8,16} = wid2(); // RHS is not statically evaluable so w2==>w2 // The set of possible widths of a bitvector must be statically evaluable. // All of the following are: var b1 = Zeros {w1}; // type is bits(w1 as {2,4,8,16}) var b2 = Zeros {w2}; // type is bits(w2 as {4,8,16}) // b1 = b2; // Type check fail // Type checker cannot determine w1==w2 // so we require a Checked Type Conversion: b1 = b2 as bits(w1); // Type check PASS // but requires an execution-time width check that (w2==w1) end; func main () => integer begin tsub02 (); gInt = 3; f1 (); f2 (); return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set +syntax:aslv1_colon_colon' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/constrained-types-example.asl000066400000000000000000000024341475314470400301670ustar00rootroot00000000000000func invokeMe {N: integer {8,16,32}} (x: bits(N)) begin return; end; func test(M: integer {8,16,32}, L: integer {8,16}) begin var myM = Zeros {M}; var myL = Zeros {L}; if (M != L) then return; end; // Note the type-checker does not do full program analysis // So it does not know that M==L after this statement // myM = myL; // ILLEGAL // myM and myL are constrained width bitvectors of determined widths // M and L respectively. // The type-checker does not know (M==L), so subtype-satisfaction // disallows this use of myL. myM = myL as bits(M); // Legal // The author explicitly claimed that myL has the width of myM // An execution-time check of (M==L) is required invokeMe{L}(myL); // Legal // The parameter N is taken to be the value which corresponds // with the width of myL and the width of myL is an integer {8,16} // which complies with the declaration of parameter 'N' // The rules for subtype-satisfaction are satisfied since // the formal 'x' and the actual 'myL' are of the same determined width. end; func main() => integer begin test (8, 8); test (16, 16); test (32, 8); return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set +syntax:aslv1_colon_colon' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/declaration-primitive-local.asl000066400000000000000000000001071475314470400304410ustar00rootroot00000000000000config N : integer = 0; func main () => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/defining_param.asl000066400000000000000000000006021475314470400260210ustar00rootroot00000000000000constant global: integer {4,8} = 4; func foo {parm: integer} ( arg0: bits(global), arg1: bits(parm+global), arg2: (integer, bits(parm)) ) begin // The type of the second part of the tuple `arg2` is // parameter-defining for `parm`, without which the // declaration would be illegal. // None of the other formals are parameter-defining. return; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/division.asl000066400000000000000000000013061475314470400247040ustar00rootroot00000000000000func divrm() begin // Identities assert(1 DIVRM 1 == 1); assert(5 DIVRM 1 == 5); assert(5 DIVRM 5 == 1); assert(0 DIVRM 4 == 0); // Exact assert(4 DIVRM 2 == 2); // Rounding assert(5 DIVRM 2 == 2); assert(11 DIVRM 3 == 3); end; func check_mod() begin assert(5 MOD 1 == 0); assert(4 MOD 2 == 0); assert(3 MOD 2 == 1); assert(3 MOD 3 == 0); end; func main () => integer begin divrm(); check_mod(); assert 6 DIV 3 == 2; assert 6 DIVRM 3 == 2; assert 6 MOD 3 == 0; assert (-6) DIV 3 == -2; assert (-6) DIVRM 3 == -2; assert (-6) MOD 3 == 0; assert 5 DIVRM 3 == 1; assert 5 MOD 3 == 2; assert (-5) DIVRM 3 == -2; assert (-5) MOD 3 == 1; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/duplicate_enumeration_items.asl000066400000000000000000000000431475314470400306360ustar00rootroot00000000000000type t of enumeration { i, j, i }; herd-herdtools7-1ca343e/asllib/tests/regressions.t/duplicate_expr_record.asl000066400000000000000000000001571475314470400274310ustar00rootroot00000000000000type A of record {h : integer}; func main() => integer begin var x = A{h = 5, h = 9}; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/duplicate_function_args.asl000066400000000000000000000000641475314470400277530ustar00rootroot00000000000000func foo(i: integer, i: integer) begin pass; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/duplicate_record_fields.asl000066400000000000000000000001061475314470400277130ustar00rootroot00000000000000type MyRecord of record { i: integer, j: boolean, i: integer }; herd-herdtools7-1ca343e/asllib/tests/regressions.t/duplicated-otherwise.asl000066400000000000000000000003751475314470400272120ustar00rootroot00000000000000func main() => integer begin var x : real = 2.0; case x of when 0.0 => println("2.0"); otherwise => println("otherwise"); when 0.0 => println("2.0"); otherwise => println("otherwise"); end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/empty-slice.asl000066400000000000000000000002631475314470400253140ustar00rootroot00000000000000func foo(x: integer {0..10}, y: integer {0..10}) begin let z = Zeros{64}; println(z[x:y]); end; func main() => integer begin foo(4, 2); foo(2, 4); return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/enum-array.asl000066400000000000000000000005011475314470400251340ustar00rootroot00000000000000type MyEnum of enumeration { A, B, C }; type MyArray of array [[ MyEnum ]] of integer; func main () => integer begin var my_array: MyArray; my_array[[A]] = 1; my_array[[B]] = 2; my_array[[C]] = 3; assert (my_array[[A]] == 1); assert (my_array[[B]] == 2); assert (my_array[[C]] == 3); return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/equality.asl000066400000000000000000000007071475314470400247210ustar00rootroot00000000000000type myenum of enumeration {A, B, C}; type myty of integer; func main () => integer begin assert 1 == 1; assert 1 != 2; assert TRUE == TRUE; assert TRUE != FALSE; assert 3.13 == 3.13; assert 3.13 != 3.14; assert '010' == '010'; assert '011' != '010'; assert "blah" == "blah"; assert "foo" != "blah"; assert A == A; assert A != B; assert (1 as myty) == (1 as integer); assert (1 as myty) != (2 as integer); return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/exceptions.asl000066400000000000000000000045351475314470400252500ustar00rootroot00000000000000type BAD_OPCODE of exception; type UNDEFINED_OPCODE of exception {reason: string, opcode: bits(16)}; constant opcode : bits(16) = '0111011101110111'; func throw_undefined_opcode() begin throw UNDEFINED_OPCODE { reason="Undefined", opcode = opcode }; end; func try_opcode() => integer begin try throw_undefined_opcode(); return 1; catch when BAD_OPCODE => return 2; when e : UNDEFINED_OPCODE => assert e.opcode == opcode; return 0; otherwise => return 3; end; end; var opcode_counter: integer = 0; func rethrow_undefined_opcode () begin try throw_undefined_opcode(); assert FALSE; catch when BAD_OPCODE => assert FALSE; when UNDEFINED_OPCODE => opcode_counter = opcode_counter + 1; throw; end; assert FALSE; end; func try_rethrow () begin try rethrow_undefined_opcode (); assert FALSE; catch when e: UNDEFINED_OPCODE => assert e.opcode == opcode; assert opcode_counter == 1; otherwise => assert FALSE; end; end; type COUNTING of exception { counter: integer }; var counter : integer = 0; func throw_counting () begin let x = counter; counter = x + 1; throw COUNTING { counter = x }; end; func throw_imbricated() begin try throw_counting (); assert FALSE; catch when BAD_OPCODE => assert FALSE; when COUNTING => try throw; catch when COUNTING => assert FALSE; otherwise => assert FALSE; end; assert FALSE; end; assert FALSE; end; func try_imbricated() begin try throw_imbricated (); catch when e: COUNTING => assert e.counter == 0; counter = counter + 1; otherwise => assert FALSE; end; assert counter == 2; end; func try_with_local_variable () begin var local_counter: integer = 0; try try throw_undefined_opcode (); catch when UNDEFINED_OPCODE => local_counter = local_counter + 1; throw; end; assert FALSE; catch when UNDEFINED_OPCODE => local_counter = local_counter + 1; otherwise => assert FALSE; end; assert local_counter == 2; end; func main () => integer begin assert try_opcode() == 0; try_rethrow (); try_imbricated (); try_with_local_variable (); return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set +syntax:aslv1_colon_colon' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/func1.asl000066400000000000000000000004771475314470400241040ustar00rootroot00000000000000func f(i:integer) => integer begin return i; end; func main() => integer begin let x = 3; let y = f(x); assert x == 3; assert y == 3; return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set +syntax:aslv1_colon_colon' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/func2.asl000066400000000000000000000006121475314470400240740ustar00rootroot00000000000000getter X(i:integer) => integer begin return i; end; setter X(i:integer) = v:integer begin let internal_i = i; let internal_v = v; end; func main() => integer begin X(2) = 3; let x = X(4); assert x == 4; return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set +syntax:aslv1_colon_colon' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/func3.asl000066400000000000000000000016511475314470400241010ustar00rootroot00000000000000getter f1() => integer begin return 3; end; setter f1() = v : integer begin assert v == 3; end; getter f1b() => integer begin return 4; end; setter f1b() = v : integer begin assert v == 4; end; getter f2(x:integer) => integer begin return f1b() + x; end; setter f2(x:integer) = v : integer begin f1b() = 4 * (v - x); end; getter f3(x:integer) => integer begin return 0; end; setter f3(x:integer) = v : integer begin assert x == 12; assert v == 13; end; func main() => integer begin f1() = f1(); // f1 = f1; // Illegal because f1 is not an empty setter/getter f1b() = f1b(); let a = f1(); assert a == 3; assert f1() == 3; let b = f1(); assert b == 3; assert 3 == f1(); let c = f2(4); assert c == 8; f2(5) = 6; f3(12) = 13; return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set +syntax:aslv1_colon_colon' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/func4.asl000066400000000000000000000006421475314470400241010ustar00rootroot00000000000000func f() => integer begin return 0; end; func f(x:integer) => integer begin return x; end; func f(x:integer, y:integer) => integer begin return x + y; end; func main() => integer begin assert 0 == f(); assert 1 == f(1); assert 5 == f(2, 3); return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set +syntax:aslv1_colon_colon' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/func5.asl000066400000000000000000000007311475314470400241010ustar00rootroot00000000000000 func f(i : integer) => integer begin return i + 2; end; func f(b : boolean) => boolean begin return if b then FALSE else TRUE; end; func f(x : bits(3)) => boolean begin return x[0] == '0'; end; func main() => integer begin assert f(0) == 2; assert f(1) == 3; assert f(FALSE); assert f('110'); return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set +syntax:aslv1_colon_colon' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/func6.asl000066400000000000000000000004431475314470400241020ustar00rootroot00000000000000func main() => integer begin assert Len('11') == 2; assert Len('110') == 3; assert Len('101') == 3; assert Len('') == 0; return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set +syntax:aslv1_colon_colon' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/func7.asl000066400000000000000000000007631475314470400241100ustar00rootroot00000000000000func f0 {N} (x: bits(N)) => bits(N) begin return x; end; func f1 {M} (x: bits(M)) => integer {0..M} begin return Len(x) as integer {0..M}; end; func f2 {L}() => bits(L) begin return Zeros{L}; end; func main() => integer begin let x: bits(4) = f0{}('0000'); let y: integer {0..5} = f1{5}('11111'); let z: bits(6) = f2 {6}; return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set +syntax:aslv1_colon_colon' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/getter_sub_tuple.asl000066400000000000000000000004001475314470400264260ustar00rootroot00000000000000type MyBV of bits(8) { [5] bitfield }; getter F() => MyBV begin return Zeros{8} as MyBV; end; setter F() = v: MyBV begin assert v[0] == '0'; end; func main () => integer begin let res = (F(), 3).item0; assert res == Zeros{8}; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/getter_subfield.asl000066400000000000000000000003721475314470400262310ustar00rootroot00000000000000type MyBV of bits(8) { [5] bitfield }; getter F() => MyBV begin return Zeros{8} as MyBV; end; setter F() = v: MyBV begin assert v[0] == '0'; end; func main () => integer begin let res = F().bitfield; assert res == '0'; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/getter_subfields.asl000066400000000000000000000003741475314470400264160ustar00rootroot00000000000000type MyBV of bits(8) { [5] b1, [4] b2 }; getter F() => MyBV begin return Zeros{8} as MyBV; end; setter F() = v: MyBV begin assert v[0] == '0'; end; func main () => integer begin let res = F().[b1, b2]; assert res == '00'; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/getter_subslice.asl000066400000000000000000000003711475314470400262440ustar00rootroot00000000000000type MyBV of bits(8) { [5] bitfield }; getter F() => MyBV begin return Zeros{8} as MyBV; end; setter F() = v: MyBV begin assert v[0] == '0'; end; func main () => integer begin let res = F().bitfield; assert res == '0'; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/global_vars-02.asl000066400000000000000000000001711475314470400255710ustar00rootroot00000000000000var x : integer = 5; var y = x as integer{1..7}; func main() => integer begin assert y == 5; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/global_vars.asl000066400000000000000000000012021475314470400253460ustar00rootroot00000000000000 var global_x : integer = 0; func incr () begin global_x = global_x + 1; end; func incr2 () => integer begin let y = global_x; global_x = y + 1; return y; end; func add (x : integer, y: integer) => integer begin return x + y; end; func main () => integer begin incr (); incr (); incr (); assert global_x == 3; let i2 = incr2 (); assert i2 == 3; let i3 = incr2 (); assert 2 + i3 * 4 == 18; // assert add (incr2 (), 3) == 8; assert global_x == 5; return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set +syntax:aslv1_colon_colon' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/hello_world.asl000066400000000000000000000001121475314470400253640ustar00rootroot00000000000000func main() => integer begin println("Hello, world!"); return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/inherit-integer-constraints-bad-basic.asl000066400000000000000000000002011475314470400323160ustar00rootroot00000000000000func bad_basic() => integer{43} begin let x : integer{-} = 42; return x; end; func main() => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/inherit-integer-constraints-bad-tuple.asl000066400000000000000000000003031475314470400323710ustar00rootroot00000000000000func bad_tuple() => (integer{42}, integer{0}) begin let y : (integer{-}, boolean, integer{-}) = (42, TRUE, 43); return (y.item0, y.item2); end; func main() => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/inherit-integer-constraints-bad-type.asl000066400000000000000000000001571475314470400322300ustar00rootroot00000000000000type badtype of record { a : integer{-}, c : integer }; func main() => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/inherit-integer-constraints.asl000066400000000000000000000006721475314470400305270ustar00rootroot00000000000000type foo of (integer{1}, boolean); func good_basic() => integer{42} begin let x : integer{-} = 42; return x; end; func good_tuple() => (integer{42}, integer{43}) begin let y : (integer{-}, boolean, integer{-}) = (42, TRUE, 43); return (y.item0, y.item2); end; func good_named_tuple() => (integer{1}, boolean) begin var f : foo; let z : (integer{-}, boolean) = f; return z; end; func main() => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/integer-accessed-bitvector.asl000066400000000000000000000001251475314470400302620ustar00rootroot00000000000000func main () => integer begin var x: integer = 32; x[0] = '1'; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/lhs-tuple-fields-same-field.asl000066400000000000000000000002361475314470400302460ustar00rootroot00000000000000type BV of bits (8) { [1:0] fld, }; func main() => integer begin var bv : BV; bv.(fld, -, fld) = ('11', TRUE, '11'); assert FALSE; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/lhs-tuple-fields.asl000066400000000000000000000003301475314470400262350ustar00rootroot00000000000000type BV of bits (8) { [1:0] fldA, [7:5] fldB }; func main() => integer begin var bv : BV; bv.(fldA, -, fldB) = ('11', TRUE, '111'); assert (bv.fldA == '11'); assert (bv.fldB == '111'); return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/lhs-tuple-same-var.asl000066400000000000000000000002361475314470400265070ustar00rootroot00000000000000type BV of bits (8) { [1:0] fld }; func main() => integer begin var bv : BV; (bv[7], -, bv.fld) = ('1', TRUE, '11'); assert FALSE; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/masks.asl000066400000000000000000000017171475314470400242040ustar00rootroot00000000000000func main () => integer begin assert ('111' IN {'1xx'}) == TRUE; assert ('111' == '1xx') == TRUE; assert ('111' IN {'0xx'}) == FALSE; assert ('111' == '0xx') == FALSE; assert (3 IN {2,3,4}) == TRUE; assert (1 IN {2,3,4}) == FALSE; assert (3 IN {1..10}) == TRUE; assert (3 IN {<= 10}) == TRUE; assert (3 IN !{1,2,4}) == TRUE; assert ((1, 2) IN {(1, 2)}) == TRUE; assert ((1,'10') IN {(1,'1x')}) == TRUE; assert ((1,'10') IN {(1,'0x'), (2, '1x')}) == FALSE; // (see note below) assert ((1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, '11') IN {(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, '0x')}) == FALSE; // The last two expressions are equivalent to: let expr_H = (1 IN {1}) && ('10' IN {'1x'}); let expr_I = ((1 IN {1}) && ('10' IN {'0x'})) || ((1 IN {2}) && ('10' IN {'1x'})); return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set +syntax:aslv1_colon_colon' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/more-assignments-examples.asl000066400000000000000000000031041475314470400301650ustar00rootroot00000000000000func assignBits {N:integer, M: integer} (someWid: integer {32,64}, argN: bits(N), argM: bits(M)) begin // argN and argM are immutable parameterized width bitvectors // assignments to them are illegal // legal since widths and domains match var eightBits: bits(8) = Zeros{8}; // legal: someBits has undetermined width so we require RHS to be a // bitvector whose domain is a subset of {32,64} which it is by the // declaration of someWid // var someBits: bits({32,64}) = Zeros{someWid}; // underconstrainedBits is a mutable parameterized width bitvector // it can be assigned to var underconstrainedBits = Zeros {N}; // underconstrainedBits has determined width `N`, so RHS must have same width underconstrainedBits = argN; // legal since widths match // and domains are identical // underconstrainedBits = argM; // illegal since widths do not match // underconstrainedBits = eightBits; // illegal since widths do not match // underconstrainedBits = someBits; // illegal since widths do not match // (someWid==N may be false) // eightBits = underconstrainedBits; // illegal since widths do not match // someBits = underconstrainedBits; // illegal since widths do not match // (someWid==N may be false) end; func main () => integer begin assignBits{3,4}(32, '111', '0000'); return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set +syntax:aslv1_colon_colon' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/more-invocation-examples.asl000066400000000000000000000052141475314470400300070ustar00rootroot00000000000000func bus {wid: integer} (arg0: bits(wid), arg1: bits(wid*2)) => bits(wid) begin // When type-checking the declaration of func bus // arg0 and arg1 are parameterized width bitvectors // of determined width `wid` // Since wid is not a formal, it takes its value in an invocation from // the width of one of the the corresponding actuals return arg0; end; // ------------------------------------------------------------ // Cases for invocation of function `bus` // which has a parameterized width bitvector formal func legal_fun_fixed_width_actual () => bits(8) begin let x: bits(8) = Zeros{8}; let y: bits(16) = Zeros{16}; // bus's wid parameter takes its value as `8` // The invocation width of bus's arg0 is therefore `8` // x type satisfies arg0: bits(8) // The invocation width of bus's arg1 is therefore `8*2` // y type satisfies arg0: bits(16) return bus{8}(x, y); end; func legal_fun_underconstrained_actual {N}() => bits(N) begin // N is a parameter, therefore it is a parameterized integer var x = Zeros {N}; var y = Zeros {N*2}; // bus's wid parameter takes its value from the width of x // which is `N` which is a parameterized integer // Therefore the type of arg0 with the invocation width `N` is // the under-constrained width bitvector of determined width `N` // which is type satisfied by x return bus{N}(x, y); end; // func legal_fun_constrained_actual (arg: bits({32,64})) => bits(32) // begin // This invocation is OK because the actual has undetermined width // so the formal is treated as having undetermined width // and the domain of bits({32,64}) is a subset of the domain of the // undetermined width bitvector // return bus(arg, [arg,arg])[31:0]; // return Zeros{32}; // end; // func illegal_fun_parameter_mismatch (N: integer{32,64}, M: integer{64,128}) // begin // var argN = Zeros {N}; // var argM = Zeros {M}; // Illegal invocation: // Either bus's wid takes its value from argN // in which case argM does not type satisfy arg1 // OR bus's wid takes its value from argM // in which case argN does not type satisfy arg0 // let illegal = bus(argN, argM); // A checked type conversion might be useful... // let legal = bus(argN, argM as bits(N*2)); // end; func main () => integer begin let - = legal_fun_fixed_width_actual (); let - = legal_fun_underconstrained_actual {4}; // let - = legal_fun_constrained_actual (Zeros{32}); // let - = legal_fun_constrained_actual (Zeros{64}); // illegal_fun_parameter_mismatch (32, 64); return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set +syntax:aslv1_colon_colon' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/named-types-example.asl000066400000000000000000000026331475314470400267430ustar00rootroot00000000000000// Neither ADDR nor PHYSICAL_ADDR is a subtype of the other. type ADDR of bits (32) {}; type PHYSICAL_ADDR of ADDR; var addr : ADDR; var physical: PHYSICAL_ADDR; // For the function "raw_addr", func raw_addr(x: ADDR) => bits(32) begin // x may be used as the expression in the return statement // since the return type is type satisfied by the type of x return x; end; func raw_physical_addr(x: PHYSICAL_ADDR) => bits(32) begin return x; end; func addresses() begin var tmp:bits(32); // primitive type bits(32) is type-satisfied by both ADDR and PHYSICAL_ADDR tmp = addr; physical = tmp; tmp = '0' :: tmp[30:0]; addr = tmp; physical = raw_addr(addr); addr = raw_physical_addr(physical); physical = addr[31:0]; // a bitslice is of type bits(N) addr = physical[31:0]; end; type Char of integer{0..255}; type Byte of integer{0..255}; constant K: Char = 210; var global_c: Char; var global_b: Byte; func f() begin pass; // global_c = 210; // legal: c has the structure of integer and can be assigned an integer // global_c = K; // legal: K has type Char and can be assigned to a Char // global_b = K; // illegal: a Char cannot be directly assigned to a Byte end; func main() => integer begin pass; return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set +syntax:aslv1_colon_colon' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/named-types-in-slices.asl000066400000000000000000000003121475314470400271660ustar00rootroot00000000000000type pagros of integer{1,2,4,8,16}; var ones = Ones{64}; func f{sz:pagros}() => bits(sz) begin return ones[sz-1:0]; end; func main() => integer begin let x = f{8}; println(x); return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/nested-bitfields.asl000066400000000000000000000017641475314470400263150ustar00rootroot00000000000000type CPTR_EL2_Type of bits(64) { // common across formats [31] TCPAC, [30] TAM, // View when E2H register has value '0' [29:0] E2H0 { [20] TTA, [10] TFP, [8] TZ }, // View when E2H register has value '1' [29:0] E2H1 { [28] TTA, [20+:2] FPEN, [16+:2] ZEN } }; // Other syntax not in the LRM example type E2H0Type of bits(30) { [20] TTA, [10] TFP, [8] TZ }; type CPTR_EL2_Type_bis of bits(64) { [31] TCPAC, [30] TAM, [29:0] E2H0: E2H0Type, [29:0] E2H1: bits(30) { [28] TTA, [20+:2] FPEN, [16+:2] ZEN }, }; func main() => integer begin var E2H: bit; var CPTR: CPTR_EL2_Type; // Select TTA depending on the value of E2H let TTA: bit = if E2H == '0' then CPTR.E2H0.TTA else CPTR.E2H1.TTA; var E2H_bis: bit; var CPTR_bis: CPTR_EL2_Type_bis; // Select TTA depending on the value of E2H let TTA_bis: bit = if E2H_bis == '0' then CPTR_bis.E2H0.TTA else CPTR_bis.E2H1.TTA; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/nonempty-getter-called-without-slices.asl000066400000000000000000000001551475314470400324250ustar00rootroot00000000000000getter f1() => integer begin return 4; end; func main () => integer begin let x = f1; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/nonempty-setter-called-without-slices.asl000066400000000000000000000002261475314470400324400ustar00rootroot00000000000000getter f1() => integer begin return 4; end; setter f1() = v: integer begin pass; end; func main () => integer begin f1 = 4; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/operator_precedence.asl000066400000000000000000000043721475314470400270760ustar00rootroot00000000000000func operator_precedence( a: integer, b: integer, c: integer, d: bits(8), e: bits(8), f: bits(8), g: boolean) begin let p_m_s = a * b - c; // '*' has higher precedence than '-' so interpreted as: let p_m_s_I = (a * b) - c; assert(p_m_s == p_m_s_I); let p_s_m = a - b * c; // '*' has higher precedence than '-' so interpreted as: let p_s_m_I = a - (b * c); assert(p_s_m == p_s_m_I); // let p_a_s = a + b - c; // '+' has equal precedence to '-' so causes a compile-time error. // Must be written as either: let p_a_s_A1 = (a + b) - c; let p_a_s_A2 = a + (b - c); // let p_s_a = a - b + c; // '-' has equal precedence to '+' so causes a compile-time error. // Must be written as either: let p_s_a_A1 = (a - b) + c; let p_s_a_A2 = a - (b + c); let p_a_e = a + b ^ c; // '^' has higher precedence than '+' so interpreted as: let p_a_e_I = a + (b ^ c); assert(p_a_e == p_a_e_I); let p_and_and = d AND e AND f; // 'AND' is associative so can be interpreted as either: let p_and_and_i1 = (d AND e) AND f; let p_and_and_i2 = d AND (e AND f); assert(p_and_and == p_and_and_i1); assert(p_and_and == p_and_and_i2); // let p_and_or = d AND e OR f; // 'AND' and 'OR' have no defined precedence so causes a compile-time error. // Must be written as either: let p_and_or_A1 = (d AND e) OR f; let p_and_or_A2 = d AND (e OR f); let p_band_eq = g && a == b; // '&&' is of precedence class 'Boolean'. // '==' is of precedence class 'Comparison'. // 'Comparison' has higher precedence than 'Boolean' so interpreted as: let p_band_eq_I = g && (a == b); assert(p_band_eq == p_band_eq_I); // let p_eq_eq = a == b == g; // '==' is not associative so causes a compile-time error. // Must be written as: let p_eq_eq_A1 = (a == b) == g; // Note: 'a == (b == g)' is not valid as it does not type satisfy. end; func main() => integer begin for i = 0 to 3 do for j = 0 to 3 do for k = 0 to 3 do for l = 0 to 3 do for m = 0 to 3 do for n = 0 to 3 do operator_precedence (i, j, k, l[7:0], m[7:0], n[7:0], TRUE); operator_precedence (i, j, k, l[7:0], m[7:0], n[7:0], FALSE); end; end; end; end; end; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/overlapping-slices.asl000066400000000000000000000001511475314470400266630ustar00rootroot00000000000000type t of bits(64) { [23: 0] a, [10: 0, 3+: 2] b, }; func main () => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/pass.asl000066400000000000000000000003071475314470400240260ustar00rootroot00000000000000func main() => integer begin pass; return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set +syntax:aslv1_colon_colon' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/pattern-masks-no-braces.asl000066400000000000000000000001671475314470400275240ustar00rootroot00000000000000 func main () => integer begin assert ('111' IN '1xx') == TRUE; assert ('111' IN '0xx') == FALSE; return 0; end herd-herdtools7-1ca343e/asllib/tests/regressions.t/pattern-string.asl000066400000000000000000000004071475314470400260420ustar00rootroot00000000000000func myfunction( s : string) begin case s of when "hello" => println("helloworld"); otherwise => return; end; end; func main () => integer begin myfunction ("Hello"); myfunction ("helloworld\n"); return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/patterns.asl000066400000000000000000000014451475314470400247240ustar00rootroot00000000000000func example_5_3 () begin // let expr_A = '111' IN {'1xx'}; // TRUE // assert expr_A; // let expr_B = '111' IN {'0xx'}; // FALSE // assert !expr_B; let expr_C = 3 IN {2,3,4}; // TRUE assert expr_C; let expr_D = 1 IN {2,3,4}; // FALSE assert !expr_D; let expr_E = 3 IN {1..10}; // TRUE assert expr_E; let expr_F = 3 IN {<= 10}; // TRUE assert expr_F; let expr_G = 3 IN !{1,2,4}; // TRUE assert expr_G; end; func main () => integer begin example_5_3 (); return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set +syntax:aslv1_colon_colon' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/pstate-exp.asl000066400000000000000000000035771475314470400251660ustar00rootroot00000000000000// Experimental implementation of PSTATE as two independant variables. type ProcState of bits(8) { [0] N, [1] Z, [2] C, [3] V, [7] SomethingElse, }; var _PSTATE : ProcState; var _NZCV : ProcState; func isNZCV(n:integer) => boolean begin return 0 <= n && n < 4 ; end; getter PSTATE() => ProcState begin return _PSTATE; end; setter PSTATE() = v : ProcState begin _PSTATE = v; end; getter PSTATE(n:integer) => bits(1) begin if isNZCV(n) then return _NZCV[n]; else return _PSTATE[n]; end; end; setter PSTATE(n:integer) = v : bits(1) begin if isNZCV(n) then _NZCV[n] = v; else _PSTATE[n] = v; end; end; getter PSTATE(n:integer,m:integer) => bits(2) begin if isNZCV(n) && isNZCV(m) then return _NZCV[n,m]; else return _PSTATE[n,m]; end; end; setter PSTATE(n:integer,m:integer) = v : bits(2) begin if isNZCV(n) && isNZCV(m) then _NZCV[n,m] = v; else _PSTATE[n,m] = v; end; end; getter PSTATE(n:integer,m:integer,o:integer) => bits(3) begin if isNZCV(n) && isNZCV(m) && isNZCV(o) then return _NZCV[n,m,o]; else return _PSTATE[n,m,o]; end; end; setter PSTATE(n:integer,m:integer,o:integer) = v : bits(3) begin if isNZCV(n) && isNZCV(m) && isNZCV(o) then _NZCV[n,m,o] = v; else _PSTATE[n,m,o] = v; end; end; getter PSTATE(n:integer,m:integer,o:integer,p:integer) => bits(4) begin if isNZCV(n) && isNZCV(m) && isNZCV(o) && isNZCV(p) then return _NZCV[n,m,o,p]; else return _PSTATE[n,m,o,p]; end; end; setter PSTATE(n:integer,m:integer,o:integer,p:integer) = v : bits(4) begin if isNZCV(n) && isNZCV(m) && isNZCV(o) && isNZCV(p) then _NZCV[n,m,o,p] = v; else _PSTATE[n,m,o,p] = v; end; end; func main () => integer begin let - = PSTATE(); let - = PSTATE().N; let - = PSTATE().[N, Z]; PSTATE() = ARBITRARY: ProcState; PSTATE().N = '1'; PSTATE().[N, Z] = '00'; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/rdiv_checks.asl000066400000000000000000000001121475314470400253360ustar00rootroot00000000000000func main() => integer begin var x = 5.3 / "hello"; return 0; end;herd-herdtools7-1ca343e/asllib/tests/regressions.t/record-getfields.asl000066400000000000000000000004501475314470400263010ustar00rootroot00000000000000type R of record { a: integer, b: bits(3), c: bits(4), }; func main () => integer begin var x = R { a = 32, b = Zeros{3}, c = '1010' }; let y = x.[b, c]; assert y == '0001010'; x.[c, b] = '1100111'; let z = x.[b, c]; assert z == '1111100'; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/records-2.asl000066400000000000000000000014031475314470400246560ustar00rootroot00000000000000 type a_record_ty of record { flag : boolean, count: integer, data : bit }; type aa_record_ty of record { flag : boolean, count: integer, data : bit, foo: integer } subtypes a_record_ty; func equal_a_record_ty (x: a_record_ty, y: a_record_ty) => boolean begin return x.flag == y.flag && x.count == y.count && x.data == y.data; end; func main() => integer begin let a = a_record_ty { flag = TRUE, count = 3, data = '1' }; let aa = aa_record_ty { flag = TRUE, count = 3, data = '1', foo = 5 }; assert equal_a_record_ty (a, aa); return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set +syntax:aslv1_colon_colon' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/records.asl000066400000000000000000000031421475314470400245210ustar00rootroot00000000000000 type SomeOtherType of integer; type MyFieldType of record { subfieldA: boolean, subfieldB: integer, }; type MyRecord of record { fieldA: integer, fieldB: MyFieldType, fieldC: SomeOtherType, }; func build_record() => MyRecord begin return MyRecord { fieldA = 3, fieldB = MyFieldType { subfieldA = TRUE, subfieldB = 4 }, fieldC = 5 }; end; func access_subfieldA(obj:MyRecord) => boolean begin return obj.fieldB.subfieldA; end; func incr_subfieldB(obj:MyRecord) => MyRecord begin var obj2 = obj; obj2.fieldB.subfieldB = obj2.fieldB.subfieldB + 1; return obj2; end; func set_fieldC(obj:MyRecord, val:integer) => MyRecord begin var obj2 = obj; obj2.fieldC = val; return obj2; end; func build_and_access() begin let obj = MyRecord { fieldA = 3, fieldB = MyFieldType { subfieldA = TRUE, subfieldB = 4 }, fieldC = 5 }; assert obj.fieldB.subfieldA; end; func build_access() begin assert MyRecord { fieldA = 3, fieldB = MyFieldType { subfieldA = TRUE, subfieldB = 4 }, fieldC = 5 }.fieldB.subfieldA; end; func main() => integer begin let obj = build_record (); assert access_subfieldA(obj); assert incr_subfieldB(obj).fieldB.subfieldB == 5; assert obj.fieldB.subfieldB == 4; // No edit by reference assert set_fieldC(obj, 32).fieldC == 32; assert obj.fieldC == 5; // No edit by reference build_and_access (); build_access (); return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set +syntax:aslv1_colon_colon' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/rename-returned-tuples.asl000066400000000000000000000004301475314470400274640ustar00rootroot00000000000000func foo {M}() => (bits (M), boolean) begin return (Zeros{M}, TRUE); end; func bar {B,A} (bv: bits(A)) => bits (B) begin let (result, b) = foo {B}; return result; end; func main () => integer begin let x = bar{5,4}('1010'); let y = bar{4,4}('0101'); return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/run.t000066400000000000000000000327571475314470400233660ustar00rootroot00000000000000Hello world should work: $ aslref hello_world.asl Hello, world! Type-checking errors: $ aslref subtype-satisfaction-arrray-illegal.asl File subtype-satisfaction-arrray-illegal.asl, line 4, characters 0 to 38: ASL Typing error: a subtype of m was expected, provided array [[10]] of n. [1] $ aslref anonymous-types-example.asl File anonymous-types-example.asl, line 21, characters 2 to 6: ASL Typing error: a subtype of pairT was expected, provided (integer {1}, T2). [1] $ aslref duplicate_function_args.asl File duplicate_function_args.asl, line 1, character 0 to line 4, character 4: ASL Typing error: cannot declare already declared element "i". [1] $ aslref duplicate_record_fields.asl File duplicate_record_fields.asl, line 1, character 0 to line 5, character 2: ASL Typing error: cannot declare already declared element "i". [1] $ aslref duplicate_enumeration_items.asl File duplicate_enumeration_items.asl, line 1, characters 0 to 34: ASL Typing error: cannot declare already declared element "i". [1] $ aslref constant-zeros.asl Bad types: $ aslref overlapping-slices.asl File overlapping-slices.asl, line 1, character 0 to line 4, character 2: ASL Static error: overlapping slices 0+:11, 3+:2. [1] $ aslref bad-inclusion-in-symbolic-type.asl File bad-inclusion-in-symbolic-type.asl, line 2, characters 0 to 26: ASL Typing error: a subtype of integer {2..A} was expected, provided integer {1}. [1] Global ignored: $ cat >global_ignored.asl < var - = 3 / 0; > func main () => integer > begin return 0; end; > EOF $ aslref global_ignored.asl File global_ignored.asl, line 1, characters 8 to 13: ASL Typing error: Illegal application of operator / on types integer {3} and integer {0}. [1] Constrained-type satisfaction: $ cat >type-sat1.asl < func illegal_f1() > begin > var x: integer { 8, 16 }; > var y: integer { 8, 16, 32}; > x = y; // illegal as domain of x is not a subset of domain of y > end; > EOF $ aslref type-sat1.asl File type-sat1.asl, line 5, characters 2 to 3: ASL Typing error: a subtype of integer {8, 16} was expected, provided integer {8, 16, 32}. [1] $ cat >type-sat2.asl < func illegal_f2() > begin > var x: integer { 8 , 16 }; > var y: integer; > x = y; // illegal > end; > EOF $ aslref type-sat2.asl File type-sat2.asl, line 5, characters 2 to 3: ASL Typing error: a subtype of integer {8, 16} was expected, provided integer. [1] $ aslref type_satisfaction_illegal_f3.asl File type_satisfaction_illegal_f3.asl, line 9, characters 4 to 17: ASL Typing error: a subtype of integer {8, 16} was expected, provided integer. [1] $ aslref type_satisfaction_illegal_f4.asl File type_satisfaction_illegal_f4.asl, line 9, characters 4 to 17: ASL Typing error: a subtype of integer {8, 16} was expected, provided integer {8..64}. [1] $ cat >type-sat3.asl < func illegal_f5 {N} (b: bits(N)) > begin > // N is under-constrained integer > var x: integer { 2, 4} = N; > return; > end; > EOF $ aslref type-sat3.asl File type-sat3.asl, line 4, characters 2 to 29: ASL Typing error: a subtype of integer {2, 4} was expected, provided integer {N}. [1] $ cat >type-sat4.asl < func invokeMe_2 {N} (b: bits(N)) > begin > // N is under-constrained integer > var x: integer { 2, 4} = N; > return; > end; > EOF $ aslref type-sat4.asl File type-sat4.asl, line 4, characters 2 to 29: ASL Typing error: a subtype of integer {2, 4} was expected, provided integer {N}. [1] Runtime checks: $ cat >runtime-type-sat1.asl < func main () => integer > begin > let x: integer {1} = 2 as integer {1}; > return 0; > end; > EOF $ aslref runtime-type-sat1.asl File runtime-type-sat1.asl, line 3, characters 23 to 24: ASL Execution error: Mismatch type: value 2 does not belong to type integer {1}. [1] $ cat >runtime-type-sat2.asl < func test(size: integer {3, 4}) begin > let - = Zeros{4} as bits(size); > end; > func main () => integer begin > test(4); > test(3); > return 0; > end; > EOF $ aslref runtime-type-sat2.asl File runtime-type-sat2.asl, line 2, characters 10 to 18: ASL Execution error: Mismatch type: value 0x0 does not belong to type bits(size). [1] $ aslref under-constrained-used.asl Parameterized integers: $ aslref bad-underconstrained-call.asl File bad-underconstrained-call.asl, line 9, characters 9 to 26: ASL Typing error: a subtype of integer {0..(M - 1)} was expected, provided integer {M}. [1] $ aslref bad-underconstrained-call-02.asl File bad-underconstrained-call-02.asl, line 8, characters 2 to 15: ASL Typing error: a subtype of integer {M} was expected, provided integer {3}. [1] $ aslref bad-underconstrained-call-03.asl File bad-underconstrained-call-03.asl, line 8, characters 2 to 19: ASL Typing error: a subtype of integer {M} was expected, provided integer {(M + 1)}. [1] $ aslref bad-underconstrained-ctc.asl File bad-underconstrained-ctc.asl, line 3, characters 12 to 13: ASL Execution error: Mismatch type: value 4 does not belong to type integer {(N - 1)}. [1] $ aslref bad-underconstrained-return.asl File bad-underconstrained-return.asl, line 3, characters 2 to 15: ASL Typing error: a subtype of integer {0..N} was expected, provided integer {(N + 1)}. [1] $ aslref bad-underconstrained-return-02.asl File bad-underconstrained-return-02.asl, line 3, characters 2 to 11: ASL Typing error: a subtype of integer {0..N} was expected, provided integer {5}. [1] $ aslref named-types-in-slices.asl 0xff $ aslref empty-slice.asl 0x0 ASL Dynamic error: Cannot extract from bitvector of length 0 slice 4+:-1. [1] $ aslref bad-slices.asl ASL Dynamic error: Cannot extract from bitvector of length 0 slice 4+:-23. [1] $ aslref bad-shift.asl 0x00 $ aslref unreachable.asl File unreachable.asl, line 3, characters 2 to 17: ASL Dynamic error: Unreachable reached. [1] $ aslref assign-to-global-immutable.asl File assign-to-global-immutable.asl, line 5, characters 2 to 21: ASL Typing error: cannot assign to immutable storage "my_immutable_global". [1] $ aslref equality.asl $ aslref bad-equality.asl File bad-equality.asl, line 3, characters 10 to 25: ASL Typing error: Illegal application of operator == on types (integer {1}, integer {2}) and (integer {1}, integer {2}). [1] $ aslref setter_without_getter.asl File setter_without_getter.asl, line 1, character 0 to line 4, character 4: ASL Typing error: setter "f" does not have a corresponding getter of signature integer -> integer. [1] $ aslref tuple_items.asl $ aslref cases_where.asl $ aslref duplicated-otherwise.asl File duplicated-otherwise.asl, line 7, characters 8 to 12: ASL Error: Cannot parse. [1] $ aslref duplicate_expr_record.asl File duplicate_expr_record.asl, line 5, characters 12 to 27: ASL Typing error: cannot declare already declared element "h". [1] $ aslref same-precedence.asl File same-precedence.asl, line 6, characters 10 to 15: ASL Error: Cannot parse. [1] $ aslref rdiv_checks.asl File rdiv_checks.asl, line 3, characters 12 to 25: ASL Typing error: Illegal application of operator / on types real and string. [1] $ aslref record-getfields.asl $ aslref integer-accessed-bitvector.asl File integer-accessed-bitvector.asl, line 4, characters 2 to 3: ASL Typing error: a subtype of bits(-) was expected, provided integer. [1] $ aslref slice-width-shorthand.asl Arrays indexed by enumerations $ aslref enum-array.asl $ aslref array-lca.asl $ aslref array-index-error.asl ASL Execution error: Mismatch type: value 14 does not belong to type integer {0..4}. [1] Parameters bugs: $ aslref bug1.asl File bug1.asl, line 5, characters 21 to 29: ASL Typing error: constrained integer expected, provided integer. [1] $ aslref bug2.asl File bug2.asl, line 5, characters 10 to 17: ASL Typing error: constrained integer expected, provided integer. [1] $ aslref bug3.asl File bug3.asl, line 4, characters 10 to 18: ASL Typing error: constrained integer expected, provided integer. [1] $ aslref bug4.asl File bug4.asl, line 5, characters 11 to 31: ASL Typing error: Illegal application of operator OR on types bits(3) and bits(4). [1] $ aslref arg-as-param-call.asl File arg-as-param-call.asl, line 8, characters 4 to 21: ASL Typing error: a subtype of bits(10) was expected, provided bits(4). [1] $ aslref typed-param-call.asl File typed-param-call.asl, line 8, characters 4 to 18: ASL Typing error: a subtype of integer {5..10} was expected, provided integer {2}. [1] $ aslref typed-arg-as-param-call.asl File typed-arg-as-param-call.asl, line 8, characters 4 to 18: ASL Typing error: a subtype of integer {5..10} was expected, provided integer {2}. [1] $ aslref --no-exec defining_param.asl $ aslref rename-returned-tuples.asl Required tests: $ aslref anonymous-types-example-success.asl $ aslref array-with-enums.asl $ aslref array.asl $ aslref -0 assign-v0.asl $ aslref -0 asl0-patterns.asl File asl0-patterns.asl, line 7, characters 25 to 29: ASL Error: Cannot parse. [1] $ aslref assign1.asl $ aslref big-ints.asl $ aslref bitfields.asl $ aslref bitvectors.asl $ aslref case.asl $ aslref concat-empty.asl File concat-empty.asl, line 3, characters 45 to 46: ASL Error: Cannot parse. [1] $ aslref concat01.asl $ aslref concat02.asl $ aslref concat03.asl $ aslref constrained-integer-types-example.asl $ aslref constrained-types-example.asl $ aslref division.asl $ aslref exceptions.asl $ aslref func1.asl $ aslref func2.asl $ aslref func3.asl $ aslref func4.asl $ aslref func5.asl $ aslref func6.asl $ aslref func7.asl $ aslref global_vars.asl $ aslref global_vars-02.asl $ aslref masks.asl $ aslref more-assignments-examples.asl $ aslref more-invocation-examples.asl $ aslref named-types-example.asl $ aslref nested-bitfields.asl $ aslref operator_precedence.asl $ aslref pass.asl $ aslref patterns.asl $ aslref pattern-string.asl $ aslref records-2.asl $ aslref records.asl $ aslref static.asl $ aslref stdlib.asl $ aslref subtypes-example.asl $ aslref subtypes-with.asl $ aslref tuples.asl $ aslref declaration-primitive-local.asl $ aslref --no-type-check -0 typing-assign-v0.asl $ aslref constant-functions.asl $ aslref undeclared-variable.asl File undeclared-variable.asl, line 3, characters 2 to 5: ASL Error: Undefined identifier: 'bar' [1] Base values $ aslref base_values.asl File base_values.asl, line 5, characters 2 to 28: ASL Typing error: base value of type integer {42, N..M} cannot be statically determined since it consists of N. [1] $ aslref base_values_empty.asl File base_values_empty.asl, line 3, characters 2 to 24: ASL Typing error: base value of type integer {N..M} cannot be statically determined since it consists of N. [1] $ aslref base_values_tuple.asl Getters/setters $ aslref nonempty-getter-called-without-slices.asl File nonempty-getter-called-without-slices.asl, line 8, characters 10 to 12: ASL Error: Undefined identifier: 'f1' [1] $ aslref nonempty-setter-called-without-slices.asl File nonempty-setter-called-without-slices.asl, line 13, characters 2 to 4: ASL Error: Undefined identifier: 'f1' [1] $ aslref setter_subfield.asl $ aslref setter_subslice.asl File setter_subslice.asl, line 15, characters 5 to 6: ASL Error: Cannot parse. [1] $ aslref getter_subfield.asl $ aslref getter_sub_tuple.asl $ aslref getter_subslice.asl $ aslref getter_subfields.asl $ aslref bad-pattern.asl File bad-pattern.asl, line 4, characters 7 to 12: ASL Typing error: Erroneous pattern '101' for expression of type integer {3}. [1] $ aslref pattern-masks-no-braces.asl File pattern-masks-no-braces.asl, line 4, characters 19 to 24: ASL Error: Cannot parse. [1] ASLRef Field getter extension $ aslref --use-field-getter-extension setter_bitfields.asl $ aslref --use-field-getter-extension pstate-exp.asl $ aslref atc-in-types.asl File atc-in-types.asl, line 1, characters 14 to 29: ASL Typing error: a pure expression was expected, found 1 as integer {2}, which produces the following side-effects: [PerformsAssertions]. [1] $ aslref single-slice.asl Inherit integer constraints on left-hand sides $ aslref inherit-integer-constraints.asl $ aslref inherit-integer-constraints-bad-basic.asl File inherit-integer-constraints-bad-basic.asl, line 4, characters 2 to 11: ASL Typing error: a subtype of integer {43} was expected, provided integer {42}. [1] $ aslref inherit-integer-constraints-bad-tuple.asl File inherit-integer-constraints-bad-tuple.asl, line 4, characters 2 to 28: ASL Typing error: a subtype of (integer {42}, integer {0}) was expected, provided (integer {42}, integer {43}). [1] $ aslref inherit-integer-constraints-bad-type.asl File inherit-integer-constraints-bad-type.asl, line 1, character 0 to line 4, character 2: ASL Typing error: a pending constrained integer is illegal here. [1] Left-hand sides $ aslref lhs-tuple-fields.asl $ aslref lhs-tuple-fields-same-field.asl File lhs-tuple-fields-same-field.asl, line 8, characters 2 to 4: ASL Typing error: multiple writes to "bv.fld". [1] $ aslref lhs-tuple-same-var.asl File lhs-tuple-same-var.asl, line 8, characters 2 to 20: ASL Typing error: multiple writes to "bv". [1] herd-herdtools7-1ca343e/asllib/tests/regressions.t/same-precedence.asl000066400000000000000000000001471475314470400261020ustar00rootroot00000000000000func main () => integer begin let a = 1; let b = 2; let c = 4; let - = a + b - c; return 0; herd-herdtools7-1ca343e/asllib/tests/regressions.t/setter_bitfields.asl000066400000000000000000000004241475314470400264130ustar00rootroot00000000000000type MyBV of bits(8) { [5] bitfield }; getter F() => MyBV begin return Ones{8} as MyBV; end; setter F() = v: MyBV begin assert v.bitfield == '0'; end; func main () => integer begin let res = F().bitfield; assert res == '1'; F().bitfield = '0'; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/setter_subfield.asl000066400000000000000000000003401475314470400262400ustar00rootroot00000000000000type MyBV of bits(8) { [5] bitfield }; getter F() => MyBV begin return Zeros{8} as MyBV; end; setter F() = v: MyBV begin assert v[0] == '0'; end; func main () => integer begin F().bitfield = '0'; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/setter_subslice.asl000066400000000000000000000003371475314470400262620ustar00rootroot00000000000000type MyBV of bits(8) { [5] bitfield }; getter F () => MyBV begin return Zeros{8} as MyBV; end; setter F () = v: MyBV begin assert v[0] == '0'; end; func main () => integer begin F()[2+:1] = '1'; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/setter_without_getter.asl000066400000000000000000000004201475314470400275170ustar00rootroot00000000000000setter f(x: integer) = v: integer begin pass; end; getter f() => integer begin return 0; end; getter f(x: integer, y: integer) => integer begin return 0; end; getter f(x: boolean) => integer begin return 0; end; func main () => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/single-slice.asl000066400000000000000000000001461475314470400254370ustar00rootroot00000000000000func main () => integer begin constant A = Zeros{4}; let b = A[UInt('1')*2+:2]; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/slice-width-shorthand.asl000066400000000000000000000001441475314470400272630ustar00rootroot00000000000000func main() => integer begin assert (0x12345[:20] == 0x123456789_12345[0+:20]); return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/static.asl000066400000000000000000000013501475314470400243460ustar00rootroot00000000000000 constant C1 : integer = 3; constant C2 : integer = C1 + 2; constant C3 : integer = C4 * C2; constant C4 : integer = C1; constant C5 : integer = - C2; constant C6 : bits(4) = 15[3:0]; constant C7 : bits(4) = 0xC[3:0]; constant C8 : integer = if C2 == C3 then 42 else 57; constant C9 : boolean = C7 + 3 == C6; constant C10 : integer = if !C9 then C1 else C5; func main() => integer begin assert C1 == 3; assert C2 == 5; assert C3 == 15; assert C4 == 3; assert C5 == -5; assert C6 == '1111'; assert C7 == '1100'; assert C8 == 57; assert C9; assert C10 == -5; return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set +syntax:aslv1_colon_colon' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/stdlib.asl000066400000000000000000000146161475314470400243510ustar00rootroot00000000000000func test_uint {N} (bv: bits(N)) begin for i = 0 to 1 << N do assert UInt (i[N:0]) == i; end; end; func test_sint {N} (bv: bits(N)) begin for i = 0 to 1 << N - 1 do assert SInt (i[N:0]) == i; assert SInt ('1' :: i[N-1:0]) == i - 1 << N; end; end; func check_pow2 (n: integer) begin if n <= 1 then // For n <= 1, we can't test 'around' 2^n assert IsPow2(0) == FALSE; assert CeilPow2(0) == 1; // No FloorPow2 for 0 assert IsPow2(1) == TRUE; assert CeilPow2(1) == 1; assert FloorPow2(1) == 1; assert IsPow2(2) == TRUE; assert CeilPow2(2) == 2; assert FloorPow2(2) == 2; assert IsPow2(3) == FALSE; assert CeilPow2(3) == 4; assert FloorPow2(3) == 2; return; end; let p = 2 ^ n; assert FloorPow2(p-1) == p DIVRM 2; assert CeilPow2(p-1) == p; assert IsPow2(p-1) == FALSE; assert FloorPow2(p) == p; assert CeilPow2(p) == p; assert IsPow2(p) == TRUE; assert FloorPow2(p+1) == p; assert CeilPow2(p+1) == 2 * p; assert IsPow2(p+1) == FALSE; end; // Extra main func main() => integer begin assert Abs (-1) == 1; assert Abs (2) == 2; assert Min (2, 3) == 2; assert Max (2, 3) == 3; assert Min (2.3, 3.3) == 2.3; assert Max (2.3, 3.3) == 3.3; assert IsEven (2); assert IsEven (0); assert IsEven (-2); assert !(IsEven (1)); assert !(IsEven (-1)); assert IsOdd (1); assert IsOdd (-1); assert Replicate{6}('01') == '010101'; assert Zeros{0} == ''; assert Zeros{3} == '000'; assert Zeros{8} == '00000000'; assert Ones{0} == ''; assert Ones{3} == '111'; assert Ones{8} == '11111111'; assert IsZero(Zeros{2}); assert IsOnes(Ones{3}); assert ! IsZero(Ones{3}); assert ! IsOnes(Zeros{3}); assert ! IsZero ('101'); assert SignExtend{5}('100') == '11100'; assert ZeroExtend{5}('100') == '00100'; assert Extend{5}('100', TRUE) == '00100'; assert Extend{5}('100', FALSE) == '11100'; assert Len('') == 0; assert Len('1010') == 4; assert UInt('110') == 6; assert UInt('') == 0; assert UInt('100000000') == 0x100; assert SInt('110') == -2; assert SInt('010') == 2; assert SInt('111') == -1; assert SInt('000') == 0; assert SInt('0') == 0; assert SInt('1') == -1; assert SInt('') == 0; test_uint{0}(Zeros{0}); test_uint{1}(Zeros{1}); test_uint{2}(Zeros{2}); test_uint{3}(Zeros{3}); test_sint{0}(Zeros{0}); test_sint{1}(Zeros{1}); test_sint{2}(Zeros{2}); test_sint{3}(Zeros{3}); for n = 0 to 25 do assert Log2(2 ^ n) == n; end; assert ((1 << 1) == 2); assert ((1 << 0) == 1); assert (((-1) << 0) == -1); assert (((-1) << 1) == -2); for m = -100 to 100 do let q = Real (m); assert RoundUp (q) == m; assert RoundDown (q) == m; assert RoundTowardsZero (q) == m; end; for m = -100 to 100 do let q = Real (m) / 3.0; assert RoundDown (q) == m DIVRM 3; end; for a = -100 to 100 do for b = 1 to 5 do assert a MOD b + (a DIVRM b) * b == a; assert (b * a) DIV b == a; if a MOD b == 0 then assert b * (a DIV b) == a; end; end; end; for i = 1 to 100 do let x = Real(i); let expected_res = SqrtRounded(x, 1000); for p = 1 to 10 do let res = SqrtRounded(x, p); assert Abs(res - expected_res) / expected_res < 2.0 ^ (-p); end; end; let b_000 = BitCount ('000'); assert b_000 == 0; let b_101 = BitCount ('101'); assert b_101 == 2; let b_010 = BitCount ('010'); assert b_010 == 1; let b_ = BitCount (''); assert b_ == 0; let lowestsetbit_000 = LowestSetBit ('000'); assert lowestsetbit_000 == 3; let lowestsetbit_101 = LowestSetBit ('101'); assert lowestsetbit_101 == 0; let lowestsetbit_010 = LowestSetBit ('010'); assert lowestsetbit_010 == 1; let lowestsetbit_ = LowestSetBit (''); assert lowestsetbit_ == 0; let highestsetbit_000 = HighestSetBit ('000'); assert highestsetbit_000 == -1; let highestsetbit_101 = HighestSetBit ('101'); assert highestsetbit_101 == 2; let highestsetbit_010 = HighestSetBit ('010'); assert highestsetbit_010 == 1; let highestsetbit_ = HighestSetBit (''); assert highestsetbit_ == -1; for i = 1 to 1000 do let x = Real (i) / 100.0; assert (Abs(ILog2(x) + ILog2(1.0 / x)) < 2); end; for i = -10 to 10 do let x = 3.0 ^ i; let lgx = ILog2(x); assert (Abs(lgx + ILog2(1.0 / x)) < 2); if i >= 0 then assert Log2(3 ^ (i as integer)) == lgx; end; end; for i = 10 to 1000 do assert Log2(i DIVRM 10) == ILog2 (Real (i) / 10.0); end; for n = 0 to 10 do check_pow2(n); check_pow2(19*n+1); end; assert AlignDownP2('110111', 1) == '110110'; assert AlignDownP2('110111', 2) == '110100'; assert AlignDownP2('110111', 3) == '110000'; assert AlignDownP2('110111', 4) == '110000'; assert AlignDownP2('110111', 5) == '100000'; assert AlignDownP2('110111', 6) == '000000'; assert AlignDownP2('001000', 1) == '001000'; assert AlignDownP2('001000', 2) == '001000'; assert AlignDownP2('001000', 3) == '001000'; assert AlignDownP2('001000', 4) == '000000'; assert AlignDownP2('001000', 5) == '000000'; assert AlignDownP2('001000', 6) == '000000'; assert AlignUpP2('110111', 1) == '111000'; assert AlignUpP2('110111', 2) == '111000'; assert AlignUpP2('110111', 3) == '111000'; assert AlignUpP2('110111', 4) == '000000'; assert AlignUpP2('110111', 5) == '000000'; assert AlignUpP2('110111', 6) == '000000'; assert AlignUpP2('001000', 1) == '001000'; assert AlignUpP2('001000', 2) == '001000'; assert AlignUpP2('001000', 3) == '001000'; assert AlignUpP2('001000', 4) == '010000'; assert AlignUpP2('001000', 5) == '100000'; assert AlignUpP2('001000', 6) == '000000'; for N = 0 to 5 do let pN = 2 ^ N; for x = -pN to pN do for y = 0 to N do let bv = x[0+:N]; let p = 2^y as integer {1..2^N}; assert AlignUpP2(bv, y) == AlignUpP2(x, y)[0+:N]; assert AlignDownP2(bv, y) == AlignDownP2(x, y)[0+:N]; assert AlignUpP2(x, y) IN {x..x+p}; assert AlignDownP2(x, y) IN {(x - p)..x}; assert AlignUpSize(x, p) == AlignUpP2(x, y); assert AlignDownSize(x, p) == AlignDownP2(x, y); assert AlignUpSize(bv, p) == AlignUpP2(bv, y); assert AlignDownSize(bv, p) == AlignDownP2(bv, y); end; end; end; return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set +syntax:aslv1_colon_colon' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/subtype-satisfaction-arrray-illegal.asl000066400000000000000000000003131475314470400321420ustar00rootroot00000000000000type l of bits(64) { [1] x, [2] y, [3] z }; type m of array[[10]] of l; type n of bits(64) { [1] x, [2] y, [3] z }; type o of array[[10]] of n subtypes m; func main () => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/subtypes-example.asl000066400000000000000000000042431475314470400263720ustar00rootroot00000000000000// Declare some named types type superInt of integer; type subInt of integer subtypes superInt ; type uniqueInt of superInt; func assign() begin // Integer is subtype-satisfied by all the named types, // so it can be assigned to them by the assignment and // initialization type checking rules var myInt: integer; var mySuperInt : superInt = myInt; var mySubInt : subInt = myInt; var myUniqueInt: uniqueInt = myInt; // Integer is subtype-satisfied by all the named types, // so it can be assigned from them by the assignment and // initialization type checking rules myInt = mySuperInt; myInt = mySubInt; myInt = myUniqueInt; // superInt is not a subtype of anything (apart from itself) // so it cannot be assigned to any other named type // Illegal: mySubInt = mySuperInt; // Illegal: myUniqueInt = mySuperInt; // subInt is a subtype of superInt, so the assignment and // initialization type checking rules permit the following: mySuperInt = mySubInt; // But subInt and uniqueInt are not subtype related // so do not type-satisfy each other. // Illegal: myUniqueInt = mySubInt; // uniqueInt has no related subtype or supertype // so it cannot be assigned to any named type // Illegal: mySuperInt = myUniqueInt; // Illegal: mySubInt = myUniqueInt; end; type aNumberOfThings of integer; type ShapeSides of aNumberOfThings; type AnimalLegs of aNumberOfThings; type InsectLegs of integer subtypes AnimalLegs ; func subtyping() begin var myCircleSides: ShapeSides = 1; // legal var myInt : integer = myCircleSides; // legal // var dogLegs : AnimalLegs = myCircleSides; // illegal: unrelated types var centipedeLegs: InsectLegs = 100; // legal var animalLegs : AnimalLegs = centipedeLegs; // legal // var insectLegs : InsectLegs = animalLegs; // illegal: subtype is wrong way end; func main () => integer begin assign (); subtyping (); return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set +syntax:aslv1_colon_colon' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/subtypes-with.asl000066400000000000000000000005661475314470400257160ustar00rootroot00000000000000type rec1 of record { a: integer, b: integer, }; type rec2 subtypes rec1 with { c: integer, }; type rec2bis subtypes rec1 with { c: integer, }; func main() => integer begin let a = rec2 { a = 1, b = 2, c = 3 }; assert a.c == 3; var b = rec2bis { a = 1, b = 2, c = 4 }; b.c = b.c + 1; assert b.c == 5; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/tuple_items.asl000066400000000000000000000001601475314470400254070ustar00rootroot00000000000000func main () => integer begin let x = (2, 3); assert x.item0 == 2; assert x.item1 == 3; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/tuples.asl000066400000000000000000000012721475314470400243760ustar00rootroot00000000000000 func f() => (integer, integer, integer) begin return (3, 4, 5); end; func multiple_return_values () begin let (a, b, c) = f(); assert a == 3; assert b == 4; assert c == 5; end; func other_tuple_usages () begin let t = f(); let (a, b, c) = t; assert a == 3; assert b == 4; assert c == 5; end; func with_var () begin var a, b, c: integer; (a, b, c) = f(); assert a == 3; assert b == 4; assert c == 5; end; func main() => integer begin multiple_return_values(); other_tuple_usages(); with_var (); return 0; end; // RUN: archex.sh --eval=':set asl=1.0' --eval=':set +syntax:aslv1_colon_colon' --eval=':load %s' --eval='assert main() == 0;' | FileCheck %s herd-herdtools7-1ca343e/asllib/tests/regressions.t/type_satisfaction_illegal_f3.asl000066400000000000000000000002431475314470400306700ustar00rootroot00000000000000func invoke_me(N: integer { 8, 16}) begin return; end; func illegal_f3() begin var x: integer; invoke_me(x); // illegal as domains doesn't match end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/type_satisfaction_illegal_f4.asl000066400000000000000000000002131475314470400306660ustar00rootroot00000000000000func invoke_me(N: integer { 8, 16}) begin return; end; func illegal_f4() begin var x: integer { 8 .. 64 }; invoke_me(x); end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/typed-arg-as-param-call.asl000066400000000000000000000002021475314470400273560ustar00rootroot00000000000000func test{N: integer{5..10}}(a: bits(N)) begin pass; end; func main() => integer begin test{2}('11'); return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/typed-param-call.asl000066400000000000000000000002021475314470400262060ustar00rootroot00000000000000func test{N: integer{5..10}}(a: bits(N)) begin pass; end; func main() => integer begin test{2}('11'); return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/typing-assign-v0.asl000066400000000000000000000001711475314470400261760ustar00rootroot00000000000000bits(N+N) Dup(bits(N) b) return b : b; integer main() x = 2; b = Dup(Ones(x)); assert b == '1111'; return 0; herd-herdtools7-1ca343e/asllib/tests/regressions.t/undeclared-variable.asl000066400000000000000000000001101475314470400267410ustar00rootroot00000000000000func main () => integer begin bar = (32 - 46) * 0; return bar; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/under-constrained-used.asl000066400000000000000000000002711475314470400274420ustar00rootroot00000000000000func foo {N} (x: bits(N)) => integer {0..2*N} begin return N as integer {0..2*N}; end; func main () => integer begin let res = foo{3} ('100'); assert res == 3; return 0; end; herd-herdtools7-1ca343e/asllib/tests/regressions.t/unreachable.asl000066400000000000000000000001011475314470400253210ustar00rootroot00000000000000func main () => integer begin Unreachable (); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/000077500000000000000000000000001475314470400223555ustar00rootroot00000000000000herd-herdtools7-1ca343e/asllib/tests/side-effects.t/assert-atc.asl000066400000000000000000000001201475314470400251150ustar00rootroot00000000000000func main () => integer begin assert 0 as integer {3} == 2; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/assert-read.asl000066400000000000000000000001261475314470400252670ustar00rootroot00000000000000var X: integer = 0; func main () => integer begin assert X == 0; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/assert-throw.asl000066400000000000000000000002341475314470400255170ustar00rootroot00000000000000type E of exception {}; func throwing () => integer begin throw E {}; end; func main () => integer begin assert throwing () == 0; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/assert-unknown.asl000066400000000000000000000002341475314470400260530ustar00rootroot00000000000000func unknown () => integer {0, 1} begin return ARBITRARY: integer {0, 1}; end; func main () => integer begin assert unknown () == 0; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/assert-write.asl000066400000000000000000000002551475314470400255110ustar00rootroot00000000000000var X: integer = 0; func write_X () => integer begin let x = X; X = x + 1; return x; end; func main () => integer begin assert write_X () == 0; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/binop-read-read.asl000066400000000000000000000001261475314470400260060ustar00rootroot00000000000000var X: integer = 0; func main () => integer begin let x = X + X; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/binop-read-write-diff.asl000066400000000000000000000003021475314470400271270ustar00rootroot00000000000000var X: integer = 0; var Y: integer = 0; func set_and_return_X () => integer begin X = 2; return 3; end; func main () => integer begin let y = set_and_return_X () + Y; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/binop-read-write.asl000066400000000000000000000002521475314470400262250ustar00rootroot00000000000000var X: integer = 0; func set_and_return () => integer begin X = 2; return 3; end; func main () => integer begin let y = set_and_return () + X; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/binop-throw-atc.asl000066400000000000000000000004531475314470400260750ustar00rootroot00000000000000type E of exception {}; func throwing () => integer begin throw E {}; end; func performs_atc () => integer begin return (1 as integer {2}); end; func main () => integer begin try let y = throwing () + performs_atc (); catch when E => print ("E caught"); end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/binop-throw-caught.asl000066400000000000000000000005141475314470400265770ustar00rootroot00000000000000type E of exception {}; func throws_E () => integer begin throw E {}; end; func caught_E () => integer begin try return throws_E (); catch when E => return 0; end; end; func main () => integer begin try let x = throws_E () + caught_E (); catch when E => print ("E caught"); end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/binop-throw-not-caught.asl000066400000000000000000000006061475314470400273770ustar00rootroot00000000000000type E of exception {}; type F of exception {}; func throws_E () => integer begin throw E {}; end; func caught_F () => integer begin try return throws_E (); catch when F => return 0; end; end; func main () => integer begin try let x = throws_E () + caught_F (); catch when E => print ("E caught"); when F => print ("F caught"); end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/binop-throw-otherwised.asl000066400000000000000000000006421475314470400275030ustar00rootroot00000000000000type E of exception {}; type F of exception {}; func throws_E () => integer begin throw E {}; end; func caught_F () => integer begin try return throws_E (); catch when F => return 0; otherwise => return 1; end; end; func main () => integer begin try let x = throws_E () + caught_F (); catch when E => print ("E caught"); when F => print ("F caught"); end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/binop-throw-read.asl000066400000000000000000000003471475314470400262430ustar00rootroot00000000000000type E of exception {}; var X: integer = 0; func throwing () => integer begin throw E {}; end; func main () => integer begin try let y = throwing () + X; catch when E => print ("E caught"); end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/binop-throw-throw.asl000066400000000000000000000003361475314470400264710ustar00rootroot00000000000000type E of exception {}; func throwing () => integer begin throw E {}; end; func main () => integer begin try let y = throwing () + throwing (); catch when E => print ("E caught"); end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/binop-throw-unknown.asl000066400000000000000000000003541475314470400270250ustar00rootroot00000000000000type E of exception {}; func throws_E () => integer begin throw E {}; end; func main () => integer begin try let x = throws_E () + ARBITRARY: integer {0..3}; catch when E => print ("Caught E."); end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/binop-throw-write.asl000066400000000000000000000004731475314470400264620ustar00rootroot00000000000000type E of exception {}; var X: integer = 0; func throwing () => integer begin throw E {}; end; func set_and_return () => integer begin X = 3; return 2; end; func main () => integer begin try let y = throwing () + set_and_return (); catch when E => print ("E caught"); end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/binop-unknown-unknown.asl000066400000000000000000000001611475314470400273550ustar00rootroot00000000000000func main () => integer begin let x = ARBITRARY: integer {0..3} + ARBITRARY: integer {0..3}; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/binop-write-atc.asl000066400000000000000000000002561475314470400260650ustar00rootroot00000000000000var X: integer = 0; func performs_atc () => integer begin return (1 as integer {2}); end; func main () => integer begin let y = performs_atc () + X; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/binop-write-unknown.asl000066400000000000000000000003011475314470400270040ustar00rootroot00000000000000var X: integer = 0; func set_and_return () => integer begin X = 4; return 3; end; func main () => integer begin let x = set_and_return () + ARBITRARY: integer {0..3}; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/binop-write-write-diff.asl000066400000000000000000000004311475314470400273510ustar00rootroot00000000000000var X: integer = 0; var Y: integer = 0; func set_and_return_X () => integer begin X = 2; return 3; end; func set_and_return_Y () => integer begin Y = 2; return 3; end; func main () => integer begin let y = set_and_return_X () + set_and_return_Y (); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/binop-write-write.asl000066400000000000000000000002711475314470400264450ustar00rootroot00000000000000var X: integer = 0; func set_and_return () => integer begin X = 2; return 3; end; func main () => integer begin let y = set_and_return () + set_and_return (); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/bool-binop-write-write.asl000066400000000000000000000006151475314470400274000ustar00rootroot00000000000000var X: integer = 0; func foo (x : integer) => boolean begin if X == x then return FALSE; else X = x; return TRUE; end; end; func main () => integer begin X = 2; if foo (2) && foo (3) then println("Impossible"); end; if foo (2) || foo (3) then println("Should print."); end; if foo (2) --> foo (3) then println ("Should print."); end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/config-uses-atc.asl000066400000000000000000000002261475314470400260450ustar00rootroot00000000000000func foo () => integer begin return 0 as integer {10}; end; config Y = foo (); func main () => integer begin assert (Y == 0); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/config-uses-config-through-func.asl000066400000000000000000000002361475314470400311530ustar00rootroot00000000000000config X: integer = 0; func foo () => integer begin return X; end; config Y = foo (); func main () => integer begin assert (Y == 0); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/config-uses-config.asl000066400000000000000000000001511475314470400265400ustar00rootroot00000000000000config X: integer = 0; config Y = X; func main () => integer begin assert (Y == 0); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/config-uses-constant-through-func.asl000066400000000000000000000002401475314470400315320ustar00rootroot00000000000000constant X: integer = 0; func foo () => integer begin return X; end; config Y = foo (); func main () => integer begin assert (Y == 0); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/config-uses-constant.asl000066400000000000000000000001531475314470400271260ustar00rootroot00000000000000constant X: integer = 0; config Y = X; func main () => integer begin assert (Y == 0); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/config-uses-let-through-func.asl000066400000000000000000000002331475314470400304670ustar00rootroot00000000000000let X: integer = 0; func foo () => integer begin return X; end; config Y = foo (); func main () => integer begin assert (Y == 0); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/config-uses-let.asl000066400000000000000000000001461475314470400260630ustar00rootroot00000000000000let X: integer = 0; config Y = X; func main () => integer begin assert (Y == 0); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/config-uses-local-constant.asl000066400000000000000000000002421475314470400302150ustar00rootroot00000000000000func foo () => integer begin constant x: integer = 0; return x; end; config Y = foo (); func main () => integer begin assert (Y == 0); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/config-uses-local-let.asl000066400000000000000000000002351475314470400271520ustar00rootroot00000000000000func foo () => integer begin let x: integer = 0; return x; end; config Y = foo (); func main () => integer begin assert (Y == 0); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/config-uses-local-var.asl000066400000000000000000000002351475314470400271560ustar00rootroot00000000000000func foo () => integer begin var x: integer = 0; return x; end; config Y = foo (); func main () => integer begin assert (Y == 0); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/config-uses-unknown.asl000066400000000000000000000002361475314470400267760ustar00rootroot00000000000000func foo () => integer begin return ARBITRARY: integer {0..10}; end; config Y = foo (); func main () => integer begin assert Y <= 10; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/config-uses-var-through-func.asl000066400000000000000000000002331475314470400304730ustar00rootroot00000000000000var X: integer = 0; func foo () => integer begin return X; end; config Y = foo (); func main () => integer begin assert (Y == 0); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/config-uses-var.asl000066400000000000000000000001531475314470400260650ustar00rootroot00000000000000var X: integer = 0; config Y = X + 3; func main () => integer begin assert (Y == 3); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/constant-func-local-type-global-let.asl000066400000000000000000000003461475314470400317320ustar00rootroot00000000000000let K : integer {8, 16, 32} = 8; func foo(x: integer) => integer begin let k = x as integer {K}; assert k == x; return 2 * k; end; constant C = foo (8); func main () => integer begin assert C == 16; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/constant-func-local-type-local-let.asl000066400000000000000000000003511475314470400315600ustar00rootroot00000000000000func foo(x: integer) => integer begin let K : integer {8, 16, 32} = 8; let k = x as integer {K}; assert k == x; return 2 * k; end; constant C = foo (8); func main () => integer begin assert C == 16; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/constant-func-local-var.asl000066400000000000000000000003161475314470400275160ustar00rootroot00000000000000func foo (x: integer) => integer begin var result: integer = 3; result = result + x * x; return result; end; constant C = foo (4); func main () => integer begin assert C == 19; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/constant-func-read.asl000066400000000000000000000002711475314470400265510ustar00rootroot00000000000000var X: integer = 0; func foo (x: integer) => integer begin X = 3; return x * x + 3; end; constant C = foo (4); func main () => integer begin assert C == 19; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/constant-func-sig-let.asl000066400000000000000000000002711475314470400272020ustar00rootroot00000000000000let K : integer {8, 16, 32} = 8; func foo(x: integer {0..K}) => integer begin return x; end; constant C = foo(3); func main () => integer begin assert C == 3; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/constant-func-throw-caught.asl000066400000000000000000000003401475314470400302470ustar00rootroot00000000000000type E of exception {}; func foo (x: integer) => integer begin try throw E {}; catch when E => return 19; end; end; constant C = foo (4); func main () => integer begin assert C == 19; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/constant-func-throw.asl000066400000000000000000000002561475314470400270040ustar00rootroot00000000000000type E of exception {}; func foo (x: integer) => integer begin throw E {}; end; constant C = foo (4); func main () => integer begin assert C == 19; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/constant-func-unknown.asl000066400000000000000000000003041475314470400273320ustar00rootroot00000000000000func foo (x: integer) => integer begin let y = ARBITRARY: integer {0..3}; return x * x + 3 + y; end; constant C = foo (4); func main () => integer begin assert C == 19; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/constant-func-write.asl000066400000000000000000000002711475314470400267700ustar00rootroot00000000000000var X: integer = 0; func foo (x: integer) => integer begin X = 3; return x * x + 3; end; constant C = foo (4); func main () => integer begin assert C == 19; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/constant-func.asl000066400000000000000000000002321475314470400256350ustar00rootroot00000000000000func foo (x: integer) => integer begin return x * x + 3; end; constant C = foo (4); func main () => integer begin assert C == 19; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/constant-rec.asl000066400000000000000000000005311475314470400254550ustar00rootroot00000000000000func foo (n: integer) => integer begin if n <= 0 then return 1; else return bar (n); end; end; func bar (n: integer) => integer begin constant r = foo (1); return n * r * foo (n); end; constant C = foo (4); constant D: integer = bar (5); func main () => integer begin assert C == 24; assert D == 120; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/for-read-write-global.asl000066400000000000000000000003541475314470400271450ustar00rootroot00000000000000var X: integer = 0; func read_X () => integer begin let x = X; return x; end; func main () => integer begin var x: integer = 10; var y: integer = 0; for i = 0 to read_X () do X = y * y + x ; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/for-read.asl000066400000000000000000000003571475314470400245620ustar00rootroot00000000000000var X: integer = 0; func read_X () => integer begin let x = X; return x; end; func main () => integer begin var x: integer = 10; var y: integer = 0; for i = 0 to read_X () do let - = y * y + x ; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/for-throw-throw.asl000066400000000000000000000003651475314470400261520ustar00rootroot00000000000000type E of exception {}; func throwing () => integer begin throw E {}; end; func main () => integer begin var x: integer = 10; var y: integer = 0; for i = 0 to throwing () do let - = y * y + throwing () ; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/for-throw.asl000066400000000000000000000003531475314470400250060ustar00rootroot00000000000000type E of exception {}; func throwing () => integer begin throw E {}; end; func main () => integer begin var x: integer = 10; var y: integer = 0; for i = 0 to throwing () do let - = y * y + x ; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/for-unknown.asl000066400000000000000000000002631475314470400253420ustar00rootroot00000000000000func unknown () => integer {0..10} begin return ARBITRARY: integer {0..10}; end; func main () => integer begin for i = 0 to unknown () do pass; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/for-var-edits.asl000066400000000000000000000002151475314470400255360ustar00rootroot00000000000000func main () => integer begin var x: integer = 10; var y: integer = 0; for i = 0 to x do x = y * y + x; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/for-var-no-edit.asl000066400000000000000000000002141475314470400257640ustar00rootroot00000000000000func main () => integer begin var x: integer = 10; var y: integer = 0; for i = 0 to x do y = y * y + x; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/for-write-throw.asl000066400000000000000000000003471475314470400261410ustar00rootroot00000000000000type E of exception {}; func throwing () => integer begin throw E {}; end; func main () => integer begin var x: integer = 10; var y: integer = 0; for i = 0 to throwing () do y = y * y + x; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/for-write.asl000066400000000000000000000003751475314470400250010ustar00rootroot00000000000000var X: integer = 0; func write_X () => integer begin let x = X; X = x + 1; return x; end; func main () => integer begin var x: integer = 10; var y: integer = 0; for i = 0 to write_X () do let - = y * y + x ; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/global-throw-initialisation.asl000066400000000000000000000002551475314470400304770ustar00rootroot00000000000000type E of exception {}; func throwing () => integer begin throw E {}; end; let X: integer = throwing (); func main () => integer begin println (X); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/global-var-initialisation.asl000066400000000000000000000007351475314470400301270ustar00rootroot00000000000000var X: integer = 0; func incr_X () => integer begin let x = X; X = x + 1; return x; end; let Y0: integer = incr_X (); let Y1: integer = incr_X (); let Y2: integer = incr_X (); // Notice that Y4 and Y3 are inverted let Y4: integer = incr_X (); let Y3: integer = incr_X (); func main () => integer begin println ("X = ", X); println ("Y0 = ", Y0); println ("Y1 = ", Y1); println ("Y2 = ", Y2); println ("Y3 = ", Y3); println ("Y4 = ", Y4); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/print-var.asl000066400000000000000000000003261475314470400250010ustar00rootroot00000000000000var X: integer = 0; func incr_X () => integer begin let x = X; X = x + 1; return x; end; func main () => integer begin println (incr_X ()); println (incr_X ()); println (incr_X ()); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/rec-assert-throw.asl000066400000000000000000000005301475314470400262650ustar00rootroot00000000000000type E of exception {}; func throwing (n: integer, b: boolean) => integer begin if b then throw E {}; else return foo (n); end; end; func foo (n: integer) => integer begin if n <= 0 then return 0; end; assert throwing (n - 1, FALSE) == 3; return 3; end; func main () => integer begin let x = foo (4); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/rec-assert.asl000066400000000000000000000004361475314470400251310ustar00rootroot00000000000000func not_throwing (n: integer) => integer begin return foo (n); end; func foo (n: integer) => integer begin if n <= 0 then return 0; end; let x = not_throwing (n - 1) * (2 as integer {3}); return 2 * x; end; func main () => integer begin let x = foo (4); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/rec-binop-atc-throw.asl000066400000000000000000000005561475314470400266500ustar00rootroot00000000000000type E of exception {}; func throwing (n: integer, b: boolean) => integer begin if b then throw E {}; else return foo (n); end; end; func foo (n: integer) => integer begin if n <= 0 then return 0; end; let x = throwing (n - 1, FALSE) * (2 as integer {3}); return 2 * x; end; func main () => integer begin let x = foo (4); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/rec-binop-atc.asl000066400000000000000000000004371475314470400255050ustar00rootroot00000000000000func not_throwing (n: integer) => integer begin return foo (n); end; func foo (n: integer) => integer begin if n <= 0 then return 0; end; let x = not_throwing (n - 1) * (2 as integer {3}); return 2 * x; end; func main () => integer begin let x = foo (4); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/rec-binop-read-local.asl000066400000000000000000000004661475314470400267430ustar00rootroot00000000000000func not_throwing (n: integer) => integer begin return foo (n); end; func foo (n: integer) => integer recurselimit 1000 begin if n <= 0 then return 0; end; var y: integer = 1; let x = not_throwing (n - 1) * y; return 2 * x; end; func main () => integer begin let x = foo (4); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/rec-binop-read-throw.asl000066400000000000000000000006671475314470400270170ustar00rootroot00000000000000type E of exception {}; var X: integer = 0; func throwing (n: integer, b: boolean) => integer begin if b then throw E {}; else return foo (n); end; end; func read_X () => integer begin let x = X; return x; end; func foo (n: integer) => integer begin if n <= 0 then return 0; end; let x = throwing (n - 1, FALSE) * read_X (); return 2 * x; end; func main () => integer begin let x = foo (4); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/rec-binop-read-write.asl000066400000000000000000000005511475314470400267760ustar00rootroot00000000000000var X: integer = 2; func not_throwing (n: integer) => integer begin return foo (n); end; func read_X () => integer begin let x = X; return x; end; func foo (n: integer) => integer begin if n <= 0 then return 1; end; let x = not_throwing (n - 1) * read_X (); return 2 * x; end; func main () => integer begin let x = foo (4); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/rec-binop-read.asl000066400000000000000000000005521475314470400256470ustar00rootroot00000000000000var X: integer = 0; func not_throwing (n: integer) => integer begin return foo (n); end; func read_X () => integer begin let x = X; return x; end; func foo (n: integer) => integer begin if n <= 0 then return 0; end; let x = not_throwing (n - 1) * read_X (); return 2 * x; end; func main () => integer begin let x = foo (4); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/rec-binop-rec.asl000066400000000000000000000004061475314470400255030ustar00rootroot00000000000000func bar (n: integer) => integer begin return foo (n); end; func foo (n: integer) => integer begin if n <= 0 then return 1; end; let x = bar (n - 1) * bar (n - 2); return 2 * x; end; func main () => integer begin let x = foo (4); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/rec-binop-unknown.asl000066400000000000000000000004611475314470400264320ustar00rootroot00000000000000func not_throwing (n: integer) => integer begin return foo (n); end; func foo (n: integer) => integer recurselimit 1000 begin if n <= 0 then return 0; end; let x = not_throwing (n - 1) * (ARBITRARY: integer); return 2 * x; end; func main () => integer begin let x = foo (4); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/rec-binop-write-throw.asl000066400000000000000000000007061475314470400272300ustar00rootroot00000000000000type E of exception {}; var X: integer = 0; func throwing (n: integer, b: boolean) => integer begin if b then throw E {}; else return foo (n); end; end; func write_X () => integer begin let x = X; X = x + 1; return x; end; func foo (n: integer) => integer begin if n <= 0 then return 0; end; let x = throwing (n - 1, FALSE) * write_X (); return 2 * x; end; func main () => integer begin let x = foo (4); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/rec-binop-write.asl000066400000000000000000000005701475314470400260660ustar00rootroot00000000000000var X: integer = 0; func not_throwing (n: integer) => integer begin return foo (n); end; func write_X () => integer begin let x = X; X = x + 1; return x; end; func foo (n: integer) => integer begin if n <= 0 then return 0; end; let x = not_throwing (n - 1) * write_X (); return 2 * x; end; func main () => integer begin let x = foo (4); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/rec-constant.asl000066400000000000000000000005221475314470400254550ustar00rootroot00000000000000func foo (n: integer) => integer begin if n <= 0 then return 1; else return bar (n); end; end; func bar (n: integer) => integer recurselimit 1000 begin return n * foo (n - 1); end; constant C = foo (4); constant D: integer = bar (5); func main () => integer begin assert C == 24; assert D == 120; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/rec-local-type.asl000066400000000000000000000005451475314470400257020ustar00rootroot00000000000000func foo (n: integer) => integer begin if n <= 0 then return 1; else return bar (n); end; end; func bar (n: integer) => integer begin let r = Zeros{foo (0)}; return Len (r) * n * foo (n - 1); end; constant C = foo (4); constant D: integer = bar (5); func main () => integer begin assert C == 24; assert D == 120; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/repeat-var-edits.asl000066400000000000000000000002351475314470400262320ustar00rootroot00000000000000func main () => integer begin var x: integer = 10; var y: integer = 10; repeat x = y * y + x; until (x > y) looplimit 100; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/run.t000066400000000000000000000307301475314470400233510ustar00rootroot00000000000000 $ aslref binop-read-read.asl $ aslref binop-read-write.asl File binop-read-write.asl, line 11, characters 10 to 31: ASL Typing error: conflicting side effects WritesGlobal "X" and ReadsGlobal "X" [1] $ aslref binop-write-write.asl File binop-write-write.asl, line 11, characters 10 to 47: ASL Typing error: conflicting side effects WritesGlobal "X" and WritesGlobal "X" [1] $ aslref binop-read-write-diff.asl $ aslref binop-write-write-diff.asl $ aslref bool-binop-write-write.asl Should print. Should print. $ aslref binop-throw-read.asl E caught $ aslref binop-throw-write.asl File binop-throw-write.asl, line 18, characters 12 to 43: ASL Typing error: conflicting side effects ThrowsException "E" and WritesGlobal "X" [1] $ aslref binop-throw-throw.asl File binop-throw-throw.asl, line 11, characters 12 to 37: ASL Typing error: conflicting side effects ThrowsException "E" and ThrowsException "E" [1] $ aslref binop-throw-caught.asl E caught $ aslref binop-throw-not-caught.asl File binop-throw-not-caught.asl, line 21, characters 12 to 37: ASL Typing error: conflicting side effects ThrowsException "E" and ThrowsException "E" [1] $ aslref binop-throw-otherwised.asl E caught $ aslref binop-throw-unknown.asl Caught E. $ aslref binop-write-unknown.asl $ aslref binop-unknown-unknown.asl $ aslref binop-throw-atc.asl File binop-throw-atc.asl, line 16, characters 12 to 41: ASL Typing error: conflicting side effects ThrowsException "E" and PerformsAssertions [1] $ aslref binop-write-atc.asl File binop-write-atc.asl, line 5, characters 10 to 11: ASL Execution error: Mismatch type: value 1 does not belong to type integer {2}. [1] // We don't need to decide about the following: // $ aslref binop-atc-atc.asl $ aslref constant-func.asl $ aslref constant-func-read.asl File constant-func-read.asl, line 9, characters 0 to 21: ASL Typing error: expected constant-time expression, got foo(4), which produces the following side-effects: [WritesGlobal "X"]. [1] $ aslref constant-func-write.asl File constant-func-write.asl, line 9, characters 0 to 21: ASL Typing error: expected constant-time expression, got foo(4), which produces the following side-effects: [WritesGlobal "X"]. [1] $ aslref constant-func-unknown.asl File constant-func-unknown.asl, line 7, characters 0 to 21: ASL Typing error: expected constant-time expression, got foo(4), which produces the following side-effects: [NonDeterministic]. [1] $ aslref constant-func-throw.asl File constant-func-throw.asl, line 8, characters 0 to 21: ASL Typing error: expected constant-time expression, got foo(4), which produces the following side-effects: [ThrowsException "E"]. [1] $ aslref constant-func-throw-caught.asl $ aslref constant-func-local-var.asl $ aslref constant-func-local-type-global-let.asl File constant-func-local-type-global-let.asl, line 12, characters 0 to 21: ASL Typing error: expected constant-time expression, got foo(8), which produces the following side-effects: [ReadsGlobal "K", PerformsAssertions]. [1] $ aslref constant-func-local-type-local-let.asl $ aslref constant-func-sig-let.asl File constant-func-sig-let.asl, line 8, characters 0 to 20: ASL Typing error: expected constant-time expression, got foo(3), which produces the following side-effects: [ReadsGlobal "K"]. [1] $ aslref for-var-no-edit.asl $ aslref for-var-edits.asl File for-var-edits.asl, line 6, character 2 to line 8, character 6: ASL Typing error: conflicting side effects ReadsLocal "x" and WritesLocal "x" [1] $ aslref for-read-write-global.asl File for-read-write-global.asl, line 14, character 2 to line 16, character 6: ASL Typing error: conflicting side effects ReadsGlobal "X" and WritesGlobal "X" [1] $ aslref while-var-edits.asl $ aslref repeat-var-edits.asl $ aslref for-read.asl $ aslref for-write.asl File for-write.asl, line 15, characters 15 to 25: ASL Typing error: a pure expression was expected, found write_X(), which produces the following side-effects: [WritesGlobal "X", ReadsGlobal "X"]. [1] $ aslref for-write-throw.asl File for-write-throw.asl, line 13, characters 15 to 26: ASL Typing error: a pure expression was expected, found throwing(), which produces the following side-effects: [ThrowsException "E"]. [1] $ aslref for-throw-throw.asl File for-throw-throw.asl, line 13, characters 15 to 26: ASL Typing error: a pure expression was expected, found throwing(), which produces the following side-effects: [ThrowsException "E"]. [1] $ aslref for-throw.asl File for-throw.asl, line 13, characters 15 to 26: ASL Typing error: a pure expression was expected, found throwing(), which produces the following side-effects: [ThrowsException "E"]. [1] $ aslref for-unknown.asl File for-unknown.asl, line 8, characters 15 to 25: ASL Typing error: a pure expression was expected, found unknown(), which produces the following side-effects: [NonDeterministic]. [1] $ aslref config-uses-var.asl File config-uses-var.asl, line 2, characters 0 to 17: ASL Typing error: expected config-time expression, got (X + 3), which produces the following side-effects: [ReadsGlobal "X"]. [1] $ aslref config-uses-config.asl $ aslref config-uses-let.asl File config-uses-let.asl, line 2, characters 0 to 13: ASL Typing error: expected config-time expression, got X, which produces the following side-effects: [ReadsGlobal "X"]. [1] $ aslref config-uses-constant.asl $ aslref config-uses-local-var.asl $ aslref config-uses-local-let.asl $ aslref config-uses-local-constant.asl $ aslref config-uses-var-through-func.asl File config-uses-var-through-func.asl, line 8, characters 0 to 18: ASL Typing error: expected config-time expression, got foo(), which produces the following side-effects: [ReadsGlobal "X"]. [1] $ aslref config-uses-config-through-func.asl $ aslref config-uses-let-through-func.asl File config-uses-let-through-func.asl, line 8, characters 0 to 18: ASL Typing error: expected config-time expression, got foo(), which produces the following side-effects: [ReadsGlobal "X"]. [1] $ aslref config-uses-constant-through-func.asl $ aslref config-uses-atc.asl File config-uses-atc.asl, line 3, characters 9 to 10: ASL Execution error: Mismatch type: value 0 does not belong to type integer {10}. [1] $ aslref config-uses-unknown.asl File config-uses-unknown.asl, line 6, characters 0 to 18: ASL Typing error: expected config-time expression, got foo(), which produces the following side-effects: [NonDeterministic]. [1] $ aslref assert-read.asl $ aslref assert-write.asl File assert-write.asl, line 12, characters 9 to 24: ASL Typing error: a pure expression was expected, found (write_X() == 0), which produces the following side-effects: [WritesGlobal "X", ReadsGlobal "X"]. [1] $ aslref assert-throw.asl File assert-throw.asl, line 10, characters 9 to 25: ASL Typing error: a pure expression was expected, found (throwing() == 0), which produces the following side-effects: [ThrowsException "E"]. [1] $ aslref assert-atc.asl File assert-atc.asl, line 3, characters 9 to 10: ASL Execution error: Mismatch type: value 0 does not belong to type integer {3}. [1] $ aslref type-read-config.asl $ aslref type-read-constant.asl $ aslref type-read-let.asl $ aslref type-read-local.asl File type-read-local.asl, line 5, characters 18 to 19: ASL Typing error: a pure expression was expected, found x, which produces the following side-effects: [ReadsLocal "x"]. [1] $ aslref type-read-local-let.asl $ aslref type-read.asl File type-read.asl, line 3, characters 19 to 20: ASL Typing error: a pure expression was expected, found X, which produces the following side-effects: [ReadsGlobal "X"]. [1] $ aslref type-write.asl File type-write.asl, line 10, characters 19 to 29: ASL Typing error: a pure expression was expected, found write_X(), which produces the following side-effects: [ReadsGlobal "X", WritesGlobal "X"]. [1] $ aslref type-unknown.asl File type-unknown.asl, line 8, characters 23 to 33: ASL Typing error: a pure expression was expected, found unknown(), which produces the following side-effects: [NonDeterministic]. [1] $ aslref type-func-atc.asl File type-func-atc.asl, line 3, characters 9 to 10: ASL Execution error: Mismatch type: value 0 does not belong to type integer {3}. [1] $ aslref type-func-local-var.asl $ aslref type-local-var.asl File type-local-var.asl, line 5, characters 15 to 16: ASL Typing error: a pure expression was expected, found x, which produces the following side-effects: [ReadsLocal "x"]. [1] $ aslref type-throw.asl File type-throw.asl, line 8, characters 19 to 30: ASL Typing error: a pure expression was expected, found throwing(), which produces the following side-effects: [ThrowsException "E"]. [1] $ aslref assert-atc.asl File assert-atc.asl, line 3, characters 9 to 10: ASL Execution error: Mismatch type: value 0 does not belong to type integer {3}. [1] $ aslref assert-read.asl $ aslref assert-throw.asl File assert-throw.asl, line 10, characters 9 to 25: ASL Typing error: a pure expression was expected, found (throwing() == 0), which produces the following side-effects: [ThrowsException "E"]. [1] $ aslref assert-write.asl File assert-write.asl, line 12, characters 9 to 24: ASL Typing error: a pure expression was expected, found (write_X() == 0), which produces the following side-effects: [WritesGlobal "X", ReadsGlobal "X"]. [1] $ aslref assert-unknown.asl $ aslref rec-assert-throw.asl File rec-assert-throw.asl, line 15, characters 9 to 37: ASL Typing error: a pure expression was expected, found (throwing((n - 1), FALSE) == 3), which produces the following side-effects: [CallsRecursive "throwing", ReadsLocal "n"]. [1] $ aslref rec-binop-atc-throw.asl File rec-binop-atc-throw.asl, line 15, characters 10 to 54: ASL Typing error: conflicting side effects CallsRecursive "throwing" and PerformsAssertions [1] $ aslref rec-binop-read-throw.asl File rec-binop-read-throw.asl, line 22, characters 10 to 45: ASL Typing error: conflicting side effects CallsRecursive "throwing" and ReadsGlobal "X" [1] $ aslref rec-binop-unknown.asl $ aslref rec-binop-read.asl File rec-binop-read.asl, line 17, characters 10 to 42: ASL Typing error: conflicting side effects CallsRecursive "not_throwing" and ReadsGlobal "X" [1] $ aslref rec-binop-read-local.asl $ aslref rec-binop-write.asl File rec-binop-write.asl, line 18, characters 10 to 43: ASL Typing error: conflicting side effects CallsRecursive "not_throwing" and WritesGlobal "X" [1] $ aslref rec-assert.asl File rec-assert.asl, line 9, characters 10 to 51: ASL Typing error: conflicting side effects CallsRecursive "not_throwing" and PerformsAssertions [1] $ aslref rec-binop-atc.asl File rec-binop-atc.asl, line 9, characters 10 to 51: ASL Typing error: conflicting side effects CallsRecursive "not_throwing" and PerformsAssertions [1] $ aslref rec-binop-read-write.asl File rec-binop-read-write.asl, line 17, characters 10 to 42: ASL Typing error: conflicting side effects CallsRecursive "not_throwing" and ReadsGlobal "X" [1] $ aslref rec-binop-write-throw.asl File rec-binop-write-throw.asl, line 23, characters 10 to 46: ASL Typing error: conflicting side effects CallsRecursive "throwing" and WritesGlobal "X" [1] $ aslref rec-constant.asl $ aslref constant-rec.asl File constant-rec.asl, line 12, characters 2 to 23: ASL Typing error: expected constant-time expression, got foo(1), which produces the following side-effects: [CallsRecursive "foo"]. [1] $ aslref rec-local-type.asl File rec-local-type.asl, line 12, characters 16 to 23: ASL Typing error: a pure expression was expected, found foo(0), which produces the following side-effects: [CallsRecursive "foo"]. [1] $ aslref rec-binop-rec.asl File rec-binop-rec.asl, line 9, characters 10 to 35: ASL Typing error: conflicting side effects CallsRecursive "bar" and CallsRecursive "bar" [1] $ aslref print-var.asl 0 1 2 $ aslref global-var-initialisation.asl X = 5 Y0 = 0 Y1 = 1 Y2 = 2 Y3 = 3 Y4 = 4 $ aslref global-throw-initialisation.asl File global-throw-initialisation.asl, line 8, characters 0 to 29: ASL Execution error: unexpected exception E thrown during the evaluation of the initialisation of the global storage element "X". [1] herd-herdtools7-1ca343e/asllib/tests/side-effects.t/type-func-atc.asl000066400000000000000000000001201475314470400255260ustar00rootroot00000000000000func main () => integer begin assert 0 as integer {3} == 2; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/type-func-local-var.asl000066400000000000000000000004241475314470400266460ustar00rootroot00000000000000func foo (x: integer {1..10}) => integer {0..10_000} begin var result: integer {0..10_000} = 79; result = result DIVRM x; return result; end; type T of bits (foo(4)); func main () => integer begin var x: T = Zeros{foo(4)}; assert Len(x) == 19; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/type-local-var.asl000066400000000000000000000001461475314470400257160ustar00rootroot00000000000000func main () => integer begin var x: integer {8, 16} = 8; var y: bits (x); return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/type-read-config.asl000066400000000000000000000001471475314470400262150ustar00rootroot00000000000000config X: integer {8, 32} = 8; type T of integer {X}; func main () => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/type-read-constant.asl000066400000000000000000000001531475314470400265760ustar00rootroot00000000000000constant X: integer {0..100} = 0; type T of integer {X}; func main () => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/type-read-let.asl000066400000000000000000000001441475314470400255310ustar00rootroot00000000000000let X: integer {8, 16} = 8; type T of integer {X}; func main () => integer begin return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/type-read-local-let.asl000066400000000000000000000001531475314470400266210ustar00rootroot00000000000000func main () => integer begin let x: integer {0..100} = 0; let -: integer {x} = 0; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/type-read-local.asl000066400000000000000000000001411475314470400260340ustar00rootroot00000000000000func main () => integer begin var x: integer = 0; let -: integer {x} = x; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/type-read.asl000066400000000000000000000000551475314470400247500ustar00rootroot00000000000000var X: integer = 0; type T of integer {X}; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/type-throw.asl000066400000000000000000000001611475314470400251760ustar00rootroot00000000000000type E of exception {}; func throwing () => integer begin throw E {}; end; type T of integer {throwing ()}; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/type-unknown.asl000066400000000000000000000003121475314470400255300ustar00rootroot00000000000000func unknown () => integer {0, 1} begin return ARBITRARY: integer {0, 1}; end; func main () => integer begin let x = 0 as integer{unknown ()}; let y: integer {unknown ()} = x; return 0; end; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/type-write.asl000066400000000000000000000002031475314470400251620ustar00rootroot00000000000000var X: integer = 0; func write_X () => integer begin let x = X; X = x + 1; return x; end; type T of integer {write_X ()}; herd-herdtools7-1ca343e/asllib/tests/side-effects.t/while-var-edits.asl000066400000000000000000000002341475314470400260610ustar00rootroot00000000000000func main () => integer begin var x: integer = 10; var y: integer = 10; while (x < y) looplimit 100 do x = y * y + x; end; return 0; end; herd-herdtools7-1ca343e/asllib/tests/static.ml000066400000000000000000000047141475314470400214010ustar00rootroot00000000000000open Asllib open AST open ASTUtils open! Helpers open Infix let _dbg = false let env_with_N = let open StaticEnv in add_local "N" integer LDK_Let empty let build_consts () = let values = [ ("c1", !$3); ("c2", !!(E_Slice (!%"c1", [ Slice_Range (!$3, !$0) ]))) ] in let consts = List.map (fun (name, e) -> D_GlobalStorage { name; keyword = GDK_Let; ty = None; initial_value = Some e } |> __POS_OF__ |> add_pos_from_pos_of) values in let main = D_Func { name = "main"; body = SB_ASL !!(S_Return (Some !$0)); args = []; recurse_limit = None; parameters = []; return_type = Some integer; subprogram_type = ST_Function; builtin = false; } |> __POS_OF__ |> add_pos_from_pos_of in let ast = main :: consts in let _ = Typing.type_and_run ast in () let normalize () = let do_one (e1, e2, env) = let e1' = StaticModel.normalize env e1 in let e2' = StaticModel.normalize env e2 in let () = if _dbg then Format.eprintf "%a ---> %a@." PP.pp_expr e1 PP.pp_expr e1' in let () = if _dbg then Format.eprintf "%a ---> %a@." PP.pp_expr e2 PP.pp_expr e2' in assert (StaticModel.equal_in_env env e1 e2) in List.iter do_one [ (binop MINUS !$4 !$2, !$2, StaticEnv.empty); ( binop PLUS (binop MINUS !%"N" !%"m") (binop MINUS !%"m" !$1), binop MINUS !%"N" !$1, StaticEnv.add_local "m" integer LDK_Let env_with_N ); (unop NEG !$3, !$(-3), StaticEnv.empty); ] let fpzero_example () = let ( -~ ) = binop MINUS and ( ==~ ) = binop EQ_OP and ( +~ ) = binop PLUS in let e = !!(E_Cond (!%"N" ==~ !$16, !$5, !!(E_Cond (!%"N" ==~ !$32, !$8, !$11)))) in let f = !%"N" -~ e -~ !$1 in let res = !$1 +~ e +~ f in let env = env_with_N in let () = if _dbg then let e' = StaticModel.normalize env e in Format.eprintf "%a ---> %a@." PP.pp_expr e PP.pp_expr e' in let () = if _dbg then let f' = StaticModel.normalize env f in Format.eprintf "%a ---> %a@." PP.pp_expr f PP.pp_expr f' in let () = if _dbg then let res' = StaticModel.normalize env res in Format.eprintf "%a ---> %a@." PP.pp_expr res PP.pp_expr res' in assert (StaticModel.equal_in_env env !%"N" res) let () = exec_tests [ ("build_consts", build_consts); ("static.normalize", normalize); ("static.fpzero_example", fpzero_example); ] herd-herdtools7-1ca343e/asllib/tests/toposort.ml000066400000000000000000000051731475314470400220030ustar00rootroot00000000000000[@@@warning "-44-40"] let ( <-- ) a b = (a, b) module ISet = Set.Make (Int) module IMap = Map.Make (Int) let from_edges = let add_one_edge (nodes, succ_map) (v, succs) = let nodes = ISet.add v nodes in let nodes = List.fold_right ISet.add succs nodes in let succ_map = IMap.update v (function | None -> ISet.of_list succs |> Option.some | Some set -> List.fold_right ISet.add succs set |> Option.some) succ_map in (nodes, succ_map) in fun edges -> let nodes, succ_map = List.fold_left add_one_edge (ISet.empty, IMap.empty) edges in let succ_map = ISet.fold (fun v -> IMap.update v (function None -> Some ISet.empty | s -> s)) nodes succ_map in (ISet.elements nodes, fun v -> IMap.find v succ_map |> ISet.elements) (* Compatibility layer around Int. *) module I = struct let hash : int -> int = Hashtbl.hash [@@warning "-32"] include Int end module TS = Asllib.TopoSort.Make (I) let print_fold os () = Format.( printf "@[{%a}@ @]" (pp_print_list ~pp_sep:pp_print_space pp_print_int) os) let () = if false then ( let nodes, succs = from_edges [ 1 <-- [ 2; 3 ]; 2 <-- [ 3 ] ] in Format.printf "@[Graph:@ "; TS.fold_strong_connected print_fold nodes succs (); Format.printf "@]@.") let () = if false then ( let nodes, succs = from_edges [ 1 <-- [ 2; 3 ]; 2 <-- [ 3 ]; 3 <-- [ 2 ] ] in Format.printf "@[Graph:@ "; TS.fold_strong_connected print_fold nodes succs (); Format.printf "@]@.") let () = if false then ( let nodes, succs = from_edges [ 0 <-- [ 1 ] ] in Format.printf "@[Graph:@ "; TS.fold_strong_connected print_fold nodes succs (); Format.printf "@]@."; assert (TS.Properties.order_respected (nodes, succs))) let graph n = let open QCheck in let node = int_bound n in let singleton v = [ v ] and unsingleton = function [ v ] -> v | _ -> assert false in let edge = pair node (map ~rev:unsingleton singleton node) in list_of_size Gen.(0 -- (n * n)) edge let test ?short count n = let long_factor = match short with Some true -> 1 | _ -> 10 in QCheck.Test.make ~count ~long_factor ~name:(Printf.sprintf "order respected on graphs of size %d" n) (graph n) (fun edges -> TS.Properties.order_respected (from_edges edges)) let testsuite = let short = true in [ test ~short 10 2; test ~short 10 1; test ~short 20 3; test ~short 20 4; test ~short 100 5; test 200 6; test 1000 7; test 4000 8; test 10000 9; test 40000 10; ] let () = QCheck_runner.run_tests_main testsuite herd-herdtools7-1ca343e/asllib/tests/types.ml000066400000000000000000000123771475314470400212620ustar00rootroot00000000000000open Asllib open ASTUtils open AST open! Helpers open Infix open Asllib.Types let empty_env = StaticEnv.empty let env_with_n = let open StaticEnv in add_local "N" integer LDK_Let empty let builtin_examples () = let assert_is_builtin_singular t = assert (is_builtin_singular !!t); assert (not (is_builtin_aggregate !!t)); assert (is_builtin !!t); assert (is_anonymous !!t); () in let assert_is_builtin_aggregate t = assert (is_builtin_aggregate !!t); assert (not (is_builtin_singular !!t)); assert (is_builtin !!t); assert (is_anonymous !!t) in (* Builtin singulars *) List.iter assert_is_builtin_singular [ integer'; integer_exact' !$3; T_Real; T_String; T_Bool; T_Enum []; T_Enum [ "Something"; "Something Else" ]; T_Bits (!$0, []); T_Bits (!$3, [ BitField_Simple ("Something", [ Slice_Single !$0 ]) ]); ]; (* Builtin aggregate *) List.iter assert_is_builtin_aggregate [ T_Tuple []; T_Tuple [ !!T_Real; !!T_String ]; T_Record []; T_Record [ ("a", !!T_Real); ("B", integer) ]; T_Exception []; T_Exception [ ("a", !!T_Real); ("B", integer) ]; ]; (* Not builtin *) assert (is_named !!(T_Named "type_x")); assert (not (is_builtin !!(T_Named "type_x"))); assert (not (is_anonymous !!(T_Named "type_x"))); () let structure_example () = (* type T1 of integer; *) let t1 = !!(T_Named "T1") in (* type T2 of (integer, T1); *) let t2_def = !!(T_Tuple [ integer; t1 ]) in let t2 = !!(T_Named "T2") in let env = let tf = SideEffect.TimeFrame.Constant in let open StaticEnv in add_type "T1" integer tf empty |> add_type "T2" t2_def tf in (* the named type `T1` whose structure is integer *) assert (is_named t1); assert ((get_structure env t1).desc = integer.desc); (* the named type `T2` whose structure is (integer, integer) *) assert (is_named t2); assert ((get_structure env t2).desc = T_Tuple [ integer; integer ]); (* Note that (integer, T1) is non-primitive since it uses T1 *) assert (is_non_primitive t2_def); (* the named (hence non-primitive) type `T1` *) assert (is_non_primitive t1); (* anonymous primitive type `integer` *) assert (is_primitive integer); assert (is_anonymous integer); (* the anonymous non-primitive type `(integer, T1)` whose structure is `(integer, integer)` *) assert (is_anonymous t2_def); assert (is_non_primitive t2_def); assert ((get_structure env t2).desc = T_Tuple [ integer; integer ]); () let subtype_examples () = (* let bits_4 = !!(T_Bits (!$4, [])) in let bits_2_4 = !!(T_Bits ( BitWidth_Constraints [ Constraint_Exact !$2; Constraint_Exact !$4 ], [] )) in assert (not (subtype_satisfies empty_env bits_2_4 bits_4)); *) let bits_btifields = !!(T_Bits (!$4, [ BitField_Simple ("a", [ Slice_Single !$3 ]) ])) in assert (subtype_satisfies empty_env bits_btifields bits_btifields); let bits_n = !!(T_Bits (!%"N", [])) in let bits_n_1 = !!(T_Bits (binop MUL !%"N" !$1, [])) in assert (subtype_satisfies env_with_n bits_n bits_n_1); () let type_examples () = let bits_4 = !!(T_Bits (!$4, [])) in let bits_n = !!(T_Bits (!%"N", [])) in let bits_n' = !!(T_Bits (!%"N", [])) in assert (type_satisfies env_with_n bits_n bits_n'); assert (not (type_satisfies empty_env !!T_Bool integer)); assert (not (type_satisfies empty_env bits_4 integer)); assert (type_satisfies empty_env integer integer); assert (type_satisfies empty_env bits_4 bits_4); assert (type_satisfies empty_env !!T_Bool !!T_Bool); () let lca_examples () = let bits_4 = !!(T_Bits (!$4, [])) in let bits_2 = !!(T_Bits (!$2, [])) in assert (lowest_common_ancestor empty_env bits_4 bits_2 = None); let integer_4 = integer_exact !$4 in let integer_2 = integer_exact !$2 in let lca = lowest_common_ancestor empty_env integer_4 integer_2 in assert (Option.is_some lca); let lca = Option.get lca in let domain = Asllib.Types.Domain.of_type empty_env lca in assert (Asllib.Types.Domain.mem ~$2 domain); assert (Asllib.Types.Domain.mem ~$4 domain); () let type_clashes () = let bits_4 = !!(T_Bits (!$4, [])) in let bits_2 = !!(T_Bits (!$2, [])) in let bits_m = !!(T_Bits (!%"M", [])) in let integer_4 = integer_exact !$4 in let integer_2 = integer_exact !$2 in assert (not (type_clashes empty_env bits_4 integer_4)); assert (not (type_clashes empty_env integer bits_2)); assert (type_clashes empty_env integer integer_4); assert (type_clashes empty_env integer_2 integer_4); assert (type_clashes empty_env bits_m bits_m); assert (type_clashes empty_env integer integer); assert (type_clashes empty_env boolean boolean); () let enum_example () = let variants = [ "A"; "B" ] in let variants' = [ "A"; "B" ] in let t1 = !!(T_Enum variants) in let t2 = !!(T_Enum variants') in assert (subtype_satisfies empty_env t1 t2); () let () = exec_tests [ ("types.builtin_examples", builtin_examples); ("types.structure_example", structure_example); ("types.subtype_example", subtype_examples); ("types.lca_example", lca_examples); ("types.types_examples", type_examples); ("types.type_clashes", type_clashes); ("types.enum_example", enum_example); ] herd-herdtools7-1ca343e/asllib/tests/typing.t/000077500000000000000000000000001475314470400213265ustar00rootroot00000000000000herd-herdtools7-1ca343e/asllib/tests/typing.t/CNegative1.asl000066400000000000000000000002301475314470400237500ustar00rootroot00000000000000// a may not be initialized from b func negative1{N}(bv : bits(N)) begin var b : integer {-1} = -1; var a : integer {0..N} = b; // illegal end; herd-herdtools7-1ca343e/asllib/tests/typing.t/CNegative10.asl000066400000000000000000000004571475314470400240430ustar00rootroot00000000000000// only static types are considered during type-checking assignments func negative10{N, M}(bv : bits(N), bv2 : bits(M)) begin var a = 0 as integer{0..N}; var b = 0 as integer{0..M}; if N == M then a = b; // illegal; only the static type is considered for type-checking end; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/CNegative11.asl000066400000000000000000000002501475314470400240330ustar00rootroot00000000000000// M is not guaranteed to be within the constraints of z func negative11{N, M}(x: bits(N), y: bits(M)) begin var z = 0 as integer{0..N}; z = M; // illegal end; herd-herdtools7-1ca343e/asllib/tests/typing.t/CNegative12.asl000066400000000000000000000002031475314470400240320ustar00rootroot00000000000000// decided this should be illegal in ASL-492 func negative12{N}(bv : bits(N), N: integer, bv2 : bits({0..N})) begin pass; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/CNegative2.asl000066400000000000000000000002401475314470400237520ustar00rootroot00000000000000// return value is not guaranteed to be within the constraints of the return type func negative2{N}(x: bits(N)) => integer {N} begin return 3; // illegal end;herd-herdtools7-1ca343e/asllib/tests/typing.t/CNegative3.asl000066400000000000000000000007361475314470400237650ustar00rootroot00000000000000// can't assign an arbitrary value to z func negative3{N}(a: bits(N), x0: real, y0: real) => integer begin var x: real = 0.0; var y: real = 0.0; var z = N; // some algorithm with an undeterminable loop count while x*x + y*y <= 2.0*2.0 do let xtemp = (x*x - y*y) + x0; y = 2.0*x*y + y0; x = xtemp; z = z + 1; // should be illegal without ATC end; let W = z; var bv: bits(W) = Ones{W}; return BitCount(bv); end; herd-herdtools7-1ca343e/asllib/tests/typing.t/CNegative4.asl000066400000000000000000000003611475314470400237600ustar00rootroot00000000000000// width of return value is not statically equivalent to width of return type // (a checked type conversion is required) func negative4{N: integer {0..64}} (x: bits(N)) => bits(64) begin return ( Ones{5} :: x ); end; herd-herdtools7-1ca343e/asllib/tests/typing.t/CNegative5.asl000066400000000000000000000004461475314470400237650ustar00rootroot00000000000000// width of bv must be equal to i func printLengths{N}(i: integer {N}, bv: bits(N)) begin print(DecStr(i)); print(" == "); print(DecStr(N)); print(" == "); print(DecStr(Len(bv))); print("\n"); end; func negative5() => integer begin printLengths{12}(3, Zeros{12}); // illegal end; herd-herdtools7-1ca343e/asllib/tests/typing.t/CNegative6.asl000066400000000000000000000002301475314470400237550ustar00rootroot00000000000000// return value must be within the constraints of the return type func negative6{N}(x: bits(N)) => integer {0..N} begin return N + 1; // illegal end; herd-herdtools7-1ca343e/asllib/tests/typing.t/CNegative7.asl000066400000000000000000000003451475314470400237650ustar00rootroot00000000000000// value passed for i must be within constraints func GetBitAt{N}(x: bits(N), i: integer {0..N-1}) => bits(1) begin return x[i]; end; func negative7{M}(x: bits(M)) => bits(1) begin return GetBitAt{M}(x, M); // illegal end; herd-herdtools7-1ca343e/asllib/tests/typing.t/CNegative8.asl000066400000000000000000000003631475314470400237660ustar00rootroot00000000000000// can't assign integer with (potentially) different constraints to another func negative8{N, M}(bv : bits(N), bv2 : bits(M)) begin var a = 0 as integer{0..N}; var b = 0 as integer{0..M}; a = b; // illegal, would require ATC end; herd-herdtools7-1ca343e/asllib/tests/typing.t/CPositive1-1.asl000066400000000000000000000002241475314470400241510ustar00rootroot00000000000000// y has the type integer {0..N} func positive1{N}(x: bits(N), offset: integer) begin let y = offset MOD N; let z: integer {0..N} = y; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/CPositive1.asl000066400000000000000000000002151475314470400240130ustar00rootroot00000000000000// y has the type integer {0..N} func positive1{N}(x: bits(N), offset: integer) => bit begin var y = offset MOD N; return x[y]; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/CPositive10.asl000066400000000000000000000002251475314470400240740ustar00rootroot00000000000000// The value of a parameter may be negative. func positive10{N}(x: bits(N+1), y: bits(N+2)) => bits(N*3+3) begin return Zeros{N} :: x :: y; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/CPositive11a.asl000066400000000000000000000004201475314470400242330ustar00rootroot00000000000000// This function is statically legal, but it is a dynamic error if the function is invoked with N != 59. func positive11a{N: integer {0..64}} (x: bits(N)) => bits(64) begin return Ones{5} as bits(64 - N) :: x ; // has static width of bits(64) end; herd-herdtools7-1ca343e/asllib/tests/typing.t/CPositive11b.asl000066400000000000000000000004171475314470400242420ustar00rootroot00000000000000// This function is statically legal, but it is a dynamic error if the function is invoked with N != 59. func positive11b{N: integer {0..64}} (x: bits(N)) => bits(64) begin return ( Ones{5} :: x ) as bits(64); // has static width of bits(64) end; herd-herdtools7-1ca343e/asllib/tests/typing.t/CPositive12.asl000066400000000000000000000024721475314470400241040ustar00rootroot00000000000000type Rnum_X of integer{0..31}; type ElementSize of integer{8, 16, 32, 64, 128}; type ExtendType of enumeration {ExtendType_SXTB, ExtendType_SXTH, ExtendType_SXTW, ExtendType_SXTX, ExtendType_UXTB, ExtendType_UXTH, ExtendType_UXTW, ExtendType_UXTX}; getter X{width : ElementSize}(n : Rnum_X) => bits(width) begin assert width IN {8,16,32,64}; return n[width-1:0]; end; func ExtendReg{N : ElementSize}(reg : Rnum_X, exttype : ExtendType, shift : integer{0..4}) => bits(N) begin assert shift >= 0 && shift <= 4; let val : bits(N) = X{}(reg); var unsigned : boolean; var len : ElementSize; case exttype of when ExtendType_SXTB => unsigned = FALSE; len = 8; when ExtendType_SXTH => unsigned = FALSE; len = 16; when ExtendType_SXTW => unsigned = FALSE; len = 32; when ExtendType_SXTX => unsigned = FALSE; len = 64; when ExtendType_UXTB => unsigned = TRUE; len = 8; when ExtendType_UXTH => unsigned = TRUE; len = 16; when ExtendType_UXTW => unsigned = TRUE; len = 32; when ExtendType_UXTX => unsigned = TRUE; len = 64; end; let nbits = Min(len, N - shift) as integer{0..N}; return Extend{N}(val[0+:nbits] :: Zeros{shift}, unsigned); end; func CPositive12() => bits(8) begin return ExtendReg{8}(0, ExtendType_SXTH, 2); end; herd-herdtools7-1ca343e/asllib/tests/typing.t/CPositive2.asl000066400000000000000000000001741475314470400240200ustar00rootroot00000000000000// N1 has the type integer{N+1} func positive2{N}(x: bits(N)) => integer{N+1} begin var N1 = N + 1; return N1; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/CPositive3.asl000066400000000000000000000002221475314470400240130ustar00rootroot00000000000000// a may be initialized from b func positive3{N}(bv : bits(N)) begin var b = 0; // b has type integer{0} var a : integer {0..N} = b; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/CPositive4.asl000066400000000000000000000002711475314470400240200ustar00rootroot00000000000000// any width bitvector may be passed to sub func sub{N}(arg : bits(N)) begin pass; end; func positive4(w: integer{1, 2, 3}) begin sub{12}(Zeros{12}); sub{w}(Zeros{w}); end; herd-herdtools7-1ca343e/asllib/tests/typing.t/CPositive5.asl000066400000000000000000000002771475314470400240270ustar00rootroot00000000000000// assignment is legal as both are the same under constrained integer func positive5{N}(bv : bits(N)) begin var a = 0 as integer {0..N}; var b = 0 as integer {0..N}; a = b; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/CPositive6.asl000066400000000000000000000002041475314470400240160ustar00rootroot00000000000000// parameter N can be assigned to R of unconstrained integer type func positive6{N}(x: bits(N)) begin var R : integer = N; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/CPositive7.asl000066400000000000000000000002321475314470400240200ustar00rootroot00000000000000// Assigning to a wider range func positive7{N}(bv: bits(N), x: integer{0..N}) begin var a: integer{0..2*N} = x; var b: integer{0..N+1} = x; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/CPositive9.asl000066400000000000000000000003501475314470400240230ustar00rootroot00000000000000// Can use a parameterized integer as a bitvector width in a subprogram body func positive9{N}(x: bits(N)) => bits(N + N DIV 2) begin let y: bits(N) = Zeros{N}; let z: bits(N DIV 2) = Zeros{N DIV 2}; return y :: z; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/HExample1.asl000066400000000000000000000024151475314470400236150ustar00rootroot00000000000000getter ReadMem{size}(address : integer, unknown : boolean) => bits(size*8) begin var value : bits(size*8) = Zeros{}(); value = Read{size}(address, unknown); return value; end; func Read{size}(address : integer, unknown : boolean) => bits(8*size) begin var value : bits(size*8) = ARBITRARY : bits(size*8); if !unknown then value = MemRead{size}(address); end; return value; end; func MemRead{size}(address : integer) => bits(8*size) begin var result : bits(8*size) = Zeros{8*size}; // Address of a special register if address == 0x800000000 then // Assuming input is integer{1, 2, 4, 8, 16} let regs = size DIV 4; // Perform multiple 4-bytes (32-bit) reads if size == 8 || size == 16 then for i = 1 to regs do let lsb = i - 1 * 32; result[lsb+31:lsb] = read_mem_bits{4}; end; else return read_mem_bits{4}[(8*size)-1:0]; end; return result; elsif address == 0x400000000 then result[31:0] = Ones{32}; return result; else let val = read_mem_bits{size}; return val[(8*size)-1:0]; end; end; func read_mem_bits{size : integer}() => bits(8*size) begin return Ones{8*size}; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/HExample10.asl000066400000000000000000000010061475314470400236700ustar00rootroot00000000000000// Divisions func division_example{width}(data_in : bits(width)) => bits(width) begin var iterations = width DIV 8; return Zeros{width}; end; func for_loop_example1{N}(data : bits(N)) begin for i = 0 to (N DIV 8) - 1 do var byte = data[i*8+7:i*8]; end; end; func for_loop_example2{width}(data_in : bits(width)) => bits(width) begin var data = data_in; var iterations = width DIV 8; for i=0 to iterations-1 do data[63+i*64:64*i] = Ones{64}; end; return data; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/HExample11.asl000066400000000000000000000003331475314470400236730ustar00rootroot00000000000000func min_highest_set_bit_example{N}(curr : bits(N)) begin var highest = HighestSetBit(curr) as integer{0..7}; var minimum = Min(highest, 7) as integer{0..7}; let size = minimum; var x = Zeros {N}; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/HExample12.asl000066400000000000000000000012511475314470400236740ustar00rootroot00000000000000// Symbolic equivalence - mixture 'N' underconstrained 'E' well-constrained func SignedZero{N}(sign: bit) => bits(N) begin let E = 5; let F = N - (E + 1); return sign :: Zeros{E} :: Zeros{F}; end; // Mixture here is fine - constrained + underconstrained - requires type equivalence func Extract{size}(offset : integer{0..32}, reg_value : bits(128)) => bits(size * 8) begin return reg_value[(offset+size) * 8 - 1:(offset) * 8]; end; // Underconstrained to Named type constraint type myconstraint of integer{1,2,3,4}; func UnderToNamedConstraint(N : integer) begin var l : myconstraint; l = (N+5) as myconstraint; let x = l; var y = Zeros {x}; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/HExample13.asl000066400000000000000000000003721475314470400237000ustar00rootroot00000000000000 func main () => integer begin let x = 64 << UInt(ARBITRARY: bits(1)); // integer {64, 128} let y = 8 << UInt(ARBITRARY: bits(2)); // integer {8, 16, 32, 64} let bv = ARBITRARY: bits(y); let bv2: bits(x) = Replicate{}(bv); return 0; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/HExample14.asl000066400000000000000000000004121475314470400236740ustar00rootroot00000000000000func Reverse{N}(word : bits(N), M : integer{1..N}) => bits(N) begin return Zeros{N}; end; func main () => integer begin let c = 8 << UInt (ARBITRARY: bits(2)); // integer {8, 16, 32, 64} let bv = Zeros{c}; let res = Reverse{c}(bv, 8); return 0; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/HExample15.asl000066400000000000000000000001621475314470400236770ustar00rootroot00000000000000func HExample15(x: integer {4, 8}, y: integer {4, 8}, a: integer) begin let d = x DIV y; let - = a < d; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/HExample16.asl000066400000000000000000000004211475314470400236760ustar00rootroot00000000000000func Reverse{N}(word : bits(N), M : integer{1..N}) => bits(N) begin return Zeros{N}; end; func HExemple16 (a: integer {8, 16, 32, 64}, b: integer {8, 16, 32, 64}) begin if a < b then Unreachable(); end; let bv = Zeros{a}; let -: bits(a) = Reverse{}(bv, b); end; herd-herdtools7-1ca343e/asllib/tests/typing.t/HExample17.asl000066400000000000000000000004051475314470400237010ustar00rootroot00000000000000func Reverse{N}(word : bits(N), M : integer{1..N}) => bits(N) begin return Zeros{N}; end; func HExemple17 (a: integer {8, 16, 32, 64}) begin if a != 64 then Unreachable(); end; let b = 32; let bv = Zeros{a}; let -: bits(a) = Reverse{}(bv, b); end; herd-herdtools7-1ca343e/asllib/tests/typing.t/HExample18.asl000066400000000000000000000004261475314470400237050ustar00rootroot00000000000000func Reverse{N}(word : bits(N), M : integer{1..N}) => bits(N) begin return Zeros{N}; end; func HExemple18 (a: bits(2)) begin if a IN {'0x'} then Unreachable(); end; let a2 = 8 << UInt(a); let bv = Zeros{a2}; let b = 16; let -: bits(a2) = Reverse{}(bv, a2); end; herd-herdtools7-1ca343e/asllib/tests/typing.t/HExample2.asl000066400000000000000000000015221475314470400236140ustar00rootroot00000000000000 type ExtractType of enumeration {PLUS, COLON, ELEM, FUNC, ARBITRARY_OP, EXTEND}; func Example{size}(op_type : ExtractType) => bits(8*size) begin var register : bits(8*size) = Ones{8*size}; case op_type of when PLUS => return register[0 +: 8*size]; when COLON => return register[8*size-1 : 0]; when ELEM => return register[0 *: 8*size]; when FUNC => return register_read{size}; when ARBITRARY_OP => return ARBITRARY: bits(8*size); when EXTEND => if size == 32 then register[31:0] = Ones{32}; else register = ZeroExtend{8*size}('0'); end; return register; end; end; func register_read{size}() => bits(8*size) begin return Ones{8*size}; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/HExample3.asl000066400000000000000000000017111475314470400236150ustar00rootroot00000000000000type RuntimeType of enumeration {BIGGER_THAN_8, LESS_THAN_8, EQUALS_8}; func Runtime{size}(error: RuntimeType) => bits(8*size) begin var temp = Zeros{64}; var result = Zeros{8*size}; case error of when BIGGER_THAN_8 => // Runtime Error when size > 8 result = temp[0+:8*size]; temp = ZeroExtend{64}(result); when EQUALS_8 => // Cannot concatenate if size != 8 result = temp[63:56] :: Zeros{8*size - 8}; when LESS_THAN_8 => // Runtime Error when size < 8 result = ZeroExtend{8*size}(temp); // Selecting values from result that do not exist result[95:0] = Zeros{96}; // Passing a value down to another function type-checks // but causes a runtime error function{size}(ZeroExtend{8*size}(temp)); end; return result; end; func function{size}(x : bits(8*size)) begin pass; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/HExample4.asl000066400000000000000000000004631475314470400236210ustar00rootroot00000000000000config LargeConfigurableBitVectorSize : integer{1..0xFFFF_FFFF_FFFF_FFFF} = 8; type LargeBitvectorSize of integer{0..LargeConfigurableBitVectorSize}; func CreateBigVector{bytes: LargeBitvectorSize}() => bits(8*bytes) begin var value = Zeros {8*bytes}; value = Ones{8*bytes}; return value; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/HExample5.asl000066400000000000000000000015421475314470400236210ustar00rootroot00000000000000func halfsize0{N}(op1 : bits(N DIV 2), op2 : bits(N DIV 2)) => bits(N) begin var value1 : bits(N) = op1 :: Zeros{N DIV 2}; return value1; end; func halfsize1{N}(op : bits(N)) => bits(N DIV 2) begin var result = Zeros {N}; let halfsize = N DIV 2; return result[(2*halfsize)-1:halfsize]; end; func halfsize2{N}(op1 : bits(N) , op2 : bits(N)) => bits(N) begin var result = Zeros {2*N}; return result[2*N-1:N]; end; func halfsize3{size}() => bits(size*8) begin var value = ARBITRARY: bits(size*8); let halfsize = (size DIV 2) as integer{4,8}; var lowhalf = Zeros {halfsize * 8}; var highhalf = Zeros {halfsize * 8}; lowhalf = returnOnes{halfsize}; highhalf = returnOnes{halfsize}; value = highhalf :: lowhalf; return value; end; func returnOnes{size}() => bits(8*size) begin return Ones{8*size}; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/HExample6.asl000066400000000000000000000004401475314470400236160ustar00rootroot00000000000000func MathematicalFunction{N, M}(input : bits(N), mask : bits(M)) begin assert(N == M * 8); let p2bits = ClosestPow2(N) as integer{0..N*2}; var op = Zeros {p2bits}; end; func ClosestPow2(N : integer) => integer begin var x = HighestSetBit(N[63:0] + 1); return x; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/HExample7.asl000066400000000000000000000005071475314470400236230ustar00rootroot00000000000000func Addition{N}(addend : bits(N), esize : integer{8,16,32,64}) => bits(N) begin assert N == esize * 2 * 2; var result = Zeros {N}; var e = Zeros {esize}; for i = 0 to 1 do for j = 0 to 1 do e = Ones{esize}; end; result[(2*i) *: esize] = e; end; return result; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/HExample8.asl000066400000000000000000000006501475314470400236230ustar00rootroot00000000000000// Different signature underconstrained to constrained // for creating an array in a separate function func ArrayExample{M,N}(vector1 : bits(M), vector0 : bits(N)) => bits(M) begin let E = N DIVRM 8; return FunctWithConstraint{M}(vector1, E as integer{1, 2, 3, 4}); end; func FunctWithConstraint{M}(result : bits(M), x : integer{1,2,3,4}) => bits(M) begin var y : array[[x]] of integer; return result; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/HExample9.asl000066400000000000000000000030731475314470400236260ustar00rootroot00000000000000func LimitBits{N}(x : bits(N), value : integer) => bits(N) begin return value[N-1:0]; end; func Return32_bits{N}(data_in : bits(N)) => bits(32) begin var data : bits(N) = data_in; return data[31:0]; end; // Create bit-vector of return type func ReturnReturnType{N,M}(op : bits(M)) => bits(N) begin var result : bits(N) = Ones{N}; return result; end; // Unused N func UnusedUnderconstrained{N}(op1 : bits(N)) => bits(4) begin return '1111'; end; // Going from unconstrained to constrained func rolling0{N}(x : bits(N), shift : integer) => bits(N) begin return rolling1{N}(x, N-shift); end; func rolling1{N}(x : bits(N), shift : integer) => bits(N) begin let length = shift as integer{0..N}; return Ones{length}[N-1:0]; end; // Condition on one underconstraint and generate a bit-vector based on return type func ConditionalInput{esize,N}(input : bits(N)) => bits(esize) begin if N == esize then return input[esize-1:0]; end; return Ones{esize}; end; func AmmendZero{N}(op : bits(N)) => bits(N) begin return '0' :: op[N-2:0]; end; func NPlusM{M,N}(op1 : bits(M), op2 : bits(N)) => bits(M+N) begin var result = Zeros{M+N}; var result0 : bits(M+N) = ZeroExtend{}(op2); for i =0 to M-1 do result[i] = '1'; end; return result; end; func save_bits{N}(x : bits(N)) => bits(N) begin var result : bits(N) = Ones{}(); if N == 16 then var value = 100; return value[N-1:0]; elsif N == 32 then result[31:0] = x[31:0]; return result; end; return result; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/KPositive01.asl000066400000000000000000000001031475314470400240770ustar00rootroot00000000000000type ty of integer{-1..2}; let w : ty = 2; var x: bits(w) = '11'; herd-herdtools7-1ca343e/asllib/tests/typing.t/NegParam.asl000066400000000000000000000002271475314470400235220ustar00rootroot00000000000000func test{N}(bv: bits(N+1)) begin let x: integer {0..N} = 0; end; func main () => integer begin test{2}('000'); test{-1}(''); return 0; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TDegraded13-sets1.asl000066400000000000000000000006151475314470400250550ustar00rootroot00000000000000func degraded13 (a: bits(64), b: bits(64)) begin var z = UInt(a) * UInt(b); let K = 2 ^ 64 - 1; // K is the highest number in the type of UInt(a) // K*K is the highest number in the type of z // K*(K-1) is the second highest number that z can take. // The distance between K*K and K*(K-1) is K, so (K*K)-1 is not a value reachable by z. z = (K*K)-1; // Is this legal? end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TDegraded13-sets2.asl000066400000000000000000000002631475314470400250550ustar00rootroot00000000000000func degraded13 (a: bits(64), b: bits(64)) begin var z = UInt(a) * UInt(b); z = (2 ^ 107) - 1; // This is a prime number according to https://www.mersenne.org/primes/ end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TDegraded13.asl000066400000000000000000000014241475314470400240170ustar00rootroot00000000000000func degraded13(a : bits(64), b : bits(64)) begin // In this case a very large constraint set is used (bit vectors must use constrained integers for their widths). Tools are permitted to // have degraded behaviour in constraint handling in cases like this. For example only tracking the min/max value of the constraints. It // would be useful if tools issued warnings if the behaviour is degraded like this. The threshold for when degraded behaviour starts to // apply is implementation defined. let temp = UInt(a) * UInt(b); let testA : bits(temp) = Zeros{temp}; end; func main() => integer begin degraded13(Zeros{64} + 1234, Zeros{64} + 4321); // WARNING: aslref freezes // degraded13(Zeros{64} + 12345, Zeros{64} + 54321); return 0; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative10-0.asl000066400000000000000000000017101475314470400242120ustar00rootroot00000000000000func negative10(N : integer {8,16}, M : integer {8,16}) begin // Width of bit vectors must be "statically evaluable", which is better thought of as symbolically evaluable. To make this sane and // avoid the need for the type system to analyse potential changes to widthN after its initialised, we require all width expressions // to be immutable. var widthN = N; // // let testA : bits(N) = Zeros{widthN}; // Symbolic evaluation doesn't propagate back to a common point because it doesn't handle var's. // This is because we don't want the type system to have to analyse any arbitary complexity code // that could modify the var between different reads of of the var. let letWidthN1 = widthN; // let letWidthN2 = widthN; let testB : bits(letWidthN1) = Zeros{letWidthN2}; // illegal as type bits(letWidthN1) is different from bits(letWidthN2). end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative10-1.asl000066400000000000000000000031531475314470400242160ustar00rootroot00000000000000func foo() => integer {0..7} begin return ARBITRARY: integer {0..7}; end; func negative10(N : integer {8,16}, M : integer {8,16}) begin // Width of bit vectors must be "statically evaluable", which is better thought of as symbolically evaluable. To make this sane and // avoid the need for the type system to analyse potential changes to widthN after its initialised, we require all width expressions // to be immutable. var widthN = N; // // let testA : bits(N) = Zeros{widthN}; // Symbolic evaluation doesn't propagate back to a common point because it doesn't handle var's. // This is because we don't want the type system to have to analyse any arbitary complexity code // that could modify the var between different reads of of the var. let letWidthN1 = widthN; // let letWidthN2 = widthN; // let testB : bits(letWidthN1) = Zeros{letWidthN2}; // illegal as type bits(letWidthN1) is different from bits(letWidthN2). // Even though the widths used in both LHS and RHS are immutable constrained integers (tempC3A and tempC3B), and they are both // derived from a common immutable constrained integer (tempC1). The following is illegal as the chain of immutability is broken // at "var tempC2B". let tempC1 : integer {0..7} = foo(); let tempC2A = tempC1; var tempC2B = tempC1; let tempC3A = tempC2A; let tempC3B = tempC2B; let testC : bits(tempC3A) = Zeros{tempC3B}; // illegal, type bits(tempC1) != bits(tempC3B) end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative10.asl000066400000000000000000000007061475314470400240610ustar00rootroot00000000000000func negative10(N : integer {8,16}, M : integer {8,16}) begin // Width of bit vectors must be "statically evaluable", which is better thought of as symbolically evaluable. To make this sane and // avoid the need for the type system to analyse potential changes to widthN after its initialised, we require all width expressions // to be immutable. var widthN = N; // let testA : bits(N) = Zeros{widthN}; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative12.asl000066400000000000000000000002251475314470400240570ustar00rootroot00000000000000func negative12(N : integer {8,16}) begin let testA = N as bits(8); // ATC's can't change structure. let testB = testA as integer; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative14-0.asl000066400000000000000000000006271475314470400242240ustar00rootroot00000000000000type NamedTypeA of integer {8,16}; type NamedTypeB of integer {8,16}; func negative14(w1 : NamedTypeA, w2: NamedTypeA) begin let tempA : NamedTypeB = w1; // illegal, not the same type // let testB : bits(w1) = Zeros(w2); // illegal, just because w1 and w2 are the same type doesn't mean they are the same value, so // type bits(w1) != bits(w2) end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative14-1.asl000066400000000000000000000006271475314470400242250ustar00rootroot00000000000000type NamedTypeA of integer {8,16}; type NamedTypeB of integer {8,16}; func negative14(w1 : NamedTypeA, w2: NamedTypeA) begin // let tempA : NamedTypeB = w1; // illegal, not the same type let testB : bits(w1) = Zeros{w2}; // illegal, just because w1 and w2 are the same type doesn't mean they are the same value, so // type bits(w1) != bits(w2) end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative15-0.asl000066400000000000000000000005461475314470400242250ustar00rootroot00000000000000type NamedTypeA of integer {8,16}; type NamedTypeB of integer {8,16}; func negative15(x: integer, w1: NamedTypeA, w2: NamedTypeA) begin let testA = 0xA55A1234[x+7:x]; // The RHS width express does not result in a constrained integer, so even though the width is // guaranteed to be 8, this is illegal. end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative15-1.asl000066400000000000000000000003511475314470400242200ustar00rootroot00000000000000type NamedTypeA of integer {8,16}; type NamedTypeB of integer {8,16}; func negative15(x: integer, w1: NamedTypeA, w2: NamedTypeA) begin let testB = 0xA55A1234[0 +: x]; // illegal, bit width isn't a constrained integer end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative15-2.asl000066400000000000000000000003521475314470400242220ustar00rootroot00000000000000type NamedTypeA of integer {8,16}; type NamedTypeB of integer {8,16}; func negative15(x: integer, w1: NamedTypeA, w2: NamedTypeA) begin let testC = 0xA55A1234[0 *: x]; // illegal, bit width isn't a constrained integer end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative15-3.asl000066400000000000000000000003651475314470400242270ustar00rootroot00000000000000type NamedTypeA of integer {8,16}; type NamedTypeB of integer {8,16}; func negative15(x: integer, w1: NamedTypeA, w2: NamedTypeA) begin var testD = Zeros{32}; testD[0 *: x] = Zeros{x}; // Same rules apply to bit slices on LHS end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative2-0.asl000066400000000000000000000003401475314470400241310ustar00rootroot00000000000000func negative2(size : integer {0..3}, size2 : integer {8,16,32,64}, myInt : integer) begin // assignment to a variable with a domain thats a subset is illegal without ATC's let testA : integer {0..2} = size; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative2-1.asl000066400000000000000000000003411475314470400241330ustar00rootroot00000000000000func negative2(size : integer {0..3}, size2 : integer {8,16,32,64}, myInt : integer) begin // assignment to a variable with a domain thats a subset is illegal without ATC's let testB : integer {8,16,32} = size2; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative2-2.asl000066400000000000000000000004771475314470400241460ustar00rootroot00000000000000func negative2(size : integer {0..3}, size2 : integer {8,16,32,64}, myInt : integer) begin // assignment to a variable with a domain thats a subset is illegal without ATC's let testC : integer {8,16,32} = myInt; // assignment of unconstrained integers to constrained integers is also illegal without a ATC end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative3.asl000066400000000000000000000004031475314470400237750ustar00rootroot00000000000000 func negative3(size2 : integer {8,16,32,64}) begin // inexact operators (eg those with rounding) don't propagate constraints let testA : integer {1,2,4,8} = size2 DIVRM 8; // illegal as DIVRM output is of type "integer" not "integer {1,2,4,8}" end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative4-bis.asl000066400000000000000000000002601475314470400245520ustar00rootroot00000000000000var VAR_ALLOWED_NUMS : integer {8, 16} = 8; func negative4() begin let testA : integer {VAR_ALLOWED_NUMS} = 8; // illegal var's aren't allowed in constraints end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative4.asl000066400000000000000000000002571475314470400240050ustar00rootroot00000000000000var VAR_ALLOWED_NUMS : integer {8} = 8; func negative4() begin let testA : integer {VAR_ALLOWED_NUMS} = 8; // illegal var's aren't allowed in constraints end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative5-0.asl000066400000000000000000000007771475314470400241520ustar00rootroot00000000000000func negative5(size : integer {0..3}) begin // The domain of the output of the ATC is the domain of the ATC, and this domain is used for type inference let temp = size as integer {8,16}; // temp has type integer {8,16} let testA : integer {0..3} = temp; // illegal as value of type integer {8,16} can't be assigned to var of type integer {0..3}. // Even though temp is guaranteed to be within the range 0..3 because it comes from size end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative5-1.asl000066400000000000000000000002051475314470400241350ustar00rootroot00000000000000func negative5(size : integer {0..3}) begin // ATC's can't coerce the structure let testB : integer = TRUE as integer; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative6.asl000066400000000000000000000010771475314470400240100ustar00rootroot00000000000000//////////////////////////////////////////////////////////////////////////////// // comparisons //////////////////////////////////////////////////////////////////////////////// func foo() => integer {8, 16} begin return ARBITRARY : integer {8, 16}; end; func negative6() begin // Same principle applies to the when clauses in a case statement let testG : integer {8,16} = foo(); case testG of when 32 => pass; // when 64 => pass; // end; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative7.asl000066400000000000000000000004661475314470400240120ustar00rootroot00000000000000type MyBitsSizes of integer {8,16,32}; type MyOtherSizes of integer {8,16,32}; type MyByteSizes of integer {1,2,4}; func negative7(size : MyBitsSizes) begin let testA : MyOtherSizes = size; // illegal as testA and size are different named types, even though they are the same structure and domain end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative8-0.asl000066400000000000000000000002721475314470400241430ustar00rootroot00000000000000func negative8() begin let N : integer = 7; for i = 0 to N do let testA : integer {0..7} = i; // N is an unconstrained integer, so i is also unconstrained end; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative8-1.asl000066400000000000000000000002761475314470400241500ustar00rootroot00000000000000func negative8() begin let N : integer = 7; for i = N downto 0 do let testB : integer {0..7} = i; // N is an unconstrained integer, so i is also unconstrained end; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative8-2.asl000066400000000000000000000002731475314470400241460ustar00rootroot00000000000000func negative8() begin let N : integer = 7; for i = N to 31 do let testC : integer {7..31} = i; // N is an unconstrained integer, so i is also unconstrained end; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative8-3.asl000066400000000000000000000002771475314470400241530ustar00rootroot00000000000000func negative8() begin let N : integer = 7; for i = 31 downto N do let testD : integer {7..31} = i; // N is an unconstrained integer, so i is also unconstrained end; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative9-0.asl000066400000000000000000000001641475314470400241440ustar00rootroot00000000000000func negative9(N : integer {8,16}, M : integer {8,16}, X : integer) begin let testA : bits(8) = Zeros{16}; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative9-1.asl000066400000000000000000000006041475314470400241440ustar00rootroot00000000000000func negative9(N : integer {8,16}, M : integer {8,16}, X : integer) begin let testB : bits(N) = Zeros{N DIV 4} :: Zeros{N DIV 2}; // bits(3N/4) != bits(N) // Type of Zeros{N} its bits(N), not bits(M), so this is illegal regardless of the fact that N and M have the same domain, // they could have different runtime values so we must evaluate the type safety symbolically end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative9-2.asl000066400000000000000000000001631475314470400241450ustar00rootroot00000000000000func negative9(N : integer {8,16}, M : integer {8,16}, X : integer) begin let testC : bits(M) = Zeros{N}; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative9-3.asl000066400000000000000000000002631475314470400241470ustar00rootroot00000000000000func negative9(N : integer {8,16}, M : integer {8,16}, X : integer) begin let testD : bits(X) = Zeros{X}; // X isn't a constrained integer, so can't be used as bit width end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TNegative9-4.asl000066400000000000000000000003051475314470400241450ustar00rootroot00000000000000func negative9(N : integer {8,16}, M : integer {8,16}, X : integer) begin let testE : bits(N) = Zeros{8}; // N != 8, even though 8 is in the constraint set for N. N could be 16 after all. end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive1.asl000066400000000000000000000023511475314470400240370ustar00rootroot00000000000000//////////////////////////////////////////////////////////////////////////////// // Generating constrained integers //////////////////////////////////////////////////////////////////////////////// func positive1(myBits : bits(4)) begin let testA : integer {42} = 42; // Integer literals are constrained integers with the domain containing just the literal value. // so "42" has type "integer {42}" let testB : integer {0..15} = UInt(myBits); // UInt() produces a constrained integer based on the number of bits. In this case 4 bits producing // an integer in the range 0 to 15 let testC : integer {-8..7} = SInt(myBits); // Similarly for SInt(). NOTE: LRM is contradictory for SInt(). Rrxyn says it doesn't return an // constrained integer, but section "9.1 Standard integer functions and procedures" says it does. // If the type of a variable isn't defined, its inferred from the RHS, including the domain/constraints, so temp has type integer {-8..7} // and the assignment to testD is legal let temp = testC; let testD : integer {-8..7} = temp; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive10-0.asl000066400000000000000000000053231475314470400242560ustar00rootroot00000000000000func foo() => integer {0..7} begin return ARBITRARY: integer {0..7}; end; func positive10(N : integer {8,16}, M : integer {8,16}, O : integer {8}) begin // The basic idea is expressions use in the width of a bitvector are executed (symbolically if necessary) by the type checker // to determine the width. This is then used to determine type satisfaction. let width8 = 8; let testA : bits(8) = Zeros{width8}; // The value of width8 can be fully statically evaluated and determined to be 8 let widthN = N; let testB : bits(N) = Zeros{widthN}; // The value of widthN can only be partially evaluated and requires symbolic execution, which // determines the width of widthN is N // The width of Zeros{letWidthFoo2} is symbolically evaluated to be letWidthFoo. NOTE: It's not varWidthFoo as the symbolic evaluation can // only handle immutable values, so only progresses back to letWidthFoo and not varWidthFoo. var varWidthFoo : integer {0..7} = foo(); // let letWidthFoo = varWidthFoo; let letWidthFoo2 = letWidthFoo; let testC : bits(letWidthFoo) = Zeros{letWidthFoo2}; // Both size of a type satisfaction undergo symbolic evaluation let letWidthFoo3 = letWidthFoo; let testD : bits(letWidthFoo3) = Zeros{letWidthFoo2}; // Both RHS and LHS have width letWidthFoo let letWidthFooSub = letWidthFoo - 1; let testE : bits(letWidthFoo) = Zeros{letWidthFooSub} :: '0'; // RHS evaluates to type bits(letWidthFoo) let tempF1 : integer {0..7} = foo(); let tempF2 = tempF1; let tempF3A = tempF2; let tempF3B = tempF2; let testF : bits(tempF3A) = Zeros{tempF3B}; // The width of the LHS and RHS have multiple common symbols, so the type could be either // bits(tempF2) or bits(tempF1), it doesn't actually matter if tools stop the symbolic // evaluation at the first common point, or continue tracking backwards as far as possible. let tempG1 : integer {0..7} = foo(); let tempG2 = tempG1; let tempG3A = tempG2; let tempG3B = tempG2; // let testG : bits(tempG3A) = Zeros{tempG3B} OR Zeros{tempG1}; // In this case the type must be bits(tempG1) as this is the first // common point. let testH : bits(8) = Zeros{O}; // as "O" only has a single allowed value, Zeros(O) evaluates to type bits(8). See R_QZJS end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive10-1.asl000066400000000000000000000005431475314470400242560ustar00rootroot00000000000000let global_width8: integer {8, 16} = 8; let global_testA: bits(8) = Zeros{global_width8}; let global_width8b = global_width8; let global_testB: bits(global_width8) = Zeros{global_width8b}; func tpositive101 () begin let testA: bits(8) = Zeros {global_width8}; let width8b = global_width8b; let testB: bits(global_width8) = Zeros{width8b}; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive10.asl000066400000000000000000000053201475314470400241160ustar00rootroot00000000000000func foo() => integer {0..7} begin return ARBITRARY: integer {0..7}; end; func positive10(N : integer {8,16}, M : integer {8,16}, O : integer {8}) begin // The basic idea is expressions use in the width of a bitvector are executed (symbolically if necessary) by the type checker // to determine the width. This is then used to determine type satisfaction. let width8 = 8; let testA : bits(8) = Zeros{width8}; // The value of width8 can be fully statically evaluated and determined to be 8 let widthN = N; let testB : bits(N) = Zeros{widthN}; // The value of widthN can only be partially evaluated and requires symbolic execution, which // determines the width of widthN is N // The width of Zeros{letWidthFoo2} is symbolically evaluated to be letWidthFoo. NOTE: It's not varWidthFoo as the symbolic evaluation can // only handle immutable values, so only progresses back to letWidthFoo and not varWidthFoo. var varWidthFoo : integer {0..7} = foo(); // let letWidthFoo = varWidthFoo; let letWidthFoo2 = letWidthFoo; let testC : bits(letWidthFoo) = Zeros{letWidthFoo2}; // Both size of a type satisfaction undergo symbolic evaluation let letWidthFoo3 = letWidthFoo; let testD : bits(letWidthFoo3) = Zeros{letWidthFoo2}; // Both RHS and LHS have width letWidthFoo let letWidthFooSub = letWidthFoo - 1; let testE : bits(letWidthFoo) = Zeros{letWidthFooSub} :: '0'; // RHS evaluates to type bits(letWidthFoo) let tempF1 : integer {0..7} = foo(); let tempF2 = tempF1; let tempF3A = tempF2; let tempF3B = tempF2; let testF : bits(tempF3A) = Zeros{tempF3B}; // The width of the LHS and RHS have multiple common symbols, so the type could be either // bits(tempF2) or bits(tempF1), it doesn't actually matter if tools stop the symbolic // evaluation at the first common point, or continue tracking backwards as far as possible. let tempG1 : integer {0..7} = foo(); let tempG2 = tempG1; let tempG3A = tempG2; let tempG3B = tempG2; let testG : bits(tempG3A) = Zeros{tempG3B} OR Zeros{tempG1}; // In this case the type must be bits(tempG1) as this is the first // common point. let testH : bits(8) = Zeros{O}; // as "O" only has a single allowed value, Zeros(O) evaluates to type bits(8). See R_QZJS end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive11-0.asl000066400000000000000000000015201475314470400242520ustar00rootroot00000000000000func ZerosBytes{N : integer {1,2,4,8}}() => bits(N*8) begin return Zeros{N*8}; end; func positive11(size : bits(2), width : integer {1..3}) begin let sizeInt = UInt(size); let numBytes = 1 << sizeInt; let numBits = 8 << sizeInt; // let testA : bits(numBits) = ZerosBytes{numBytes}; let esize = 8 << UInt(size); let testB : bits(esize) = ZerosBytes{esize DIV 8}; let testC : integer {0..(2^esize)-1} = UInt(testB); // symbolically constrained integer, without being an under defined integer let testD : bits(testC) = Zeros{testC}; let tempE = width + sizeInt; let testE : bits(tempE) = Zeros{sizeInt} :: Zeros{width}; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive11-1.asl000066400000000000000000000015311475314470400242550ustar00rootroot00000000000000func ZerosBytes{N : integer {1,2,4,8}}() => bits(N*8) begin return Zeros{N*8}; end; func positive11(size : bits(2), width : integer {1..3}) begin let sizeInt = UInt(size); let numBytes = 1 << sizeInt; let numBits = 8 << sizeInt; // let testA : bits(numBits) = ZerosBytes{numBytes}; let esize = 8 << UInt(size); // let testB : bits(esize) = ZerosBytes{esize DIV 8}; // let testC : integer {0..(2^esize)-1} = UInt(testB); // symbolically constrained integer, without being an under defined integer // let testD : bits(testC) = Zeros{testC}; let tempE = width + sizeInt; let testE : bits(tempE) = Zeros{sizeInt} :: Zeros{width}; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive11.asl000066400000000000000000000015151475314470400241210ustar00rootroot00000000000000func ZerosBytes{N : integer {1,2,4,8}}() => bits(N*8) begin return Zeros{N*8}; end; func positive11(size : bits(2), width : integer {1..3}) begin let sizeInt = UInt(size); let numBytes = 1 << sizeInt; let numBits = 8 << sizeInt; let testA : bits(numBits) = ZerosBytes{numBytes}; let esize = 8 << UInt(size); let testB : bits(esize) = ZerosBytes{esize DIV 8}; let testC : integer {0..(2^esize)-1} = UInt(testB); // symbolically constrained integer, without being an under defined integer let testD : bits(testC) = Zeros{testC}; let tempE = width + sizeInt; let testE : bits(tempE) = Zeros{sizeInt} :: Zeros{width}; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive12.asl000066400000000000000000000007211475314470400241200ustar00rootroot00000000000000func positive12(N : integer {8,16}) begin let testA : bits(8) = Zeros{N} as bits(8); let testB : bits(N) = Zeros{8} as bits(N); // ATC's permitted to be disjoint with bit vector they're applied to. Must compile, but will fail at runtime if the line is executed. // See ASL-313 for rational. let testC : bits(32) = Zeros{N} as bits(32); let testD : bits(N) = Zeros{32} as bits(N); let testE : bits(8) = Zeros{32} as bits(8); end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive13.asl000066400000000000000000000016171475314470400241260ustar00rootroot00000000000000func positive13(a : bits(64), b : bits(64), c : bits(64)) begin // Some operations will result in very large constraint sets. testA to testC are all constrained integers by type inference, and must // compile and run without any warnings. // NOTE: although the constraint set is massive and probably can't be handled by most tools, it's not actually used. One way of getting // round the massive size of the constraint set is to handle it lazily. That way tools wouldn't need to compute the constraint set // at all for cases like this. let testA = UInt(a) * UInt(b); let testB = SInt(a) * SInt(b); let testC = (SInt(a) * UInt(b)) + UInt(c); let testD = testA[63:0]; let testE = testB[63:0]; let testF = testC[63:0]; end; func main() => integer begin positive13(Zeros{64} + 123456789, Zeros{64} + 987654321, Zeros{64} + 987654321); return 0; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive14.asl000066400000000000000000000014311475314470400241210ustar00rootroot00000000000000type NamedTypeA of integer {8,16}; type NamedTypeB of integer {8,16}; func positive14(w1 : NamedTypeA) begin let tempA : NamedTypeB = w1 as NamedTypeB; // NOTE: ATC's between different named types will be permitted by ASL-505 let testB : bits(w1) = Zeros{tempA}; // legal, RHS and LHS are both of type bits(w1). The fact that w1 and tempA are different // named types doesn't matter, its the value they have, not their types that matters. // Assignment to/from named type and primitive type are legal without ATC's let testC : integer {8,16} = w1; let testD : NamedTypeB = testC; let tempE : NamedTypeB = w1 as integer {8,16}; // Combined version of testC/D. Using ATC to erase named type. end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive15.asl000066400000000000000000000016751475314470400241340ustar00rootroot00000000000000func positive15(x : integer, n: integer {0..31}) begin let testA : bits(8) = 0xA55A1234[7:0]; let testB : bits(8) = 0xA55A1234[n+7:n]; // RHS is type bits(n+7 - n + 1), which reduces to bits(8), and the width expression is a // constrained integer let testC : bits(8) = 0xA55A1234[x +: 8]; // RHS is type bits(8), position allowed to be an unconstrained integer let testD : bits(8) = 0xA55A1234[x *: 8]; let testE : bits(n) = 0xA55A1234[x *: n]; // RHS is type bits(n), which is a constrained integer var testF = Zeros{32}; testF[x *: n] = Zeros{n}; // Same rules apply to bit slices on LHS let testG = 0xA55A1234[0 +: 0]; // Zero width bit slices permitted let testH : bit = 0xA55A1234[n]; // bit slices of bit vectors let testI = Zeros{2}[n]; // statically allowed, but may fail at runtime if n > 1 end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive2.asl000066400000000000000000000014361475314470400240430ustar00rootroot00000000000000//////////////////////////////////////////////////////////////////////////////// // Assignments of constrained integers //////////////////////////////////////////////////////////////////////////////// func positive2(size : integer {0..3}, size2 : integer {8,16,32,64}) begin // assignment to a variable with a domain that's a superset is valid, let testA : integer {0..4} = size; let testB : integer {8,16,32,64,128} = size2; // The way the domain is expressed doesn't matter, so {0..3} is the same as {0,1,2,3} let testC : integer {0,1,2,3} = size; let testD : integer {0..3} = testC; // Combinations of both of the above are also legal let testE : integer {0,1,2,3,4} = size; let testF : integer {0..128} = size2; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive3-0.asl000066400000000000000000000007131475314470400241760ustar00rootroot00000000000000func positive3(size : integer {0..3}, size2 : integer {8,16,32,64}) begin // exact operators propagate the constraints. For example "integer {8} << integer {0..3}" has type "integer {8,16,32,64}" // let testA : integer {8,16,32,64} = 8 << size; let testB : integer {1..4} = size + 1; let testC : integer {0,2,4,6} = size * 2; let testD : integer {1,2,4,8} = size2 DIV 8; let testE : integer {7,15,31,63} = size2 - 1; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive3-1.asl000066400000000000000000000007171475314470400242030ustar00rootroot00000000000000func positive3(size : integer {0..3}, size2 : integer {8,16,32,64}) begin // exact operators propagate the constraints. For example "integer {8} << integer {0..3}" has type "integer {8,16,32,64}" // let testA : integer {8,16,32,64} = 8 << size; let testB : integer {1..4} = size + 1; // let testC : integer {0,2,4,6} = size * 2; let testD : integer {1,2,4,8} = size2 DIV 8; let testE : integer {7,15,31,63} = size2 - 1; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive3.asl000066400000000000000000000007071475314470400240440ustar00rootroot00000000000000func positive3(size : integer {0..3}, size2 : integer {8,16,32,64}) begin // exact operators propagate the constraints. For example "integer {8} << integer {0..3}" has type "integer {8,16,32,64}" let testA : integer {8,16,32,64} = 8 << size; let testB : integer {1..4} = size + 1; let testC : integer {0,2,4,6} = size * 2; let testD : integer {1,2,4,8} = size2 DIV 8; let testE : integer {7,15,31,63} = size2 - 1; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive4-1.asl000066400000000000000000000002101475314470400241700ustar00rootroot00000000000000let LET_ALLOWED_NUMS_B : integer {8,16} = 8; func positive4() begin let testB : integer {LET_ALLOWED_NUMS_B} = 16; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive4-2.asl000066400000000000000000000003021475314470400241730ustar00rootroot00000000000000func foo () => integer {8, 16} begin return 8; end; let LET_ALLOWED_NUMS_C : integer {8,16} = foo(); func positive4() begin let testC : integer {LET_ALLOWED_NUMS_C} = 16; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive4-3.asl000066400000000000000000000003721475314470400242030ustar00rootroot00000000000000func foo () => integer {8, 16} begin return 8; end; let LET_ALLOWED_NUMS_C : integer {8,16} = foo(); func positive4() begin let testD : integer {0..LET_ALLOWED_NUMS_C} = 3; let testE : integer {0..16} = testD; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive4-4.asl000066400000000000000000000004031475314470400241770ustar00rootroot00000000000000func foo () => integer {8, 16} begin return 8; end; config CONFIG_ALLOWED_NUMS : integer {8,16} = foo(); func positive4() begin // configs can also be used and follow the same rules as lets let testF : integer {CONFIG_ALLOWED_NUMS} = 16; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive4-5.asl000066400000000000000000000003001475314470400241740ustar00rootroot00000000000000func foo () => integer {8, 16} begin return 8; end; config CONFIG_ALLOWED_NUMS : integer {8,16} = foo(); func positive4() begin let testG : integer {0..CONFIG_ALLOWED_NUMS} = 3; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive4.asl000066400000000000000000000002071475314470400240400ustar00rootroot00000000000000let LET_ALLOWED_NUMS_A = 8; func positive4() begin let testA : integer {LET_ALLOWED_NUMS_A} = 8; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive5.asl000066400000000000000000000017441475314470400240500ustar00rootroot00000000000000func positive5(size : integer {0..3}) begin // The domain of the ATC can be exactly the same, or a subset/superset of the value it applies to let testA = size as integer {0..3}; let testB = size as integer {0..16}; let testC = size as integer {0..1}; // Legal statically, but may fail at runtime if size is >1 // The domain of the ATC may be completely disjoint from the value it applies to. This sounds odd but is required by the instruction // flow. See ASL-313 for rational let testD = size as integer {8,16}; // Must be legal statically, but will fail at runtime if this line is ever reached. let testE = 1 as integer {8,16}; // Must be legal statically, but will fail at runtime if this line is ever reached. // The domain of the output of the ATC is the domain of the ATC, and this domain is used for type inference let temp = size as integer {0..1}; // temp has type integer {0..1} let testF : integer {0..1} = temp; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive6.asl000066400000000000000000000017551475314470400240530ustar00rootroot00000000000000//////////////////////////////////////////////////////////////////////////////// // comparisons //////////////////////////////////////////////////////////////////////////////// func foo() => integer {8, 16} begin return ARBITRARY : integer {8, 16}; end; func positive6(size : integer {0..3}) begin let testA = size == 8; // legal even though there's no overlap between domains integer {0..3} and integer {8} let testB = size > 8; let testC = size >= 8; let testD = size < 8; let testE = size <= 8; let testF = size IN {8,16}; // Same principle applies to the when clauses in a case statement, although the case statement must still be exhaustive or contain an otherwise clause. let testG : integer {8,16} = foo(); case testG of when 8 => pass; // when 16 => pass; // when 32 => // Unreachable but legal code pass; // end; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive7.asl000066400000000000000000000021731475314470400240470ustar00rootroot00000000000000type MyBitsSizes of integer {8,16,32}; type MyOtherSizes of integer {8,16,32}; type MyByteSizes of integer {1,2,4}; func positive7(size : MyBitsSizes, size2 : integer {8,16,32}) begin let testA : MyBitsSizes = size; let testB : MyBitsSizes = size2; // assignment to/from unnamed types is permitted, as long as the constraints are satisfied let testC : MyBitsSizes = 8; let testD : integer {8,16,32} = size; let testE : MyByteSizes = size DIV 8; // operators erase the name of the type. The type of "size DIV 8" is therefore just // integer {1,2,4}, and can therefore be assigned to a var of type MyByteSizes let testF : MyOtherSizes = size as MyOtherSizes; // ATC's can be used between named types of the same structure let testG : MyByteSizes = size as MyByteSizes; // As per positive5 and ASL-313, ATC's can be used even if the domains are disjoint. This // must be valid statically but will fail at runtime if the line is reached. end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive8-1.asl000066400000000000000000000003031475314470400241770ustar00rootroot00000000000000func tpositive8b () begin // NOTE: this test is not supported by ASLRef. for i = 100 as integer {8,16} to 110 as integer {0,31} do let testK : integer {8..31} = i; end; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive8.asl000066400000000000000000000022451475314470400240500ustar00rootroot00000000000000//////////////////////////////////////////////////////////////////////////////// // loops //////////////////////////////////////////////////////////////////////////////// func positive8(N : integer {0..15}, M : integer {7,15}) begin for i = 0 to 7 do // i has type integer {0..7} let testA : integer {0..7} = i; end; for i = 7 downto 0 do // i has type integer {0..7} let testB : integer {0..7} = i; end; for i = 0 to N do // i has type integer {0..N} let testC : integer {0..15} = i; end; for i = 0 to M do // i has type integer {0..M} let testD : integer {0..15} = i; end; for i = N downto 0 do let testE : integer {0..15} = i; end; for i = M downto 0 do let testF : integer {0..15} = i; end; for i = N to 31 do let testG : integer {0..31} = i; // i has type integer {N..31} end; for i = M to 31 do let testH : integer {7..31} = i; // i has type integer {M..31} end; for i = 31 downto N do let testI : integer {0..31} = i; end; for i = 31 downto M do let testJ : integer {7..31} = i; end; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive9-1.asl000066400000000000000000000012571475314470400242110ustar00rootroot00000000000000func positive9(N : integer {8,16}, M : integer {8,16}) begin let testA : bits(8) = Zeros{8}; let testB : bits(8) = Zeros{4+4}; let testC : bits(8) = Zeros{4} :: Zeros{4}; let testD : bits(N) = Zeros{N}; // type of Zeros{N} its bits(N) let testE : bits(N-1) = Zeros{N-1}; // type of Zeros{N-1} its bits(N-1) // let testF : bits(N) = Zeros(N DIV 2) :: Zeros{N DIV 2}; // type system must work out that bits(N/2) :: bits(N/2) is the same as bits(N) let testG : bits(M) = Zeros{N} as bits(M); for i = 0 to 7 do let testH : bits(i) = Zeros{i}; // i is both immutable and a constrained integer, so can be used as a bit width end; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TPositive9.asl000066400000000000000000000012541475314470400240500ustar00rootroot00000000000000func positive9(N : integer {8,16}, M : integer {8,16}) begin let testA : bits(8) = Zeros{8}; let testB : bits(8) = Zeros{4+4}; let testC : bits(8) = Zeros{4} :: Zeros{4}; let testD : bits(N) = Zeros{N}; // type of Zeros{N} its bits(N) let testE : bits(N-1) = Zeros{N-1}; // type of Zeros{N-1} its bits(N-1) let testF : bits(N) = Zeros{N DIV 2} :: Zeros{N DIV 2}; // type system must work out that bits(N/2) :: bits(N/2) is the same as bits(N) let testG : bits(M) = Zeros{N} as bits(M); for i = 0 to 7 do let testH : bits(i) = Zeros{i}; // i is both immutable and a constrained integer, so can be used as a bit width end; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TReconsider15.asl000066400000000000000000000010371475314470400244170ustar00rootroot00000000000000func reconsider15() begin // currently required to fail as 8 is guaranteed to be out of range. However this isn't consistent with the general approach behind // ASL-313. This isn't currently causing any problems in the ported pseudocode, but we might want to reconsider this for consistency. // If we do then this would be required be legal statically, but raise an error at runtime if the line is executed. let testA = Zeros{2}[8]; // Similar issue with negative width bit vectors let testB = Zeros{8}[0 +: -1]; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TReconsider4-0.asl000066400000000000000000000013611475314470400244720ustar00rootroot00000000000000let LET_ALLOWED_NUMS_A = 8; let LET_ALLOWED_NUMS_B : integer {8,16} = 8; let LET_ALLOWED_NUMS_C : integer {8,16} = foo(); constant CONST_ALLOWED_NUMS : integer {8,16} = 8; config CONFIG_ALLOWED_NUMS : integer {8,16} = foo(); var VAR_ALLOWED_NUMS : integer {8} = 8; func reconsider4() begin // R_LYDS currently has a special case for constants which makes the following illegal. Given we've already changed constants // to make them behave more consistently with config/lets in other respects (see ASL-503) we should probably also change R_LYDS // to make the following legal. let testA : integer {CONST_ALLOWED_NUMS} = 16; let testB : integer {0..CONST_ALLOWED_NUMS} = 10; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/TReconsider4-1.asl000066400000000000000000000013641475314470400244760ustar00rootroot00000000000000let LET_ALLOWED_NUMS_A = 8; let LET_ALLOWED_NUMS_B : integer {8,16} = 8; let LET_ALLOWED_NUMS_C : integer {8,16} = foo(); constant CONST_ALLOWED_NUMS : integer {8,16} = 8; config CONFIG_ALLOWED_NUMS : integer {8,16} = foo(); var VAR_ALLOWED_NUMS : integer {8} = 8; func reconsider4() begin // R_LYDS currently has a special case for constants which makes the following illegal. Given we've already changed constants // to make them behave more consistently with config/lets in other respects (see ASL-503) we should probably also change R_LYDS // to make the following legal. // let testA : integer {CONST_ALLOWED_NUMS} = 16; let testB : integer {0..CONST_ALLOWED_NUMS} = 10; end; herd-herdtools7-1ca343e/asllib/tests/typing.t/run.t000066400000000000000000000324241475314470400223240ustar00rootroot00000000000000H Examples $ aslref --no-exec HExample1.asl $ aslref --no-exec HExample2.asl $ aslref --no-exec HExample3.asl $ aslref --no-exec HExample4.asl $ aslref --no-exec HExample5.asl $ aslref --no-exec HExample6.asl $ aslref --no-exec HExample7.asl $ aslref --no-exec HExample8.asl $ aslref --no-exec HExample9.asl $ aslref --no-exec HExample10.asl $ aslref --no-exec HExample11.asl $ aslref --no-exec HExample12.asl $ aslref --no-exec HExample13.asl $ aslref --no-exec HExample14.asl $ aslref --no-exec HExample15.asl $ aslref --no-exec HExample16.asl File HExample16.asl, line 10, characters 19 to 35: ASL Typing error: a subtype of integer {1..a} was expected, provided integer {8, 16, 32, 64}. [1] $ aslref --no-exec HExample17.asl File HExample17.asl, line 11, characters 19 to 35: ASL Typing error: a subtype of integer {1..a} was expected, provided integer {32}. [1] $ aslref --no-exec HExample18.asl File HExample18.asl, line 12, characters 20 to 37: ASL Typing error: a subtype of integer {1..a2} was expected, provided integer {8, 16, 32, 64}. [1] T Tests $ aslref --no-exec TPositive1.asl Assignments of constrained integers $ aslref --no-exec TPositive2.asl $ aslref --no-exec TNegative2-0.asl File TNegative2-0.asl, line 4, characters 4 to 41: ASL Typing error: a subtype of integer {0..2} was expected, provided integer {0..3}. [1] $ aslref --no-exec TNegative2-1.asl File TNegative2-1.asl, line 4, characters 4 to 42: ASL Typing error: a subtype of integer {8, 16, 32} was expected, provided integer {8, 16, 32, 64}. [1] $ aslref --no-exec TNegative2-2.asl File TNegative2-2.asl, line 4, characters 4 to 42: ASL Typing error: a subtype of integer {8, 16, 32} was expected, provided integer. [1] Propagation of constrained integers $ aslref --no-exec TPositive3.asl $ aslref --no-exec TPositive3-0.asl $ aslref --no-exec TPositive3-1.asl $ aslref --no-exec TNegative3.asl Use of global vars in constraints $ aslref --no-exec TPositive4.asl $ aslref --no-exec TPositive4-1.asl File TPositive4-1.asl, line 5, characters 4 to 54: ASL Typing error: a subtype of integer {8} was expected, provided integer {16}. [1] $ aslref --no-exec TPositive4-2.asl File TPositive4-2.asl, line 8, characters 4 to 54: ASL Typing error: a subtype of integer {LET_ALLOWED_NUMS_C} was expected, provided integer {16}. [1] $ aslref --no-exec TPositive4-3.asl $ aslref --no-exec TPositive4-4.asl File TPositive4-4.asl, line 9, characters 4 to 54: ASL Typing error: a subtype of integer {CONFIG_ALLOWED_NUMS} was expected, provided integer {16}. [1] $ aslref --no-exec TPositive4-5.asl $ aslref --no-exec TReconsider4-0.asl File TReconsider4-0.asl, line 13, characters 4 to 54: ASL Typing error: a subtype of integer {8} was expected, provided integer {16}. [1] $ aslref --no-exec TReconsider4-1.asl File TReconsider4-1.asl, line 14, characters 4 to 54: ASL Typing error: a subtype of integer {0..8} was expected, provided integer {10}. [1] $ aslref --no-exec TNegative4.asl File TNegative4.asl, line 5, characters 25 to 41: ASL Typing error: a pure expression was expected, found VAR_ALLOWED_NUMS, which produces the following side-effects: [ReadsGlobal "VAR_ALLOWED_NUMS"]. [1] $ aslref --no-exec TNegative4-bis.asl File TNegative4-bis.asl, line 5, characters 25 to 41: ASL Typing error: a pure expression was expected, found VAR_ALLOWED_NUMS, which produces the following side-effects: [ReadsGlobal "VAR_ALLOWED_NUMS"]. [1] Asserted type conversions $ aslref --no-exec TPositive5.asl $ aslref --no-exec TNegative5-0.asl File TNegative5-0.asl, line 5, characters 4 to 38: ASL Typing error: a subtype of integer {0..3} was expected, provided integer {8, 16}. [1] $ aslref --no-exec TNegative5-1.asl File TNegative5-1.asl, line 4, characters 26 to 41: ASL Typing error: cannot perform Asserted Type Conversion on boolean by integer. [1] Comparisons $ aslref --no-exec TPositive6.asl $ aslref --no-exec TNegative6.asl Named types $ aslref --no-exec TPositive7.asl $ aslref --no-exec TNegative7.asl File TNegative7.asl, line 7, characters 4 to 36: ASL Typing error: a subtype of MyOtherSizes was expected, provided MyBitsSizes. [1] $ aslref --no-exec KPositive01.asl Loops $ aslref --no-exec TPositive8.asl $ aslref --no-exec TPositive8-1.asl File TPositive8-1.asl, line 5, characters 8 to 40: ASL Typing error: a subtype of integer {8..31} was expected, provided integer {100..110}. [1] $ aslref --no-exec TNegative8-0.asl File TNegative8-0.asl, line 5, characters 8 to 40: ASL Typing error: a subtype of integer {0..7} was expected, provided integer. [1] $ aslref --no-exec TNegative8-1.asl File TNegative8-1.asl, line 5, characters 8 to 40: ASL Typing error: a subtype of integer {0..7} was expected, provided integer. [1] $ aslref --no-exec TNegative8-2.asl File TNegative8-2.asl, line 5, characters 8 to 40: ASL Typing error: a subtype of integer {7..31} was expected, provided integer. [1] $ aslref --no-exec TNegative8-3.asl File TNegative8-3.asl, line 5, characters 8 to 40: ASL Typing error: a subtype of integer {7..31} was expected, provided integer. [1] Bit vector widths defined by constrained integers $ aslref --no-exec TPositive9.asl $ aslref --no-exec TPositive9-1.asl $ aslref --no-exec TNegative9-0.asl File TNegative9-0.asl, line 3, characters 4 to 36: ASL Typing error: a subtype of bits(8) was expected, provided bits(16). [1] $ aslref --no-exec TNegative9-1.asl File TNegative9-1.asl, line 3, characters 4 to 59: ASL Typing error: a subtype of bits(N) was expected, provided bits(((3 * N) DIV 4)). [1] $ aslref --no-exec TNegative9-2.asl File TNegative9-2.asl, line 3, characters 4 to 35: ASL Typing error: a subtype of bits(M) was expected, provided bits(N). [1] $ aslref --no-exec TNegative9-3.asl File TNegative9-3.asl, line 3, characters 26 to 34: ASL Typing error: constrained integer expected, provided integer. [1] $ aslref --no-exec TNegative9-4.asl File TNegative9-4.asl, line 3, characters 4 to 35: ASL Typing error: a subtype of bits(N) was expected, provided bits(8). [1] Symbolic execution of bit vector widths expressions $ aslref --no-exec TPositive10.asl $ aslref --no-exec TPositive10-0.asl $ aslref --no-exec TPositive10-1.asl $ aslref --no-exec TNegative10.asl File TNegative10.asl, line 8, characters 32 to 38: ASL Typing error: a pure expression was expected, found widthN, which produces the following side-effects: [ReadsLocal "widthN"]. [1] $ aslref --no-exec TNegative10-0.asl File TNegative10-0.asl, line 16, characters 4 to 53: ASL Typing error: a subtype of bits(letWidthN1) was expected, provided bits(letWidthN2). [1] $ aslref --no-exec TNegative10-1.asl File TNegative10-1.asl, line 28, characters 4 to 49: ASL Typing error: a subtype of bits(tempC3A) was expected, provided bits(tempC3B). [1] Complex symbolic execution of bit vector widths expressions $ aslref --no-exec TPositive11.asl File TPositive11.asl, line 11, characters 4 to 64: ASL Typing error: a subtype of bits(numBits) was expected, provided bits((8 * numBytes)). [1] $ aslref --no-exec TPositive11-0.asl $ aslref --no-exec TPositive11-1.asl ATC's on bit vectors $ aslref --no-exec TPositive12.asl $ aslref --no-exec TNegative12.asl File TNegative12.asl, line 3, characters 16 to 32: ASL Typing error: cannot perform Asserted Type Conversion on integer {8, 16} by bits(8). [1] Large constraint sets $ aslref TPositive13.asl File TPositive13.asl, line 8, characters 17 to 34: Interval too large: [ 0 .. 18446744073709551615 ]. Keeping it as an interval. File TPositive13.asl, line 8, characters 17 to 34: Interval too large: [ 0 .. 18446744073709551615 ]. Keeping it as an interval. File TPositive13.asl, line 10, characters 17 to 34: Interval too large: [ 0 .. 18446744073709551615 ]. Keeping it as an interval. $ aslref --no-exec TDegraded13.asl File TDegraded13.asl, line 7, characters 29 to 46: Interval too large: [ 0 .. 18446744073709551615 ]. Keeping it as an interval. File TDegraded13.asl, line 7, characters 29 to 46: Interval too large: [ 0 .. 18446744073709551615 ]. Keeping it as an interval. $ if [ $(ocaml -vnum | cut -b 1) = "5" ]; then aslref TDegraded13.asl 2>/dev/null; fi $ aslref --no-exec TDegraded13-sets1.asl File TDegraded13-sets1.asl, line 3, characters 10 to 27: Interval too large: [ 0 .. 18446744073709551615 ]. Keeping it as an interval. File TDegraded13-sets1.asl, line 3, characters 10 to 27: Interval too large: [ 0 .. 18446744073709551615 ]. Keeping it as an interval. $ aslref --no-exec TDegraded13-sets2.asl File TDegraded13-sets2.asl, line 3, characters 10 to 27: Interval too large: [ 0 .. 18446744073709551615 ]. Keeping it as an interval. File TDegraded13-sets2.asl, line 3, characters 10 to 27: Interval too large: [ 0 .. 18446744073709551615 ]. Keeping it as an interval. Named types for bit vector widths $ aslref --no-exec TPositive14.asl $ aslref --no-exec TNegative14-0.asl File TNegative14-0.asl, line 6, characters 4 to 32: ASL Typing error: a subtype of NamedTypeB was expected, provided NamedTypeA. [1] $ aslref --no-exec TNegative14-1.asl File TNegative14-1.asl, line 7, characters 4 to 39: ASL Typing error: a subtype of bits(w1) was expected, provided bits(w2). [1] Bit slice expressions $ aslref --no-exec TPositive15.asl $ aslref --no-exec TReconsider15.asl $ aslref --no-exec TNegative15-0.asl File TNegative15-0.asl, line 6, characters 20 to 37: ASL Typing error: constrained integer expected, provided integer. [1] $ aslref --no-exec TNegative15-1.asl File TNegative15-1.asl, line 6, characters 20 to 38: ASL Typing error: constrained integer expected, provided integer. [1] $ aslref --no-exec TNegative15-2.asl File TNegative15-2.asl, line 6, characters 20 to 38: ASL Typing error: constrained integer expected, provided integer. [1] $ aslref --no-exec TNegative15-3.asl File TNegative15-3.asl, line 7, characters 20 to 28: ASL Typing error: constrained integer expected, provided integer. [1] C Tests $ aslref --no-exec CPositive1.asl $ aslref --no-exec CPositive1-1.asl File CPositive1-1.asl, line 5, characters 4 to 30: ASL Typing error: a subtype of integer {0..N} was expected, provided integer. [1] $ aslref --no-exec CPositive2.asl $ aslref --no-exec CPositive3.asl File CPositive3.asl, line 5, characters 4 to 31: ASL Typing error: a subtype of integer {0..N} was expected, provided integer {0}. [1] $ aslref --no-exec CPositive4.asl $ aslref --no-exec CPositive5.asl $ aslref --no-exec CPositive6.asl $ aslref --no-exec CPositive7.asl File CPositive7.asl, line 4, characters 4 to 31: ASL Typing error: a subtype of integer {0..(2 * N)} was expected, provided integer {0..N}. [1] $ aslref --no-exec CPositive9.asl $ aslref --no-exec CPositive10.asl $ aslref --no-exec CPositive11a.asl $ aslref --no-exec CPositive11b.asl $ aslref --no-exec CPositive12.asl $ aslref --no-exec CNegative1.asl File CNegative1.asl, line 5, characters 4 to 31: ASL Typing error: a subtype of integer {0..N} was expected, provided integer {-1}. [1] $ aslref --no-exec CNegative2.asl File CNegative2.asl, line 4, characters 2 to 11: ASL Typing error: a subtype of integer {N} was expected, provided integer {3}. [1] $ aslref --no-exec CNegative3.asl File CNegative3.asl, line 8, character 4 to line 13, character 8: ASL Warning: Loop does not have a limit. File CNegative3.asl, line 12, characters 8 to 9: ASL Typing error: a subtype of integer {N} was expected, provided integer {(N + 1)}. [1] $ aslref --no-exec CNegative4.asl File CNegative4.asl, line 5, character 4 to line 8, character 6: ASL Typing error: a subtype of bits(64) was expected, provided bits((N + 5)). [1] $ aslref --no-exec CNegative5.asl File CNegative5.asl, line 13, characters 2 to 33: ASL Typing error: a subtype of integer {12} was expected, provided integer {3}. [1] $ aslref --no-exec CNegative6.asl File CNegative6.asl, line 4, characters 2 to 15: ASL Typing error: a subtype of integer {0..N} was expected, provided integer {(N + 1)}. [1] $ aslref --no-exec CNegative7.asl File CNegative7.asl, line 8, characters 9 to 26: ASL Typing error: a subtype of integer {0..(M - 1)} was expected, provided integer {M}. [1] $ aslref --no-exec CNegative8.asl File CNegative8.asl, line 7, characters 4 to 5: ASL Typing error: a subtype of integer {0..N} was expected, provided integer {0..M}. [1] $ aslref --no-exec CNegative10.asl File CNegative10.asl, line 7, characters 8 to 9: ASL Typing error: a subtype of integer {0..N} was expected, provided integer {0..M}. [1] $ aslref --no-exec CNegative11.asl File CNegative11.asl, line 5, characters 4 to 5: ASL Typing error: a subtype of integer {0..N} was expected, provided integer {M}. [1] $ aslref --no-exec CNegative12.asl File CNegative12.asl, line 2, characters 56 to 57: ASL Error: Cannot parse. [1] Extra tests by ASLRef team $ aslref NegParam.asl File NegParam.asl, line 3, characters 2 to 28: ASL Typing error: a subtype of integer {0..N} was expected, provided integer {0}. [1] herd-herdtools7-1ca343e/asllib/types.ml000066400000000000000000000707461475314470400201240ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) open AST open ASTUtils open Infix module SEnv = StaticEnv type env = SEnv.env module TypingRule = Instrumentation.TypingRule let ( |: ) = Instrumentation.TypingNoInstr.use_with let undefined_identifier pos x = Error.fatal_from pos (Error.UndefinedIdentifier x) let thing_equal astutil_equal env = astutil_equal (StaticModel.equal_in_env env) let expr_equal = thing_equal expr_equal let type_equal = thing_equal type_equal let array_length_equal = thing_equal array_length_equal let bitwidth_equal = thing_equal bitwidth_equal let slices_equal = thing_equal slices_equal let bitfield_equal = thing_equal bitfield_equal let constraints_equal = thing_equal constraints_equal let assoc_map map li = List.map (fun (x, y) -> (x, map y)) li (* --------------------------------------------------------------------------*) (* Begin Anonymize *) let rec make_anonymous (env : env) (ty : ty) : ty = match ty.desc with | T_Named x -> ( match IMap.find_opt x env.global.declared_types with | Some (t1, _) -> make_anonymous env t1 | None -> undefined_identifier ty x) | _ -> ty (* End *) (* TODO: rethink to have physical equality when structural equality? *) (* TODO: memoize? *) (* Begin Structure *) let rec get_structure (env : env) (ty : ty) : ty = let () = if false then Format.eprintf "@[Getting structure of %a.@]@." PP.pp_ty ty in let with_pos = add_pos_from ty in (match ty.desc with | T_Named x -> ( match IMap.find_opt x env.global.declared_types with | None -> undefined_identifier ty x | Some (t1, _) -> get_structure env t1) | T_Int _ | T_Real | T_String | T_Bool | T_Bits _ | T_Enum _ -> ty | T_Tuple tys -> T_Tuple (List.map (get_structure env) tys) |> with_pos | T_Array (e, t) -> T_Array (e, (get_structure env) t) |> with_pos | T_Record fields -> let fields' = assoc_map (get_structure env) fields |> canonical_fields in T_Record fields' |> with_pos | T_Exception fields -> let fields' = assoc_map (get_structure env) fields |> canonical_fields in T_Exception fields' |> with_pos) |: TypingRule.Structure (* End *) (* --------------------------------------------------------------------------*) (* Begin BuiltinSingular *) let is_builtin_singular ty = (match ty.desc with | T_Real | T_String | T_Bool | T_Bits _ | T_Enum _ | T_Int _ -> true | T_Tuple _ | T_Array (_, _) | T_Record _ | T_Exception _ | T_Named _ -> false) |: TypingRule.BuiltinSingularType (* End *) (* Begin BuiltinAggregate *) let is_builtin_aggregate ty = (match ty.desc with | T_Tuple _ | T_Array _ | T_Record _ | T_Exception _ -> true | T_Int _ | T_Bits (_, _) | T_Real | T_String | T_Bool | T_Enum _ | T_Named _ -> false) |: TypingRule.BuiltinAggregateType (* End *) (* Begin BuiltinSingularOrAggregate *) let is_builtin ty = (is_builtin_singular ty || is_builtin_aggregate ty) |: TypingRule.BuiltinSingularOrAggregate (* End *) (* Begin Named *) let is_named ty = (match ty.desc with T_Named _ -> true | _ -> false) |: TypingRule.NamedType (* End *) (* Begin Anonymous *) let is_anonymous ty = (not (is_named ty)) |: TypingRule.AnonymousType (* End *) (* A named type is singular if its underlying (a.k.a. anonimized) type is a builtin-singular type, otherwise it is aggregate. *) (* Begin Singular *) let is_singular env ty = make_anonymous env ty |> is_builtin_singular |: TypingRule.SingularType (* End *) (* A named type is singular if its underlying (a.k.a. anonimized) type is a builtin-aggregate type. *) (* Begin Aggregate *) let is_aggregate env ty = make_anonymous env ty |> is_builtin_aggregate |: TypingRule.AggregateType (* End *) (* Begin NonPrimitive *) let rec is_non_primitive ty = (match ty.desc with | T_Real | T_String | T_Bool | T_Bits _ | T_Enum _ | T_Int _ -> false | T_Named _ -> true | T_Tuple tys -> List.exists is_non_primitive tys | T_Array (_, ty) -> is_non_primitive ty | T_Record fields | T_Exception fields -> List.exists (fun (_, ty) -> is_non_primitive ty) fields) |: TypingRule.NonPrimitiveType (* End *) (* Begin Primitive *) let is_primitive ty = (not (is_non_primitive ty)) |: TypingRule.PrimitiveType (* End *) let parameterized_constraints = let next_uid = ref 0 in fun var -> let uid = !next_uid in incr next_uid; Parameterized (uid, var) let parameterized_ty var = T_Int (parameterized_constraints var) |> add_dummy_annotation let to_well_constrained ty = match ty.desc with | T_Int (Parameterized (_uid, var)) -> var_ var |> integer_exact | _ -> ty let get_well_constrained_structure env ty = get_structure env ty |> to_well_constrained (* --------------------------------------------------------------------------*) module Domain = struct module IntSet = Diet.Z type syntax = AST.int_constraint list (** Represents the domain of an integer expression. *) type t = Finite of IntSet.t | Top | FromSyntax of syntax let add_interval_to_intset acc bot top = if bot > top then acc else let interval = IntSet.Interval.make bot top in IntSet.add interval acc let pp f = let open Format in function | Top -> pp_print_string f "ℤ" | Finite set -> fprintf f "@[{@,%a}@]" IntSet.pp set | FromSyntax slices -> PP.pp_int_constraints f slices exception StaticEvaluationTop (* Begin NormalizeToInt *) let eval (env : env) (e : expr) = match StaticModel.reduce_to_z_opt env e with | None -> raise StaticEvaluationTop | Some i -> i (* End *) (* Begin ConstraintToIntSet *) let add_constraint_to_intset env acc = function | Constraint_Exact e -> let v = eval env e in add_interval_to_intset acc v v | Constraint_Range (bot, top) -> let bot = eval env bot and top = eval env top in add_interval_to_intset acc bot top (* End *) (* Begin IntSetOfIntConstraints *) let int_set_of_int_constraints env constraints = match constraints with | [] -> Error.fatal_from ASTUtils.dummy_annotated Error.EmptyConstraints | _ -> ( try Finite (List.fold_left (add_constraint_to_intset env) IntSet.empty constraints) with StaticEvaluationTop -> FromSyntax constraints) (* End *) (* Begin IntSetToIntConstraints *) let int_set_to_int_constraints = let interval_to_constraint interval = let x = IntSet.Interval.x interval and y = IntSet.Interval.y interval in let expr_of_z z = L_Int z |> literal in Constraint_Range (expr_of_z x, expr_of_z y) in fun is -> IntSet.fold (fun interval acc -> interval_to_constraint interval :: acc) is [] (* End *) (* Begin IntSetOp *) let rec int_set_raise_interval_op fop op is1 is2 = match (is1, is2) with | Top, _ | _, Top -> Top | Finite is1, Finite is2 -> ( try Finite (IntSet.fold (fun i1 -> IntSet.fold (fun i2 -> IntSet.add (fop i1 i2)) is2) is1 IntSet.empty) with StaticEvaluationTop -> let s1 = int_set_to_int_constraints is1 and s2 = int_set_to_int_constraints is2 in int_set_raise_interval_op fop op (FromSyntax s1) (FromSyntax s2)) | Finite is1, FromSyntax _ -> let s1 = int_set_to_int_constraints is1 in int_set_raise_interval_op fop op (FromSyntax s1) is2 | FromSyntax _, Finite is2 -> let s2 = int_set_to_int_constraints is2 in int_set_raise_interval_op fop op is1 (FromSyntax s2) | FromSyntax s1, FromSyntax s2 -> FromSyntax (StaticOperations.constraint_binop op s1 s2) (* End *) let monotone_interval_op op i1 i2 = let open IntSet.Interval in let x = op (x i1) (x i2) and y = op (y i1) (y i2) in if x < y then make x y else raise StaticEvaluationTop let anti_monotone_interval_op op i1 i2 = let open IntSet.Interval in let x = op (x i1) (y i2) and y = op (y i1) (x i2) in if x < y then make x y else raise StaticEvaluationTop let of_literal = function | L_Int n -> Finite (IntSet.singleton n) | _ -> raise StaticEvaluationTop (* [of_expr env e] returns the symbolic integer domain for the integer-typed expression [e]. *) let rec of_expr env e = match e.desc with | E_Literal v -> of_literal v | E_Var x -> ( try SEnv.lookup_constants env x |> of_literal with Not_found -> ( try SEnv.type_of env x |> of_type env with Not_found -> Error.fatal_from e (Error.UndefinedIdentifier x))) | E_Unop (NEG, e1) -> of_expr env (E_Binop (MINUS, !$0, e1) |> add_pos_from e) | E_Binop (((PLUS | MINUS | MUL) as op), e1, e2) -> let is1 = of_expr env e1 and is2 = of_expr env e2 and fop = match op with | PLUS -> monotone_interval_op Z.add | MINUS -> anti_monotone_interval_op Z.sub | MUL -> monotone_interval_op Z.mul | _ -> assert false in int_set_raise_interval_op fop op is1 is2 | _ -> let () = if false then Format.eprintf "@[<2>Cannot interpret as int set:@ @[%a@]@]@." PP.pp_expr e in FromSyntax [ Constraint_Exact e ] and of_width_expr env e = let e_domain = of_expr env e in let exact_domain = FromSyntax [ Constraint_Exact e ] in match e_domain with | Finite int_set -> if Z.equal (IntSet.cardinal int_set) Z.one then e_domain else exact_domain | FromSyntax [ Constraint_Exact _ ] -> e_domain | _ -> exact_domain and of_type env ty = let ty = make_anonymous env ty in match ty.desc with | T_Int UnConstrained -> Top | T_Int (Parameterized (_uid, var)) -> FromSyntax [ Constraint_Exact (var_ var) ] | T_Int (WellConstrained constraints) -> int_set_of_int_constraints env constraints | T_Int PendingConstrained -> assert false | T_Bool | T_String | T_Real -> failwith "Unimplemented: domain of primitive type" | T_Bits _ | T_Enum _ | T_Array _ | T_Exception _ | T_Record _ | T_Tuple _ -> failwith "Unimplemented: domain of a non singular type." | T_Named _ -> assert false (* make anonymous *) let mem v d = match (v, d) with | L_Bool _, _ | L_Real _, _ | L_String _, _ | L_BitVector _, _ | L_Label _, _ -> false | L_Int _, Top -> true | L_Int i, Finite intset -> IntSet.mem i intset | L_Int _, _ -> false let equal d1 d2 = match (d1, d2) with | Top, Top -> true | Finite is1, Finite is2 -> IntSet.equal is1 is2 | _ -> false let compare _d1 _d2 = assert false (** The [StaticApprox] module creates constant approximation of integer constraints as sets of integers. *) module StaticApprox = struct (** The two possible types of approximations. *) type approx = Over | Under exception CannotOverApproximate (** Raised if over approximation is not possible. *) (** Return bottom for Under approximation, top for over approximation. *) let bottom_top approx = if approx = Over then raise CannotOverApproximate else IntSet.empty let make_interval approx z1 z2 = if Z.leq z1 z2 then IntSet.(add (Interval.make z1 z2) empty) else bottom_top approx let literal_to_z = function L_Int z -> Some z | _ -> None let apply_unop loc op z = let open Error in try Operations.unop_values loc Error.Static op (L_Int z) |> literal_to_z with ASLException { desc = UnsupportedUnop _ } -> None let apply_binop loc op z1 z2 = let open Error in try Operations.binop_values loc Static op (L_Int z1) (L_Int z2) |> literal_to_z with ASLException { desc = UnsupportedBinop _ } -> None (* Begin ApproxExpr *) let rec approx_expr approx env e = match e.desc with | E_Literal (L_Int z) -> IntSet.singleton z | E_Literal _ -> bottom_top approx | E_Var x -> ( match approx with | Over -> approx_type Over env (SEnv.type_of env x) | Under -> IntSet.empty) | E_Unop (op, e') -> IntSet.filter_map_individual (apply_unop e op) (approx_expr approx env e') | E_Binop (op, e1, e2) -> IntSet.cross_filter_map_individual (apply_binop e op) (approx_expr approx env e1) (approx_expr approx env e2) | E_Cond (_econd, e2, e3) -> ( let s2 = approx_expr approx env e2 and s3 = approx_expr approx env e3 in match approx with | Over -> IntSet.union s2 s3 | Under -> IntSet.inter s2 s3) | _ -> bottom_top approx (* End *) (* Begin ApproxType *) and approx_type approx env t = match t.desc with | T_Named _ -> make_anonymous env t |> approx_type approx env | T_Int (WellConstrained cs) -> approx_constraints approx env cs | _ -> bottom_top approx (* End *) (* Begin ApproxConstraints *) and approx_constraints approx env cs = let join = let empty = IntSet.empty (* will not be used *) in match approx with | Under -> list_iterated_op ~empty IntSet.inter | Over -> list_iterated_op ~empty IntSet.union in List.map (approx_constraint approx env) cs |> join |: TypingRule.ApproxConstraints (* End *) (* Begin ApproxConstraint *) and approx_constraint approx env = function | Constraint_Exact e -> approx_expr approx env e |: TypingRule.ApproxConstraint | Constraint_Range (e1, e2) -> ( try let z1, z2 = match approx with | Over -> (approx_expr_min env e1, approx_expr_max env e2) | Under -> (approx_expr_max env e1, approx_expr_min env e2) in make_interval approx z1 z2 with Not_found | CannotOverApproximate -> bottom_top approx) (* end *) (* Begin ApproxExprMin *) and approx_expr_min env e = approx_expr Over env e |> IntSet.min_elt (* End *) (* Begin ApproxExprMax *) and approx_expr_max env e = approx_expr Over env e |> IntSet.max_elt (* End *) end (* Begin SymDomIsSubset *) let is_subset env is1 is2 = let () = if false then Format.eprintf "Is %a a subset of %a?@." pp is1 pp is2 in let open StaticApprox in (match (is1, is2) with | _, Top -> true | Top, _ -> false | Finite ints1, Finite ints2 -> IntSet.(is_empty (diff ints1 ints2)) | FromSyntax cs1, FromSyntax cs2 -> ( constraints_equal env cs1 cs2 || try let s1 = approx_constraints Over env cs1 and s2 = approx_constraints Under env cs2 in IntSet.subset s1 s2 with CannotOverApproximate -> false) | Finite s1, FromSyntax cs2 -> let s2 = approx_constraints Under env cs2 in IntSet.subset s1 s2 | FromSyntax cs1, Finite s2 -> ( try let s1 = approx_constraints Over env cs1 in IntSet.subset s1 s2 with CannotOverApproximate -> false)) |: TypingRule.SymDomIsSubset (* End *) end (* --------------------------------------------------------------------------*) let is_bits_width_fixed env ty = match ty.desc with | T_Bits _ -> ( let open Domain in match of_type env ty with | Finite int_set -> IntSet.cardinal int_set = Z.one | Top -> false | _ -> failwith "Wrong domain for a bitwidth.") | _ -> failwith "Wrong type for some bits." let _is_bits_width_constrained env ty = not (is_bits_width_fixed env ty) (* --------------------------------------------------------------------------*) (* Begin Subtype *) let rec subtypes_names env s1 s2 = if String.equal s1 s2 then true else match IMap.find_opt s1 env.SEnv.global.subtypes with | None -> false | Some s1' -> subtypes_names env s1' s2 let subtypes env t1 t2 = (match (t1.desc, t2.desc) with | T_Named s1, T_Named s2 -> subtypes_names env s1 s2 | _ -> false) |: TypingRule.Subtype (* End Subtype *) let rec bitfields_included env bfs1 bfs2 = let rec mem_bfs bfs2 bf1 = match find_bitfield_opt (bitfield_get_name bf1) bfs2 with | None -> false | Some (BitField_Simple _ as bf2) -> bitfield_equal env bf1 bf2 | Some (BitField_Nested (name2, slices2, bfs2') as bf2) -> ( match bf1 with | BitField_Simple _ -> bitfield_equal env bf1 bf2 | BitField_Nested (name1, slices1, bfs1) -> String.equal name1 name2 && slices_equal env slices1 slices2 && incl_bfs bfs1 bfs2' | BitField_Type _ -> false) | Some (BitField_Type (name2, slices2, ty2) as bf2) -> ( match bf1 with | BitField_Simple _ -> bitfield_equal env bf1 bf2 | BitField_Nested _ -> false | BitField_Type (name1, slices1, ty1) -> String.equal name1 name2 && slices_equal env slices1 slices2 && subtype_satisfies env ty1 ty2) and incl_bfs bfs1 bfs2 = List.for_all (mem_bfs bfs2) bfs1 in incl_bfs bfs1 bfs2 (* Begin TypingRule.SubtypeSatisfaction *) and subtype_satisfies env t s = (* A type T subtype-satisfies type S if and only if all of the following conditions hold: *) (match ((make_anonymous env s).desc, (make_anonymous env t).desc) with (* If S has the structure of an integer type then T must have the structure of an integer type. *) | T_Int _, T_Int _ -> let d_s = Domain.of_type env s and d_t = Domain.of_type env t in let () = if false then Format.eprintf "domain_subtype_satisfies: %a included in %a?@." Domain.pp d_t Domain.pp d_s in Domain.is_subset env d_t d_s (* If S has the structure of a real/string/bool then T must have the same structure. *) | ( ((T_Real | T_String | T_Bool) as s_anon), ((T_Real | T_String | T_Bool) as t_anon) ) -> s_anon = t_anon (* If S has the structure of an enumeration type then T must have the structure of an enumeration type with exactly the same enumeration literals. *) | T_Enum li_s, T_Enum li_t -> list_equal String.equal li_s li_t (* • If S has the structure of a bitvector type then T must have the structure of a bitvector type of the same width. • If S has the structure of a bitvector type which has bitfields then T must have the structure of a bitvector type of the same width and for every bitfield in S there must be a bitfield in T of the same name, width and offset, whose type type-satisfies the bitfield in S. *) | T_Bits (w_s, bf_s), T_Bits (w_t, bf_t) -> let bitfields_subtype = bitfields_included env bf_s bf_t in let widths_subtype = let t_width_domain = Domain.of_width_expr env w_t and s_width_domain = Domain.of_width_expr env w_s in let () = if false then Format.eprintf "Is %a included in %a?@." Domain.pp t_width_domain Domain.pp s_width_domain in Domain.is_subset env t_width_domain s_width_domain in bitfields_subtype && widths_subtype (* If S has the structure of an array type with elements of type E then T must have the structure of an array type with elements of type E, and T must have the same element indices as S. *) | T_Array (length_s, ty_s), T_Array (length_t, ty_t) -> ( type_equal env ty_s ty_t && match (length_s, length_t) with | ArrayLength_Expr length_expr_s, ArrayLength_Expr length_expr_t -> expr_equal env length_expr_s length_expr_t | ArrayLength_Enum (name_s, _), ArrayLength_Enum (name_t, _) -> String.equal name_s name_t | ArrayLength_Enum (_, _), ArrayLength_Expr _ | ArrayLength_Expr _, ArrayLength_Enum (_, _) -> false) (* If S has the structure of a tuple type then T must have the structure of a tuple type with same number of elements as S, and each element in T must type-satisfy the corresponding element in S.*) | T_Tuple li_s, T_Tuple li_t -> List.compare_lengths li_s li_t = 0 && List.for_all2 (type_satisfies env) li_t li_s (* If S has the structure of an exception type then T must have the structure of an exception type with at least the same fields (each with the same type) as S. If S has the structure of a record type then T must have the structure of a record type with at least the same fields (each with the same type) as S. *) | T_Exception fields_s, T_Exception fields_t | T_Record fields_s, T_Record fields_t -> List.for_all (fun (name_s, ty_s) -> List.exists (fun (name_t, ty_t) -> String.equal name_s name_t && type_equal env ty_s ty_t) fields_t) fields_s | T_Named _, _ -> assert false | _, _ -> false) |: TypingRule.SubtypeSatisfaction (* End *) (* Begin TypeSatisfaction *) and type_satisfies env t s = ((* Type T type-satisfies type S if and only if at least one of the following conditions holds: *) (* T is a subtype of S *) subtypes env t s (* T subtype-satisfies S and at least one of S or T is an anonymous type *) || ((is_anonymous t || is_anonymous s) && subtype_satisfies env t s) || (* T is an anonymous bitvector with no bitfields and S has the structure of a bitvector (with or without bitfields) of the same width as T. *) (* Here we interpret "same width" as statically the same width *) match (t.desc, (get_structure env s).desc) with | T_Bits (width_t, []), T_Bits (width_s, _) -> bitwidth_equal env width_t width_s | _ -> false) |: TypingRule.TypeSatisfaction (* End *) (* --------------------------------------------------------------------------*) (* Begin TypeClash *) let rec type_clashes env t s = (* Definition VPZZ: A type T type-clashes with S if any of the following hold: • they both have the structure of integers • they both have the structure of reals • they both have the structure of strings • they both have the structure of enumeration types with the same enumeration literals • they both have the structure of bitvectors • they both have the structure of arrays whose element types type-clash • they both have the structure of tuples of the same length whose corresponding element types type-clash • S is either a subtype or a supertype of T *) (* We will add a rule for boolean and boolean. *) ((subtypes env s t || subtypes env t s) || let s_struct = get_structure env s and t_struct = get_structure env t in match (s_struct.desc, t_struct.desc) with | T_Int _, T_Int _ | T_Real, T_Real | T_String, T_String | T_Bits _, T_Bits _ | T_Bool, T_Bool -> true | T_Enum li_s, T_Enum li_t -> list_equal String.equal li_s li_t | T_Array (_, ty_s), T_Array (_, ty_t) -> type_clashes env ty_s ty_t | T_Tuple li_s, T_Tuple li_t -> List.compare_lengths li_s li_t = 0 && List.for_all2 (type_clashes env) li_s li_t | _ -> false) |: TypingRule.TypeClash (* End *) let subprogram_clashes env (f1 : func) (f2 : func) = (* Two subprograms clash if all of the following hold: • they have the same name • they are the same kind of subprogram • they have the same number of formal arguments • every formal argument in one type-clashes with the corresponding formal argument in the other TODO: they are the same kind of subprogram *) String.equal f1.name f2.name && List.compare_lengths f1.args f2.args = 0 && List.for_all2 (fun (_, t1) (_, t2) -> type_clashes env t1 t2) f1.args f2.args (* --------------------------------------------------------------------------*) let supertypes_set (env : env) = let rec aux acc x = let acc = ISet.add x acc in match IMap.find_opt x env.global.subtypes with | Some x' -> aux acc x' | None -> acc in aux ISet.empty let find_named_lowest_common_supertype env x1 x2 = (* TODO: Have a better algorithm? This is in O(h * log h) because set insertions are in O (log h), where h is the max height of the subtype tree. Wikipedia says it is in O(h) generally, and it can be precomputed, in which case it becomes O(1). *) let set1 = supertypes_set env x1 in let rec aux x = if ISet.mem x set1 then Some x else match IMap.find_opt x env.global.subtypes with | None -> None | Some x' -> aux x' in aux x2 (* [unpack_options li] is [Some [x1; ... x_n]] if [li] is [[Some x1; ... Some x_n]], [None] otherwise *) let unpack_options li = let exception NoneFound in let unpack_one = function Some elt -> elt | None -> raise NoneFound in try Some (List.map unpack_one li) with NoneFound -> None (* Begin LowestCommonAncestor *) let rec lowest_common_ancestor env s t = let ( let+ ) o f = Option.map f o in (* The lowest common ancestor of types S and T is: *) (match (s.desc, t.desc) with | _, _ when type_equal env s t -> (* • If S and T are the same type: S (or T). *) Some s | T_Named name_s, T_Named name_t -> ( (* If S and T are both named types: the (unique) common supertype of S and T that is a subtype of all other common supertypes of S and T. *) match find_named_lowest_common_supertype env name_s name_t with | Some name -> Some (T_Named name |> add_dummy_annotation) | None -> let anon_s = make_anonymous env s and anon_t = make_anonymous env t in lowest_common_ancestor env anon_s anon_t) | _, T_Named _ | T_Named _, _ -> let anon_s = make_anonymous env s and anon_t = make_anonymous env t in if type_equal env anon_s anon_t then Some (match s.desc with T_Named _ -> s | _ -> t) else lowest_common_ancestor env anon_s anon_t | T_Int _, T_Int UnConstrained | T_Int UnConstrained, T_Int _ -> (* If either S or T is an unconstrained integer type: the unconstrained integer type. *) Some integer | T_Int _, T_Int (Parameterized _) | T_Int (Parameterized _), T_Int _ -> lowest_common_ancestor env (to_well_constrained s) (to_well_constrained t) | T_Int (WellConstrained cs_s), T_Int (WellConstrained cs_t) -> (* If S and T both are well-constrained integer types: the well-constrained integer type with domain the union of the domains of S and T. *) (* TODO: simplify domains ? If domains use a form of diets, this could be more efficient. *) Some (add_dummy_annotation (T_Int (WellConstrained (cs_s @ cs_t)))) | T_Bits (e_s, _), T_Bits (e_t, _) when expr_equal env e_s e_t -> (* We forget the bitfields if they are not equal. *) Some (T_Bits (e_s, []) |> add_dummy_annotation) | T_Array (width_s, ty_s), T_Array (width_t, ty_t) when array_length_equal env width_s width_t -> let+ t = lowest_common_ancestor env ty_s ty_t in T_Array (width_s, t) |> add_dummy_annotation | T_Tuple li_s, T_Tuple li_t when List.compare_lengths li_s li_t = 0 -> (* If S and T both are tuple types with the same number of elements: the tuple type with the type of each element the lowest common ancestor of the types of the corresponding elements of S and T. *) let+ li = List.map2 (lowest_common_ancestor env) li_s li_t |> unpack_options in add_dummy_annotation (T_Tuple li) | _ -> None) |: TypingRule.LowestCommonAncestor (* End *) herd-herdtools7-1ca343e/asllib/types.mli000066400000000000000000000120471475314470400202630ustar00rootroot00000000000000(******************************************************************************) (* ASLRef *) (******************************************************************************) (* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) (** Type Algebra *) (** Types are defined as {!type:AST.ty}. This should map pretty-well with the current version of the Language Reference Manual. *) open AST type env = StaticEnv.env (** {1 Predicates on types} *) val is_builtin : ty -> bool val is_builtin_singular : ty -> bool val is_builtin_aggregate : ty -> bool (** Note that a builtin type is either builtin aggregate or builtin singular. *) val is_singular : env -> ty -> bool val is_aggregate : env -> ty -> bool (** Note that a type is either singular or aggregate. *) val is_named : ty -> bool (** Types declared using the [type] syntax. *) val is_anonymous : ty -> bool (** Those not declared using †he [type] syntax. *) (** Note that a type is either builtin, named or anonymous. *) val is_primitive : ty -> bool (** Types that only use the builtin types. *) val is_non_primitive : ty -> bool (** Types that are named types or which make use of named types. Usually for all [ty]: {[ is_non_primitive ty = not (is_primitive ty) ]} *) (** {1 Relations on types} *) (** {2 Type transformations} *) val make_anonymous : env -> ty -> ty (** Replace any named type by its declared type in the environment. *) val get_structure : env -> ty -> ty (** The structure of a type is the primitive type that can hold the same values. *) val parameterized_ty : identifier -> ty (** Builds an parameterized integer type from a declared variable. *) val to_well_constrained : ty -> ty (** Transform a parameterized integer type into a well-constrained integer equal to the parameter that have this type, and leave the other types (such as well-constrained integers) as they are. *) val get_well_constrained_structure : env -> ty -> ty (** [get_well_constrained_structure env ty] quivalent to [get_structure env ty |> to_well_constrained]. *) (** {2 Domains} *) (** The domain of a type is the symbolic representation of the set of values which storage element of that type may hold. *) module Domain : sig type t (** Abstract value set. *) val pp : Format.formatter -> t -> unit (** A printer for the domain type. *) val of_type : env -> ty -> t (** Construct the domain of a type. *) val mem : AST.literal -> t -> bool (** [mem v d] is true if and only if [v] is in [d]. *) val equal : t -> t -> bool (** Wheather two domains are equal. *) val compare : t -> t -> int option (** The inclusion order on domains. It is a partial order. *) end (** {2 Orders on types} *) val subtypes : env -> ty -> ty -> bool (** [subtypes env t1 t2] is true if and only if [t1] is a declared subtype of [t2]. *) val subtypes_names : env -> identifier -> identifier -> bool (** [subtypes_names env s1 s2] is true if and only if the type named [s1] is a declared subtype of the type named [s2]. Equivalent to [subtypes env (T_Named s1 |> here) (T_Named s2 |> here)]. *) val subtype_satisfies : env -> ty -> ty -> bool (** Subtype-satisfation as per Definition TRVR. *) val type_satisfies : env -> ty -> ty -> bool (** Type-satisfation as per Rule FMXK. *) val type_clashes : env -> ty -> ty -> bool (** Type-clashing relation. Notes: - T subtype-satisfies S implies T and S type-clash - This is an equivalence relation per Definition VPZZ. *) val subprogram_clashes : env -> func -> func -> bool (** Subprogram clashing relation. per Definition BTBR. *) val lowest_common_ancestor : env -> ty -> ty -> ty option (** Lowest common ancestor. As per Rule YZHM. *) val type_equal : env -> ty -> ty -> bool (** Equality in env for types. *) herd-herdtools7-1ca343e/defs.sh000066400000000000000000000001421475314470400164140ustar00rootroot00000000000000set -o errexit VERSION=$(cat VERSION.txt) REV=$(git rev-parse HEAD 2>/dev/null || echo exported) herd-herdtools7-1ca343e/dune000066400000000000000000000005231475314470400160200ustar00rootroot00000000000000(dirs :standard \ catalogue carpenter) (env (release (flags (:standard -w +a-3-4-9-29-33-41-45-60-67-70))) (dev (flags (:standard -warn-error +A -w +a-3-4-9-29-33-41-45-60-67-70)))) (alias (name default) (deps (alias install) (alias internal/all))) (alias (name jerd) (deps (alias herd-www/all))) (documentation) herd-herdtools7-1ca343e/dune-install.sh000077500000000000000000000014101475314470400200740ustar00rootroot00000000000000#!/bin/sh set -eu if [ "$#" -ne 1 ] then readonly this="${0}" echo "Usage: ${this} " echo echo "For example '${this} /home/john/.local' will copy:" echo " * executables into /home/john/.local/bin" echo " * library files into /home/john/.local/share/herdtools7" exit 1 fi readonly prefix="${1}" readonly libdir="${prefix}/share/herdtools7" . ./defs.sh cpdir () { if [ "$#" -ne 2 ] then echo "Usage: cpdir " exit 1 fi local from="${1}" local to="${2}" rm -rf "${to}" && mkdir -p "${to}" && ( cd "${from}" && cp -r . "${to}" ) } # Copy binaries dune install --prefix "${prefix}" # Copy libfiles cpdir herd/libdir "${libdir}/herd" cpdir litmus/libdir "${libdir}/litmus" cpdir jingle/libdir "${libdir}/jingle" herd-herdtools7-1ca343e/dune-project000066400000000000000000000001031475314470400174560ustar00rootroot00000000000000(lang dune 2.7) (name herdtools7) (using menhir 2.0) (cram enable) herd-herdtools7-1ca343e/dune-uninstall.sh000077500000000000000000000010571475314470400204460ustar00rootroot00000000000000#!/bin/sh set -eu if [ "$#" -ne 1 ] then readonly this="${0}" echo "Usage: ${this} " echo echo "For example '${this} /home/john/.local' will remove:" echo " * executables from /home/john/.local/bin" echo " * delete the directory /home/john/.local/share/herdtools7" exit 1 fi readonly prefix="${1}" readonly bindir="${prefix}/bin" readonly libdir="${prefix}/share/herdtools7" # Print out the commands that this script runs. set -x # Remove binaries dune uninstall --prefix "${prefix}" # Remove libfiles rm -rf "${libdir}" herd-herdtools7-1ca343e/dune-workspace.versions000066400000000000000000000004671475314470400216720ustar00rootroot00000000000000(lang dune 2.0) (context (opam (switch 4.08.1))) (context (opam (switch 4.09.0))) (context (opam (switch 4.10.0))) (context (opam (switch 4.11.2))) (context (opam (switch 4.12.1))) (context (opam (switch 4.13.1))) (context (opam (switch 4.14.1))) (context (opam (switch 5.0.0))) (context (opam (switch 5.1.1))) herd-herdtools7-1ca343e/gen/000077500000000000000000000000001475314470400157135ustar00rootroot00000000000000herd-herdtools7-1ca343e/gen/AArch64Arch_gen.ml000066400000000000000000000574171475314470400210420ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Config = struct let naturalsize = MachSize.Word let moreedges = false let fullmixed = false let variant _ = false end module Make (C:sig val naturalsize : MachSize.sz val moreedges : bool val fullmixed : bool val variant : Variant_gen.t -> bool end) = struct let do_self = C.variant Variant_gen.Self let do_tag = C.variant Variant_gen.MemTag let do_morello = C.variant Variant_gen.Morello let do_fullkvm = C.variant Variant_gen.FullKVM let do_kvm = do_fullkvm || C.variant Variant_gen.KVM let do_neon = C.variant Variant_gen.Neon let do_sve = C.variant Variant_gen.SVE let do_sme = C.variant Variant_gen.SME let do_mixed = Variant_gen.is_mixed C.variant let do_cu = C.variant Variant_gen.ConstrainedUnpredictable open Code open Printf include MakeAArch64Base.Make(struct let is_morello = do_morello end) (* Little endian *) let tr_endian = Misc.identity module ScopeGen = ScopeGen.NoGen (* Mixed size *) module Mixed = MachMixed.Make (struct let naturalsize = Some C.naturalsize let fullmixed = C.fullmixed end) (* AArch64 has more atoms that others *) let bellatom = false module SIMD = struct type atom = SmV|SmH |SvV|Sv1|Sv2i|Sv3i|Sv4i |NeP|NeAcqPc|NeRel|Ne1|Ne2|Ne3|Ne4|Ne2i|Ne3i|Ne4i|NePa|NePaN let fold_neon f r = r |> f NeAcqPc |> f NeRel |> f NeP |> f NePa |> f NePaN |> f Ne1 |> f Ne2 |> f Ne3 |> f Ne4 |> f Ne2i |> f Ne3i |> f Ne4i let fold_sve f r = r |> f SvV |> f Sv1 |> f Sv2i |> f Sv3i |> f Sv4i let fold_sme f r = r |> f SmV |> f SmH let nregs = function | SmV | SmH | SvV | Sv1 | Ne1 -> 1 | Sv2i | Ne2 | Ne2i -> 2 | Sv3i | Ne3 | Ne3i -> 3 | Sv4i | Ne4 | Ne4i -> 4 | _ -> 1 let nelements = function | SmV|SmH | SvV|Sv1|Sv2i|Sv3i|Sv4i | Ne1|Ne2|Ne2i|Ne3|Ne3i|Ne4|Ne4i -> 4 | NePa|NePaN -> 2 | NeP | NeAcqPc | NeRel -> 1 let pp_opt = function | Sv2i | Sv3i | Sv4i | Ne2i | Ne3i | Ne4i -> "i" | _ -> "" let pp n = match n with | Ne1 | Ne2 | Ne3 | Ne4 | Ne2i | Ne3i | Ne4i -> Printf.sprintf "Ne%i%s" (nregs n) (pp_opt n) | Sv1 | Sv2i | Sv3i | Sv4i -> Printf.sprintf "Sv%i%s" (nregs n) (pp_opt n) | SmV -> "SmV" | SmH-> "SmH" | SvV -> "SvV" | NePa -> "NePa" | NePaN -> "NePaN" | NeP -> "NeP" | NeAcqPc -> "NeQ" | NeRel -> "NeL" let initial sz = let sz = if sz <= 0 then 1 else sz in Array.make sz 0 let step n start v = let start = start+1 in let el = nelements n in let sz = nregs n in let v = Array.copy v in for k = 0 to sz-1 do for i=0 to el-1 do let j = match n with | SmV |Sv2i | Sv3i | Sv4i | Ne2i | Ne3i | Ne4i -> k+i*sz | NeP | NeAcqPc | NeRel | NePa | NePaN | Ne1 | Ne2 | Ne3 | Ne4 | SmH | SvV | Sv1 -> i+k*el in v.(j) <- start+k done done ; v let read n v = let el = nelements n in let sz = nregs n in let access r k = match n with | SmV | Sv2i | Sv3i | Sv4i | Ne2i | Ne3i | Ne4i -> sz*k + r | NeP | NeAcqPc | NeRel | NePa | NePaN | Ne1 | Ne2 | Ne3 | Ne4 | SmH | SvV | Sv1 -> el*r + k in let rec reg r k = if k >= el then [] else v.(access r k)::reg r (k+1) in let rec regs r = if r >= sz then [] else reg r 0::regs (r+1) in regs 0 let reduce vec = List.fold_right (+) (List.flatten vec) 0 end type atom_rw = PP | PL | AP | AL type capa = Capability type capa_opt = capa option module WPTE = struct type t = AF | DB | OA | DBM | VALID let all= [AF; DB; OA; DBM; VALID;] let compare w1 w2 = match w1,w2 with | (AF,AF) | (DB,DB) | (OA,OA) | (DBM,DBM) | (VALID,VALID) -> 0 | (AF,(DB|OA|DBM|VALID)) | (DB,(OA|DBM|VALID)) | (OA,(DBM|VALID)) | (DBM,VALID) -> -1 | ((DB|OA|DBM|VALID),AF) | ((OA|DBM|VALID),DB) | ((DBM|VALID),OA) | (VALID,DBM) -> 1 let pp = function | AF -> "AF" | DB -> "DB" | DBM -> "DBM" | VALID -> "VA" | OA -> "OA" end module WPTESet = MySet.Make(WPTE) type atom_pte = | Read|ReadAcq|ReadAcqPc | Set of WPTESet.t | SetRel of WPTESet.t type neon_opt = SIMD.atom type pair_idx = Both type atom_acc = | Plain of capa_opt | Acq of capa_opt | AcqPc of capa_opt | Rel of capa_opt | Atomic of atom_rw | Tag | CapaTag | CapaSeal | Pte of atom_pte | Neon of neon_opt | Pair of pair_opt * pair_idx | Instr let plain = Plain None type atom = atom_acc * MachMixed.t option let default_atom = Atomic PP,None let instr_atom = Some (Instr,None) let applies_atom (a,_) d = match a,d with | Neon SIMD.NeAcqPc,W | Neon SIMD.NeRel,R -> false | Acq _,R | AcqPc _,R | Rel _,W | Pte (Read|ReadAcq|ReadAcqPc),R | Pte (Set _|SetRel _),W | Instr, R | (Plain _|Atomic _|Tag|CapaTag|CapaSeal|Neon _|Pair _),(R|W) -> true | _ -> false let is_ifetch a = match a with | Some (Instr,_) -> true | _ -> false let pp_plain = "P" (* Annotation A is taken by load aquire *) let pp_as_a = None let pp_atom_rw = function | PP -> "" | PL -> "L" | AP -> "A" | AL -> "AL" let pp_opt = function | None -> "" | Some Capability -> "c" let pp_w_pte ws = WPTESet.pp_str "." WPTE.pp ws let pp_atom_pte = function | Read -> "" | ReadAcq -> "A" | ReadAcqPc -> "Q" | Set set -> pp_w_pte set | SetRel set -> pp_w_pte set ^"L" let pp_pair_opt = function | Pa -> "" | PaN -> "N" | PaI -> "I" and pp_pair_idx = function | Both -> "" let pp_atom_acc = function | Atomic rw -> sprintf "X%s" (pp_atom_rw rw) | Rel o -> sprintf "L%s" (pp_opt o) | Acq o -> sprintf "A%s" (pp_opt o) | AcqPc o -> sprintf "Q%s" (pp_opt o) | Plain o -> sprintf "P%s" (pp_opt o) | Tag -> "T" | CapaTag -> "Ct" | CapaSeal -> "Cs" | Pte p -> sprintf "Pte%s" (pp_atom_pte p) | Neon n -> SIMD.pp n | Pair (opt,idx) -> sprintf "Pa%s%s" (pp_pair_opt opt) (pp_pair_idx idx) | Instr -> "I" let pp_atom (a,m) = match a with | Plain o -> let prefix = match o with | None -> "" | Some Capability -> "Pc" in begin match m with | None -> prefix | Some m -> if String.length prefix > 0 then sprintf "%s.%s" prefix (Mixed.pp_mixed m) else Mixed.pp_mixed m end | _ -> let pp_acc = pp_atom_acc a in match m with | None -> pp_acc | Some m -> sprintf "%s.%s" pp_acc (Mixed.pp_mixed m) let compare_atom = compare let equal_atom a1 a2 = a1 = a2 include MachMixed.Util (struct type at = atom_acc let plain = plain end) let fold_mixed f r = if do_mixed then Mixed.fold_mixed (fun m r -> f (Plain None,Some m) r) r else r let fold_all_subsets f = let rec fold_rec xs k r = match xs with | [] -> if WPTESet.is_empty k then r else f k r | x::xs -> let r = fold_rec xs (WPTESet.add x k) r in fold_rec xs k r in fold_rec WPTE.all WPTESet.empty let fold_small_subsets f = let rec fold_rec xs r = match xs with | [] -> r | x::xs -> let sx = WPTESet.singleton x in List.fold_right (fun y r -> f (WPTESet.add y sx) r) xs (f sx (fold_rec xs r)) in fold_rec WPTE.all let fold_subsets = if do_fullkvm then fold_all_subsets else fold_small_subsets let fold_pte f r = if do_kvm then let g fs r = f (Set fs) (f (SetRel fs) r) in let r = fold_subsets g r in f Read (f ReadAcq (f ReadAcqPc r)) else r let fold_atom_rw f r = f PP (f PL (f AP (f AL r))) let fold_tag = if do_tag then fun f r -> f Tag r else fun _f r -> r let fold_morello = if do_morello then fun f r -> f CapaSeal (f CapaTag r) else fun _f r -> r let fold_neon = if do_neon then fun f -> SIMD.fold_neon (fun n -> f (Neon n)) else fun _ r -> r let fold_sve = if do_sve then fun f -> SIMD.fold_sve (fun n -> f (Neon n)) else fun _ r -> r let fold_sme = if do_sme then fun f -> SIMD.fold_sme (fun n -> f (Neon n)) else fun _ r -> r let fold_pair f r = if do_mixed then r else let f opt idx r = f (Pair (opt,idx)) r in r |> f Pa Both |> f PaN Both |> f PaI Both let fold_acc_opt o f r = let r = f (Acq o) r in let r = f (AcqPc o) r in let r = f (Rel o) r in r let fold_self f r = if do_self then f Instr r else r let fold_acc mixed f r = let r = if mixed then r else fold_pte (fun p r -> f (Pte p) r) r in let r = fold_morello f r in let r = fold_tag f r in let r = fold_neon f r in let r = fold_sve f r in let r = fold_sme f r in let r = fold_pair f r in let r = fold_acc_opt None f r in let r = fold_self f r in let r = if do_morello then let r = f (Plain (Some Capability)) r in let r = fold_acc_opt (Some Capability) f r in r else r in let r = fold_atom_rw (fun rw -> f (Atomic rw)) r in r let fold_non_mixed f r = fold_acc false (fun acc r -> f (acc,None) r) r let fold_atom f r = let r = fold_non_mixed f r in if do_mixed then fold_acc true (fun acc r -> Mixed.fold_mixed (fun m r -> f (acc,Some m) r) r) (Mixed.fold_mixed (fun m r -> f (Plain None,Some m) r) r) else r let worth_final (a,_) = match a with | Atomic _ -> true | Acq _|AcqPc _|Rel _|Plain _|Tag|Instr | CapaTag|CapaSeal | Pte _|Neon _ | Pair _ -> false let varatom_dir _d f r = f None r let merge_atoms a1 a2 = match a1,a2 with (* Plain and Instr do not merge *) | ((Plain _,_),(Instr,_)) | ((Instr,_),(Plain _,_)) -> None (* Eat Plain *) | ((Plain None,None),a) | (a,(Plain None,None)) -> Some a (* Add size to ordinary annotations *) | ((Plain None,(Some _ as sz)), ((Acq None|AcqPc None|Rel None|Atomic _ as a),None)) | (((Acq None|AcqPc None|Rel None|Atomic _ as a),None), (Plain None,(Some _ as sz))) -> Some (a,sz) (* No sizes for Pte and tags *) | (((Pte _|Tag),_),(_,Some _)) | ((_,Some _),((Pte _|Tag),_)) -> None (* Merge Pte *) | ((Pte (Read|ReadAcq),None),((Pte ReadAcq|Acq None),None)) | (((Acq None|Pte ReadAcq),None),(Pte (Read|ReadAcq),None)) -> Some (Pte ReadAcq,None) | ((Pte (Read|ReadAcqPc),None),((Pte ReadAcqPc|AcqPc None),None)) | (((Pte ReadAcqPc|AcqPc None),None),(Pte (Read|ReadAcqPc),None)) -> Some (Pte ReadAcqPc,None) | ((Pte (Set set|SetRel set),None),(Rel None,None)) | ((Rel None,None),(Pte (Set set|SetRel set),None)) -> Some (Pte (SetRel set),None) | (Pte (Set set1),None),(Pte (Set set2),None) -> Some (Pte (Set (WPTESet.union set1 set2)),None) | ((Pte (Set set1),None),(Pte (SetRel set2),None)) | ((Pte (SetRel set1),None),(Pte (Set set2),None)) | ((Pte (SetRel set1),None),(Pte (SetRel set2),None)) -> Some (Pte (SetRel (WPTESet.union set1 set2)),None) (* Add size when (ordinary) annotation equal *) | ((Acq None as a,None),(Acq None,(Some _ as sz))) | ((Acq None as a,(Some _ as sz)),(Acq None,None)) | ((AcqPc None as a,None),(AcqPc None,(Some _ as sz))) | ((AcqPc None as a,(Some _ as sz)),(AcqPc None,None)) | ((Rel None as a,None),(Rel None,(Some _ as sz))) | ((Rel None as a,(Some _ as sz)),(Rel None,None)) | ((Atomic PP as a,None),(Atomic PP,(Some _ as sz))) | ((Atomic PP as a,(Some _ as sz)),(Atomic PP,None)) | ((Atomic AP as a,None),(Atomic AP,(Some _ as sz))) | ((Atomic AP as a,(Some _ as sz)),(Atomic AP,None)) | ((Atomic PL as a,None),(Atomic PL,(Some _ as sz))) | ((Atomic PL as a,(Some _ as sz)),(Atomic PL,None)) | ((Atomic AL as a,None),(Atomic AL,(Some _ as sz))) | ((Atomic AL as a,(Some _ as sz)),(Atomic AL,None)) -> Some (a,sz) (* Remove plain when size equal *) | ((Plain None,sz1),(a,sz2)) | ((a,sz1),(Plain None,sz2)) when sz1=sz2 -> Some (a,sz1) | _,_ -> if equal_atom a1 a2 then Some a1 else None let overlap_atoms a1 a2 = match a1,a2 with | ((_,None),(_,_))|((_,_),(_,None)) -> true | ((_,Some sz1),(_,Some sz2)) -> MachMixed.overlap sz1 sz2 let neon_as_integers = let open SIMD in function | NeP | NeAcqPc | NeRel -> 1 | NePa | NePaN -> 2 | SmV | SmH | SvV | Sv1 | Ne1 -> 4 | Sv2i | Ne2 | Ne2i -> 8 | Sv3i | Ne3 | Ne3i -> 12 | Sv4i | Ne4 | Ne4i -> 16 let atom_to_bank = function | Tag,None -> Code.Tag | Pte _,None -> Code.Pte | CapaTag,None -> Code.CapaTag | CapaSeal,None -> Code.CapaSeal | Neon n,None -> Code.VecReg n | Pair (_,Both),_ -> Code.Pair | Instr,_ -> Code.Instr | (Tag|CapaTag|CapaSeal|Pte _|Neon _),Some _ -> assert false | (Plain _|Acq _|AcqPc _|Rel _|Atomic _),_ -> Code.Ord (**************) (* Mixed size *) (**************) let tr_value ao v = match ao with | None| Some (_,None) -> v | Some (_,Some (sz,_)) -> Mixed.tr_value sz v module ValsMixed = MachMixed.Vals (struct let naturalsize () = C.naturalsize let endian = endian end) let overwrite_value v ao w = match ao with | None | Some ((Atomic _|Acq _|AcqPc _|Rel _|Plain _| Tag|CapaTag|CapaSeal|Pte _|Neon _|Pair _|Instr),None) -> w (* total overwrite *) | Some ((Atomic _|Acq _|AcqPc _|Rel _|Plain _|Neon _|Instr),Some (sz,o)) -> ValsMixed.overwrite_value v sz o w | Some ((Tag|CapaTag|CapaSeal|Pte _|Pair _),Some _) -> assert false let extract_value v ao = match ao with | None | Some ((Atomic _|Acq _|AcqPc _|Rel _|Plain _ |Tag|CapaTag|CapaSeal|Pte _|Neon _|Pair _|Instr),None) -> v | Some ((Atomic _|Acq _|AcqPc _|Rel _|Plain _|Tag|CapaTag|CapaSeal|Neon _),Some (sz,o)) -> ValsMixed.extract_value v sz o | Some ((Pte _|Pair _|Instr),Some _) -> assert false (* Page table entries *) module PteVal = struct type pte_atom = atom type t = AArch64PteVal.t let pp = AArch64PteVal.pp_v let default = AArch64PteVal.default let compare = AArch64PteVal.compare let do_setpteval a f p loc = let open AArch64PteVal in let fs = match f with | Set f|SetRel f -> f | Read|ReadAcq|ReadAcqPc -> Warn.user_error "Atom %s is not a pteval write" (pp_atom a) in WPTESet.fold (fun f p -> let open WPTE in match f with | AF -> { p with af = 1-p.af; } | DB -> { p with db = 1-p.db; } | DBM -> { p with dbm = 1-p.dbm; } | VALID -> { p with valid = 1-p.valid; } | OA -> { p with oa=OutputAddress.PHY (loc ()); }) fs p let set_pteval a p = match a with | Pte f,None -> do_setpteval a f p | _ -> Warn.user_error "Atom %s is not a pteval write" (pp_atom a) end (* Wide accesses *) let as_integers a = Misc.seq_opt (function | Neon n,_ -> (match neon_as_integers n with | 1 -> None | n -> Some n) | Pair _,_ -> Some 2 | _ -> None) a let is_pair a = match a with | Some (Pair _,_) -> true | Some _|None -> false (* End of atoms *) (**********) (* Fences *) (**********) type strength = Strong | Weak let fold_strength f r = f Strong (f Weak r) let fold_dirloc f r = f Next (f Prev r) type sync = Sync | NoSync type fence = | Barrier of barrier | CacheSync of strength * bool | Shootdown of mBReqDomain * TLBI.op * sync | CMO of syncType * dirloc let is_isync = function | Barrier ISB -> true | _ -> false let compare_fence b1 b2 = match b1,b2 with | (Barrier _,(CacheSync _|Shootdown _)) | (CacheSync _,Shootdown _) -> -1 | Barrier b1,Barrier b2 -> barrier_compare b1 b2 | CacheSync (s1,b1) ,CacheSync (s2,b2)-> begin match compare b1 b2 with | 0 -> compare s1 s2 | r -> r end | Shootdown (dom1,op1,sync1),Shootdown (dom2,op2,sync2) -> begin match compare dom1 dom2 with | 0 -> begin match compare op1 op2 with | 0 -> compare sync1 sync2 | r -> r end | r -> r end | (Shootdown _,(Barrier _|CacheSync _)) | (CacheSync _,Barrier _) | (CMO _,_) | (_, CMO _) -> +1 let default = Barrier (DMB (SY,FULL)) let strong = default let add_dot f x = match f x with | "" -> "" | s -> "." ^ s let pp_sync = function | NoSync -> "" | Sync -> "-sync" let pp_fence f = match f with | Barrier f -> do_pp_barrier "." f | CacheSync (s,isb) -> sprintf "CacheSync%s%s" (match s with Strong -> "Strong" | Weak -> "") (if isb then "Isb" else "") | Shootdown (d,op,sync) -> let tlbi = "TLBI" ^ pp_sync sync in sprintf "%s%s%s" tlbi (add_dot TLBI.short_pp_op op) (match sync with | NoSync -> "" | Sync -> add_dot pp_domain d) | CMO (t,loc) -> sprintf "%s%s" (match t with DC_CVAU -> "DC.CVAU" | IC_IVAU -> "IC.IVAU") (match loc with Prev -> "p"| Next -> "n") let fold_cumul_fences f k = do_fold_dmb_dsb do_kvm C.moreedges (fun b k -> f (Barrier b) k) k let fold_shootdown = if do_kvm then let fold_domain = if C.moreedges then fold_domain else fun f k -> f ISH k and fold_op = if C.moreedges then TLBI.full_fold_op else TLBI.fold_op in fun f k -> fold_op (fun op k -> fold_domain (fun d k -> f (Shootdown(d,op,Sync)) (f (Shootdown(d,op,NoSync)) k)) k) k else fun _f k -> k let fold_cachesync = if do_self then fun f -> Misc.fold_bool (fun b k -> fold_strength (fun s k -> f (CacheSync (s,b)) k) k) else fun _ k -> k let fold_cmo f k = fold_dirloc (fun d k -> f (CMO (DC_CVAU,d)) (f (CMO (IC_IVAU,d)) k)) k let fold_all_fences f k = let k = fold_shootdown f k in let k = fold_cachesync f k in let k = fold_cmo f k in fold_barrier do_kvm C.moreedges (fun b k -> f (Barrier b) k) k let fold_some_fences f k = let f = fun b k -> f (Barrier b) k in let k = f ISB k in let k = f (DMB (SY,FULL)) k in let k = f (DMB (SY,ST)) k in let k = f (DMB (SY,LD)) k in k let orders f d1 d2 = match f,d1,d2 with | Barrier ISB,_,_ -> false | Barrier (DSB (_,FULL)|DMB (_,FULL)),_,_ -> true | Barrier (DSB (_,ST)|DMB (_,ST)),W,W -> true | Barrier (DSB (_,ST)|DMB (_,ST)),_,_ -> false | Barrier (DSB (_,LD)|DMB (_,LD)),Code.R,(W|Code.R) -> true | Barrier (DSB (_,LD)|DMB (_,LD)),_,_ -> false | CacheSync _,_,_ -> true | Shootdown _,_,_ -> false | CMO _,_,_ -> true let var_fence f r = f default r (********) (* Deps *) (********) module D = Dep type csel = OkCsel|NoCsel type dp = D.dp * csel let fold_dpr f r = D.fold_dpr (fun d r -> f (d,NoCsel) (f (d,OkCsel) r)) r let fold_dpw f r = D.fold_dpw (fun d r -> f (d,NoCsel) (f (d,OkCsel) r)) r let pp_ddp = let open D in function | ADDR -> "Addr" | DATA -> "Data" | CTRL -> "Ctrl" | CTRLISYNC -> "CtrlIsb" let pp_dp (d,c) = match c with | NoCsel -> pp_ddp d | OkCsel -> pp_ddp d^"Csel" let lift_dd = Misc.app_opt (fun d -> d,NoCsel) let ddr_default = lift_dd D.ddr_default let ddw_default = lift_dd D.ddw_default let ctrlr_default = lift_dd D.ctrlr_default let ctrlw_default = lift_dd D.ctrlw_default let lift_pred p (d,_) = p d let is_ctrlr dc = lift_pred D.is_ctrlr dc let is_addr dc = lift_pred D.is_addr dc let fst_dp (d,c) = match c with | NoCsel -> List.map (fun d -> (d,NoCsel)) (D.fst_dp d) | OkCsel -> [] let sequence_dp (d1,c1) (d2,c2) = match c1 with | NoCsel -> List.map (fun d -> d,c2) (D.sequence_dp d1 d2) | OkCsel -> [] (* Read-Modify-Write *) type rmw = LrSc | LdOp of atomic_op | StOp of atomic_op | Swp | Cas type rmw_atom = atom (* Enforced by Rmw.S signature *) let pp_aop op = Misc.capitalize (Misc.lowercase (pp_aop op)) let pp_rmw compat = function | LrSc -> if compat then "Rmw" else "LxSx" | Swp -> "Amo.Swp" | Cas -> "Amo.Cas" | LdOp op -> sprintf "Amo.Ld%s" (pp_aop op) | StOp op -> sprintf "Amo.St%s" (pp_aop op) let is_one_instruction = function | LrSc -> false | LdOp _ | StOp _ | Swp | Cas -> true let fold_aop f r = let r = f A_ADD r in let r = f A_EOR r in let r = f A_SET r in let r = f A_CLR r in r let fold_rmw f r = let r = f LrSc r in let r = f Swp r in let r = f Cas r in let r = fold_aop (fun op r -> f (LdOp op) r) r in let r = fold_aop (fun op r -> f (StOp op) r) r in r let fold_rmw_compat f r = f LrSc r (* Check legal anotation for AMO instructions and LxSx pairs *) let ok_rw ar aw = match ar,aw with | (Some ((Acq _|Plain _),_)|None),(Some ((Rel _|Plain _),_)|None) -> true | _ -> false let ok_w ar aw = match ar,aw with | (Some (Plain _,_)|None),(Some ((Rel _|Plain _),_)|None) -> true | _ -> false let same_mixed (a1:atom option) (a2:atom option) = let a1 = get_access_atom a1 and a2 = get_access_atom a2 in Misc.opt_eq MachMixed.equal a1 a2 let applies_atom_rmw rmw ar aw = match rmw with | LrSc -> ok_rw ar aw && (do_cu || same_mixed ar aw) | Swp|Cas|LdOp _ -> ok_rw ar aw && same_mixed ar aw | StOp _ -> ok_w ar aw && same_mixed ar aw let show_rmw_reg = function | StOp _ -> false | LdOp _|Cas|Swp|LrSc -> true type arch_edge = IFF of ie | FIF of ie let pp_arch_edge = function | IFF ie -> sprintf "Iff%s" (pp_ie ie) | FIF ie -> sprintf "Fif%s" (pp_ie ie) let dir_tgt = function | IFF _ -> R | FIF _ -> W let dir_src = function | IFF _ -> W | FIF _ -> R let loc_sd (IFF _|FIF _) = Code.Same let get_ie e = match e with | IFF ie|FIF ie -> ie let fold_edge f r = Code.fold_ie (fun ie r -> f (IFF ie) (f (FIF ie) r)) r let compute_rmw r old co = match r with | LdOp op | StOp op -> begin match op with | A_ADD -> old + co | A_SMAX -> if old > co then old else co | A_UMAX -> let o = Int64.of_int old and c = Int64.of_int co in if Int64.unsigned_compare o c > 0 then old else co | A_SMIN -> if old < co then old else co | A_UMIN -> let o = Int64.of_int old and c = Int64.of_int co in if Int64.unsigned_compare o c < 0 then old else co | A_EOR -> old lxor co | A_SET -> old lor co | A_CLR -> old land (lnot co) end | LrSc | Swp | Cas -> co include ArchExtra_gen.Make (struct type arch_reg = reg let is_symbolic = function | Symbolic_reg _ -> true | _ -> false let pp_reg = pp_reg let pp_i = pp_i let free_registers = allowed_for_symb type special = reg type special2 = reg type special3 = int * reg let specials = vregs let specials2 = pregs let specials3 = zaslices end) end herd-herdtools7-1ca343e/gen/AArch64Compile_gen.ml000066400000000000000000003104241475314470400215430ustar00rootroot00000000000000(****************************************************************************) (* The diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Code module type Config = sig include CompileCommon.Config val moreedges : bool val realdep : bool end module Make(Cfg:Config) : XXXCompile_gen.S = struct let do_memtag = Cfg.variant Variant_gen.MemTag (* Common *) let naturalsize = TypBase.get_size Cfg.typ module A64 = AArch64Arch_gen.Make (struct let naturalsize = naturalsize let moreedges = Cfg.moreedges let fullmixed = Cfg.variant Variant_gen.FullMixed let variant = Cfg.variant end) include CompileCommon.Make(Cfg)(A64) let ppo _f k = k open A64 (* Nop instr code *) let nop = "NOP" (* Utilities *) (* Reserve SME's slice index register *) let x12 = Ireg R12 let next_reg x = if do_sme then begin let r,x = A64.alloc_reg x in match r with | Ireg R12 -> A64.alloc_reg x | _ -> r,x end else A64.alloc_reg x let next_reg2 x = let r1,x = next_reg x in let r2,x = next_reg x in r1,r2,x let to_scalar r = match r with | Vreg (r,(_,8)) -> A64.SIMDreg r | Vreg (r,(_,16)) -> A64.SIMDreg r | Vreg (r,(_,32)) -> A64.SIMDreg r | Vreg (r,(_,64)) -> A64.SIMDreg r | _ -> assert false (* ? *) let to_scalable_vec r = match r with | Vreg (r,(_,s)) -> A64.Zreg (r,s) | _ -> assert false (* ? *) let next_vreg x = A64.alloc_special x let next_scalar_reg x = let r,x = next_vreg x in to_scalar r,x let next_zreg x = let r,x = next_vreg x in to_scalable_vec r,x let next_preg x = A64.alloc_special2 x let with_mode m r = match r with | Preg (r,_) -> PMreg(r,m) | PMreg (r,_) -> PMreg(r,m) | _ -> assert false let with_direction dir r = match r with | ZAreg (tile,_,size) -> ZAreg (tile,Some dir,size) | _ -> assert false let next_zaslice n st = let dir = match n with | SIMD.SmV -> Vertical | SIMD.SmH -> Horizontal | _ -> assert false in let (i,r),st = A64.alloc_special3 st in with_direction dir r,i,st let pattern = function | 1 -> VL1 | 2 -> VL2 | 3 -> VL3 | 4 -> VL4 | 5 -> VL5 | 6 -> VL6 | 7 -> VL7 | 8 -> VL8 | _ -> assert false let pseudo = List.map (fun i -> Instruction i) let tempo1 st = A.alloc_trashed_reg "T1" st (* May be used for address *) let tempo2 st = A.alloc_trashed_reg "T2" st (* May be used for second address *) let tempo3 st = A.alloc_trashed_reg "T3" st (* May be used for STRX flag *) let tempo4 st = A.alloc_loop_idx "I4" st (* Loop observer index *) let emit_vregs = let rec call_rec n st = let r1,st = next_vreg st in let (r2,rs),st = get_reg_list n st in (r1,(r2::rs)),st and get_reg_list n st = let open SIMD in match n with | Ne1 | NePa | NePaN | NeP | NeAcqPc | NeRel -> let r,st = next_vreg st in (r,[]),st | Ne2 | Ne2i -> call_rec Ne1 st | Ne3 | Ne3i -> call_rec Ne2 st | Ne4 | Ne4i -> call_rec Ne3 st | _ -> assert false in fun n st -> let (r,rs),st = get_reg_list n st in (r,rs),A.set_friends r rs st let emit_zregs = let rec call_rec n st = let r1,st = next_zreg st in let (r2,rs),st = get_reg_list n st in (r1,(r2::rs)),st and get_reg_list n st = let open SIMD in match n with | Sv1 -> let r,st = next_zreg st in (r,[]),st | Sv2i -> call_rec Sv1 st | Sv3i -> call_rec Sv2i st | Sv4i -> call_rec Sv3i st | _ -> assert false in fun n st -> let (r,rs),st = get_reg_list n st in (r,rs),A.set_friends r rs st (******************) (* Idiosyncrasies *) (******************) let vloc = let open TypBase in let sz = match Cfg.typ with | Std (_,MachSize.S128) -> V128 | Std (_,MachSize.Quad) -> V64 | Int |Std (_,MachSize.Word) -> V32 | Std (_,(MachSize.Short|MachSize.Byte)) -> V32 | Pteval -> V64 in (* Minimum size is V64 with morello to reduce mixed-size gap with V128 *) if do_morello && sz = V32 then V64 else sz let sz2v = let open MachSize in function | Byte|Short|Word -> V32 | Quad -> V64 | S128 -> V128 and v2sz = let open MachSize in function | V128 -> S128 | V64 -> Quad | V32 -> Word let szloc = v2sz vloc let do_movi vdep r i = I_MOV (vdep,r,K i) let mov = do_movi vloc let mov_mixed sz r i = let sz = let open MachSize in match sz with | S128 -> Quad (* MOV C?,#X is not recognized *) | Byte|Short|Word|Quad -> sz in let v = sz2v sz in I_MOV (v,r,i) let mov_reg_addr r1 r2 = I_MOV (V64,r1,RV (V64,r2)) let mov_reg r1 r2 = I_MOV (vloc,r1,RV (vloc,r2)) let mov_reg_mixed sz r1 r2 = let v = sz2v sz in I_MOV (v,r1,RV (v,r2)) let movi_reg r1 i = I_MOVI_V (r1,i,S_NOEXT) module Extra = struct let use_symbolic = false type reg = A64.reg type instruction = A64.pseudo let mov r i = Instruction (mov r i) let mov_mixed sz r i = Instruction (mov_mixed sz r (K i)) let mov_reg r1 r2 = Instruction (mov_reg r1 r2) let mov_reg_mixed sz r1 r2 = Instruction (mov_reg_mixed sz r1 r2) end module U = GenUtils.Make(Cfg)(A)(Extra) let op3i v op r1 r2 i = let open OpExt in I_OP3 (v,op,r1,r2,Imm (i,0)) and op3r v op r1 r2 r3 = let open OpExt in I_OP3 (v,op,r1,r2,Reg (r3,no_shift)) let cbz r1 lbl = I_CBZ (vloc,r1,BranchTarget.Lbl lbl) let do_cbnz v r1 lbl = I_CBNZ (v,r1,BranchTarget.Lbl lbl) let cbnz = do_cbnz vloc let do_cmpi v r i = op3i v SUBS ZR r i let cmpi r i = do_cmpi vloc r i let do_csel v r1 r2 r3 = I_CSEL (v,r1,r2,r3,EQ,Cpy) let do_cinc v r1 r2 r3 = I_CSEL (v,r1,r2,r3,EQ,Inc) let cmp r1 r2 = op3r vloc SUBS ZR r1 r2 let b lbl = I_B (BranchTarget.Lbl lbl) let bne lbl = I_BC (NE,BranchTarget.Lbl lbl) let eor sz r1 r2 r3 = op3r sz EOR r1 r2 r3 let andi sz r1 r2 k = op3i sz AND r1 r2 k let incr r = op3i V32 ADD r r 1 let lsri64 r1 r2 k = op3i V64 LSR r1 r2 k let do_addi v r1 r2 k = op3i v ADD r1 r2 k let addi = do_addi vloc let addi_64 = do_addi V64 let add v r1 r2 r3 = op3r v ADD r1 r2 r3 let add_simd r1 r2 = I_ADD_SIMD (r1,r1,r2) let do_add64 v r1 r2 r3 = match v with | V64 -> add v r1 r2 r3 | _ -> let ext = Ext.v2sext v in I_ADDSUBEXT (V64,Ext.ADD,r1,r2,(v,r3),(ext, None)) let do_addcapa r1 r2 r3 = I_ADDSUBEXT (V128,Ext.ADD,r1,r2,(V64,r3),Ext.no_ext) let gctype r1 r2 = I_GC (GCTYPE,r1,r2) let gcvalue r1 r2 = I_GC (GCVALUE,r1,r2) let scvalue r1 r2 r3 = I_SC (SCVALUE,r1,r2,r3) let seal r1 r2 r3 = I_SEAL (r1,r2,r3) let cseal r1 r2 r3 = I_CSEAL (r1,r2,r3) let subi sz r1 r2 k = op3i sz SUB r1 r2 k let dec r1 r2 = subi vloc r1 r2 1 let ldr_mixed r1 r2 sz o = let idx = MemExt.Imm (o,Idx) in let open MachSize in match sz with | Byte -> I_LDRBH (B,r1,r2,idx) | Short -> I_LDRBH (H,r1,r2,idx) | Word -> I_LDR (V32,r1,r2,idx) | Quad -> I_LDR (V64,r1,r2,idx) | S128 -> I_LDR (V128,r1,r2,idx) let do_ldr v r1 r2 = I_LDR (v,r1,r2,MemExt.Imm(0,Idx)) let ldg r1 r2 = I_LDG (r1,r2,0) let ldct r1 r2 = I_LDCT(r1,r2) let do_ldar vr r1 r2 = I_LDAR (vr,AA,r1,r2) let do_ldapr vr r1 r2 = I_LDAR (vr,AQ,r1,r2) let ldxr r1 r2 = I_LDAR (vloc,XX,r1,r2) let ldaxr r1 r2 = I_LDAR (vloc,AX,r1,r2) let sxtw r1 r2 = I_SXTW (r1,r2) let do_ldr_idx v1 v2 r1 r2 idx = let open MemExt in let sext = match v2 with | V32 -> SXTW | V64|V128 -> LSL in I_LDR (v1,r1,r2,Reg (v2,idx,sext,0)) let ldn n rs rt = let open SIMD in match n with | Ne1 | Ne2 | Ne3 | Ne4 -> I_LD1M (rs,rt,K 0) | Ne2i -> I_LD2M (rs,rt,K 0) | Ne3i -> I_LD3M (rs,rt,K 0) | Ne4i -> I_LD4M (rs,rt,K 0) | _ -> assert false let ldnsv n rs pg rn idx= let open SIMD in match n with | Sv1 -> I_LD1SP (VSIMD32,rs,with_mode Zero pg,rn,idx) | Sv2i -> I_LD2SP (VSIMD32,rs,with_mode Zero pg,rn,idx) | Sv3i -> I_LD3SP (VSIMD32,rs,with_mode Zero pg,rn,idx) | Sv4i -> I_LD4SP (VSIMD32,rs,with_mode Zero pg,rn,idx) | _ -> assert false let ldr_mixed_idx v r1 r2 idx sz = let idx = MemExt.v2idx_reg v idx in let open MachSize in match sz with | Byte -> I_LDRBH (B,r1,r2,idx) | Short -> I_LDRBH (H,r1,r2,idx) | Word -> I_LDR (V32,r1,r2,idx) | Quad -> I_LDR (V64,r1,r2,idx) | S128 -> I_LDR (V128,r1,r2,idx) let str_mixed sz o r1 r2 = let idx = MemExt.Imm (o,Idx) in let open MachSize in match sz with | Byte -> I_STRBH (B,r1,r2,idx) | Short -> I_STRBH (H,r1,r2,idx) | Word -> I_STR (V32,r1,r2,idx) | Quad -> I_STR (V64,r1,r2,idx) | S128 -> I_STR (V128,r1,r2,idx) let do_str v r1 r2 = I_STR (v,r1,r2,MemExt.Imm (0,Idx)) let str = do_str vloc let stg r1 r2 = I_STG (r1,r2,(0,Idx)) let stct r1 r2 = I_STCT(r1,r2) let do_stlr v r1 r2 = I_STLR (v,r1,r2) let stlr = do_stlr vloc let do_str_idx v r1 r2 idx = I_STR (vloc,r1,r2,MemExt.v2idx_reg v idx) let str_idx = do_str_idx vloc let stxr r1 r2 r3 = I_STXR (vloc,YY,r1,r2,r3) let stlxr r1 r2 r3 = I_STXR (vloc,LY,r1,r2,r3) let stn n rs rt = let open SIMD in match n with | Ne1 | Ne2 | Ne3 | Ne4 -> I_ST1M (rs,rt,K 0) | Ne2i -> I_ST2M (rs,rt,K 0) | Ne3i -> I_ST3M (rs,rt,K 0) | Ne4i -> I_ST4M (rs,rt,K 0) | _ -> assert false let stnsv n rs pg rn idx = let open SIMD in match n with | Sv1 -> I_ST1SP (VSIMD32,rs,pg,rn,idx) | Sv2i -> I_ST2SP (VSIMD32,rs,pg,rn,idx) | Sv3i -> I_ST3SP (VSIMD32,rs,pg,rn,idx) | Sv4i -> I_ST4SP (VSIMD32,rs,pg,rn,idx) | _ -> assert false let stxr_sz t sz r1 r2 r3 = let open MachSize in match sz with | Byte -> I_STXRBH (B,t,r1,r2,r3) | Short -> I_STXRBH (H,t,r1,r2,r3) | Word -> I_STXR (V32,t,r1,r2,r3) | Quad -> I_STXR (V64,t,r1,r2,r3) | S128 -> I_STXR (V128,t,r1,r2,r3) let ldxr_sz t sz r1 r2 = let open MachSize in match sz with | Byte -> I_LDARBH (B,t,r1,r2) | Short -> I_LDARBH (H,t,r1,r2) | Word -> I_LDAR (V32,t,r1,r2) | Quad -> I_LDAR (V64,t,r1,r2) | S128 -> I_LDAR (V128,t,r1,r2) let sumi_addr_gen tempo st rA o = match o with | 0 -> rA,[],st | _ -> let r,st = tempo st in r,[addi_64 r rA o],st let sumi_addr st rA o = sumi_addr_gen tempo1 st rA o let str_mixed_idx sz v r1 r2 idx = let idx = MemExt.v2idx_reg v idx in let open MachSize in match sz with | Byte -> I_STRBH (B,r1,r2,idx) | Short -> I_STRBH (H,r1,r2,idx) | Word -> I_STR (V32,r1,r2,idx) | Quad -> I_STR (V64,r1,r2,idx) | S128 -> I_STR (V128,r1,r2,idx) let swp_mixed sz a rS rT rN = let open MachSize in match sz with | Byte -> I_SWPBH (B,a,rS,rT,rN) | Short -> I_SWPBH (H,a,rS,rT,rN) | Word -> I_SWP (V32,a,rS,rT,rN) | Quad -> I_SWP (V64,a,rS,rT,rN) | S128 -> I_SWP (V128,a,rS,rT,rN) let swp a rS rT rN = I_SWP (vloc,a,rS,rT,rN) let sctag a rN rM = I_SC (SCTAG,a,rN,rM) let cas_mixed sz a rS rT rN = let open MachSize in match sz with | Byte -> I_CASBH (B,a,rS,rT,rN) | Short -> I_CASBH (H,a,rS,rT,rN) | Word -> I_CAS (V32,a,rS,rT,rN) | Quad -> I_CAS (V64,a,rS,rT,rN) | S128 -> I_CAS (V128,a,rS,rT,rN) let cas a rS rT rN = I_CAS (vloc,a,rS,rT,rN) let ldop_mixed op sz a rS rT rN = let open MachSize in match sz with | Byte -> I_LDOPBH (op,B,a,rS,rT,rN) | Short -> I_LDOPBH (op,H,a,rS,rT,rN) | Word -> I_LDOP (op,V32,a,rS,rT,rN) | Quad -> I_LDOP (op,V64,a,rS,rT,rN) | S128 -> I_LDOP (op,V128,a,rS,rT,rN) let ldop op a rS rT rN = I_LDOP (op,vloc,a,rS,rT,rN) let stop_mixed op sz a rS rN = let open MachSize in match sz with | Byte -> I_STOPBH (op,B,a,rS,rN) | Short -> I_STOPBH (op,H,a,rS,rN) | Word -> I_STOP (op,V32,a,rS,rN) | Quad -> I_STOP (op,V64,a,rS,rN) | S128 -> I_STOP (op,V128,a,rS,rN) let stop op a rS rN = I_STOP (op,vloc,a,rS,rN) let do_sum_addr v st rA idx = let r,st = tempo1 st in if do_morello then r,[do_addcapa r rA idx],st else r,[do_add64 v r rA idx],st let sum_addr = do_sum_addr vloc let stlr_of_sz sz r1 r2 = let open MachSize in match sz with | Byte -> I_STLRBH (B,r1,r2) | Short -> I_STLRBH (H,r1,r2) | Word -> I_STLR (V32,r1,r2) | Quad -> I_STLR (V64,r1,r2) | S128 -> I_STLR (V128,r1,r2) let stlr_mixed sz o st r1 r2 = let rA,cs_sum,st = sumi_addr st r2 o in cs_sum@[stlr_of_sz sz r1 rA],st let stlr_mixed_idx sz st r1 r2 idx = let rA,cs_sum,st = sum_addr st r2 idx in cs_sum@[stlr_of_sz sz r1 rA],st let ldar_mixed t sz o st r1 r2 = let rA,cs,st = sumi_addr st r2 o in let ld = let open MachSize in match sz with | Byte -> I_LDARBH (B,t,r1,rA) | Short -> I_LDARBH (H,t,r1,rA) | Word -> I_LDAR (V32,t,r1,rA) | Quad -> I_LDAR (V64,t,r1,rA) | S128 -> I_LDAR (V128,t,r1,rA) in cs@[ld],st let do_ldar_mixed_idx v t sz o st r1 r2 idx = let rA,cs1,st = sumi_addr st r2 o in let rA,cs2,st = do_sum_addr v st rA idx in let ld = let open MachSize in match sz with | Byte -> I_LDARBH (B,t,r1,rA) | Short -> I_LDARBH (H,t,r1,rA) | Word -> I_LDAR (V32,t,r1,rA) | Quad -> I_LDAR (V64,t,r1,rA) | S128 -> I_LDAR (V128,t,r1,rA) in cs1@cs2@[ld],st let ldar_mixed_idx = do_ldar_mixed_idx vloc let do_ldp opt r1 r2 rA = I_LDP (opt,vloc,r1,r2,rA,(0,Idx)) and do_ldxp opt r1 r2 rA = I_LDXP (vloc,opt,r1,r2,rA) let do_stp opt r1 r2 rA = I_STP (opt,vloc,r1,r2,rA,(0,Idx)) and do_stxp opt r r1 r2 rA = I_STXP (vloc,opt,r,r1,r2,rA) (*********) (* loads *) (*********) module type L = sig type sz val sz0 : sz val load : sz -> A.st -> reg -> reg -> instruction list * A.st val load_idx : sz -> sz -> A.st -> reg -> reg -> reg -> instruction list * A.st val next_reg : A.st -> Code.proc -> sz -> reg * A.st end let type_of_sz sz = let open TypBase in Std (Unsigned,MachSize.at_least_word sz) let next_reg_sz st p sz = let r,st = next_reg st in let loc = A.Reg (p,r) in let st = A.add_type loc (type_of_sz sz) st in r,st let next_reg_var st p var = next_reg_sz st p (v2sz var) let emit_load_mixed sz o st p init x = let rA,st = next_reg_sz st p sz in let rB,init,st = U.next_init st p init x in rA,init,lift_code [ldr_mixed rA rB sz o],st let _emit_load_int_idx o st _p init rA = let r1,st = next_reg st in r1,init,lift_code [ldr_mixed r1 rA szloc o],st let emit_ldr_addon a r = match a with | Some Capability -> assert do_morello ; [gcvalue r r] | None -> [] let do_emit_load_idx_var next_reg_loc load_idx v1 v2 st p init x idx = let rA,st = if do_mixed then next_reg_loc st p v1 else next_reg st in let rB,init,st = U.next_init st p init x in let ins,st = load_idx v1 v2 st rA rB idx in rA,init,pseudo ins ,st module LOAD(L:L) = struct let emit_load_var_reg vr st p init rB = let rA,st = if do_mixed then L.next_reg st p vr else next_reg st in let ld,st = L.load vr st rA rB in rA,init,lift_code ld,st let emit_load_var vr st p init x = let rB,init,st = U.next_init st p init x in emit_load_var_reg vr st p init rB let emit_load = emit_load_var L.sz0 let emit_fetch st _p init lab = let rA,st = next_reg st in let lab0 = ".+12" in let lab1 = ".+8" in let cs = Label (lab,Instruction (b lab0)):: Instruction (mov rA 2):: Instruction (b lab1):: Instruction (mov rA 1):: [] in rA,init,cs,st let emit_load_not_zero st p init x = let rA,st = next_reg st in let rB,init,st = U.next_init st p init x in let ld,st = L.load L.sz0 st rA rB in let lab = Label.next_label "L" in rA,init, Label (lab,Nop):: lift_code (ld@[cbz rA lab]), st let emit_load_one st p init x = let rA,st = next_reg st in let rB,init,st = U.next_init st p init x in let ld,st = L.load L.sz0 st rA rB in let lab = Label.next_label "L" in rA,init, Label (lab,Nop):: pseudo (ld@[cmpi rA 1; bne lab]), st let emit_load_not st p init x cmp = let rA,st = next_reg st in let rC,st = tempo4 st in let rB,init,st = U.next_init st p init x in let ld,st = L.load L.sz0 st rA rB in let lab = Label.next_label "L" in let out = Label.next_label "L" in rA,init, Instruction (mov rC 200):: (* 200 X about 5 ins looks for a typical memory delay *) Label (lab,Nop):: pseudo (ld@ [cmp rA; bne out; I_OP3 (vloc,SUBS,rC,rC,OpExt.Imm (1,0)); cbnz rC lab ; ])@ [Label (out,Nop)],st let emit_load_not_eq st p init x rP = emit_load_not st p init x (fun r -> cmp r rP) let emit_load_not_value st p init x v = emit_load_not st p init x (fun r -> cmpi r v) let emit_load_idx_var = do_emit_load_idx_var L.next_reg L.load_idx end let wrap_st emit st r1 r2 = let c = emit r1 r2 in [c],st module LDR = LOAD (struct type sz = A64.variant let sz0 = vloc let load vr = wrap_st (do_ldr vr) let load_idx v1 v2 st rA rB idx = [do_ldr_idx v1 v2 rA rB idx],st let next_reg = next_reg_var end) module LDN = struct let emit_load_reg n st init rA = let (r,rs),st = emit_vregs n st in let adds = List.map (fun v -> add_simd r v) rs in let rS,st = next_scalar_reg st in let addv = [I_ADDV(A64.VSIMD32,rS,r)] in let rX,st = next_reg st in let fmov = [I_FMOV_TG(A64.V32,rX,A64.VSIMD32,rS)] in rX,init,lift_code ([ldn n (r::rs) rA]@adds@addv@fmov),st let emit_load n st p init loc = let rA,init,st = U.next_init st p init loc in emit_load_reg n st init rA let emit_load_idx n v st p init loc ridx = let rA,init,st = U.next_init st p init loc in let rA,csA,st = do_sum_addr v st rA ridx in let r,init,cs,st = emit_load_reg n st init rA in r,init,pseudo csA@cs,st end module LDP = struct let emit_load_reg temporal st init rA = let r1,st = next_vreg st in let r2,st = next_vreg st in let ldp = [I_LDP_SIMD(temporal,A64.VSIMD32,to_scalar r1,to_scalar r2,rA,(0,A64.Idx))] in let r3,st = next_vreg st in let add = [I_ADD_SIMD (r3,r1,r2)] in let rX,st = next_reg st in let fmov = [I_FMOV_TG(A64.V32,rX,A64.VSIMD32,to_scalar r3)] in rX,init,lift_code (ldp@add@fmov),st let emit_load t st p init loc = let rA,init,st = U.next_init st p init loc in emit_load_reg t st init rA let emit_load_idx t v st p init loc ridx = let rA,init,st = U.next_init st p init loc in let rA,csA,st = do_sum_addr v st rA ridx in let r,init,cs,st = emit_load_reg t st init rA in r,init,pseudo csA@cs,st end module LDUR = struct let emit_load_reg st init rA = let r,st = next_scalar_reg st in let ldur = [I_LDUR_SIMD(A64.VSIMD32,r,rA,0)] in let rX,st = next_reg st in let fmov = [I_FMOV_TG(A64.V32,rX,A64.VSIMD32,r)] in rX,init,lift_code (ldur@fmov),st let emit_load st p init loc = let rA,init,st = U.next_init st p init loc in emit_load_reg st init rA let emit_load_idx v st p init loc ridx = let rA,init,st = U.next_init st p init loc in let rA,csA,st = do_sum_addr v st rA ridx in let r,init,cs,st = emit_load_reg st init rA in r,init,pseudo csA@cs,st end module LDAPUR = struct let emit_load_reg st init rA = let r,st = next_scalar_reg st in let ldur = [I_LDAPUR_SIMD(A64.VSIMD32,r,rA,0)] in let rX,st = next_reg st in let fmov = [I_FMOV_TG(A64.V32,rX,A64.VSIMD32,r)] in rX,init,lift_code (ldur@fmov),st let emit_load st p init loc = let rA,init,st = U.next_init st p init loc in emit_load_reg st init rA let emit_load_idx v st p init loc ridx = let rA,init,st = U.next_init st p init loc in let rA,csA,st = do_sum_addr v st rA ridx in let r,init,cs,st = emit_load_reg st init rA in r,init,pseudo csA@cs,st end module LDNW = struct let emit_load_reg n st init rA idx = let pred,st = next_preg st in let acc,st = next_vreg st in let nelem = SIMD.nelements n in let ptrue = [I_PTRUE (pred,pattern nelem)] in let (r,rs),st = emit_zregs n st in let load = [ldnsv n (r::rs) pred rA idx] in let reduce = (List.map (fun v -> I_ADD_SV (r,r,v)) rs)@[I_UADDV (VSIMD64,to_scalar acc,pred,r)] in let rX,st = next_reg st in let fmov = [I_FMOV_TG(V32,rX,VSIMD32,to_scalar acc)] in rX,init,lift_code (ptrue@load@reduce@fmov),st let emit_load n st p init loc = let open MemExt in let idx = Imm(0,Idx) in let rA,init,st = U.next_init st p init loc in emit_load_reg n st init rA idx let emit_load_idx n v st p init loc ridx = let open MemExt in let rA,init,st = U.next_init st p init loc in let rI,csI,st = match v with | V32 -> let r,st = next_reg st in r,[sxtw r ridx],st | _ -> ridx,[],st in let idx = Reg(V64,rI,LSL,2) in let r,init,cs,st = emit_load_reg n st init rA idx in r,init,pseudo csI@cs,st end module LD1G = struct let emit_load_reg n st init rA idx = let pred,st = next_preg st in let acc,st = next_vreg st in let nelem = SIMD.nelements n in let ptrue = [I_PTRUE (pred,pattern nelem)] in let r,st = next_zreg st in let load = [I_LD1SP (VSIMD32,[r],with_mode Zero pred,rA,idx)] in let reduce = [I_UADDV (VSIMD64,to_scalar acc,pred,r)] in let rX,st = next_reg st in let fmov = [I_FMOV_TG(V32,rX,VSIMD32,to_scalar acc)] in rX,init,lift_code (ptrue@load@reduce@fmov),st let emit_load n st p init loc = let open MemExt in let rA,init,st = U.next_init st p init loc in let rI,st = next_zreg st in let csI = [I_INDEX_II (rI,0,1)] in let idx = ZReg(rI,UXTW,2) in let r,init,cs,st = emit_load_reg n st init rA idx in r,init,pseudo csI@cs,st let emit_load_idx n v st p init loc ridx = let open MemExt in let rA,init,st = U.next_init st p init loc in let rI,st = next_zreg st in let csI = [I_INDEX_SI (rI,v,ridx,1)] in let idx = ZReg(rI,UXTW,2) in let r,init,cs,st = emit_load_reg n st init rA idx in r,init,pseudo csI@cs,st end module LD1T = struct let emit_load_reg n st init rA idx = let smstart = [I_SMSTART (None)] in let pred,st = next_preg st in let nelem = SIMD.nelements n in let ptrue = [I_PTRUE (pred,pattern nelem)] in let movx12 = [I_MOV (V32,x12,RV (V32,ZR))] in let tile,slice,st = next_zaslice n st in let load = [I_LD1SPT (VSIMD32,tile,x12,slice,with_mode Zero pred,rA,idx)] in let r,st = next_zreg st in let mova = [I_MOVA_TV (r,with_mode Merge pred,tile,x12,slice)] in let acc,st = next_vreg st in let reduce = [I_UADDV (VSIMD64,to_scalar acc,pred,r)] in let rX,st = next_reg st in let fmov = [I_FMOV_TG(V32,rX,VSIMD32,to_scalar acc)] in let smstop = [I_SMSTOP (None)] in rX,init,lift_code (smstart@ptrue@movx12@load@mova@reduce@fmov@smstop),st let emit_load n st p init loc = let open MemExt in let idx = Imm(0,Idx) in let rA,init,st = U.next_init st p init loc in emit_load_reg n st init rA idx let emit_load_idx n v st p init loc ridx = let open MemExt in let rA,init,st = U.next_init st p init loc in let rI,csI,st = match v with | V32 -> let r,st = next_reg st in r,[sxtw r ridx],st | _ -> ridx,[],st in let idx = Reg(V64,rI,LSL,2) in let r,init,cs,st = emit_load_reg n st init rA idx in r,init,pseudo csI@cs,st end module LDG = struct let emit_load st p init x = let rA,st = next_reg st in let rB,init,st = U.next_init st p init x in rA,init,lift_code [mov_reg_addr rA rB;ldg rA rB],st let emit_load_idx v st p init x idx = let rA,st = next_reg st in let rB,init,st = U.next_init st p init x in let rC,c,st = do_sum_addr v st rB idx in rA,init,lift_code (mov_reg_addr rA rB::c@[ldg rA rC]),st end module LDCT = struct let emit_load st p init x = let rA,st = next_reg st in let rB,init,st = U.next_init st p init x in rA,init,lift_code [ldct rA rB],st let emit_load_idx st p init x idx = let rA,init,st = U.next_init st p init x in let rB,st = next_reg st in let rC,st = next_reg st in rC,init,lift_code ([sctag rB rA idx; ldct rC rB]),st end module OBS = LOAD (struct type sz = MachSize.sz let sz0 = naturalsize let load vr st rA rB = [ldr_mixed rA rB vr 0],st let load_idx v1 _v2 st rA rB idx = [ldr_mixed_idx vloc rA rB idx v1],st let next_reg = next_reg_sz end) (* Load pair *) module LDAR = LOAD (struct type sz = A64.variant let sz0 = vloc let load vr = wrap_st (do_ldar vr) let load_idx v1 v2 st rA rB idx = let r,ins,st = do_sum_addr v2 st rB idx in ins@[do_ldar v1 rA r],st let next_reg = next_reg_var end) module LDAPR = LOAD (struct type sz = A64.variant let sz0 = vloc let load vr = wrap_st (do_ldapr vr) let load_idx v1 v2 st rA rB idx = let r,ins,st = do_sum_addr v2 st rB idx in ins@[do_ldapr v1 rA r],st let next_reg = next_reg_var end) (**********) (* Stores *) (**********) let seal_dp_addr init p loc st rd v = let rB,init,st = U.next_init st p init loc in let rC,st = next_reg st in let cs = lift_code [ subi V64 rC rd v; andi V64 rC rC 0xfff; scvalue rC rB rC; cseal rC rB rC; ] in (rB,rC),init,cs,st module type S = sig val store : A.st -> reg -> reg -> instruction list * A.st val store_idx : A.st -> reg -> reg -> reg -> instruction list * A.st val emit_mov : A.st -> Code.proc -> A.init -> int -> reg * A.init * Extra.instruction list * A.st end let emit_str_addon st p init rA rB a e = match a with | Some Capability -> assert do_morello ; let init,cs,st = if e.C.cseal > 0 then let r,init,csi,st = U.emit_mov st p init e.C.cseal in init,csi@lift_code [scvalue rA rB rA; seal rA rA r],st else init,[],st in let init,cs,st = if e.C.ctag > 0 then let r,init,csi,st = U.emit_mov st p init e.C.ctag in init,cs@csi@lift_code [sctag rA rA r],st else init,cs,st in init,cs,st | None -> init,[],st let emit_store_reg_mixed sz o st p init x rA a e = let rB,init,st = U.next_init st p init x in let init,csi,st = emit_str_addon st p init rA rB a e in init,csi@[Instruction (str_mixed sz o rA rB)],st let do_emit_mov_sz emit_mov_sz sz st p init v = let rA,init,csi,st = emit_mov_sz sz st p init v in let st = let loc = A.Reg (p,rA) in let t = type_of_sz sz in A.add_type loc t st in rA,init,csi,st let emit_mov_sz = do_emit_mov_sz U.emit_mov_sz let emit_mov_sz_fresh = do_emit_mov_sz U.emit_mov_sz_fresh let emit_store_mixed sz o st p init x v a e = let rA,init,csi,st = emit_mov_sz sz st p init v in let init,cs,st = emit_store_reg_mixed sz o st p init x rA a e in init,csi@cs,st let _emit_store_int_idx o st p init rA v = let r1,init,csi,st = U.emit_mov st p init v in init,csi@pseudo [str_mixed szloc o r1 rA;],st module STORE(S:S) = struct let emit_store_reg st p init x rA a e = let rB,init,st = U.next_init st p init x in let init,csi,st = emit_str_addon st p init rA rB a e in let cs,st = S.store st rA rB in init,csi@pseudo cs,st let emit_store st p init x v a e = let rA,init,csi,st = S.emit_mov st p init v in let init,cs,st = emit_store_reg st p init x rA a e in init,csi@cs,st let emit_store_idx_reg st p init x idx rA a e = let rB,init,st = U.next_init st p init x in let init,csi,st = emit_str_addon st p init rA rB a e in let ins,st = S.store_idx st rA rB idx in init,csi@pseudo ins,st let emit_store_idx st p init x idx v a e = let rA,init,csi,st = S.emit_mov st p init v in let init,cs,st = emit_store_idx_reg st p init x idx rA a e in init,csi@cs,st let emit_store_nop st p init lab = let rA,init,st = U.emit_nop st p init nop in let rB,init,st = U.next_init st p init lab in let cs,st = S.store st rA rB in init,pseudo cs,st end module STR = STORE (struct let store = wrap_st str let store_idx st rA rB idx = [str_idx rA rB idx],st let emit_mov = U.emit_mov end) module STN = struct let emit_store_reg n st init rA v = let (r,rs),st = emit_vregs n st in let movi = List.mapi (fun i r -> movi_reg r (v+i)) (r::rs) in init,pseudo movi@pseudo [stn n (r::rs) rA],st let emit_store n st p init loc v = let rA,init,st = U.next_init st p init loc in emit_store_reg n st init rA v let emit_store_idx n vdep st p init loc ridx v = let rA,init,st = U.next_init st p init loc in let rA,csA,st = do_sum_addr vdep st rA ridx in let init,cs,st = emit_store_reg n st init rA v in init,pseudo csA@cs,st let emit_store_dep n vdep st init rA v = let (r,rs),st = emit_vregs n st in let rB,st = next_vreg st in let dup = [I_DUP (rB,A64.V32,vdep)] in let movi = List.mapi (fun i r -> movi_reg r (v+i)) (r::rs) in let adds = List.map (fun v -> add_simd v rB) (r::rs) in let stn = [stn n (r::rs) rA] in init,lift_code(dup@movi@adds@stn),st end module STP = struct let emit_store_reg temporal st init rA v = let r1,st = next_vreg st in let r2,st = next_vreg st in let movi = List.mapi (fun i r -> movi_reg r (v+i)) [r1;r2] in let stp = [I_STP_SIMD(temporal,A64.VSIMD32,to_scalar r1,to_scalar r2,rA,(0,A64.Idx))] in init,pseudo movi@pseudo stp,st let emit_store n st p init loc v = let rA,init,st = U.next_init st p init loc in emit_store_reg n st init rA v let emit_store_idx n vdep st p init loc ridx v = let rA,init,st = U.next_init st p init loc in let rA,csA,st = do_sum_addr vdep st rA ridx in let init,cs,st = emit_store_reg n st init rA v in init,pseudo csA@cs,st let emit_store_dep temporal vdep st init rA v = let rB,st = next_vreg st in let dup = [I_DUP (rB,A64.V32,vdep)] in let r1,st = next_vreg st in let r2,st = next_vreg st in let movi = List.mapi (fun i r -> movi_reg r (v+i)) [r1;r2] in let adds = List.map (fun v -> add_simd v rB) [r1;r2] in let stp = [I_STP_SIMD(temporal,A64.VSIMD32,to_scalar r1,to_scalar r2,rA,(0,A64.Idx))] in init,lift_code(dup@movi@adds@stp),st end module STUR = struct let emit_store_reg st init rA v = let r,st = next_vreg st in let movi = [movi_reg r v] in let stur = [I_STUR_SIMD(A64.VSIMD32,to_scalar r,rA,0)] in init,lift_code(movi@stur),st let emit_store st p init loc v = let rA,init,st = U.next_init st p init loc in emit_store_reg st init rA v let emit_store_idx vdep st p init loc ridx v = let rA,init,st = U.next_init st p init loc in let rA,csA,st = do_sum_addr vdep st rA ridx in let init,cs,st = emit_store_reg st init rA v in init,pseudo csA@cs,st let emit_store_dep vdep st init rA v = let rB,st = next_vreg st in let dup = [I_DUP (rB,A64.V32,vdep)] in let r1,st = next_vreg st in let movi = [movi_reg r1 v] in let adds = [add_simd r1 rB]in let stur = [I_STUR_SIMD(A64.VSIMD32,to_scalar r1,rA,0)] in init,lift_code(dup@movi@adds@stur),st end module STLUR = struct let emit_store_reg st init rA v = let r,st = next_vreg st in let movi = [movi_reg r v] in let stlur = [I_STLUR_SIMD(A64.VSIMD32,to_scalar r,rA,0)] in init,lift_code(movi@stlur),st let emit_store st p init loc v = let rA,init,st = U.next_init st p init loc in emit_store_reg st init rA v let emit_store_idx vdep st p init loc ridx v = let rA,init,st = U.next_init st p init loc in let rA,csA,st = do_sum_addr vdep st rA ridx in let init,cs,st = emit_store_reg st init rA v in init,pseudo csA@cs,st let emit_store_dep vdep st init rA v = let rB,st = next_vreg st in let dup = [I_DUP (rB,A64.V32,vdep)] in let r1,st = next_vreg st in let movi = [movi_reg r1 v] in let adds = [add_simd r1 rB]in let stlur = [I_STLUR_SIMD(A64.VSIMD32,to_scalar r1,rA,0)] in init,lift_code(dup@movi@adds@stlur),st end module STNW = struct let emit_store_reg n st init rA v idx = let pred,st = next_preg st in let nelem = SIMD.nelements n in let ptrue = [I_PTRUE (pred,pattern nelem)] in let (r,rs),st = emit_zregs n st in let mov_sv = List.mapi (fun i r -> I_MOV_SV (r,(v+i),S_NOEXT)) (r::rs) in let setup = mov_sv@ptrue in let store = [stnsv n (r::rs) pred rA idx] in init,lift_code (setup@store),st let emit_store n st p init loc v = let open MemExt in let idx = Imm(0,Idx) in let rA,init,st = U.next_init st p init loc in emit_store_reg n st init rA v idx let emit_store_idx n vdep st p init loc ridx v = let open MemExt in let rA,init,st = U.next_init st p init loc in let rI,csI,st = match vdep with | V32 -> let r,st = next_reg st in r,[sxtw r ridx],st | _ -> ridx,[],st in let idx = Reg(V64,rI,LSL,2) in let init,cs,st = emit_store_reg n st init rA v idx in init,pseudo csI@cs,st let emit_store_dep n vdep st init rA v = let open MemExt in let idx = Imm(0,Idx) in let rB,st = next_zreg st in let dup_sv = [I_DUP_SV (rB,V32,vdep)] in let (r,rs),st = emit_zregs n st in let mov_sv = List.mapi (fun i r -> I_MOV_SV (r,(v+i),S_NOEXT)) (r::rs) in let add_sv = List.map (fun v -> I_ADD_SV(v,v,rB)) (r::rs) in let pred,st = next_preg st in let nelem = SIMD.nelements n in let ptrue = [I_PTRUE (pred,pattern nelem)] in let setup = dup_sv@mov_sv@add_sv@ptrue in let store = [stnsv n (r::rs) pred rA idx] in init,lift_code (setup@store),st end module ST1S = struct let emit_store_reg n st init rA v idx= let pred,st = next_preg st in let nelem = SIMD.nelements n in let ptrue = [I_PTRUE (pred,pattern nelem)] in let r,st = next_zreg st in let mov_sv = [I_MOV_SV (r,v,S_NOEXT)] in let setup = mov_sv@ptrue in let store = [I_ST1SP (VSIMD32,[r],pred,rA,idx)] in init,lift_code (setup@store),st let emit_store n st p init loc v = let open MemExt in let rA,init,st = U.next_init st p init loc in let rI,st = next_zreg st in let csI = [I_INDEX_II (rI,0,1)] in let idx = ZReg(rI,UXTW,2) in let init,cs,st = emit_store_reg n st init rA v idx in init,pseudo csI@cs,st let emit_store_idx n vdep st p init loc ridx v = let open MemExt in let rA,init,st = U.next_init st p init loc in let rI,st = next_zreg st in let csI = [I_INDEX_SI (rI,vdep,ridx,1)] in let idx = ZReg(rI,UXTW,2) in let init,cs,st = emit_store_reg n st init rA v idx in init,pseudo csI@cs,st let emit_store_dep n vdep st init rA v = let open MemExt in let rB,st = next_zreg st in let dup_sv = [I_DUP_SV (rB,V32,vdep)] in let r,st = next_zreg st in let mov_sv = [I_MOV_SV (r,v,S_NOEXT)] in let add_sv = [I_ADD_SV (r,r,rB)] in let pred,st = next_preg st in let rI,st = next_zreg st in let nelem = SIMD.nelements n in let ptrue = [I_PTRUE (pred,pattern nelem)] in let index = [I_INDEX_II (rI,0,1)] in let setup = dup_sv@mov_sv@add_sv@ptrue in let store = [I_ST1SP (VSIMD32,[r],pred,rA,ZReg(rI,UXTW,2))] in init,lift_code (index@setup@store),st end module ST1T = struct let emit_store_reg n st init rA v idx= let smstart = [I_SMSTART (None)] in let pred,st = next_preg st in let nelem = SIMD.nelements n in let ptrue = [I_PTRUE (pred,pattern nelem)] in let movx12 = [I_MOV (V32,x12,RV (V32,ZR))] in let r,st = next_zreg st in let mov_sv = [I_MOV_SV (r,v,S_NOEXT)] in let tile,slice,st = next_zaslice n st in let mova = [I_MOVA_VT (tile,x12,slice,with_mode Merge pred,r)] in let setup = mov_sv@ptrue@movx12@mova in let store = [I_ST1SPT (VSIMD32,tile,x12,slice,pred,rA,idx)] in let smstop = [I_SMSTOP (None)] in init,lift_code (smstart@setup@store@smstop),st let emit_store n st p init loc v = let open MemExt in let idx = Imm(0,Idx) in let rA,init,st = U.next_init st p init loc in emit_store_reg n st init rA v idx let emit_store_idx n vdep st p init loc ridx v = let open MemExt in let rA,init,st = U.next_init st p init loc in let rI,csI,st = match vdep with | V32 -> let r,st = next_reg st in r,[sxtw r ridx],st | _ -> ridx,[],st in let idx = Reg(V64,rI,LSL,2) in let init,cs,st = emit_store_reg n st init rA v idx in init,pseudo csI@cs,st let emit_store_dep n vdep st init rA v = let open MemExt in let idx = Imm(0,Idx) in let smstart = [I_SMSTART (None)] in let rB,st = next_zreg st in let dup_sv = [I_DUP_SV (rB,V32,vdep)] in let r,st = next_zreg st in let mov_sv = [I_MOV_SV (r,v,S_NOEXT)] in let add_sv = [I_ADD_SV (r,r,rB)] in let tile,slice,st = next_zaslice n st in let pred,st = next_preg st in let nelem = SIMD.nelements n in let ptrue = [I_PTRUE (pred,pattern nelem)] in let movx12 = [I_MOV (V32,x12,RV (V32,ZR))] in let mova = [I_MOVA_VT (tile,x12,slice,with_mode Merge pred,r)] in let setup = dup_sv@mov_sv@add_sv@ptrue@movx12@mova in let store = [I_ST1SPT (VSIMD32,tile,x12,slice,pred,rA,idx)] in let smstop = [I_SMSTOP (None)] in init,lift_code (smstart@setup@store@smstop),st end module STG = struct let emit_store_reg st p init x rA = let rB,init,st = U.next_init st p init x in init,pseudo [stg rA rB],st let emit_store st p init e = let loc = Code.as_data e.C.loc in let x = Code.add_tag loc e.C.tag and v = Code.add_tag loc e.C.v in let rA,init,st = U.next_init st p init v in emit_store_reg st p init x rA let emit_store_idx vaddr st p init e idx = let loc = Code.as_data e.C.loc in let x = Code.add_tag loc e.C.tag and v = Code.add_tag loc e.C.v in let rA,init,st = U.next_init st p init v in let rB,init,st = U.next_init st p init x in let rC,c,st = do_sum_addr vaddr st rB idx in init,pseudo (c@[stg rA rC]),st end module STCT = struct let emit_store_reg st p init x rA = let rB,init,st = U.next_init st p init x in init,pseudo [stct rA rB],st let emit_store st p init x v = if v > 1 then Warn.fatal "Capability tags can't be incremented above 1"; let rA,init,csi,st = U.emit_mov st p init v in let init,cs,st = emit_store_reg st p init x rA in init,csi@cs,st let emit_store_idx st p init x idx v = if v > 1 then Warn.fatal "Capability tags can't be incremented above 1"; let rA,init,csi,st = U.emit_mov st p init v in let rB,init,st = U.next_init st p init x in let rC,st = next_reg st in init,csi@pseudo ([sctag rC rB idx; stct rA rC]),st end module STLR = STORE (struct let store = wrap_st stlr let store_idx st rA rB idx = let r,ins,st = sum_addr st rB idx in ins@[stlr rA r],st let emit_mov = U.emit_mov end) (***************************) (* Atomic loads and stores *) (***************************) let get_xload_addon (a,_m) r1 = match a with | Plain a | Acq a -> emit_ldr_addon a r1 | _ -> [] let get_xload = function | (Plain None,None) ->ldxr | (Plain Some Capability,None) -> ldxr_sz XX MachSize.S128 | (Plain None,Some (sz,_)) -> ldxr_sz XX sz | (Acq None,None) -> ldaxr | (Acq Some Capability,None) -> ldxr_sz AX MachSize.S128 | (Acq None,Some (sz,_)) -> ldxr_sz AX sz | (AcqPc _,_) -> Warn.fatal "AcqPC annotation on xload" | (Tag,_)|(CapaTag,_)|(CapaSeal,_) -> Warn.fatal "variant annotation on xload" | a -> Warn.fatal "Bad annotation for Lx: %s\n" (A.pp_atom a) and get_xstore = function | (Plain None,None) -> stxr | (Plain Some Capability,None) -> stxr_sz YY MachSize.S128 | (Plain None,Some (sz,_)) -> stxr_sz YY sz | (Rel None,None) -> stlxr | (Rel Some Capability,None) -> stxr_sz LY MachSize.S128 | (Rel None,Some (sz,_)) -> stxr_sz LY sz | (Tag,_)|(CapaTag,_)|(CapaSeal,_) -> Warn.fatal "variant annotation on xstore" | a -> Warn.fatal "Bad annotation for Sx: %s\n" (A.pp_atom a) let get_xstore_addon (a,_m) r2 r3 e init st p = match a with | Plain a | Rel a -> emit_str_addon st p init r2 r3 a e | _ -> init,[],st let get_rmw_addrs arw st rA = match arw with | (_,(None|Some (_,0))),(_,(None|Some (_,0))) -> rA,rA,[],st | (_,Some (_,o1)),(_,Some (_,o2)) when o1=o2 -> let r,cs,st = sumi_addr st rA o1 in r,r,cs,st | (_,(None|Some (_,0))),(_,Some (_,o)) -> let r,cs,st = sumi_addr st rA o in rA,r,cs,st | (_,Some (_,o)),(_,(None|Some (_,0))) -> let r,cs,st = sumi_addr st rA o in r,rA,cs,st | (_,Some (_,o1)),(_,Some (_,o2)) -> let r1,cs1,st = sumi_addr_gen tempo1 st rA o1 in let r2,cs2,st = sumi_addr_gen tempo2 st rA o2 in r1,r2,cs1@cs2,st module ExclusivePair (Load: sig type load_regs val load : A.atom -> load_regs -> A.reg -> A.ins list val load_addon : A.atom -> load_regs -> A.ins list end) (Store: sig type store_regs val store : A.atom -> A.reg -> store_regs -> A.reg -> A.ins list val store_addon : A.atom -> store_regs -> A.reg -> C.event -> A.init -> A.st -> Proc.t -> A.init * A.pseudo list * A.st end) = struct let emit_xpair ar rR rAR aw r rW rAW = let cs_load = Load.load ar rR rAR and cs_store = Store.store aw r rW rAW in cs_load@Load.load_addon ar rR@cs_store let emit_loop_pair (ar,aw as arw) p st init rR rW rA e = let rAR,rAW,cs0,st = get_rmw_addrs arw st rA in let init,cs1,st = Store.store_addon ar rW rAW e init st p in let lbl = Label.next_label "Loop" in let r,st = tempo3 st in let cs = Label (lbl,Nop) ::lift_code (emit_xpair ar rR rAR aw r rW rAW) @[Instruction (cbnz r lbl)] in init,pseudo cs0@cs1@cs,st let emit_one_pair (ar, aw) p st init r rR rW rAR rAW k e = let ok,st = A.ok_reg st in let init,cs1,st = Store.store_addon ar rW rAW e init st p in init, cs1 @lift_code (emit_xpair ar rR rAR aw r rW rAW) @[Instruction (cbnz r (Label.last p))] @(k (Instruction (incr ok))), A.next_ok st let emit_unroll_pair u (ar, aw as arw) p st init rR rW rA e = let rAR,rAW,cs0,st = get_rmw_addrs arw st rA in let cs0 = pseudo cs0 in if u <= 0 then let r,st = next_reg st in let init,cs1,st = Store.store_addon ar rW rA e init st p in init, cs0@cs1 @pseudo (emit_xpair ar rR rAR aw r rW rAW), st else if u = 1 then let r,st = tempo3 st in let init,cs,st = emit_one_pair arw p st init r rR rW rAR rAW (fun i -> [i]) e in init,cs0@cs,st else let r,st = tempo3 st in let init,cs1,st = Store.store_addon ar rW rA e init st p in let out = Label.next_label "Go" in let rec do_rec = function | 1 -> emit_one_pair arw p st init r rR rW rAR rAW (fun i -> [Label (out,Nop);i]) e | u -> let init,cs,st = do_rec (u-1) in init, pseudo (emit_xpair ar rR rAR aw r rW rAW) @(Instruction (cbz r out)::cs1@cs), st in let init,cs,st = do_rec u in init,cs0@cs,st let emit_pair = match Cfg.unrollatomic with | None -> emit_loop_pair | Some u -> emit_unroll_pair u end module XLoad = struct type load_regs = A.reg let load ar rR rAR = [get_xload ar rR rAR] let load_addon = get_xload_addon end module XStore = struct type store_regs = A.reg let store aw r rW rAW = [get_xstore aw r rW rAW] let store_addon = get_xstore_addon end module XSingle = ExclusivePair(XLoad)(XStore) module XLoadPair = struct type load_regs = A.reg * A.reg let load ar (r1,r2) rA = let a = match ar with | Pair (Pa,_),None -> XP | Pair (PaI,_),None -> AXP | _ -> Warn.fatal "Illegal %s annotaton on load exclusive pair" (pp_atom ar) in [do_ldxp a r1 r2 rA; add vloc r1 r2 r1;] let load_addon _ _ = assert (not (do_morello)); [] end module XStorePair = struct type store_regs = A.reg * A.reg let store aw r (r1,r2) rA = let a = match aw with | Pair (Pa,_),_ -> YY | Pair (PaI,_),_ -> LY | _ -> Warn.fatal "Illegal %s annotaton on store exclusive pair" (pp_atom aw) in [dec r2 r1; do_stxp a r r2 r1 rA;] let store_addon _ _ _ _ init st _ = assert (not (do_morello)); init,[],st end module XPair = ExclusivePair(XLoadPair)(XStorePair) (* Translate annotations *) let tr_rw = function | PP -> (Plain None,None),(Plain None,None) | PL -> (Plain None,None),(Rel None,None) | AP -> (Acq None,None),(Plain None,None) | AL -> (Acq None,None),(Rel None,None) let tr_none = function | None -> Plain None,None | Some p -> p (********************) (* Mixed size pairs *) (********************) let emit_pair_mixed sz o rw = let arw = match tr_rw rw with | (a1,_),(a2,_) -> (a1,Some (sz,o)),(a2,Some (sz,o)) in XSingle.emit_pair arw (********************************) (* Individual loads and strores *) (********************************) let emit_lda_reg rw st init p rA = let rR,st = next_reg st in let _,cs,st = XSingle.emit_pair rw p st init rR rR rA C.evt_null in rR,cs,st let emit_lda rw st p init loc = let rA,init,st = U.next_init st p init loc in let r,cs,st = emit_lda_reg rw st init p rA in r,init,cs,st let do_emit_lda_idx v rw st p init loc idx = let rA,init,st = U.next_init st p init loc in let rA,cs1,st = do_sum_addr v st rA idx in let r,cs2,st = emit_lda_reg rw st init p rA in r,init,pseudo cs1@cs2,st let emit_lda_mixed_reg sz o rw st p init rA = let rR,st = next_reg_sz st p sz in let _,cs,st = emit_pair_mixed sz o rw p st init rR rR rA C.evt_null in rR,cs,st let emit_lda_mixed sz o rw st p init loc = let rA,init,st = U.next_init st p init loc in let r,cs,st = emit_lda_mixed_reg sz o rw st p init rA in r,init,cs,st let do_emit_lda_mixed_idx v sz o rw st p init loc idx = let rA,init,st = U.next_init st p init loc in let rA,cs1,st = do_sum_addr v st rA idx in let r,cs2,st = emit_lda_mixed_reg sz o rw st p init rA in r,init,pseudo cs1@cs2,st let do_emit_sta rw st p init rW rA = let rR,st = next_reg st in let init,cs,st = XSingle.emit_pair rw p st init rR rW rA C.evt_null in rR,init,cs,st let emit_sta rw st p init loc v = let rA,init,st = U.next_init st p init loc in let rW,init,csi,st = U.emit_mov st p init v in let rR,init,cs,st = do_emit_sta rw st p init rW rA in rR,init,csi@cs,st let emit_sta_reg rw st p init loc rW = let rA,init,st = U.next_init st p init loc in let rR,init,cs,st = do_emit_sta rw st p init rW rA in rR,init,cs,st let emit_sta_idx rw st p init loc idx v = let rA,init,st = U.next_init st p init loc in let rA,cs1,st = sum_addr st rA idx in let rW,init,csi,st = U.emit_mov st p init v in let rR,init,cs2,st = do_emit_sta rw st p init rW rA in rR,init,csi@pseudo cs1@cs2,st let do_emit_sta_mixed sz o rw st p init rW rA = let rR,st = next_reg st in let init,cs,st = emit_pair_mixed sz o rw p st init rR rW rA C.evt_null in rR,init,cs,st let emit_sta_mixed sz o rw st p init loc v = let rA,init,st = U.next_init st p init loc in let rW,init,csi,st = U.emit_mov st p init v in let rR,init,cs,st = do_emit_sta_mixed sz o rw st p init rW rA in rR,init,csi@cs,st let emit_sta_mixed_reg sz o rw st p init loc rW = let rA,init,st = U.next_init st p init loc in let rR,init,cs,st = do_emit_sta_mixed sz o rw st p init rW rA in rR,init,cs,st let emit_sta_mixed_idx sz o rw st p init loc idx v = let rA,init,st = U.next_init st p init loc in let rA,cs1,st = sum_addr st rA idx in let rW,init,csi,st = U.emit_mov st p init v in let rR,init,cs2,st = do_emit_sta_mixed sz o rw st p init rW rA in rR,init,csi@pseudo cs1@cs2,st let do_emit_set_pteval rel st p init v rA = let rB,init,st = U.emit_pteval st p init v in let do_str = if rel then do_stlr else do_str in init,pseudo [do_str A64.V64 rB rA],st let emit_set_pteval rel st p init v loc = let rA,init,st = U.next_init st p init loc in do_emit_set_pteval rel st p init v rA let emit_set_pteval_idx rel vdep idx st p init v loc = let rA,init,st = U.next_init st p init loc in let rA,cs1,st = do_sum_addr vdep st rA idx in let init,cs2,st = do_emit_set_pteval rel st p init v rA in init,pseudo cs1@cs2,st let emit_set_pteval_reg rel st p init rB loc = let rA,init,st = U.next_init st p init loc in let do_str = if rel then do_stlr else do_str in init,pseudo [do_str A64.V64 rB rA],st (********) (* Pair *) (********) let emit_ldp_reg opt st init rA = let r1,r2,st = next_reg2 st in r1,init,pseudo [do_ldp opt r1 r2 rA;add vloc r1 r1 r2;],st let emit_ldp_reg opt idx st _p init rA = match opt,idx with | _,Both -> emit_ldp_reg opt st init rA let emit_ldp opt idx st p init loc = let rA,init,st = U.next_init st p init loc in emit_ldp_reg opt idx st p init rA let emit_ldp_idx_var opt idx vdep st p init loc ridx = let rA,init,st = U.next_init st p init loc in let rA,csA,st = do_sum_addr vdep st rA ridx in let r,init,cs,st = emit_ldp_reg opt idx st p init rA in r,init,pseudo csA@cs,st let do_emit_stp_reg opt st p init v rA = let r1,init,csi1,st = U.emit_mov st p init v in let r2,st = next_reg st in init,csi1@pseudo [dec r2 r1; do_stp opt r2 r1 rA;],st let emit_stp_reg opt idx st p init rA e = match opt,idx with | _,Both -> do_emit_stp_reg opt st p init e.C.v rA let emit_stp opt idx st p init loc e = let rA,init,st = U.next_init st p init loc in emit_stp_reg opt idx st p init rA e let emit_stp_idx_var opt idx vdep st p init loc e ridx = let rA,init,st = U.next_init st p init loc in let rA,csA,st = do_sum_addr vdep st rA ridx in let init,cs,st = emit_stp_reg opt idx st p init rA e in init,pseudo csA@cs,st let stp_emit_store_reg opt idx st p init loc r1 = let rA,init,st = U.next_init st p init loc in let r2,st = next_reg st in match idx with | Both -> init,pseudo [dec r2 r1; do_stp opt r2 r1 rA;],st (**************) (* For export *) (**************) let emit_load_one = LDR.emit_load_one let emit_load = LDR.emit_load let emit_obs t = match t with | Code.Ord | Code.Instr-> emit_load_mixed naturalsize 0 | Code.Pte-> fun st p init loc -> let r,init,cs,st = LDR.emit_load_var A64.V64 st p init (Misc.add_pte loc) in r,init,cs,st | Code.Tag -> LDG.emit_load | Code.CapaTag -> LDCT.emit_load | Code.CapaSeal -> fun st p init x -> let r,init,cs,st = emit_load_mixed MachSize.S128 0 st p init x in let cs2 = lift_code [gctype r r] in r,init,cs@cs2,st | Code.VecReg n -> let emit_load = match n with | SIMD.NeAcqPc -> LDAPUR.emit_load | SIMD.NeP -> LDUR.emit_load | SIMD.NePa -> LDP.emit_load A64.TT | SIMD.NePaN -> LDP.emit_load A64.NT | SIMD.Sv1 | SIMD.Sv2i | SIMD.Sv3i | SIMD.Sv4i-> LDNW.emit_load n | SIMD.SvV -> LD1G.emit_load n | SIMD.SmV | SIMD.SmH -> LD1T.emit_load n | _ -> LDN.emit_load n in emit_load | Code.Pair -> emit_ldp Pa Both let emit_obs_not_value = OBS.emit_load_not_value let emit_obs_not_eq = OBS.emit_load_not_eq let emit_obs_not_zero = OBS.emit_load_not_zero (**********) (* Access *) (**********) let emit_joker st init = None,init,[],st let add_tag = if do_memtag then fun loc tag -> Code.add_tag loc tag else if do_morello then fun loc _ -> Code.add_capability loc 0 else fun loc _ -> loc let get_tagged_loc e = add_tag (as_data e.C.loc) e.C.tag let emit_access st p init e = match e.C.dir,e.C.loc with | None,_ -> Warn.fatal "AArchCompile.emit_access" | Some d,Code lab -> begin match d,e.C.atom with | R,Some (Instr, None) -> let r,init,cs,st = LDR.emit_fetch st p init lab in Some r,init,cs,st (* Plain read from an instruction label is currently not supported, but will be implemented in a future patch | R, None -> let r,init,cs,st = LDR.emit_load st p init lab in Some r,init,cs,st | W, Some(Instr, None) *) | W, None -> let init,cs,st = STR.emit_store_nop st p init lab in None,init,cs,st | _,_ -> Warn.fatal "Not Yet (%s,%s)!!!" (pp_dir d) (C.debug_evt e) end | Some d,Data loc -> let loc = add_tag loc e.C.tag in let atom = match e.C.atom with | None -> None | Some (a,m) -> begin match a with | Plain Some Capability | Acq Some Capability | AcqPc Some Capability | Rel Some Capability -> assert (Misc.is_none m) ; Some (a,Some (MachSize.S128,0)) | _ -> Some (a,m) end in begin match d,atom with | R,None -> let r,init,cs,st = LDR.emit_load st p init loc in Some r,init,cs,st | R,Some (Acq _,None) -> let r,init,cs,st = LDAR.emit_load st p init loc in Some r,init,cs,st | R,Some (Acq a,Some (sz,o)) -> let module L = LOAD (struct type sz = MachSize.sz let sz0 = sz let load sz = ldar_mixed AA sz o let load_idx sz _ = ldar_mixed_idx AA sz o let next_reg = next_reg_sz end) in let r,init,cs,st = L.emit_load st p init loc in let cs2 = emit_ldr_addon a r in Some r,init,cs@pseudo cs2,st | R,Some (AcqPc _,None) -> let r,init,cs,st = LDAPR.emit_load st p init loc in Some r,init,cs,st | R,Some (AcqPc a,Some (sz,o)) -> let module L = LOAD (struct type sz = MachSize.sz let sz0 = sz let load sz = ldar_mixed AQ sz o let load_idx sz _ = ldar_mixed_idx AQ sz o let next_reg = next_reg_sz end) in let r,init,cs,st = L.emit_load st p init loc in let cs2 = emit_ldr_addon a r in Some r,init,cs@pseudo cs2,st | R,Some (Rel _,_) -> Warn.fatal "No load release" | R,Some (Atomic rw,None) -> let r,init,cs,st = emit_lda (tr_rw rw) st p init loc in Some r,init,cs,st | R,Some (Atomic rw,Some (sz,o)) -> let r,init,cs,st = emit_lda_mixed sz o rw st p init loc in Some r,init,cs,st | R,Some (Plain a,Some (sz,o)) -> let r,init,cs,st = emit_load_mixed sz o st p init loc in let cs2 = emit_ldr_addon a r in Some r,init,cs@pseudo cs2,st | R,Some (Tag,None) -> let r,init,cs,st = LDG.emit_load st p init loc in Some r,init,cs,st | R,Some (CapaTag,None) -> let r,init,cs,st = LDCT.emit_load st p init loc in Some r,init,cs,st | R,Some (CapaTag,Some _) -> assert false | R,Some (CapaSeal,None) -> let r,init,cs,st = emit_load_mixed MachSize.S128 0 st p init loc in Some r,init,cs@lift_code [gctype r r],st | R,Some (CapaSeal,Some _) -> assert false | R,Some (Neon n, None) -> let emit_load = match n with | SIMD.NeRel -> Warn.fatal "No laod release" | SIMD.NeAcqPc -> LDAPUR.emit_load | SIMD.NeP -> LDUR.emit_load | SIMD.NePa -> LDP.emit_load A64.TT | SIMD.NePaN -> LDP.emit_load A64.NT | SIMD.Sv1 | SIMD.Sv2i | SIMD.Sv3i | SIMD.Sv4i -> LDNW.emit_load n | SIMD.SvV -> LD1G.emit_load n | SIMD.SmV | SIMD.SmH -> LD1T.emit_load n | _ -> LDN.emit_load n in let r,init,cs,st = emit_load st p init loc in Some r,init,cs,st | R,Some (Neon _,Some _) -> assert false | R,Some (Pair (opt,idx),None) -> let r,init,cs,st = emit_ldp opt idx st p init loc in Some r,init,cs,st | R,Some (Pair _,Some _) -> assert false | W,None -> let init,cs,st = STR.emit_store st p init loc e.C.v None C.evt_null in None,init,cs,st | W,Some (Rel _,None) -> let init,cs,st = STLR.emit_store st p init loc e.C.v None C.evt_null in None,init,cs,st | W,Some (Acq _,_) -> Warn.fatal "No store acquire" | W,Some (AcqPc _,_) -> Warn.fatal "No store acquirePc" | W,Some (Atomic rw,None) -> let r,init,cs,st = emit_sta (tr_rw rw) st p init loc e.C.v in Some r,init,cs,st | W,Some (Atomic rw,Some (sz,o)) -> let r,init,cs,st = emit_sta_mixed sz o rw st p init loc e.C.v in Some r,init,cs,st | W,Some (Plain a,Some (sz,o)) -> let init,cs,st = emit_store_mixed sz o st p init loc e.C.v a e in None,init,cs,st | W,Some (Rel a,Some (sz,o)) -> let module S = STORE (struct let store = stlr_mixed sz o let store_idx st r1 r2 idx = let cs,st = stlr_mixed_idx sz st r1 r2 idx in let cs = match o with | 0 -> cs | _ -> addi idx idx o::cs in cs,st let emit_mov = emit_mov_sz sz end) in let init,cs,st = S.emit_store st p init loc e.C.v a e in None,init,cs,st | W,Some (Tag,None) -> let init,cs,st = STG.emit_store st p init e in None,init,cs,st | W,Some (Pair (opt,idx),None) -> let init,cs,st = emit_stp opt idx st p init loc e in None,init,cs,st | W,Some (Pair _,Some _) -> assert false | (R|W), Some (Instr, _) -> Warn.fatal "Instr annotation did not create code location %s" (C.debug_evt e) | R,Some (Pte (Read|ReadAcq|ReadAcqPc as rk),None) -> let emit = match rk with | Read -> LDR.emit_load_var | ReadAcq -> LDAR.emit_load_var | ReadAcqPc -> LDAPR.emit_load_var | _ -> assert false in let r,init,cs,st = emit A64.V64 st p init (Misc.add_pte loc) in Some r,init,cs,st | W,Some (Pte (Set _),None) -> let init,cs,st = emit_set_pteval false st p init e.C.pte (Misc.add_pte loc) in None,init,cs,st | W,Some (Pte (SetRel _),None) -> let init,cs,st = emit_set_pteval true st p init e.C.pte (Misc.add_pte loc) in None,init,cs,st | d,Some (Pte _,_ as a) -> Warn.fatal "Atom %s does not apply to direction %s" (A.pp_atom a) (Code.pp_dir d) | _,Some (Plain _,None) -> assert false | _,Some (Tag,_) -> assert false | J,_ -> emit_joker st init | W,Some (CapaTag,None) -> let init,cs,st = STCT.emit_store st p init loc e.C.v in None,init,cs,st | W,Some (CapaTag,Some _) -> assert false | W,Some (CapaSeal,None) -> let rA,init,st = U.next_init st p init loc in let rB,init,csi,st = U.emit_mov st p init e.C.ord in let init,cs,st = emit_str_addon st p init rB rA (Some Capability) {e with C.cseal = e.C.v} in None,init,csi@cs@lift_code [str_mixed MachSize.S128 0 rB rA],st | W,Some (CapaSeal,Some _) -> assert false | W,Some (Neon n, None) -> let emit_store = match n with | SIMD.NeAcqPc -> Warn.fatal "No store acquirePc" | SIMD.NeRel -> STLUR.emit_store | SIMD.NeP -> STUR.emit_store | SIMD.NePa -> STP.emit_store A64.TT | SIMD.NePaN -> STP.emit_store A64.NT | SIMD.Sv1 | SIMD.Sv2i | SIMD.Sv3i | SIMD.Sv4i-> STNW.emit_store n | SIMD.SvV -> ST1S.emit_store n | SIMD.SmV | SIMD.SmH -> ST1T.emit_store n | _ -> STN.emit_store n in let init,cs,st = emit_store st p init loc e.C.v in None,init,cs,st | W,Some (Neon _,Some _) -> assert false end let same_sz sz1 sz2 = match sz1,sz2 with | None,None -> true | Some s1,Some s2 -> MachMixed.equal s1 s2 | (None,Some _)|(Some _,None) -> false let check_cu b = if b then Warn.fatal "Refuse to generate constrained unpredictable, use -variant CU to accept" let check_arw_lxsx er ew = let _,szr as ar = tr_none er.C.atom and _,szw as aw = tr_none ew.C.atom in check_cu (not (A64.do_cu || same_sz szr szw)) ; ar,aw let emit_addr_simple st p init er = let rA,init,st = U.next_init st p init (get_tagged_loc er) in rA,init,[],st let do_emit_exch1 emit_addr st p init er ew = let rA,init,caddr,st = emit_addr st p init er in let rR,st = next_reg st in let rW,init,csi,st = U.emit_mov st p init ew.C.v in let arw = check_arw_lxsx er ew in let init,cs,st = XSingle.emit_pair arw p st init rR rW rA ew in rR,init,csi@caddr@cs,st let emit_exch1 = do_emit_exch1 emit_addr_simple let do_emit_exch22 emit_addr st p init er ew = let rA,init,caddr,st = emit_addr st p init er in let rR1,rR2,st = next_reg2 st in let rW1,init,csi,st = U.emit_mov st p init ew.C.v in let rW2,st = next_reg st in let arw = check_arw_lxsx er ew in let init,cs,st = XPair.emit_pair arw p st init (rR1,rR2) (rW1,rW2) rA ew in rR1,init,csi@caddr@cs,st let emit_exch22 = do_emit_exch22 emit_addr_simple let do_emit_exch21 emit_addr st p init er ew = let rA,init,caddr,st = emit_addr st p init er in let rR1,rR2,st = next_reg2 st in let rW,init,csi,st = U.emit_mov st p init ew.C.v in let arw = check_arw_lxsx er ew in let module X = ExclusivePair(XLoadPair)(XStore) in let init,cs,st = X.emit_pair arw p st init (rR1,rR2) rW rA ew in rR1,init,csi@caddr@cs,st let emit_exch21 = do_emit_exch21 emit_addr_simple let do_emit_exch12 emit_addr st p init er ew = let rA,init,caddr,st = emit_addr st p init er in let rR,st = next_reg st in let rW1,init,csi,st = U.emit_mov st p init ew.C.v in let rW2,st = next_reg st in let arw = check_arw_lxsx er ew in let module X = ExclusivePair(XLoad)(XStorePair) in let init,cs,st = X.emit_pair arw p st init rR (rW1,rW2) rA ew in rR,init,csi@caddr@cs,st let emit_exch12 = do_emit_exch12 emit_addr_simple let emit_exch st p init er ew = let ar,_ = tr_none er.C.atom and aw,_ = tr_none ew.C.atom in match ar,aw with | (Pair _,Pair _) -> emit_exch22 st p init er ew | (Pair _,_) -> check_cu (not A64.do_cu) ; emit_exch21 st p init er ew | (_,Pair _) -> check_cu (not A64.do_cu) ; emit_exch12 st p init er ew | _,_ -> emit_exch1 st p init er ew let do_sz sz1 sz2 = if same_sz sz1 sz2 then sz1 else Warn.fatal "Amo instructions with different sizes or offsets" let do_rmw_type a1 a2 = match a1,a2 with | Plain o1,Plain o2 when o1 = o2 -> RMW_P,o1 | Acq o1,Plain o2 when o1 = o2 -> RMW_A,o1 | Plain o1,Rel o2 when o1 = o2 -> RMW_L,o1 | Acq o1,Rel o2 when o1 = o2 -> RMW_AL,o1 | _,_ -> Warn.fatal "Bad annotation for Amo: R=%s, W=%s" (pp_atom_acc a1) (pp_atom_acc a2) let do_rmw_annot (ar,szr) (aw,szw) = let sz = do_sz szr szw in let a,opt = do_rmw_type ar aw in sz,a,opt let mk_emit_mov sz = match sz with | None -> U.emit_mov | Some (sz,_) -> emit_mov_sz sz let mk_emit_mov_fresh sz = match sz with | None -> U.emit_mov_fresh | Some (sz,_) -> emit_mov_sz_fresh sz let do_emit_ldop_rA ins ins_mixed st p init er ew rA = assert (er.C.ctag = ew.C.ctag && er.C.cseal = ew.C.cseal) ; let sz,a,opt = do_rmw_annot (tr_none er.C.atom) (tr_none ew.C.atom) in let rR,st = next_reg st in let rW,init,csi,st = mk_emit_mov sz st p init ew.C.v in let sz = match opt with | None -> sz | Some Capability -> assert (Misc.is_none sz) ; Some (MachSize.S128, 0) in let init,csi2,st = emit_str_addon st p init rW rA opt ew in let cs,st = match sz with | None -> [ins a rW rR rA],st | Some (sz,o) -> let rA,cs,st = sumi_addr st rA o in cs@[ins_mixed sz a rW rR rA],st in let cs2 = emit_ldr_addon opt rR in rR,init,csi@csi2@pseudo (cs@cs2),st let do_emit_ldop ins ins_mixed st p init er ew = let rA,init,st = U.next_init st p init (get_tagged_loc er) in do_emit_ldop_rA ins ins_mixed st p init er ew rA let emit_swp = do_emit_ldop swp swp_mixed and emit_ldop op = do_emit_ldop (ldop op) (ldop_mixed op) let emit_cas_rA st p init er ew rA = assert (er.C.ctag = ew.C.ctag && er.C.cseal = ew.C.cseal) ; let sz,a,opt = do_rmw_annot (tr_none er.C.atom) (tr_none ew.C.atom) in let rS,init,csS,st = mk_emit_mov_fresh sz st p init er.C.v in let rT,init,csT,st = mk_emit_mov sz st p init ew.C.v in let sz = match opt with | None -> sz | Some Capability -> assert (Misc.is_none sz) ; Some (MachSize.S128, 0) in let init,csS2,st = emit_str_addon st p init rS rA opt er in let init,csT2,st = emit_str_addon st p init rT rA opt ew in let cs,st = match sz with | None -> [cas a rS rT rA],st | Some (sz,o) -> let rA,cs,st = sumi_addr st rA o in cs@[cas_mixed sz a rS rT rA],st in let cs2 = emit_ldr_addon opt rS in rS,init,csS@csS2@csT@csT2@pseudo (cs@cs2),st let emit_cas st p init er ew = let rA,init,st = U.next_init st p init (get_tagged_loc er) in emit_cas_rA st p init er ew rA let emit_stop_rA op st p init er ew rA = let a,sz1 = tr_none ew.C.atom and b,sz2 = tr_none er.C.atom in let sz = do_sz sz1 sz2 in let a = match b,a with | Plain _,Plain _-> W_P | Plain _,Rel _ -> W_L | _ -> Warn.fatal "Unexpected atoms in STOP instruction: %s,%s" (pp_atom_acc b) (pp_atom_acc a) in let rW,init,csi,st = mk_emit_mov sz st p init ew.C.v in let cs,st = match sz with | None -> [stop op a rW rA],st | Some (sz,o) -> let rA,cs,st = sumi_addr st rA o in cs@[stop_mixed op sz a rW rA],st in None,init,csi@pseudo cs,st let emit_stop op st p init er ew = let rA,init,st = U.next_init st p init (get_tagged_loc er) in emit_stop_rA op st p init er ew rA let map_some f st p init er ew = let r,init,cs,st = f st p init er ew in Some r,init,cs,st let emit_rmw rmw = match rmw with | LrSc -> map_some emit_exch | Swp -> map_some emit_swp | Cas -> map_some emit_cas | LdOp op -> map_some (emit_ldop op) | StOp op -> emit_stop op (* Fences *) let emit_cachesync s isb r = pseudo (I_DC ((match s with Strong -> DC.civac | Weak -> DC.cvau),r):: I_FENCE (DSB (ISH,FULL)):: I_IC (IC.ivau,r):: I_FENCE (DSB (ISH,FULL)):: (if isb then [I_FENCE ISB] else [])) let emit_shootdown dom op sync r = match sync with | Sync -> pseudo (I_FENCE (DSB(dom,FULL)):: I_TLBI(op,r)::I_FENCE (DSB(dom,FULL))::[]) | NoSync -> pseudo (I_TLBI(op,r)::[]) let emit_CMO t r = match t with | DC_CVAU -> pseudo ([I_DC (DC.cvau, r)]) | IC_IVAU -> pseudo ([I_IC (IC.ivau, r)]) let emit_fence st p init n f = match f with | Barrier f -> init,[Instruction (I_FENCE f)],st | Shootdown(dom,op,sync) -> let loc = match n.C.evt.C.loc with | Data loc -> loc | Code _ -> Warn.user_error "TLBI/CacheSync" in let open TLBI in let r,init,csr,st = match op.TLBI.typ with | ALL|VMALL|VMALLS12 -> ZR,init,[],st | ASID|VA|VAL|VAA|VAAL|IPAS2|IPAS2L -> let r,init,st = U.next_init st p init loc in let r1,st = tempo1 st in let cs = [Instruction (lsri64 r1 r 12)] in r1,init,cs,st in let cs = emit_shootdown dom op sync r in init,csr@cs,st | CacheSync (s,isb) -> begin try let lab = C.find_prev_code_write n in let r,init,st = U.next_init st p init lab in init,emit_cachesync s isb r,st with Not_found -> Warn.user_error "No code write before CacheSync" end | CMO (t,dirloc) -> let loc = let n0 = match dirloc with | Next -> C.find_non_pseudo n | Prev -> C.find_non_pseudo_prev n in match n0.C.evt.C.loc with | Data loc -> loc | Code lab -> lab in let r,init,st = U.next_init st p init loc in init,emit_CMO t r,st let stronger_fence = strong (* Dependencies *) let calc0 = if Cfg.realdep then fun vdep dst src -> andi vdep dst src 128 else fun vdep dst src -> eor vdep dst src src let calc0_gen csel st vdep = match csel with | NoCsel -> fun src dst -> [calc0 vdep src dst],st | OkCsel -> fun dst src -> let r3,st = next_reg st in let r4,st = next_reg st in [do_movi vdep r3 1; do_cmpi vdep src 0; do_csel vdep dst r3 r4; andi vdep dst dst 2;],st let emit_access_dep_addr csel vdep st p init e rd = let r2,st = next_reg st in let cs0,st = calc0_gen csel st vdep r2 rd in match e.C.dir,e.C.loc with | None,_ -> Warn.fatal "TODO" | Some d,Data loc -> let loc = add_tag loc e.C.tag in let atom = match e.C.atom with | None -> None | Some (a,m) -> begin match a with | Plain Some Capability | Acq Some Capability | AcqPc Some Capability | Rel Some Capability -> assert (Misc.is_none m) ; Some (a,Some (MachSize.S128,0)) | _ -> Some (a,m) end in begin match d,atom with | R,None -> let r,init,cs,st = LDR.emit_load_idx_var vloc vdep st p init loc r2 in Some r,init, pseudo cs0@cs,st | R,Some (Acq _,None) -> let r,init,cs,st = LDAR.emit_load_idx_var vloc vdep st p init loc r2 in Some r,init, pseudo cs0@cs,st | R,Some (Acq a,Some (sz,o)) -> let load = do_emit_load_idx_var next_reg_sz (fun sz _ -> do_ldar_mixed_idx vdep AA sz o) sz sz in let r,init,cs,st = load st p init loc r2 in let cs2 = emit_ldr_addon a r in Some r,init,pseudo cs0@cs@pseudo cs2,st | R,Some (AcqPc _,None) -> let r,init,cs,st = LDAPR.emit_load_idx_var vloc vdep st p init loc r2 in Some r,init, pseudo cs0@cs,st | R,Some (AcqPc a,Some (sz,o)) -> let load = do_emit_load_idx_var next_reg_sz (fun sz _ -> do_ldar_mixed_idx vdep AQ sz o) sz sz in let r,init,cs,st = load st p init loc r2 in let cs2 = emit_ldr_addon a r in Some r,init,pseudo cs0@cs@pseudo cs2,st | R,Some (Rel _,_) -> Warn.fatal "No load release" | R,Some (Atomic rw,None) -> let r,init,cs,st = do_emit_lda_idx vdep (tr_rw rw) st p init loc r2 in Some r,init, pseudo cs0@cs,st | R,Some (Atomic rw,Some (sz,o)) -> let r,init,cs,st = do_emit_lda_mixed_idx vdep sz o rw st p init loc r2 in Some r,init, pseudo cs0@cs,st | R,Some (Tag,None) -> let r,init,cs,st = LDG.emit_load_idx vdep st p init loc r2 in Some r,init, pseudo cs0@cs,st | R,Some (Tag,Some _) -> assert false | R,Some (CapaTag,None) -> (* TODO: don't waste r2 *) let r,init,cs,st = LDCT.emit_load_idx st p init loc rd in Some r,init,cs,st | R,Some (CapaTag,Some _) -> assert false | R,Some (CapaSeal,None) -> (* TODO: don't waste r2 *) let (_,rA),init,cs,st = seal_dp_addr init p loc st rd e.C.dep in let rB,st = next_reg st in Some rB,init,cs@lift_code [ldr_mixed rB rA MachSize.S128 0; gctype rB rB],st | R,Some (CapaSeal,Some _) -> assert false | R,Some (Neon n,None) -> let emit_load_idx = match n with | SIMD.NeRel -> Warn.fatal "No laod release" | SIMD.NeAcqPc -> LDAPUR.emit_load_idx | SIMD.NeP -> LDUR.emit_load_idx | SIMD.NePa -> LDP.emit_load_idx A64.TT | SIMD.NePaN -> LDP.emit_load_idx A64.NT | SIMD.Sv1 | SIMD.Sv2i | SIMD.Sv3i | SIMD.Sv4i -> LDNW.emit_load_idx n | SIMD.SvV -> LD1G.emit_load_idx n | SIMD.SmV | SIMD.SmH -> LD1T.emit_load_idx n | _ -> LDN.emit_load_idx n in let rB,init,cs,st = emit_load_idx vdep st p init loc r2 in Some rB,init,pseudo cs0@cs,st | R,Some (Pair (opt,idx),None) -> let r,init,cs,st = emit_ldp_idx_var opt idx vdep st p init loc r2 in Some r,init, pseudo cs0@cs,st | R,Some ((Neon _|Pair _),Some _) -> assert false | W,None -> let module STR = STORE (struct let store = wrap_st str let store_idx st rA rB idx = [do_str_idx vdep rA rB idx],st let emit_mov = U.emit_mov end) in let init,cs,st = STR.emit_store_idx st p init loc r2 e.C.v None C.evt_null in None,init,pseudo cs0@cs,st | W,Some (Rel _,None) -> let module STLR = STORE (struct let store = wrap_st stlr let store_idx st rA rB idx = let r,ins,st = do_sum_addr vdep st rB idx in ins@[stlr rA r],st let emit_mov = U.emit_mov end) in let init,cs,st = STLR.emit_store_idx st p init loc r2 e.C.v None C.evt_null in None,init,pseudo cs0@cs,st | W,Some (Rel a,Some (sz,o)) -> let module S = STORE (struct let store = stlr_mixed sz o let store_idx st r1 r2 idx = let cs,st = stlr_mixed_idx sz st r1 r2 idx in let cs = match o with | 0 -> cs | _ -> addi idx idx o::cs in cs,st let emit_mov = emit_mov_sz sz end) in let init,cs,st = S.emit_store_idx st p init loc r2 e.C.v a e in None,init,pseudo cs0@cs,st | W,Some (Acq _,_) -> Warn.fatal "No store acquire" | W,Some (AcqPc _,_) -> Warn.fatal "No store acquirePc" | (R|W), Some (Instr, _) -> Warn.fatal "No dependency to code location" | W,Some (Atomic rw,None) -> let r,init,cs,st = emit_sta_idx (tr_rw rw) st p init loc r2 e.C.v in Some r,init,pseudo cs0@cs,st | W,Some (Atomic rw,Some (sz,o)) -> let r,init,cs,st = emit_sta_mixed_idx sz o rw st p init loc r2 e.C.v in Some r,init,pseudo cs0@cs,st | R,Some (Plain a,Some (sz,o)) -> let load_idx sz _ st r1 r2 idx = let cs = [ldr_mixed_idx vdep r1 r2 idx sz] in let cs = match o with | 0 -> cs | _ -> do_addi vdep idx idx o::cs in cs,st in let load = do_emit_load_idx_var next_reg_sz load_idx sz sz in let r,init,cs,st = load st p init loc r2 in let cs2 = emit_ldr_addon a r in Some r,init,pseudo cs0@cs@pseudo cs2,st | W,Some (Plain a,Some (sz,o)) -> let module S = STORE (struct let store = wrap_st (str_mixed sz o) let store_idx st r1 r2 idx = let cs = [str_mixed_idx sz vdep r1 r2 idx] in let cs = match o with | 0 -> cs | _ -> do_addi vdep idx idx o::cs in cs,st let emit_mov = emit_mov_sz sz end) in let init,cs,st = S.emit_store_idx st p init loc r2 e.C.v a e in None,init,pseudo cs0@cs,st | W,Some (Tag, None) -> let init,cs,st = STG.emit_store_idx vdep st p init e r2 in None,init,pseudo cs0@cs,st | W,Some (Pair (opt,idx),None) -> let init,cs,st = emit_stp_idx_var opt idx vdep st p init loc e r2 in None,init, pseudo cs0@cs,st | W,Some (Pair _,_) -> assert false | (W,(Some (Pte (Set _),None))) -> let init,cs,st = emit_set_pteval_idx false vdep r2 st p init e.C.pte (Misc.add_pte loc) in None,init,pseudo cs0@cs,st | (W,(Some (Pte (SetRel _),None))) -> let init,cs,st = emit_set_pteval_idx true vdep r2 st p init e.C.pte (Misc.add_pte loc) in None,init,pseudo cs0@cs,st | (R,(Some (Pte (Read|ReadAcq|ReadAcqPc as rk),None))) -> let emit = match rk with | Read -> LDR.emit_load_var_reg | ReadAcq -> LDAR.emit_load_var_reg | ReadAcqPc -> LDAPR.emit_load_var_reg | _ -> assert false in let loc = Misc.add_pte loc in let rA,init,st = U.next_init st p init loc in let rA,cs1,st = do_sum_addr vdep st rA r2 in let r,init,cs,st = emit A64.V64 st p init rA in Some r,init,pseudo cs0@pseudo cs1@cs,st | (W|R) as d,Some (Pte _,_ as a) -> Warn.fatal "Annotation %s does not apply to direction %s" (A64.pp_atom a) (Code.pp_dir d) | W,Some (Tag,Some _) -> assert false | W,Some (CapaTag,None) -> (* TODO: don't waste r2 *) let init,cs,st = STCT.emit_store_idx st p init loc rd e.C.v in None,init,cs,st | W,Some (CapaTag,Some _) -> assert false | W,Some (CapaSeal,None) -> (* TODO: don't waste r2 *) let (rA,rB),init,csi,st = seal_dp_addr init p loc st rd e.C.dep in let rC,init,csi2,st = U.emit_mov st p init e.C.ord in let init,cs,st = emit_str_addon st p init rC rA (Some Capability) {e with C.cseal = e.C.v} in None,init, csi@csi2@cs@lift_code [str_mixed MachSize.S128 0 rC rB],st | W,Some (CapaSeal,Some _) -> assert false | W,Some (Neon n,None) -> let emit_store_idx = match n with | SIMD.NeAcqPc -> Warn.fatal "No store acquirePc" | SIMD.NeRel -> STLUR.emit_store_idx | SIMD.NeP -> STUR.emit_store_idx | SIMD.NePa -> STP.emit_store_idx A64.TT | SIMD.NePaN -> STP.emit_store_idx A64.NT | SIMD.Sv1 | SIMD.Sv2i | SIMD.Sv3i | SIMD.Sv4i -> STNW.emit_store_idx n | SIMD.SvV -> ST1S.emit_store_idx n | SIMD.SmV | SIMD.SmH -> ST1T.emit_store_idx n | _ -> STN.emit_store_idx n in let init,cs,st = emit_store_idx vdep st p init loc r2 e.C.v in None,init,pseudo cs0@cs,st | W,Some (Neon _,Some _) -> assert false | J,_ -> emit_joker st init | _,Some (Plain _,None) -> assert false end | _,Code _ -> Warn.fatal "No dependency to code location" let emit_addr_dep csel vdep st p init loc rd = let r2,st = next_reg st in let cs0,st = calc0_gen csel st vdep r2 rd in let rA,init,st = U.next_init st p init loc in let rA,csum,st = do_sum_addr vdep st rA r2 in rA,init,pseudo (cs0@csum),st let emit_exch_dep_addr1 csel vdep st p init er ew rd = do_emit_exch1 (fun st p init er -> emit_addr_dep csel vdep st p init (get_tagged_loc er) rd) st p init er ew let emit_exch_dep_addr22 csel vdep st p init er ew rd = do_emit_exch22 (fun st p init er -> emit_addr_dep csel vdep st p init (get_tagged_loc er) rd) st p init er ew let emit_exch_dep_addr21 csel vdep st p init er ew rd = do_emit_exch21 (fun st p init er -> emit_addr_dep csel vdep st p init (get_tagged_loc er) rd) st p init er ew let emit_exch_dep_addr12 csel vdep st p init er ew rd = do_emit_exch12 (fun st p init er -> emit_addr_dep csel vdep st p init (get_tagged_loc er) rd) st p init er ew let emit_exch_dep_addr csel vdep st p init er ew rd = let ar,_ = tr_none er.C.atom and aw,_ = tr_none ew.C.atom in match ar,aw with | (Pair _,Pair _)-> emit_exch_dep_addr22 csel vdep st p init er ew rd | (Pair _,_) -> check_cu (not A64.do_cu); emit_exch_dep_addr21 csel vdep st p init er ew rd | (_,Pair _) -> check_cu (not A64.do_cu); emit_exch_dep_addr12 csel vdep st p init er ew rd | _,_ -> emit_exch_dep_addr1 csel vdep st p init er ew rd let emit_access_dep_data csel vdep st p init e r1 = let atom = match e.C.atom with | None -> None | Some (a,m) -> begin match a with | Plain Some Capability | Acq Some Capability | AcqPc Some Capability | Rel Some Capability -> assert (Misc.is_none m) ; Some (a,Some (MachSize.S128,0)) | _ -> Some (a,m) end in match e.C.dir,e.C.loc with | None,_ -> Warn.fatal "TODO" | Some R,_ -> Warn.fatal "data dependency to load" | Some W,Data loc -> let r2,cs2,init,st,addi = let r2,st = next_reg st in match atom with | Some (Tag,None) -> let cs0,st = calc0_gen csel st vdep r2 r1 in let rA,init,st = U.next_init st p init (add_tag loc e.C.v) in let rB,cB,st = sum_addr st rA r2 in rB,pseudo (cs0@cB),init,st,[] | Some (_,Some (sz,_)) -> let cs0,st = calc0_gen csel st vdep r2 r1 in let rA,init,csA,st = emit_mov_sz sz st p init e.C.v in let cs2 = pseudo cs0 in let addi = [add (sz2v sz) r2 r2 rA] in r2,csA@cs2,init,st,addi | Some (CapaSeal,None) -> let cs0,st = calc0_gen csel st vdep r2 r1 in let cs2 = pseudo cs0 in let addi = [addi r2 r2 e.C.ord] in r2,cs2,init,st,addi | Some (Pte _,None) -> let rA,init,st = U.emit_pteval st p init e.C.pte in let cs,st = match vdep with | A64.V128 -> Warn.fatal "128 bit dependency to pte access" | A64.V64 -> calc0_gen csel st A64.V64 r2 r1 | A64.V32 -> let r3,st = tempo1 st in let cs0,st = calc0_gen csel st A64.V64 r2 r3 in sxtw r3 r1::cs0,st in let addi = [add A64.V64 r2 r2 rA] in let cs2 = pseudo cs in r2,cs2,init,st,addi | _ -> let cs2,st = match vdep,vloc with | (V128,_)|(_,V128) -> Warn.fatal "dependance from 128 bits access" | (V32,V32)|(V64,V64)|(V64,V32) -> calc0_gen csel st vdep r2 r1 | (V32,V64) -> let r3,st = tempo1 st in let cs,st = calc0_gen csel st vdep r3 r1 in sxtw r2 r3::cs,st in let addi = [addi r2 r2 e.C.v] in let cs2 = pseudo cs2 in r2,cs2,init,st,addi in let r2,cs2,init,st = match atom with | Some(Neon _, None) -> r2,cs2,init,st | _ -> r2,cs2@pseudo addi,init,st in let loc = add_tag loc e.C.tag in begin match atom with | None -> let init,cs,st = STR.emit_store_reg st p init loc r2 None C.evt_null in None,init,cs2@cs,st | Some (Rel _,None) -> let init,cs,st = STLR.emit_store_reg st p init loc r2 None C.evt_null in None,init,cs2@cs,st | Some (Rel a,Some (sz,o)) -> let module S = STORE (struct let store = stlr_mixed sz o let store_idx _st _r1 _r2 _idx = assert false let emit_mov = emit_mov_sz sz end) in let init,cs,st = S.emit_store_reg st p init loc r2 a e in None,init,cs2@cs,st | Some (Atomic rw,None) -> let r,init,cs,st = emit_sta_reg (tr_rw rw) st p init loc r2 in Some r,init,cs2@cs,st | Some (Atomic rw,Some (sz,o)) -> let r,init,cs,st = emit_sta_mixed_reg sz o rw st p init loc r2 in Some r,init,cs2@cs,st | Some (Acq _,_) -> Warn.fatal "No store acquire" | Some (AcqPc _,_) -> Warn.fatal "No store acquirePc" | Some (Instr, _) -> Warn.fatal "No Plain Write to label (code location)" | Some (Plain a,Some (sz,o)) -> let module S = STORE (struct let store = wrap_st (str_mixed sz o) let store_idx st r1 r2 idx = let cs = [str_mixed_idx sz V64 r1 r2 idx] in let cs = match o with | 0 -> cs | _ -> addi_64 idx idx o::cs in cs,st let emit_mov = emit_mov_sz sz end) in let init,cs,st = S.emit_store_reg st p init loc r2 a e in None,init,cs2@cs,st | Some (Tag, None) -> let init,cs,st = STG.emit_store_reg st p init loc r2 in None,init,cs2@cs,st | Some (Pte (Set _),None) -> let init,cs,st = emit_set_pteval_reg false st p init r2 (Misc.add_pte loc) in None,init,cs2@cs,st | Some (Pte (SetRel _),None) -> let init,cs,st = emit_set_pteval_reg true st p init r2 (Misc.add_pte loc) in None,init,cs2@cs,st | Some ((Pte _,Some _)|(Pte (Read|ReadAcq|ReadAcqPc),_)) -> assert false | Some (Plain _,None) -> assert false | Some (Tag,Some _) -> assert false | Some (CapaTag,None) -> if e.C.v > 1 then Warn.fatal "Capability tags can't be incremented above 1"; let init,cs,st = STCT.emit_store_reg st p init loc r2 in None,init,cs2@cs,st | Some (CapaTag,Some _) -> assert false | Some (CapaSeal,None) -> let rA,init,st = U.next_init st p init loc in let init,cs,st = emit_str_addon st p init r2 rA (Some Capability) {e with C.cseal = e.C.v} in None,init,cs2@cs@lift_code [str_mixed MachSize.S128 0 r2 rA],st | Some (CapaSeal,Some _) -> assert false | Some (Neon n,None) -> let rA,init,st = U.next_init st p init loc in let emit_store_dep = match n with | SIMD.NeAcqPc -> Warn.fatal "No store acquirePc" | SIMD.NeRel -> STLUR.emit_store_dep | SIMD.NeP -> STUR.emit_store_dep | SIMD.NePa -> STP.emit_store_dep A64.TT | SIMD.NePaN -> STP.emit_store_dep A64.NT | SIMD.Sv1 | SIMD.Sv2i | SIMD.Sv3i | SIMD.Sv4i -> STNW.emit_store_dep n | SIMD.SvV -> ST1S.emit_store_dep n | SIMD.SmV | SIMD.SmH -> ST1T.emit_store_dep n | _ -> STN.emit_store_dep n in let init,cs,st = emit_store_dep r2 st init rA e.C.v in None,init,cs2@cs,st | Some (Neon _,Some _) -> assert false | Some (Pair (opt,idx),None) -> let init,cs,st = stp_emit_store_reg opt idx st p init loc r2 in None,init,cs2@cs,st | Some (Pair _,Some _) -> assert false end | Some J,_ -> emit_joker st init | _,Code _ -> Warn.fatal "Not Yet (%s,dep_data)" (C.debug_evt e) let is_ctrlisync = function | D.CTRLISYNC -> true | _ -> false let insert_isb isb cs1 cs2 = if isb then cs1@[Instruction (I_FENCE ISB)]@cs2 else cs1@cs2 let emit_ctrl vdep r = let lab = Label.next_label "LC" in let c = [Instruction (do_cbnz vdep r lab); Label (lab,Nop);] in c let emit_ctrl_gen csel st vdep r = match csel with | NoCsel -> emit_ctrl vdep r,st | OkCsel -> let r2,st = next_reg st in let r3,st = next_reg st in pseudo [do_cmpi vdep r 0; do_cinc vdep r2 r3 r2;]@ emit_ctrl vdep r2, st let emit_access_ctrl csel vdep isb st p init e r1 = let c,st = emit_ctrl_gen csel st vdep r1 in let ropt,init,cs,st = emit_access st p init e in ropt,init,insert_isb isb c cs,st let emit_exch_ctrl csel vdep isb st p init er ew r1 = let c,st = emit_ctrl_gen csel st vdep r1 in let ropt,init,cs,st = emit_exch st p init er ew in ropt,init,insert_isb isb c cs,st let tr_atom = function | Some ((Tag|Pte _),_) -> V64 | at -> begin match A64.get_access_atom at with | Some (sz,_) -> sz2v sz | None -> vloc end let node2vdep n = let e = n.C.evt in let at = e.C.atom in tr_atom at let emit_access_dep st p init e (dp,csel) r1 n1 = let vdep = node2vdep n1 in match dp with | D.ADDR -> emit_access_dep_addr csel vdep st p init e r1 | D.DATA -> emit_access_dep_data csel vdep st p init e r1 | D.CTRL -> emit_access_ctrl csel vdep false st p init e r1 | D.CTRLISYNC -> emit_access_ctrl csel vdep true st p init e r1 let emit_exch_dep st p init er ew (dp,csel) vdep rd = match dp with | D.ADDR -> emit_exch_dep_addr csel vdep st p init er ew rd | D.DATA -> Warn.fatal "not data dependency to RMW" | D.CTRL -> emit_exch_ctrl csel vdep false st p init er ew rd | D.CTRLISYNC -> emit_exch_ctrl csel vdep true st p init er ew rd let emit_ldop_dep ins ins_mixed st p init er ew (dp,csel) vdep rd = match dp with | D.ADDR -> let rA,init,caddr,st = emit_addr_dep csel vdep st p init (get_tagged_loc er) rd in let rR,init,cs,st = do_emit_ldop_rA ins ins_mixed st p init er ew rA in rR,init,caddr@cs,st | D.CTRL|D.CTRLISYNC -> let c = emit_ctrl vdep rd in let rR,init,cs,st = do_emit_ldop ins ins_mixed st p init er ew in rR,init,insert_isb (is_ctrlisync dp) c cs,st | D.DATA -> Warn.fatal "Data dependency to LDOP" let emit_cas_dep st p init er ew (dp,csel) vdep rd = match dp with | D.ADDR -> let rA,init,caddr,st = emit_addr_dep csel vdep st p init (get_tagged_loc er) rd in let rR,init,cs,st = emit_cas_rA st p init er ew rA in rR,init,caddr@cs,st | D.CTRL|D.CTRLISYNC -> let c,st = emit_ctrl_gen csel st vdep rd in let rR,init,cs,st = emit_cas st p init er ew in rR,init,insert_isb (is_ctrlisync dp) c cs,st | D.DATA -> Warn.fatal "Data dependency to CAS" let emit_stop_dep op st p init er ew (dp,csel) rd n = let vdep = node2vdep n in match dp with | D.ADDR -> let rA,init,caddr,st = emit_addr_dep csel vdep st p init (get_tagged_loc er) rd in let rR,init,cs,st = emit_stop_rA op st p init er ew rA in rR,init,caddr@cs,st | D.CTRL|D.CTRLISYNC -> let c,st = emit_ctrl_gen csel st vdep rd in let rR,init,cs,st = emit_stop op st p init er ew in rR,init,insert_isb (is_ctrlisync dp) c cs,st | D.DATA -> Warn.fatal "Data dependency to STOP" let map_some_dp f st p init er ew dp rd n = let vdep = node2vdep n in let r,init,cs,st = f st p init er ew dp vdep rd in Some r,init,cs,st let emit_rmw_dep rmw = match rmw with | LrSc -> map_some_dp emit_exch_dep | LdOp op -> map_some_dp (emit_ldop_dep (ldop op) (ldop_mixed op)) | Swp -> map_some_dp (emit_ldop_dep swp swp_mixed) | Cas -> map_some_dp emit_cas_dep | StOp op -> emit_stop_dep op let emit_fence_dp st p init n f (dp,csel) r1 n1 = let vdep = node2vdep n1 in match dp with | D.ADDR -> let n2 = C.find_non_pseudo n in let loc = match n2.C.evt.C.loc with | Data loc -> loc | Code lab -> match f with | CMO (_,Next) -> lab | _ -> Warn.fatal "Address dependency to code location must be directly followed by DC.CVAUn or IC.IVAUn" in (try ignore (C.find_node (fun m -> match m.C.edge.E.edge with | E.Insert (CMO (_,Prev)) when (loc_eq m.C.evt.C.loc n.C.evt.C.loc) -> Warn.fatal "Address dependency to code location cannot have IC.IVAUp or DC.CVAUp" | _ -> false ) n) with Not_found -> ()); let r2,st = next_reg st in let cs0,st = calc0_gen csel st vdep r2 r1 in let rB,init,st = U.next_init st p init loc in let r,st = match f with | CMO _ -> rB,st | _ -> tempo1 st in let cs2 = (if do_morello then [do_addcapa rB r r2] else [do_add64 vloc rB r r2]) in let _,cs, st = emit_fence st p init n f in None, init, pseudo cs0@pseudo cs2@cs, st | D.DATA -> let init,cs, st = emit_fence st p init n f in Some r1, init, cs, st | D.CTRL | D.CTRLISYNC -> let c,st = emit_ctrl_gen csel st vdep r1 in let init,cs,st = emit_fence st p init n f in None,init,insert_isb (is_ctrlisync dp) c cs,st let do_check_load p st r e = let ok,st = A.ok_reg st in (fun k -> Instruction (cmpi r e.C.v):: Instruction (bne (Label.last p)):: Instruction (incr ok):: k), A.next_ok st let check_load p r e init st = let cs,st = do_check_load p st r e in init,cs,st (* Postlude *) let postlude = mk_postlude (fun st p init loc r -> STR.emit_store_reg st p init loc r None C.evt_null) let get_strx_result k = function | I_STXR (_,_,r,_,_)|I_STXRBH (_,_,r,_,_) -> r::k | _ -> k let get_strx_result_pseudo k = pseudo_fold get_strx_result k let get_xstore_results = match Cfg.unrollatomic with | Some x when x <= 0 -> fun cs -> let rs = List.fold_left get_strx_result_pseudo [] cs in List.rev_map (fun r -> r,0) rs | Some _|None -> fun _ -> [] include NoInfo end herd-herdtools7-1ca343e/gen/ARMArch_gen.ml000066400000000000000000000055051475314470400203200ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2011-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Printf module Config = struct let moreedges = false end module Make(C:sig val moreedges : bool end) = struct include ARMBase module ScopeGen = ScopeGen.NoGen let tr_endian = Misc.identity include MachAtom.Make (struct let naturalsize=None let endian = endian let fullmixed = C.moreedges end) module PteVal = PteVal_gen.No(struct type arch_atom = atom end) (**********) (* Fences *) (**********) type fence = DMB of barrier_option | DSB of barrier_option | ISB let is_isync = function | ISB -> true | _ -> false let compare_fence = compare let default = DMB SY let strong = default let pp_fence = function | DMB SY -> "DMB" | DMB o -> sprintf "DMB.%s" (pp_option o) | DSB SY -> "DSB" | DSB o -> sprintf "DSB.%s" (pp_option o) | ISB -> "ISB" let fo f r = f SY (f ST r) let fold_cumul_fences f r = fo (fun o -> f (DMB o)) (fo (fun o -> f (DSB o)) r) let fold_all_fences f r = f ISB (fold_cumul_fences f r) (* Do not include DSB in 'some fences' at the moment *) let fold_some_fences f r = f ISB (fo (fun o -> f (DMB o)) r) let orders _f _d1 _d2 =true let var_fence f r = f default r (********) (* Deps *) (********) include Dep let pp_dp = function | ADDR -> "Addr" | DATA -> "Data" | CTRL -> "Ctrl" | CTRLISYNC -> "CtrlIsb" (*******) (* RWM *) (*******) include Exch.LxSx(struct type arch_atom = atom end) include NoEdge include ArchExtra_gen.Make (struct type arch_reg = reg let is_symbolic = function | Symbolic_reg _ -> true | _ -> false let pp_reg = pp_reg let pp_i _ = assert false let free_registers = allowed_for_symb include NoSpecial end) end herd-herdtools7-1ca343e/gen/ARMCompile_gen.ml000066400000000000000000000330571475314470400210360ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Code module type Config = sig include CompileCommon.Config val realdep : bool end module Make(Cfg:Config) : XXXCompile_gen.S = struct module ARM = ARMArch_gen.Make(Cfg) include CompileCommon.Make(Cfg)(ARM) (******) let ppo _f k = k open ARM open C (* Utilities *) let next_reg x = ARM.alloc_reg x module Extra = struct let use_symbolic = true type reg = ARM.reg type instruction = ARM.pseudo let mov r v = Instruction (I_MOVI (r,v,AL)) let mov_mixed _sz _r _v = Warn.fatal "No mixed size for ARM" let mov_reg r1 r2 = Instruction (I_MOV (r1,r2,AL)) let mov_reg_mixed _sz _r _v = Warn.fatal "No mixed size for ARM" end module U = GenUtils.Make(Cfg)(ARM)(Extra) (* RMW utilities *) let tempo1 = ARM.Symbolic_reg "T1" (* May be used for address, and loop observer index *) let tempo2 = ARM.Symbolic_reg "T2" (* utility *) let emit_loop_pair _p st r1 r2 addr = let lab = Label.next_label "Loop" in Label (lab,Nop):: lift_code [I_LDREX (r1,addr) ; I_STREX (tempo2,r2,addr,AL); I_CMPI (tempo2,0); I_BNE (lab); ],st let emit_one_pair p st r1 r2 addr k = let ok,st = A.ok_reg st in (lift_code [I_LDREX (r1,addr); I_STREX (tempo2,r2,addr,AL); I_CMPI (tempo2,0); I_BNE (Label.last p);]) @k [Instruction (I_ADD (DontSetFlags,ok,ok,1));], A.next_ok st let emit_unroll_pair u p st r1 r2 addr = if u <= 0 then lift_code [I_LDREX (r1,addr); I_STREX (tempo2,r2,addr,AL);], st else if u = 1 then emit_one_pair p st r1 r2 addr Misc.identity else let out = Label.next_label "Go" in let rec do_rec = function | 1 -> emit_one_pair p st r1 r2 addr (fun k -> Label (out,Nop)::k) | u -> let cs,st = do_rec (u-1) in lift_code [I_LDREX (r1,addr); I_STREX (tempo2,r2,addr,AL); I_CMPI (tempo2,0); I_BEQ out;]@cs,st in do_rec u let emit_pair = match Cfg.unrollatomic with | None -> emit_loop_pair | Some u -> emit_unroll_pair u (*********) (* loads *) (*********) let emit_load st p init x = let rA,st = next_reg st in let rB,init,st = U.next_init st p init x in rA,init,lift_code [I_LDR (rA,rB,AL)],st let emit_obs _ = emit_load let emit_obs_not_zero st p init x = let rA,st = next_reg st in let rB,init,st = U.next_init st p init x in let lab = Label.next_label "L" in rA,init, Label (lab,Nop)::lift_code [I_LDR (rA,rB,AL); I_CMPI (rA,0); I_BEQ (lab)], st let emit_load_one st p init x = let rA,st = next_reg st in let rB,init,st = U.next_init st p init x in let lab = Label.next_label "L" in rA,init, Label (lab,Nop)::lift_code [I_LDR (rA,rB,AL); I_CMPI (rA,1); I_BNE (lab)], st let emit_load_not st p init x cmp = let rA,st = next_reg st in let rC = tempo1 in let rB,init,st = U.next_init st p init x in let lab = Label.next_label "L" in let out = Label.next_label "L" in rA,init, Instruction (I_MOVI (rC,200,AL)):: (* 200 X about 5 ins looks for a typical memory delay *) Label (lab,Nop):: lift_code [ I_LDR (rA,rB,AL); cmp rA ; I_BNE out; I_ADD (DontSetFlags,rC,rC,-1) ; I_CMPI (rC,0) ; I_BNE lab ; ]@ [Label (out,Nop)], st let emit_obs_not_eq st p init x rP = emit_load_not st p init x (fun r -> I_CMP (r,rP)) let emit_obs_not_value st p init x v = emit_load_not st p init x (fun r -> I_CMPI (r,v)) let emit_load_idx st p init x idx = let rA,st = next_reg st in let rB,init,st = U.next_init st p init x in rA,init,lift_code [I_LDR3 (rA,idx,rB,AL)],st (**********) (* Stores *) (**********) let emit_store_reg st p init x rA = let rB,init,st = U.next_init st p init x in init,[Instruction (I_STR (rA,rB,AL))],st let emit_store_idx_reg st p init x idx rA = let rB,init,st = U.next_init st p init x in init,[Instruction (I_STR3 (rA,idx,rB,AL))],st let emit_store st p init x v = let rA,init,csi,st = U.emit_mov st p init v in let init,cs,st = emit_store_reg st p init x rA in init,csi@cs,st let emit_store_idx st p init x idx v = let rA,init,csi,st = U.emit_mov st p init v in let init,cs,st = emit_store_idx_reg st p init x idx rA in init,csi@cs,st let emit_one_strex_reg st p init rA v = let ok,st = A.ok_reg st in let rV,init,csi,st = U.emit_mov st p init v in init, csi@lift_code [I_STREX (tempo2,rV,rA,AL); I_CMPI (tempo2,0); I_BNE (Label.last p); I_ADD (DontSetFlags,ok,ok,1);], A.next_ok st let emit_ldrex_reg st _p init rB = let rA,st = next_reg st in rA,init,lift_code [I_LDREX (rA,rB)],st let emit_ldrex st p init x = let rB,init,st = U.next_init st p init x in emit_ldrex_reg st p init rB let emit_ldrex_idx st p init x idx = let rA,st = next_reg st in let rB,init,st = U.next_init st p init x in rA,init, lift_code [I_ADD3 (DontSetFlags,tempo1,idx,rB); I_LDREX (rA,tempo1)],st (* LDA *) let emit_lda st p init x = let rA,init,st = U.next_init st p init x in let rR,st = next_reg st in let cs,st = emit_pair p st rR rR rA in rR,init,cs,st let emit_lda_idx st p init x idx = let rA,init,st = U.next_init st p init x in let rR,st = next_reg st in let cs,st = emit_pair p st rR rR tempo1 in rR,init, Instruction (I_ADD3 (DontSetFlags,tempo1,idx,rA))::cs, st (* STA *) let emit_sta_reg st p init x rW = let rA,init,st = U.next_init st p init x in let rR,st = next_reg st in let cs,st = emit_pair p st rR rW rA in Some rR,init,cs,st let emit_sta st p init x v = let rW,init,csi,st = U.emit_mov st p init v in let ro,init,cs,st = emit_sta_reg st p init x rW in ro,init,csi@cs,st let emit_sta_idx st p init x idx v = let rA,init,st = U.next_init st p init x in let rW,init,csi,st = U.emit_mov st p init v in let rR,st = next_reg st in let cs,st = emit_pair p st rR rW tempo1 in Some rR, init, csi@Instruction (I_ADD3 (DontSetFlags,tempo1,idx,rA))::cs,st (*************) (* Acccesses *) (*************) let emit_joker st init = None,init,[],st let emit_access st p init e = match e.dir with | None -> Warn.fatal "ARMCompile.emit_access" | Some d -> match d,e.atom,e.loc with | R,None,Data loc -> let r,init,cs,st = emit_load st p init loc in Some r,init,cs,st | R,Some Reserve,Data loc -> let r,init,cs,st = emit_ldrex st p init loc in Some r,init,cs,st | R,Some Atomic,Data loc -> let r,init,cs,st = emit_lda st p init loc in Some r,init,cs,st | W,None,Data loc -> let init,cs,st = emit_store st p init loc e.v in None,init,cs,st | W,Some Reserve,Data _ -> Warn.fatal "No store with reservation" | W,Some Atomic,Data loc -> let ro,init,cs,st = emit_sta st p init loc e.v in ro,init,cs,st | _,Some (Mixed _),Data _ -> assert false | Code.J,_,Data _ -> emit_joker st init | _,_,Code _ -> Warn.fatal "No code location in ARM" let emit_exch st p init er ew = let rA,init,st = U.next_init st p init (as_data er.loc) in let rW,init,csi,st = U.emit_mov st p init ew.v in let rR,st = next_reg st in let cs,st = emit_pair p st rR rW rA in Some rR,init,csi@cs,st let emit_rmw _ = emit_exch let calc0 = if Cfg.realdep then fun r2 r1 -> I_AND (DontSetFlags,r2,r1,128) else fun r2 r1 -> I_XOR (DontSetFlags,r2,r1,r1) let emit_access_dep_addr st p init e r1 = let r2,st = next_reg st in let c = calc0 r2 r1 in match Misc.as_some e.dir,e.atom,e.loc with | R,None,Data loc -> let r,init,cs,st = emit_load_idx st p init loc r2 in Some r,init, Instruction c::cs,st | R,Some Reserve,Data loc -> let r,init,cs,st = emit_ldrex_idx st p init loc r2 in Some r,init, Instruction c::cs,st | R,Some Atomic,Data loc -> let r,init,cs,st = emit_lda_idx st p init loc r2 in Some r,init, Instruction c::cs,st | W,None,Data loc -> let init,cs,st = emit_store_idx st p init loc r2 e.v in None,init,Instruction c::cs,st | W,Some Reserve,Data _ -> Warn.fatal "No store with reservation" | W,Some Atomic,Data loc -> let ro,init,cs,st = emit_sta_idx st p init loc r2 e.v in ro,init,Instruction c::cs,st | _,Some (Mixed _),Data _ -> assert false | Code.J,_,Data _ -> emit_joker st init | _,_,Code _ -> Warn.fatal "No code location for arch ARM" let emit_exch_dep_addr st p init er ew rd = let rA,init,st = U.next_init st p init (as_data er.loc) in let c = [Instruction (calc0 tempo1 rd); Instruction (I_ADD3 (DontSetFlags,tempo1,rA,tempo1));] in let r,init,csr,st = emit_ldrex_reg st p init tempo1 in let init,csw,st = emit_one_strex_reg st p init tempo1 ew.v in r,init,c@csr@csw,st let emit_access_dep_data st p init e r1 = match e.dir with | None -> Warn.fatal "TODO" | Some R -> Warn.fatal "data dependency to load" | Some W -> let r2,st = next_reg st in let cs2 = [Instruction (calc0 r2 r1) ; Instruction (I_ADD (DontSetFlags,r2,r2,e.v)) ; ] in begin match e.atom,e.loc with | None,Data loc -> let init,cs,st = emit_store_reg st p init loc r2 in None,init,cs2@cs,st | Some Atomic,Data loc -> let ro,init,cs,st = emit_sta_reg st p init loc r2 in ro,init,cs2@cs,st | Some Reserve,Data _ -> Warn.fatal "No store with reservation" | Some (Mixed _),Data _ -> assert false | _,Code _ -> Warn.fatal "No code location for arch ARM" end | Some Code.J -> assert false let insert_isb isb cs1 cs2 = if isb then cs1@[Instruction I_ISB]@cs2 else cs1@cs2 let emit_access_ctrl isb st p init e r1 = let lab = Label.next_label "LC" in let c = [Instruction (I_CMP (r1,r1)); Instruction (I_BNE lab); Label (lab,Nop);] in let ropt,init,cs,st = emit_access st p init e in ropt,init,insert_isb isb c cs,st let emit_exch_ctrl isb st p init er ew r1 = let lab = Label.next_label "LC" in let c = [Instruction (I_CMP (r1,r1)); Instruction (I_BNE lab); Label (lab,Nop);] in let ropt,init,cs,st = emit_exch st p init er ew in Misc.as_some ropt,init,insert_isb isb c cs,st let emit_access_dep st p init e dp r1 _v1 = match dp with | ADDR -> emit_access_dep_addr st p init e r1 | DATA -> emit_access_dep_data st p init e r1 | CTRL -> emit_access_ctrl false st p init e r1 | CTRLISYNC -> emit_access_ctrl true st p init e r1 let emit_exch_dep st p init er ew dp rd = match dp with | ADDR -> emit_exch_dep_addr st p init er ew rd | DATA -> Warn.fatal "not data dependency to RMW" | CTRL -> emit_exch_ctrl false st p init er ew rd | CTRLISYNC -> emit_exch_ctrl true st p init er ew rd let emit_rmw_dep _ st p init er ew dp rd _n = let r,init,cs,st = emit_exch_dep st p init er ew dp rd in Some r,init,cs,st (* Fences *) let emit_fence st _ init _ f = init,[Instruction (match f with | DMB o -> I_DMB o | DSB o -> I_DSB o | ISB -> I_ISB)],st let emit_fence_dp st a init b f _ r _ = let init,cs,st = emit_fence st a init b f in Some r,init,cs,st let stronger_fence = DMB SY let do_check_load p st r e = let ok,st = A.ok_reg st in (fun k -> Instruction (I_CMPI (r,e.v)):: Instruction (I_BNE (Label.last p)):: Instruction (I_ADD (DontSetFlags,ok,ok,1)):: k), A.next_ok st let check_load p r e init st = let cs,st = do_check_load p st r e in init,cs,st (* Postlude *) let postlude = mk_postlude emit_store_reg let get_xstore_results _ = [] include NoInfo end herd-herdtools7-1ca343e/gen/BellArch_gen.ml000066400000000000000000000152501475314470400205550ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Printf open Code module type Config = sig val debug : Debug_gen.t val verbose : int val libdir : string val prog : string val bell : string option val varatom : string list val variant : Variant_gen.t -> bool end module Make(O:Config) = struct include BellBase (* Assume little endian *) let tr_endian = Misc.identity let bi = match O.bell with | Some fname -> let module R = ReadBell.Make (struct let debug_lexer = O.debug.Debug_gen.lexer let debug_model = O.debug.Debug_gen.model let debug_files = false let verbose = O.verbose let libfind = let module ML = MyLib.Make (struct let includes = [] let env = None let libdir = O.libdir let debug = O.debug.Debug_gen.files end) in ML.find let compat = false let prog = O.prog let variant = Misc.delay_parse O.variant Variant_gen.parse end) in Some (R.read fname) | None -> None (* Workaround, as we cannot simply write module ScopeGen = (val scopegen : ScopeGen.S) in OCaml pre-4.02.1 *) module ScopeGen = struct let scopegen = match bi with | None -> let module M = ScopeGen.NoGen in (module M : ScopeGen.S) | Some bi -> let module M = ScopeGen.Make (struct let debug = false let info = bi end) in (module M : ScopeGen.S) let default,gen,all = let module M = (val scopegen : ScopeGen.S) in M.default,M.gen,M.all end (* Should check non-ambiguity *) let pp_annot a = match a with | "atomic" -> "A" | "ordinary" -> "P" | _ -> let len = String.length a in match len with | 0 -> assert false | _ -> let fst = a.[0] in sprintf "%c%s" (Misc.char_uppercase fst) (String.sub a 1 (len-1)) (* No atoms yet *) let bellatom = true module SIMD = NoSIMD type atom = string list let default_atom = [] (* Wrong, extract from bell file? *) let instr_atom = None let tr_dir = function | R -> BellName.r | W -> BellName.w | J -> BellName.j let applies_atom = match bi with | None -> (fun a _d -> match a with [] -> true | _ -> false) | Some bi -> (fun a d -> BellModel.check_event (tr_dir d) a bi) let is_ifetch _ = false let pp_plain = "P" let pp_as_a = None let pp_annots a = match a with | [] -> "" | _ -> String.concat "" (List.map pp_annot a) let pp_atom a = pp_annots a let compare_atom a1 a2 = Misc.list_compare String.compare a1 a2 include MachMixed.No let fold_annots eg f r = List.fold_left (fun r ag -> match ag with | [] -> r | _ -> Misc.fold_cross (List.map StringSet.elements ag) f r) r eg let fold_annots_dir bi d f r = let eg = BellModel.get_events (tr_dir d) bi in fold_annots eg f r let fold_non_mixed = match bi with | None -> fun _f r -> r | Some bi -> fun f r -> fold_annots_dir bi R f (fold_annots_dir bi W f r) let fold_atom = fold_non_mixed let worth_final _ = false (* Atomic variation *) (* No atomic variation *) let no_varatom f r = f None r (* Some atomic variation *) let fold_from_gen all f = List.fold_right (fun al -> Misc.fold_cross (List.map StringSet.elements al) f) all let fold_from all f = fold_from_gen all (fun al -> f (Some al)) let varatom = match O.varatom with | [] -> None | lines -> let module P = Annot.Make (struct let debug = O.debug.Debug_gen.lexer end) in Some begin let x = P.parse lines in if O.debug.Debug_gen.generator then eprintf "Variations:\n%s\n" (BellModel.pp_event_decs x) ; x end let varatom_dir = match varatom with | None -> fun _ -> no_varatom | Some va -> fun d -> try let at = StringMap.find (tr_dir d) va in fold_from at with Not_found -> no_varatom let merge_atoms a1 a2 = if a2 = a1 then Some a1 else None let overlap_atoms _ _ = true let atom_to_bank _ = Code.Ord let varatom_rmw = match varatom with | None -> no_varatom | Some _va -> fun _ -> assert false include NoMixed include NoWide (* End of atoms *) module PteVal = PteVal_gen.No(struct type arch_atom = atom end) (**********) (* Fences *) (**********) type fence = barrier let is_isync _ = false let compare_fence = barrier_compare let default = Fence ([],None) let strong = match bi with | None -> Fence ([],None) | Some bi -> try Fence (BellModel.get_default BellName.f bi,None) with Not_found -> Fence ([],None) let pp_fence (Fence (a,_)) = sprintf "Fence%s" (pp_annots a) let fold_fences = match bi with | None -> fun _f k -> k | Some bi -> fun f k -> let eg = BellModel.get_events BellName.f bi in fold_annots eg (fun a k -> f (Fence (a,None)) k) k let fold_cumul_fences _f k = k let fold_all_fences = fold_fences let fold_some_fences f k = f strong k let orders _ _ _ = true let no_varfence f r = f strong r let var_fence f = match varatom with | None -> no_varfence f | Some va -> try let at = StringMap.find BellName.f va in fold_from_gen at (fun al -> f (Fence (al,None))) with Not_found -> no_varfence f (********) (* Deps *) (********) include ClassicDep include NoRmw.Make(struct type arch_atom = atom end) include NoEdge include ArchExtra_gen.Make (struct type arch_reg = reg let is_symbolic _ = false let pp_reg = pp_reg let pp_i _ = assert false let free_registers = allowed_for_symb include NoSpecial end) end herd-herdtools7-1ca343e/gen/BellCompile.ml000066400000000000000000000233321475314470400204370ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Code module type Config = sig include CompileCommon.Config val realdep : bool end module Make(Cfg:Config)(BO:BellArch_gen.Config) : XXXCompile_gen.S = struct (* Common *) module Bell = BellArch_gen.Make(BO) include CompileCommon.Make(Cfg)(Bell) let ppo _f k = k open Bell open C (* Utilities *) let tempo1 = Symbolic_reg "T1" (* May be used for branch cond *) let next_reg x = Bell.alloc_reg x let pseudo = List.map (fun i -> Instruction i) (* Bell instructions *) let symb_of_string x = Abs x (* let movi r i = Pmov (r,IAR_imm i) *) let ld_tagged r x a = Pld (r, Addr_op_atom (symb_of_string x),a) let ld r x = ld_tagged r x [] let ld_idx_tagged r x idx a = Pld (r, Addr_op_add (symb_of_string x,Regi idx),a) let st_tagged x v a = Pst (Addr_op_atom (symb_of_string x),Imm v,a) let st_reg_tagged x r a = Pst (Addr_op_atom (Abs x),Regi r,a) let st_idx_tagged x v idx a = Pst (Addr_op_add (symb_of_string x,Regi idx),Imm v,a) let mov rA op = Pmov (rA,op) let movne rA rB k = mov rA (OP (Neq,IAR_roa (Rega rB),IAR_imm k)) let moveq rA rB k = mov rA (OP (Eq,IAR_roa (Rega rB),IAR_imm k)) let xor r1 r2 r3 = mov r1 (OP (Xor,IAR_roa (Rega r2),IAR_roa (Rega r3))) let addk r1 r2 k = mov r1 (OP (Add,IAR_roa (Rega r2),IAR_imm k)) let andk r1 r2 k = mov r1 (OP (And,IAR_roa (Rega r2),IAR_imm k)) let branchcc reg lab = Pbranch (Some reg,lab,[]) let inc r = Pmov (r,OP (Add,IAR_roa (Rega r),IAR_imm 1)) (**********) (* Export *) (**********) let emit_joker st init = None,init,[],st (* Loads (some specific added) *) let emit_load_tagged st _p init x a = let rA,st = next_reg st in rA,init,pseudo [ld_tagged rA x a],st let emit_load st p init x = emit_load_tagged st p init x [] let emit_obs _ = emit_load let emit_load_idx_tagged st _p init x idx a = let rA,st = next_reg st in rA,init,pseudo [ld_idx_tagged rA x idx a],st let emit_load_idx st p init x idx = emit_load_idx_tagged st p init x idx [] let emit_obs_not_zero st _p init x = let rA,st = next_reg st in let rB,st = next_reg st in let lab = Label.next_label "L" in rA,init, Label (lab,Nop):: pseudo [ld rA x; movne rB rA 0 ; branchcc rB lab;], st let emit_load_one st _p init x = let rA,st = next_reg st in let rB,st = next_reg st in let lab = Label.next_label "L" in rA,init, Label (lab,Nop):: pseudo [ld rA x; movne rB rA 1; branchcc rB lab], st (* let emit_load_not st _p init x bcc = let rA,st = next_reg st in let rC,st = next_reg st in let lab = Label.next_label "L" in let out = Label.next_label "L" in rA,init, Instruction (movi rC 200):: (* 200 X about 5 ins looks for a typical memory delay *) Label (lab,Nop):: pseudo [ ld rA x; bcc rA out; subi rC rC 1 ; bcci Ne rC 0 lab ; ]@ [Label (out,Nop)], st *) (* let emit_load_not_eq st p init x rP = emit_load_not st p init x zz (fun r lab -> bcc Ne r rP lab) let emit_load_not_value st p init x v = emit_load_not st p init x (fun r lab -> bcci Ne r v lab) *) let emit_obs_not_eq _ = assert false let emit_obs_not_value _ = assert false (* Stores *) let emit_store_tagged st _p init x v a = init,[Instruction (st_tagged x v a)],st let emit_store st p init x v = emit_store_tagged st p init x v [] let emit_store_idx_tagged st _p init x v idx a = init,[Instruction (st_idx_tagged x v idx a)],st let emit_store_idx st p init x v idx = emit_store_idx_tagged st p init x v idx [] let emit_store_reg_tagged st _p init x r a = init,[Instruction (st_reg_tagged x r a)],st let emit_store_reg st p init x r = emit_store_reg_tagged st p init x r [] (**********) (* Access *) (**********) let emit_access st p init e = match e.dir with | None -> Warn.fatal "BellCompile.emit_access" | Some d -> match d,e.atom,e.loc with | R,None,Data loc -> let r,init,cs,st = emit_load st p init loc in Some r,init,cs,st | R,Some a,Data loc -> let r,init,cs,st = emit_load_tagged st p init loc a in Some r,init,cs,st | W,None,Data loc -> let init,cs,st = emit_store st p init loc e.v in None,init,cs,st | W,Some a,Data loc -> let init,cs,st = emit_store_tagged st p init loc e.v a in None,init,cs,st | J,_,_ -> emit_joker st init | _,_,Code _ -> Warn.fatal "No code location in Bell" (* Dubious... *) let _tr_a ar aw = match ar,aw with | None,None -> [] | (Some a,None) | (None,Some a) -> a | Some a,Some _ -> a (* let emit_exch st _p init er ew = let rR,st = next_reg st in let arw = tr_a er.C.atom ew.C.atom in rR,init,[Instruction (exch_tagged rR er.loc ew.v arw)],st *) let emit_rmw _ = assert false (**********) (* Fences *) (**********) let emit_fence st _ init _ f = init,[Instruction (Pfence f)],st let emit_fence_dp st a init b f _ r _ = let init,cs,st = emit_fence st a init b f in Some r,init,cs,st let _emit_fence_tagged o a = Instruction (Pfence(Fence(a,o))) let stronger_fence = strong (****************) (* Dependencies *) (****************) (*jade: l'idee c'est de tout faire par les labelled fences en LISA*) let calc_zero = if Cfg.realdep then fun dst src -> Instruction (andk dst src kbig) else fun dst src -> Instruction (xor dst src src) let emit_access_dep_addr st p init e r1 = let idx,st = next_reg st in let cA = calc_zero idx r1 in begin match Misc.as_some e.dir,e.atom,e.loc with | R,None,Data loc -> let rC,init,cs,st = emit_load_idx st p init loc idx in Some rC,init,cA::cs,st | R,Some a,Data loc -> let rC,init,cs,st = emit_load_idx_tagged st p init loc idx a in Some rC,init,cA::cs,st | W,None,Data loc -> let init,cs,st = emit_store_idx st p init loc e.v idx in None,init,cA::cs,st | W,Some a,Data loc -> let init,cs,st = emit_store_idx_tagged st p init loc e.v idx a in None,init,cA::cs,st | J,_,Data _ -> emit_joker st init | _,_,Code _ -> Warn.fatal "No code location for Bell" end let emit_access_dep_data st p init e r1 = match e.dir,e.loc with | None,_ -> Warn.fatal "BellCompile.emit_access_dep_data" | Some R,_ -> Warn.fatal "data dependency to load" | Some W,Data loc -> let r2,st = next_reg st in let cs2 = [calc_zero r2 r1;Instruction (addk r2 r2 e.v);] in begin match e.atom with | None -> let init,cs,st = emit_store_reg st p init loc r2 in None,init,cs2@cs,st | Some a -> let init,cs,st = emit_store_reg_tagged st p init loc r2 a in None,init,cs2@cs,st end | Some J,Data _ -> emit_joker st init | _,Code _ -> Warn.fatal "No code location for Bell" let emit_access_ctrl st p init e r1 v1 = if Cfg.realdep then let lab = Label.last p in let ok,st = A.ok_reg st in let st = A.next_ok st in let rd,st = next_reg st in let c = [Instruction (movne rd r1 v1) ; Instruction (branchcc rd lab) ; Instruction (inc ok);] in let ropt,init,cs,st = emit_access st p init e in ropt,init,c@cs,st else let lab = Label.next_label "LC" in let rd,st = next_reg st in let c = [Instruction (moveq rd r1 0) ; Instruction (branchcc rd lab) ; Label (lab,Nop);] in let ropt,init,cs,st = emit_access st p init e in ropt,init,c@cs,st let emit_access_dep st p init e dp r1 n1 = let v1 = n1.C.evt.C.v in match dp with | ADDR -> emit_access_dep_addr st p init e r1 | DATA -> emit_access_dep_data st p init e r1 | CTRL -> emit_access_ctrl st p init e r1 v1 let emit_rmw_dep _ = assert false (* Check load *) let do_check_load p st r e = let ok,st = A.ok_reg st in (fun k -> Instruction (movne tempo1 r e.v):: Instruction (branchcc tempo1 (Label.last p)):: Instruction (inc ok)::k), A.next_ok st let check_load p r e init st = let cs,st = do_check_load p st r e in init,cs,st (* Postlude for adding exit label *) let postlude = mk_postlude emit_store_reg let get_xstore_results _ = [] include NoInfo end herd-herdtools7-1ca343e/gen/CArch_gen.ml000066400000000000000000000151451475314470400200640ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2014-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Printf (* Memory order *) module ScopeGen = ScopeGen.NoGen (* Atoms *) open Code open MemOrder let bellatom = false module SIMD = NoSIMD type atom = MemOrder.t let default_atom = SC let instr_atom = None let applies_atom a d = match a,d with | (Acq|Acq_Rel|Con),W -> false | (Rel|Acq_Rel),R -> false | _,_ -> true let is_ifetch _ = false let compare_atom = Misc.polymorphic_compare include MachMixed.No let pp_plain = Code.plain let pp_as_a = Some SC let pp_atom = pp_mem_order_short let fold_non_mixed f k = let k = f Acq k in let k = f Rel k in let k = f Acq_Rel k in let k = f SC k in let k = f Rlx k in let k = f Con k in k let fold_atom = fold_non_mixed let worth_final _ = false let varatom_dir _d f = f None let merge_atoms a1 a2 = if a1=a2 then Some a1 else None let overlap_atoms _ _ = true let atom_to_bank _ = Code.Ord include NoMixed include NoWide module PteVal = PteVal_gen.No(struct type arch_atom = atom end) (* Fences, to be completed *) type fence = MemOrder.t let is_isync _ = false let compare_fence = MemOrder.compare let default = SC let strong = SC let pp_fence f = sprintf "Fence%s" (pp_mem_order_short f) let do_fold_fence f k = let k = f Acq k in let k = f Rel k in let k = f Acq_Rel k in let k = f SC k in let k = f Rlx k in let k = f Con k in k let fold_cumul_fences = do_fold_fence let fold_all_fences = do_fold_fence let fold_some_fences = do_fold_fence let orders _f _d1 _d2 = true let var_fence f r = f default r (* Basic C arch *) type arch_reg = { id:int } let reg_compare {id=id1} {id=id2} = Misc.int_compare id1 id2 let dump_reg r = sprintf "r%i" r.id type location = | Loc of string | Reg of Code.proc * arch_reg let dump_loc = function | Loc loc -> loc | Reg (p,r) -> sprintf "%i:%s" p (dump_reg r) let pp_location = dump_loc let pp_location_brk loc = match loc with | Loc loc -> sprintf "[%s]" loc | Reg _ -> dump_loc loc let location_compare loc1 loc2 = match loc1,loc2 with | Loc _,Reg _ -> -1 | Reg _,Loc _ -> 1 | Loc loc1,Loc loc2 -> String.compare loc1 loc2 | Reg (p1,r1),Reg (p2,r2) -> begin match Misc.int_compare p1 p2 with | 0 -> reg_compare r1 r2 | r -> r end let of_reg p r = Reg (p,r) let pp_i _ = assert false let of_loc loc = Loc (as_data loc) type tbase = TypBase.t let dump_tbase t = TypBase.pp t type typ = Plain of tbase | Atomic of tbase let is_default = function | Plain t|Atomic t -> TypBase.is_default t let dump_typ = function | Plain t -> dump_tbase t | Atomic TypBase.Int -> "atomic_int" | Atomic t -> sprintf "_Atomic %s" (dump_tbase t) type exp = | Load of location | AtomicLoad of MemOrder.t * exp | AtomicExch of MemOrder.t * exp * Code.v | AtomicFetchOp of MemOrder.t * exp * Code.v | Deref of exp | Const of Code.v | AssertVal of exp * Code.v | AddZero of exp * location let addrs_of_location = function | Reg _ -> StringSet.empty | Loc loc -> StringSet.singleton loc let rec addrs_of_exp = function | Const _ -> StringSet.empty | Load loc -> addrs_of_location loc | AddZero (loc1,loc2) -> StringSet.union (addrs_of_exp loc1) (addrs_of_location loc2) | Deref e|AssertVal (e,_) | AtomicLoad (_,e)|AtomicExch (_,e,_)|AtomicFetchOp (_,e,_)-> addrs_of_exp e type cond = Eq | Ne type condexp = exp * cond * exp type ins = | Seq of ins * ins | Decl of typ * arch_reg * exp option | Store of exp * exp | SetReg of arch_reg * exp | AtomicStore of MemOrder.t * exp * exp | Fence of fence | Loop of ins | If of condexp * ins * ins option | Break | Decr of arch_reg | Nop let addrs_ofcondexp (e1,_,e2) = StringSet.union (addrs_of_exp e1) (addrs_of_exp e2) let rec addrs_of = function | Break | Fence _ | Decr _ | Nop | Decl (_,_,None) -> StringSet.empty | Seq (i1,i2) -> StringSet.union (addrs_of i1) (addrs_of i2) | Decl (_,_,Some e) | SetReg (_,e) -> addrs_of_exp e | Store (loc,e)|AtomicStore (_,loc,e) -> StringSet.union (addrs_of_exp loc) (addrs_of_exp e) | Loop i -> addrs_of i | If (ce,itrue,ifalse) -> StringSet.union (addrs_ofcondexp ce) (StringSet.union (addrs_of itrue) (addrs_of_opt ifalse)) and addrs_of_opt = function | None -> StringSet.empty | Some i -> addrs_of i let seq i1 i2 = match i1,i2 with | (Nop,i)|(i,Nop) -> i | _,_ -> Seq (i1,i2) let seqs is = List.fold_right seq is Nop let rec is_nop = function | Nop|Decl (_,_,None) -> true | Seq (i1,i2) -> is_nop i1 && is_nop i2 | _ -> false (* Dependencies, no CTRLISYNC *) include CDep let pp_dp = function | ADDR -> "Addr" | DATA -> "Data" | CTRL -> "Ctrl" (* Read-Modify-Write *) type rmw = | Exch | Add type rmw_atom = atom let pp_rmw compat = function | Exch -> if compat then "Rmw" else "Exch" | Add -> "Fetch.Add" let is_one_instruction _ = true let fold_rmw f r = let r = f Add r in f Exch r let fold_rmw_compat f r = f Exch r let tr_atom_rmw omo_r omo_w = match omo_r,omo_w with | (None,_)|(_, None) -> None | (Some mo_r,Some mo_w) -> try Some (match mo_r,mo_w with | SC,SC -> SC | Rlx,Rlx -> Rlx | Acq,Rel -> Acq_Rel | Acq,Rlx -> Acq | Rlx,Rel -> Rel | _,_ -> raise Exit) with Exit -> None let applies_atom_rmw _ ar aw = match ar,aw with | None,None -> true (* to allow edge lexemes `Rmw` *) | _,_ -> match tr_atom_rmw ar aw with | Some _ -> true | None -> false let show_rmw_reg _ = true let compute_rmw rmw old co = match rmw with | Exch -> co | Add -> old+co include NoEdge herd-herdtools7-1ca343e/gen/CCompile_gen.ml000066400000000000000000001127641475314470400206040ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2014-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* 'C' compiler *) (* Compared with hardware archs, XXXCompile and top are merged... *) open Printf open Code module type Config = sig include Top_gen.Config val same_loc : bool val verbose : int val allow_back : bool val show : ShowGen.t option val typ : TypBase.t val cpp : bool val docheck : bool end module Make(O:Config) : Builder.S = struct let () = if O.optcond then Warn.warn_always "optimised conditions are not supported by C arch" module O = struct include O let optcond = false end module A = struct include CArch_gen let deftype = O.typ end module E = Edge.Make (struct let variant = O.variant let naturalsize = TypBase.get_size O.typ end) (A) let () = match O.show with | Some s -> begin E.show s ; exit 0 end | None -> () module R = Relax.Make(A)(E) module ConfWithSize = struct include O let naturalsize = TypBase.get_size O.typ end module C = Cycle.Make(ConfWithSize)(E) module AR = struct module A = A module E = E module R = R module C = C end module U = TopUtils.Make(O)(AR) module F = Final.Make(O)(AR) (******************************************) (* Compile cycle, ie generate test proper *) (******************************************) (* Typing *) let type_event env e = let loc = as_data e.C.loc in let ty = match e.C.atom with | Some _ -> A.Atomic A.deftype | None -> A.Plain A.deftype in try let ty0 = StringMap.find loc env in if ty0 <> ty then Warn.fatal "Type mismatch on location %s" loc ; env with | Not_found -> StringMap.add loc ty env let type_cycle n = let rec do_rec env m = let env = type_event env m.C.evt in if m.C.next == n then env else do_rec env m.C.next in do_rec StringMap.empty n (* Basics *) let i0 = 128 let st0 = 0,i0 (* With the alloc_loop_idx trick, straight and loop coherence observers feature the same observed registers *) let reset_alloc,alloc_reg,alloc_loop_idx = if O.cpp then let c = ref 0 in let alloc _p (st,i) = let c0 = !c in incr c ; { A.id = c0; },(st+1,i) in (fun () -> c := 0),alloc,alloc else (fun () -> ()), (fun _p (st,i) -> { A.id=st;},(st+1,i)), (fun _p (st,i) -> { A.id=i;},(st,i+1)) type prev_load = | No (* Non-existent or irrelevant *) | Yes of A.dp * A.location let mk_eloc pdp loc = match pdp with | Yes (A.ADDR,pr) -> A.AddZero (A.Load loc,pr) | _ -> A.Load loc let compile_store pdp e = let loc = A.Loc (as_data e.C.loc) in let eloc = mk_eloc pdp loc in let v = e.C.v in let ev = match pdp with | Yes (A.DATA,pr) -> A.AddZero (A.Const v,pr) | _ -> A.Const v in match e.C.atom with | None -> A.Store (eloc,ev) | Some a -> if A.applies_atom a Code.W then A.AtomicStore(a,eloc,ev) else Warn.fatal "wrong memory order for store" let load_checked_not = None let load_from pdp mo loc = let eloc = mk_eloc pdp loc in match mo with | None -> if O.cpp then eloc else A.Deref (eloc) | Some mo -> if A.applies_atom mo Code.R then A.AtomicLoad (mo,eloc) else Warn.fatal "wrong memory order for load" let exch_from rmw omo omo_w loc v = match omo,omo_w with | (None,_)|(_, None) -> Warn.fatal "Non atomic RMW" | Some _,Some _ -> match A.tr_atom_rmw omo omo_w with | Some mo -> begin match rmw.E.edge with | E.Rmw A.Exch -> A.AtomicExch (mo,A.Load loc,v) | E.Rmw A.Add -> A.AtomicFetchOp (mo,A.Load loc,v) | _ -> assert false end | None -> Warn.fatal "wrong memory order for atomic exchange" let compile_load st p mo loc = let r,st = alloc_reg p st in let i = A.Decl (A.Plain A.deftype,r,Some (load_from No mo loc)) in r,i,st let compile_exch rmw st p mo mo_w loc v = let r,st = alloc_reg p st in let i = A.Decl (A.Plain A.deftype,r,Some (exch_from rmw mo mo_w loc v)) in r,i,st let assertval pdp mo loc v = if O.cpp then A.AssertVal(load_from pdp mo loc,v) else load_from pdp mo loc let assert_exch rmw v1 mo mo_w loc v2 = if O.cpp then A.AssertVal(exch_from rmw mo mo_w loc v2 ,v1) else exch_from rmw mo mo_w loc v2 let compile_load_assertvalue pdp v st p mo loc = let r,st = alloc_reg p st in let i = A.Decl (A.Plain A.deftype,r, Some (assertval pdp mo loc v)) in r,i,st let compile_exch_assertvalue rmw v1 st p mo mo_w loc v2 = let r,st = alloc_reg p st in let i = A.Decl (A.Plain A.deftype,r, Some (assert_exch rmw v1 mo mo_w loc v2)) in r,i,st let do_breakcond cond p r v = A.If ((v,cond,A.Load (A.Reg (p,r))),A.Break,None) let breakcond cond p r v = do_breakcond cond p r (A.Const v) let compile_load_not_zero st p mo x = let r,st = alloc_reg p st in let decls = A.Decl (A.Plain A.deftype,r,None) and body = A.Seq (A.SetReg (r,load_from No mo x),breakcond A.Ne p r 0) in r,A.Seq (decls,A.Loop body),st let compile_load_one st p mo x = let r,st = alloc_reg p st in let decls = A.Decl (A.Plain A.deftype,r,None) and body = A.Seq (A.SetReg (r,load_from No mo x), breakcond A.Eq p r 1) in r,A.Seq (decls,A.Loop body),st let do_compile_load_not st p mo x e = let r,st = alloc_reg p st in let idx,st = alloc_loop_idx p st in let decls = A.Seq (A.Decl (A.Plain TypBase.Int,idx,Some (A.Const 200)), A.Decl (A.Plain A.deftype,r,None)) and body = A.seqs [A.SetReg (r,load_from No mo x) ; do_breakcond A.Ne p r e ; A.Decr idx ; breakcond A.Eq p idx 0;] in r,A.Seq (decls,A.Loop body),st let compile_load_not_value st p mo x v = do_compile_load_not st p mo x (A.Const v) let compile_load_not_eq st p mo x r = do_compile_load_not st p mo x (A.Load (A.Reg (p,r))) let po_of_node p ro n = match ro with | None -> No | Some r -> begin match n.C.edge.E.edge with | E.Dp (A.ADDR|A.DATA as dp,_,_) -> Yes (dp,A.Reg (p,r)) | _ -> No end let compile_access pdp st p n = let e = n.C.evt in if e.C.rmw then match e.C.dir,e.C.loc with | Some R,Data loc -> let v = n.C.next.C.evt.C.v in let loc = A.Loc loc in let mo = e.C.atom in let mo_w = n.C.next.C.evt.C.atom in let r,i,st = compile_exch_assertvalue n.C.edge e.C.v st p mo mo_w loc v in Some r,i,st | (Some W|None),_ -> None,A.Nop,st | (Some J,_)|(_,Code _) -> assert false else match e.C.dir,e.C.loc with | Some R,Data loc -> let loc = A.Loc loc in let mo = e.C.atom in let r,i,st = (if U.do_poll n then compile_load_one else compile_load_assertvalue pdp e.C.v) st p mo loc in Some r,i,st | Some W,Data _ -> let i = compile_store pdp e in None,i,st | (None,Data _) -> None,A.Nop,st | (Some J,_)|(_,Code _) -> assert false (* Lift definitions *) module RegSet = MySet.Make (struct type t = A.arch_reg let compare = compare end) let insert_now d i = List.fold_right (fun (t,r) k -> A.seqs [A.Decl (t,r,Some (A.Const (-1)));k]) d i let rec lift_rec top xs i = let open A in match i with | Decl (t,r,None) -> if not top && RegSet.mem r xs then [t,r],Nop else [],i | Decl (t,r,Some e) -> if not top && RegSet.mem r xs then [t,r],SetReg (r,e) else [],i | Seq (i1,i2) -> let d1,i1 = lift_rec top xs i1 and d2,i2 = lift_rec top xs i2 in d1@d2,seqs [i1;i2] | Loop i -> let d,i = lift_rec false xs i in if top then [],insert_now d (Loop i) else d,Loop i | If (ce,itrue,ifalse) -> let dtrue,itrue = lift_rec false xs itrue and dfalse,ifalse = match ifalse with | None -> [],None | Some ifalse -> let dfalse,ifalse = lift_rec false xs ifalse in dfalse,Some ifalse in let d = dtrue@dfalse in if top then [],insert_now d (If (ce,itrue,ifalse)) else d,If (ce,itrue,ifalse) | Store _|AtomicStore _|SetReg _ | Fence _|Break|Decr _|Nop -> [],i let lift_top xs i = let d,i = lift_rec true xs i in match d with | [] -> i | _ -> assert false let lift_defs xs i = if O.cpp then i else let regs = List.fold_right (fun loc k -> match loc with | A.Loc _ -> k | A.Reg (_,r) -> r::k) xs [] in let xs = RegSet.of_list regs in lift_top xs i (*************) (* Observers *) (*************) let add_fence fenced ins = match fenced,ins with | (false,_)|(_,A.Nop) -> ins | _ -> A.Seq (A.Fence A.strong,ins) let rec straight_observer_std fenced st p mo x = function | [] -> A.Nop,[] | v::vs -> let r,c,st = compile_load_assertvalue No (IntSet.choose v) st p mo x in let cs,fs = straight_observer_std fenced st p mo x vs in A.seq c (add_fence fenced cs),F.add_final_v p r v fs let rec straight_observer_check fenced st p mo x = function | [] -> assert false (* A.Nop,[] *) | [_] as vs -> straight_observer_std fenced st p mo x vs | v::vs -> let v0 = IntSet.choose v in if O.cpp then let ce = A.Const v0,A.Eq,assertval No mo x v0 in let cs,fs = straight_observer_check fenced st p mo x vs in A.If (ce,add_fence fenced cs,load_checked_not),fs else let r,i,st = compile_load st p mo x in let ce = A.Const v0,A.Eq,A.Load (A.Reg (p,r)) in let cs,fs = straight_observer_check fenced st p mo x vs in A.Seq (i,A.If (ce,add_fence fenced cs,load_checked_not)), F.add_final_v p r v fs let straight_observer_check_lift fenced st p mo x i = let i,f = straight_observer_check fenced st p mo x i in let xs = List.map fst f in lift_defs xs i,f let straight_observer = (if O.docheck then straight_observer_check_lift else straight_observer_std) false let fenced_observer = (if O.docheck then straight_observer_check_lift else straight_observer_std) true let loop_observer st p mo x = function | []|[_] -> A.Nop,[] | v::vs -> let r,c,st = compile_load_not_zero st p mo x in let rec do_loop st prev_r = function | [] -> assert false | [v] -> let r,c,_st = compile_load_not_eq st p mo x prev_r in c,F.add_final_v p r v [] | v::vs -> let r,c,st = compile_load_not_eq st p mo x prev_r in let cs,fs = do_loop st r vs in A.seq c cs,F.add_final_v p r v fs in let cs,fs = do_loop st r vs in A.seq c cs,F.add_final_v p r v fs let rec split_last = function | [] -> assert false | [v] -> [],v | v::vs -> let vs,w = split_last vs in v::vs,w let rec do_opt_coherence k obs = function | [] -> [k] | (v,vobs)::co -> let i = IntSet.inter obs vobs in if IntSet.is_empty i then begin k:: do_opt_coherence (IntSet.singleton v) vobs co end else do_opt_coherence (IntSet.add v k) vobs co let opt_coherence = function | [] -> assert false | (v,obs)::co -> do_opt_coherence (IntSet.singleton v) obs co let min_set = IntSet.min_elt let max_set = IntSet.max_elt let min_max xs = let ps = List.map (fun x -> min_set x, max_set x) xs in match ps with | []|[_] -> [] | (_,x)::rem -> let rec remove_last = function | [] -> assert false | [x,_] -> [x] | (x,y)::rem -> if x=y then x::remove_last rem else x::y::remove_last rem in List.map IntSet.singleton (x::remove_last rem) exception NoObserver let build_observer st p mo x vs = let vs,f = if O.optcoherence && O.obs_type <> Config.Loop then let vs = opt_coherence vs in if O.verbose > 1 then begin eprintf "OPT:" ; List.iter (fun vs -> eprintf " {%s}" (IntSet.pp_str "," (sprintf "%i") vs)) vs ; eprintf "\n%!" end ; match vs with | []|[_] -> raise NoObserver | _ -> if List.for_all (fun x -> match IntSet.as_singleton x with | Some _ -> true | None -> false) vs then let ws,w = split_last vs in (match ws with [_] -> [] | _ -> ws),[A.Loc x, w] else min_max vs,[] else let vs = List.map (fun (v,_obs) -> IntSet.singleton v) vs in vs,[] in let cs,fs = let open Config in let x = A.Loc x in match O.obs_type with | Straight -> straight_observer st p mo x vs | Config.Fenced -> fenced_observer st p mo x vs | Loop -> loop_observer st p mo x vs in cs,F.add_int_sets fs f let rec build_observers p mo x arg = let open Config in match arg,O.do_observers with | [],_ -> [],[] | []::vss,_ | [_]::vss,(Avoid|Accept) -> build_observers p mo x vss | vs::vss,_ -> try let c,f = build_observer st0 p mo x vs in let is_nop = A.is_nop c in begin match is_nop,O.do_observers with | false,Avoid -> Warn.fatal "Observer" | _,_ -> () end ; if is_nop then let cs,fs = build_observers p mo x vss in cs,f@fs else let cs,fs = build_observers (p+1) mo x vss in c::cs,f@fs with NoObserver -> build_observers p mo x vss let cons_one x i fs = F.cons_int (A.Loc x) i fs let rec check_rec env p = let add_look_loc loc v k = if O.optcond then k else cons_one loc v k in let open Config in function | [] -> [],[] | (x,vs)::xvs -> let mo = try match StringMap.find x env with | A.Plain _ -> None | A.Atomic _ -> Some MemOrder.Rlx with | Not_found -> assert false in let c,f = match O.cond with | Observe -> let vs = List.flatten vs in begin match vs with | [] -> [],[] | _::_ -> let v,_ = Misc.last vs in [],cons_one x v [] end | Unicond -> assert false | Cycle -> begin match vs with | []|[[_]] -> [],[] | [[_;(v,_)]] -> begin match O.do_observers with | Local -> [],add_look_loc x v [] | Avoid|Accept|Three|Four|Infinity -> [],cons_one x v [] | Enforce -> let c,f = build_observers p mo x vs in c,add_look_loc x v f end | _ -> let vs_flat = List.flatten vs in let v = let v,_ = Misc.last vs_flat in v in begin match O.do_observers with | Local -> [],add_look_loc x v [] | Three -> begin match vs_flat with | _x1::_x2::_x3::_x4::_ -> Warn.fatal "More than three writes" | _ -> [],cons_one x v [] end | Four -> begin match vs_flat with | _x1::_x2::_x3::_x4::_x5::__ -> Warn.fatal "More than four writes" | _ -> [],cons_one x v [] end | Infinity -> [],cons_one x v [] | _ -> let c,f = build_observers p mo x vs in c,add_look_loc x v f end end in let cs,fs = check_rec env (p+List.length c) xvs in c@cs,f@fs let check_writes env p cos = let cos = List.map (fun (loc,vss) -> let vss = List.map (List.map (fun (v,obs) -> if Array.length v > 1 then Warn.fatal "No wide access in C" ; v.(0),obs)) vss in loc,vss) cos in check_rec env p cos (* Local check of coherence *) let do_add_load st p f mo x v = let r,c,st = compile_load_assertvalue No v st p mo x in c,F.add_final_v p r (IntSet.singleton v) f,st let do_add_loop st p f mo x v w = let r,c,st = compile_load_not_value st p mo x v in c,F.add_final_v p r (IntSet.singleton w) f,st let add_fence n is = match n.C.edge.E.edge with | E.Fenced (fe,_,_,_) -> A.Seq (A.Fence fe,is) | _ -> is let do_observe_local st p (m,f) mo x pv v = let mo = match mo with | Some _ -> Some MemOrder.Rlx | None -> None in let open Config in match O.obs_type with | Straight -> let c,f,st = do_add_load st p f mo x v in c,(m,f),st | Config.Fenced -> let c,f,st = do_add_load st p f mo x v in A.Seq (A.Fence A.strong,c),(m,f),st | Loop -> let c,f,st = do_add_loop st p f mo x pv v in c,(m,f),st let observe_local st p f n = let open Config in match O.do_observers with | Local when U.check_here n -> let e = n.C.evt in do_observe_local st p f e.C.atom (A.Loc (as_data e.C.loc)) e.C.v n.C.next.C.evt.C.v | _ -> A.Nop,f,st let observe_local_check st _p f n = let open Config in match O.do_observers with | Local when U.check_here n -> Warn.fatal "Local observers not complete in mode -check true" | _ -> (fun is -> is),f,st let rec compile_proc_std pdp loc_writes st p ns = match ns with | [] -> let f = C.EventMap.empty,[] in A.Nop,f,st | n::ns -> begin match n.C.edge.E.edge with | E.Dp (A.CTRL,_,_) -> let o,i,st = compile_access pdp st p n in let just_read = Misc.as_some o and expected_v = n.C.evt.C.v in let is,fs,st = compile_proc_std No loc_writes st p ns in let obs,fs,st = observe_local st p fs n in let open A in Seq (i, If ((Load (of_reg p just_read),Eq,Const expected_v), A.seqs [obs;is], None)), F.add_final (fun _ -> []) p o n fs, st | _ -> let o,i,st = compile_access pdp st p n in let is,fs,st = compile_proc_std (po_of_node p o n) loc_writes st p ns in let obs,fs,st = observe_local st p fs n in A.seqs [i;obs;add_fence n is], (if not (U.do_poll n) then F.add_final (fun _ -> []) p o n fs else fs), st end let rec do_compile_proc_check loc_writes st p ns = match ns with | [] -> assert false (* A.Nop,(C.EventMap.empty,[]),st *) | [_] -> compile_proc_std No loc_writes st p ns | n::ns -> let e = n.C.evt in let o,fi,st = if e.C.rmw then match e.C.dir,e.C.loc with | Some R,Data x -> let vw = n.C.next.C.evt.C.v and mo = e.C.atom and mo_w = n.C.next.C.evt.C.atom and loc = A.Loc x and v = e.C.v in if O.cpp then let ce = A.Const v,A.Eq,assert_exch n.C.edge vw mo mo_w loc v in None, (fun ins -> A.If (ce,add_fence n ins,load_checked_not)), st else let r,i,st = compile_exch n.C.edge st p mo mo_w loc vw in let ce = A.Const v,A.Eq,A.Load (A.Reg (p,r)) in Some r, (fun ins -> A.Seq (i,A.If (ce,add_fence n ins,load_checked_not))), st | (Some W|None),_ -> None,add_fence n,st | (Some J,_)|(_,Code _) -> assert false else begin match e.C.dir,e.C.loc with | None,_ -> Warn.fatal "TODO" | Some R,Data x -> let v = e.C.v and mo = e.C.atom and loc = A.Loc x in if O.cpp then let ce = A.Const v,A.Eq,assertval No mo loc v in None, (fun ins -> A.If (ce,add_fence n ins,load_checked_not)), st else let r,i,st = compile_load st p mo loc in let ce = A.Const v,A.Eq,A.Load (A.Reg (p,r)) in Some r, (fun ins -> A.Seq (i,A.If (ce,add_fence n ins,load_checked_not))), st | Some W,_ -> None, (fun ins -> A.Seq (compile_store No e,add_fence n ins)), st | (Some J,_)|(_,Code _) -> assert false end in let is,fs,st = do_compile_proc_check loc_writes st p ns in let obs,fs,st = observe_local_check st p fs n in fi (obs is), (if true then F.add_final (fun _ -> []) p o n fs else fs), st let compile_proc_check loc_writes st p ns = let i,(_,f as mf),st = do_compile_proc_check loc_writes st p ns in lift_defs (List.map fst f) i,mf,st let add_args env prog = List.map (fun i -> let locs = A.addrs_of i in let args = StringSet.fold (fun x k -> let t = try StringMap.find x env with Not_found -> assert false in (t,x)::k) locs [] in args,i) prog let compile_cycle ok n = reset_alloc () ; let env = type_cycle n in let open Config in let splitted = C.split_procs n in (* Split before, as proc numbers added by side effet.. *) let cos0 = C.coherence n in let cos = U.compute_cos cos0 in if O.verbose > 1 then U.pp_coherence cos0 ; let loc_writes = U.comp_loc_writes n in let rec do_rec p = function | [] -> [],(C.EventMap.empty,[]),[] | n::ns -> let c,(m,f),_st = (if O.docheck then compile_proc_check else compile_proc_std No) loc_writes st0 p n in let cs,(ms,fs),ios = do_rec (p+1) ns in let io = U.io_of_thread n in c::cs,(C.union_map m ms,f@fs),io::ios in let obsc,f = match O.cond with | Unicond -> [],[] | Cycle|Observe -> check_writes env 0 cos in match splitted,O.cond with | [],_ -> Warn.fatal "No proc" (* | [_],Cycle -> Warn.fatal "One proc" *) | _,_ -> let c,(m,f),ios = if let len = List.length splitted in O.nprocs <= 0 || (if O.eprocs then len = O.nprocs else len <= O.nprocs) then let ess = List.map (List.map (fun n -> n.C.edge)) splitted in if ok ess then let cs,(m,fs),ios = do_rec (List.length obsc) splitted in obsc@cs,(m,f@fs),ios else Warn.fatal "Last minute check" else Warn.fatal "Too many procs" in let f = match O.cond with | Unicond -> let evts = List.map (List.map (fun n -> n.C.evt)) splitted in F.run evts m | Cycle -> F.check f | Observe -> F.observe f in (add_args env c,f []), (U.compile_prefetch_ios (List.length obsc) ios, U.compile_coms splitted), env (********) (* Dump *) (********) type args = (A.typ * string) list let dump_args args = let pp = List.map (fun (t,loc) -> match t with | A.Plain _ -> let novolatile = O.variant Variant_gen.NoVolatile in let volatile = if novolatile then "" else "volatile " in sprintf "%s%s* %s" volatile (A.dump_typ t) loc | A.Atomic _ -> sprintf "%s* %s" (A.dump_typ t) loc) args in String.concat "," pp let dump_mem_order = MemOrder.pp_mem_order let dump_loc_exp = function | A.Loc loc -> loc | A.Reg (_,r) -> A.dump_reg r let dump_cond c = match c with A.Ne -> "!=" | A.Eq -> "==" let rec dump_exp e = let open A in match e with | Load loc -> dump_loc_exp loc | AddZero (e,loc) -> sprintf "%s + (%s & 128)" (dump_exp e) (dump_loc_exp loc) | AtomicLoad (mo,loc) -> sprintf "atomic_load_explicit(%s,%s)" (dump_exp loc) (dump_mem_order mo) | AtomicExch (MemOrder.SC,loc,v) -> sprintf "atomic_exchange(%s,%i)" (dump_exp loc) v | AtomicExch (mo,loc,v) -> sprintf "atomic_exchange_explicit(%s,%i,%s)" (dump_exp loc) v (dump_mem_order mo) | AtomicFetchOp (MemOrder.SC,loc,v) -> sprintf "atomic_fetch_add(%s,%i)" (dump_exp loc) v | AtomicFetchOp (mo,loc,v) -> sprintf "atomic_fetch_add_explicit(%s,%i,%s)" (dump_exp loc) v (dump_mem_order mo) | Deref (Load _ as e) -> sprintf "*%s" (dump_exp e) | Deref e -> sprintf "*(%s)" (dump_exp e) | Const v -> sprintf "%i" v | AssertVal (e,_) -> dump_exp e let dump_left_val = function | A.Load loc -> dump_loc_exp loc | e -> sprintf "(%s)" (dump_exp e) let dump_condexp (e1,c,e2) = sprintf "%s %s %s" (dump_exp e1) (dump_cond c) (dump_exp e2) let fx chan indent fmt = output_string chan indent ; kfprintf (fun chan -> output_string chan "\n") chan fmt let indent1 = " " let indent2 = indent1 ^ indent1 let rec dump_ins chan i ins = let open A in match ins with | Seq (i1,i2) -> dump_ins chan i i1 ; dump_ins chan i i2 | Decl (t,r,None) -> fx chan i "%s %s;" (A.dump_typ t) (A.dump_reg r) | Decl (t,r,Some e) -> fx chan i "%s %s = %s;" (A.dump_typ t) (A.dump_reg r) (dump_exp e) | Store (loc,e) -> fx chan i "*%s = %s;" (dump_left_val loc) (dump_exp e) | SetReg (r,e) -> fx chan i "%s = %s;" (A.dump_reg r) (dump_exp e) | AtomicStore (mo,loc,e) -> fx chan i "atomic_store_explicit(%s,%s,%s);" (dump_exp loc) (dump_exp e) (dump_mem_order mo) | Fence mo -> fx chan i "atomic_thread_fence(%s);" (dump_mem_order mo) | Loop body -> fx chan i "for (;;) {" ; dump_ins chan (i ^ indent1) body ; fx chan i "}" | If (ce,itrue,ifalse) -> fx chan i "if (%s) {" (dump_condexp ce) ; dump_ins chan (i ^ indent1) itrue ; begin match ifalse with | None -> () | Some ins -> fx chan i "} else {" ; dump_ins chan (i ^ indent1) ins ; end ; fx chan i "}" | Break -> fx chan i "break;" | A.Decr r -> fx chan i "%s--;" (A.dump_reg r) | Nop -> () let dump_proc_code chan p (a,i) = fprintf chan "%s (%s) {\n" (pp_proc p) (dump_args a) ; dump_ins chan indent1 i ; fprintf chan "}\n" ; () type prog = (args * A.ins) list let dump_init chan prog = let vars = List.fold_left (fun m (args,_) -> List.fold_left (fun m (t,x) -> if CArch_gen.is_default t then m else StringMap.add x t m) m args) StringMap.empty prog in fprintf chan "\n{" ; let env = StringMap.fold (fun x t k -> sprintf "%s %s;" (CArch_gen.dump_typ t) x::k) vars [] in let pp = String.concat " " env in fprintf chan "%s" pp ; fprintf chan "}\n\n" let dump_code chan prog = Misc.iteri (fun p code -> dump_proc_code chan p code ; output_string chan "\n") prog (********) (* Test *) (********) type edge = E.edge type node = C.node let ppo _f k = k type check = edge list list -> bool type test = { name : string ; com : string ; info : Code.info ; edges : edge list ; prog : prog ; final : F.final ; types : A.typ StringMap.t; } let get_nprocs t = List.length t.prog let get_name t = t.name let set_name t n = { t with name=n; } let set_scope _t _sc = Warn.fatal "No scope for C" let add_info t k i = { t with info = (k,i)::t.info; } let extract_edges t = t.edges let dump_c_test_channel chan t = fprintf chan "C %s\n" t.name ; if t.com <> "" then fprintf chan "\"%s\"\n" t.com ; List.iter (fun (k,v) -> fprintf chan "%s=%s\n" k v) t.info ; Hint.dump O.hout t.name t.info ; (* Empty init *) dump_init chan t.prog ; dump_code chan t.prog ; F.dump_final chan t.final ; () (* let dump_c_test ({ name = name; _ } as t) = let fname = name ^ ".litmus" in Misc.output_protect (fun chan -> dump_c_test_channel chan t) fname *) (************************) (* C++ a la cppmem dump *) (************************) let rec dump_exp e = let open A in match e with | Load loc -> dump_loc_exp loc | AddZero _ -> Warn.fatal "AddZero in cpp mode" | AtomicLoad (mo,loc) -> sprintf "%s.load(%s)" (dump_exp loc) (dump_mem_order mo) | AtomicExch (mo,loc,v) -> sprintf "%s.exchange(%i,%s)" (dump_exp loc) v (dump_mem_order mo) | AtomicFetchOp (mo,loc,v) -> sprintf "%s.fetch_add(%i,%s)" (dump_exp loc) v (dump_mem_order mo) | Deref (Load _ as e) -> sprintf "*%s" (dump_exp e) | Deref e -> sprintf "*(%s)" (dump_exp e) | Const v -> sprintf "%i" v | AssertVal (AtomicLoad _|Load _ as e,v) -> sprintf "%s.readsvalue(%i)" (dump_exp e) v | AssertVal _ -> Warn.fatal "Cannot compile to C++ (expr)" let dump_cond_arg e = match e with | A.Const _|A.Load _ -> dump_exp e | _ -> sprintf "(%s)" (dump_exp e) let dump_condexp (e1,c,e2) = sprintf "%s %s %s" (dump_cond_arg e1) (dump_cond c) (dump_cond_arg e2) let rec dump_ins chan i ins = let open A in match ins with | Seq (i1,i2) -> dump_ins chan i i1 ; dump_ins chan i i2 | Decl (_,_,None) -> () | Decl (_t,r,Some e) -> fx chan i "%s = %s;" (A.dump_reg r) (dump_exp e) | Store (loc,e) -> fx chan i "%s = %s;" (dump_exp loc) (dump_exp e) | SetReg (r,e) -> fx chan i "%s = %s;" (A.dump_reg r) (dump_exp e) | AtomicStore (mo,loc,e) -> fx chan i "%s.store(%s,%s);" (dump_exp loc) (dump_exp e) (dump_mem_order mo) | If (ce,itrue,ifalse) -> fx chan i "if (%s) {" (dump_condexp ce) ; dump_ins chan (i ^ indent1) itrue ; begin match ifalse with | None -> () | Some ifalse -> fx chan i "} else {" ; dump_ins chan (i ^ indent1) ifalse ; end ; fx chan i "}" | Fence _ | Loop _ | Break | A.Decr _ -> Warn.fatal "Cannot compile to C++" | Nop -> () let dump_prog chan = let rec do_rec pre = function | (_,i)::rem -> fx chan indent1 "%s {" pre ; dump_ins chan indent2 i ; fx chan indent1 "}" ; do_rec "|||" rem | [] -> fx chan indent1 "%s" "}}}" in do_rec "{{{" let dump_cpp_test_channel chan t = fprintf chan "// CPP %s\n" t.name ; if t.com <> "" then fprintf chan "// \"%s\"\n" t.com ; fprintf chan "int main() {\n" ; StringMap.iter (fun loc t -> fprintf chan " %s %s = 0;\n" (A.dump_typ t) loc) t.types ; dump_prog chan t.prog ; fprintf chan " return 0;\n" ; fprintf chan "}\n" ; () (* let dump_cpp_test ({ name = name; _ } as t) = let fname = name ^ ".c" in Misc.output_protect (fun chan -> dump_cpp_test_channel chan t) fname *) let dump_test_channel = if O.cpp then dump_cpp_test_channel else dump_c_test_channel (* let dump_test = if O.cpp then dump_cpp_test else dump_c_test *) let test_of_cycle name ?com ?(info=[]) ?(check=(fun _ -> true)) ?scope ?(init=[]) es c = ignore (scope) ; assert (init=[]) ; let com = match com with None -> E.pp_edges es | Some com -> com in let (prog,final),(prf,coms),env = compile_cycle check c in let coms = String.concat " " coms in let myinfo = ["Generator",O.generator;"Prefetch",prf ; "Com",coms; "Orig",com; ] in let info = info@myinfo in { name=name ; info=info; com=com ; edges = es ; prog=prog ; final=final ; types=env;} let make_test name ?com ?info ?check ?scope es = ignore (scope) ; try if O.verbose > 1 then eprintf "**Test %s**\n" name ; if O.verbose > 2 then eprintf "**Cycle %s**\n" (E.pp_edges es) ; let es,c,init = C.make es in test_of_cycle name ?com ?info ?check ~init es c with | Misc.Fatal msg -> Warn.fatal "Test %s [%s] failed:\n%s" name (E.pp_edges es) msg end herd-herdtools7-1ca343e/gen/CHANGES.txt000066400000000000000000000035311475314470400175260ustar00rootroot000000000000005.01 Release 5.00 Release * Added classify tool * Uniform naming scheme, clarify usage and document * Refactor diyone second mode, in the same style as diy/diycross * Support for atomic accesses (undocumented) 4.00 Release * ARM support. * Generalize -o option, as for litmus. * option -var for diycross for nice variables., * new tool diycross, similar to diyvar, but let user specify the list of alternatives eg: diycross -name SB PodWR,SyncdWR Fre PodWR,SyncdWR Fre For 3 MP-like tests (MP, MP+sync+po, MP+syncs) diyvar behavior is still here with the pseudo-relaxation all(R|W)(R|W) eg: diycross -name SB allWR Fre allWR Fre * Add a new functionality for diyone: generate tests from a list of cycles given in stdin. * Mode precise edge dependencies, DpdR, DpdW, CltrdR, CtrldW are still recognised by parser and are default values (backward compatibility). However, Dpd* and Ctrld* are not available anymore. * dont: uncompress archive with gunzip (AIX: tar z.. not accepted) * diy: -cumul false also acts on RfStar * dont: Corrected bug in default safe_conform list for PPC. * dont: Use compressed archive 3.00 Release 2.99 Release (beta) * Introduce dont, for automating testing. * Additional mode for diy: critical, for generating critical cycles (no Po/Po consing) * Additional option for diy: -cumul, for avoiding ambiguous tests. 2.00 Release * -mix option (default false, for backward compatibility) * Clarification of observers and documentation [three modes accept/avoid/force, three sorts straight/fenced/loop] Defaults avoid/fenced. * Added PPO pseudo-relaxation, very ad-hoc. * Added RfStar edge (ie Rf to a read by lwarx) * various -fno mode * -sta mode * PPO macro * Arch independant readRelax 1.0 Initial release. herd-herdtools7-1ca343e/gen/MIPSArch_gen.ml000066400000000000000000000055441475314470400204540ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2014-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Config = struct let moreedges = false end module Make(C:sig val moreedges : bool end) = struct include MIPSBase module ScopeGen = ScopeGen.NoGen let tr_endian = Misc.identity include MachAtom.Make (struct let naturalsize=None let endian = endian let fullmixed = C.moreedges end) module PteVal = PteVal_gen.No(struct type arch_atom = atom end) (**********) (* Fences *) (**********) type fence = barrier let is_isync _ = false let compare_fence = barrier_compare let default = Sync let strong = default let pp_fence = pp_barrier let fold_all_fences f r = f Sync r let fold_cumul_fences f r = f Sync r let fold_some_fences f r = f Sync r let orders f d1 d2 = match f,d1,d2 with | Sync,_,_ -> true let var_fence f r = f default r (********) (* Deps *) (********) type dp = ADDR | DATA | CTRL let pp_dp = function | ADDR -> "Addr" | DATA -> "Data" | CTRL -> "Ctrl" let fold_dpr f r = f ADDR (f CTRL r) let fold_dpw f r = f ADDR (f DATA (f CTRL r)) let ddr_default = Some ADDR let ddw_default = Some DATA let ctrlr_default = Some CTRL let ctrlw_default = Some CTRL let is_ctrlr = function | CTRL -> true | _ -> false let is_addr = function | ADDR -> true | _ -> false let fst_dp = function | CTRL -> [CTRL] | ADDR|DATA -> [] let sequence_dp d1 d2 = match d1 with | ADDR -> [d2] | DATA|CTRL -> [] include Exch.LxSx(struct type arch_atom = atom end) include NoEdge include ArchExtra_gen.Make (struct type arch_reg = reg let is_symbolic = function | Symbolic_reg _ -> true | _ -> false let pp_reg = pp_reg let pp_i _ = assert false let free_registers = allowed_for_symb include NoSpecial end) end herd-herdtools7-1ca343e/gen/MIPSCompile_gen.ml000066400000000000000000000315411475314470400211630ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Code module Make(Cfg:CompileCommon.Config) : XXXCompile_gen.S = struct module MIPS = MIPSArch_gen.Make(Cfg) include CompileCommon.Make(Cfg)(MIPS) (******) let ppo _f k = k open MIPS open C (* Utilities *) let li r v = if (v < 0 || v > 0xffff) then Warn.fatal "MIPS generator cannot handle constant %i\n" v ; OPI (OR,r,MIPS.r0,v) let inc r = OPI (ADD,r,r,1) let mv r1 r2 = OP (OR,r1,MIPS.r0,r2) module Extra = struct let use_symbolic = true type reg = MIPS.reg type instruction = MIPS.pseudo let mov r v = Instruction (li r v) let mov_mixed _sz _r _v = assert false let mov_reg r1 r2 = Instruction (mv r1 r2) let mov_reg_mixed _sz _r _v = assert false end module U = GenUtils.Make(Cfg)(MIPS)(Extra) (* RMW utilities *) let atom r1 r2 addr k = LL (r1,0,addr):: move tmp2 r2:: SC (tmp2,0,addr)::k let emit_loop_pair _p st r1 r2 addr = let lab = Label.next_label "Loop" in Label (lab,Nop):: lift_code (atom r1 r2 addr [BC (EQ,tmp2,r0,lab)]), st let emit_unroll_pair u p st r1 r2 addr = if u <= 0 then lift_code (atom r1 r2 addr []),st else let ok,st = A.ok_reg st in if u = 1 then lift_code (atom r1 r2 addr [BC (EQ,tmp2,r0,Label.last p); inc ok;]), A.next_ok st else let out = Label.next_label "Go" in let rec do_rec = function | 1 -> lift_code (atom r1 r2 addr [BC (EQ,tmp2,r0,Label.last p)])@ [Label (out,Nop);Instruction (inc ok)] | u -> lift_code (atom r1 r2 addr [BC (NE,tmp2,r0,out)])@ do_rec (u-1) in do_rec u,A.next_ok st let emit_pair = match Cfg.unrollatomic with | None -> emit_loop_pair | Some u -> emit_unroll_pair u (*********) (* loads *) (*********) let do_branch cond r i lab k = match i with | 0 -> BC (cond,r,MIPS.r0,lab)::k | _ -> li MIPS.tmp3 i:: BC (cond,r,tmp3,lab)::k let branch_neq r i lab k = do_branch MIPS.NE r i lab k let _branch_eq r i lab k = do_branch MIPS.EQ r i lab k let emit_load st p init x = let rA,st = A.alloc_reg st in let rB,init,st = U.next_init st p init x in rA,init,lift_code [LW (rA,0,rB)],st let emit_obs _ = emit_load let emit_obs_not_zero st p init x = let rA,st = A.alloc_reg st in let rB,init,st = U.next_init st p init x in let lab = Label.next_label "L" in rA,init, Label (lab,Nop):: lift_code (LW (rA,0,rB)::branch_neq rA 0 lab []), st let emit_load_one st p init x = let rA,st = A.alloc_reg st in let rB,init,st = U.next_init st p init x in let lab = Label.next_label "L" in rA,init, Label (lab,Nop):: lift_code (LW (rA,0,rB)::branch_neq rA 1 lab []), st let emit_load_not st p init x bne = let rA,st = A.alloc_reg st in let rC,st = A.alloc_reg st in let rB,init,st = U.next_init st p init x in let lab = Label.next_label "L" in let out = Label.next_label "L" in rA,init, Instruction (li rC 200):: (* 200 X about 5 ins looks for a typical memory delay *) Label (lab,Nop):: lift_code (LW (rA,0,rB):: bne rA out (OPI (ADDU,rC,rC,-1)::branch_neq rC 0 lab []))@ [Label (out,Nop)], st let emit_obs_not_eq st p init x rP = emit_load_not st p init x (fun r lab k -> BC (NE,r,rP,lab)::k) let emit_obs_not_value st p init x v = emit_load_not st p init x (fun r lab k -> branch_neq r v lab k) let emit_load_idx st p init x idx = let rA,st = A.alloc_reg st in let rB,init,st = U.next_init st p init x in rA,init,lift_code [OP (ADDU,tmp1,idx,rB);LW (rA,0,tmp1)],st (**********) (* Stores *) (**********) let emit_store_reg st p init x rA = let rB,init,st = U.next_init st p init x in init,[Instruction (SW (rA,0,rB))],st let emit_store_idx_reg st p init x idx rA = let rB,init,st = U.next_init st p init x in let cs = [OP (ADDU,tmp1,idx,rB); SW (rA,0,tmp1);] in init,lift_code cs,st let emit_store st p init x v = let rA,init,csv,st = U.emit_mov st p init v in let init,cs,st = emit_store_reg st p init x rA in init,csv@cs,st let emit_store_idx st p init x idx v = let rA,init,csv,st = U.emit_mov st p init v in let init,cs,st = emit_store_idx_reg st p init x idx rA in init,csv@cs,st (* Load exclusive *) (* FNO *) let emit_ll_reg st _p init rB = let rA,st = A.alloc_reg st in rA,init,lift_code [LL (rA,0,rB)],st let emit_ll st p init x = let rB,init,st = U.next_init st p init x in emit_ll_reg st p init rB let emit_ll_idx st p init x idx = let rA,st = A.alloc_reg st in let rB,init,st = U.next_init st p init x in rA,init, lift_code [OP (ADDU,tmp1,idx,rB); LL (rA,0,tmp1)],st let do_emit_fno st p init rA = let rR,st = A.alloc_reg st in let cs,st = emit_pair p st rR rR rA in rR,init,cs,st let emit_fno st p init x = let rB,init,st = U.next_init st p init x in do_emit_fno st p init rB let emit_fno_idx st p init x idx = let rB,init,st = U.next_init st p init x in let r,init,cs,st = do_emit_fno st p init tmp1 in r,init, Instruction (OP (ADDU,tmp1,idx,rB))::cs, st (* STA *) let do_emit_sta st p init rA rW = let rR,st = A.alloc_reg st in let cs,st = emit_pair p st rR rW rA in Some rR,init,cs,st let emit_sta_reg st p init x rW = let rA,init,st = U.next_init st p init x in do_emit_sta st p init rA rW let emit_sta st p init x v = let rW,init,csv,st = U.emit_mov st p init v in let ro,init,cs,st = emit_sta_reg st p init x rW in ro,init,csv@cs,st let emit_sta_idx st p init x idx v = let rA,init,st = U.next_init st p init x in let rW,init,csv,st = U.emit_mov st p init v in let ro,init,cs,st = do_emit_sta st p init tmp1 rW in ro, init, csv@Instruction (OP (ADDU,tmp1,idx,rA))::cs, st (*************) (* Acccesses *) (*************) let emit_joker st init = None,init,[],st let emit_access st p init e = match e.dir with | None -> Warn.fatal "MIPSCompile.emit_access" | Some d -> match d,e.atom,e.loc with | R,None,Data loc -> let r,init,cs,st = emit_load st p init loc in Some r,init,cs,st | R,Some Reserve,Data loc -> let r,init,cs,st = emit_ll st p init loc in Some r,init,cs,st | R,Some Atomic,Data loc -> let r,init,cs,st = emit_fno st p init loc in Some r,init,cs,st | W,None,Data loc -> let init,cs,st = emit_store st p init loc e.v in None,init,cs,st | W,Some Reserve,Data _ -> Warn.fatal "No store with reservation" | W,Some Atomic,Data loc -> let ro,init,cs,st = emit_sta st p init loc e.v in ro,init,cs,st | _,Some (Mixed _),Data _ -> assert false | J, _,Data _ -> emit_joker st init | _,_,Code _ -> Warn.fatal "No code location for arch MIPS" let emit_exch st p init er ew = let rA,init,st = U.next_init st p init (Code.as_data er.loc) in let rR,st = A.alloc_reg st in let rW,init,csv,st = U.emit_mov st p init ew.v in let cs,st = emit_pair p st rR rW rA in rR,init,csv@cs,st let emit_rmw () st p init er ew = let rR,init,cs,st = emit_exch st p init er ew in Some rR,init,cs,st let emit_access_dep_addr st p init e r1 = let r2,st = A.alloc_reg st in let c = OP (XOR,r2,r1,r1) in match e.dir,e.loc with | None,_ -> Warn.fatal "TODO" | Some d,Data loc -> begin match d,e.atom with | R,None -> let r,init,cs,st = emit_load_idx st p init loc r2 in Some r,init, Instruction c::cs,st | R,Some Reserve -> let r,init,cs,st = emit_ll_idx st p init loc r2 in Some r,init, Instruction c::cs,st | R,Some Atomic -> let r,init,cs,st = emit_fno_idx st p init loc r2 in Some r,init, Instruction c::cs,st | W,None -> let init,cs,st = emit_store_idx st p init loc r2 e.v in None,init,Instruction c::cs,st | W,Some Reserve -> Warn.fatal "No store with reservation" | W,Some Atomic -> let ro,init,cs,st = emit_sta_idx st p init loc r2 e.v in ro,init,Instruction c::cs,st | _,Some (Mixed _) -> assert false | J,_ -> emit_joker st init end | _,Code _ -> Warn.fatal "No code location for MIPS" let emit_exch_dep_addr st p init er ew rd = let rA,init,st = U.next_init st p init (as_data er.loc) in let rR,st = A.alloc_reg st in let rW,init,csv,st = U.emit_mov st p init ew.v in let cs,st = emit_pair p st rR rW tmp1 in rR,init, csv@ Instruction (OP (XOR,tmp1,rd,rd)):: Instruction (OP (ADDU,tmp1,rA,tmp1)):: cs, st let emit_access_dep_data st p init e r1 = match e.dir,e.loc with | None,_ -> Warn.fatal "TODO" | Some R,_ -> Warn.fatal "data dependency to load" | Some W,Data loc -> let r2,st = A.alloc_reg st in let cs2 = [Instruction (OP (XOR,r2,r1,r1)) ; Instruction (OPI (ADDU,r2,r2,e.v)) ; ] in begin match e.atom with | None -> let init,cs,st = emit_store_reg st p init loc r2 in None,init,cs2@cs,st | Some Atomic -> let ro,init,cs,st = emit_sta_reg st p init loc r2 in ro,init,cs2@cs,st | Some Reserve -> Warn.fatal "No store with reservation" | Some (Mixed _) -> assert false end | Some J,_ -> emit_joker st init | _,Code _ -> Warn.fatal "No code location for MIPS" let emit_access_ctrl st p init e r1 = let lab = Label.next_label "LC" in let c = [Instruction (BC (NE,r1,r1,lab)); Label (lab,Nop);] in let ropt,init,cs,st = emit_access st p init e in ropt,init, c@cs,st let emit_exch_ctrl st p init er ew rd = let lab = Label.next_label "LC" in let c = [Instruction (BC (NE,rd,rd,lab)); Label (lab,Nop);] in let ropt,init,cs,st = emit_exch st p init er ew in ropt,init, c@cs,st let emit_access_dep st p init e dp r1 _v1 = match dp with | ADDR -> emit_access_dep_addr st p init e r1 | DATA -> emit_access_dep_data st p init e r1 | CTRL -> emit_access_ctrl st p init e r1 let emit_exch_dep st p init er ew dp r1 = match dp with | ADDR -> emit_exch_dep_addr st p init er ew r1 | DATA -> Warn.fatal "no data depency to RMW" | CTRL -> emit_exch_ctrl st p init er ew r1 let emit_rmw_dep () st p init er ew dp rd _n = let r,init,cs,st = emit_exch_dep st p init er ew dp rd in Some r,init,cs,st (* Fences *) let emit_fence st _ init _ f = init,[Instruction (match f with Sync -> SYNC)],st let emit_fence_dp st a init b f _ r _ = let init,cs,st = emit_fence st a init b f in Some r,init,cs,st let stronger_fence = Sync (* Check load *) let do_check_load p st r e = let ok,st = A.ok_reg st in (fun k -> lift_code (branch_neq r e.v (Label.last p) [inc ok])@k), A.next_ok st let check_load p r e init st = let cs,st = do_check_load p st r e in init,cs,st (* Postlude *) let postlude = mk_postlude emit_store_reg let get_xstore_results _ = [] include NoInfo end herd-herdtools7-1ca343e/gen/PPCArch_gen.ml000066400000000000000000000063771475314470400203330ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module type Config = sig val eieio : bool val naturalsize : MachSize.sz val moreedges : bool end (* Default: know about eieio and word size *) module Config = struct let eieio = true let naturalsize = MachSize.Word let moreedges = false end module Make(C:Config) = struct include PPCBase let tr_endian x = MachSize.tr_endian C.naturalsize x module ScopeGen = ScopeGen.NoGen include MachAtom.Make (struct let naturalsize = Some C.naturalsize let endian = endian let fullmixed = C.moreedges end) module PteVal = PteVal_gen.No(struct type arch_atom = atom end) (**********) (* Fences *) (**********) type fence = Sync | LwSync | ISync | Eieio let is_isync = function | ISync -> true | _ -> false let compare_fence = compare let default = Sync let strong = default let pp_fence = function | Sync -> "Sync" | LwSync -> "LwSync" | ISync -> "ISync" | Eieio -> "Eieio" let fold_cumul_fences = if C.eieio then fun f r -> f Sync (f LwSync (f Eieio r)) else fun f r -> f Sync (f LwSync r) let fold_all_fences f r = f ISync (fold_cumul_fences f r) let fold_some_fences = fold_cumul_fences open Code let orders f d1 d2 = match f,d1,d2 with | Sync,_,_ -> true | LwSync,W,R -> false | LwSync,_,_ -> true | ISync,_,_ -> false | Eieio,W,W -> true | Eieio,_,_ -> false let var_fence f r = f default r (********) (* Deps *) (********) include Dep let pp_dp = function | ADDR -> "Addr" | DATA -> "Data" | CTRL -> "Ctrl" | CTRLISYNC -> "CtrlIsync" (*******) (* RWM *) (*******) include Exch.LxSx(struct type arch_atom = atom end) include NoEdge include ArchExtra_gen.Make (struct type arch_reg = reg let is_symbolic = function | Symbolic_reg _ -> true | _ -> false let pp_reg = pp_reg let pp_i _ = assert false let free_registers = allowed_for_symb include NoSpecial end) end herd-herdtools7-1ca343e/gen/PPCCompile_gen.ml000066400000000000000000000443541475314470400210430ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Printf open Code module type Config = sig include CompileCommon.Config val realdep : bool end module Make(O:Config)(C:sig val eieio : bool end) : XXXCompile_gen.S = struct open MachSize let naturalsize = TypBase.get_size O.typ module PPC = PPCArch_gen.Make (struct include C let naturalsize = naturalsize let moreedges = O.moreedges end) include CompileCommon.Make(O)(PPC) let r0 = PPC.Ireg PPC.GPR0 (* PPO *) open E open R let as_opt = function Some x -> x | None -> assert false let dprd = as_opt PPC.ddr_default let dpwd = as_opt PPC.ddw_default let ctrlrd = as_opt PPC.ctrlr_default let ctrlwd = as_opt PPC.ctrlw_default let dpr f = f (Dp (dprd,Diff,Dir R)) and dpw f = f (Dp (dpwd,Diff,Dir W)) and ctrlw f = f (Dp (ctrlwd,Diff,Dir W)) and ctrlr f = f (Dp (ctrlrd,Diff,Dir R)) and poswr f = f (Po(Same,Dir W,Dir R)) let dp f k = dpr f (dpw f k) and ctrl f k = ctrlr f (ctrlw f k) let cons r rs = r (fun r -> r::rs) let single f r = f (ERS [plain_edge r]) let seq rs f = f (ERS (List.map plain_edge rs)) let do_ppo f k = let k = dp (single f) k in let k = ctrl (single f) k in let k = seq (cons dpr (cons ctrlr [])) f k in let k = seq (cons dpr (cons ctrlw [])) f k in let k = seq (cons dpr (cons dpr [])) f k in let k = seq (cons dpr (cons dpw [])) f k in let k = seq (cons dpw (cons poswr [])) f k in let k = seq (cons dpw (cons poswr (cons dpr []))) f k in let k = seq (cons dpw (cons poswr (cons dpw []))) f k in let k = seq (cons dpw (cons poswr (cons ctrlr []))) f k in let k = seq (cons dpw (cons poswr (cons ctrlw []))) f k in (* let k = seq (cons ctrlw (cons poswr [])) f k in let k = seq (cons ctrlw (cons poswr (cons dpr []))) f k in *) k let ppoext = false let ppo f k = do_ppo f (if ppoext then do_ppo (fun r k -> match r with | ERS rs -> f (ERS (rs@[plain_edge (Rf Ext)])) k | PPO -> assert false) k else k) let () = if O.verbose > 0 then begin eprintf "PPO is:\n" ; ppo (fun r () -> eprintf "%s\n" (R.pp_relax r)) () end (*******) open C let next_reg x = PPC.alloc_reg x let inc r = PPC.Paddi (r,r,1) let emit_loop_pair _p st r1 r2 idx addr = let lab = Label.next_label "Loop" in PPC.Label (lab,PPC.Nop):: PPC.lift_code [PPC.Plwarx (r1,idx,addr); PPC.Pstwcx (r2,idx,addr); PPC.Pbcc (PPC.Ne,lab)], st let emit_unroll_pair u p st r1 r2 idx addr = if u <= 0 then PPC.lift_code [PPC.Plwarx (r1,idx,addr); PPC.Pstwcx (r2,idx,addr)], st else let ok,st = PPC.ok_reg st in if u = 1 then PPC.lift_code [PPC.Plwarx (r1,idx,addr); PPC.Pstwcx (r2,idx,addr); PPC.Pbcc (PPC.Ne,Label.last p); inc ok;], PPC.next_ok st else let out = Label.next_label "Go" in let rec do_rec = function | 1 -> PPC.lift_code [PPC.Plwarx (r1,idx,addr); PPC.Pstwcx (r2,idx,addr); PPC.Pbcc (PPC.Ne,Label.last p);] @[PPC.Label (out,PPC.Nop);PPC.Instruction (inc ok);] | u -> PPC.lift_code [PPC.Plwarx (r1,idx,addr); PPC.Pstwcx (r2,idx,addr); PPC.Pbcc (PPC.Eq,out);]@ do_rec (u-1) in do_rec u,A.next_ok st let emit_pair = match O.unrollatomic with | None -> emit_loop_pair | Some u -> emit_unroll_pair u module Extra = struct let use_symbolic = false type reg = PPC.reg type instruction = PPC.pseudo let mov r v = PPC.Instruction (PPC.Pli (r,v)) let mov_mixed _sz _r _i = assert false let mov_reg r1 r2 = PPC.Instruction (PPC.Pori (r1,r2,0)) let mov_reg_mixed _sz _r1 _r2 = assert false end module U = GenUtils.Make(O)(PPC)(Extra) (* STA *) let emit_sta_idx_reg st p init x idx rW = let rA,init,st = U.next_init st p init x in let rR,st = next_reg st in let cs,st = emit_pair p st rR rW idx rA in rR,init,cs,st let emit_sta_idx st p init x idx v = let rW,init,csi,st = U.emit_mov st p init v in let r,init,cs,st = emit_sta_idx_reg st p init x idx rW in r,init,csi@cs,st let emit_sta_reg st p init x rW = emit_sta_idx_reg st p init x r0 rW let emit_sta st p init x v = let rA,init,csi,st = U.emit_mov st p init v in let r,init,cs,st = emit_sta_reg st p init x rA in r,init,csi@cs,st (* STORE *) let emit_store_reg_mixed sz o st p init x rA = let rB,init,st = U.next_init st p init x in init,[PPC.Instruction (PPC.Pstore (sz,rA,o,rB))],st let emit_store_reg st p init x rA = emit_store_reg_mixed naturalsize 0 st p init x rA let emit_store_idx_reg_mixed sz st p init x idx rA = let rB,init,st = U.next_init st p init x in init,[PPC.Instruction (PPC.Pstorex (sz,rA,idx,rB))],st let emit_store_idx_reg st p init x idx rA = emit_store_idx_reg_mixed naturalsize st p init x idx rA let emit_store_mixed sz o st p init x v = let rA,init,csi,st = U.emit_mov st p init v in let init,cs,st = emit_store_reg_mixed sz o st p init x rA in init,csi@cs,st let emit_store st p init x v = emit_store_mixed naturalsize 0 st p init x v let emit_store_idx st p init x idx v = let rA,init,csi,st = U.emit_mov st p init v in let init,cs,st = emit_store_idx_reg st p init x idx rA in init,csi@cs,st (* LDA *) let emit_lda_idx st p init x idx = let rA,init,st = U.next_init st p init x in let rR,st = next_reg st in let cs,st = emit_pair p st rR rR idx rA in rR,init,cs,st let emit_lda st p init x = emit_lda_idx st p init x r0 (* Load *) let emit_load_mixed sz o st p init x = let rA,st = next_reg st in let rB,init,st = U.next_init st p init x in rA,init,PPC.lift_code [PPC.Pload (sz,rA,o,rB)],st let emit_load st p init x = emit_load_mixed naturalsize 0 st p init x let emit_obs _ = emit_load_mixed naturalsize 0 let emit_obs_not_zero st p init x = let rA,st = next_reg st in let rB,init,st = U.next_init st p init x in let lab = Label.next_label "L" in rA,init, PPC.Label (lab,PPC.Nop):: PPC.lift_code [PPC.Pload (naturalsize,rA,0,rB) ; PPC.Pcmpwi (0,rA,0) ; PPC.Pbcc (PPC.Eq,lab)], st let emit_load_one st p init x = let rA,st = next_reg st in let rB,init,st = U.next_init st p init x in let lab = Label.next_label "L" in rA,init, PPC.Label (lab,PPC.Nop):: PPC.lift_code [PPC.Pload (Word,rA,0,rB) ; PPC.Pcmpwi (0,rA,1) ; PPC.Pbcc (PPC.Ne,lab)], st let emit_obs_not st p init x cmp = let rA,st = next_reg st in let rC,st = A.alloc_loop_idx "I" st in let rB,init,st = U.next_init st p init x in let lab = Label.next_label "L" in let out = Label.next_label "L" in rA,init, PPC.Instruction (PPC.Pli (rC,200)):: (* 200 X about 5 ins looks for a typical memory delay *) PPC.Label (lab,PPC.Nop):: PPC.lift_code [ PPC.Pload (naturalsize,rA,0,rB) ; cmp rA ; PPC.Pbcc (PPC.Ne,out) ; PPC.Paddi (rC,rC,-1) ; PPC.Pcmpwi (0,rC,0) ; PPC.Pbcc (PPC.Ne,lab) ; ]@ [PPC.Label (out,PPC.Nop)], st let emit_obs_not_eq st p init x rP = emit_obs_not st p init x (fun r -> PPC.Pcmpw (0,r,rP)) let emit_obs_not_value st p init x v = emit_obs_not st p init x (fun r -> PPC.Pcmpwi (0,r,v)) let emit_load_idx st p init x idx = let rA,st = next_reg st in let rB,init,st = U.next_init st p init x in rA,init,PPC.lift_code [PPC.Ploadx (naturalsize,rA,idx,rB)],st let emit_lwarx_idx st p init x idx = let rA,st = next_reg st in let rB,init,st = U.next_init st p init x in rA,init,PPC.lift_code [PPC.Plwarx (rA,idx,rB)],st let emit_lwarx st p init x = emit_lwarx_idx st p init x PPC.r0 let emit_one_stwcx_idx st p init x idx v = let ok,st = PPC.ok_reg st in let rA,init,csi,st = U.emit_mov st p init v in let rB,init,st = U.next_init st p init x in init, csi@PPC.lift_code [PPC.Pstwcx (rA,idx,rB); PPC.Pbcc (PPC.Ne,Label.last p); inc ok;], PPC.next_ok st let emit_one_stwcx st p init x v = emit_one_stwcx_idx st p init x PPC.r0 v let emit_joker st init = None,init,[],st let emit_access st p init e = match e.dir with | None -> Warn.fatal "TODO" | Some d -> begin match e.loc with | Code _ -> Warn.fatal "No code location for PPC" | Data loc -> begin match d,e.atom with | R,None -> let emit = if e.rmw then emit_lwarx else emit_load in let r,init,cs,st = emit st p init loc in Some r,init,cs,st | W,None -> let init,cs,st = emit_store st p init loc e.v in None,init,cs,st | R,Some PPC.Atomic -> let r,init,cs,st = emit_lda st p init loc in Some r,init,cs,st | W,Some PPC.Atomic -> let r,init,cs,st = emit_sta st p init loc e.v in Some r,init,cs,st | R,Some PPC.Reserve -> let r,init,cs,st = emit_lwarx st p init loc in Some r,init,cs,st | W,Some PPC.Reserve -> Warn.fatal "No store with reservation" | R,Some (PPC.Mixed (sz,o)) -> let r,init,cs,st = emit_load_mixed sz o st p init loc in Some r,init,cs,st | W,Some (PPC.Mixed (sz,o)) -> let init,cs,st = emit_store_mixed sz o st p init loc e.v in None,init,cs,st | J,_ -> emit_joker st init end end let emit_exch_idx st p init er ew idx = let rA,init,st = U.next_init st p init (as_data er.loc) in let rR,st = next_reg st in let rW,init,csi,st = U.emit_mov st p init ew.v in let cs,st = emit_pair p st rR rW idx rA in rR,init,csi@cs,st let emit_exch st p init er ew = emit_exch_idx st p init er ew r0 let emit_rmw () st p init er ew = let rR,init,cs,st = emit_exch st p init er ew in Some rR,init,cs,st let calc_zero = if O.realdep then fun dst src -> PPC.Pandi(dst,src,kbig) else fun dst src -> PPC.Pxor(PPC.DontSetCR0,dst,src,src) let emit_access_dep_addr st p init e r1 = let r2,st = next_reg st in let c = calc_zero r2 r1 in match e.dir,e.loc with | None,_ -> Warn.fatal "TODO" | _,Code _ -> Warn.fatal "No code location for PPC" | Some d,Data loc -> begin match d,e.atom with | R,None -> let r,init,cs,st = emit_load_idx st p init loc r2 in Some r,init, PPC.Instruction c::cs,st | R,Some PPC.Reserve -> let r,init,cs,st = emit_lwarx_idx st p init loc r2 in Some r,init, PPC.Instruction c::cs,st | W,None -> let init,cs,st = emit_store_idx st p init loc r2 e.v in None,init,PPC.Instruction c::cs,st | R,Some PPC.Atomic -> let r,init,cs,st = emit_lda_idx st p init loc r2 in Some r,init, PPC.Instruction c::cs,st | W,Some PPC.Atomic -> let r,init,cs,st = emit_sta_idx st p init loc r2 e.v in Some r,init,PPC.Instruction c::cs,st | W,Some PPC.Reserve -> Warn.fatal "No store with reservation" | _,Some (PPC.Mixed _) -> Warn.fatal "addr dep with mixed" | J,_ -> emit_joker st init end let emit_exch_dep_addr st p init er ew rd = let idx,st = next_reg st in let c = calc_zero idx rd in let r,init,cs,st = emit_exch_idx st p init er ew idx in r,init,PPC.Instruction c::cs,st let emit_access_dep_data st p init e r1 = match e.dir,e.loc with | None,_ -> Warn.fatal "TODO" | Some R,_ ->Warn.fatal "data dependency to load" | _,Code _ -> Warn.fatal "No code location for PPC" | Some W,Data loc -> let rW,st = next_reg st in let ro,init,st = U.emit_const st p init e.v in let cs2 = match ro with | None -> [PPC.Instruction (calc_zero rW r1) ; PPC.Instruction (PPC.Paddi (rW,rW,e.v)) ; ] | Some rC -> [PPC.Instruction (calc_zero rW r1) ; PPC.Instruction (PPC.Padd (PPC.DontSetCR0,rW,rW,rC)) ; ] in let ro,init,cs,st = match e.atom with | None -> let init,cs,st = emit_store_reg st p init loc rW in None,init,cs,st | Some PPC.Atomic -> let r,init,cs,st = emit_sta_reg st p init loc rW in Some r,init,cs,st | Some (PPC.Mixed (sz,o)) -> let init,cs,st = emit_store_reg_mixed sz o st p init loc rW in None,init,cs,st | Some PPC.Reserve -> Warn.fatal "No store with reservation" in ro,init,cs2@cs,st | Some J,_ -> emit_joker st init let insert_isync cs1 cs2 = cs1@[PPC.Instruction PPC.Pisync]@cs2 let emit_access_ctrl isync st p init e r1 v1 = let c,st = if O.realdep then let ok,st = PPC.ok_reg st in let lab = Label.last p in [PPC.Instruction (PPC.Pcmpwi (0,r1,v1)); PPC.Instruction (PPC.Pbcc (PPC.Ne,lab)); PPC.Instruction (inc ok);], A.next_ok st else let lab = Label.next_label "LC" in [PPC.Instruction (PPC.Pcmpw (0,r1,r1)); PPC.Instruction (PPC.Pbcc (PPC.Eq,lab)); PPC.Label (lab,PPC.Nop);],st in match e.dir,e.loc with | None,_ -> Warn.fatal "TODO" | Some R,Data loc -> let emit = match e.atom with | None -> emit_load | Some (PPC.Mixed (sz,o)) -> emit_load_mixed sz o | Some PPC.Reserve ->emit_lwarx | Some PPC.Atomic -> emit_lda in let r,init,cs,st = emit st p init loc in Some r,init,(if isync then insert_isync c cs else c@cs),st | Some W,Data loc -> let ro,init,cs,st = match e.atom with | None -> let init,cs,st = emit_store st p init loc e.v in None,init,cs,st | Some (PPC.Mixed (sz,o)) -> let init,cs,st = emit_store_mixed sz o st p init loc e.v in None,init,cs,st | Some PPC.Reserve -> Warn.fatal "No store with reservation" | Some PPC.Atomic -> let r,init,cs,st = emit_sta st p init loc e.v in Some r,init,cs,st in ro,init,(if isync then insert_isync c cs else c@cs),st | Some J,_ -> emit_joker st init | _,Code _ -> Warn.fatal "No code location for PPC" let emit_exch_ctrl isync st p init er ew rd = let lab = Label.next_label "LC" in let c = [PPC.Instruction (PPC.Pcmpw (0,rd,rd)); PPC.Instruction (PPC.Pbcc (PPC.Eq,lab)); PPC.Label (lab,PPC.Nop);] in let r,init,csr,st = emit_lwarx st p init (as_data er.loc) in let init,csw,st = emit_one_stwcx st p init (as_data ew.loc) ew.v in let cs = csr@csw in let cs = if isync then insert_isync c cs else c@cs in r,init,cs,st let emit_access_dep st p init e dp r1 n1 = let v1 = n1.C.evt.C.v in match dp with | PPC.ADDR -> emit_access_dep_addr st p init e r1 | PPC.DATA -> emit_access_dep_data st p init e r1 | PPC.CTRL -> emit_access_ctrl false st p init e r1 v1 | PPC.CTRLISYNC -> emit_access_ctrl true st p init e r1 v1 let emit_exch_dep st p init er ew dp rd = match dp with | PPC.ADDR -> emit_exch_dep_addr st p init er ew rd | PPC.DATA -> Warn.fatal "not data dependency to RMW" | PPC.CTRL -> emit_exch_ctrl false st p init er ew rd | PPC.CTRLISYNC -> emit_exch_ctrl true st p init er ew rd let emit_rmw_dep () st p init er ew dp rd _n = let r,init,cs,st = emit_exch_dep st p init er ew dp rd in Some r,init,cs,st (* Fences *) let emit_fence st _ init _ f = init,[PPC.Instruction (match f with | PPC.Sync -> PPC.Psync | PPC.LwSync -> PPC.Plwsync | PPC.ISync -> PPC.Pisync | PPC.Eieio -> PPC.Peieio)],st let emit_fence_dp st a init b f _ r _ = let init,cs,st = emit_fence st a init b f in Some r,init,cs,st let stronger_fence = PPC.Sync (* Check load *) let do_check_load p st r e = let ok,st = A.ok_reg st in (fun k -> PPC.Instruction (PPC.Pcmpwi (0,r,e.v)):: PPC.Instruction (PPC.Pbcc (PPC.Ne,Label.last p)):: PPC.Instruction (inc ok):: k), PPC.next_ok st let check_load p r e init st = let cs,st = do_check_load p st r e in init,cs,st (* Postlude *) let postlude = mk_postlude emit_store_reg let get_xstore_results _ = [] include NoInfo end herd-herdtools7-1ca343e/gen/RISCVArch_gen.ml000066400000000000000000000135531475314470400205710ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2017-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Config = struct let naturalsize = MachSize.Word let moreedges = false end module Make (C:sig val naturalsize : MachSize.sz val moreedges : bool end) = struct include RISCVBase (* Little endian, as far as I know *) let tr_endian = Misc.identity (* No Scope *) module ScopeGen = ScopeGen.NoGen (* Mixed size *) module Mixed = MachMixed.Make (struct let naturalsize = Some C.naturalsize let fullmixed = C.moreedges end) include NoWide (*********) (* Atoms *) (*********) let bellatom = false module SIMD = NoSIMD type atom = MO of mo | Atomic of mo * mo | Mixed of MachMixed.t let default_atom = Atomic (Rlx,Rlx) let instr_atom = None let applies_atom a d = match a with | MO mo -> begin match mo,d with | (Acq,Code.W)|(Rel,Code.R) -> false | (Rel, Code.W)|(Acq, Code.R) | ((Rlx|AcqRel), _) -> true | _,Code.J -> assert false | Sc,_ -> assert false end | Atomic _|Mixed _ -> true let is_ifetch _ = false let pp_plain = "P" let pp_as_a = None let pp_mo = function | Rlx -> "P" | Acq -> "Aq" | Rel -> "Rl" | AcqRel -> "AR" | Sc -> assert false let pp_mo2 m1 m2 = match m1,m2 with | Rlx,Rlx -> "" | _,_ -> pp_mo m1 ^ pp_mo m2 let pp_atom = function | MO mo -> pp_mo mo | Atomic (m1,m2) -> "X" ^ pp_mo2 m1 m2 | Mixed m -> Mixed.pp_mixed m let compare_atom = compare let get_access_atom = function | None | Some (MO _|Atomic _) -> None | Some (Mixed m) -> Some m let set_access_atom a sz = Some (match a with | None|Some (Mixed _) -> Mixed sz | Some (MO _|Atomic _ as a) -> a) let fold_mixed f k = Mixed.fold_mixed (fun mix r -> f (Mixed mix) r) k let fold_mo f k = let k = f Acq k in let k = f Rel k in let k = f AcqRel k in k let fold_rmw f k = let fold1 f k = fold_mo f (f Rlx k) in fold1 (fun m1 k -> fold1 (fun m2 k -> f (Atomic (m1,m2)) k) k) k let fold_non_mixed f k = let k = fold_mo (fun mo k -> f (MO mo) k) k in fold_rmw f k let fold_atom f k = let k = fold_mixed f k in fold_non_mixed f k let worth_final = function | Atomic _ -> true | MO _|Mixed _ -> false let varatom_dir _ f k = f None k let merge_atoms a1 a2 = if a1=a2 then Some a1 else None let overlap_atoms a1 a2 = match a1,a2 with | ((MO _|Atomic _),_)|(_,(MO _|Atomic _)) -> true | Mixed m1,Mixed m2 -> MachMixed.overlap m1 m2 let atom_to_bank _ = Code.Ord let tr_value ao v = match ao with | None| Some (MO _|Atomic _) -> v | Some (Mixed (sz,_)) -> Mixed.tr_value sz v module ValsMixed = MachMixed.Vals (struct let naturalsize () = C.naturalsize let endian = endian end) let overwrite_value v ao w = match ao with | None| Some (MO _|Atomic _) -> w (* total overwrite *) | Some (Mixed (sz,o)) -> ValsMixed.overwrite_value v sz o w let extract_value v ao = match ao with | None| Some (MO _|Atomic _) -> v | Some (Mixed (sz,o)) -> ValsMixed.extract_value v sz o module PteVal = PteVal_gen.No(struct type arch_atom = atom end) (* End of atoms *) type fence = barrier let is_isync = function | FenceI -> true | _ -> false let compare_fence = barrier_compare let default = Fence (IORW,IORW) let strong = default let pp_fence f = Misc.capitalize (pp_barrier_dot f) let add_iorw fold f k = fold f k |> f (Fence (IORW,IORW)) let do_fold_fence f = add_iorw do_fold_fence f and fold_barrier f = add_iorw fold_barrier f let fold_cumul_fences f k = do_fold_fence f k let fold_all_fences f k = fold_barrier f k let fold_some_fences = fold_all_fences let applies r d = match r,d with | (IORW|RW),_ | (IR|R),Code.R | (OW|W),Code.W -> true | (W|OW),Code.R | (R|IR),Code.W -> false | _ -> assert false let orders f d1 d2 = match f with | FenceI -> false | FenceTSO -> begin match d1,d2 with | Code.W,Code.R -> false | _,_ -> true end | Fence (r1,r2) -> applies r1 d1 && applies r2 d2 let var_fence f r = f default r (********) (* Deps *) (********) include Dep let pp_dp = function | ADDR -> "Addr" | DATA -> "Data" | CTRL -> "Ctrl" | CTRLISYNC -> "CtrlFenceI" include Exch.Exch(struct type arch_atom = atom end) include NoEdge include ArchExtra_gen.Make (struct type arch_reg = reg let is_symbolic = function | Symbolic_reg _ -> true | _ -> false let pp_reg = pp_reg let pp_i _ = assert false let free_registers = allowed_for_symb include NoSpecial end) end herd-herdtools7-1ca343e/gen/RISCVCompile_gen.ml000066400000000000000000000466021475314470400213050ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2017-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Sign module type Config = sig include CompileCommon.Config val realdep : bool end module Make(Cfg:Config) : XXXCompile_gen.S = struct let naturalsize = TypBase.get_size Cfg.typ module RISCV = RISCVArch_gen.Make (struct let naturalsize = naturalsize let moreedges = Cfg.moreedges end) include CompileCommon.Make(Cfg)(RISCV) let ppo _f k = k module AV=RISCV open RISCV open C open Code (* Utilities *) let zero = AV.Ireg AV.X0 let next_reg x = RISCV.alloc_reg x (**********************) (* Basic instructions *) (**********************) let wloc = let open TypBase in let open MachSize in match Cfg.typ with | Std (_,MachSize.Quad) -> AV.Double | Int |Std (_,(Word|Short|Byte)) -> AV.Word | Pteval | Std (_,MachSize.S128) -> assert false let bne r1 r2 lab = AV.Bcc (AV.NE,r1,r2,lab) let cbz r lab = AV.Bcc (AV.EQ,r,zero,lab) and cbnz r lab = AV.Bcc (AV.NE,r,zero,lab) let ori r1 r2 k = AV.OpI (AV.ORI,r1,r2,k) let li r k = ori r zero k let andi r1 r2 k = AV.OpI (AV.ANDI,r1,r2,k) let mv r1 r2 = AV.Op (AV.OR,r1,r2,zero) let addiw r1 r2 k = AV.OpIW (AV.ADDIW,r1,r2,k) let subiw r1 r2 k = addiw r1 r2 (-k) let addi r1 r2 k = AV.OpI (AV.ADDI,r1,r2,k) let incr r = addi r r 1 let _subi r1 r2 k = addi r1 r2 (-k) let amoswap mo r1 r2 r3 = AV.Amo (AV.AMOSWAP,wloc,mo,r1,r2,r3) let amoor_as_load mo r1 r2 = AV.Amo (AV.AMOOR,wloc,mo,r1,zero,r2) and swap_as_store mo r1 r2 = AV.Amo (AV.AMOSWAP,wloc,mo,zero,r1,r2) let as_amo = Cfg.variant Variant_gen.AsAmo let ldr mo r1 r2 = match mo with |AV.Rlx -> AV.Load (wloc,Signed,mo,r1,0,r2) |AV.Acq|AV.Rel|AV.AcqRel -> if as_amo then amoor_as_load mo r1 r2 else AV.Load (wloc,Signed,mo,r1,0,r2) |AV.Sc -> assert false and str mo r1 r2 = match mo with |AV.Rlx -> AV.Store (wloc,mo,r1,0,r2) |AV.Acq|AV.Rel|AV.AcqRel -> if as_amo then swap_as_store mo r1 r2 else AV.Store (wloc,mo,r1,0,r2) |AV.Sc -> assert false let add r1 r2 r3 = AV.Op (AV.ADD,r1,r2,r3) let xor r1 r2 r3 = AV.Op (AV.XOR,r1,r2,r3) let tr_sz = function | MachSize.Byte -> AV.Byte | MachSize.Short -> AV.Half | MachSize.Word -> AV.Word | MachSize.Quad -> AV.Double | MachSize.S128 -> assert false let ldr_mixed r1 r2 sz o = AV.Load (tr_sz sz,Signed,AV.Rlx,r1,o,r2) and str_mixed r1 r2 sz o = AV.Store (tr_sz sz,AV.Rlx,r1,o,r2) let lr mo r1 r2 = AV.LoadReserve (wloc,mo,r1,r2) and sc mo r1 r2 r3 = AV.StoreConditional (wloc,mo,r1,r2,r3) module Extra = struct let use_symbolic = false type reg = AV.reg type instruction = AV.pseudo let mov r v = Instruction (li r v) let mov_mixed _sz _r _v = assert false let mov_reg r1 r2 = Instruction (mv r1 r2) let mov_reg_mixed _sz _r1 _r2 = assert false end module U = GenUtils.Make(Cfg)(AV)(Extra) let next_const st p init v = match v with | 0 -> zero,init,st | _ -> let r,st = next_reg st in r,(Reg (p,r),Some (A.S (Printf.sprintf "0x%x" v)))::init,st (*********) (* Loads *) (*********) let emit_load_mixed sz o st p init x = let rA,st = next_reg st in let rB,init,st = U.next_init st p init x in rA,init,lift_code [ldr_mixed rA rB sz o],st module type L = sig val load : AV.mo -> reg -> reg -> instruction end module MKLOAD(L:L) = struct let load_idx mo st rA rB idx = let rD,st = next_reg st in [add rD rB idx;L.load mo rA rD],st let emit_load mo st p init x = let rA,st = next_reg st in let rB,init,st = U.next_init st p init x in let ld = L.load mo rA rB in rA,init,lift_code [ld],st let emit_load_not_zero mo st p init x = let rA,st = next_reg st in let rB,init,st = U.next_init st p init x in let ld = L.load mo rA rB in let lab = Label.next_label "L" in rA,init,Label (lab,Nop)::lift_code (ld::[cbz rA lab]),st let emit_load_one mo st p init x = let rA,st = next_reg st in let rB,init,st = U.next_init st p init x in let lab = Label.next_label "L" in let ld = L.load mo rA rB in rA,init, Label (lab,Nop):: lift_code [ld; subiw rA rA 1; cbnz rA lab; li rA 1;], st let emit_load_not mo st p init x bne = let rA,st = next_reg st in let rC,st = next_reg st in let rB,init,st = U.next_init st p init x in let lab = Label.next_label "L" in let out = Label.next_label "L" in let r200,init,st = next_const st p init 200 in rA,init, Instruction (mv rC r200):: (* 200 X about 5 ins looks for a typical memory delay *) Label (lab,Nop):: lift_code [ L.load mo rA rB; bne rA out ; subiw rC rC 1 ; cbnz rC lab ; ]@ [Label (out,Nop)], st let emit_load_not_eq mo st p init x rP = emit_load_not mo st p init x (fun r out -> bne rP r out) let emit_load_not_value mo st p init x v = let rC,init,st = next_const st p init v in emit_load_not_eq mo st p init x rC let emit_load_idx mo st p init x idx = let rA,st = next_reg st in let rB,init,st = U.next_init st p init x in let ins,st = load_idx mo st rA rB idx in rA,init,lift_code ins ,st end module LOAD = MKLOAD (struct let load = ldr end) module OBS = MKLOAD (struct let load mo rA rB = assert (mo = AV.Rlx) ; ldr_mixed rA rB naturalsize 0 end) (* For export *) let emit_load_one = LOAD.emit_load_one AV.Rlx let emit_load = LOAD.emit_load AV.Rlx let emit_obs _ = OBS.emit_load AV.Rlx let emit_obs_not_value = OBS.emit_load_not_value AV.Rlx let emit_obs_not_eq = OBS.emit_load_not_eq AV.Rlx let emit_obs_not_zero = OBS.emit_load_not_zero AV.Rlx (**********) (* Stores *) (**********) let emit_store_reg_mixed sz o st p init x rA = let rB,init,st = U.next_init st p init x in init,[Instruction (str_mixed rA rB sz o)],st let emit_store_mixed sz o st p init x v = let rA,init,csi,st = U.emit_mov st p init v in let init,cs,st = emit_store_reg_mixed sz o st p init x rA in init,csi@cs,st module STORE = struct let store_idx mo st rA rB idx = let rD,st = next_reg st in [add rD rB idx;str mo rA rD],st let emit_store_reg mo st p init x rA = let rB,init,st = U.next_init st p init x in init,[Instruction (str mo rA rB)],st let emit_store mo st p init x v = let rA,init,csi,st = U.emit_mov st p init v in let init,cs,st = emit_store_reg mo st p init x rA in init,csi@cs,st let emit_store_idx_reg mo st p init x idx rA = let rB,init,st = U.next_init st p init x in let ins,st = store_idx mo st rA rB idx in init,lift_code ins,st let emit_store_idx mo st p init x idx v = let rA,init,csi,st = U.emit_mov st p init v in let init,cs,st = emit_store_idx_reg mo st p init x idx rA in init,csi@cs,st end (***************************) (* Atomic loads and stores *) (***************************) let tempo1 st = A.alloc_trashed_reg "T1" st let emit_loop_pair mo1 mo2 _p st rR rW rA = let lbl = Label.next_label "Loop" in let r,st = tempo1 st in let cs = [ Label (lbl,Instruction (lr mo1 rR rA)); Instruction (sc mo2 r rW rA); Instruction (cbnz r lbl); ] in cs,st let emit_one_pair mo1 mo2 p st r rR rW rA k = let ok,st = A.ok_reg st in Instruction (lr mo1 rR rA):: Instruction (sc mo2 r rW rA):: Instruction (cbnz r (Label.last p)):: k (Instruction (incr ok)), A.next_ok st let emit_unroll_pair u mo1 mo2 p st rR rW rA = if u <= 0 then let r,st = next_reg st in lift_code [lr mo1 rR rA; sc mo2 r rW rA;],st else if u = 1 then let r,st = tempo1 st in emit_one_pair mo1 mo2 p st r rR rW rA (fun i -> [i]) else let r,st = tempo1 st in let out = Label.next_label "Go" in let rec do_rec = function | 1 -> let cs,st = emit_one_pair mo1 mo2 p st r rR rW rA (fun i -> [Label (out,Nop);i]) in cs,st | u -> let cs,st = do_rec (u-1) in Instruction (lr mo1 rR rA):: Instruction (sc mo2 r rW rA):: Instruction (cbz r out)::cs, st in do_rec u let emit_pair = match Cfg.unrollatomic with | None -> emit_loop_pair | Some u -> emit_unroll_pair u let emit_lda_reg mo1 mo2 st p rA = let rR,st = next_reg st in let cs,st = emit_pair mo1 mo2 p st rR rR rA in rR,cs,st let emit_lda mo1 mo2 st p init loc = let rA,init,st = U.next_init st p init loc in let r,cs,st = emit_lda_reg mo1 mo2 st p rA in r,init,cs,st let emit_lda_idx mo1 mo2 st p init loc idx = let rA,init,st = U.next_init st p init loc in let rB,st = next_reg st in let r,cs2,st = emit_lda_reg mo1 mo2 st p rB in r,init,lift_code [add rB rA idx]@cs2,st let do_emit_sta mo1 mo2 st p rW rA = let rR,st = next_reg st in let cs,st = emit_pair mo1 mo2 p st rR rW rA in rR,cs,st let emit_sta mo1 mo2 st p init loc v = let rA,init,st = U.next_init st p init loc in let rW,init,csv,st = U.emit_mov st p init v in let rR,cs,st = do_emit_sta mo1 mo2 st p rW rA in rR,init,csv@cs,st let emit_sta_reg mo1 mo2 st p init loc rW = let rA,init,st = U.next_init st p init loc in let rR,cs,st = do_emit_sta mo1 mo2 st p rW rA in rR,init,cs,st let emit_sta_idx mo1 mo2 st p init loc idx v = let rA,init,st = U.next_init st p init loc in let rX,st = next_reg st in let rW,init,csv,st = U.emit_mov st p init v in let rR,cs2,st = do_emit_sta mo1 mo2 st p rW rX in rR,init,csv@Instruction (add rX rA idx)::cs2,st (**********) (* Access *) (**********) let emit_joker st init = None,init,[],st let emit_access st p init e = match e.dir,e.loc with | None,_ -> Warn.fatal "TODO" | Some d,Data loc -> begin match d,e.atom with | Code.R,None -> let r,init,cs,st = LOAD.emit_load AV.Rlx st p init loc in Some r,init,cs,st | Code.R,Some (MO mo) -> let r,init,cs,st = LOAD.emit_load mo st p init loc in Some r,init,cs,st | Code.R,Some (Atomic (mo1,mo2)) -> let r,init,cs,st = emit_lda mo1 mo2 st p init loc in Some r,init,cs,st | Code.R,Some (Mixed (sz,o)) -> let r,init,cs,st = emit_load_mixed sz o st p init loc in Some r,init,cs,st | Code.W,None -> let init,cs,st = STORE.emit_store AV.Rlx st p init loc e.v in None,init,cs,st | Code.W,(Some (MO mo)) -> let init,cs,st = STORE.emit_store mo st p init loc e.v in None,init,cs,st | Code.W,Some (Atomic (mo1,mo2)) -> let r,init,cs,st = emit_sta mo1 mo2 st p init loc e.v in Some r,init,cs,st | Code.W,Some (Mixed (sz,o)) -> let init,cs,st = emit_store_mixed sz o st p init loc e.v in None,init,cs,st | Code.J, _ -> emit_joker st init end | _,Code _ -> Warn.fatal "No code location for RISCV" let tr_a = function | None -> AV.Rlx | Some (MO mo) -> mo | Some (Atomic _|Mixed _) as at -> Warn.fatal "bad atomicity in rmw, %s" (E.pp_atom_option at) (* let emit_exch st p init er ew = let rA,init,st = U.next_init st p init er.loc in let rR,st = next_reg st in let rW,init,csv,st = U.emit_mov st p init ew.v in let mo1 = tr_a er.C.atom and mo2 = tr_a ew.C.atom in let cs,st = emit_pair mo1 mo2 p st rR rW rA in rR,init,csv@cs,st *) let tr_swap a1 a2 = match tr_a a1,tr_a a2 with | (AV.Rlx,a)|(a,AV.Rlx) -> a | (AV.Acq,AV.Rel)|(AV.AcqRel,_)|(_,AV.AcqRel) -> AV.AcqRel | (AV.Sc,_)|(_,AV.Sc) -> assert false | (AV.Rel,_)|(_,AV.Acq) -> Warn.fatal "bad atomicity in rmw, acquire on write or release on read" let emit_exch st p init er ew = let rA,init,st = U.next_init st p init (Code.as_data er.loc) in let rR,st = next_reg st in let rW,init,csv,st = U.emit_mov st p init ew.v in let mo = tr_swap er.C.atom ew.C.atom in rR,init,csv@[Instruction (amoswap mo rR rW rA)],st let emit_rmw () st p init er ew = let rR,init,cs,st = emit_exch st p init er ew in Some rR,init,cs,st (**********) (* Fences *) (**********) let emit_fence st _ init _ f = init,[Instruction (AV.FenceIns f)],st let emit_fence_dp st a init b f _ r _ = let init,cs,st = emit_fence st a init b f in Some r,init,cs,st let stronger_fence = strong (* Dependencies *) let calc0 = if Cfg.realdep then fun dst src -> andi dst src 128 else fun dst src -> xor dst src src let emit_access_dep_addr st p init e rd = let r2,st = next_reg st in let c = calc0 r2 rd in match e.dir,e.loc with | None,_ -> Warn.fatal "TODO" | Some d,Data loc -> begin match d,e.atom with | Code.R,None -> let r,init,cs,st = LOAD.emit_load_idx AV.Rlx st p init loc r2 in Some r,init, Instruction c::cs,st | Code.R,Some (MO mo) -> let r,init,cs,st = LOAD.emit_load_idx mo st p init loc r2 in Some r,init, Instruction c::cs,st | Code.R,Some (Atomic (mo1,mo2)) -> let r,init,cs,st = emit_lda_idx mo1 mo2 st p init loc r2 in Some r,init, Instruction c::cs,st | Code.W,None -> let init,cs,st = STORE.emit_store_idx AV.Rlx st p init loc r2 e.v in None,init,Instruction c::cs,st | Code.W,Some (MO mo) -> let init,cs,st = STORE.emit_store_idx mo st p init loc r2 e.v in None,init,Instruction c::cs,st | Code.W,Some (Atomic (mo1,mo2)) -> let r,init,cs,st = emit_sta_idx mo1 mo2 st p init loc r2 e.v in Some r,init,Instruction c::cs,st | _,Some (Mixed _) -> Warn.fatal "addr dep with mixed" | Code.J, _ -> emit_joker st init end | _,Code _ -> Warn.fatal "No code location for RISCV" let emit_exch_dep_addr st p init er ew rd = let r2,st = next_reg st in let c = calc0 r2 rd in let loc = Code.as_data er.loc in let rA,init,st = U.next_init st p init loc in let rW,init,csv,st = U.emit_mov st p init ew.v in let rR,st = next_reg st in let mo = tr_swap er.C.atom ew.C.atom in let swap = Instruction (amoswap mo rR rW rA) in rR,init, Instruction c::Instruction (add r2 rA r2)::csv@[swap],st let emit_access_dep_data st p init e r1 = match e.dir,e.loc with | None,_ -> Warn.fatal "TODO" | Some Code.R,_ -> Warn.fatal "data dependency to load" | Some Code.W,Data loc -> let r2,st = next_reg st in let cs2 = [Instruction (calc0 r2 r1) ; Instruction (ori r2 r2 e.v) ; ] in begin match e.atom with | None -> let init,cs,st = STORE.emit_store_reg AV.Rlx st p init loc r2 in None,init,cs2@cs,st | Some (MO mo) -> let init,cs,st = STORE.emit_store_reg mo st p init loc r2 in None,init,cs2@cs,st | Some (Atomic (mo1,mo2)) -> let r,init,cs,st = emit_sta_reg mo1 mo2 st p init loc r2 in Some r,init,cs2@cs,st | Some (Mixed _) -> Warn.fatal "data dep with mixed" end | Some Code.J,_ -> emit_joker st init | _,Code _ -> Warn.fatal "No code location for RISCV" let insert_isb st p init isb cs1 cs2 = let _,cs,_ = emit_fence st p init 0 FenceI in if isb then cs1@cs@cs2 else cs1@cs2 let emit_access_ctrl isb st p init e r1 = let lab = Label.next_label "LC" in let c = [Instruction (cbnz r1 lab); Label (lab,Nop);] in let ropt,init,cs,st = emit_access st p init e in ropt,init,insert_isb st p init isb c cs,st let emit_exch_ctrl isb st p init er ew r1 = let lab = Label.next_label "LC" in let c = [Instruction (cbnz r1 lab); Label (lab,Nop);] in let ropt,init,cs,st = emit_exch st p init er ew in ropt,init,insert_isb st p init isb c cs,st let emit_access_dep st p init e dp r1 _v1 = match dp with | ADDR -> emit_access_dep_addr st p init e r1 | DATA -> emit_access_dep_data st p init e r1 | CTRL -> emit_access_ctrl false st p init e r1 | CTRLISYNC -> emit_access_ctrl true st p init e r1 let emit_exch_dep st p init er ew dp rd = match dp with | ADDR -> emit_exch_dep_addr st p init er ew rd | DATA -> Warn.fatal "not data dependency to RMW" | CTRL -> emit_exch_ctrl false st p init er ew rd | CTRLISYNC -> emit_exch_ctrl true st p init er ew rd let emit_rmw_dep () st p init er ew dp rd _n = let r,init,cs,st = emit_exch_dep st p init er ew dp rd in Some r,init,cs,st let check_load p r e init st = let ok,st = A.ok_reg st in let rI,init,ci,st = U.emit_mov st p init e.v in init, (fun k -> ci@ (Instruction (bne r rI (Label.last p)):: Instruction (incr ok)::k)), A.next_ok st (* Postlude *) let postlude = mk_postlude (fun st p init loc r -> STORE.emit_store_reg AV.Rlx st p init loc r) let get_strx_result k = function | StoreConditional (_,_,r,_,_) -> r::k | _ -> k let get_strx_result_pseudo k = pseudo_fold get_strx_result k let get_xstore_results = match Cfg.unrollatomic with | Some x when x <= 0 -> fun cs -> let rs = List.fold_left get_strx_result_pseudo [] cs in List.rev_map (fun r -> r,0) rs | Some _|None -> fun _ -> [] include NoInfo end herd-herdtools7-1ca343e/gen/X86Arch_gen.ml000066400000000000000000000060431475314470400202640ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Code include X86Base let tr_endian = Misc.identity module ScopeGen = ScopeGen.NoGen let bellatom = false module SIMD = NoSIMD type atom = Atomic let default_atom = Atomic let instr_atom = None let applies_atom a d = match a,d with | Atomic,W -> true | _,_ -> false let is_ifetch _ = false let compare_atom = compare include MachMixed.No let merge_atoms Atomic Atomic = Some Atomic let overlap_atoms _ _ = true let pp_plain = Code.plain let pp_as_a = None let pp_atom = function | Atomic -> "A" let fold_non_mixed f k = f Atomic k let fold_atom f k = fold_non_mixed f k let worth_final _ = true let varatom_dir _d f = f None let atom_to_bank _ = Code.Ord include NoMixed include NoWide module PteVal = PteVal_gen.No(struct type arch_atom = atom end) (**********) (* Fences *) (**********) type fence = MFence let is_isync _ = false let compare_fence = compare let default = MFence let strong = default let pp_fence = function | MFence -> "MFence" let fold_all_fences f r = f MFence r let fold_cumul_fences f r = f MFence r let fold_some_fences f r = f MFence r let orders f d1 d2 = match f,d1,d2 with | MFence,_,_ -> true let var_fence f r = f default r (********) (* Deps *) (********) type dp let pp_dp _ = assert false let fold_dpr _f r = r let fold_dpw _f r = r let ddr_default = None let ddw_default = None let ctrlr_default = None let ctrlw_default = None let is_ctrlr _ = assert false let is_addr _ = assert false let fst_dp _ = assert false let sequence_dp _ _ = assert false (*******) (* RWM *) (*******) include Exch.Exch(struct type arch_atom = atom end) include NoEdge include ArchExtra_gen.Make (struct type arch_reg = reg let is_symbolic = function | Symbolic_reg _ -> true | _ -> false let pp_reg = pp_reg let pp_i _ = assert false let free_registers = allowed_for_symb include NoSpecial end) herd-herdtools7-1ca343e/gen/X86Compile_gen.ml000066400000000000000000000123631475314470400210010ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Code module Make(C:CompileCommon.Config) : XXXCompile_gen.S = struct module X86 = X86Arch_gen include CompileCommon.Make(C)(X86) (******) let ppo _f k = k (******) open X86 let next_reg x = alloc_reg x let emit_store addr v = I_MOV (Effaddr_rm32 (Rm32_abs (ParsedConstant.nameToV addr)), Operand_immediate v) let emit_store_reg addr r = I_MOV (Effaddr_rm32 (Rm32_abs (ParsedConstant.nameToV addr)), Operand_effaddr (Effaddr_rm32 (Rm32_reg r))) let emit_sta addr r v = [ I_MOV (Effaddr_rm32 (Rm32_reg r), Operand_immediate v) ; I_XCHG (Effaddr_rm32 (Rm32_abs (ParsedConstant.nameToV addr)), Effaddr_rm32 (Rm32_reg r)) ] let emit_load_ins addr r = let addr = ParsedConstant.nameToV addr in I_MOV (Effaddr_rm32 (Rm32_reg r), Operand_effaddr (Effaddr_rm32 (Rm32_abs addr))) and emit_cmp_zero_ins r = I_CMP (Effaddr_rm32 (Rm32_reg r), Operand_immediate 0) and emit_cmp_one_ins r = I_CMP (Effaddr_rm32 (Rm32_reg r), Operand_immediate 1) and emit_cmp_int_ins r i = I_CMP (Effaddr_rm32 (Rm32_reg r), Operand_immediate i) and emit_je_ins lab = I_JCC (C_EQ,lab) and emit_jne_ins lab = I_JCC (C_NE,lab) let pseudo = List.map (fun i -> X86.Instruction i) let emit_load st _p init x = let rA,st = next_reg st in rA,init,pseudo [emit_load_ins x rA],st let emit_obs _ = emit_load let emit_obs_not_zero st _p init x = let rA,st = next_reg st in let lab = Label.next_label "L" in rA,init, Label (lab,Nop):: pseudo [emit_load_ins x rA ; emit_cmp_zero_ins rA ; emit_je_ins lab], st let emit_load_one st _p init x = let rA,st = next_reg st in let lab = Label.next_label "L" in rA,init, Label (lab,Nop):: pseudo [emit_load_ins x rA ; emit_cmp_one_ins rA ; emit_jne_ins lab], st let emit_load_not _st _p _init _x _cmp = Warn.fatal "Loop observers not implemented for X86" let emit_obs_not_eq st = emit_load_not st let emit_obs_not_value st = emit_load_not st let emit_joker st init = None,init,[],st let emit_access st _p init e = match e.C.dir,e.C.loc with | None,_ -> Warn.fatal "TODO" | Some R,Data loc -> let rA,st = next_reg st in begin match e.C.atom with | None -> Some rA,init,pseudo [emit_load_ins loc rA],st | Some Atomic -> Warn.fatal "No atomic load for X86" end | Some W,Data loc -> if (match e.C.atom with Some Atomic -> true | None -> false) then let rX,st = next_reg st in None,init,pseudo (emit_sta loc rX e.C.v), st else None,init,pseudo [emit_store loc e.C.v],st | Some J,_ -> emit_joker st init | _,Code _ -> Warn.fatal "No code location for X86" let emit_exch st _p init er ew = let rA,st = next_reg st in rA,init, pseudo (emit_sta (Code.as_data er.C.loc) rA ew.C.v), st let emit_rmw () st p init er ew = let rR,init,cs,st = emit_exch st p init er ew in Some rR,init,cs,st let emit_access_dep _st _p _init _e _r1 = Warn.fatal "Dependent access is irrelevant for X86" let emit_exch_dep _st = Warn.fatal "Dependent access is irrelevant for X86" let emit_rmw_dep () _n = emit_exch_dep let emit_fence st _ init _ f = match f with | MFence -> init,[X86.Instruction I_MFENCE],st let emit_fence_dp st a init b f _ r _ = let init,cs,st = emit_fence st a init b f in Some r,init,cs,st let stronger_fence = MFence let emit_inc r = I_INC (Effaddr_rm32 (Rm32_reg r)) (* Check load *) let do_check_load p st r e = let ok,st = A.ok_reg st in (fun k -> Instruction (emit_cmp_int_ins r e.C.v):: Instruction (emit_jne_ins (Label.last p)):: Instruction (emit_inc ok):: k), A.next_ok st let check_load p r e init st = let cs,st = do_check_load p st r e in init,cs,st (* Postlude *) let postlude = mk_postlude (fun st _p init loc r -> init,[Instruction (emit_store_reg loc r)],st) let get_xstore_results _ = [] include NoInfo end herd-herdtools7-1ca343e/gen/X86_64Arch_gen.ml000066400000000000000000000173401475314470400205770ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Config = struct let naturalsize = MachSize.Word let fullmixed = true end module Make (C:sig val naturalsize : MachSize.sz val fullmixed : bool end) = struct open Printf include X86_64Base let tr_endian = Misc.identity module ScopeGen = ScopeGen.NoGen module Mixed = MachMixed.Make (struct let naturalsize = Some C.naturalsize let fullmixed = C.fullmixed end) let bellatom = false module SIMD = NoSIMD type atom_acc = Plain | Atomic | NonTemporal type atom = atom_acc * MachMixed.t option let default_atom = Atomic,None let instr_atom = None let applies_atom a d = match a,d with | ((Atomic,_),Code.W) | (((Plain|NonTemporal),_),(Code.W|Code.R)) -> true | ((Atomic,_),Code.R) | (_,Code.J)-> false let is_ifetch _ = false let compare_atom = compare include MachMixed.Util (struct type at = atom_acc let plain = Plain end) let pp_plain = Code.plain let pp_as_a = None let pp_atom_acc = function | Atomic -> "A" | Plain -> "" | NonTemporal -> "NT" let pp_atom = function | a,None -> pp_atom_acc a | a,Some m -> sprintf "%s%s" (pp_atom_acc a) (Mixed.pp_mixed m) let fold_mixed f r = Mixed.fold_mixed (fun mix r -> f (Plain,Some mix) r) r let fold_acc f k = f Atomic (f NonTemporal k) let fold_non_mixed f r = fold_acc (fun acc r -> f (acc,None) r) r let apply_mix f acc m r = match acc,m with | (NonTemporal,(None|Some ((MachSize.Quad|MachSize.Word),_))) | ((Plain|Atomic),_) -> f (acc,m) r | (NonTemporal,Some ((MachSize.Short|MachSize.Byte),_)) -> r | (NonTemporal,Some (MachSize.S128,_)) -> assert false let fold_atom f r = fold_acc (fun acc r -> Mixed.fold_mixed (fun m r -> apply_mix f acc (Some m) r) (f (acc,None) r)) (fold_mixed f r) let worth_final (a,_) = match a with | NonTemporal|Plain -> false | Atomic -> true let varatom_dir _d f = f None let check_nt a sz = apply_mix (fun c _ -> Some c) a sz None let merge_atoms a1 a2 = match a1,a2 with | ((Plain,sz),(a,None)) | ((a,None), (Plain,sz)) -> check_nt a sz | ((a1,None),(a2,sz)) | ((a1,sz),(a2,None)) when a1=a2 -> check_nt a1 sz | ((Plain,sz1),(a,sz2)) | ((a,sz1),(Plain,sz2)) when sz1=sz2 -> check_nt a sz1 | _,_ -> if a1=a2 then Some a1 else None let overlap_atoms a1 a2 = match a1,a2 with | ((_,None),_)|(_,(_,None)) -> true | (_,Some m1),(_,Some m2) -> MachMixed.overlap m1 m2 let atom_to_bank _ = Code.Ord (**************) (* Mixed size *) (**************) let tr_value ao v = match ao with | None | Some ((NonTemporal|Plain|Atomic),None) -> v | Some ((NonTemporal|Plain|Atomic), Some (sz, _)) -> Mixed.tr_value sz v module ValsMixed = MachMixed.Vals (struct let naturalsize () = C.naturalsize let endian = endian end) let overwrite_value v ao w = match ao with | None | Some ((Plain|Atomic|NonTemporal),None) -> w | Some ((Plain|Atomic|NonTemporal),Some (sz, o)) -> ValsMixed.overwrite_value v sz o w let extract_value v ao = match ao with | None | Some ((Plain|Atomic|NonTemporal),None) -> v | Some ((Plain|Atomic|NonTemporal),Some (sz, o)) -> ValsMixed.extract_value v sz o include NoWide module PteVal = PteVal_gen.No(struct type arch_atom = atom end) (**********) (* Fences *) (**********) type flushline = Prev|Next|Other type fence = Fence of barrier | ClFlush of opt * flushline let is_isync _ = false let compare_fence f1 f2 = match f1,f2 with | Fence b1,Fence b2 -> barrier_compare b1 b2 | ClFlush (o1,l1),ClFlush (o2,l2) -> begin match compare o1 o2 with | 0 -> compare l1 l2 | r -> r end | ClFlush _,Fence _ -> -1 | Fence _,ClFlush _ -> 1 let default = Fence MFENCE let strong = default let pp_barrier = function | MFENCE -> "MFence" | SFENCE -> "SFence" | LFENCE -> "LFence" let pp_fence = function | Fence b -> pp_barrier b | ClFlush (NoOpt,Prev) -> "ClFlush" | ClFlush (Opt,Prev) -> "ClFlushOpt" | ClFlush (NoOpt,Next) -> "ClFlushNext" | ClFlush (Opt,Next) -> "ClFlushOptNext" | ClFlush (NoOpt,Other) -> "ClFlushOther" | ClFlush (Opt,Other) -> "ClFlushOptOther" let fold_all_barriers f r = f MFENCE (f SFENCE (f LFENCE r)) let fold_all_fences f r = let r = f (ClFlush (NoOpt,Prev)) (f (ClFlush (Opt,Prev)) r) in let r = f (ClFlush (NoOpt,Next)) (f (ClFlush (Opt,Next)) r) in let r = f (ClFlush (NoOpt,Other)) (f (ClFlush (Opt,Other)) r) in fold_all_barriers (fun b -> f (Fence b)) r let fold_cumul_fences = fold_all_fences let fold_some_fences f r = f default r let orders f d1 d2 = let open Code in match f,d1,d2 with | (Fence MFENCE,_,_) | (Fence SFENCE,W,W) | (Fence LFENCE,R,R) | (ClFlush _,_,_) (* Do not know exactly yet *) -> true | (_,_,_) -> false let var_fence f r = f default r (********) (* Deps *) (********) type dp let pp_dp _ = assert false let fold_dpr _f r = r let fold_dpw _f r = r let ddr_default = None let ddw_default = None let ctrlr_default = None let ctrlw_default = None let is_ctrlr _ = assert false let is_addr _ = assert false let fst_dp _ = assert false let sequence_dp _ _ = assert false (*******) (* RWM *) (*******) include Exch.Exch(struct type arch_atom = atom end) include NoEdge include ArchExtra_gen.Make (struct type arch_reg = reg let is_symbolic = function | Symbolic_reg _ -> true | _ -> false let pp_reg = pp_reg let pp_i _ = assert false let free_registers = allowed_for_symb type special = xmm type special2 type special3 let specials = xmms let specials2 = [] let specials3 = [] end) end herd-herdtools7-1ca343e/gen/X86_64Compile_gen.ml000066400000000000000000000374771475314470400213270ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Code module Make(Cfg:CompileCommon.Config) : XXXCompile_gen.S = struct open MachSize let mach_size = let open TypBase in match Cfg.typ with | Std (_,Quad) -> Quad | Int | Std (_,Word) -> Word | Std (_,Short) -> Short | Std (_,Byte) -> Byte | Std (_,S128) | Pteval -> assert false let size_to_inst_size = let open X86_64Base in function | Byte -> I8b | Short -> I16b | Word -> I32b | Quad -> I64b | S128 -> assert false let size_to_reg_size = let open X86_64Base in function | Byte -> R8bL | Short -> R16b | Word -> R32b | Quad -> R64b | S128 -> assert false let size_reg_part = size_to_reg_size mach_size let size = size_to_inst_size mach_size let naturalsize = TypBase.get_size Cfg.typ module X86_64 = X86_64Arch_gen.Make (struct let naturalsize = naturalsize let fullmixed = Cfg.variant Variant_gen.FullMixed end) include CompileCommon.Make(Cfg)(X86_64) open X86_64 let inst_to_reg_size = function | I8b -> R8bL | I16b -> R16b | I32b | INSb -> R32b | I64b -> R64b (******) let ppo _f k = k (******) let next_reg x = alloc_reg x let mov r i = let r = change_size_reg r size_reg_part in I_EFF_OP (I_MOV, size, Effaddr_rm64 (Rm64_reg r), Operand_immediate i) let mov_mixed sz r i = let sz = size_to_inst_size sz in let r = change_size_reg r (inst_to_reg_size sz) in I_EFF_OP (I_MOV, sz, Effaddr_rm64 (Rm64_reg r), Operand_immediate i) let mov_reg r1 r2 = let r1 = change_size_reg r1 size_reg_part and r2 = change_size_reg r2 size_reg_part in I_EFF_OP (I_MOV, size, Effaddr_rm64 (Rm64_reg r1), Operand_effaddr (Effaddr_rm64 (Rm64_reg r2))) let mov_reg_mixed sz r1 r2 = let sz = size_to_inst_size sz in let r1 = change_size_reg r1 (inst_to_reg_size sz) and r2 = change_size_reg r2 (inst_to_reg_size sz) in I_EFF_OP (I_MOV, sz, Effaddr_rm64 (Rm64_reg r1), Operand_effaddr (Effaddr_rm64 (Rm64_reg r2))) let emit_inc sz r = let r = change_size_reg r (size_to_reg_size sz) in I_EFF (I_INC,size_to_inst_size sz,Effaddr_rm64 (Rm64_reg r)) module Extra = struct let use_symbolic = false type reg = X86_64.reg type instruction = X86_64.pseudo let mov r i = Instruction (mov r i) let mov_mixed sz r i = Instruction (mov_mixed sz r i) let mov_reg r1 r2 = Instruction (mov_reg r1 r2) let mov_reg_mixed sz r1 r2 = Instruction (mov_reg_mixed sz r1 r2) end module U = GenUtils.Make(Cfg)(A)(Extra) let pseudo = List.map (fun i -> X86_64.Instruction i) let emit_store_ins sz _ rB v = I_EFF_OP (I_MOV, sz, Effaddr_rm64 rB, Operand_immediate v) let emit_store_ins_reg sz _ rB rC = I_EFF_OP (I_MOV, sz, Effaddr_rm64 rB, Operand_effaddr (Effaddr_rm64 (Rm64_reg rC))) let emit_store_nti_ins_reg sz o rB rC = I_MOVNTI (sz,Effaddr_rm64 (Rm64_deref (rB,o)),rC) let emit_store_mixed_reg sz o st p init addr rC = let isz = size_to_inst_size sz in let rB,init,st = if o <> 0 then let r,i,s = U.next_init st p init addr in let r = change_size_reg r R64b in Rm64_deref (r,o),i,s else Rm64_abs (ParsedConstant.nameToV addr),init,st in let rC = change_size_reg rC (size_to_reg_size sz) in init,pseudo [emit_store_ins_reg isz o rB rC],st let emit_store_mixed sz o st p init addr v = let isz = size_to_inst_size sz in let rB,init,st = if o <> 0 then let r,i,s = U.next_init st p init addr in let r = change_size_reg r R64b in Rm64_deref (r,o),i,s else Rm64_abs (ParsedConstant.nameToV addr),init,st in let r_opt,init,st = U.emit_const st p init v in match r_opt with | None -> init,pseudo [emit_store_ins isz o rB v],st | Some rC -> let rC = change_size_reg rC (size_to_reg_size sz) in init,pseudo [emit_store_ins_reg isz o rB rC],st let emit_store st p init addr v = emit_store_mixed mach_size 0 st p init addr v let emit_store_nti_mixed sz o st p init addr v = let rA,init,st = U.next_init st p init addr in let rA = change_size_reg rA R64b in let rV,init,cv,st = U.emit_mov st p init v in let rV = change_size_reg rV (size_to_reg_size sz) in init,cv@pseudo [emit_store_nti_ins_reg (size_to_inst_size sz) o rA rV],st let emit_store_nti st p init addr v = emit_store_nti_mixed mach_size 0 st p init addr v let emit_movntdqa_ins xmm rA = I_MOVNTDQA (xmm,Effaddr_rm64 (Rm64_deref (rA,0))) let emit_movd_ins sz r xmm = I_MOVD (sz,r,xmm) let emit_load_nti sz st p init addr = let rA,init,st = U.next_init st p init addr in let r64,st = next_reg st in let r = change_size_reg r64 (size_to_reg_size sz) in let xmm,st = alloc_special st in let c = [emit_movntdqa_ins xmm rA;emit_movd_ins (size_to_inst_size sz) r xmm] in r64,init,pseudo c,st let emit_sta sz addr r v = let rsz = size_to_reg_size sz and isz = size_to_inst_size sz in let r = change_size_reg r rsz in [ I_EFF_OP (I_MOV, isz, Effaddr_rm64 (Rm64_reg r), Operand_immediate v); I_EFF_EFF (I_XCHG, isz, Effaddr_rm64 (Rm64_abs (ParsedConstant.nameToV addr)), Effaddr_rm64 (Rm64_reg r)) ] let emit_sta_mixed sz o st p init addr v = let rsz = size_to_reg_size sz and isz = size_to_inst_size sz in let r_opt,init,st = U.emit_const st p init v in let r64,st = next_reg st in let r = change_size_reg r64 rsz in let imov = match r_opt with | None -> I_EFF_OP (I_MOV, isz, Effaddr_rm64 (Rm64_reg r), Operand_immediate v) | Some rc -> let rc = change_size_reg rc rsz in I_EFF_OP (I_MOV, isz, Effaddr_rm64 (Rm64_reg r), Operand_effaddr (Effaddr_rm64 (Rm64_reg rc))) in let init,iexch,st = match o with | 0 -> let iexch = I_EFF_EFF (I_XCHG, isz, Effaddr_rm64 (Rm64_abs (ParsedConstant.nameToV addr)), Effaddr_rm64 (Rm64_reg r)) in init,iexch,st | _ -> let rbase,init,st = U.next_init st p init addr in let iexch = I_EFF_EFF (I_XCHG, isz, Effaddr_rm64 (Rm64_deref (rbase,o)), Effaddr_rm64 (Rm64_reg r)) in init,iexch,st in r64,init,pseudo [imov;iexch;],st let emit_cmp_zero_ins r = let r = change_size_reg r size_reg_part in I_EFF_OP (I_CMP, size, Effaddr_rm64 (Rm64_reg r), Operand_immediate 0) and emit_cmp_one_ins r = let r = change_size_reg r size_reg_part in I_EFF_OP (I_CMP, size, Effaddr_rm64 (Rm64_reg r), Operand_immediate 1) and emit_cmp_int_ins r i = let r = change_size_reg r size_reg_part in I_EFF_OP (I_CMP, size, Effaddr_rm64 (Rm64_reg r), Operand_immediate i) and emit_je_ins lab = I_JCC (C_EQ,lab) and emit_jne_ins lab = I_JCC (C_NE,lab) let emit_load_ins sz _ rm r = let r = change_size_reg r (inst_to_reg_size (size_to_inst_size sz)) in I_EFF_OP (I_MOV, size_to_inst_size sz, Effaddr_rm64 (Rm64_reg r), Operand_effaddr (Effaddr_rm64 rm)) let emit_load_mixed sz o st p init x = let rA,st = next_reg st in let rB,init,st = if o <> 0 then let r,i,s = U.next_init st p init x in let r = change_size_reg r R64b in Rm64_deref (r,o),i,s else Rm64_abs (ParsedConstant.nameToV x),init,st in rA,init,pseudo [emit_load_ins sz o rB rA],st let emit_load st p init x = emit_load_mixed mach_size 0 st p init x let emit_load_not_zero st _p init x = let rA,st = next_reg st in let rB = Rm64_abs (ParsedConstant.nameToV x) in let lab = Label.next_label "L" in rA,init, Label (lab,Nop):: pseudo [emit_load_ins mach_size 0 rB rA ; emit_cmp_zero_ins rA ; emit_je_ins lab], st let emit_load_one st _p init x = let rA,st = next_reg st in let rB = Rm64_abs (ParsedConstant.nameToV x) in let lab = Label.next_label "L" in rA,init, Label (lab,Nop):: pseudo [emit_load_ins mach_size 0 rB rA ; emit_cmp_one_ins rA ; emit_jne_ins lab], st let emit_load_not _st _p _init _x _cmp = Warn.fatal "Loop observers not implemented for X86_64" let emit_load_not_eq st = emit_load_not st let emit_load_not_value st = emit_load_not st let emit_obs _ = emit_load_mixed naturalsize 0 let emit_obs_not_value = emit_load_not_value let emit_obs_not_eq = emit_load_not_eq let emit_obs_not_zero = emit_load_not_zero let emit_joker st init = None,init,[],st let emit_access st _p init e = match e.C.dir with | None -> Warn.fatal "TODO" | Some d -> begin match e.C.loc with | Data loc -> begin match d with | R -> begin match e.C.atom with | None|Some (Plain,None) -> let r,init,cs,st = emit_load st _p init loc in Some r,init, cs,st | Some (Atomic,_) -> Warn.fatal "No atomic load for X86_64" | Some (Plain,Some (sz, o)) -> let r,init,cs,st = emit_load_mixed sz o st _p init loc in Some r,init,cs,st | Some (NonTemporal,None) -> let r,init,cs,st = emit_load_nti mach_size st _p init loc in Some r,init,cs,st | Some (NonTemporal,Some (sz,0)) -> let r,init,cs,st = emit_load_nti sz st _p init loc in Some r,init,cs,st | Some (NonTemporal,Some _) -> Warn.fatal "Illegal non-temporal load" end | W -> begin match e.C.atom with | None|Some (Plain,None) -> let init,cs,st = emit_store st _p init loc e.C.v in None,init,cs,st | Some (NonTemporal,None) -> let init,cs,st = emit_store_nti st _p init loc e.C.v in None,init,cs,st | Some (Atomic,None) -> let rX,st = next_reg st in Some rX,init,pseudo (emit_sta mach_size loc rX e.C.v), st | Some (NonTemporal,Some (sz,o)) -> let init,cs,st = emit_store_nti_mixed sz o st _p init loc e.C.v in None,init,cs,st | Some (Atomic,Some (sz,o)) -> let r,init,cs,st = emit_sta_mixed sz o st _p init loc e.C.v in Some r,init,cs,st | Some (Plain,Some (sz, o)) -> let init,cs,st = emit_store_mixed sz o st _p init loc e.C.v in None,init,cs,st end | J -> emit_joker st init end | Code _ -> Warn.fatal "No code location for X86_64" end let get_access_exch er ew = let szr = get_access_atom er.C.atom and szw = get_access_atom ew.C.atom in if not (Misc.opt_eq MachMixed.equal szr szw) then Warn.fatal "Exchange instruction with different accesses" ; szw let emit_exch st p init er ew = let loc = Code.as_data er.C.loc in let v = ew.C.v in match get_access_exch er ew with | None -> let rA,st = next_reg st in rA,init, pseudo (emit_sta mach_size loc rA v), st | Some (sz,o) -> emit_sta_mixed sz o st p init loc v let emit_rmw () st p init er ew = let rR,init,cs,st = emit_exch st p init er ew in Some rR,init,cs,st let emit_access_dep _st _p _init _e _r1 = Warn.fatal "Dependent access is irrelevant for X86_64" let emit_exch_dep _st = Warn.fatal "Dependent access is irrelevant for X86_64" let emit_rmw_dep () _n = emit_exch_dep let emit_fence st p init n f = match f with | Fence b -> init,[X86_64.Instruction (I_FENCE b)],st | ClFlush (opt,line) -> let addr,st = match line with | Other -> A.next_addr st | _ -> let node_loc = match line with | Prev -> n | Next -> n.C.next | Other -> assert false in match node_loc.C.evt.C.loc with | Data addr -> addr,st | Code _ -> Warn.user_error "ClFlush not allowed on code location" in let ea,init,st = match n.C.edge.E.a1 with | Some (NonTemporal,_) -> let r,init,st = U.next_init st p init addr in Rm64_deref (r,0),init,st | _ -> Rm64_abs (ParsedConstant.nameToV addr),init,st in let cs = [X86_64.Instruction (I_CLFLUSH (opt,Effaddr_rm64 ea))] in init,cs,st let emit_fence_dp st a init b f _ r _ = let init,cs,st = emit_fence st a init b f in Some r,init,cs,st let stronger_fence = Fence MFENCE (* Check load *) let do_check_load p st r e = let ok,st = A.ok_reg st in (fun k -> Instruction (emit_cmp_int_ins r e.C.v):: Instruction (emit_jne_ins (Label.last p)):: Instruction (emit_inc Word ok):: k), A.next_ok st let check_load p r e init st = let cs,st = do_check_load p st r e in init,cs,st (* Postlude *) let postlude = mk_postlude (fun st p init loc r -> emit_store_mixed_reg Word 0 st p init loc r) let get_xstore_results _ = [] (* Info computation, compute extra alignement constraints *) let add_info n k = let e = n.C.evt in match e.C.loc,e.C.dir,e.C.atom with | Data x,Some R,Some (NonTemporal,_) -> let v = try let old = StringMap.find x k in max 16 old with Not_found -> 16 in StringMap.add x v k | _,_,_ -> k let get_archinfo n = let i = C.fold add_info n StringMap.empty in if StringMap.is_empty i then [] else let i = StringMap.fold (fun x a k -> Printf.sprintf "%s:%i" x a::k) i [] in ["Align",String.concat "," i;] end herd-herdtools7-1ca343e/gen/XXXCompile_gen.mli000066400000000000000000000064131475314470400212530ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module type S = sig include CompileCommon.S val ppo : (R.relax -> 'a -> 'a) -> 'a -> 'a (* Accesses *) val emit_load : A.st -> Code.proc -> A.init -> string -> A.reg * A.init * A.pseudo list * A.st (* Load for observation *) val emit_obs : A.SIMD.atom Code.bank -> A.st -> Code.proc -> A.init -> string -> A.reg * A.init * A.pseudo list * A.st val emit_obs_not_zero : A.st -> Code.proc -> A.init -> string -> A.reg * A.init * A.pseudo list * A.st val emit_load_one : A.st -> Code.proc -> A.init -> string -> A.reg * A.init * A.pseudo list * A.st val emit_obs_not_eq : A.st -> Code.proc -> A.init -> string -> A.reg -> A.reg * A.init * A.pseudo list * A.st val emit_obs_not_value : A.st -> Code.proc -> A.init -> string -> int -> A.reg * A.init * A.pseudo list * A.st val emit_access : A.st -> Code.proc -> A.init -> C.event -> A.reg option * A.init * A.pseudo list * A.st val emit_rmw : A.rmw -> A.st -> Code.proc -> A.init -> C.event -> C.event -> A.reg option * A.init * A.pseudo list * A.st val emit_access_dep : A.st -> Code.proc -> A.init -> C.event -> A.dp -> A.reg -> C.node -> A.reg option * A.init * A.pseudo list * A.st val emit_rmw_dep : A.rmw -> A.st -> Code.proc -> A.init -> C.event -> C.event -> A.dp -> A.reg -> C.node -> A.reg option * A.init * A.pseudo list * A.st (* Fences *) val emit_fence : A.st -> Code.proc -> A.init -> C.node -> A.fence -> A.init * A.pseudo list * A.st val emit_fence_dp : A.st -> Code.proc -> A.init -> C.node -> A.fence -> A.dp -> A.reg -> C.node -> A.reg option * A.init * A.pseudo list * A.st val stronger_fence : A.fence (* Code additions *) val check_load : Code.proc -> A.reg -> C.event -> A.init -> A.st -> A.init * (A.pseudo list -> A.pseudo list) * A.st val postlude : A.st -> Code.proc -> A.init -> A.pseudo list -> A.init * A.pseudo list * A.st val get_xstore_results : A.pseudo list -> (A.reg * int) list (* Info from events *) val get_archinfo : C.node -> (string * string) list end herd-herdtools7-1ca343e/gen/alt.ml000066400000000000000000000606451475314470400170400ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Printf open Code module type AltConfig = sig include DumpAll.Config val upto : bool val max_ins : int val mix : bool val max_relax : int val min_relax : int val choice : check type relax val prefix : relax list list val variant : Variant_gen.t -> bool type fence val cumul : fence list Config.cumul end module Make(C:Builder.S) (O:AltConfig with type relax = C.R.relax and type fence = C.A.fence) : sig val gen : ?relax:C.R.relax list -> ?safe:C.R.relax list -> ?reject:C.R.relax list -> int -> unit end = struct let mixed = Variant_gen.is_mixed O.variant let do_kvm = Variant_gen.is_kvm O.variant module D = DumpAll.Make(O) (C) open C.E open C.R let dbg = false module RelaxSet = C.R.Set let is_int e = match get_ie e with | Int -> true | Ext -> false let is_ext e = not (is_int e) let equal_fence f1 f2 = C.A.compare_fence f1 f2 = 0 let is_cumul = let open Config in match O.cumul with | Empty -> (fun _ -> false) | All -> (fun _ -> true) | Set fs -> (fun f -> List.exists (equal_fence f) fs) let choice_sc po_safe e1 e2 = let r = match e1.edge,e2.edge with (* Now accept internal with internal composition when the do not match safe, explicit po candidates. A bit rude, maybe... Also notice that we are more tolerant for Rfi. *) (* Assuming Dp is safe *) | Rf Int,Dp _ | Dp _,Rf Int -> true | Dp (_,sd,_),Ws Int | Dp (_,sd,_),Fr Int -> not (po_safe sd (dir_src e1) (dir_tgt e2)) | Po (sd1,_,_), Dp (_,sd2,_) -> not (po_safe sd1 (dir_src e1) (dir_tgt e1)) && not (po_safe (seq_sd sd1 sd2) (dir_src e1) (dir_tgt e2)) | Dp (_,sd1,_),Po (sd2,_,_) -> not (po_safe sd2 (dir_src e2) (dir_tgt e2)) && not (po_safe (seq_sd sd1 sd2) (dir_src e1) (dir_tgt e2)) (* Check Po is safe *) | Po (sd1,_,_),Po (sd2,_,_) -> not (po_safe (seq_sd sd1 sd2) (dir_src e1) (dir_tgt e2)) | Rf Int,Po (sd,_,_) -> po_safe sd (dir_src e2) (dir_tgt e2) && not (po_safe sd (dir_src e1) (dir_tgt e2)) | Po (sd,_,_),Rf Int -> po_safe sd (dir_src e1) (dir_tgt e1) && not (po_safe sd (dir_src e1) (dir_tgt e2)) (* Allow Rmw *) | (Rmw _,_)|(_,Rmw _) -> true (* Added *) | _,_ -> match get_ie e1, get_ie e2 with | Int,Int -> false | Ext,_|_,Ext -> true in if dbg then eprintf "Choice: %s %s -> %b\n%!" (C.E.pp_edge e1) (C.E.pp_edge e2) r ; r let choice_default e1 e2 = let r = match e1.edge,e2.edge with (* Now accept some internal with internal composition *) | (Ws Int|Rf Int|Fr Int|Insert _),(Dp (_,_,_)|Po (Diff,_,_)) | (Dp (_,_,_)|Po (Diff,_,_)),(Ws Int|Rf Int|Fr Int|Insert _) | Dp (_,Diff,_),Po (Diff,_,_) | Po (Diff,_,_),Dp (_,Diff,_) | Rf Int,Po (Same,_,_) | Po (Same,_,_),Rf Int | (Rmw _,_)|(_,Rmw _) -> true | _,_ -> (* Reject other internal followed by internal sequences *) match get_ie e1, get_ie e2 with | Int,Int -> false | Ext,_|_,Ext -> true in if dbg then eprintf "Choice: %s %s -> %b\n%!" (C.E.pp_edge e1) (C.E.pp_edge e2) r ; r (* Check altenance of com/po *) let choice_critical e1 e2 = let r = match e1.edge,e2.edge with (* Two cases of allowed com composition *) | (Ws _|Leave CWs|Back CWs|Fr _|Leave CFr|Back CFr), (Rf _|Leave CRf|Back CRf) -> true (* Rmw allowed to compose arbitrarily *) | (Rmw _,_)|(_,Rmw _) -> true (* Otherwise require alternance *) | _,_ -> C.E.get_ie e1 <> C.E.get_ie e2 in (* eprintf "Choice: %s %s -> %b\n" (C.E.pp_edge e1) (C.E.pp_edge e2) r ; *) r let choice_mixed e1 e2 = let r = match e1.edge,e2.edge with (* Two cases of allowed com composition *) | (Ws _|Leave CWs|Back CWs|Fr _|Leave CFr|Back CFr), (Rf _|Leave CRf|Back CRf) -> true (* Rmw allowed to compose arbitrarily *) | (Rmw _,_)|(_,Rmw _) -> true (* Otherwise accept composition *) | _,_ -> let ie1 = C.E.get_ie e1 and ie2 = C.E.get_ie e2 in match ie1,ie2 with | Int,Int -> begin match loc_sd e1,loc_sd e2 with | (Same,Same) | (Diff,Same) | (Same,Diff) -> true | Diff,Diff -> false end | Ext,Ext -> false | (Ext,Int) | (Int,Ext) -> true in (* eprintf "Choice: %s %s -> %b\n" (C.E.pp_edge e1) (C.E.pp_edge e2) r ; *) r let choice_uni e1 e2 = match e1.edge,e2.edge with | (Ws _,Ws _) | (Fr _,Ws _) | (Rf _,Fr _) | (Rf _,Hat) | (Hat,Fr _) -> C.E.get_ie e1 <> C.E.get_ie e2 (* Allow alternance *) | Po _,Po _ -> false | _,_ -> true let choice_id _ _ = true let choice_free e1 e2 = match e1.edge,e2.edge with | (Ws _,Ws _) | (Fr _,Ws _) | (Rf _,Fr _) -> false | _,_ -> true let choice_free_alt e1 e2 = match e1.edge,e2.edge with | (Ws _,Ws _) | (Fr _,Ws _) | (Rf _,Fr _) -> C.E.get_ie e1 <> C.E.get_ie e2 (* Allow alternance *) | _,_ -> true let choice_ppo e1 e2 = choice_free e1 e2 && C.E.compare e1 e2 <> 0 && (match e1.edge with | Dp (dp,_,Dir R) when C.A.is_ctrlr dp -> is_ext e2 | _ -> true) let choice_transitive safes xs ys e1 e2 = choice_free_alt e1 e2 && begin match C.E.get_ie e1, C.E.get_ie e2 with | Int,Int -> let cs = C.E.compact_sequence xs ys e1 e2 in if O.verbose > 0 then eprintf "COMPACT %s,%s -> [%s] -> " (C.E.pp_edge e1) (C.E.pp_edge e2) (String.concat "," (List.map (fun es -> C.R.pp_relax (C.R.ERS es)) cs)) ; let r = not (List.exists (fun es -> C.R.Set.mem (C.R.ERS es) safes) cs) in if O.verbose > 0 then eprintf "%b\n" r ; r | _,_ -> true end let iarg f = fun _ _ _ _ -> f let choose c = match c with | Sc -> fun _safes po_safe _xs _ys -> choice_sc po_safe | Default -> iarg choice_default | MixedCheck -> iarg choice_mixed | Critical -> iarg choice_critical | Uni -> iarg choice_uni | Thin |Total -> iarg choice_id | Free -> iarg choice_free_alt | Ppo -> iarg choice_ppo | Transitive -> (fun safes _po_safe -> choice_transitive safes) let compat_id ao d = match ao,d with | (None,_)|(_,(Irr|NoDir)) -> true | Some a,(Dir d) -> C.A.applies_atom a d let pair_ok safes po_safe xs ys e1 e2 = match e1.edge,e2.edge with (* First reject some of hb' ; hb' *) | Hat,Hat (* Hat *) (* Ext Ext Only? *) | Ws _,Ws _ (* -> Ws *) | Fr _,Ws _ (* -> Fr*) | Rf _,Fr _ (* -> Ws *) (* Rf _,Fr _ (* -> Ws *) May be interesting, because values are observed by outcome itself, also useful to add Fre after B-cumulativity *) -> C.E.get_ie e1 <> C.E.get_ie e2 (* Allow alternance *) | Id,Id -> false | Id,_ -> compat_id e1.a2 (dir_src e2) | _,Id -> compat_id e2.a1 (dir_tgt e1) (* Fence cumulativity *) | Rf _,Fenced (f,_,_,_) | Fenced (f,_,_,_),Rf _ -> is_cumul f && choose O.choice safes po_safe xs ys e1 e2 | _,_ -> choose O.choice safes po_safe xs ys e1 e2 let check_mixed = if mixed then fun e1 e2 -> match e1.edge,e2.edge with | Id,Id -> false | (_,Id)|(Id,_) -> true | _,_ -> false else fun _ _ -> true let rec hd_non_insert = function | [] -> assert false | [x] -> x | x::xs -> if C.E.is_insert_store x.C.E.edge then hd_non_insert xs else x let last_non_insert xs = hd_non_insert (List.rev xs) let do_compat safes po_safe xs ys = let x = Misc.last xs and y = List.hd ys in let r = C.E.can_precede x y && check_mixed x y && pair_ok safes po_safe xs ys x y && begin if do_kvm then C.E.can_precede (hd_non_insert xs) (last_non_insert ys) else true end in if O.verbose > 2 then begin eprintf "do_compat '%s' '%s' = %b\n" (C.E.pp_edges xs) (C.E.pp_edges ys) r end ; r let can_precede safes po_safe (_,xs) k = match k with | [] -> true | (_,ys)::_ -> do_compat safes po_safe xs ys && begin match k with | (_,[{edge=Id;_}])::(_,y::_)::_ when mixed -> let x = Misc.last xs in C.E.can_precede x y | _ -> true end let pp_ess ess = String.concat " " (List.fold_right (fun (_,es) -> List.fold_right (fun e k -> pp_edge e::k) es) ess []) let edges_ofs rs = List.map (fun r -> (r, edges_of r)) rs (* Functional for recursive call of generators *) let sz (_,es) = if List.for_all (fun e -> is_id e.edge) es then 0 else 1 let rec c_minprocs_es c = function | [] -> c | e::es -> let c = match e.C.E.edge with | Back _|Leave _ -> c | _ -> match get_ie e with | Int -> c | Ext -> c+1 in c_minprocs_es c es let rec c_minprocs_suff c = function | [] -> c | (_,es)::suff -> c_minprocs_suff (c_minprocs_es c es) suff let minprocs suff = let r = c_minprocs_suff 0 suff in if O.verbose > 3 then eprintf "MIN [%s] => %i\n" (pp_ess suff) r ; r let rec c_minint_es c = function | [] -> false,c | {edge=Id; _}::es -> c_minint_es c es | e::es -> match get_ie e with | Ext -> true,c | Int -> c_minint_es (c+1) es let rec c_minint c = function | [] -> c | (_,es)::suff -> let stop,c = c_minint_es c es in if stop then c else c_minint c suff let minint suff = c_minint 0 suff (* Prefix *) let prefix_expanded = List.flatten (List.map C.R.expand_relax_seq O.prefix) let () = if O.verbose > 0 && O.prefix <> [] then begin eprintf "Prefixes:\n" ; List.iter (fun rs -> eprintf " %s\n" (C.R.pp_relax_list rs)) prefix_expanded end let prefixes = List.map edges_ofs prefix_expanded let rec mk_can_prefix = function | [] -> (fun _ _ -> true) | [x] -> (fun p -> p x) | _::xs -> mk_can_prefix xs let can_prefix prefix = mk_can_prefix prefix let rec is_prefix l rl = match rl,l with | hrl::trl, hl::tl -> if hl = hrl then is_prefix tl trl else false | [], _ -> true (* end of rl before or at the end of l *) | _, [] -> false (* end of l before end of rl*) let check_cycle rsuff rl = let rsuff = List.map (fun (_,rr) -> rr) rsuff in let rsuff = List.concat rsuff in not (List.exists (fun rl -> is_prefix rsuff rl) rl) let call_rec prefix f0 safes po_safe over n r suff f_rec k ?(reject=[])= if can_precede safes po_safe r suff && minprocs suff <= O.nprocs && minint (r::suff) <= O.max_ins-1 && check_cycle (r::suff) reject then let suff = r::suff and n = n-sz r in if O.verbose > 2 then eprintf "CALL: %i %s\n%!" n (pp_ess suff) ; let k = if over && (n = 0 || (n > 0 && O.upto)) && can_prefix prefix (can_precede safes po_safe) suff then begin let tr = prefix@suff in (* eprintf "TRY: '%s'\n" (C.E.pp_edges (List.flatten (List.map snd tr))) ; *) try f0 po_safe tr k with Misc.Exit -> k | Misc.Fatal msg |Misc.UserError msg -> eprintf "Marche pas: '%s'\n" msg ; k | e -> eprintf "Exc in F0: '%s'\n" (Printexc.to_string e) ; raise e end else k in if n <= 0 then k else f_rec n suff k else k module SdDir2Set = MySet.Make (struct type t = sd * extr * extr let compare = Misc.polymorphic_compare end) let extract_po rs = match O.choice with | Sc -> let d2 = List.fold_right (fun (r,_) k -> match r with | ERS [{edge=Po (sd,e1,e2); _}] -> SdDir2Set.add (sd,e1,e2) k | _ -> k) rs SdDir2Set.empty in if dbg then eprintf "PoSafe: {%s}\n" (SdDir2Set.pp_str "," (fun (sd,e1,e2) -> pp_sd sd ^ "-" ^ pp_extr e1 ^ "-" ^ pp_extr e2) d2) ; fun sd e1 e2 -> SdDir2Set.mem (sd,e1,e2) d2 | m -> fun _ _ _ -> eprintf "Function po_safe called in mode %s\n%!" (pp_check m) ; assert false let zyva prefix aset relax safe reject n f = (* let safes = C.R.Set.of_list safe in *) let relax = edges_ofs relax in let safe = edges_ofs safe in let po_safe = extract_po safe in let rec choose_relax rs k = match rs with | [] -> k | r0::rs -> (* Build simple cycles for relaxation r0 *) let call_rec = call_rec prefix (f [fst r0]) aset po_safe ~reject:reject in (* Add a safe edge to suffix *) let rec add_safe over ss n suf k = match ss with | [] -> k | s::ss -> let k = call_rec over n s suf (add_relaxs over) k in add_safe over ss n suf k (* Add some relax edges r0 to suffix, or nothing *) and add_relaxs over n suf k = let k = call_rec true n r0 suf (add_relaxs true) k in add_safe over safe n suf k in match prefix with | [] -> (* Optimise: start with a relax edge r0 *) let k = call_rec true n r0 [] (add_relaxs true) k in choose_relax rs k | _::_ -> let k = add_relaxs false n [] k in choose_relax rs k in (* Alternative: mix relaxation from relax list *) let all_relax k = let relax_set = RelaxSet.of_list (List.map fst relax) in let extract_relaxs suff = let suff_set = RelaxSet.of_list (List.map fst suff) in RelaxSet.elements (RelaxSet.inter suff_set relax_set) in let call_rec = call_rec prefix (fun po_safe suff k -> let rs = extract_relaxs suff in let nrs = List.length rs in if nrs > O.max_relax || nrs < O.min_relax then k else f rs po_safe suff k) aset po_safe ~reject:reject in (* Add a one edge to suffix *) let rec add_one over rs ss n suf k = match rs,ss with | [],[] -> k | [],s::ss -> let k = call_rec over n s suf (add_one over relax safe) k in add_one over rs ss n suf k | r::rs,_ -> let k = call_rec true n r suf (add_one true relax safe) k in add_one over rs ss n suf k in (* Force first edge to be a relaxed one *) let rec add_first rs k = match rs with | [] -> k | r::rs -> let k = call_rec true n r [] (add_one true relax safe) k in add_first rs k in match prefix with | [] -> add_first relax k | _::_ -> add_one false relax safe n [] k in (* New relax that does not enforce the first edge to be a relax *) (* As a safety check, generate cycles with no relaxation *) let call_rec = call_rec prefix (f []) aset po_safe ~reject:reject in let rec no_relax ss n suf k = match ss with | [] -> k | s::ss -> let k = call_rec true n s suf (no_relax safe) k in no_relax ss n suf k in fun k -> match relax with | [] -> no_relax safe n [] k | _ -> if O.mix && O.max_relax < 1 then k (* Let us stay logical *) else if O.mix && O.max_relax > 1 then all_relax k else choose_relax relax k let rec all_int l = match l with | [] -> true | a::s -> (is_int a)&&(all_int s) let rec count_e ce = function | [] -> ce | e::es -> count_e (if is_int e then ce else ce+1) es let count_ext es = count_e 0 es let change_loc e = match loc_sd e with | Same -> false | Diff -> true let count_p p = let rec do_rec c = function | [] -> c | x::xs -> do_rec (if p x then c+1 else c) xs in do_rec 0 let count_changes = count_p change_loc let build_safe r0 es = let rs = List.fold_right (fun (r,_) -> RelaxSet.add r) es RelaxSet.empty in let rs = RelaxSet.diff rs (RelaxSet.of_list r0) in RelaxSet.elements rs exception Result of bool (* Is xs a prefix of s@p ? *) let prefix_spanp xs (p,s) = let rec is_prefix xs ys = match xs,ys with | [],_ -> raise (Result true) | _::_,[] -> xs (* xs -> what is still to be matched *) | x::xs,y::ys -> if C.E.compare x y = 0 then is_prefix xs ys else raise (Result false) in try let xs = is_prefix xs s in match is_prefix xs p with | [] -> true (* xs and s@p are equal! *) | _::_ -> false (* xs larger.. *) with Result b -> b let substring_spanp rej pss = List.exists (fun xs -> List.exists (fun ps -> prefix_spanp xs ps) pss) rej let last_check_call rej aset f rs po_safe res k = match res with | [] -> k | _ -> let lst = Misc.last res in if can_precede aset po_safe lst res then let es = List.map snd res in let le = List.flatten es in try if (match O.choice with | Default| Sc | Ppo | MixedCheck -> true | Thin | Free | Uni | Critical | Transitive |Total -> false) && (count_ext le=1 || all_int le || count_changes le < 2) then k else begin let ok = (* Check for rejected sequenes that span over cycle "cut" *) let rej = (* Keep non-trivial edge sequences only *) List.filter (function | []|[_] -> false | _::_::_ -> true) rej in match rej with | [] -> true | _::_ -> let max_sz = List.fold_left (fun k xs -> max k (List.length xs)) 0 rej in let pss = Misc.cuts max_sz le in not (substring_spanp rej pss) in if ok then let mk_info _es = let ss = build_safe rs res in let info = [ "Relax",pp_relax_list rs; "Safe", pp_relax_list ss; ] in info,C.R.Set.of_list rs in f le mk_info D.no_name D.no_scope k else k end with (Normaliser.CannotNormalise _) -> k else k let rec prefixp xs ys = match xs,ys with | [],_ -> true | _::_,[] -> raise Exit | x::xs,y::ys -> C.E.compare x y = 0 && prefixp xs ys let rec sublistp xs ys = match ys with | [] -> false | _::rem -> prefixp xs ys || sublistp xs rem let substringp xs ys = try sublistp xs ys with Exit -> match xs with | []|[_] -> false | _::_::_ -> let pss = Misc.cuts (List.length xs) ys in List.exists (fun ps -> prefix_spanp xs ps) pss let last_minute rej ess = not (List.exists (fun es -> List.length es > O.max_ins) ess) && begin match rej with | _::_ -> let es = List.flatten ess in not (List.exists (fun xs -> substringp xs es) rej) | [] -> true end let rec zyva_prefix prefixes aset relax safe reject n f k = match prefixes with | [] -> k | pref::rem -> zyva pref aset relax safe reject n f (zyva_prefix rem aset relax safe reject n f k ) let do_gen relax safe rej n = let sset = C.R.Set.of_list safe in let rset = C.R.Set.of_list relax in let aset = C.R.Set.union sset rset in let rej = List.map (fun a -> edges_of a) rej in D.all ~check:(last_minute rej) (fun f -> zyva_prefix prefixes aset relax safe rej n (last_check_call rej aset f)) let debug_rs chan rs = List.iter (fun r -> fprintf chan "%s\n" (pp_relax r)) rs let secret_gen relax safe reject n = let r_nempty = Misc.consp relax in let relax = expand_relaxs C.ppo relax and safe = expand_relaxs C.ppo safe and reject = expand_relaxs C.ppo reject in if Misc.nilp relax then if r_nempty then begin Warn.fatal "relaxations provided in relaxlist could not be used to generate cycles" end ; if O.verbose > 0 then begin eprintf "** Relax0 **\n" ; debug_rs stderr relax ; eprintf "** Safe0 **\n" ; debug_rs stderr safe end ; let relax_set = C.R.Set.of_list relax and safe_set = C.R.Set.of_list safe in let relax = C.R.Set.elements relax_set and safe = C.R.Set.elements (C.R.Set.diff safe_set relax_set) (* and reject = C.R.Set.elements reject_set *)in if O.verbose > 0 then begin eprintf "** Relax **\n" ; debug_rs stderr relax ; eprintf "** Safe **\n" ; debug_rs stderr safe end ; do_gen relax safe reject n (**********************) (* Default edge lists *) (**********************) let fold_ie f k = f (Int) (f (Ext) k) let fold_dir f k = f Irr k (* expand later ! *) let fold_dir2 f = fold_dir (fun i1 k -> fold_dir (f i1) k) let fold_sd f k = f (Same) (f Diff k) let fold_sd_dir2 f = fold_sd (fun sd -> fold_dir2 (fun d1 d2 -> f sd d1 d2)) let fold_all_fences f = fold_sd_dir2 (fun sd d1 d2 -> C.A.fold_all_fences (fun fe -> f fe sd d1 d2)) let fold_cumul_fences f = fold_sd_dir2 (fun sd d1 d2 -> C.A.fold_cumul_fences (fun fe -> f fe sd d1 d2)) let fold_cum f = fold_cumul_fences f let er e = ERS [plain_edge e] let safe = let k = [] in let k = fold_ie (fun ie k -> er (Ws ie)::er (Fr ie)::k) k in k let relax = let k = [] in let k = fold_dir2 (fun d1 d2 k -> er (Po (Diff, d1, d2))::k) k in let k = er (Po (Same, Dir R, Dir R))::k in let k = fold_all_fences (fun fe sd d1 d2 k -> er (Fenced (fe,sd,d1,d2))::k) k in let k = C.A.fold_dpr (fun dp k -> fold_sd (fun sd k -> er (Dp(dp,sd,Dir R))::k) k) k in let k = C.A.fold_dpw (fun dp k -> fold_sd (fun sd k -> er (Dp(dp,sd,Dir W))::k) k) k in let k = fold_ie (fun ie k -> er (Rf ie)::k) k in let k = fold_cum (fun fe sd d1 d2 k -> ac_fence fe sd d1 d2::k) k in let k = fold_cum (fun fe sd d1 d2 k -> bc_fence fe sd d1 d2::k) k in let k = er (Hat)::k in k let gen ?(relax=relax) ?(safe=safe) ?(reject=[]) n = try secret_gen relax safe reject n with e -> eprintf "Exc: '%s'\n" (Printexc.to_string e) ; raise e end herd-herdtools7-1ca343e/gen/annot.ml000066400000000000000000000055631475314470400173750ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Annotation specification parser *) module Make(O:LexUtils.Config) = struct module Lexer = ModelLexer.Make(O) open ModelParser let error () = raise Parsing.Parse_error let do_parse lex lexbuf = let rec annot_list_rec = function | TAG t|VAR t -> begin match lex lexbuf with | COMMA -> t::annot_list_rec (lex lexbuf) | RACC -> [t] | _ -> error () end | _-> error () in let annot_list = function | RACC -> [] | tok -> annot_list_rec tok in let rec annot_list_list_rec = function | LACC -> let ts = StringSet.of_list (annot_list (lex lexbuf)) in begin match lex lexbuf with | COMMA -> ts::annot_list_list_rec (lex lexbuf) | RBRAC -> [ts] | _ -> error () end | _ -> error () in (* Forbid empty annotation specification *) let annot_list_list tok = annot_list_list_rec tok in let rec event_dec = function | VAR n -> if StringSet.mem n BellName.all_sets then match lex lexbuf with | LBRAC -> let ts = annot_list_list (lex lexbuf) in (n,ts)::event_dec (lex lexbuf) | _ -> error () else error () | EOF -> [] | _ -> error () in event_dec (lex lexbuf) let parse_one s m = let to_add = GenParserUtils.call_parser "_none_" (Lexing.from_string s) Lexer.token do_parse in List.fold_right (fun (n,al) -> BellModel.add_event_dec n al) to_add m let parse lines = List.fold_right parse_one lines BellModel.event_decs_empty end herd-herdtools7-1ca343e/gen/annot.mli000066400000000000000000000024621475314470400175410ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Annotation specification parser *) module Make : functor (O:LexUtils.Config) -> sig val parse : string list -> BellModel.event_decs end herd-herdtools7-1ca343e/gen/archExtra_gen.ml000066400000000000000000000213101475314470400210140ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Printf module type I = sig type arch_reg val is_symbolic : arch_reg -> bool val pp_reg : arch_reg -> string val free_registers : arch_reg list type special type special2 type special3 val specials : special list val specials2 : special2 list val specials3 : special3 list val pp_i : int -> string end module type S = sig type arch_reg (* Locations *) type location = | Reg of Code.proc * arch_reg | Loc of string val of_loc : Code.loc -> location val of_reg : Code.proc -> arch_reg -> location val pp_i : int -> string val pp_location : location -> string val pp_location_brk : location -> string val location_compare : location -> location -> int module LocSet : MySet.S with type elt = location module LocMap : MyMap.S with type key = location (* Initial states *) type initval = S of string | P of AArch64PteVal.t val pp_initval : initval -> string val initval_eq : initval -> initval -> bool type init = (location * initval option) list (* complete init with necessary information *) val complete_init : bool (* hexa *) -> Code.env -> init -> init (***********************) (* Register allocation *) (***********************) type st val debug_env : st -> string val st0 : st val alloc_reg : st -> arch_reg * st val alloc_trashed_reg : string -> st -> arch_reg * st val alloc_loop_idx : string -> st -> arch_reg * st type special type special2 type special3 val alloc_special : st -> special * st val alloc_special2 : st -> special2 * st val alloc_special3 : st -> special3 * st val set_friends : arch_reg -> arch_reg list -> st -> st val get_friends : st -> arch_reg -> arch_reg list val ok_reg : st -> arch_reg * st val next_ok : st -> st val get_noks : st -> int val add_type : location -> TypBase.t -> st -> st val get_env : st -> TypBase.t LocMap.t val next_addr : st -> string * st end module Make(I:I) : S with type arch_reg = I.arch_reg and type special = I.special and type special2 = I.special2 and type special3 = I.special3 = struct type arch_reg = I.arch_reg type location = | Reg of int * arch_reg | Loc of string let pp_symbol loc = match Misc.tr_pte loc with | Some s -> Misc.pp_pte s | None -> loc let pp_location = function | Reg (i,r) -> if I.is_symbolic r then I.pp_reg r else sprintf "%i:%s" i (I.pp_reg r) | Loc loc -> pp_symbol loc let pp_location_brk = function | Reg (i,r) -> if I.is_symbolic r then I.pp_reg r else sprintf "%i:%s" i (I.pp_reg r) | Loc loc -> sprintf "[%s]" (pp_symbol loc) let pp_i = I.pp_i let location_compare loc1 loc2 = match loc1,loc2 with | Reg _,Loc _ -> -1 | Loc _,Reg _ -> 1 | Reg (p1,r1),Reg (p2,r2) -> begin match Misc.int_compare p1 p2 with | 0 -> compare r1 r2 | r -> r end | Loc loc1,Loc loc2 -> compare loc1 loc2 module LocOrd = struct type t = location let compare = location_compare end module LocSet = MySet.Make(LocOrd) module LocMap = MyMap.Make(LocOrd) let of_loc loc = Loc (Code.as_data loc) let of_reg p r = Reg (p,r) type initval = S of string | P of AArch64PteVal.t let pp_initval = function | S v -> pp_symbol v | P p -> AArch64PteVal.pp_v p let initval_eq v1 v2 = match v1,v2 with | S s1,S s2 -> Misc.string_eq s1 s2 | P p1,P p2 -> AArch64PteVal.compare p1 p2 = 0 | (S _,P _)|(P _,S _) -> false type init = (location * initval option) list let as_virtual s = match Misc.tr_pte s with | Some _ -> None | None -> if LexScan.is_num s then None else Some s let refers_virtual s = match Misc.tr_pte s with | Some _ as r -> r | None -> match Misc.tr_physical s with | Some _ as r -> r | None -> None let add_some x xs = match x with | None -> xs | Some x -> StringSet.add x xs let ppo = function | None -> "-" | Some v -> pp_initval v let _pp_env env = String.concat ", " (List.map (fun (loc,v) -> pp_location loc ^ "->" ^ ppo v) env) let complete_init hexa iv i = let i = List.fold_left (fun env (loc,v) -> (Loc loc,Some (S (Code.pp_v ~hexa:hexa v)))::env) i iv in let already_here = List.fold_left (fun k (loc,v) -> let k = match loc with | Loc s -> add_some (as_virtual s) k | Reg _ -> k in let k = match v with | Some (S s) -> add_some (as_virtual s) k | _ -> k in k) StringSet.empty i in let refer = List.fold_left (fun k (loc,v) -> let k = match loc with | Loc s -> add_some (refers_virtual s) k | Reg _ -> k in let k = match v with | Some (S s) -> add_some (refers_virtual s) k | Some (P p) -> add_some (OutputAddress.refers_virtual p.AArch64PteVal.oa) k | None -> k in k) StringSet.empty i in let i = StringSet.fold (fun x i -> (Loc x,None)::i) (StringSet.diff refer already_here) i in i module RegMap = MyMap.Make (struct type t = I.arch_reg let compare = compare end) type st = { regs : arch_reg list ; map : arch_reg StringMap.t ; specials : I.special list ; specials2 : I.special2 list ; specials3 : I.special3 list ; noks : int ; env : TypBase.t LocMap.t ; (* Record types *) (* Group special registers together *) friends : arch_reg list RegMap.t; (* For fresh addresses *) next_addr : int; } let debug_env st = LocMap.pp_str (fun loc t -> sprintf "%s->%s" (pp_location loc) (TypBase.pp t)) st.env let st0 = { regs = I.free_registers; map = StringMap.empty; specials = I.specials; specials2 = I.specials2; specials3 = I.specials3; noks = 0; env = LocMap.empty; friends = RegMap.empty; next_addr = 0; } let alloc_reg st = match st.regs with | [] -> Warn.fatal "No more registers" | r::rs -> r,{ st with regs = rs; } let alloc_last_reg st = match st.regs with | [] -> Warn.fatal "No more registers" | r::rs -> let r,rs = Misc.pop_last r rs in r,{ st with regs = rs; } let do_alloc_trashed_reg alloc k st = try let r = StringMap.find k st.map in r,st with Not_found -> let r,st = alloc st in r,{ st with map = StringMap.add k r st.map; } let alloc_trashed_reg k st = do_alloc_trashed_reg alloc_reg k st and alloc_loop_idx k st = do_alloc_trashed_reg alloc_last_reg k st type special = I.special type special2 = I.special2 type special3 = I.special3 let alloc_special st = match st.specials with | [] -> Warn.fatal "No more special registers" | r::rs -> r,{ st with specials = rs; } let alloc_special2 st = match st.specials2 with | [] -> Warn.fatal "No more special registers" | r::rs -> r,{ st with specials2 = rs; } let alloc_special3 st = match st.specials3 with | [] -> Warn.fatal "No more special registers" | r::rs -> r,{ st with specials3 = rs; } let set_friends r rs st = let friends = RegMap.add r rs st.friends in { st with friends; } let get_friends st r = RegMap.safe_find [] r st.friends let ok_reg st = alloc_trashed_reg "ok" st let next_ok st = { st with noks = st.noks+1; } let get_noks st = st.noks let add_type loc t st = { st with env = LocMap.add loc t st.env; } let get_env st = st.env let next_addr st = let n = st.next_addr in let r = if n = 0 then "_z" else sprintf "_z%d" n in r,{ st with next_addr = n+1; } end herd-herdtools7-1ca343e/gen/archLoc.mli000066400000000000000000000030601475314470400177700ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2014-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Restricted arch, with abstract location *) module type S = sig type arch_reg module ScopeGen : ScopeGen.S include Fence.S type location val of_loc : Code.loc -> location val of_reg : Code.proc -> arch_reg -> location val location_compare : location -> location -> int val pp_location : location -> string val pp_location_brk : location -> string val pp_i : int -> string end herd-herdtools7-1ca343e/gen/archRun.mli000066400000000000000000000030771475314470400200270ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2014-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Argument for run module *) module type S = sig module A : ArchLoc.S module E : Edge.S with type fence = A.fence and type dp = A.dp and type atom = A.atom and type rmw = A.rmw module R : Relax.S with type fence = A.fence and type dp = A.dp and type edge = E.edge module C : Cycle.S with type edge=E.edge and type atom = A.atom and module PteVal = A.PteVal end herd-herdtools7-1ca343e/gen/arch_gen.mli000066400000000000000000000025341475314470400201700ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module type S = sig include ArchBase.S val tr_endian : int -> int module ScopeGen:ScopeGen.S include Fence.S include ArchExtra_gen.S with type arch_reg = reg end herd-herdtools7-1ca343e/gen/atom.mli000066400000000000000000000053661475314470400173700ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2014-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module type SIMD = sig type atom val nregs : atom -> int val pp : atom -> string val initial : int -> int array val step : atom -> int -> int array -> int array val read : atom -> int array -> int list list val reduce: int list list -> int end module type S = sig val bellatom : bool (* true if bell style atoms *) (* SIMD writes and reads *) module SIMD : SIMD type atom val default_atom : atom val instr_atom : atom option val applies_atom : atom -> Code.dir -> bool val is_ifetch : atom option -> bool val compare_atom : atom -> atom -> int val get_access_atom : atom option -> MachMixed.t option val set_access_atom : atom option -> MachMixed.t -> atom option val pp_plain : string val pp_as_a : atom option val pp_atom : atom -> string val fold_non_mixed : (atom -> 'a -> 'a) -> 'a -> 'a val fold_mixed : (atom -> 'a -> 'a) -> 'a -> 'a val fold_atom : (atom -> 'a -> 'a) -> 'a -> 'a val worth_final : atom -> bool val varatom_dir : Code.dir -> (atom option -> 'a -> 'a) -> 'a -> 'a val merge_atoms : atom -> atom -> atom option val overlap_atoms : atom -> atom -> bool (* Memory bank *) val atom_to_bank : atom -> SIMD.atom Code.bank (* Value computation, for mixed size *) val tr_value : atom option -> Code.v -> Code.v val overwrite_value : Code. v -> atom option -> Code.v -> Code.v val extract_value : Code. v -> atom option -> Code.v (* Typing of wide accesses as arrays of integers *) val as_integers : atom option -> int option (* Typing of pair accesses is different, so check them *) val is_pair : atom option -> bool end herd-herdtools7-1ca343e/gen/atomize.ml000066400000000000000000000110661475314470400177210ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2011-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Printf open Code (* Configuration *) let arch = ref `PPC let opts = [Util.arch_opt arch] module Make (A:Fence.S) = struct module E = Edge.Make(Edge.Config)(A) module Namer = Namer.Make(A)(E) module Normer = Normaliser.Make(struct let lowercase = false end)(E) let is_ext e = match E.get_ie e with | Ext -> true | Int -> false let atomic = Some A.default_atom let atomize es = match es with | [] -> [] | fst::_ -> let rec do_rec es = match es with | [] -> [] | [e] -> if E.is_ext fst || E.is_ext e then [ { e with E.a2 = atomic ; } ] else es | e1::e2::es -> if E.is_ext e1 || E.is_ext e2 then let e1 = { e1 with E.a2 = atomic; } in let e2 = { e2 with E.a1 = atomic; } in e1::do_rec (e2::es) else e1::do_rec (e2::es) in match do_rec es with | [] -> assert false | fst::rem as es -> let lst = Misc.last es in if is_ext fst || is_ext lst then { fst with E.a1 = atomic;}::rem else es let parse_line s = try let r = String.index s ':' in let name = String.sub s 0 r and es = String.sub s (r+1) (String.length s - (r+1)) in let es = E.parse_edges es in name,es with | Not_found | Invalid_argument _ -> Warn.fatal "bad line: %s" s let pp_edges es = String.concat " " (List.map E.pp_edge es) let zyva_stdin () = try while true do try let line = read_line () in let _,es = parse_line line in let base,es,_ = Normer.normalise_family (atomize es) in let name = Namer.mk_name base es in printf "%s: %s\n" name (pp_edges es) with Misc.Fatal msg -> Warn.warn_always "%s" msg done with End_of_file -> () let zyva_argv es = let es = List.map E.parse_edge es in let es = atomize es in printf "%s\n" (pp_edges es) let zyva = function | [] -> zyva_stdin () | es -> zyva_argv es end let pp_es = ref [] let () = Util.parse_cmdline opts (fun x -> pp_es := x :: !pp_es) let pp_es = List.rev !pp_es let () = (match !arch with | `X86 -> let module M = Make(X86Arch_gen) in M.zyva | `X86_64 -> assert false | `PPC -> let module M = Make(PPCArch_gen.Make(PPCArch_gen.Config)) in M.zyva | `ARM -> let module M = Make(ARMArch_gen.Make(ARMArch_gen.Config)) in M.zyva | `AArch64 -> let module M = Make(AArch64Arch_gen.Make(AArch64Arch_gen.Config)) in M.zyva | `MIPS -> let module M = Make(MIPSArch_gen.Make(MIPSArch_gen.Config)) in M.zyva | `RISCV -> let module M = Make(RISCVArch_gen.Make(RISCVArch_gen.Config)) in M.zyva | `LISA -> let module BellConfig = Config.ToLisa(Config) in let module M = Make(BellArch_gen.Make(BellConfig)) in M.zyva | `C -> let module M = Make(CArch_gen) in M.zyva | `ASL -> Warn.fatal "ASL arch in atoms" | `BPF -> Warn.fatal "BPF arch in atomize" | `CPP -> Warn.fatal "CCP arch in atomize" | `JAVA -> Warn.fatal "JAVA arch in atomize") pp_es herd-herdtools7-1ca343e/gen/atoms.ml000066400000000000000000000074361475314470400174020ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2014-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** select cycles with at least one atomic specification *) open Printf (* Configuration *) let arch = ref `PPC let opts = [Util.arch_opt arch] module Make (A:Fence.S) = struct module E = Edge.Make(Edge.Config)(A) let is_atom es = List.exists (fun e -> match e.E.a1,e.E.a2 with | None,None -> false | Some _,_ | _,Some _ -> true) es && List.for_all (fun e -> match e with | {E.edge=E.Po _; a1=None; a2=None; _} -> false | {E.edge=E.Fenced (f,_,_,_); _ } -> not (A.is_isync f) | _ -> true) es let parse_line s = try let r = String.index s ':' in let name = String.sub s 0 r and es = String.sub s (r+1) (String.length s - (r+1)) in let es = E.parse_edges es in name,es with | Not_found | Invalid_argument _ -> Warn.fatal "bad line: %s" s let pp_edges es = String.concat " " (List.map E.pp_edge es) let rec next_line () = let line = read_line () in match line with | "" -> next_line () | _ -> begin match line.[0] with | '%'|'#' -> next_line () | _ -> line end let zyva () = try while true do try let line = next_line () in let _,es = parse_line line in if is_atom es then printf "%s\n" line (* else eprintf "No: '%s'\n" line *) with Misc.Fatal msg -> Warn.warn_always "%s" msg done with End_of_file -> () end let () = Util.parse_cmdline opts (fun _ -> raise (Arg.Bad "No argument")) let () = (match !arch with | `X86 -> let module M = Make(X86Arch_gen) in M.zyva | `X86_64 -> assert false | `PPC -> let module M = Make(PPCArch_gen.Make(PPCArch_gen.Config)) in M.zyva | `ARM -> let module M = Make(ARMArch_gen.Make(ARMArch_gen.Config)) in M.zyva | `AArch64 -> let module M = Make(AArch64Arch_gen.Make(AArch64Arch_gen.Config)) in M.zyva | `MIPS -> let module M = Make(MIPSArch_gen.Make(MIPSArch_gen.Config)) in M.zyva | `RISCV -> let module M = Make(RISCVArch_gen.Make(RISCVArch_gen.Config)) in M.zyva | `LISA -> let module BellConfig = Config.ToLisa(Config) in let module M = Make(BellArch_gen.Make(BellConfig)) in M.zyva | `C -> let module M = Make(CArch_gen) in M.zyva | `ASL -> Warn.fatal "ASL arch in atoms" | `CPP -> Warn.fatal "CCP arch in atoms" | `BPF -> Warn.fatal "BPF arch in atoms" | `JAVA -> Warn.fatal "JAVA arch in atoms") () herd-herdtools7-1ca343e/gen/autoArch.ml000066400000000000000000000031731475314470400200170ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module type S = sig module A : Arch_gen.S module E : Edge.S with type fence = A.fence module R : Relax.S with type edge = E.edge and type fence = A.fence module L : LogRelax.S with type relax = R.relax end module Make(A:Arch_gen.S) : S = struct module A = A module E = Edge.Make(Edge.Config)(A) module R = Relax.Make(A) (E) module LogInput = struct type relax = R.relax let parse = R.parse_relax end module L = LogRelax.Make(LogInput) end herd-herdtools7-1ca343e/gen/autoBase.ml000066400000000000000000000066231475314470400200170ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Printf (* Description of a test subdirectory *) type base_st = { id : string ; (* directory name *) num : int ; (* rank in base sequence *) ntests : int ; (* number of (diy) tests generated *) next_log : int ; (* number of run logs present *) } let alloc_log dir base = let log = Filename.concat dir (sprintf "%s.%02i"base.id base.next_log) in log,{ base with next_log = base.next_log+1 ; } module Make(A:AutoArch.S) = struct open A module K = struct type t = { cur : R.Set.t ; rel : R.Set.t ; saf : R.Set.t ; } let compare a b = begin match R.Set.compare a.cur b.cur with | 0 -> begin match R.Set.compare a.rel b.rel with | 0 -> R.Set.compare a.saf b.saf | r -> r end | r -> r end let pp chan k = fprintf chan "C=%a, R=%a, S=%a" R.pp_set k.cur R.pp_set k.rel R.pp_set k.saf end module Key = struct type t = { phase : AutoPhase.t ; key : K.t } let compare a b = match compare a.phase b.phase with | 0 -> K.compare a.key b.key | r -> r let pp chan k = fprintf chan "P=%s %a" (AutoPhase.pp k.phase) K.pp k.key end module BaseMap = Map.Make(Key) (* All test subdirectory, in a map indexed by diy significant agruments *) type t = { next_base : int ; base_map : base_st BaseMap.t ; } let empty = { next_base = 0 ; base_map = BaseMap.empty ; } let do_mk_base n = if n < 26 then sprintf "%c" (Char.chr (n + Char.code 'A')) else sprintf "Z%02i" n let look key bases = try BaseMap.find key bases.base_map,bases with Not_found -> let new_base = { id = do_mk_base bases.next_base ; num = bases.next_base ; ntests = -1 ; next_log = 0 ; } in let bases = { next_base = bases.next_base+1 ; base_map = BaseMap.add key new_base bases.base_map ; } in new_base,bases let change key base bases = { bases with base_map = BaseMap.add key base bases.base_map ; } end herd-herdtools7-1ca343e/gen/autoBase.mli000066400000000000000000000036751475314470400201740ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Description of a test subdirectory *) type base_st = { id : string ; (* directory name *) num : int ; (* rank in base sequence *) ntests : int ; (* number of (diy) tests generated *) next_log : int ; (* number of run logs present *) } val alloc_log : string -> base_st -> string * base_st module Make(A:AutoArch.S) : sig open A (* Key to bases, too complex ? *) module K : sig type t = { cur : R.Set.t ; rel : R.Set.t ; saf : R.Set.t ; } end module Key : sig type t = { phase : AutoPhase.t ; key : K.t ; } val pp : out_channel -> t -> unit end type t val empty : t (* Look/create a new base *) val look : Key.t -> t -> base_st * t (* Change base value *) val change : Key.t -> base_st -> t -> t end herd-herdtools7-1ca343e/gen/autoCom.ml000066400000000000000000000057711475314470400176660ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Printf type mach = Local | Distant of string module type Config = sig val addpath : string list val target : mach end module type S = sig val dist_sh : string -> unit val dist_sh_save : string -> string -> unit val dist_upload : string -> string -> unit val dist_download : string -> string -> unit end module Make(C:Config) = struct let path = match C.addpath with | [] -> "" | ds -> "PATH=" ^ List.fold_right (fun d k -> sprintf "%s:%s" d k) ds "$PATH && " module LocalCom = struct let dist_sh com = MySys.exec_stdout (sprintf "sh -c '%s'" com) let dist_sh_save com name = MySys.exec_stdout (sprintf "sh -c '%s' > %s" com name) let dist_upload f t = MySys.exec_stdout (sprintf "cp %s %s" f t) let dist_download _ _ = assert false end module DistCom (C:sig val addr : string end) = struct let ssh = "ssh -q -T -x -n" let dist_sh com = let com = sprintf "%s %s '%s%s'" ssh C.addr path com in MySys.exec_stdout com let dist_sh_save com name = let com = sprintf "%s %s '%s%s' > %s" ssh C.addr path com name in MySys.exec_stdout com let dist_upload f t = let com = sprintf "scp -q %s %s:%s > /dev/null" f C.addr t in MySys.exec_stdout com let dist_download f t = let com = sprintf "scp -q %s:%s %s > /dev/null" C.addr f t in MySys.exec_stdout com end let upload,download,sh,sh_save = match C.target with | Local -> let open LocalCom in dist_upload,dist_download,dist_sh,dist_sh_save | Distant addr -> let module M = DistCom(struct let addr = addr end) in let open M in dist_upload,dist_download,dist_sh,dist_sh_save let dist_upload = upload let dist_download = download let dist_sh = sh let dist_sh_save = sh_save end herd-herdtools7-1ca343e/gen/autoCom.mli000066400000000000000000000027631475314470400200350ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) type mach = Local | Distant of string module type Config = sig val addpath : string list val target : mach end module type S = sig val dist_sh : string -> unit val dist_sh_save : string -> string -> unit val dist_upload : string -> string -> unit val dist_download : string -> string -> unit end module Make(C:Config) : S herd-herdtools7-1ca343e/gen/autoConf.ml000066400000000000000000000127601475314470400200310ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module PPC = struct module P = PPCArch_gen.Make(PPCArch_gen.Config) module A = AutoArch.Make(P) let testing = "Pod**, DpAddrdR,DpAddrdW, DpDatadW,\ DpCtrldW,DpCtrldR,DpCtrlIsyncdR,\ ISyncd**,\ LwSyncd**, Syncd**, ACLwSyncdR*,\ ACSyncdR*, ABCLwSyncdRW,ABCSyncdRW, BCLwSyncd*W, BCSyncd*W,\ Rfe,[Rfi,DpdR],[Rfi,CtrldR],\ [DpAddrdW,Wsi],[DpDatadW,Wsi],[DpAddrdR,Fri]" let safe ="Wse,Fre" let safe_conform = "Fre, Wse, DpAddrdR,DpAddrdW,DpDatadW, DpCtrlIsyncdR,DpCtrldW,\ Syncd**, ACSyncdR*, BCSyncd*W, ABCSyncdRW,\ LwSyncdWW, LwSyncdR*,\ ACLwSyncdRW, BCLwSyncdRW,\ [DpAddrdW,Wsi],[DpDatadW,Wsi],[DpAddrdR,Fri]" end module X86 = struct module X = X86Arch_gen module A = AutoArch.Make(X) let testing = "Rfe,Pod**,MFenced**,[Rfi,MFencedR*],[Rfi,PodR*]" let safe = "Fre,Wse" let safe_conform = "Rfe,Fre,Wse,PodR*,PodWW,MFencedWR" end module MIPS = struct module X = MIPSArch_gen.Make(MIPSArch_gen.Config) module A = AutoArch.Make(X) let testing = "Rfe,Pod**,Syncd**,[Rfi,SyncdR*],[Rfi,PodR*]" let safe = "Fre,Wse" let safe_conform = "Rfe,Fre,Wse,PodR*,PodWW,SyncdWR" end module ARM = struct module P = ARMArch_gen.Make(ARMArch_gen.Config) module A = AutoArch.Make(P) let testing = "Pod**, DpAddrdR,DpAddrdW, DpDatadW,\ DpCtrldW,DpCtrldR,CtrldR,\ DMBd**,\ ACDMBdR*, ABCDMBdRW, BCDMBd*W,\ DSBd**,\ ACDSBdR*, ABCDSBdRW, BCDSBd*W,\ Rfe,[Rfi,DpdR],[Rfi,CtrldR],\ [DpAddrdW,Wsi],[DpDatadW,Wsi],[DpAddrdR,Fri]" let safe ="Wse,Fre" let safe_conform = "Fre, Wse, DpdR,DpdW, CtrldR,CtrldW,DpDatadW,\ DMBd**, ACDMBdR*, BCDMBd*W, ABCDMBdRW,\ DSBd**, ACDSBdR*, BCDSBd*W, ABCDSBdRW,\ [DpAddrdW,Wsi],[DpDatadW,Wsi],[DpAddrdR,Fri]" end module type InitialSets = sig val testing : string val safe : string end module type ArchConf = sig module A : AutoArch.S include InitialSets val safe_conform : string end let get_arch a = match a with | `X86 -> (module X86 : ArchConf) | `PPC -> (module PPC : ArchConf) | `ARM -> (module ARM : ArchConf) | `MIPS -> (module MIPS : ArchConf) | _ -> Warn.fatal "architecture %s not implemented" (Archs.pp a) open AutoOpt module type B = sig val mode : mode val mach : mach val nprocs : int val diy_sz : int val litmus_opts : string val my_dir : string val dist_dir : string val run_opts : string list val verbose : int val interactive : bool val build : string end let copy_b opt = let module B = struct let mode = opt.mode let mach = opt.mach let nprocs = get_nprocs opt.arch opt let diy_sz = match opt.diy_sz with Some n -> n | None -> 2*nprocs let litmus_opts = opt.litmus_opts let my_dir = opt.output let dist_dir = opt.work_dir let run_opts = opt.run_opts let verbose = opt.verbose let interactive = opt.interactive let build = opt.build end in (module B : B) module type T = sig module A : AutoArch.S val testing : string val safe : string include B end module type S = sig include T module I : AutoInterpret.S with type outcome = A.L.outcome and type relax = A.R.relax and type relax_set = A.R.Set.t and type count = int A.R.Map.t val opt : AutoOpt.t end module MakeInitialSets (I: sig val opt : AutoOpt.t val testing : string val safe : string val safe_conform : string end) = struct let testing = match I.opt.testing with | None -> I.testing | Some tst -> tst let safe = match I.opt.safe with | None -> begin match I.opt.mode with | Explo -> I.safe | Conform -> I.safe_conform end | Some safe -> safe end let mk_config opt = let module X = struct include (val (get_arch opt.arch) : ArchConf) include (MakeInitialSets (struct let opt = opt let testing = testing let safe = safe let safe_conform = safe_conform end)) include (val (copy_b opt): B) end in match opt.interpretation with | Single -> let module C = struct include X module I = AutoSingle.Make(A) let opt = opt end in (module C : S) | Multi -> let module C = struct include X module I = AutoMulti.Make(A) let opt = opt end in (module C : S) herd-herdtools7-1ca343e/gen/autoConf.mli000066400000000000000000000035521475314470400202010ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module type S = sig module A : AutoArch.S (* Options for configuration *) val testing : string val safe : string val mode : AutoOpt.mode val mach : AutoOpt.mach val nprocs : int val diy_sz : int val litmus_opts : string val my_dir : string val dist_dir : string val run_opts : string list val verbose : int val interactive : bool val build : string (* command to build .exe files *) (* Interpretation of cycles *) module I : AutoInterpret.S with type outcome = A.L.outcome and type relax = A.R.relax and type relax_set = A.R.Set.t and type count = int A.R.Map.t (* Sumary of options (for checkpoint) *) val opt : AutoOpt.t end val mk_config : AutoOpt.t -> (module S) herd-herdtools7-1ca343e/gen/autoInterpret.mli000066400000000000000000000034551475314470400212720ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module type S = sig type t type outcome type relax type relax_set type count val pp : out_channel -> t -> unit val interpret : relax_set -> outcome -> t val intest : t -> relax_set val expand_cumul : t -> t val get_relaxed_assuming : relax_set -> t -> relax list -> relax list val shows_relax : relax_set -> relax -> t -> bool val simplify_for_safes : relax_set -> relax_set -> t -> t option val safe_by_inter : t -> relax_set val safe_by_cardinal : t -> (relax_set * int) list -> (relax_set * int) list val unexplained : relax_set -> t -> t option val count : string -> relax_set -> t -> count -> count end herd-herdtools7-1ca343e/gen/autoLex.mll000066400000000000000000000105011475314470400200370ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) { open Printf open AutoOpt exception Error of string let error msg = raise (Error msg) let get_int arg = try int_of_string arg with _ -> error "integer argument expected" let get_bool arg = match arg with | "true" -> true | "false" -> false | _ -> error "boolean argument expected" } let blank = [' ''\t''\r'] let not_blank = [^' ''\t''\n''\r'] let alpha = ['A'-'Z' 'a'-'z'] let arg = blank* '=' blank* (not_blank | not_blank [^'\n']* not_blank as arg) blank* '\n' rule lex_diy = parse | "Generator produced" ' '+ (['0'-'9']+ as x) { try int_of_string x with _ -> assert false } | "" { error "diy output" } and lex_list = parse | ([^',']* as arg) { arg::lex_list lexbuf } | ',' { lex_list lexbuf } | eof { [] } | "" { error "lex_list" } and lex_conf cfg = parse | ('#'|'%') [^'\n']+ '\n' | '\n' { lex_conf cfg lexbuf } | "arch" arg { lex_conf (match Archs.parse arg with | None -> error (sprintf "unknown architecture: %s" arg) | Some a -> { cfg with arch =a; } ) lexbuf } | "testing" blank* '=' blank* '\n' { lex_conf { cfg with testing = Some "" ; } lexbuf } | "testing" arg { lex_conf { cfg with testing = Some arg ; } lexbuf } | "safe" arg { lex_conf { cfg with safe = Some arg ; } lexbuf } | "mode" arg { lex_conf (set_mode arg cfg) lexbuf } | ("mach"|"run") arg { let m = parse_mach arg in match m with | None -> error (sprintf "bad mach: %s" arg) | Some m -> lex_conf { cfg with mach = m ; } lexbuf } | "work_dir" arg { lex_conf { cfg with work_dir = arg; } lexbuf } | "nprocs" arg { lex_conf (set_nprocs (get_int arg) cfg) lexbuf } | "diy_sz" arg { lex_conf { cfg with diy_sz = Some (get_int arg); } lexbuf } | "diy_opts" arg { lex_conf (set_diy_opts arg cfg) lexbuf } | "litmus_opts" arg { lex_conf { cfg with litmus_opts = arg; } lexbuf } | "run_opts" blank* '=' blank* '\n' { lex_conf { cfg with run_opts = [""] ; } lexbuf } | "run_opts" arg { let opts = lex_list (Lexing.from_string arg) in lex_conf { cfg with run_opts = opts; } lexbuf } | "cycle" arg { match parse_interpretation arg with | Some i -> lex_conf { cfg with interpretation = i ; } lexbuf | None -> error (sprintf "bad cycle interpretation: %s" arg) } | "interactive" arg { lex_conf (AutoOpt.set_interactive (get_bool arg) cfg) lexbuf } | "transitive" arg { lex_conf (AutoOpt.set_transitive (get_bool arg) cfg) lexbuf } | "compress" arg { lex_conf (AutoOpt.set_compress (get_bool arg) cfg) lexbuf } | "build" arg { lex_conf {cfg with build = arg; } lexbuf } | "distrm" arg { lex_conf {cfg with distrm = arg; } lexbuf } | "distaddpath" arg { let p = cfg.distaddpath in lex_conf {cfg with distaddpath = p@[arg]; } lexbuf } | "stabilise" arg { lex_conf { cfg with stabilise = get_int arg; } lexbuf } | eof { cfg } | [^'\n']* as line '\n'? { error (sprintf "bad line in configuration: %s" line) } { let diy chan = lex_diy (Lexing.from_channel chan) let conf opt name = try Misc.input_protect (fun chan -> lex_conf opt (Lexing.from_channel chan)) name with | Error msg -> Warn.fatal "%s" msg } herd-herdtools7-1ca343e/gen/autoMulti.ml000066400000000000000000000077431475314470400202430ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Test interpretation as all cycles of relaxations *) module Make(A:AutoArch.S) = struct module R = A.R module L = A.L type t = R.SetSet.t type outcome = L.outcome type relax = R.relax type relax_set = R.Set.t type count = int R.Map.t let pp = R.pp_set_set let interpret all o = R.relaxs_of all (A.E.parse_edges o.L.cycle) let intest i = R.Set.unions (R.SetSet.elements i) let expand_cumul i = let xs = R.SetSet.fold (fun rs k -> R.expand_cumul rs::k) i [] in R.SetSet.of_list xs let get_relaxed_assuming safe i = R.SetSet.fold (fun rs k -> match R.Set.as_singleton (R.Set.diff rs safe) with | None -> k | Some r -> r::k) i let shows_relax safe r i = R.SetSet.exists (fun rs -> match R.Set.as_singleton (R.Set.diff rs safe) with | None -> false | Some s -> R.compare r s = 0) i let simplify_for_safes relaxed testing i = try let i = R.SetSet.of_list (R.SetSet.fold (fun rs k -> (* Irrelevant interpretation, corresponding cycle is non-global *) if R.Set.is_empty (R.Set.inter relaxed rs) then rs::k else k) i []) in let i = R.SetSet.of_list (R.SetSet.fold (fun rs k -> let rs = R.Set.inter testing rs in (* No explained *) if R.Set.is_empty rs then raise Exit else rs::k) i []) in if R.SetSet.is_empty i then None else Some i with Exit -> None (* Safe heuristics *) let safe_by_inter i = let xss = R.SetSet.elements i in match xss with | []|[_] -> R.Set.empty | xs::(_::_ as xss) -> List.fold_left R.Set.inter xs xss let get_mins le ps = let rec select_rec r = function [] -> r | p::ps -> if List.exists (fun p0 -> le p0 p) ps then select_rec r ps else select_rec (p::r) ps in select_rec [] (select_rec [] ps) let safe_by_cardinal i k = let i = R.SetSet.of_list (get_mins (fun s1 s2 -> R.Set.cardinal s1 < R.Set.cardinal s2) (R.SetSet.elements i)) in let c = R.SetSet.cardinal i in if c > 0 then R.SetSet.fold (fun rs k -> (rs,c)::k) i k else k (* Relaxation connt for false safe heuristic *) let unexplained safe i = let x = R.SetSet.filter (fun rs -> R.Set.subset rs safe) i in if R.SetSet.is_empty x then None else Some x let count _name safe i m = R.SetSet.fold (fun rs m -> if R.Set.subset rs safe then R.Set.fold (fun r m -> let v = try R.Map.find r m with Not_found -> 0 in R.Map.add r (v+1) m) rs m else m) i m end herd-herdtools7-1ca343e/gen/autoOpt.ml000066400000000000000000000113701475314470400177020ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Printf (* Main mode *) type mode = Explo | Conform let parse_mode s = match Misc.lowercase s with | "explo" -> Some Explo | "conform" -> Some Conform | _ -> None let pp_mode = function | Explo -> "explo" | Conform -> "conform" (* Execution *) type mach = | Local | Distant of string | Simul of string * string | Cross of string * string let split_space s = try let i = String.index s ' ' in String.sub s 0 i, String.sub s (i+1) (String.length s - (i+1)) with Not_found -> s,"" let parse_mach s = let key,v = split_space s in match Misc.lowercase key with | "local" -> Some Local | "ssh" -> Some (Distant v) | ("memevents"|"ppcmem"|"herd") as prog -> Some (Simul (prog,v)) | "cross" -> let v1,v2 = split_space v in Some (Cross (v1,v2)) | _ -> None let sp s = if s = "" then "" else " " let pp_mach = function | Local -> "local" | Distant addr -> sprintf "ssh %s" addr | Simul (prog,opts) -> sprintf "%s%s%s" prog (sp opts) opts | Cross (addr1,addr2) -> sprintf "cross %s %s" addr1 addr2 (* Interpretation *) type interpretation = Single | Multi let parse_interpretation s = match Misc.lowercase s with | "single" -> Some Single | "multi" -> Some Multi | _ -> None let pp_interpretation = function | Single -> "single" | Multi -> "multi" (* Checkpoint *) let ckpt_name = "ckpt" type t = { arch : Archs.t ; output : string ; (* Directory for all output *) testing : string option ; safe : string option ; mode : mode ; mach : mach ; interpretation : interpretation ; work_dir : string ; nprocs : int option ; diy_sz : int option ; litmus_opts : string ; run_opts : string list ; verbose : int ; interactive : bool ; force_interactive : bool ; build : string ; stabilise : int ; compress : bool ; distrm : string ; distaddpath : string list ; diy_opts : string list ; transitive : bool ; } let pp_opt chan t = let pp_opt pp = function | None -> "-" | Some x -> pp x in let pp_oint = pp_opt string_of_int in let p = fprintf chan in p "arch = %s\n" (Archs.pp t.arch) ; p "nprocs = %s\n" (pp_oint t.nprocs) ; p "diy_sz = %s\n" (pp_oint t.diy_sz) ; () let default = { arch = `X86 ; output = "." ; testing = None ; safe = None ; mach = Local ; mode = Explo ; interpretation = Single ; work_dir = "/var/tmp" ; nprocs = None ; diy_sz = None ; litmus_opts = "" ; run_opts = ["";] ; verbose = 0 ; interactive = true ; force_interactive = false ; build = "sh comp.sh" ; stabilise = 5 ; compress = true ; distrm = "/bin/rm" ; distaddpath = [] ; diy_opts = [] ; transitive = false ; } let incr_verbose opts = { opts with verbose = opts.verbose + 1 ; } let set_interactive b opts = { opts with interactive = b ; } let set_transitive b opts = { opts with transitive = b ; } let set_compress b opts = { opts with compress = b ; } let set_arch arg cfg = match Archs.parse arg with | None -> raise (Arg.Bad (sprintf "unknown architecture: %s" arg)) | Some a -> { cfg with arch =a; } let set_mode arg cfg = match parse_mode arg with | None -> raise (Arg.Bad (sprintf "bad mode: %s" arg)) | Some m -> { cfg with mode = m ; } let set_nprocs i cfg = { cfg with nprocs = Some i; } let get_nprocs a cfg = match cfg.nprocs with | None -> begin match a with | `PPC -> 4 | `X86|`X86_64 | `ARM | `MIPS | `LISA | `AArch64 | `RISCV -> 2 | `C | `CPP -> 2 end | Some i -> i let set_diy_opts s t = { t with diy_opts = s :: t.diy_opts; } let get_diy_opts t = t.diy_opts herd-herdtools7-1ca343e/gen/autoOpt.mli000066400000000000000000000052101475314470400200470ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Main mode *) type mode = Explo | Conform val parse_mode : string -> mode option val pp_mode : mode -> string (* Execution of tests *) type mach = | Local | Distant of string | Simul of string * string | Cross of string * string val parse_mach : string -> mach option val pp_mach : mach -> string (* Interpretation *) type interpretation = Single | Multi val parse_interpretation : string -> interpretation option val pp_interpretation : interpretation -> string (* Checkpoint *) val ckpt_name : string (* Options *) type t = { arch : Archs.t ; output : string ; (* Directory for all output *) testing : string option ; safe : string option ; mode : mode ; mach : mach ; interpretation : interpretation ; work_dir : string ; nprocs : int option ; diy_sz : int option ; litmus_opts : string ; run_opts : string list ; verbose : int ; interactive : bool ; force_interactive : bool ; build : string ; stabilise : int ; compress : bool ; distrm : string ; distaddpath : string list ; diy_opts : string list; transitive : bool ; } val pp_opt : out_channel -> t -> unit val default : t val incr_verbose : t -> t val set_interactive : bool -> t -> t val set_transitive : bool -> t -> t val set_compress : bool -> t -> t val set_arch : string -> t -> t val set_mode : string -> t -> t val set_nprocs : int -> t -> t val get_nprocs : Archs.t -> t -> int val set_diy_opts : string -> t -> t val get_diy_opts : t -> string list herd-herdtools7-1ca343e/gen/autoOuts.ml000066400000000000000000000174061475314470400201000ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Printf module type S = sig module A : AutoArch.S type relax = A.R.relax type set = A.R.Set.t type outs val empty : outs val is_empty : outs -> bool val equal : outs -> outs -> bool val pp : out_channel -> string -> outs -> unit val make : set -> A.L.outcome list -> outs val intests : outs -> set val diff : outs -> outs -> outs val union : outs -> outs -> outs val expand_cumul : outs -> outs (* Get relaxed from safe set *) val get_relaxed_assuming : set -> outs -> set val get_relax_witnesses : set -> relax -> outs -> outs (*******************) (* Safe heuristics *) (*******************) (* first argument is relaxed set, second is tested relaxations *) val simplify_for_safes : set -> set -> outs -> outs (* heuristics proper *) val safe_by_inter : outs -> set (* first arg is tests seen ok, second is tests seen safe *) val safe_by_cardinal : outs -> outs -> set (* Compute (some of) false safes *) val unexplained : set -> outs -> outs val false_safes : set -> set -> outs -> set end module Make(C:AutoConf.S) : S with module A = C.A = struct open C module A = A module R = A.R module L = A.L type relax = R.relax type set = R.Set.t (* Outcome proper *) module O = struct type t = { name : string ; cycle : string ; interpret : I.t } let pp chan o = fprintf chan "%s: '%s' %a\n" o.name o.cycle I.pp o.interpret end module M = Map.Make(String) include M (* outs is really a set of keys *) let equal os1 os2 = M.equal (fun _ _ -> true) os1 os2 type outs = O.t t let pp chan title os = if is_empty os then () else begin fprintf chan "++ %s ++\n" title ; iter (fun _ o -> O.pp chan o) os ; fprintf chan "++++++++\n%!" end let make all os = List.fold_left (fun k o -> add o.L.cycle {O.name = o.L.name ; cycle = o.L.cycle ; interpret = I.interpret all o } k) empty os let intests os = let xs = fold (fun _ o k -> I.intest o.O.interpret::k) os [] in R.Set.unions xs (*******************************) (* Convenient additions to Map *) (*******************************) let union = fold add let diff o1 o2 = fold (fun k v r -> if mem k o2 then r else add k v r) o1 empty (************) (* Specific *) (************) let expand_cumul = map (fun o -> { o with O.interpret = I.expand_cumul o.O.interpret }) let simplify_for_safes relaxed testing os = fold (fun k o r -> match I.simplify_for_safes relaxed testing o.O.interpret with | None -> r | Some i -> add k { o with O.interpret = i } r) os empty let get_relaxed_assuming safe os = let rs = fold (fun _ o -> I.get_relaxed_assuming safe o.O.interpret) os [] in R.Set.of_list rs let get_relax_witnesses safe r os = fold (fun cy o k-> if I.shows_relax safe r o.O.interpret then add cy o k else k) os empty (* Safe heuristics *) let safe_by_inter os = R.Set.unions (fold (fun _ o k -> I.safe_by_inter o.O.interpret::k) os []) let group = let rec g_rec c k = function | [] -> [k] | (x,d)::xs -> if d = c then g_rec c (x::k) xs else let xs = g_rec d [x] xs in k::xs in function | [] -> [] | (x,c)::xs -> g_rec c [x] xs (* select relaxations that occur most *) let factor = 4 let count xs = List.fold_left (fun m rs -> A.R.Set.fold (fun r m -> let v = try A.R.Map.find r m with Not_found -> 0 in A.R.Map.add r (v+1) m) rs m) A.R.Map.empty xs let pp_count m = A.R.Map.iter (fun r o -> eprintf " %s->%i" (A.R.pp_relax r) o) m ; eprintf "\n%!" let take_high ok xs = let ms = count xs and mr = count ok in if C.verbose > 0 then begin eprintf "Occurrence counts for safes:" ; pp_count ms ; eprintf "Occurrence counts for relaxs:" ; pp_count mr ; () end ; let xs = A.R.Map.fold (fun r o k -> let o_r = try A.R.Map.find r mr with Not_found -> 0 in if factor*o > o_r then r::k else k) ms [] in let r = A.R.Set.of_list xs in if C.verbose > 0 then begin eprintf "Above %i/%i: %a\n%!" (factor-1) factor A.R.pp_set r end; r let extract os = let xs = fold (fun _ o ->I.safe_by_cardinal o.O.interpret) os [] in let xs = List.sort (fun (_,c1) (_,c2) -> Misc.int_compare c1 c2) xs in match group xs with | [] -> [] | xs::_ -> xs let safe_by_cardinal ok os = match extract os with | [] -> R.Set.empty | xs -> if !Misc.switch then take_high (extract ok) xs else R.Set.unions xs (* False safe heuristics *) let count safe os = fold (fun _ o -> I.count o.O.name safe o.O.interpret) os R.Map.empty let find_max avoid rm = let _,r = R.Map.fold (fun r n ((max,k) as acc) -> if R.Set.mem r avoid then acc else if n < max then acc else if n > max then (n,R.Set.singleton r) else (n,R.Set.add r k)) rm (0,R.Set.empty) in r let unexplained safe ok = fold (fun cy o k -> match I.unexplained safe o.O.interpret with | None -> k | Some i -> add cy { o with O.interpret = i } k) ok empty let false_safes avoid safe ok = let rm = count safe ok in if verbose > 1 && not (R.Map.is_empty rm) then begin eprintf "++++++++++\n" ; R.Map.iter (fun r n -> eprintf "%s -> %i\n" (R.pp_relax r) n) rm ; eprintf "++++++++++\n%!" end ; find_max avoid rm end herd-herdtools7-1ca343e/gen/autoPhase.ml000066400000000000000000000023461475314470400202030ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) type t = One | Two let pp = function | One -> "1" | Two -> "2" herd-herdtools7-1ca343e/gen/autoPhase.mli000066400000000000000000000023131475314470400203460ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) type t = One | Two val pp : t -> string herd-herdtools7-1ca343e/gen/autoSingle.ml000066400000000000000000000047651475314470400203730ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Test interpretation as a single cycle of relaxations *) module Make(A:AutoArch.S) = struct module R = A.R module L = A.L type t = R.Set.t type outcome = L.outcome type relax = R.relax type relax_set = R.Set.t type count = int R.Map.t let pp = R.pp_set let interpret _ o = R.Set.of_list (o.L.relaxs @ o.L.safes) let intest rs = rs let expand_cumul i = R.expand_cumul i let get_relaxed_assuming safe rs k = match R.Set.as_singleton ( R.Set.diff rs safe) with | None -> k | Some r -> r::k let shows_relax safe r rs = match R.Set.as_singleton (R.Set.diff rs safe) with | None -> false | Some s -> R.compare r s = 0 let simplify_for_safes relaxed testing i = if R.Set.is_empty (R.Set.inter relaxed i) then let i = R.Set.inter i testing in if R.Set.is_empty i then None else Some i else None (* Safe heuristics *) let safe_by_inter _i = R.Set.empty let safe_by_cardinal i k = (i,1)::k (* Relaxation count for false safe heuristic *) let unexplained safe cy = if R.Set.subset cy safe then Some cy else None let count _name safe cy m = if R.Set.subset cy safe then begin R.Set.fold (fun r m -> let v = try R.Map.find r m with Not_found -> 0 in R.Map.add r (v+1) m) cy m end else m end herd-herdtools7-1ca343e/gen/builder.mli000066400000000000000000000043651475314470400200540ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Signature of test builder *) module type S = sig include ArchRun.S val ppo : (R.relax -> 'a -> 'a) -> 'a -> 'a type test (* Various access to test *) val get_nprocs : test -> int val get_name : test -> string val set_name : test -> string -> test val set_scope : test -> BellInfo.scopes -> test val add_info : test -> string -> string -> test type node = C.node type edge = E.edge type check = edge list list -> bool (* Returns resolved edges of test *) val extract_edges : test -> edge list (* Build up test, test structure includes name & comment given as first two arguments, third argument is the last minute check *) val make_test : string -> ?com:string -> ?info:Code.info -> ?check:check -> ?scope:BellInfo.scopes -> edge list -> test (* Build test from cycle *) val test_of_cycle : string -> ?com:string -> ?info:Code.info -> ?check:check -> ?scope:BellInfo.scopes -> ?init:Code.env -> edge list -> node -> test (* Dump the given test *) val dump_test_channel : out_channel -> test -> unit end herd-herdtools7-1ca343e/gen/cDep.ml000066400000000000000000000032271475314470400171240ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2011-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* C dependencies *) type dp = ADDR | DATA | CTRL let fold_dpr f r = f ADDR (f CTRL r) let fold_dpw f r = f ADDR (f DATA (f CTRL r)) let ddr_default = Some ADDR let ddw_default = Some DATA let ctrlr_default = Some CTRL let ctrlw_default = Some CTRL let is_ctrlr = function | CTRL -> true | _ -> false let is_addr = function | ADDR -> true | _ -> false let fst_dp = function | CTRL -> [CTRL] | ADDR|DATA -> [] let sequence_dp d1 d2 = match d1 with | ADDR -> [d2] | DATA|CTRL -> [] herd-herdtools7-1ca343e/gen/cDep.mli000066400000000000000000000032211475314470400172670ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2011-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* C dependencies *) type dp = ADDR | DATA | CTRL val fold_dpr : (dp -> 'a -> 'a) -> 'a -> 'a val fold_dpw : (dp -> 'a -> 'a) -> 'a -> 'a (* Defaults for backward compatibility *) val ddr_default : dp option val ddw_default : dp option val ctrlr_default : dp option val ctrlw_default : dp option (* Predicate for control on reads *) val is_ctrlr : dp -> bool val is_addr : dp -> bool (* Dependencies compositin by sequence *) val fst_dp : dp -> dp list val sequence_dp : dp -> dp -> dp list herd-herdtools7-1ca343e/gen/classicDep.ml000066400000000000000000000033021475314470400203150ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Classical dependencies, ie data + addr + ctrl *) type dp = ADDR | DATA | CTRL let fold_dpr f r = f ADDR (f CTRL r) let fold_dpw f r = f ADDR (f DATA (f CTRL r)) let ddr_default = Some ADDR let ddw_default = Some DATA let ctrlr_default = Some CTRL let ctrlw_default = Some CTRL let is_ctrlr _ = false let is_addr _ = false let fst_dp = function | CTRL -> [CTRL] | ADDR|DATA -> [] let sequence_dp d1 d2 = match d1 with | ADDR -> [d2] | DATA|CTRL -> [] let pp_dp = function | ADDR -> "Addr" | DATA -> "Data" | CTRL -> "Ctrl" herd-herdtools7-1ca343e/gen/classicDep.mli000066400000000000000000000032631475314470400204740ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Classical dependencies *) type dp = ADDR | DATA | CTRL val pp_dp : dp -> string val fold_dpr : (dp -> 'a -> 'a) -> 'a -> 'a val fold_dpw : (dp -> 'a -> 'a) -> 'a -> 'a (* Defaults for backward compatibility *) val ddr_default : dp option val ddw_default : dp option val ctrlr_default : dp option val ctrlw_default : dp option (* Predicate for control on reads *) val is_ctrlr : dp -> bool val is_addr : dp -> bool (* Dependencies compositin by sequence *) val fst_dp : dp -> dp list val sequence_dp : dp -> dp -> dp list herd-herdtools7-1ca343e/gen/classify.ml000066400000000000000000000130461475314470400200660ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Printf let arch = ref `PPC let diyone = ref false let lowercase = ref false let uniq = ref false let map = ref None let bell = ref None let opts = ("-diyone", Arg.Set diyone," generate input for diyone"):: ("-lowercase", Arg.Bool (fun b -> lowercase := b), sprintf " use lowercase familly names, default %b" !lowercase):: ("-u", Arg.Set uniq," reject duplicate normalised names"):: ("-map", Arg.String (fun s -> map := Some s)," save renaming map into file "):: ("-bell",Arg.String (fun f -> bell := Some f; arch := `LISA), " read bell file "):: Util.parse_tag "-arch" (fun tag -> match Archs.parse tag with | None -> false | Some a -> arch := a ; true) Archs.tags "specify architecture":: [] module type Config = sig val diyone : bool val uniq : bool val outmap : string option val lowercase : bool val sufname : string option end module Make(Co:Config) (A:Fence.S) = struct module E = Edge.Make(Edge.Config)(A) module N = Namer.Make(A)(E) module Norm = Normaliser.Make(Co)(E) module P = LineUtils.Make(E) let parse_line s = P.parse s let skip_line s = match s with | "" -> true | _ -> match s.[0] with | '#'|'%' -> true | _ -> false let add name (key,ps,_) st k = let xs = try StringMap.find key k with Not_found -> [] in StringMap.add key ((name,(ps,st))::xs) k let scan chan = let k = ref StringMap.empty in let rec do_rec () = let line = input_line chan in if skip_line line then do_rec () else begin let name,es,st = parse_line line in let ps = Norm.normalise_family (E.resolve_edges es) in k := add name ps st !k ; do_rec () end in try do_rec () with End_of_file -> !k let pp_scope_opt = function | None -> "" | Some st -> " " ^ BellInfo.pp_scopes st let dump_map outmap m = StringMap.iter (fun k xs -> let base = k in if not Co.diyone then printf "%s\n" base ; let rec do_rec seen = function | [] -> () | (name,(es,scope))::rem -> let new_name = N.mk_name base ?scope es in if Co.uniq && StringSet.mem new_name seen then Warn.fatal "Duplicate name: %s" new_name ; if Co.diyone then printf "%s: %s%s\n" new_name (E.pp_edges es) (pp_scope_opt scope) else printf " %s -> %s: %s%s\n" name new_name (E.pp_edges es) (pp_scope_opt scope) ; fprintf outmap "%s %s\n" name new_name ; let seen = StringSet.add new_name seen in do_rec seen rem in do_rec StringSet.empty (List.rev xs)) m let zyva chan = try let k = scan chan in Misc.output_protect (fun chan -> dump_map chan k) (match Co.outmap with | None -> "/dev/null" | Some s -> s) with Misc.Fatal msg -> eprintf "Fatal error: %s\n" msg ; exit 2 end let () = Util.parse_cmdline opts (fun _ -> raise (Arg.Bad "No argument")) let () = let module Co = struct let diyone = !diyone let uniq = !uniq let outmap = !map let lowercase = !lowercase let sufname = None end in let module Build = Make(Co) in (match !arch with | `X86 -> let module M = Build(X86Arch_gen) in M.zyva | `X86_64 -> let module M = Build(X86_64Arch_gen.Make(X86_64Arch_gen.Config)) in M.zyva | `PPC -> let module M = Build(PPCArch_gen.Make(PPCArch_gen.Config)) in M.zyva | `ARM -> let module M = Build(ARMArch_gen.Make(ARMArch_gen.Config)) in M.zyva | `AArch64 -> let module A = AArch64Arch_gen.Make (struct include AArch64Arch_gen.Config let moreedges = !Config.moreedges end) in let module M = Build(A) in M.zyva | `MIPS -> let module M = Build(MIPSArch_gen.Make(MIPSArch_gen.Config)) in M.zyva | `RISCV -> let module M = Build(RISCVArch_gen.Make(RISCVArch_gen.Config)) in M.zyva | `LISA -> let module BellConfig = Config.ToLisa(Config) in let module M = Build(BellArch_gen.Make(BellConfig)) in M.zyva | `C | `CPP -> let module M = Build(CArch_gen) in M.zyva | `JAVA | `ASL | `BPF -> assert false) stdin herd-herdtools7-1ca343e/gen/code.ml000066400000000000000000000113311475314470400171560ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Event components *) type loc = Data of string | Code of Label.t let as_data = function | Data loc -> loc | Code _ -> assert false let is_data = function | Data _ -> true | Code _ -> false let pp_loc = function Data s | Code s -> s let loc_eq loc1 loc2 = match loc1,loc2 with | (Data s1,Data s2) | (Code s1,Code s2) -> Misc.string_eq s1 s2 | (Data _,Code _) | (Code _,Data _) -> false let loc_compare loc1 loc2 = match loc1,loc2 with | Data _,Code _ -> -1 | Code _,Data _ -> 1 | (Data s1,Data s2) | (Code s1,Code s2) -> compare s1 s2 module LocOrd = struct type t = loc let compare = loc_compare end module LocSet = MySet.Make(LocOrd) module LocMap = MyMap.Make(LocOrd) let loc_none = Data "*" let ok_str = "ok" let ok = Data ok_str let myok p n = Data (Printf.sprintf "ok%i%i" p n) let myok_proc p = Data (Printf.sprintf "ok%i" p) type v = int let pp_v ?(hexa=false) = Printf.sprintf (if hexa then "0x%x" else "%d") type proc = Proc.t let pp_proc p = Proc.pp p type env = (string * v) list (* Direction of event *) type dir = W | R | J (* Edges compoments that do not depend on architecture *) (* Change or proc accross edge *) type ie = Int|Ext (* Change of location across edge *) type sd = Same|Diff (* Direction of related events *) type extr = Dir of dir | Irr | NoDir (* Associated pretty print & generators *) let pp_dir = function | W -> "W" | R -> "R" | J -> "J" let pp_ie = function | Int -> "i" | Ext -> "e" let pp_extr = function | Dir d -> pp_dir d | Irr -> "*" | NoDir -> "" let pp_sd = function | Same -> "s" | Diff -> "d" let seq_sd sd1 sd2 = match sd1,sd2 with | Same,Same -> Same | Diff,_|_,Diff -> Diff let fold_ie f r = f Ext (f Int r) let fold_sd f r = f Diff (f Same r) let do_fold_extr withj f r = let r = f (Dir W) (f (Dir R) (f Irr r)) in if withj then f (Dir J) r else r let fold_extr f r = do_fold_extr false f r let fold_sd_extr f = fold_sd (fun sd -> fold_extr (fun e -> f sd e)) let fold_sd_extr_extr f = fold_sd_extr (fun sd e1 -> fold_extr (fun e2 -> f sd e1 e2)) type check = | Default | Sc | Uni | Thin | Critical | Free | Ppo | Transitive | Total | MixedCheck let pp_check = function | Default -> "default" | Sc -> "sc" | Uni -> "uni" | Thin -> "thin" | Critical -> "critical" | Free -> "free" | Ppo -> "ppo" | Transitive -> "transitive" | Total -> "total" | MixedCheck -> "mixedcheck" let checks = [ "default"; "sc"; "uni"; "thin"; "critical"; "free"; "ppo"; "transitive"; "total"; "mixedcheck"; ] (* Com relation *) type com = CRf | CFr | CWs let pp_com = function | CRf -> "Rf" | CFr -> "Fr" | CWs -> "Co" let fold_com f r = f CRf (f CFr (f CWs r)) (* Info in tests *) type info = (string * string) list let plain = "Na" (* Memory Space *) type 'a bank = Ord | Tag | CapaTag | CapaSeal | Pte | VecReg of 'a | Pair | Instr let pp_bank = function | Ord -> "Ord" | Tag -> "Tag" | CapaTag -> "CapaTag" | CapaSeal -> "CapaSeal" | Pte -> "Pte" | VecReg _ -> "VecReg" | Pair -> "Pair" | Instr -> "Instr" let tag_of_int = function | 0 -> "green" | 1 -> "red" | 2 -> "blue" | 3 -> "black" | 4 -> "white" | 5 -> "cyan" | 6 -> "yellow" | 7 -> "magenta" | n -> Warn.fatal "Sorry, not pretty tag for number %i" n let add_tag s t = Printf.sprintf "%s:%s" s (tag_of_int t) let add_capability s t = Printf.sprintf "0xffffc0000:%s:%i" s (if t = 0 then 1 else 0) let add_vector hexa v = let open Printf in let pp = pp_v ~hexa:hexa in sprintf "{%s}" (String.concat "," (List.map pp v)) herd-herdtools7-1ca343e/gen/code.mli000066400000000000000000000061431475314470400173340ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Event components *) type loc = Data of string | Code of Label.t val as_data : loc -> string val is_data : loc -> bool val pp_loc : loc -> string val loc_eq : loc -> loc -> bool val loc_compare : loc -> loc -> int module LocSet : MySet.S with type elt = loc module LocMap : MyMap.S with type key = loc val loc_none : loc val ok_str : string val ok : loc val myok : int -> int -> loc val myok_proc : int -> loc type v = int val pp_v : ?hexa:bool -> v -> string type proc = Proc.t val pp_proc : proc -> string type env = (string * v) list (* Direction of event *) type dir = W | R | J (* Edges compoments that do not depend on architecture *) (* Change or proc accross edge *) type ie = Int|Ext (* Change of location across edge *) type sd = Same|Diff (* Direction of related events *) type extr = Dir of dir | Irr | NoDir (* Associated pretty print & generators *) val pp_ie : ie -> string val pp_dir : dir -> string val pp_extr : extr -> string val pp_sd : sd -> string val seq_sd : sd -> sd -> sd val fold_ie : (ie -> 'a -> 'a) -> 'a -> 'a val do_fold_extr : bool -> (extr -> 'a -> 'a) -> 'a -> 'a val fold_extr : (extr -> 'a -> 'a) -> 'a -> 'a val fold_sd : (sd -> 'a -> 'a) -> 'a -> 'a val fold_sd_extr : (sd -> extr -> 'a -> 'a) -> 'a -> 'a val fold_sd_extr_extr : (sd -> extr -> extr -> 'a -> 'a) -> 'a -> 'a type check = | Default | Sc | Uni | Thin | Critical | Free | Ppo | Transitive | Total | MixedCheck val pp_check : check -> string val checks : string list (* Com *) type com = CRf | CFr | CWs val pp_com : com -> string val fold_com : (com -> 'a -> 'a) -> 'a -> 'a (* Info in tests *) type info = (string * string) list (* Name of plain accesses *) val plain : string (* Memory bank (for MTE, KVM) *) type 'a bank = Ord | Tag | CapaTag | CapaSeal | Pte | VecReg of 'a | Pair | Instr val pp_bank : 'a bank -> string val add_tag : string -> v -> string val add_capability : string -> v -> string val add_vector : bool -> int list -> string herd-herdtools7-1ca343e/gen/compileCommon.ml000066400000000000000000000060531475314470400210520ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module type Config = sig val verbose : int val show : ShowGen.t option val same_loc : bool val unrollatomic : int option val allow_back : bool val typ : TypBase.t val hexa : bool val moreedges : bool val variant : Variant_gen.t -> bool end module type S = sig module A : Arch_gen.S module E : Edge.S with type fence = A.fence and type dp = A.dp and module SIMD = A.SIMD and type atom = A.atom and type rmw = A.rmw type check = E.edge list list -> bool module R : Relax.S with type fence = A.fence and type dp = A.dp and type edge = E.edge module C : Cycle.S with type fence = A.fence and type edge=E.edge and module SIMD = A.SIMD and type atom = A.atom and module PteVal = A.PteVal end module Make(C:Config) (A:Arch_gen.S) = struct module A = A module E = Edge.Make (struct let variant = C.variant let naturalsize = TypBase.get_size C.typ end) (A) type check = E.edge list list -> bool let () = match C.show with | Some s -> begin try E.show s ; exit 0 with e -> Printexc.print_backtrace stderr ; flush stderr ; raise e end | None -> () module R = Relax.Make(A) (E) module Conf = struct include C let naturalsize = TypBase.get_size C.typ end module C = Cycle.Make(Conf)(E) (* Big constant *) let kbig = 128 (* Postlude *) let mk_postlude emit_store_reg st p init cs = if A.get_noks st > 0 then let ok,st = A.ok_reg st in (* Add explict `int` type for `ok` variables *) let ok_loc = Code.as_data (Code.myok_proc p) in let st = A.add_type (A.Loc ok_loc) TypBase.Int st in let init,cs_store,st = emit_store_reg st p init ok_loc ok in let csok = A.Label (Label.last p,A.Nop)::cs_store in (* Add explict initialvalue of zero for `ok` variables *) (A.Loc ok_loc,Some (A.S "0"))::init,cs@csok,st else init,cs,st end herd-herdtools7-1ca343e/gen/config.ml000066400000000000000000000331201475314470400175110ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Printf open Code let verbose = ref 0 let libdir = ref (Filename.concat Version.libdir "herd") let nprocs = ref 4 let size = ref 6 let one = ref false let arch = ref (`PPC: Archs.t) let typ = ref TypBase.default let hexa = ref false let tarfile = ref None let prefix = ref [] let safes = ref [] let relaxs = ref [] let name = ref None let sufname = ref None let canonical_only = ref true let conf = ref None let mode = ref Default let mix = ref false let max_ins = ref 4 let eprocs = ref false let max_relax = ref 100 let min_relax = ref 1 type 'a cumul = Empty | All | Set of 'a let cumul = ref All let poll = ref false let docheck = ref false let fmt = ref 3 let no = ref None let addnum = ref true let lowercase = ref false let optcoherence = ref false let bell = ref None let scope = ref Scope.No let variant = ref (fun (_:Variant_gen.t) -> false) let rejects = ref None let stdout = ref false let cycleonly = ref false let metadata = ref true let info = ref ([]:MiscParser.info) let add_info_line line = match LexScan.info line with | Some kv -> info := !info @ [kv] | None -> let msg = Printf.sprintf "argument '%s' is not in 'key = value' format" line in raise (Arg.Bad msg) type do_observers = | Avoid (* was false *) | Accept (* was true *) | Enforce (* is new *) | Local (* Local observer when possible *) | Three (* Accept up to three writes, no observers *) | Four (* Accept up to four writes, no observers *) | Infinity (* Accept all tests, no observers *) let do_observers = ref Avoid type obs_type = Straight | Fenced | Loop let obs_type = ref Straight let upto = ref true let optcond = ref true let overload = ref None let neg = ref false let unrollatomic : int option ref = ref None let same_loc = ref false type cond = Cycle | Unicond | Observe let cond = ref Cycle let hout = ref None type show = Edges | Annotations | Fences let show = ref (None:ShowGen.t option) let debug = ref Debug_gen.none let moreedges = ref false let realdep = ref false let parse_cond tag = match tag with | "cycle" -> Cycle | "unicond" -> Unicond | "observe" -> Observe | _ -> failwith "Wrong cond, choose cycle, unicond or observe" let parse_mode s = match s with | "default"|"def" -> Default | "sc" -> Sc | "thin" -> Thin | "uni" -> Uni | "critical" -> Critical | "free" -> Free | "ppo" -> Ppo | "transitive"|"trans" -> Transitive | "total" -> Total | "mixed" -> MixedCheck | _ -> failwith (Printf.sprintf "Wrong mode: choose %s" (String.concat "," Code.checks)) let parse_do_observers s = match s with | "avoid"|"false" -> Avoid | "accept"|"true" -> Accept | "force" -> Enforce | "local" -> Local | "three" -> Three | "four" -> Four | "oo"|"infinity" -> Infinity | _ -> failwith "Wrong observer mode, choose avoid, accept, force, local, three or four" let parse_obs_type = function | "straight" -> Straight | "fenced" -> Fenced | "loop" -> Loop | _ -> failwith "Wrong observer style, choose straight, fenced or loop" let parse_cumul = function | "false" -> Empty | "true" -> All | s -> Set s (* Helpers *) let common_specs () = ("-v", Arg.Unit (fun () -> incr verbose)," be verbose"):: ("-version", Arg.Unit (fun () -> print_endline Version.version ; exit 0), " show version number and exit"):: ("-set-libdir", Arg.String (fun s -> libdir := s), " path to libdir"):: Util.parse_tag "-debug" (fun tag -> match Debug_gen.parse !debug tag with | None -> false | Some d -> debug := d ; true) Debug_gen.tags "specify debugged part":: Util.parse_tag "-arch" (fun tag -> match Archs.parse tag with | None -> false | Some a -> arch := a ; true) Archs.tags "specify architecture":: ("-bell", Arg.String (fun f -> arch := Archs.lisa ; bell := Some f), " read bell file , implies -arch LISA"):: Util.parse_tag "-scopes" (fun tag -> match Scope.parse tag with | None -> false | Some a -> scope := a; true) Scope.tags " specifiy scope tree":: Util.parse_tag "-type" (fun tag -> match TypBase.parse tag with | None -> false | Some a -> typ := a ; true) TypBase.tags (sprintf "specify base type, default %s" (TypBase.pp !typ)):: Util.parse_tags "-variant" (fun tag -> match Variant_gen.parse tag with | None -> false | Some v0 -> let open Variant_gen in let ov = let ov = !variant in match v0 with | Mixed -> (* Special case: Mixed cancels FullMixed *) (function | FullMixed -> false | v-> ov v) | KVM -> (* Special case: KVM cancels FullKVM *) (function | FullKVM -> false | v-> ov v) | _ -> ov in variant := (fun v -> v = v0 || ov v) ; true) Variant_gen.tags (sprintf "specify variant"):: ("-hexa", Arg.Unit (fun () -> hexa := true),"hexadecimal output"):: ("-o", Arg.String (fun s -> tarfile := Some s), " output litmus tests in archive (default, output in curent directory)"):: ("-c", Arg.Bool (fun b -> canonical_only := b), sprintf " avoid equivalent cycles (default %b)" !canonical_only):: ("-list", Arg.Unit (fun () -> show := Some ShowGen.Edges), "list accepted edge syntax and exit"):: ("-show", Arg.String (fun s -> show := Some (ShowGen.parse s)), " list accepted edges, annotations or fences, and exit"):: ("-switch", Arg.Set Misc.switch, "switch something"):: ("-obs", Arg.String (fun s -> do_observers := parse_do_observers s), " enable observers (default avoid)"):: ("-obstype", Arg.String (fun s -> obs_type := parse_obs_type s), " style of observers (default fenced)"):: ("-optcond", Arg.Set optcond, " optimize conditions (default)"):: ("-nooptcond", Arg.Clear optcond, "do not optimize conditions"):: ("-optcoherence", Arg.Set optcoherence, " optimize coherence"):: ("-nooptcoherence", Arg.Clear optcoherence, "do not optimize coherence (default)"):: ("-metadata",Arg.Bool (fun b -> metadata := b), sprintf "output metadata, default %b" !metadata):: ("-info",Arg.String add_info_line,"add metadata to generated test(s)"):: ("-moreedges", Arg.Bool (fun b -> moreedges := b), Printf.sprintf "consider a very complete set of edges, default %b" !moreedges):: ("-realdep", Arg.Bool (fun b -> realdep := b), Printf.sprintf "output \"real\" dependencies, default %b" !moreedges):: ("-overload", Arg.Int (fun n -> overload := Some n), " stress load unit by useless loads"):: ("-unrollatomic",Arg.Int (fun i -> unrollatomic := Some i), " unroll atomic idioms (default, use loops)"):: ("-ua",Arg.Int (fun i -> unrollatomic := Some i), " shorthand for -unrollatomic "):: ("-poll",Arg.Bool (fun b -> poll := b), " poll on loaded values, as much as possible"):: ("-check",Arg.Bool (fun b -> docheck := b), " check loaded values in test code"):: ("-neg", Arg.Bool (fun b -> neg := b), " negate final condition (default false)"):: ("-coherence_decreasing", Arg.Unit (fun () -> ()), " does nothing, deprecated"):: ("-oneloc", Arg.Set same_loc, "Do not fail on tests with one single location (default false)"):: ("-cond", Arg.String (fun s -> cond := parse_cond s), " style of final condition, default cycle"):: ("-unicond", Arg.Unit (fun () -> cond := Unicond), "alias for -cond unicond (deprecated)"):: ("-oh", Arg.String (fun n -> hout := Some n), " save a copy of hints"):: ("-addnum", Arg.Bool (fun n -> addnum := n), sprintf " complete test name with number when identical (default %b)" !addnum):: ("-name",Arg.String (fun s -> name := Some s), " specify base name of tests"):: ("-sufname",Arg.String (fun s -> sufname := Some s), " specify test name suffix"):: ("-lowercase", Arg.Bool (fun b -> lowercase := b), sprintf " generate lowercase family names (default %b)" !lowercase):: ("-fmt",Arg.Int (fun i -> fmt := i), sprintf " size of integer added to base name that yield test names (default %i)" !fmt):: ("-no", Arg.String (fun s -> no := Some s), " do not generate tests for these cycles"):: ("-stdout", Arg.Bool (fun b -> stdout := b), "output to stdout. If Cycleonly is true, then this is implied to be true. (default false)"):: ("-cycleonly", Arg.Bool (fun b -> cycleonly := b), "output only cycle, i.e. no litmus body (default false)"):: [] let numeric = ref true let speclist () = common_specs () @ ("-num", Arg.Bool (fun b -> numeric := b), sprintf " use numeric names (default %b)" !numeric):: ("-mode", Arg.String (fun s -> mode := parse_mode s), sprintf "<%s> running mode (default %s). Modes thin and uni are experimental." (String.concat "|" Code.checks) (Code.pp_check !mode) ):: ("-cumul", Arg.String (fun b -> cumul := parse_cumul b), " allow non-explicit fence cumulativity for specified fenced (default all)"):: ("-conf", Arg.String (fun s -> conf := Some s), " read configuration file"):: ("-size", Arg.Int (fun n -> size := n), sprintf " set the maximal size of cycles (default %i)" !size):: ("-exact", Arg.Clear upto, " produce cycle of size exactly "):: ("-nprocs", Arg.Int (fun n -> nprocs := n), sprintf " reject tests with more than threads (default %i)" !nprocs):: ("-eprocs", Arg.Set eprocs, "produce tests with exactly threads (default disabled)"):: ("-ins", Arg.Int (fun n -> max_ins := n), sprintf " max number of edges per proc (default %i)" !max_ins):: ("-one", Arg.Unit (fun _ -> one := true), " specify a sole cycle"):: ("-prefix", Arg.String (fun s -> prefix := s :: !prefix), " specify a prefix for cycles, can be repeated"):: ("-relax", Arg.String (fun s -> relaxs := !relaxs @ [s]), " specify a relax list"):: ("-mix", Arg.Bool (fun b -> mix := b), sprintf " mix relaxations when several are given (default %b)" !mix):: ("-maxrelax", Arg.Int (fun n -> mix := true ; max_relax := n), sprintf " test up to different relaxations together (default %i). Implies -mix true." !max_relax):: ("-minrelax", Arg.Int (fun n -> mix := true ; min_relax := n), sprintf " test relaxations considering or more different relaxations (default %i). Implies -mix true." !min_relax):: ("-safe", Arg.String (fun s -> safes := !safes @ [s]), " specify a safe list"):: ("-relaxlist", Arg.String (fun s -> safes := !safes @[s]), " specify a list of relaxations of interest (alias for -safe)"):: ("-rejectlist", Arg.String (fun s -> rejects := Some s), " specify a list of relaxation combinations to reject from generation"):: [] let varatom = ref ([] : string list) let varatomspec = ("-varatom", Arg.String (fun s -> varatom := !varatom @ [s]), " specify atom variations") let prog = if Array.length Sys.argv > 0 then Sys.argv.(0) else "XXX" let baseprog = sprintf "%s (version %s)" (Filename.basename prog) (Version.version) let usage_msg = "Usage: " ^ prog ^ " [options]*" let read_no fname = try Misc.input_protect (fun chan -> MySys.read_list chan (fun s -> Some s)) fname with _ -> [] let read_bell libfind fname = let module R = ReadBell.Make (struct let debug_lexer = false let debug_model = false let debug_files = false let verbose = !verbose let libfind = libfind let compat = false let prog = prog let variant = Misc.delay_parse !variant Variant_gen.parse end) in R.read fname let parse_annots lines = match lines with | [] -> None | _ -> let module P = Annot.Make (struct let debug = !debug.Debug_gen.lexer end) in Some (P.parse lines) (* Dereference config variables into a config module for Lisa *) module ToLisa = functor (O:sig val debug : Debug_gen.t ref val verbose : int ref val prog : string val bell : string option ref val varatom : string list ref val variant : (Variant_gen.t -> bool) ref end) -> struct let debug = !O.debug let verbose = !O.verbose let libdir = !libdir let prog = O.prog let bell = !O.bell let varatom = !O.varatom let variant = !O.variant end herd-herdtools7-1ca343e/gen/critical.ml000066400000000000000000000115431475314470400200430ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Serves as an example of using DumpAll *) (* "./critical n" outputs critical tests on n procs. *) open Misc open Printf open Archs (* Configuration *) let () = Config.nprocs := 1000 let () = Config.numeric := false let opts = Config.common_specs @ ("-num", Arg.Bool (fun b -> Config.numeric := b), sprintf " use numeric names, default %b" !Config.numeric):: [] module type Config = sig include Top.Config include DumpAll.Config val cpp : bool val docheck : bool end module Make(O:Config) (M:Builder.S) = struct (********) let rfe = M.E.parse_edge "Rfe" let fre = M.E.parse_edge "Fre" let coe = M.E.parse_edge "Wse" (* direct coms *) let coms = [rfe; fre; coe ;] (* coms through a write on another proc *) let coms2 = [[coe;rfe;];[fre;rfe]] let po = M.E.parse_edge "Pod**" module D = DumpAll.Make(O)(M) let zyva n0 = let gen kont = let rec do_rec k n es = if n < 0 then k (* es is too long *) else if n=0 then (* es is ok *) kont es D.no_info D.no_name k else (* recurse *) let k = List.fold_left (fun k com -> do_rec k (n-1) (com::po::es)) k coms in let k = List.fold_left (fun k com -> do_rec k (n-2) (com@po::es)) k coms2 in k in fun k -> do_rec k n0 [] in D.all gen end let size = ref 2 let () = Util.parse_cmdline opts (fun x -> size := int_of_string x) let cpp = match !Config.arch with | CPP -> true | _ -> false let () = let module Co = struct (* Dump all *) let verbose = !Config.verbose let hout = match !Config.hout with | None -> Hint.none | Some n -> Hint.open_out n let family = !Config.name let canonical_only = !Config.canonical_only let fmt = !Config.fmt let no = match !Config.no with | None -> [] | Some fname -> Config.read_no fname let cond = !Config.cond let tarfile = !Config.tarfile let addnum = !Config.addnum let numeric = !Config.numeric let lowercase = !Config.lowercase let coherence_decreasing = !Config.coherence_decreasing let optcoherence = !Config.optcoherence let optcond = !Config.optcond let poll = !Config.poll let fno = !Config.fno let overload = !Config.overload let obs_type = !Config.obs_type let do_observers = !Config.do_observers let eprocs = !Config.eprocs let nprocs = !Config.nprocs let neg = !Config.neg (* Specific *) let cpp = cpp let docheck = !Config.docheck end in let module Build = Make(Co) in let module C = struct let verbose = !Config.verbose let list_edges = !Config.list_edges let coherence_decreasing = !Config.coherence_decreasing let same_loc = !Config.same_loc || (match Co.cond with | Config.Unicond -> true | _ -> false) let sta = !Config.sta let unrollatomic = !Config.unrollatomic let allow_back = true end in (match !Config.arch with | X86 -> let module T = Top.Make(Co) in let module M = Build(T(X86Compile.Make(V)(C))) in M.zyva | PPC -> let module T = Top.Make(Co) in let module M = Build(T(PPCCompile.Make(V)(C)(PPCArch_gen.Config))) in M.zyva | ARM -> let module T = Top.Make(Co) in let module M = Build(T(ARMCompile.Make(V)(C))) in M.zyva | C|CPP as a -> let module CoC = struct include Co include C let typ = !Config.typ let cpp = match a with CPP -> true | _ -> false end in let module T = CCompile.Make(CoC) in let module M = Build(T) in M.zyva ) !size herd-herdtools7-1ca343e/gen/cycle.ml000066400000000000000000001243411475314470400173510ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Printf open Code module type S = sig type fence type edge module SIMD : Atom.SIMD type atom module PteVal : PteVal_gen.S with type pte_atom = atom type event = { loc : loc ; ord : int; tag : int ; ctag : int; cseal : int; dep : int ; v : v ; (* Value read or written *) vecreg: v list list ; (* Alternative for SIMD *) ins : int ; dir : dir option ; proc : Code.proc ; atom : atom option ; rmw : bool ; cell : v array ; (* Content of memory, after event *) tcell : v array ; (* value of tag memory after event *) bank : SIMD.atom Code.bank ; idx : int ; pte : PteVal.t ; } val evt_null : event val make_wsi : int -> Code.loc -> event val debug_evt : event -> string module OrderedEvent : Set.OrderedType with type t = event module EventMap : MyMap.S with type key = event val union_map : 'a EventMap.t -> 'a EventMap.t -> 'a EventMap.t type node = { mutable evt : event ; mutable edge : edge ; mutable next : node ; mutable prev : node ; mutable store : node ; } val nil : node val str_node : node -> string val debug_cycle : out_channel -> node -> unit (* Find, may raise Not_found *) val find_node : (node -> bool) -> node -> node val find_node_prev : (node -> bool) -> node -> node (* First node a strict po-predecessor of second node. *) val po_pred : node -> node -> bool val find_prev_code_write : node -> string val find_edge : (edge -> bool) -> node -> node val find_edge_prev : (edge -> bool) -> node -> node val find_non_insert_store : node -> node val find_non_insert_store_prev : node -> node val find_non_pseudo : node -> node val find_non_pseudo_prev : node -> node (* Generic fold *) val fold : (node -> 'a -> 'a) -> node -> 'a -> 'a (* Extract wide accesses from cycle. Size as number of integers *) val get_wide : node -> int StringMap.t (* Extract pair accesses from cycle. *) val get_pair : node -> StringSet.t (* Re-extract edges out of cycle *) val extract_edges : node -> edge list (* Resolve edge direction and build cycle *) val resolve_edges : edge list -> edge list * node (* Finish edge cycle, adding complete events, returns initial environment *) val finish : node -> (string * Code.v) list (* Composition of the two more basic steps above *) val make : edge list -> edge list * node * Code.env (* split cycle amoungst processors *) val split_procs : node -> node list list (* Return coherence orders *) val coherence : node -> (string * (node * IntSet.t) list list) list (* Return last pteval in pte accesses coherence *) val last_ptes : node -> (string * PteVal.t) list (* All locations *) val get_globals : ?init:Code.env -> node -> string list (* All (modified) code labels *) val get_labels : node -> string list end module type Config = sig val same_loc : bool val verbose : int (* allow threads s.t. start -> end is against com+ *) val allow_back : bool val naturalsize : MachSize.sz val hexa : bool val variant : Variant_gen.t -> bool end module Make (O:Config) (E:Edge.S) : S with type fence = E.fence and type edge = E.edge and module SIMD = E.SIMD and type atom = E.atom and module PteVal = E.PteVal = struct let dbg = false let do_memtag = O.variant Variant_gen.MemTag let do_morello = O.variant Variant_gen.Morello let do_kvm = Variant_gen.is_kvm O.variant let do_neon = O.variant Variant_gen.Neon let do_sve = O.variant Variant_gen.SVE let do_sme = O.variant Variant_gen.SME type fence = E.fence type edge = E.edge module SIMD = E.SIMD type atom = E.atom module PteVal = E.PteVal type event = { loc : loc ; ord : int; tag : int; ctag : int; cseal : int; dep : int; v : v ; vecreg: v list list ; ins : int ; dir : dir option ; proc : Code.proc ; atom : atom option ; rmw : bool ; cell : v array ; (* value of cell at node exit *) tcell : v array ; (* value of tag cell at node exit *) bank : SIMD.atom Code.bank ; idx : int ; pte : PteVal.t } let pte_default = PteVal.default "*" let evt_null = { loc=Code.loc_none ; ord=0; tag=0; ctag=0; cseal=0; dep=0; vecreg= []; v=(-1) ; ins=0;dir=None; proc=(-1); atom=None; rmw=false; cell=[||]; tcell=[||]; bank=Code.Ord; idx=(-1); pte=pte_default; } let make_wsi idx loc = { evt_null with dir=Some W ; loc=loc; idx=idx; v=0;} module OrderedEvent = struct type t = event let compare e1 e2 = Misc.int_compare e1.idx e2.idx end module EventMap = MyMap.Make(OrderedEvent) let union_map m1 m2 = EventMap.union (fun _n1 _n2 -> assert false) m1 m2 type node = { mutable evt : event ; mutable edge : edge ; (* NB evt is the source of edge *) mutable next : node ; mutable prev : node ; mutable store : node ; } let debug_dir d = match d with Some W -> "W" | Some R -> "R" | Some J -> "J" | None -> "_" let debug_atom a = match a with None -> "" | Some a -> E.pp_atom a let debug_tag = if do_memtag then fun e -> sprintf " (tag=%i)" e.tag else fun _ -> "" let debug_morello = if do_morello then fun e -> sprintf " (ord=%i) (ctag=%i) (cseal=%i) (dep=%i)" e.ord e.ctag e.cseal e.dep else fun _ -> "" let debug_vector = if do_neon || do_sve || do_sme then let pp_one = Code.add_vector O.hexa in fun e -> sprintf " (vecreg={%s})" (String.concat "," (List.map pp_one e.vecreg)) else fun _ -> "" let debug_val = Code.pp_v ~hexa:O.hexa let debug_vec v = String.concat ", " (List.map debug_val (Array.to_list v)) let debug_evt e = let pp_v = match e.bank with | Pte -> PteVal.pp e.pte | (Ord|Pair|Tag|CapaTag|CapaSeal|VecReg _|Instr) -> debug_val e.v in sprintf "%s%s %s %s%s%s%s%s" (debug_dir e.dir) (debug_atom e.atom) (Code.pp_loc e.loc) (match debug_vec e.cell with | "" -> "" | s -> "cell=[" ^ s ^"] ") pp_v (debug_tag e) (debug_morello e) (debug_vector e) let debug_edge = E.pp_edge let rec nil = { evt = evt_null ; edge = E.plain_edge (E.Po (Diff,Irr,Irr)) ; next = nil ; prev = nil ; store = nil ; } let debug_node chan n = if n.store != nil then begin let n = n.store in fprintf chan "[%s %s]" (debug_edge n.edge) (debug_evt n.evt) end ; fprintf chan "%s -%s->" (debug_evt n.evt) (debug_edge n.edge) let str_node n = sprintf "%s -%s->" (debug_evt n.evt) (debug_edge n.edge) let debug_nodes chan ns = let rec iter chan = function | [] -> () | [n] -> debug_node chan n | n::ns -> fprintf chan "%a,%a" debug_node n iter ns in iter chan ns let debug_cycle chan n = let rec do_rec m = debug_node chan m ; output_char chan '\n' ; if m.next != n then do_rec m.next in do_rec n ; flush chan let do_alloc_node idx e = { evt = { evt_null with idx = idx ;} ; edge = e ; next = nil ; prev = nil ; store = nil ; } let alloc_node idx e = let n = do_alloc_node idx e in n,idx+1 (* Add a node to non-empty cycle *) let cons_cycle n c = n.next <- c ; n.prev <- c.prev ; c.prev.next <- n ; c.prev <- n ; n let check_balance = let rec do_rec r = function | [] -> r = 0 | e::es -> do_rec (match e.E.edge with E.Back _ -> r-1 | E.Leave _ -> r+1 | _ -> r) es in do_rec 0 let build_cycle = let rec do_rec idx es = match es with | [] -> assert false (* Empty cycle is absurd *) | [e] -> let n,_ = alloc_node idx e in n.next <- n ; n.prev <- n ; n | e::es -> let n,idx = alloc_node idx e in cons_cycle n (do_rec idx es) in fun es -> if not (check_balance es) then Warn.fatal "Leave/Back are not balanced" ; let c = do_rec 0 es in c let find_node p n = let rec do_rec m = if p m then m else let m = m.next in if m == n then raise Not_found else do_rec m in do_rec n let find_node_prev p n = let rec do_rec m = if p m then m else let m = m.prev in if m == n then raise Not_found else do_rec m in do_rec n (* n and m are on the same thread, n being strictly before m *) let po_pred n m = if dbg then eprintf "po_pred: n=[%a], m=[%a]\n%!" debug_node n debug_node m ; let rec do_rec p = if dbg then eprintf " pred_rec, node %a\n%!" debug_node p ; if p == m then true else if E.is_ext p.edge || p.next == n then false else do_rec p.next in do_rec n.next let find_prev_code_write n = let rec do_rec m = if dbg then eprintf "find_prev_code_write, n=%a m=%a\n%!" debug_node n debug_node m ; let e = m.evt in match e.loc,E.safe_dir m.edge with | Code c,Some W -> (* Avoid the case where the cachesync is po-before the code write... *) begin if po_pred n m then raise Not_found end ; c | _,_ -> let m = m.prev in if m == n then raise Not_found else do_rec m in do_rec n let find_edge p = find_node (fun n -> p n.edge) let find_edge_prev p = find_node_prev (fun n -> p n.edge) let non_insert_store e = not (E.is_insert_store e.E.edge) let find_non_insert_store m = find_edge non_insert_store m let find_non_insert_store_prev m = find_edge_prev non_insert_store m let non_pseudo e = E.is_non_pseudo e.E.edge let find_non_pseudo m = find_edge non_pseudo m let find_non_pseudo_prev m = find_edge_prev non_pseudo m (* generic scan *) let fold f m k = let rec fold_rec n k = let k = f n k and nxt = n.next in if nxt == m then k else fold_rec nxt k in fold_rec m k (* Get size (as integers) from annotations *) let as_integers n = match n.evt.loc with | Data loc -> begin match E.as_integers n.edge with | Some sz -> Some (loc,sz) | None -> None end | Code _ -> None let get_wide_list ns = List.fold_left (fun k n -> match as_integers n with | Some (_,n) -> max n k | None -> k) 0 ns let get_wide m = fold (fun n k -> match as_integers n with | Some (loc,sz) -> let sz0 = StringMap.safe_find 0 loc k in StringMap.add loc (max sz0 sz) k | None-> k) m StringMap.empty let is_pair n = match n.evt.loc with | Data loc -> if E.is_pair n.edge then Some loc else None | Code _ -> None let get_pair m = fold (fun n k -> match is_pair n with | Some loc -> StringSet.add loc k | None -> k) m StringSet.empty (* Add events in nodes *) module Env = Map.Make(String) let locs,next_x = let t = Array.make 26 "" in t.(0) <- "x" ; t.(1) <- "y" ; t.(2) <- "z" ; for k=0 to (26-3)-1 do t.(k+3) <- String.make 1 (Char.chr (Char.code 'a' + k)) done ; t,t.(1) let locs_len = Array.length locs let make_loc n = if n < locs_len then locs.(n) else Printf.sprintf "x%02i" (n-locs_len) let next_loc e ((loc0,lab0),vs) = match E.is_fetch e with | true -> Code (sprintf "Lself%02i" lab0),((loc0,lab0+1),vs) | _ -> Code.Data (make_loc loc0),((loc0+1,lab0),vs) let same_loc e = match E.loc_sd e with | Same -> true | Diff -> false let diff_loc e = not (same_loc e) let same_proc e = E.get_ie e = Int let diff_proc e = E.get_ie e = Ext (* Coherence definition *) module CoSt = struct module M = MyMap.Make (struct type t = E.SIMD.atom Code.bank let compare = compare end) type t = { map : int M.t; co_cell : int array; } let (<<) f g = fun x -> f (g x) and ( assert false let get_co st bank = find_no_fail bank st.map let set_co st bank v = let b = match bank with VecReg _ -> Ord | _ -> bank in { st with map=M.add b v st.map; } let get_cell st = st.co_cell let set_cell st n = let e = n.evt in match e.bank with | Ord|Pair -> begin let old = st.co_cell.(0) in let co_cell = Array.copy st.co_cell in let cell2 = match n.prev.edge.E.edge with | E.Rmw rmw -> let old = E.extract_value old n.prev.evt.atom in E.compute_rmw rmw old e.v | _ -> e.v in begin match e.bank with | Ord -> co_cell.(0) <- E.overwrite_value old e.atom cell2 | Pair -> (* No Rmw for pairs *) co_cell.(0) <- E.overwrite_value old e.atom (e.v-1); let old = st.co_cell.(0) in co_cell.(1) <- E.overwrite_value old e.atom e.v | _ -> assert false end ; {e with cell=co_cell;},{ st with co_cell; } end | _ -> e,st let set_tcell st e = match e.bank with | Tag -> {e with tcell=[| e.v; |];},st | _ -> e,st let next_co st bank = match bank with | VecReg n -> let v = find_no_fail Ord st.map in { st with map=M.add Ord (v+E.SIMD.nregs n) st.map; } | _ -> let v = find_no_fail bank st.map in { st with map=M.add bank (v+1) st.map; } let step_simd st n = let fst = find_no_fail Ord st.map in let lst = fst+E.SIMD.nregs n in { co_cell=E.SIMD.step n fst st.co_cell; map=M.add Ord lst st.map;} end let pte_val_init loc = match loc with | Code.Data loc when do_kvm -> PteVal.default loc | _ -> pte_default (****************************) (* Add events in edge cycle *) (****************************) (* Put directions into edge component of nodes, for easier access *) let rec next_dir m = match m.next.evt.dir with | None -> next_dir m.next | Some d -> d let patch_edges n = let rec do_rec m = let e = match m.evt.dir with | None -> m.edge | Some d -> E.set_src d (E.set_tgt (next_dir m) m.edge) in m.edge <- e ; if m.next != n then do_rec m.next in do_rec n (* Merge annotations *) exception FailMerge let merge2 a1 a2 = match a1,a2 with | (None,Some a) | (Some a,None) when E.is_ifetch (Some a) -> raise FailMerge | (None,a)|(a,None) -> a | Some a1,Some a2 -> match E.merge_atoms a1 a2 with | None -> raise FailMerge | Some _ as r -> r let merge_annotations m = let rec do_rec n = let e = n.edge in if non_insert_store e then begin let p = find_non_insert_store_prev n.prev in if O.verbose > 0 then Printf.eprintf "Merge p=%a, n=%a\n" debug_node p debug_node n ; let pe = p.edge in let a2 = pe.E.a2 and a1 = e.E.a1 in try let a = merge2 a2 a1 in p.edge <- { pe with E.a2=a ; } ; n.edge <- { e with E.a1=a ; } ; if O.verbose > 1 then Printf.eprintf " => p=%a, n=%a\n" debug_node p debug_node n with FailMerge -> Warn.fatal "Impossible annotations: %s %s" (E.pp_edge pe) (E.pp_edge e) end ; if n.next != m then do_rec n.next in do_rec m (* Set directions of events *) let is_rmw_edge e = match e.E.edge with | E.Rmw _ ->true | _ -> false let is_rmw d e = match d with | R -> is_rmw_edge e.edge | W -> is_rmw_edge e.prev.edge | J -> is_rmw_edge e.edge let is_com_rmw n0 = E.is_com n0.edge || is_rmw_edge n0.edge let remove_store n0 = let n0 = try find_non_insert_store n0 with Not_found -> Warn.user_error "I cannot believe it" in let rec do_rec m = begin match m.edge.E.edge with | E.Store -> let prev = find_non_insert_store_prev m and next = find_non_insert_store m in prev.next <- next ; next.prev <- prev ; m.evt <- { m.evt with dir = Some W; } ; next.store <- m | E.Node W -> (* Also remove isolated W nodes, before computing values *) let prev = m.prev and next = m.next in prev.next <- next ; next.prev <- prev | _ -> () end ; if m.next != n0 then do_rec m.next in do_rec n0 ; n0 let set_dir n0 = let rec do_rec m = if non_insert_store m.edge then begin let my_d = E.dir_src m.edge in let p = find_non_insert_store_prev m.prev in if E.is_node m.edge.E.edge then begin (* perform sanity checks specific to Node pseudo-edge *) if E.is_node p.edge.E.edge then begin Warn.fatal "Double 'Node' pseudo edge %s %s" (E.pp_edge p.edge) (E.pp_edge m.edge) end ; let n = find_non_insert_store m.next in if not (E.is_ext p.edge && E.is_ext n.edge) then Warn.fatal "Node pseudo edge %s appears in-between %s..%s (one neighbour at least must be an external edge)" (E.pp_edge m.edge) (E.pp_edge p.edge) (E.pp_edge n.edge) end ; (* eprintf "p=%a, m=%a\n" debug_node p debug_node m ; *) let prev_d = E.dir_tgt p.edge in let d = match prev_d,my_d with | Irr,Irr -> Warn.fatal "Ambiguous direction %s %s" (E.pp_edge p.edge) (E.pp_edge m.edge) | (Dir d,Irr)|(Irr,Dir d) -> d (* | Dir W,Dir R when is_rmw W m -> R *) | Dir d1,Dir d2 -> if d1=d2 then d1 else Warn.fatal "Impossible direction %s[%s] %s[%s]" (str_node p) (pp_extr prev_d) (str_node m) (pp_extr my_d) | (NoDir,_)|(_,NoDir) -> assert false in let a = let a2 = p.edge.E.a2 and a1 = m.edge.E.a1 in if E.compare_atomo a1 a2 = 0 then a1 else if a1 = None && E.is_ext p.edge then a2 else if a2 = None && E.is_ext m.edge then a1 else Warn.fatal "Impossible atomicity %s %s" (E.pp_edge p.edge) (E.pp_edge m.edge) in let rmw = is_rmw d m in m.evt <- { m.evt with dir=Some d; atom=a; rmw=rmw} end else begin let p = find_non_pseudo_prev m.prev and n = find_non_pseudo m.next in (* eprintf "[%a] in [%a]..[%a]\n" debug_node m debug_node p debug_node n ; *) if not (E.is_ext p.edge || E.is_po_or_fenced_joker p.edge || E.is_ext n.edge || E.is_po_or_fenced_joker n.edge) then begin Warn.fatal "Insert pseudo edge %s appears in-between %s..%s (at least one neighbour must be an external edge)" (E.pp_edge m.edge) (E.pp_edge p.edge) (E.pp_edge n.edge) end; match p.edge.E.edge with | (E.Rf Ext | E.Fr Ext) -> Warn.fatal "Insert pseudo edge %s appears after external communication edge %s" (E.pp_edge m.edge) (E.pp_edge p.edge) | _ -> () end ; if m.next != n0 then do_rec m.next in do_rec n0 ; patch_edges n0 ; if O.verbose > 1 then begin eprintf "DIRECTIONS\n" ; debug_cycle stderr n0 end (***************************) (* Set locations of events *) (***************************) let is_read_same_fetch m = let check n = (n != m && (loc_compare n.evt.loc m.evt.loc) = 0 && n.evt.dir = Some R && (E.is_ifetch n.edge.E.a1)) in try ignore (find_node_prev (fun n -> check n) m); true with Not_found -> false let check_fetch n0 = let rec do_rec m = (* ensure Instr read is followed or preceded by plain read to same location*) begin match m.evt.loc, m.evt.dir with | Code.Code _, Some R when (E.is_ifetch m.edge.E.a1) -> if is_read_same_fetch m then begin Warn.user_error "Multiple ifetch reads to same code location [%s]" (str_node m) end; | Code.Code _, Some R when not (E.is_ifetch m.edge.E.a1) -> if not (is_read_same_fetch m) then begin Warn.user_error "Reading from label that doesn't exist [%s]" (str_node m) end; | Code.Code _, Some W when (E.is_ifetch m.edge.E.a1) -> Warn.user_error "Writing non-instruction value to code location: [%s]" (str_node m) | _ -> (); end; if m.next != n0 then do_rec m.next in do_rec n0 (* Loc is changing *) let set_diff_loc st n0 = let rec do_rec st p m = let loc,st = if same_loc p.edge then begin p.evt.loc,st end else let n1 = try find_node (fun n -> (if not (same_loc n.prev.edge) then raise Not_found); E.is_ifetch n.edge.E.a1 ) m.next with Not_found -> try find_node_prev (fun n -> (if not (same_loc n.edge) then raise Not_found); E.is_ifetch n.edge.E.a2 ) m.prev with Not_found -> m in next_loc n1.edge st in m.evt <- { m.evt with loc=loc ; bank=E.atom_to_bank m.evt.atom; } ; (* eprintf "LOC SET: %a [p=%a]\n%!" debug_node m debug_node p; *) if m.store != nil then begin m.store.evt <- { m.store.evt with loc=loc ; bank=Ord; } end ; if m.next != n0 then do_rec st p.next m.next else begin if m.evt.loc = n0.evt.loc then Warn.fatal "Cannot get changing loc accros %s\n" (E.pp_edge m.edge) ; st end in let p = n0.prev in assert (not (same_loc p.edge)) ; do_rec st p n0 (* Loc is not changing *) let set_same_loc st n0 = let n1 = try find_node (fun n -> E.is_com n.edge) n0 with Not_found -> n0 in let loc,st = next_loc n1.edge st in let rec do_rec m = m.evt <- { m.evt with loc=loc; bank=E.atom_to_bank m.evt.atom; } ; if m.store != nil then begin m.store.evt <- { m.store.evt with loc=loc; bank=Ord; } end ; if m.next != n0 then do_rec m.next in do_rec n0 ; st (* Set the values of write events *) let split_by_loc n = let rec do_rec m = let r = if m.next == n then begin assert (m.evt.loc <> m.next.evt.loc) ; [[]] end else do_rec m.next in if m.evt.loc = m.next.evt.loc then match r with | ms::rem -> (m::ms)::rem | [] -> assert false else [m]::r in do_rec n let split_one_loc n = let rec do_rec m = m:: if m.next == n then [] else do_rec m.next in [do_rec n] let tr_value e v = E.tr_value e.atom v let set_write_val_ord st n = let st = CoSt.next_co st Ord in let v = CoSt.get_co st Ord in n.evt <- { n.evt with v = tr_value n.evt v; } ; (* Writing Ord resets morello tag *) let st = CoSt.set_co st CapaTag evt_null.ctag in let e,st = CoSt.set_cell st n in n.evt <- e ; st (* do_set_write_val returns true when variable next_x has been used and should thus be initialised *) let rec do_set_write_val next_x_ok st pte_val = function | [] -> next_x_ok | n::ns -> let st = if n.store == nil then st else set_write_val_ord st n.store in begin if Code.is_data n.evt.loc then begin if do_memtag then let tag = CoSt.get_co st Tag in n.evt <- { n.evt with tag=tag; } else if do_morello then let ord = CoSt.get_co st Ord in let ctag = CoSt.get_co st CapaTag in let cseal = CoSt.get_co st CapaSeal in n.evt <- { n.evt with ord=ord; ctag=ctag; cseal=cseal; } end else begin let instr = CoSt.get_co st Instr in n.evt <- { n.evt with ins=instr} end (* else if do_neon then (* set both fields, it cannot harm *) let ord = get_co st Ord in let v = get_co st VecReg in let vecreg = [|v;v;v;v;|] in n.evt <- { n.evt with ord=ord; vecreg=vecreg; } *) end ; begin match n.evt.dir with | Some W -> begin match n.evt.loc with | Data _ -> let bank = n.evt.bank in begin match bank with | Instr -> Warn.fatal "instruction annotation to data bank not possible?" | Ord -> let st = set_write_val_ord st n in do_set_write_val next_x_ok st pte_val ns | Pair -> (* Same code as for Ord, however notice that CoSet.set_cell has a case for pairs. However increment of current value is by 2 *) let cell = CoSt.get_cell st in assert (Array.length cell>=2) ; let st = CoSt.next_co st Ord in (* Pre-increment *) let st = set_write_val_ord st n in do_set_write_val next_x_ok st pte_val ns | Tag|CapaTag|CapaSeal -> let st = CoSt.next_co st bank in let v = CoSt.get_co st bank in n.evt <- { n.evt with v = v; } ; let e,st = CoSt.set_tcell st n.evt in n.evt <- e ; do_set_write_val next_x_ok st pte_val ns | VecReg a -> let st = CoSt.step_simd st a in let cell = CoSt.get_cell st in let vecreg = E.SIMD.read a cell in let v = match vecreg with | (v::_)::_ -> v | _ -> assert false in n.evt <- { n.evt with vecreg; cell;v;} ; do_set_write_val next_x_ok st pte_val ns | Pte -> let next_x_pred = ref false in let pte_val = if do_kvm then begin let next_loc () = match n.evt.loc with | Code.Data x -> begin try let m = find_node (fun m -> match m.evt.loc with | Code.Data y -> not (Misc.string_eq x y) | _-> false) n in Code.as_data m.evt.loc with Not_found -> next_x_pred := true ; next_x end | Code.Code _ -> assert false in E.set_pteval n.evt.atom pte_val next_loc end else pte_val in n.evt <- { n.evt with pte = pte_val; } ; do_set_write_val (!next_x_pred || next_x_ok) st pte_val ns end | Code _ -> let bank = n.evt.bank in begin match bank with | Instr -> Warn.fatal "not letting instr write happen" | Ord -> let st = CoSt.next_co st bank in let v = CoSt.get_co st bank in n.evt <- { n.evt with ins = v;} ; do_set_write_val next_x_ok st pte_val ns | _ -> do_set_write_val next_x_ok st pte_val ns end end | Some (R|J) |None -> do_set_write_val next_x_ok st pte_val ns end let set_all_write_val nss = let _,initvals = List.fold_right (fun ns (k,env as r) -> match ns with | [] -> r | n::_ -> let loc = n.evt.loc in let sz = get_wide_list ns in let i = if do_kvm then k else 0 in let next_x_ok = do_set_write_val false (CoSt.create ~init:i sz) (pte_val_init loc) ns in let env = if do_kvm then (Code.as_data loc,k)::env else env in if next_x_ok then k+8,(next_x,k+4)::env else k+4,env) nss (0,[]) in initvals let set_write_v n = let nss = try let m = find_node (fun m -> m.prev.evt.loc <> m.evt.loc && m.next.evt.loc = m.evt.loc) n in split_by_loc m with | Not_found -> (*check if node is preceded by a non com/rmw node and is itself a com/rmw node*) let to_com_rmw n0 = not (is_com_rmw n0.prev) && is_com_rmw n0 in fold (fun n0 _ -> if E.is_id n0.edge.E.edge then assert false) n (); try (* check for R ensures that we start on Fr or Rmw if possible*) let m = find_node (fun m -> to_com_rmw m && m.evt.dir = Some R) n in split_one_loc m with Not_found -> try (* The previous search failed. This search will return the W node from which an Rf edge starts, provided that the previous edge is not a communication or a Rmw edge *) let m = find_node (fun m -> to_com_rmw m) n in split_one_loc m with Not_found -> Warn.fatal "cannot set write values" | Exit -> Warn.fatal "cannot set write values" in let initvals = set_all_write_val nss in nss,initvals (* Loop over every node and set the expected value from the previous node *) let set_dep_v nss = let v = List.fold_left (fun k ns -> List.fold_left (fun v n -> n.evt <- { n.evt with dep=v; } ; n.evt.v) k ns) 0 nss in (if List.length nss > 0 then if List.length (List.hd nss) > 0 then let n = (List.hd (List.hd nss)) in n.evt <- { n.evt with dep=v; }) ; () (* TODO: this is wrong for Store CR's: consider Rfi Store PosRR *) let set_read_v n cell = let e = n.evt in let v = E.extract_value cell.(0) e.atom in (* eprintf "SET READ: cell=0x%x, v=0x%x\n" cell v ; *) let e = { e with v=v; } in n.evt <- e (* eprintf "AFTER %a\n" debug_node n *) let set_read_pair_v n cell = let e = n.evt in let v0 = E.extract_value cell.(0) e.atom and v1 = E.extract_value cell.(1) e.atom in let v = v0 + v1 in let e = { e with v=v; } in n.evt <- e let do_set_read_v = (* st keeps track of tags, cell and pte_cell are the current state of memory *) let rec do_rec st cell pte_cell = function | [] -> cell.(0),pte_cell | n::ns -> let cell = if n.store == nil then cell else n.store.evt.cell in let bank = n.evt.bank in begin match n.evt.dir with | Some R -> begin match bank with | Ord | Instr-> set_read_v n cell | Pair -> set_read_pair_v n cell | VecReg a -> let v = E.SIMD.read a cell in let v = E.SIMD.reduce v in n.evt <- { n.evt with v=v ; vecreg=[]; bank=Ord } | Tag|CapaTag|CapaSeal -> n.evt <- { n.evt with v = CoSt.get_co st bank; } | Pte -> n.evt <- { n.evt with pte = pte_cell; } end ; do_rec st cell pte_cell ns | Some W -> let st = match bank with | Tag|CapaTag|CapaSeal -> CoSt.set_co st bank n.evt.v | Pte|Ord|Pair|VecReg _| Instr -> if Code.is_data n.evt.loc then st else CoSt.set_co st bank n.evt.ins in do_rec st (match bank with | Ord|Pair|VecReg _ -> if Code.is_data n.evt.loc then n.evt.cell else cell | Tag|CapaTag|CapaSeal|Pte|Instr -> cell) (match bank with | Ord|Pair|Tag|CapaTag|CapaSeal|VecReg _|Instr -> pte_cell | Pte -> n.evt.pte) ns | None | Some J -> do_rec st cell pte_cell ns end in fun ns -> match ns with | [] -> assert false | n::_ -> let sz = get_wide_list ns in let st = CoSt.create sz in let cell = CoSt.get_cell st in do_rec st cell (pte_val_init n.evt.loc) ns let set_read_v nss = List.fold_right (fun ns k -> match ns with | [] -> k | n::_ -> let vf = do_set_read_v ns in (n.evt.loc,vf)::k) nss [] (* zyva... *) let finish n = let st = (0,0),Env.empty in (* Set locations *) let sd,n = let no = try Some (find_edge_prev diff_loc (find_edge_prev diff_proc n)) with Not_found -> None in match no with | Some n -> Diff, begin try find_edge same_loc n with Not_found -> Warn.fatal "This cycle changes location at every step" end | None -> Same,n in let _nv,_st = match sd with | Diff -> set_diff_loc st n | Same -> set_same_loc st n in if O.verbose > 1 then begin eprintf "LOCATIONS\n" ; debug_cycle stderr n end ; (* Set write values *) let by_loc,initvals = set_write_v n in if O.verbose > 1 then begin eprintf "INITIAL VALUES: %s\n" (String.concat "; " (List.map (fun (loc,k) -> sprintf "%s->%d" loc k) initvals)) ; eprintf "WRITE VALUES\n" ; debug_cycle stderr n end ; (* Set load values *) let vs = set_read_v by_loc in (* Set dependency values *) (if do_morello then set_dep_v by_loc) ; if O.verbose > 1 then begin eprintf "READ VALUES\n" ; debug_cycle stderr n ; eprintf "FINAL VALUES [%s]\n" (String.concat "," (List.map (fun (loc,(v,_pte)) -> sprintf "%s -> 0x%x" (Code.pp_loc loc) v) vs)) end ; if O.variant Variant_gen.Self then check_fetch n; initvals (* Re-extract edges, with irelevant directions solved *) let extract_edges n = let rec do_rec m = let k = if m.next == n then [] else do_rec m.next in let k = m.edge::k in let k = if m.store == nil then k else E.plain_edge m.store.edge.E.edge::k in k in do_rec n let resolve_edges = function | [] -> Warn.fatal "No edges at all!" | es -> let c = build_cycle es in merge_annotations c ; let c = remove_store c in set_dir c ; extract_edges c,c let make es = let es,c = resolve_edges es in let initvals = finish c in es,c,initvals (*************************) (* Gather events by proc *) (*************************) let find_start_proc n = let p = find_non_pseudo_prev n.prev in if diff_proc p.edge then p.next else let n = find_edge (fun n -> diff_proc n) n in try find_edge same_proc n with Not_found -> n let cons_not_nil k1 k2 = match k1 with | [] -> k2 | _::_ -> k1::k2 let find_proc t n = let rec array_rec j = assert (j < Array.length t) ; list_rec j t.(j) and list_rec j = function | [] -> array_rec (j+1) | m::ms -> if n == m then j else list_rec j ms in array_rec 0 let find_back n = let rec find_rec k m = match m.edge.E.edge with | E.Back _ -> if k = 0 then m else find_next (k-1) m | E.Leave _ -> find_next (k+1) m | _ -> find_next k m and find_next k m = if m.next == n then Warn.fatal "Non-matching Leave/Back" else find_rec k m.next in find_rec 0 n let merge_changes n nss = let t = Array.of_list nss in let rec do_rec m = match m.edge.E.edge with | E.Leave _ -> let i = find_proc t m in let back = find_back m.next in let j = find_proc t back.next in if i=j then Warn.fatal "Useless Leave/Back" ; t.(i) <- t.(i) @ t.(j) ; t.(j) <- [] ; do_next m | _ -> do_next m and do_next m = if m.next != n then do_rec m.next in do_rec n ; List.filter Misc.consp (Array.to_list t) let value_before v1 v2 = v1 < v2 let proc_back ns = match ns with | []|[_] -> false | fst::rem -> let lst = Misc.last rem in let e1 = fst.evt and e2 = lst.evt in e1.loc = e2.loc && value_before e2 e1 let debug_proc ns = String.concat " " (List.map (fun n -> sprintf "<%s>" (str_node n)) ns) let debug_procs nss = List.iter (fun ns -> eprintf "%s\n" (debug_proc ns)) nss let split_procs n = let n = try find_start_proc n with Not_found -> Warn.fatal "Cannot split in procs" in let rec do_rec m = let k1,k2 = if m.next == n then begin if same_proc m.edge then Warn.fatal "%s at proc end" (debug_edge m.edge) else [],[] end else do_rec m.next in if same_proc m.edge then m::k1,k2 else [m],cons_not_nil k1 k2 in let k1,k2 = do_rec n in let nss = cons_not_nil k1 k2 in let nss = merge_changes n nss in let rec num_rec k = function | [] -> () | ns::nss -> List.iter (fun n -> if n.store != nil then begin n.store.evt <- { n.store.evt with proc = k; } end ; n.evt <- { n.evt with proc = k; }) ns ; num_rec (k+1) nss in num_rec 0 nss ; if not O.allow_back && List.exists proc_back nss then Warn.fatal "Forbidden po vs. com" ; if O.verbose > 1 then begin eprintf "SPLITTED:\n" ; debug_procs nss end ; nss (****************************) (* Compute coherence orders *) (****************************) let rec group_rec x ns = function | [] -> [x,List.rev ns] | (y,n)::rem -> if Code.loc_compare x y = 0 then group_rec x (n::ns) rem else (x,List.rev ns)::group_rec y [n] rem let group = function | [] -> [] | (x,n)::rem -> group_rec x [n] rem let by_loc xvs = let r = group xvs in let r = List.stable_sort (fun (x,_) (y,_) -> Code.loc_compare x y) r in let r = List.map (fun (x,ns) -> match ns with | [] -> assert false | _::_ -> (x,ns)) r in group r (* find changing location *) let find_change n = let rec do_rec m = if m.evt.loc <> m.next.evt.loc then Some m.next else if m.next == n then None else do_rec m.next in do_rec n let do_get_writes pbank n = let rec do_rec m = let k = if m.next == n then [] else do_rec m.next in let e = m.evt in let k = match e.dir with | Some W -> if E.is_node m.edge.E.edge || not (pbank m.evt.bank) then k else (e.loc,m)::k | None| Some R | Some J -> k in if m.store == nil then k else begin let e = m.store.evt in if pbank e.bank then (e.loc,m.store)::k else k end in do_rec n let get_ord_writes = let open Code in do_get_writes (* Not so sure about capacity here... *) (function Ord|Tag|VecReg _|Pair|Instr -> true | CapaTag|CapaSeal|Pte -> false) let get_pte_writes = do_get_writes (function Code.Pte -> true | _ -> false) let to_tagloc = function | Data s -> Data (Misc.add_atag s) | Code s -> Code (Misc.add_atag s) let get_tag_locs (loc,n) = (to_tagloc loc,n) let get_observers n = let e = n.evt in assert (e.dir = Some W) ; let k = IntSet.empty in let k = if e.proc >= 0 then IntSet.add e.proc k else k in let k = match n.edge.E.edge with | E.Rf _ -> IntSet.add n.next.evt.proc k | _ -> k in k let coherence n = let r = match find_change n with | Some n -> let ord_ws = get_ord_writes n in (* MTE locations shadow normal locations, so we need * to track them separately. As we may be interested * in the same graph nodes, lets just duplicate and * label accordingly. *) let tag_ws = if do_memtag then List.map get_tag_locs (get_ord_writes n) else [] in let ws = ord_ws@tag_ws in if O.verbose > 1 then List.iter (fun (loc,n) -> eprintf "LOC=%s, node=%a\n" (Code.pp_loc loc) debug_node n) ws ; let r = by_loc ws in List.fold_right (fun (loc,ws) k -> match ws with | [] -> k | [ns] -> if O.verbose > 1 then Printf.eprintf "Standard write sequence on %s: %s\n" (Code.pp_loc loc) (String.concat " " (List.map str_node ns)) ; (loc,ws)::k | _ -> List.iter (fun ns -> eprintf "[%a]\n" debug_nodes ns) ws ; assert false) r [] | None -> if O.same_loc then match get_ord_writes n with | [] -> [] | (loc,_)::_ as xs -> [loc,[List.map snd xs]] else Warn.fatal "Unique location" in List.fold_right (fun (loc,ns) k -> match loc with | Data loc -> (loc, List.map (List.map (fun n -> n,get_observers n)) ns)::k | Code _ -> k) r [] let last_ptes n = match find_change n with | Some n -> let ws = get_pte_writes n in let r = by_loc ws in List.fold_right (fun (loc,ns) k -> match List.flatten ns with | []|[_]|_::_::_::_ -> k | [_;n;] -> let p = n.evt.pte in (Misc.add_pte (Code.as_data loc),p)::k) r [] | None -> [] (* Get all shared locations/labels *) let get_rec get m = let rec do_rec k n = if n.next == m then k else let k = get n.evt.loc k in do_rec k n.next in let locs = do_rec [] m in StringSet.elements (StringSet.of_list locs) let get_globals ?(init=[]) m = let init = List.map (fun (loc,_) -> loc) init in let code = get_rec (fun loc k -> match loc with Data loc -> loc::k | Code _ -> k) m in StringSet.elements (StringSet.of_list (init@code)) let get_labels m = get_rec (fun loc k -> match loc with Code loc -> loc::k | Data _ -> k) m end herd-herdtools7-1ca343e/gen/debug_gen.ml000066400000000000000000000033751475314470400201740ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Debug tags *) type t = { lexer : bool ; top : bool ; generator : bool ; model : bool ; files : bool ; } let tags = [ "lexer"; "top"; "generator";"gen"; "model"; "files"; ] let none = { lexer = false ; top = false ; generator = false ; model = false ; files = false ; } let parse t tag = match tag with | "lexer" -> Some { t with lexer = true; } | "top" -> Some { t with top = true; } | "generator"|"gen" -> Some { t with generator = true; } | "model" -> Some { t with model = true; } | "files"|"file" -> Some { t with files = true; } | _ -> None herd-herdtools7-1ca343e/gen/debug_gen.mli000066400000000000000000000025441475314470400203420ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Debug tags *) type t = { lexer : bool ; top : bool ; generator : bool ; model : bool ; files : bool ; } val none : t val tags : string list val parse : t -> string -> t option herd-herdtools7-1ca343e/gen/dep.ml000066400000000000000000000033771475314470400170270ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2011-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Power / ARM dependencies *) type dp = ADDR | DATA | CTRL | CTRLISYNC let fold_dpr f r = f ADDR (f CTRL (f CTRLISYNC r)) let fold_dpw f r = f ADDR (f DATA (f CTRL (f CTRLISYNC r))) let ddr_default = Some ADDR let ddw_default = Some DATA let ctrlr_default = Some CTRLISYNC let ctrlw_default = Some CTRL let is_ctrlr = function | CTRLISYNC -> true | _ -> false let is_addr = function | ADDR -> true | _ -> false let fst_dp = function | CTRL -> [CTRL] | CTRLISYNC -> [CTRL;CTRLISYNC] | ADDR|DATA -> [] let sequence_dp d1 d2 = match d1 with | ADDR -> [d2] | DATA|CTRL|CTRLISYNC -> [] herd-herdtools7-1ca343e/gen/dep.mli000066400000000000000000000032471475314470400171740ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2011-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Power / ARM dependencies *) type dp = ADDR | DATA | CTRL | CTRLISYNC val fold_dpr : (dp -> 'a -> 'a) -> 'a -> 'a val fold_dpw : (dp -> 'a -> 'a) -> 'a -> 'a (* Defaults for backward compatibility *) val ddr_default : dp option val ddw_default : dp option val ctrlr_default : dp option val ctrlw_default : dp option (* Predicate for control on reads *) val is_ctrlr : dp -> bool val is_addr : dp -> bool (* Dependencies compositin by sequence *) val fst_dp : dp -> dp list val sequence_dp : dp -> dp -> dp list herd-herdtools7-1ca343e/gen/diy.ml000066400000000000000000000227621475314470400170430ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Printf open Code open LexUtil module type DiyConfig = sig include DumpAll.Config val choice : Code.check val variant : Variant_gen.t -> bool val prefix : LexUtil.t list list val cumul : LexUtil.t list Config.cumul val max_ins : int val upto : bool val varatom : string list end module Make(C:Builder.S)(O:DiyConfig) = struct open C.E open C.R let parse_fence s k = match s with | One f -> C.E.parse_fence f::k | Seq [] -> k | Seq (fs) -> List.fold_right (fun s k -> C.E.parse_fence s::k) fs k let parse_relaxs = List.map parse_relax let parse_edges = List.map parse_edge let parse_fences fs = List.fold_right parse_fence fs [] module AltConfig = struct include O type relax = C.R.relax let mix = !Config.mix let max_relax = !Config.max_relax let min_relax = !Config.min_relax let prefix = match List.map parse_relaxs O.prefix with | [] -> [[]] (* No prefix <=> one empty prefix *) | pss -> pss let variant = O.variant type fence = C.A.fence let cumul = let open Config in match O.cumul with | Empty -> Empty | All -> All | Set ps -> Set (parse_fences ps) end module M = Alt.Make(C)(AltConfig) let var_relax fold rs = function | PPO as r -> r::rs | ERS es -> let ess = fold es in List.fold_left (fun k es -> ERS es::k) rs ess let var_atom = if C.A.bellatom then Misc.identity else match O.varatom with | [] -> Misc.identity | ["all"] -> let module Fold = struct type atom = C.E.atom let fold = C.E.fold_atomo end in let module V = VarAtomic.Make(C.E)(Fold) in List.fold_left (var_relax V.varatom_one) [] | atoms -> let atoms = C.E.parse_atoms atoms in let module Fold = struct type atom = C.E.atom let fold f k = C.E.fold_atomo_list atoms f k end in let module V = VarAtomic.Make(C.E)(Fold) in List.fold_left (var_relax V.varatom_one) [] let gen lr ls rl n = let lr = C.R.expand_relax_macros lr and ls = C.R.expand_relax_macros ls and rl = C.R.expand_relax_macros rl in let lr = var_atom lr and ls = var_atom ls and rl = var_atom rl in if O.verbose > 0 then begin Printf.eprintf "expanded relax=%s\n" (C.R.pp_relax_list lr) end ; M.gen ~relax:lr ~safe:ls ~reject:rl n let er e = ERS [plain_edge e] let gen_thin n = let lr = [er (Rf Int); er (Rf Ext)] and ls = [PPO] in M.gen ~relax:lr ~safe:ls n let gen_uni n = let lr = [er (Rf Int); er (Rf Ext)] and ls = [er (Ws Int); er (Ws Ext); er (Fr Int); er (Fr Ext); er (Po (Same,Irr,Irr))] in M.gen ~relax:lr ~safe:ls n let parse_edges_opt = function | None -> None | Some xs -> Some (parse_edges xs) let orl_opt = function | None -> [] | Some xs -> xs let go n (*size*) orl olr ols (*relax and safe lists*) = let orl = orl_opt orl in match O.choice with | Default|Sc|Critical|Free|Ppo|Transitive|Total|MixedCheck -> begin match olr,ols with | None,None -> M.gen n | None,Some ls -> gen [] ls orl n | Some lr,None -> gen lr [] orl n | Some lr,Some ls -> gen lr ls orl n end | Thin -> gen_thin n | Uni -> begin match olr,ols with | None,None -> gen_uni n | None,Some ls -> gen [] ls orl n | Some lr,None -> gen lr [] orl n | Some lr,Some ls -> gen lr ls orl n end end let split s = match s with | None -> None | Some s -> let splitted = LexUtil.split s in Some splitted let get_arg s = raise (Arg.Bad (Printf.sprintf "%s takes no argument, argument %s is present" Config.prog s)) let norm_cmd cmd = match cmd with | [] -> assert false | _::s -> let rec no_conf l = match l with | [] -> [] | "-conf"::_::l -> no_conf l | s::l -> s::(no_conf l) in no_conf s let exec_conf s = let conf = Misc.input_protect LexConf_gen.conf s in let prog = Sys.argv.(0) in let cmd = Array.to_list Sys.argv in let cmd = norm_cmd cmd in if !Config.verbose > 1 then eprintf "EXEC: %s %s\n%!" prog (String.concat " " (conf @ cmd)) ; ignore (Unix.execvp prog (Array.of_list (prog::conf@cmd))) ; () let speclist = Config.speclist () @ [Config.varatomspec] let split_cands xs = match List.concat (List.map LexUtil.split xs) with | [] -> None | _::_ as xs -> Some xs let () = Arg.parse speclist get_arg Config.usage_msg; begin match !Config.conf with | None -> () | Some s -> exec_conf s end; let relax_list = split_cands !Config.relaxs and safe_list = split_cands !Config.safes and reject_list = split !Config.rejects in let () = if !Config.verbose > 0 then begin let relaxs = match relax_list with | None -> [] | Some xs -> xs in Printf.eprintf "parsed relax=%s\n" (String.concat " " (List.map LexUtil.pp relaxs)) end in let cpp = match !Config.arch with `CPP -> true | _ -> false in let module Co = struct (* Dump all *) let verbose = !Config.verbose let generator = Config.baseprog let debug = !Config.debug let hout = match !Config.hout with | None -> Hint.none | Some n -> Hint.open_out n let family = !Config.name let canonical_only = !Config.canonical_only let fmt = !Config.fmt let no = match !Config.no with | None -> [] | Some fname -> Config.read_no fname let cond = !Config.cond let tarfile = !Config.tarfile let sufname = !Config.sufname let addnum = !Config.addnum let numeric = !Config.numeric let lowercase = !Config.lowercase let stdout = if !Config.cycleonly then true else !Config.stdout let cycleonly = !Config.cycleonly let metadata = !Config.metadata (* Specific *) open Config let choice = !Config.mode let prefix = List.rev_map LexUtil.split !Config.prefix let variant = !Config.variant let cumul = match !Config.cumul with | Empty -> Empty | All -> All | Set s -> Set (LexUtil.split s) let upto = !Config.upto let varatom = !varatom let max_ins = !Config.max_ins let overload = !Config.overload let poll = !Config.poll let optcoherence = !Config.optcoherence let optcond = !Config.optcond let obs_type = !Config.obs_type let do_observers = !Config.do_observers let eprocs = !Config.eprocs let nprocs = !Config.nprocs let neg = !Config.neg let cpp = cpp let scope = !scope let info = !Config.info let docheck = !Config.docheck let typ = !Config.typ let hexa = !Config.hexa end in let module C = struct let verbose = !Config.verbose let show = !Config.show let same_loc = !Config.same_loc || (match Co.choice with Uni -> true | _ -> false) let unrollatomic = !Config.unrollatomic let allow_back = match !Config.mode with | Default|Sc|Critical|Thin -> false | _ -> true let typ = !Config.typ let hexa = !Config.hexa let moreedges = !Config.moreedges let realdep = !Config.realdep let variant = !Config.variant end in let module T = Top_gen.Make(Co) in let go = match !Config.arch with | `PPC -> let module M = Make(T(PPCCompile_gen.Make(C)(PPCArch_gen.Config)))(Co) in M.go | `X86 -> let module M = Make(T(X86Compile_gen.Make(C)))(Co) in M.go | `X86_64 -> let module M = Make(T(X86_64Compile_gen.Make(C)))(Co) in M.go | `ARM -> let module M = Make(T(ARMCompile_gen.Make(C)))(Co) in M.go | `AArch64 -> let module M = Make(T(AArch64Compile_gen.Make(C)))(Co) in M.go | `MIPS -> let module M = Make(T(MIPSCompile_gen.Make(C)))(Co) in M.go | `RISCV -> let module M = Make(T(RISCVCompile_gen.Make(C)))(Co) in M.go | `LISA -> let module BellConfig = Config.ToLisa(Config) in let module M = Make(T(BellCompile.Make(C)(BellConfig)))(Co) in M.go | `C | `CPP -> let module CoC = struct include Co include C let typ = !Config.typ end in let module M = Make(CCompile_gen.Make(CoC))(Co) in M.go | `JAVA | `ASL | `BPF -> assert false in try go !Config.size reject_list relax_list safe_list ; exit 0 with | Misc.Fatal msg | Misc.UserError msg-> eprintf "%s: Fatal error: %s\n" Config.prog msg ; exit 2 herd-herdtools7-1ca343e/gen/diycross.ml000066400000000000000000000175441475314470400201170ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Misc open Printf (* Configuration *) let use_eieio = ref true let norm = ref false let () = Config.addnum := false let () = Config.numeric := false let () = Config.nprocs := 1000 let opts = Config.common_specs () @ ("-num", Arg.Bool (fun b -> Config.numeric := b), sprintf " use numeric names, default %b" !Config.numeric):: ("-noeieio", Arg.Clear use_eieio, " ignore eieio fence (backward compatibility)"):: Config.varatomspec::[] module type Config = sig include DumpAll.Config val varatom : string list val unrollatomic : int option end module Make (Config:Config) (M:Builder.S) = struct module D = DumpAll.Make (Config) (M) open M.E let norm = match Config.family with | None -> true | Some _ -> false let gen ess kont r = Misc.fold_cross ess (fun es r -> let es = List.flatten es in kont es D.no_info D.no_name D.no_scope r) r open Code let er e = M.R.ERS [plain_edge e] let all_fences sd d1 d2 = M.A.fold_all_fences (fun f k -> er (M.E.Fenced (f,sd,Dir d1,Dir d2))::k) let some_fences sd d1 d2 = M.A.fold_some_fences (fun f k -> er (M.E.Fenced (f,sd,Dir d1,Dir d2))::k) (* Limited variations *) let app_def_dp o f r = match o with | None -> r | Some dp -> f dp r let someR sd d = er (Po (sd,Dir R,Dir d)):: app_def_dp (match d with R|J -> M.A.ddr_default | W -> M.A.ddw_default) (fun dp k -> er (Dp (dp,sd,Dir d))::k) (some_fences sd R d []) let someW sd d = er (Po (sd,Dir W,Dir d)):: (some_fences sd W d []) (* ALL *) let allR sd d = er (Po (sd,Dir R,Dir d)):: (match d with R|J -> M.A.fold_dpr | W -> M.A.fold_dpw) (fun dp k -> er (Dp (dp,sd,Dir d))::k) (all_fences sd R d []) let allW sd d = er (Po (sd,Dir W,Dir d)):: (all_fences sd W d []) let parse_relaxs s = match s with | "allRR" -> allR Diff R | "allRW" -> allR Diff W | "allWR" -> allW Diff R | "allWW" -> allW Diff W | "someRR" -> someR Diff R | "someRW" -> someR Diff W | "someWR" -> someW Diff R | "someWW" -> someW Diff W | _ -> let es = LexUtil.split s in List.map M.R.parse_relax es let parse_edges s = (* let rs = parse_relaxs s in *) let rs = M.R.expand_relax_macros (LexUtil.split s) in List.fold_right (fun r k -> M.R.edges_of r :: k) rs [] let varatom_ess = if M.A.bellatom then Misc.identity else match Config.varatom with | [] -> fun ess -> ess | ["all"] -> let module Fold = struct type atom = M.E.atom let fold = M.E.fold_atomo end in let module V = VarAtomic.Make(M.E)(Fold) in List.map V.varatom_es | atoms -> let atoms = M.E.parse_atoms atoms in let module Fold = struct type atom = M.E.atom let fold f k = M.E.fold_atomo_list atoms f k end in let module V = VarAtomic.Make(M.E)(Fold) in List.map V.varatom_es let expand_edge es = M.E.expand_edges es Misc.cons let expand_edges ess = List.flatten (List.map (fun e -> expand_edge e []) ess) let zyva pp_rs = try let ess = List.map parse_edges pp_rs in let ess = List.map expand_edges ess in let ess = varatom_ess ess in D.all (gen ess) with Fatal msg -> eprintf "Fatal error: %s\n" msg ; exit 2 end let pp_es = ref [] let () = Util.parse_cmdline opts (fun x -> pp_es := x :: !pp_es) let pp_es = List.rev !pp_es let () = try let module C = struct (* Dump all *) let verbose = !Config.verbose let generator = Config.baseprog let debug = !Config.debug let hout = match !Config.hout with | None -> Hint.none | Some n -> Hint.open_out n let family = !Config.name let canonical_only = !Config.canonical_only let fmt = !Config.fmt let no = match !Config.no with | None -> [] | Some fname -> Config.read_no fname let cond = !Config.cond let tarfile = !Config.tarfile let sufname = !Config.sufname let addnum = !Config.addnum let numeric = !Config.numeric let lowercase = !Config.lowercase let stdout = if !Config.cycleonly then true else !Config.stdout let cycleonly = !Config.cycleonly let metadata = !Config.metadata (* Specific *) let varatom = !Config.varatom let same_loc = !Config.same_loc || (match cond with | Config.Unicond -> true | _ -> false) let unrollatomic = !Config.unrollatomic let show = !Config.show let overload = !Config.overload let poll = !Config.poll let docheck = !Config.docheck let optcoherence = !Config.optcoherence let optcond = !Config.optcond let obs_type = !Config.obs_type let do_observers = !Config.do_observers let eprocs = !Config.eprocs let nprocs = !Config.nprocs let neg = !Config.neg let allow_back = true let typ = !Config.typ let hexa = !Config.hexa let moreedges = !Config.moreedges let realdep = !Config.realdep let cpp = match !Config.arch with `CPP -> true | _ -> false let scope = !Config.scope let info = !Config.info let variant = !Config.variant end in let module T = Top_gen.Make(C) in begin match !Config.arch with | `X86 -> let module M = Make(C)(T(X86Compile_gen.Make(C))) in M.zyva | `X86_64 -> let module M = Make(C)(T(X86_64Compile_gen.Make(C))) in M.zyva | `PPC -> let module PPCConf = struct let eieio = !use_eieio end in let module M = Make(C)(T(PPCCompile_gen.Make(C)(PPCConf))) in M.zyva | `ARM -> let module M = Make(C)(T(ARMCompile_gen.Make(C))) in M.zyva | `AArch64 -> let module M = Make(C)(T(AArch64Compile_gen.Make(C))) in M.zyva | `MIPS -> let module M = Make(C)(T(MIPSCompile_gen.Make(C))) in M.zyva | `RISCV -> let module M = Make(C)(T(RISCVCompile_gen.Make(C))) in M.zyva | `LISA -> let module BellConfig = Config.ToLisa(Config) in let module M = Make(C)(T(BellCompile.Make(C)(BellConfig))) in M.zyva | `C | `CPP -> let module CoC = struct include C let typ = !Config.typ end in let module T = CCompile_gen.Make(CoC) in let module M = Make(C)(T) in M.zyva | `JAVA | `ASL | `BPF -> assert false end pp_es with | Misc.Exit -> () | (Misc.Fatal msg|Misc.UserError msg) -> eprintf "%s: Fatal error: %s\n" Config.prog msg herd-herdtools7-1ca343e/gen/diyone.ml000066400000000000000000000230651475314470400175420ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Misc open Printf (* Configuration *) let norm = ref false let () = Config.nprocs := 1000 let () = Config.numeric := true let opts = Config.common_specs () @ ("-num", Arg.Bool (fun b -> Config.numeric := b), sprintf " use numeric names, default %b" !Config.numeric):: ("-norm",Arg.Set norm," find a normalised name for me"):: [] module type Config = sig include Top_gen.Config include DumpAll.Config val norm : bool val cpp : bool val docheck : bool val prog : string end module Make(O:Config) (M:Builder.S) = struct let dump_stdout ?scope es = let t = M.make_test "A" ~info:O.info ?scope es in M.dump_test_channel stdout t ; None let litmus = if O.cpp then sprintf "%s.c" else sprintf "%s.litmus" let dump_file name ?scope es = if O.verbose > 0 then eprintf "Test name: %s\n" name ; let t = M.make_test name ~info:O.info ?scope es in let fname = litmus name in Misc.output_protect (fun chan -> M.dump_test_channel chan t; Some fname) fname let gen_one_scope gen n = try gen n (fun st r -> match r with | Some _ -> raise Exit | None -> Some st) None with Exit -> None let get_scope n = match O.scope with | Scope.No -> None | Scope.One st -> Some st | Scope.Default -> Some (M.A.ScopeGen.default n) | Scope.Gen scs -> begin match gen_one_scope (M.A.ScopeGen.gen scs) n with | None -> Warn.fatal "scope enumeration yields several scopes" | Some _ as st -> st end | Scope.All -> begin match gen_one_scope M.A.ScopeGen.all n with | None -> Warn.fatal "scope enumeration yield several scopes" | Some _ as st -> st end let dump = let module Normer = Normaliser.Make(O)(M.E) in let add_suffix = match O.sufname with | None -> fun n -> n | Some s -> fun n -> n ^ s in if O.norm then let module Namer = Namer.Make(M.A)(M.E) in fun _name es -> let es = M.E.resolve_edges es in let es,_ = M.C.resolve_edges es in let base,es,nprocs = Normer.normalise_family es in let scope = get_scope nprocs in let name = add_suffix (Namer.mk_name base ?scope es) in dump_file name ?scope es else fun name es -> let es = M.E.resolve_edges es in let nprocs = Normer.get_nprocs es in let scope = get_scope nprocs in match name with | None -> dump_stdout ?scope es | Some name -> let name = add_suffix name in dump_file name ?scope es module P = LineUtils.Make(M.E) let parse_line s = P.parse s (********) let rec read_line_no_comment () = let line = read_line () in if String.length line = 0 || (String.length line > 0 && line.[0] = '#') then read_line_no_comment () else line (********) let do_zyva name pp_rs = try begin let pp_rs = List.map LexUtil.split pp_rs in let pp_rs = List.concat pp_rs in let rs = List.map M.R.parse_relax pp_rs in if O.verbose > 0 then Printf.eprintf "Parsed relaxs: %s\n" (M.R.pp_relax_list rs) ; let es = List.fold_right (fun r k -> M.R.edges_of r @ k) rs [] in if O.verbose > 0 then Printf.eprintf "Parsed edges: %s\n" (M.E.pp_edges es) ; match es with | [] -> let dump_names = O.norm || (match O.family with Some _ -> true | None -> false) in let module D = DumpAll.Make(O)(M) in let gen kont = let rec do_rec k0 = let k = try let line = read_line_no_comment () in try let name,es,st = parse_line line in let mk_name = if dump_names then D.no_name else let name = match O.sufname with | None -> name | Some suf -> name ^ suf in fun _ -> Some name in let mk_scope _ = st in Some (kont es D.no_info mk_name mk_scope k0) with | Fatal msg | UserError msg -> Warn.warn_always "%s on line '%s'" msg line ; Some k0 with | End_of_file -> None in match k with | None -> k0 | Some k -> do_rec k in do_rec in D.all gen | _ -> ignore (dump name es) end with Fatal msg -> eprintf "%s: Fatal error: %s\n" Config.prog msg ; exit 2 let zyva = do_zyva O.family end let pp_es = ref [] let () = Util.parse_cmdline opts (fun x -> pp_es := x :: !pp_es) let pp_es = List.rev !pp_es let cpp = match !Config.arch with | `CPP -> true | _ -> false let () = let module Co = struct (* Dump all *) let verbose = !Config.verbose let generator = Config.baseprog let debug = !Config.debug let hout = match !Config.hout with | None -> Hint.none | Some n -> Hint.open_out n let family = !Config.name let canonical_only = !Config.canonical_only let fmt = !Config.fmt let no = match !Config.no with | None -> [] | Some fname -> Config.read_no fname let cond = !Config.cond let tarfile = !Config.tarfile let sufname = !Config.sufname let addnum = !Config.addnum let numeric = !Config.numeric let lowercase = !Config.lowercase let optcoherence = !Config.optcoherence let optcond = !Config.optcond let poll = !Config.poll let overload = !Config.overload let obs_type = !Config.obs_type let do_observers = !Config.do_observers let eprocs = !Config.eprocs let nprocs = !Config.nprocs let neg = !Config.neg let typ = !Config.typ let hexa = !Config.hexa let stdout = if !Config.cycleonly then true else !Config.stdout let cycleonly = !Config.cycleonly let metadata = !Config.metadata (* Specific *) let norm = !norm let cpp = cpp let scope = !Config.scope let docheck = !Config.docheck let prog = Config.prog let info = !Config.info let variant = !Config.variant end in let module Build = Make(Co) in let module C = struct let verbose = !Config.verbose let debug = !Config.debug let show = !Config.show let same_loc = !Config.same_loc || (match Co.cond with | Config.Unicond -> true | _ -> false) let unrollatomic = !Config.unrollatomic let allow_back = true let typ = !Config.typ let hexa = !Config.hexa let moreedges = !Config.moreedges let realdep = !Config.realdep let variant = !Config.variant end in (match !Config.arch with | `X86 -> let module T = Top_gen.Make(Co) in let module M = Build(T(X86Compile_gen.Make(C))) in M.zyva | `X86_64 -> let module T = Top_gen.Make(Co) in let module M = Build(T(X86_64Compile_gen.Make(C))) in M.zyva | `PPC -> let module T = Top_gen.Make(Co) in let module M = Build(T(PPCCompile_gen.Make(C)(PPCArch_gen.Config))) in M.zyva | `ARM -> let module T = Top_gen.Make(Co) in let module M = Build(T(ARMCompile_gen.Make(C))) in M.zyva | `AArch64 -> let module T = Top_gen.Make(Co) in let module M = Build(T(AArch64Compile_gen.Make(C))) in M.zyva | `MIPS -> let module T = Top_gen.Make(Co) in let module M = Build(T(MIPSCompile_gen.Make(C))) in M.zyva | `RISCV -> let module T = Top_gen.Make(Co) in let module M = Build(T(RISCVCompile_gen.Make(C))) in M.zyva | `LISA -> let module BellConfig = Config.ToLisa(Config) in let module T = Top_gen.Make(Co) in let module M = Build(T(BellCompile.Make(C)(BellConfig))) in M.zyva | `C | `CPP as a -> let module CoC = struct include Co include C let typ = !Config.typ let cpp = match a with `CPP -> true | _ -> false end in let module T = CCompile_gen.Make(CoC) in let module M = Build(T) in M.zyva | `JAVA | `ASL | `BPF -> assert false ) pp_es herd-herdtools7-1ca343e/gen/dumpAll.ml000066400000000000000000000362611475314470400176530ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Printf module type Config = sig include Top_gen.Config val family : string option val canonical_only : bool val fmt : int val no : string list val tarfile : string option val sufname : string option val addnum : bool val numeric : bool val lowercase : bool val overload : int option val cpp : bool val scope : Scope.t val info : MiscParser.info val stdout: bool end module Make(Config:Config)(T:Builder.S) = struct module Tar = Tar.Make (struct let verbose = Config.verbose let outname = Config.tarfile end) type edge = T.edge (* Families *) (* Environment for test names *) module Env = MyMap.Make(String) (****************************) (* High-level normalisation *) (****************************) let normalise = if Config.canonical_only then let module Normer = Normaliser.Make(Config)(T.E) in fun cy -> let ncy = Normer.normalise (T.E.resolve_edges cy) in if Config.verbose > 0 then eprintf "Changed %s -> %s\n" (T.E.pp_edges cy) (T.E.pp_edges ncy) ; ncy else fun cy -> cy let mk_base = match Config.family with | Some b -> fun _cy -> b | None -> let module Normer = Normaliser.Make(Config)(T.E) in Normer.family (* Complete name *) let mk_fmt base n = sprintf "%s%0*i" base Config.fmt n let add_suffix = match Config.sufname with | None -> fun n -> n | Some s -> fun n -> n ^ s let global_mk_name = if Config.numeric then fun env base _es -> let n = try Env.find base env with Not_found -> 0 in add_suffix (mk_fmt base n),Env.add base (n+1) env else let module Namer = Namer.Make(T.A)(T.E) in fun env base es -> add_suffix (Namer.mk_name base es),env exception DupName of string (* No need to add disambiguating numbers to numeric names *) let addnum = Config.addnum let dup_name = if addnum then fun env name -> let n = try Env.find name env with Not_found -> 0 in (match n with | 0 -> name | _ -> mk_fmt name n), Env.add name (n+1) env else fun env name -> try let _ = Env.find name env in raise (DupName name) with Not_found -> name,Env.add name 0 env (**********************************) (* Computation of cycle signature *) (**********************************) (* A bit contrieved... - change list to array, - find starting index of minimal sequence in array, - build the signature starting from this index. *) (* Signatures as strings, for the sake of compacity *) module W = Warn.Make(Config) type sigs = { sig_next : int ; sig_map : int T.E.Map.t ; sig_set : StringSet.t} let get_sig sigs e = try T.E.Map.find e sigs.sig_map,sigs with Not_found -> let i = sigs.sig_next in W.warn "New sig: %s -> %i" (T.E.pp_edge e) i ; if i > 0xffff then Warn.warn_always "Signatures for are more than 2 bytes, expect duplicates" ; i, { sigs with sig_next=i+1; sig_map = T.E.Map.add e i sigs.sig_map; } let sig_of sigs out e = let i,sigs = get_sig sigs e in let c1 = i land 0xff in let c2 = (i lsr 8) land 0xff in out (Char.chr c1) ; out (Char.chr c2) ; sigs let sig_of_shift = let buff = Buffer.create 16 in let add c = Buffer.add_char buff c in fun sigs t k -> let sz = Array.length t in assert(sz > 0) ; let incr i = if i+1 >= sz then 0 else i+1 in let rec do_rec sigs i = let sigs = sig_of sigs add t.(i) in let j = incr i in if j=k then sigs else do_rec sigs j in let sigs = do_rec sigs k in let r = Buffer.contents buff in Buffer.clear buff ; r,sigs let cycle_of_shift t k = let sz = Array.length t in assert(sz > 0) ; let incr i = if i+1 >= sz then 0 else i+1 in let rec do_rec i = let es = let j = incr i in if j=k then [] else do_rec j in t.(i)::es in do_rec k let find_min_shift t = let sz = Array.length t in assert (sz > 0) ; let incr i = if i+1 >= sz then 0 else i+1 in let rec c_rec k i1 i2 = if k <= 0 then 0 else let c = T.E.compare t.(i1) t.(i2) in if c=0 then c_rec (k-1) (incr i1) (incr i2) else c in let rec find_rec k_min k = if k >= sz then k_min else if c_rec sz k k_min < 0 then find_rec k (k+1) else find_rec k_min (k+1) in find_rec 0 1 let comp_sig sigs es = match es with | [] -> "",es,sigs | _::_ -> let t = Array.of_list es in let k = find_min_shift t in let s,sigs = sig_of_shift sigs t k in s, cycle_of_shift t k,sigs let have_seen sigs es = let xxx,es,sigs = comp_sig sigs es in if StringSet.mem xxx sigs.sig_set then true,es,sigs else false,es,{ sigs with sig_set = StringSet.add xxx sigs.sig_set; } (******************) (* Internal state *) (******************) type t = { ntests : int ; (* number of tests outputed so far *) sigs : sigs ; (* Signatures of compiled tests *) env : int Env.t ; (* State for getting numeric names *) dup : int Env.t ; (* State for getting fresh names *) relaxed : T.R.SetSet.t ; } type check = edge list list -> bool type info = (string * string) list type mk_info = edge list -> info * T.R.Set.t let no_info _ = [],T.R.Set.empty type mk_name = edge list -> string option let no_name _ = None type mk_scope = edge list -> BellInfo.scopes option let no_scope _ = None type generator = (edge list -> mk_info -> mk_name -> mk_scope -> t -> t) -> t -> t let empty_sig = { sig_next = 0 ; sig_map = T.E.Map.empty ; sig_set = StringSet.empty } let sigs_init cys = let cys = List.rev_map T.E.parse_edges cys in List.fold_left (fun k es -> let xxx,_,k = comp_sig k es in { k with sig_set = StringSet.add xxx k.sig_set;} ) empty_sig cys let empty_t = { ntests = 0 ; sigs = sigs_init Config.no ; env = Env.empty; dup = Env.empty; relaxed = T.R.SetSet.empty; } (************************************** ****) (* Check duplicates, compile and dump test *) (*******************************************) (* Adapt actual filename *) let tar_output_protect f name = Misc.output_protect f (Tar.outname name) (* Compile & dump proper *) (* Test specification *) type cycle = { orig : T.E.edge list ; (* As given, for actually building the test & name. *) norm : T.E.edge list; (* Normalized, for the cycle and info field. *) } (* Output test proper *) let do_dump_test all_chan t res = let n = T.get_name t in let src = sprintf "%s.%s" n (if Config.cpp then "c" else "litmus") in if Config.stdout then T.dump_test_channel stdout t else tar_output_protect (fun chan -> T.dump_test_channel chan t) src ; (* And litmus file name in @all file *) if not Config.stdout then fprintf all_chan "%s\n" src ; if Config.verbose > 0 then eprintf "Test: %s\n" n ; (* printf "%s: %s\n" n (pp_edges cycle.orig) ; *) { res with ntests = res.ntests+1; } (* Dump from cycle, with specified scope tree *) let dump_test_st keep_name all_chan check init cycle info relaxed env n c mk_st res = (* Build test (we need number of procs...) *) let t = T.test_of_cycle n ~info:info ~check:check ~init cycle.orig c in let st = mk_st (T.get_nprocs t) in let n = if keep_name then n else n ^ "+" ^ Namer.of_scope st in let n,dup = dup_name res.dup n in let t = T.set_name t n in let t = T.set_scope t st in let res = { res with env; dup; relaxed= T.R.SetSet.add relaxed res.relaxed; } in do_dump_test all_chan t res let dump_test all_chan check init cycle mk_info mk_name mk_scope c res = let n,env = match mk_name cycle.orig with | None -> let fam = mk_base cycle.orig in let n,env = global_mk_name res.env fam cycle.orig in n,env | Some n -> n,res.env in let cy = T.E.pp_edges cycle.norm in let info,relaxed = mk_info cycle.norm in let info = Config.info@("Cycle",cy)::info in match Config.scope with | Scope.No -> let n,dup = dup_name res.dup n in let t = T.test_of_cycle n ~info:info ~check:check ~init cycle.orig c in let res = { res with env; dup; relaxed= T.R.SetSet.add relaxed res.relaxed; } in do_dump_test all_chan t res | Scope.Default -> let keep_name,mk_st = (match mk_scope cycle.orig with | None -> false,T.A.ScopeGen.default | Some st -> true,(fun _ -> st)) in dump_test_st keep_name all_chan check init cycle info relaxed env n c mk_st res | Scope.One st -> dump_test_st false all_chan check init cycle info relaxed env n c (fun _ -> st) res | Scope.Gen scs -> let t = T.test_of_cycle n ~info:info ~check:check ~init cycle.orig c in let res = { res with env; relaxed= T.R.SetSet.add relaxed res.relaxed; } in T.A.ScopeGen.gen scs (T.get_nprocs t) (fun st res -> let n = n ^ "+" ^ Namer.of_scope st in let n,dup = dup_name res.dup n in let t = T.set_name t n in let t = T.set_scope t st in let res = { res with dup;} in do_dump_test all_chan t res) res | Scope.All -> let t = T.test_of_cycle n ~info:info ~check:check ~init cycle.orig c in let res = { res with env; relaxed= T.R.SetSet.add relaxed res.relaxed; } in T.A.ScopeGen.all (T.get_nprocs t) (fun st res -> let n = n ^ "+" ^ Namer.of_scope st in let n,dup = dup_name res.dup n in let t = T.set_name t n in let t = T.set_scope t st in let res = { res with dup;} in do_dump_test all_chan t res) res (* Compose duplicate checker and dumper *) let check_dump = if Config.canonical_only then fun all_chan check es mk_info mk_name mk_scope r -> let es,c = T.C.resolve_edges es in let seen,nes,sigs = have_seen r.sigs es in if seen then Warn.fatal "Duplicate" ; let init = T.C.finish c in dump_test all_chan check init { orig = es ; norm = nes } mk_info mk_name mk_scope c { r with sigs = sigs; } else fun all_chan check es mk_info mk_name mk_scope r -> let es,c = T.C.resolve_edges es in let init = T.C.finish c in dump_test all_chan check init { orig = es ; norm = es ; } mk_info mk_name mk_scope c r let check_dump all_chan check es mk_info mk_name mk_scope res = if Config.verbose > 0 then begin eprintf "------------------------------------------------------\n" ; eprintf "Cycle: %s\n" (T.E.pp_edges es) ; let info,_ = mk_info es in List.iter (fun (tag,i) -> eprintf "%s: %s\n" tag i) info end ; try check_dump all_chan check es mk_info mk_name mk_scope res with | Misc.Fatal msg -> if Config.verbose > 0 then begin eprintf "Compilation failed: %s\n" msg end ; res | DupName name -> Warn.fatal "Duplicate name %s" name let check_dump all_chan check es mk_info mk_name mk_scope res = try let es = try normalise es with Normaliser.CannotNormalise msg -> Warn.fatal "Cannot normalise '%s'" msg in T.E.varatom es (fun es res -> if Config.debug.Debug_gen.generator then eprintf "Atomic variation: %s\n" (T.E.pp_edges es) ; check_dump all_chan check es mk_info mk_name mk_scope res) res with | Misc.Fatal msg|Misc.UserError msg -> if Config.verbose > 0 then eprintf "Fatal ignored: %s\n" msg ; res |Misc.Exit -> res (* Exported *) let all ?(check=(fun _ -> true)) gen = let output f = if Config.stdout then f stderr else tar_output_protect f "@all" and print = if Config.stdout then eprintf else printf in output (fun all_chan -> fprintf all_chan "# %s\n" (String.concat " " (Array.to_list Sys.argv)) ; fprintf all_chan "# Version %s, Revision: %s\n" Version.version Version.rev ; let res = gen (check_dump all_chan check) empty_t in flush stderr ; print "Generator produced %d tests\n%!" res.ntests ; if T.R.SetSet.exists (fun r -> not (T.R.Set.is_empty r)) res.relaxed then print "Relaxations tested: %a\n" T.R.pp_set_set res.relaxed) ; Tar.tar () ; Hint.close_out Config.hout end herd-herdtools7-1ca343e/gen/dumpAll.mli000066400000000000000000000045511475314470400200210ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2014-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module type Config = sig include Top_gen.Config val family : string option val canonical_only : bool val fmt : int val no : string list val tarfile : string option val sufname : string option val addnum : bool val numeric : bool val lowercase : bool val overload : int option val cpp : bool val scope : Scope.t val info : MiscParser.info val stdout: bool end module Make(Config:Config) (T:Builder.S) : sig type edge = T.edge type check = edge list list -> bool type info = (string * string) list (* Compute information *) type mk_info = edge list -> info * T.R.Set.t val no_info : mk_info (* Compute name *) type mk_name = edge list -> string option val no_name : mk_name (* Compute scope *) type mk_scope = edge list -> BellInfo.scopes option val no_scope : mk_scope (* Remains abstract: for dumper internal usage *) type t (* Type of cycle generator *) type generator = (edge list -> mk_info -> mk_name -> mk_scope -> t -> t) -> t -> t (* Combine generator and dumper: so as to dump all test from generated cycles, check is the "last minute check" that operates on cycles splitted by proc *) val all : ?check:T.check -> generator -> unit end herd-herdtools7-1ca343e/gen/dune000066400000000000000000000006611475314470400165740ustar00rootroot00000000000000(ocamllex lexUtil lexLog_gen lexConf_gen autoLex) (rule (copy ../Version.ml Version.ml)) (executables (names readRelax atoms diycross mexpand atomize diyone nexts classify diy norm) (public_names readRelax7 atoms7 diycross7 mexpand7 atomize7 diyone7 nexts7 classify7 diy7 norm7) (libraries herdtools unix) (modules_without_implementation archLoc archRun arch_gen atom autoInterpret builder fence XXXCompile_gen rmw)) herd-herdtools7-1ca343e/gen/edge.ml000066400000000000000000001025051475314470400171540ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Edges, ie specifications of an event pair in a model relation *) module Config = struct let variant _ = false let naturalsize = TypBase.get_size TypBase.default end let dbg = 0 module type S = sig open Code type fence type dp module SIMD : Atom.SIMD type atom module PteVal : PteVal_gen.S with type pte_atom = atom type rmw val pp_atom : atom -> string val tr_value : atom option -> Code.v -> Code.v val overwrite_value : Code.v -> atom option -> Code.v -> Code.v val extract_value : Code.v -> atom option -> Code.v val set_pteval : atom option -> PteVal.t -> (unit -> string) -> PteVal.t val merge_atoms : atom -> atom -> atom option val is_ifetch : atom option -> bool val atom_to_bank : atom option -> SIMD.atom Code.bank val strong : fence val pp_fence : fence -> string (* edge proper *) type tedge = | Rf of ie | Fr of ie | Ws of ie | Po of sd*extr*extr | Fenced of fence*sd*extr*extr | Dp of dp*sd*extr | Leave of com (* Leave thread *) | Back of com (* Return to thread *) (* Fake edges *) | Id (* Annotation on access *) | Insert of fence (* Insert some code *) | Store (* Add store at thread code start *) | Node of dir (* Isolated event *) (* fancy *) | Hat | Rmw of rmw (* Various sorts of read-modify-write *) val is_id : tedge -> bool val is_node : tedge -> bool val is_insert_store : tedge -> bool val is_non_pseudo : tedge -> bool val compute_rmw : rmw -> int -> int -> int type edge = { edge: tedge; a1:atom option; a2: atom option; } val plain_edge : tedge -> edge val fold_atomo : (atom option -> 'a -> 'a) -> 'a -> 'a val fold_mixed : (atom option -> 'a -> 'a) -> 'a -> 'a val fold_atomo_list : atom list -> (atom option -> 'a -> 'a) -> 'a -> 'a val fold_edges : (edge -> 'a -> 'a) -> 'a -> 'a val iter_edges : (edge -> unit) -> unit val fold_pp_edges : (string -> 'a -> 'a) -> 'a -> 'a val pp_tedge : tedge -> string val pp_atom_option : atom option -> string val debug_edge : edge -> string val pp_edge : edge -> string val compare_atomo : atom option -> atom option -> int val compare : edge -> edge -> int val parse_atom : string -> atom val parse_atoms : string list -> atom list val parse_fence : string -> fence val parse_edge : string -> edge val parse_edges : string -> edge list val pp_edges : edge list -> string (* Get source and target event direction, Returning Irr means that a Read OR a Write is acceptable, Returning No means that the direction is not applicable (pseudo edge *) val dir_src : edge -> extr val dir_tgt : edge -> extr val safe_dir : edge -> dir option (* Return edge with direction resolved *) val set_src : dir -> edge -> edge val set_tgt : dir -> edge -> edge (* Does source and target events have the same or different locations? *) val loc_sd : edge -> sd val is_diff: edge -> bool (* Internal (same proc) or external edge (different procs) *) val get_ie : edge -> ie (* More detailed *) type full_ie = IE of ie | LeaveBack val get_full_ie : edge -> full_ie (* If source atom implies wide access, size of access as integers *) val as_integers : edge -> int option (* Is source atom a pair access? *) val is_pair : edge -> bool (* Can e1 target event direction be the same as e2 source event? *) val can_precede : edge -> edge -> bool (* Expansion of Irr directions *) val expand_edges : edge list -> (edge list -> 'a -> 'a) -> 'a -> 'a (* Resolve Irr directions and unspecified atom *) val resolve_edges : edge list -> edge list (* Atomic variation over yet unspecified atoms *) val varatom : edge list -> (edge list -> 'a -> 'a) -> 'a -> 'a (* Possible interpretation of edge sequence as an edge *) val compact_sequence : edge list -> edge list -> edge -> edge -> edge list list (* Utilities *) val is_ext : edge -> bool val is_com : edge -> bool val is_fetch : edge -> bool val is_po_or_fenced_joker : edge -> bool (* Set/Map *) module Set : MySet.S with type elt = edge module Map : MyMap.S with type key = edge (* Show some elements, for documentation *) val show : ShowGen.t -> unit end module Make (Cfg: sig val variant : Variant_gen.t -> bool val naturalsize : MachSize.sz end) (F:Fence.S) : S with type fence = F.fence and type dp = F.dp and module SIMD = F.SIMD and type atom = F.atom and module PteVal = F.PteVal and type rmw = F.rmw = struct let () = ignore (Cfg.naturalsize) let do_self = Cfg.variant Variant_gen.Self let do_mixed = Variant_gen.is_mixed Cfg.variant let do_kvm = Variant_gen.is_kvm Cfg.variant let do_disjoint = Cfg.variant Variant_gen.MixedDisjoint let do_strict_overlap = Cfg.variant Variant_gen.MixedStrictOverlap let debug = false open Code type fence = F.fence type dp = F.dp module SIMD = F.SIMD type atom = F.atom type rmw = F.rmw let compute_rmw = F.compute_rmw module PteVal = F.PteVal let pp_atom = F.pp_atom let tr_value = F.tr_value let overwrite_value = F.overwrite_value let extract_value = F.extract_value let set_pteval ao p = match ao with | None -> fun _ -> p | Some a -> F.PteVal.set_pteval a p let applies_atom ao d = match ao,d with | (None,_)|(_,(Irr|NoDir)) -> true | Some a,Dir d -> F.applies_atom a d let merge_atoms = F.merge_atoms let is_ifetch = F.is_ifetch let atom_to_bank = function | None -> Ord | Some a -> F.atom_to_bank a let strong = F.strong let pp_fence = F.pp_fence (* edge proper *) type tedge = | Rf of ie | Fr of ie | Ws of ie | Po of sd*extr*extr | Fenced of fence*sd*extr*extr | Dp of dp*sd*extr | Leave of com | Back of com | Id | Insert of fence | Store | Node of dir | Hat | Rmw of rmw let is_id = function | Id -> true | Store|Insert _|Hat|Rmw _|Rf _|Fr _|Ws _|Po (_, _, _) | Fenced (_, _, _, _)|Dp (_, _, _)|Leave _|Back _|Node _ -> false let is_insert_store = function | Store|Insert _ -> true | Id|Hat|Rmw _|Rf _|Fr _|Ws _|Po (_, _, _) | Fenced (_, _, _, _)|Dp (_, _, _)|Leave _|Back _|Node _ -> false let is_node = function | Node _ -> true | Id|Hat|Rmw _|Rf _|Fr _|Ws _|Po (_, _, _) | Fenced (_, _, _, _)|Dp (_, _, _)|Leave _|Back _|Insert _ | Store -> false let is_non_pseudo = function | Store|Insert _ |Id|Node _-> false | Hat|Rmw _|Rf _|Fr _|Ws _|Po (_, _, _) | Fenced (_, _, _, _)|Dp (_, _, _)|Leave _|Back _ -> true type edge = { edge: tedge; a1:atom option; a2: atom option; } open Printf let plain_edge e = { a1=None; a2=None; edge=e; } let pp_arch = function | None -> F.pp_plain | Some a -> F.pp_atom a let pp_one_or_two pp_a e a1 a2 = match e with | Id -> pp_a a1 | _ -> sprintf "%s%s" (pp_a a1) (pp_a a2) let pp_archs e a1 a2 = match a1, a2 with | None,None when not (is_id e) -> "" | _,_ -> pp_one_or_two pp_arch e a1 a2 let pp_a = function | None -> Code.plain | Some a -> F.pp_atom a let pp_atom_option = pp_a let pp_aa e a1 a2 = match a1, a2 with | None,None when not (is_id e) -> "" | _,_ -> pp_one_or_two pp_a e a1 a2 let pp_a_bis = function | None -> "P" | Some a -> F.pp_atom a let pp_aa_bis e a1 a2 = match a1,a2 with | None,None when not (is_id e) -> "" | _,_ -> pp_one_or_two pp_a_bis e a1 a2 let pp_a_ter = function | None -> F.pp_plain | Some a as ao -> if ao = F.pp_as_a then "A" else F.pp_atom a let pp_aa_ter e a1 a2 = match a1,a2 with | None,None when not (is_id e) -> "" | _,_ -> pp_one_or_two pp_a_ter e a1 a2 let pp_a_qua = function | None -> "P" | Some a as ao -> if ao = F.pp_as_a then "A" else F.pp_atom a let pp_aa_qua e a1 a2 = match a1,a2 with | None,None when not (is_id e) -> "" | _,_ -> pp_one_or_two pp_a_qua e a1 a2 let do_pp_tedge compat = function | Rf ie -> sprintf "Rf%s" (pp_ie ie) | Fr ie -> sprintf "Fr%s" (pp_ie ie) | Ws ie -> if compat then sprintf "Ws%s" (pp_ie ie) else sprintf "Co%s" (pp_ie ie) | Po (sd,e1,e2) -> sprintf "Po%s%s%s" (pp_sd sd) (pp_extr e1) (pp_extr e2) | Fenced (f,sd,e1,e2) -> sprintf "%s%s%s%s" (F.pp_fence f) (pp_sd sd) (pp_extr e1) (pp_extr e2) | Dp (dp,sd,e) -> sprintf "Dp%s%s%s" (F.pp_dp dp) (pp_sd sd) (pp_extr e) | Hat -> "Hat" | Rmw rmw-> F.pp_rmw compat rmw | Leave c -> sprintf "%sLeave" (pp_com c) | Back c -> sprintf "%sBack" (pp_com c) | Id -> "Id" | Insert f -> F.pp_fence f | Store -> "Store" | Node W -> "Write" | Node R -> "Read" | Node J -> assert false let pp_tedge = do_pp_tedge false let debug_edge e = sprintf "{edge=%s, a1=%s, a2=%s}" (do_pp_tedge false e.edge) (pp_a e.a1) (pp_a e.a2) let do_pp_edge compat pp_aa e = (match e.edge with Id -> "" | _ -> do_pp_tedge compat e.edge) ^ pp_aa e.edge e.a1 e.a2 let pp_edge e = do_pp_edge false pp_archs e let pp_edge_with_xx compat e = do_pp_edge compat pp_aa e let pp_edge_with_p compat e = do_pp_edge compat pp_aa_bis e let pp_edge_with_a compat e = do_pp_edge compat pp_aa_ter e let pp_edge_with_pa compat e = do_pp_edge compat pp_aa_qua e let compare_atomo a1 a2 = match a1,a2 with | None,None -> 0 | None,Some _ -> -1 | Some _,None -> 1 | Some a1,Some a2 -> F.compare_atom a1 a2 let compare e1 e2 = match compare_atomo e1.a1 e2.a1 with | 0 -> begin match compare_atomo e1.a2 e2.a2 with | 0 -> compare e1.edge e2.edge | r -> r end | r -> r let pp_strong sd e1 e2 = sprintf "Fence%s%s%s" (pp_sd sd) (pp_extr e1) (pp_extr e2) (* Backward compatibility... *) let pp_dp_default tag sd e = sprintf "%s%s%s" tag (pp_sd sd) (pp_extr e) let do_dir_tgt_com = function | CRf -> Dir R | CWs|CFr -> Dir W and do_dir_src_com = function | CRf|CWs -> Dir W | CFr -> Dir R exception NotThat of string let not_that e msg = raise (NotThat (sprintf "%s: %s" msg (pp_tedge e))) let do_dir_tgt e = match e with | Po(_,_,e)| Fenced(_,_,_,e)|Dp (_,_,e) -> e | Rf _| Hat -> Dir R | Ws _|Fr _|Rmw _ -> Dir W | Leave c|Back c -> do_dir_tgt_com c | Id -> not_that e "do_dir_tgt" | Insert _ -> NoDir | Store -> Dir W | Node d -> Dir d and do_dir_src e = match e with | Po(_,e,_)| Fenced(_,_,e,_) -> e | Dp _|Fr _|Hat|Rmw _ -> Dir R | Ws _|Rf _ -> Dir W | Leave c|Back c -> do_dir_src_com c | Id -> not_that e "do_dir_src" | Insert _ -> NoDir | Store -> Dir W | Node d -> Dir d let do_loc_sd e = match e with | Po (sd,_,_) | Fenced (_,sd,_,_) | Dp (_,sd,_) -> sd | Insert _|Store|Node _|Fr _|Ws _|Rf _|Hat|Rmw _|Id|Leave _|Back _ -> Same let do_is_diff e = match do_loc_sd e with | Same -> false | Diff -> true let fold_tedges_compat f r = let r = fold_ie (fun ie -> f (Ws ie)) r in let r = F.fold_rmw_compat (fun rmw -> f (Rmw rmw)) r in r let fold_tedges f r = let r = fold_ie (fun ie -> f (Rf ie)) r in let r = fold_ie (fun ie -> f (Fr ie)) r in let r = fold_ie (fun ie -> f (Ws ie)) r in let r = F.fold_rmw (fun rmw -> f (Rmw rmw)) r in let r = fold_sd_extr_extr (fun sd e1 e2 r -> f (Po (sd,e1,e2)) r) r in let r = F.fold_all_fences (fun fe -> f (Insert fe)) r in let r = f Store r in let r = F.fold_all_fences (fun fe -> fold_sd_extr_extr (fun sd e1 e2 -> f (Fenced (fe,sd,e1,e2)))) r in let r = F.fold_dpr (fun dp -> fold_sd (fun sd -> f (Dp (dp,sd,Dir R)))) r in let r = F.fold_dpw (fun dp -> fold_sd (fun sd -> f (Dp (dp,sd,Dir W)))) r in let r = f Id r in let r = f (Node R) (f (Node W) r) in let r = f Hat r in let r = fold_com (fun c r -> f (Leave c) r) r in let r = fold_com (fun c r -> f (Back c) r) r in r let fold_atomo f k = f None (F.fold_atom (fun a k -> f (Some a) k) k) let fold_mixed f k = F.fold_mixed (fun a k -> f (Some a) k) k let fold_atomo_list aos f k = List.fold_right (fun a k -> f (Some a) k) aos k let overlap_atoms a1 a2 = match a1,a2 with | (None,_)|(_,None) -> true | Some a1,Some a2 -> F.overlap_atoms a1 a2 let same_access_atoms a1 a2 = Misc.opt_eq MachMixed.equal (F.get_access_atom a1) (F.get_access_atom a2) (* For rmw instruction any accesses is a priori. However identical accesses are forced for rmw instructions *) let ok_rmw rmw a1 a2 = not (F.is_one_instruction rmw) || same_access_atoms a1 a2 let ok_non_rmw e a1 a2 = do_is_diff e || do_disjoint || (overlap_atoms a1 a2 && not (do_strict_overlap && same_access_atoms a1 a2)) let ok_mixed e a1 a2 = match e with | Rmw rmw -> (* Specific case *) ok_rmw rmw a1 a2 | _ -> (* Situation is controlled by variant for other relaxations *) ok_non_rmw e a1 a2 let do_fold_edges fold_tedges f = fold_atomo (fun a1 -> fold_atomo (fun a2 -> (fold_tedges (fun te k -> match te with | Rmw rmw -> (* Allowed source and target atomicity for rmw *) if F.applies_atom_rmw rmw a1 a2 then begin let e = {a1; a2; edge=te;} in f e k end else k | Id -> begin match a1,a2 with | Some x1,Some x2 when F.compare_atom x1 x2=0 && not (F.is_ifetch a1) -> f { a1; a2;edge=te; } k | None,None -> let e = { a1; a2;edge=te; } in f e k | _,_ -> k end | Insert _|Node _|Store -> begin match a1,a2 with | None,None -> let e = { a1; a2;edge=te; } in f e k | _,_ -> k end | _ -> let d1 = do_dir_src te and d2 = do_dir_tgt te in if applies_atom a1 d1 && applies_atom a2 d2 && (Misc.is_none (F.get_access_atom a1) && Misc.is_none (F.get_access_atom a2)|| ok_non_rmw te a1 a2) then f {a1; a2; edge=te;} k else begin if debug then eprintf "Not %s\n" (debug_edge {a1; a2; edge=te;}) ; k end )))) let fold_edges f = do_fold_edges fold_tedges f (* checked later... because rmw accepts all atomicity let d1 = do_dir_src te and d2 = do_dir_tgt te in if applies_atom a1 d1 && applies_atom a2 d2 then f {a1; a2; edge=te;} k else k *) let dir_tgt e = do_dir_tgt e.edge and dir_src e = do_dir_src e.edge and safe_dir e = try begin match do_dir_src e.edge with | Dir d -> Some d | NoDir|Irr -> None end with NotThat _ -> None (***************) (* Atom lexing *) (***************) let iter_atom = Misc.fold_to_iter F.fold_atom let ta = Hashtbl.create 37 let add_lxm lxm a = if dbg > 1 then eprintf "ATOM: %s\n" lxm ; try let old = Hashtbl.find ta lxm in assert (F.compare_atom old a = 0) ; with Not_found -> if not (F.is_ifetch (Some a)) then Hashtbl.add ta lxm a let () = iter_atom (fun a -> add_lxm (pp_atom a) a) let parse_atom s = try Hashtbl.find ta s with Not_found -> Warn.fatal "Bad atom: %s" s let parse_atoms xs = try List.fold_left (fun k x -> List.fold_left (fun k s -> parse_atom s::k) k (LexUtil.just_split x)) [] xs with LexUtil.Error msg -> Warn.fatal "bad atoms list (%s)" msg (**********) (* Lexing *) (**********) let iter_edges = Misc.fold_to_iter fold_edges let t = Hashtbl.create 101 let add_lxm lxm e = if dbg > 1 then eprintf "LXM: %s\n" lxm ; try let old = Hashtbl.find t lxm in if compare old e <> 0 then begin Warn.warn_always "ambiguous lexeme: %s" lxm ; eprintf "%s\n%s\n" (debug_edge old) (debug_edge e) ; assert false end with Not_found -> Hashtbl.add t lxm e (* Fill lexeme table *) let iter_ie = Misc.fold_to_iter fold_ie let four_times_iter_edges compat iter_edges = iter_edges (fun e -> add_lxm (pp_edge_with_xx compat e) e) ; iter_edges (fun e -> match e.a1,e.a2 with | (None,Some _) | (Some _,None) -> add_lxm (pp_edge_with_p compat e) e | _,_ -> ()) ; iter_edges (fun e -> match e.a1,e.a2 with | (_,(Some _ as a)) when a = F.pp_as_a -> add_lxm (pp_edge_with_a compat e) e | ((Some _ as a),_) when a = F.pp_as_a -> add_lxm (pp_edge_with_a compat e) e | _,_ -> ()) ; iter_edges (fun e -> match e.a1,e.a2 with | (None,(Some _ as a)) | ((Some _ as a),None) when a = F.pp_as_a -> add_lxm (pp_edge_with_pa compat e) e | _,_ -> ()) let () = four_times_iter_edges false iter_edges; fold_sd_extr_extr (fun sd e1 e2 () -> add_lxm (pp_strong sd e1 e2) (plain_edge (Fenced (F.strong,sd,e1,e2)))) () ; let fill_opt tag dpo sd e = match dpo with | None -> () | Some dp -> add_lxm (pp_dp_default tag sd e) (plain_edge (Dp (dp,sd,e))) in fold_sd (fun sd () -> fill_opt "Dp" F.ddr_default sd Irr ; fill_opt "Dp" F.ddr_default sd (Dir R) ; fill_opt "Ctrl" F.ctrlr_default sd (Dir R) ; fill_opt "Dp" F.ddw_default sd (Dir W) ; fill_opt "Ctrl" F.ctrlw_default sd (Dir W) ; ()) () ; if not (Hashtbl.mem t "R") then add_lxm "R" (plain_edge (Node R)) ; if not (Hashtbl.mem t "W") then add_lxm "W" (plain_edge (Node W)) ; (*Co aka Ws and LxSx aka Rmw*) four_times_iter_edges true (Misc.fold_to_iter (do_fold_edges fold_tedges_compat)); (* Backward compatibility *) if do_self && F.instr_atom != None then iter_ie (fun ie -> add_lxm (sprintf "Iff%s" (pp_ie ie)) { a1=None; a2=F.instr_atom; edge=(Rf ie); } ; add_lxm (sprintf "Irf%s" (pp_ie ie)) { a1=None; a2=F.instr_atom; edge=(Rf ie); } ; add_lxm (sprintf "Fif%s" (pp_ie ie)) { a1=F.instr_atom; a2=None; edge=(Fr ie); } ; add_lxm (sprintf "Ifr%s" (pp_ie ie)) { a1=F.instr_atom; a2=None; edge=(Fr ie); }); () let fold_pp_edges f = Hashtbl.fold (fun s e k -> if e.a1=None && e.a2=None then f s k else k) t let fences_pp = F.fold_all_fences (fun f k -> (F.pp_fence f,f)::k) [] let parse_fence s = try List.assoc s fences_pp with Not_found -> Warn.fatal "%s is not a fence" s let parse_edge s = try Hashtbl.find t s with Not_found -> Warn.fatal "Bad edge: %s" s let parse_edges s = List.map parse_edge (LexUtil.just_split s) let pp_edges es = String.concat " " (List.map pp_edge es) let do_set_tgt d e = match e with | Po(sd,src,_) -> Po (sd,src,Dir d) | Fenced(f,sd,src,_) -> Fenced(f,sd,src,Dir d) | Dp (dp,sd,_) -> Dp (dp,sd,Dir d) | Rf _ | Hat | Insert _|Store|Id|Node _|Ws _|Fr _|Rmw _|Leave _|Back _-> e and do_set_src d e = match e with | Po(sd,_,tgt) -> Po(sd,Dir d,tgt) | Fenced(f,sd,_,tgt) -> Fenced(f,sd,Dir d,tgt) | Fr _|Hat|Dp _ | Insert _|Store|Id|Node _|Ws _|Rf _|Rmw _|Leave _|Back _ -> e let set_tgt d e = { e with edge = do_set_tgt d e.edge ; } and set_src d e = { e with edge = do_set_src d e.edge ; } let loc_sd e = do_loc_sd e.edge and is_diff e = do_is_diff e.edge let get_ie e = match e.edge with | Id |Po _|Dp _|Fenced _|Rmw _ -> Int | Rf ie|Fr ie|Ws ie -> ie | Leave _|Back _|Hat -> Ext | Insert _|Store|Node _ -> Int type full_ie = IE of ie | LeaveBack let get_full_ie e = match e.edge with | Leave _|Back _ -> LeaveBack | _ -> IE (get_ie e) let as_integers e = F.as_integers e.a1 let is_pair e = F.is_pair e.a1 let can_precede_dirs x y = match x.edge,y.edge with | (Store,Store) -> false | (Id,_)|(_,Id)|(Store,_)|(_,Store) -> true | (Insert _,Insert _) -> do_kvm || do_self | _,_ -> begin match dir_tgt x,dir_src y with | (Irr,Irr) -> false | (Irr,Dir _) | (Dir _,Irr)|(NoDir,_)|(_,NoDir) -> true | Dir d1,Dir d2 -> d1=d2 end let is_ext e = match e.edge with | Rf Ext|Fr Ext|Ws Ext | Leave _|Back _ -> true | _ -> false let is_com e = match e.edge with | Rf _|Fr _|Ws _|Leave _|Back _| Hat -> true | _ -> false let is_fetch e = match e.edge with | Rf _ -> is_ifetch e.a2 | Fr _ -> is_ifetch e.a1 | _ -> is_ifetch e.a1 || ( loc_sd e = Same && is_ifetch e.a2) let compat_atoms a1 a2 = match F.merge_atoms a1 a2 with | None -> false | Some _ -> true let is_po_or_fenced_joker e = match e.edge with | Po(_,Dir J,_) | Po(_,_,Dir J) | Fenced(_,_,Dir J,_) | Fenced(_,_,_,Dir J) -> true | _ -> false let can_precede_atoms x y = match x.a2,y.a1 with | None,_ | _,None -> true | Some a1,Some a2 -> compat_atoms a1 a2 let can_precede x y = can_precede_dirs x y && can_precede_atoms x y (*************************************************************) (* Expansion of irrelevant direction specifications in edges *) (*************************************************************) let expand_dir d f = match d with | Dir _|NoDir -> f d | Irr -> fun k -> f (Dir W) (f (Dir R) k) let expand_dir2 e1 e2 f = expand_dir e1 (fun d1 -> expand_dir e2 (fun d2 -> f d1 d2)) let do_expand_edge e f = match e.edge with | Insert _|Store|Id|Node _|Rf _ | Fr _ | Ws _ | Hat |Rmw _|Dp _|Leave _|Back _ -> f e | Po(sd,e1,e2) -> expand_dir2 e1 e2 (fun d1 d2 -> f {e with edge=Po(sd,d1,d2);}) | Fenced(fe,sd,e1,e2) -> expand_dir2 e1 e2 (fun d1 d2 -> f {e with edge=Fenced(fe,sd,d1,d2);}) let rec do_expand_edges es f suf = match es with | [] -> f suf | e::es -> do_expand_edge e (fun e k -> try let suf = match suf with | [] -> [e] | f::_ -> if can_precede e f then e::suf else raise Exit in do_expand_edges es f suf k with Exit -> k) let expand_edges es f = do_expand_edges (List.rev es) f [] (* resolve *) let rec find_non_insert_store = function | [] -> raise Not_found | e::es -> begin match e.edge with | Insert _|Store -> let bef,ni,aft = find_non_insert_store es in e::bef,ni,aft | _ -> [],e,es end let set_a1 e a = match e.edge with | Node _|Id -> { e with a1=a; a2=a;} | _ -> { e with a1=a;} let set_a2 e a = match e.edge with | Node _|Id -> { e with a1=a; a2=a;} | _ -> { e with a2=a;} let merge_id e1 e2 = match e1.edge,e2.edge with | Id,Id -> begin let a1 = e1.a2 and a2 = e2.a1 in match a1,a2 with | None,None -> Some e1 | (None,(Some _ as a))|((Some _ as a),None) -> Some { e1 with a1=a; a2=a; } | Some a1,Some a2 -> begin match F.merge_atoms a1 a2 with | None -> None (* Merge impossible, will fail later *) | Some _ as a -> Some { e1 with a1=a; a2=a; } end end | _ -> None let merge_ids = let rec do_rec fst = function | [] -> fst,[] | [lst] -> begin match merge_id lst fst with | None -> fst,[lst] | Some e -> e,[] end | e1::(e2::es as k) -> begin match merge_id e1 e2 with | None -> let fst,k = do_rec fst k in fst,e1::k | Some e -> do_rec fst (e::es) end in let rec do_fst = function | []|[_] as es -> es | e1::(e2::es as k) -> begin match merge_id e1 e2 with | None -> let fst,k = do_rec e1 k in fst::k | Some e -> do_fst (e::es) end in do_fst (* resolve_pair e1 e2, merges the end annotation of e1 with the start annotation of e2. Warning: resolve_pair cannot fail, instead it must leave e1 and e2 as they are... *) let resolve_pair e1 e2 = if dbg > 0 then eprintf "Resolve pair <%s,%s> -> " (debug_edge e1) (debug_edge e2) ; let e1,e2 = try let d1 = dir_tgt e1 and d2 = dir_src e2 in match d1,d2 with | Irr,Dir d -> set_tgt d e1,e2 | Dir d,Irr -> e1,set_src d e2 | _,_ -> e1,e2 with NotThat _ -> e1,e2 in let a1 = e1.a2 and a2 = e2.a1 in let r = match a1,a2 with | None,None -> e1,e2 | None,Some a | Some a,None when F.is_ifetch (Some a)-> e1, e2 | None,Some _ -> set_a2 e1 a2,e2 | Some _,None -> e1, set_a1 e2 a1 | Some a1,Some a2 -> begin match F.merge_atoms a1 a2 with | None -> e1,e2 | Some _ as a -> set_a2 e1 a,set_a1 e2 a end in if dbg > 0 then begin let e1,e2 = r in eprintf "<%s,%s>\n" (debug_edge e1) (debug_edge e2) end ; r (* Function merge_pair merges two versions of the same edge with different annotations and direction resolution. It cannot fail *) let merge_dir d1 d2 = match d1,d2 with | (Irr,Dir d)|(Dir d,Irr) -> d | Dir d1,Dir d2 -> assert (d1=d2) ; d1 | (Irr,Irr)|(NoDir,_)|(_,NoDir) -> assert false let merge_atomo a1 a2 = match a1,a2 with | None,Some _ -> a2 | Some _,None -> a1 | None,None -> None | Some a1,Some a2 -> begin match F.merge_atoms a1 a2 with | None -> Warn.fatal "Atoms %s and %s *must* be mergeable" (F.pp_atom a1) (F.pp_atom a2) | Some _ as a -> a end let merge_pair e1 e2 = match e1.edge,e2.edge with | (Id,Id) -> e1 | (Insert _,_)|(_,Insert _) -> assert false | _,_ -> let tgt = merge_dir (dir_tgt e1) (dir_tgt e2) and src = merge_dir (dir_src e1) (dir_src e2) in let e = set_tgt tgt (set_src src e1) in { e with a1 = merge_atomo e1.a1 e2.a1; a2 = merge_atomo e1.a2 e2.a2; } let default_access = Cfg.naturalsize,0 let replace_plain_atom a = match F.get_access_atom a with | Some _ -> a | None -> F.set_access_atom a default_access let replace_plain e = let a1 = replace_plain_atom e.a1 and a2 = replace_plain_atom e.a2 in { e with a1; a2; } let remove_id = List.filter (fun e -> not (is_id e.edge)) let check_mixed = if not do_mixed || do_disjoint then fun _ -> () else List.iter (fun e -> if not (ok_mixed e.edge e.a1 e.a2) then begin match e.edge with | Rmw _ -> Warn.fatal "Illegal mixed-size Rmw edge: %s" (pp_edge e) | _ -> if same_access_atoms e.a1 e.a2 then Warn.fatal "Identical mixed access in %s and `-variant MixedStrictOverlap` mode" (pp_edge e) else Warn.fatal "Non overlapping accesses in %s, allow with `-variant MixedDisjoint`" (pp_edge e) end) let resolve_edges es0 = let es0 = merge_ids es0 in match es0 with | []|[_] -> es0 | e::es -> let rec do_rec e es = match e.edge with | Insert _|Store -> let fst,nxt,es = do_recs es in fst,e,nxt::es | _ -> begin try let es0,e1,es1 = find_non_insert_store es in let e,e1 = resolve_pair e e1 in let fst,f,es = do_recs (es0@(e1::es1)) in fst,e,f::es with Not_found -> try let _,e1,_ = find_non_insert_store es0 in let e,e1 = resolve_pair e e1 in e1,e,es with Not_found -> Warn.user_error "No non-insert-store node in cycle" end and do_recs = function (* This case is handled by Not_found handler above *) | [] -> assert false | e::es -> do_rec e es in let fst,e,es = do_rec e es in let e = match e.edge with | Insert _ -> e | _ -> try merge_pair fst e with exn -> eprintf "Failure <%s,%s>\n" (debug_edge fst) (debug_edge e) ; raise exn in let es = remove_id (e::es) in let es = if do_mixed then List.map replace_plain es else es in if dbg > 0 then eprintf "Check Mixed: %s\n" (pp_edges es) ; check_mixed es ; es (********************) (* Atomic variation *) (********************) (* Apply atomic variation to nodes with no atomicity (ie a = None) This is done after a resolution step (see resolve_edge above), with leaves a1 and a2 to None when there us not neighbouring atomic specification. One atomic variation has been applied to all the a` fields of all edges, we do another step of resolution, so as to set the neighbouring a2 *) let var_fence e f r = match e.edge with | Fenced (fe,sd,ex1,ex2) when F.compare_fence fe F.strong = 0 -> F.var_fence (fun fe r -> f {e with edge = Fenced (fe,sd,ex1,ex2)} r) r | _ -> f e r let varatom es f r = let rec var_rec ves es r = match es with | [] -> f (resolve_edges (List.rev ves)) r | e::es -> var_fence e (fun e r -> match e.a1 with | Some _ -> var_rec (e::ves) es r | None -> begin match dir_src e with | Dir d -> F.varatom_dir d (fun a r -> var_rec ({e with a1=a}::ves) es r) r | NoDir -> var_rec (e::ves) es r | Irr -> assert false (* resolved at this step *) end) r in var_rec [] es r (* compact *) let seq_sd e1 e2 = match loc_sd e1,loc_sd e2 with | Same,Same -> Same | _,_ -> Diff let fst_dp e1 e2 k = match e1.edge with | Dp (d,_,_) -> let ds = F.fst_dp d in List.fold_right (fun d k -> [plain_edge (Dp (d, seq_sd e1 e2,dir_tgt e2))]::k) ds k | _ -> k let sequence_dp e1 e2 k = match e1.edge,e2.edge with | Dp (d1,_,_),Dp (d2,_,_) -> let ds = F.sequence_dp d1 d2 in List.fold_right (fun d k -> [plain_edge (Dp (d, seq_sd e1 e2,dir_tgt e2))]::k) ds k | _,_ -> k let rec set_last xs y = match xs with | [] -> assert false | [_] -> [y] | x::xs -> x::set_last xs y let set_fst y xs = match xs with | _::xs -> y::xs | [] -> assert false let fst_fence xs ys e1 e2 k = match e1.edge with | Fenced (f,_,_,_) -> let ne = plain_edge (Fenced (f, seq_sd e1 e2,dir_src e1,dir_tgt e2)) in [ne]::set_last xs ne::set_fst ne ys::k | _ -> k let snd_fence xs ys e1 e2 k = match e2.edge with | Fenced (f,_,_,_) -> let ne = plain_edge (Fenced (f, seq_sd e1 e2,dir_src e1,dir_tgt e2)) in [ne]::set_last xs ne::set_fst ne ys::k | _ -> k let po e1 e2 k = [plain_edge (Po (seq_sd e1 e2,dir_src e1,dir_tgt e2))]::k let com e1 e2 k = match e1.edge,e2.edge with | Ws _,Ws _ | Fr _,Ws _ -> [e1]::k | Rf _,Fr _ -> [plain_edge (Ws Int)]::k | _,_ -> k let compact_sequence xs ys e1 e2 = let k = com e1 e2 [] in let k = po e1 e2 k in let k = snd_fence xs ys e1 e2 k in let k = fst_fence xs ys e1 e2 k in let k = fst_dp e1 e2 k in let k = sequence_dp e1 e2 k in k module Set = MySet.Make (struct type t = edge let compare = compare end) module Map = MyMap.Make (struct type t = edge let compare = compare end) let show = let open ShowGen in function | Edges -> let es = fold_pp_edges (fun s k -> s::k) [] in let es = List.sort String.compare es in List.iter (eprintf " %s") es ; eprintf "\n%!" | Annotations -> let es = F.fold_atom (fun a k -> let ao = Some a in if F.is_ifetch ao then k else { edge=Id; a1=ao; a2=ao;}::k) [] in List.iter (fun e -> eprintf " %s" (pp_edge e)) es ; eprintf "\n%!" | Fences -> F.fold_all_fences (fun f () -> eprintf " %s" (F.pp_fence f)) () ; eprintf "\n%!" end herd-herdtools7-1ca343e/gen/exch.ml000066400000000000000000000041151475314470400171750ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2019-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** The only RMW is exchange *) module Make (I: sig type atom val pp : string val is_one_instruction : bool end) = struct type rmw = unit type rmw_atom = I.atom let pp_rmw compat () = if compat then "Rmw" else I.pp let is_one_instruction _ = I.is_one_instruction let fold_rmw f r = f () r let fold_rmw_compat f r = f () r let applies_atom_rmw () ar aw = match ar,aw with | None,None -> true | _,_ -> false let show_rmw_reg () = false let compute_rmw () _old co_cell = co_cell end module LxSx(A:sig type arch_atom end) = struct include Make (struct type atom = A.arch_atom let pp = "LxSx" let is_one_instruction = false end) end module Exch(A:sig type arch_atom end) = struct include Make (struct type atom = A.arch_atom let pp = "Exch" let is_one_instruction = true end) end herd-herdtools7-1ca343e/gen/exch.mli000066400000000000000000000027541475314470400173550ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2019-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** The only RMW is exchange *) (* Implemented as load reserve store conditional *) module LxSx(A:sig type arch_atom end) : Rmw.S with type rmw = unit and type rmw_atom = A.arch_atom (* Implemented as exchange instruction *) module Exch(A:sig type arch_atom end) : Rmw.S with type rmw = unit and type rmw_atom = A.arch_atom herd-herdtools7-1ca343e/gen/fence.mli000066400000000000000000000051241475314470400175000ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module type Edge = sig type arch_edge val pp_arch_edge : arch_edge -> string val dir_tgt : arch_edge -> Code.dir val dir_src : arch_edge -> Code.dir val loc_sd : arch_edge -> Code.sd val get_ie : arch_edge -> Code.ie val fold_edge : (arch_edge -> 'a -> 'a) -> 'a -> 'a end module type S = sig (* Atoms *) include Atom.S (* Page table entry *) module PteVal : PteVal_gen.S with type pte_atom = atom (* Fences *) type fence val is_isync : fence -> bool val compare_fence : fence -> fence -> int val default : fence val strong : fence val pp_fence : fence -> string val fold_cumul_fences : (fence -> 'a -> 'a) -> 'a -> 'a val fold_all_fences : (fence -> 'a -> 'a) -> 'a -> 'a val fold_some_fences : (fence -> 'a -> 'a) -> 'a -> 'a open Code val orders : fence -> dir -> dir -> bool val var_fence : (fence -> 'a -> 'a) -> 'a -> 'a (* Dependencies *) type dp val pp_dp : dp -> string val fold_dpr : (dp -> 'a -> 'a) -> 'a -> 'a val fold_dpw : (dp -> 'a -> 'a) -> 'a -> 'a (* Defaults for backward compatibility *) val ddr_default : dp option val ddw_default : dp option val ctrlr_default : dp option val ctrlw_default : dp option (* Predicate for control on reads *) val is_ctrlr : dp -> bool val is_addr : dp -> bool (* Sequence dependencies *) val fst_dp : dp -> dp list val sequence_dp : dp -> dp -> dp list (* Read-Modify-Write *) include Rmw.S with type rmw_atom = atom end herd-herdtools7-1ca343e/gen/final.ml000066400000000000000000000261461475314470400173470ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2014-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module type Config = sig val verbose : int val cond : Config.cond val optcond : bool val hexa : bool val variant : Variant_gen.t -> bool end module Make : functor (O:Config) -> functor (C:ArchRun.S) -> sig (* During compilation of cycle, final state is a pair eventmap * fenv, where + fenv associates locations to final values; + eventmap maps one event to the register written by the node. This is useful only for simulating execution in `-cond unicond` mode *) type vset type fenv = (C.A.location * vset) list type eventmap = C.A.location C.C.EventMap.t (* Add an observation to fenv *) val add_final_v : Code.proc -> C.A.arch_reg -> IntSet.t -> fenv -> fenv val add_final_pte : Code.proc -> C.A.arch_reg -> C.A.PteVal.t -> fenv -> fenv val add_final_loc : Code.proc -> C.A.arch_reg -> string -> fenv -> fenv val cons_int : C.A.location -> int -> fenv -> fenv val cons_vec : C.A.location -> int array -> fenv -> fenv val cons_pteval : C.A.location -> C.A.PteVal.t -> fenv -> fenv val cons_int_set : (C.A.location * IntSet.t) -> fenv -> fenv val add_int_sets : fenv -> (C.A.location * IntSet.t) list -> fenv (* Standard function to record an association from register to expected value: Call is `add_final get_friends proc reg node (map,fenv)`, where: + get_friends returns the "friends of register", friends are registers whose expected value is identical. Those may stem from instructions that write into several registers. + proc is a thread identifier. + reg is a register option, when None nothing happens. + node is the current node. + (map,env) is the old final structure. *) val add_final : (C.A.arch_reg -> C.A.arch_reg list) -> Code.proc -> C.A.arch_reg option -> C.C.node -> eventmap * fenv -> eventmap * fenv type faults = (Proc.t * StringSet.t) list type final val check : fenv -> faults -> final val observe : fenv -> faults -> final val run : C.C.event list list -> C.A.location C.C.EventMap.t -> faults -> final val dump_final : out_channel -> final -> unit (* Complement init environemt *) val extract_ptes : fenv -> C.A.location list end = functor (O:Config) -> functor (C:ArchRun.S) -> struct let do_kvm = Variant_gen.is_kvm O.variant type v = I of int | S of string | P of C.A.PteVal.t let pte_def = P (C.A.PteVal.default "*") let () = ignore pte_def let looks_like_array = function | S s -> String.length s > 0 && s.[0] = '{' | _ -> false module VSet = MySet.Make (struct type t = v let compare v1 v2 = match v1,v2 with | I i1,I i2 -> compare i1 i2 | S s1,S s2 -> String.compare s1 s2 | P p1,P p2 -> C.A.PteVal.compare p1 p2 | ((P _|S _),I _) | (P _,S _) -> -1 | (I _,(S _|P _)) | (S _,P _) -> +1 end) type vset = VSet.t type fenv = (C.A.location * vset) list type eventmap = C.A.location C.C.EventMap.t let show_in_cond = if O.optcond then let valid_edge m = let e = m.C.C.edge in let open C.E in match e.C.E.edge with | Rf _ | Fr _ | Ws _ | Hat | Back _|Leave _ -> true | Rmw rmw -> C.A.show_rmw_reg rmw | Po _ | Fenced _ | Dp _ -> begin match C.E.loc_sd e with | Code.Same -> true | Code.Diff -> false end |Insert _|Store|Node _ -> false | Id -> assert false in (fun n -> let p = C.C.find_non_pseudo_prev n.C.C.prev in valid_edge p || valid_edge n) else (fun _ -> true) let intset2vset is = IntSet.fold (fun v k -> VSet.add (I v) k) is VSet.empty let add_final_v p r v finals = (C.A.of_reg p r,intset2vset v)::finals let add_final_pte p r v finals = (C.A.of_reg p r,VSet.singleton (P v))::finals let add_final_loc p r v finals = let loc = C.A.of_reg p r in (loc,VSet.singleton (S v))::finals let cons_int loc i fs = (loc,VSet.singleton (I i))::fs let cons_vec loc t fs = let vec = Code.add_vector O.hexa (Array.to_list t) in (loc,VSet.singleton (S vec))::fs let cons_pteval loc p fs = (loc,VSet.singleton (P p))::fs let cons_int_set (l,is) fs = (l,intset2vset is)::fs let add_int_sets fs f = fs@List.map (fun (l,is) -> l,intset2vset is) f let prev_value = fun v -> v-1 let add_final get_friends p o n finals = match o with | Some r -> let m,fs = finals in let evt = n.C.C.evt in let bank = evt.C.C.bank in let v = match evt.C.C.dir with | Some Code.R -> begin match bank with | Code.CapaTag | Code.CapaSeal | Code.Ord | Code.Pair | Code.Instr -> Some (I evt.C.C.v) | Code.VecReg _-> let v0 = match evt.C.C.vecreg with | [] -> assert false | v0::_ -> v0 in let vec = Code.add_vector O.hexa v0 in Some (S vec) | Code.Tag -> Some (S (Code.add_tag (Code.as_data evt.C.C.loc) evt.C.C.v)) | Code.Pte -> Some (P evt.C.C.pte) end | Some Code.W -> assert (evt.C.C.bank = Code.Ord || evt.C.C.bank = Code.CapaSeal) ; Some (I (prev_value evt.C.C.v)) | None|Some Code.J -> None in if show_in_cond n then match v with | Some v -> let add_to_fs r v fs = (C.A.of_reg p r,VSet.singleton v)::fs in let vs = match bank with | Code.VecReg _ -> begin match evt.C.C.vecreg with | _::vs -> List.map (fun v -> S (Code.add_vector O.hexa v)) vs | _ -> assert false end | _ -> [] in let m = C.C.EventMap.add n.C.C.evt (C.A.of_reg p r) m and fs = try add_to_fs r v (List.fold_right2 add_to_fs (get_friends r) vs fs) with Invalid_argument _ -> Printf.eprintf "Something wrong on %s\n" (C.C.str_node n) ; assert false in m,fs | None -> finals else finals | None -> finals type faults = (Proc.t * StringSet.t) list type cond_final = | Exists of fenv | Forall of (C.A.location * Code.v) list list | Locations of C.A.location list type final = cond_final * faults module Run = Run_gen.Make(O)(C) let check f flts = Exists f,flts let observe f flts = Locations (List.map fst f),flts let run evts m flts = Forall (Run.run evts m),flts (* Dumping *) open Printf let dump_val = function | I i -> if O.hexa then sprintf "0x%x" i else sprintf "%i" i | S s -> s | P p -> C.A.PteVal.pp p let dump_tag = function | I i -> i | _ -> Warn.fatal "Tags can only be of type integer" let dump_atom r v = match Misc.tr_atag (C.A.pp_location r) with | Some s -> sprintf "[tag(%s)]=%s" s (Code.add_tag "" (dump_tag v)) | None -> let pp_loc = if looks_like_array v then C.A.pp_location else C.A.pp_location_brk in sprintf "%s=%s" (pp_loc r) (dump_val v) let dump_state fs = String.concat " /\\ " (List.map (fun (r,vs) -> match VSet.as_singleton vs with | Some v -> dump_atom r v | None -> let pp = VSet.pp_str " \\/ " (fun v -> dump_atom r v) vs in sprintf "(%s)" pp) fs) let dump_one_flt p x = sprintf "fault (%s,%s)" (Proc.pp p) x let dump_flt sep (p,xs) = StringSet.pp_str sep (dump_one_flt p) xs let dump_flts = if do_kvm then fun _ -> "" else fun flts -> let pp = List.map (dump_flt " \\/ ") flts in let pp = String.concat " \\/ " pp in match flts with | [] -> "" | [_,xs] when StringSet.is_singleton xs -> "~" ^ pp | _ -> sprintf "~(%s)" pp let dump_locations chan = function | [] -> () | locs -> fprintf chan "locations [%s]\n" (String.concat " " locs) let dump_final chan (f,flts) = let loc_flts = if do_kvm then List.fold_right (fun (p,xs) -> StringSet.fold (fun x k -> sprintf "%s;" (dump_one_flt p x)::k) xs) flts [] else [] in match f with | Exists fs -> dump_locations chan loc_flts ; let ppfs = dump_state fs and ppflts = dump_flts flts in let cc = match ppfs,ppflts with | "","" -> "" | "",_ -> ppflts | _,"" -> sprintf "(%s)" ppfs | _,_ -> sprintf "(%s) /\\ %s" ppfs ppflts in if cc <> "" then fprintf chan "%sexists %s\n" (if !Config.neg then "~" else "") cc | Forall ffs -> dump_locations chan loc_flts ; fprintf chan "forall\n" ; fprintf chan "%s%s\n" (Run.dump_cond ffs) (match dump_flts flts with | "" -> "" | pp -> " /\\ "^pp) | Locations locs -> dump_locations chan (List.fold_right (fun loc k -> sprintf "%s;" (C.A.pp_location loc)::k) locs loc_flts) ; begin match dump_flts flts with | "" -> () | pp -> if not do_kvm then fprintf chan "forall %s\n" pp end (* Extract ptes *) let extract_ptes = List.fold_left (fun k (loc,vset) -> if VSet.exists (function | P _ -> true | (I _|S _) -> false) vset then loc::k else k) [] end herd-herdtools7-1ca343e/gen/genUtils.ml000066400000000000000000000111251475314470400200370ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2018-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) let to_full emit st p init n x = init,emit st p init n x,st module type Config = sig val hexa : bool val variant : Variant_gen.t -> bool end module type Extra = sig val use_symbolic : bool type reg type instruction val mov : reg -> int -> instruction val mov_mixed : MachSize.sz -> reg -> int -> instruction val mov_reg : reg -> reg -> instruction val mov_reg_mixed : MachSize.sz -> reg -> reg -> instruction end module Make(Cfg:Config)(A:Arch_gen.S) (Extra : Extra with type reg = A.reg and type instruction = A.pseudo) = struct open A let next_init st p init loc = let rec find_rec = function | (Reg (p0,r0),Some (A.S loc0))::_ when Misc.string_eq loc0 loc && Misc.int_eq p p0 -> r0,init,st | _::rem -> find_rec rem | [] -> let r,st = if Extra.use_symbolic then A.symb_reg (Printf.sprintf "%s%i" loc p),st else A.alloc_reg st in r,(Reg (p,r),Some (A.S loc))::init,st in find_rec init let find_init p init loc = let rec find_rec = function | (Reg (p0,r0),Some (A.S loc0))::_ when Misc.string_eq loc0 loc && Misc.int_eq p p0 -> r0 | _::rem -> find_rec rem | [] -> raise Not_found in find_rec init let next_const st p init k = let rec find_rec = function | (Reg (p0,r0),Some k0)::_ when A.initval_eq k k0 && p = p0 -> r0,init,st | _::rem -> find_rec rem | [] -> let r,st = A.alloc_reg st in r,(Reg (p,r),Some k)::init,st in find_rec init let allow_consts_in_code = not (Cfg.variant Variant_gen.ConstsInInit) (* RISCV limit, fits all ? *) let max_k = 1 lsl 12 and min_k = - (1 lsl 12) let emit_const st p init v = if min_k <= v && v < max_k && allow_consts_in_code then None,init,st else let k = S (Printf.sprintf (if Cfg.hexa then "0x%x" else "%i") v) in let rA,init,st = next_const st p init k in Some rA,init,st let emit_pteval st p init v = next_const st p init (A.P v) let emit_nop st p init nop = let rA,init,st = next_const st p init (S ("instr:\""^nop^"\"")) in rA,init,st let emit_mov st p init v = match emit_const st p init v with | None,init,st -> let rA,st = A.alloc_reg st in rA,init,[Extra.mov rA v],st | Some rA,init,st -> rA,init,[],st let emit_mov_sz sz st p init v = match emit_const st p init v with | None,init,st -> let rA,st = A.alloc_reg st in rA,init,[Extra.mov_mixed sz rA v],st | Some rA,init,st -> rA,init,[],st let emit_mov_fresh st p init v = match emit_const st p init v with | None,init,st -> let rA,st = A.alloc_reg st in rA,init,[Extra.mov rA v],st | Some rA,init,st -> let rB,st = A.alloc_reg st in rB,init,[Extra.mov_reg rB rA],st let emit_mov_sz_fresh sz st p init v = match emit_const st p init v with | None,init,st -> let rA,st = A.alloc_reg st in rA,init,[Extra.mov_mixed sz rA v],st | Some rA,init,st -> let rB,st = A.alloc_reg st in rB,init,[Extra.mov_reg_mixed sz rB rA],st end herd-herdtools7-1ca343e/gen/genUtils.mli000066400000000000000000000060551475314470400202160ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2018-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) val to_full : ('st -> 'p -> 'init -> 'n -> 'x -> 'r) -> 'st -> 'p -> 'init -> 'n -> 'x -> 'init * 'r * 'st module type Config = sig val hexa : bool val variant : Variant_gen.t -> bool end module type Extra = sig val use_symbolic : bool type reg type instruction val mov : reg -> int -> instruction val mov_mixed : MachSize.sz -> reg -> int -> instruction val mov_reg : reg -> reg -> instruction val mov_reg_mixed : MachSize.sz -> reg -> reg -> instruction end module Make : functor (Cfg:Config) -> functor (A:Arch_gen.S) -> functor(Extra : Extra with type reg = A.reg and type instruction = A.pseudo) -> sig val next_init : A.st -> Code.proc -> A.init -> string -> A.arch_reg * A.init * A.st val find_init : Code.proc -> A.init -> string -> A.arch_reg val emit_const : A.st -> Code.proc -> A.init -> int -> A.reg option * A.init * A.st val emit_pteval : A.st -> Code.proc -> A.init -> AArch64PteVal.t -> A.reg * A.init * A.st val emit_nop : A.st -> Code.proc -> A.init -> string -> A.reg * A.init * A.st val emit_mov : A.st -> Code.proc -> A.init -> int -> A.arch_reg * A.init * Extra.instruction list * A.st val emit_mov_sz : MachSize.sz -> A.st -> Code.proc -> A.init -> int -> A.arch_reg * A.init * Extra.instruction list * A.st val emit_mov_fresh : A.st -> Code.proc -> A.init -> int -> A.arch_reg * A.init * Extra.instruction list * A.st val emit_mov_sz_fresh : MachSize.sz -> A.st -> Code.proc -> A.init -> int -> A.arch_reg * A.init * Extra.instruction list * A.st end herd-herdtools7-1ca343e/gen/lexConf_gen.mll000066400000000000000000000031701475314470400206510ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) { } let blank = [' ''\t''\r'] let not_blank = [^' ''\t''\n''\r'] let alpha = ['A'-'Z' 'a'-'z'] let opt = '-' (('_'|alpha)+) rule main = parse | eof { [] } | (opt as opt) blank* '\n' {opt :: main lexbuf} | (opt as opt) blank+ ((not_blank [^'\n']* not_blank | not_blank) as arg) blank* {opt :: arg :: main lexbuf} | blank* '\n' {main lexbuf} | '#' [^'\n']* '\n' {main lexbuf} | "" {Warn.fatal "Bad conf file"} { let conf chan = main (Lexing.from_channel chan) } herd-herdtools7-1ca343e/gen/lexLog_gen.mll000066400000000000000000000042161475314470400205070ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) { } let digit = [ '0'-'9' ] let num = digit+ let hexa = ['0'-'9' 'a'-'f' 'A'-'F' ] let alpha = [ 'a'-'z' 'A'-'Z'] let name = alpha (alpha|digit)* let blank = [' ' '\t'] let testname = (alpha|digit|'_' | '/' | '.' | '-' | '+' | '[' | ']')+ rule main add env = parse | eof { env } | ("Cycle=" ([^'\n']+ as cycle) '\n') ? "Relax" blank+ (testname as name) blank+ ("Ok"|"No" as v) blank+ ([^'\n']* as rem) '\n' ("Safe" blank* '=' blank* ([^'\n']* as safes) '\n') ? { let name = Misc.clean_name name in let v = match v with | "Ok" -> true | "No" -> false | _ -> assert false in let relaxs = LexUtil.split rem in let safes = match safes with | None -> [] | Some rem -> LexUtil.split rem in let cycle = match cycle with | None -> "" | Some cy -> cy in main add (add env name v relaxs safes cycle) lexbuf } | [^'\n']* '\n' { main add env lexbuf } | "" { env } { let tokens add env lexbuf = main add env lexbuf } herd-herdtools7-1ca343e/gen/lexUtil.mli000066400000000000000000000025111475314470400200430ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) exception Error of string type t = | One of string | Seq of string list val pp : t -> string val split : string -> t list val just_split : string -> string list herd-herdtools7-1ca343e/gen/lexUtil.mll000066400000000000000000000040431475314470400200500ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) { exception Error of string let error msg = raise (Error msg) type t = | One of string | Seq of string list let pp = function | One s -> Printf.sprintf "One(%s)" s | Seq ss -> Printf.sprintf "Seq(%s)" (String.concat "," ss) } let blank = [','' ''\t''\n''\r'] let not_blank = [^','' ''\t''\n''\r' '[' ']'] rule main = parse | eof { [] } | '[' { let seq = pseq lexbuf in Seq seq::main lexbuf } | blank+ { main lexbuf } | not_blank+ as lxm { One lxm :: main lexbuf } | "" { error "main" } and pseq = parse | eof { failwith "] missing" } | ']' { [] } | blank+ { pseq lexbuf } | not_blank+ as lxm { lxm :: pseq lexbuf } | "" { error "pseq" } and just_split = parse | eof { [] } | blank+ { just_split lexbuf } | not_blank+ as lxm { lxm :: just_split lexbuf } | "" { error "just_split" } { let split s = main (Lexing.from_string s) let just_split s = just_split (Lexing.from_string s) } herd-herdtools7-1ca343e/gen/libdir/000077500000000000000000000000001475314470400171605ustar00rootroot00000000000000herd-herdtools7-1ca343e/gen/libdir/forbidden.conf000066400000000000000000000131721475314470400217670ustar00rootroot00000000000000# The Armv8 Application Level Memory Model. # # This is a machine-readable, executable and formal artefact, which aims to # generate systematic families of litmus tests which are forbidden by the Arm # memory model. # If you have comments on the content of this file, please send an email to # jade.alglave@arm.com, referring to version number: # 9470edab1356b1d824422808bf681d59529e8b91 # # For the executable formal Armv memory model, see: # https://developer.arm.com/architectures/cpu-architecture/a-profile/memory-model-tool # For a textual version of the model, see section B2.3 of the Armv8 ARM: # https://developer.arm.com/docs/ddi0487/latest/arm-architecture-reference-manual-armv8-for-armv8-a-architecture-profile # # Author: Will Deacon # Author: Jade Alglave # # Copyright (C) 2016-2020, Arm Ltd. # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are # met: # # * Redistributions of source code must retain the above copyright # notice, this list of conditions and the following disclaimer. # * 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. # * Neither the name of ARM nor the names of its contributors may be # used to endorse or promote products derived from this software # without specific prior written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT # HOLDER 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. -arch AArch64 -nprocs 2 -size 8 -name Armv8-ext-forbidden -relaxlist Rfe Fre Wse Hat DpAddrdR DpAddrdW DpAddrsR DpAddrsW DpDatadW DpDatasW DpCtrldW DpCtrlsW DpCtrlIsbdR [DpAddrdR, ISBd*R] [DpAddrdW, ISBd*R] DpCtrlIsbsR [DpAddrsR, ISBs*R] [DpAddrsW, ISBs*R] [DpAddrsR, ISBd*R] [DpAddrsW, ISBd*R] [DpAddrdR, ISBs*R] [DpAddrdW, ISBs*R] [DpAddrdR, Pod*W] [DpAddrdW, Pod*W] [DpAddrsR, Pos*W] [DpAddrsW, Pos*W] [DpAddrsR, Pod*W] [DpAddrsW, Pod*W] [DpAddrdR, Pos*W] [DpAddrdW, Pos*W] [DpAddrdW, Rfi] [DpDatadW, Rfi] [DpAddrsW, Rfi] [DpDatasW, Rfi] DMB.SYd** DMB.SYs** PodWRLA PosWRLA DMB.LDdR* DMB.LDsR* PodR*AP PodR*QP PosR*AP PosR*QP PodRRAA PodRRQA PosRRAA PosRRQA PodRRAQ PodRRQQ PosRRAQ PosRRQQ PodRWAL PodRWQL PosRWAL PosRWQL DMB.STdWW DMB.STsWW Pod*WPL Pos*WPL PodWWLL PosWWLL Pos*W LxSx LxSxAP LxSxPL LxSxAL [LxSx, RfiPA] [LxSx, RfiPQ] [LxSxAP, RfiPA] [LxSxAP, RfiPQ] [LxSxPL, RfiLA] [LxSxPL, RfiLQ] [LxSxAL, RfiLA] [LxSxAL, RfiLQ] Amo.Swp Amo.Cas Amo.LdAdd Amo.LdEor Amo.LdClr Amo.LdSet Amo.StAdd Amo.StEor Amo.StClr Amo.StSet Amo.SwpAP Amo.CasAP Amo.LdAddAP Amo.LdEorAP Amo.LdClrAP Amo.LdSetAP Amo.SwpPL Amo.CasPL Amo.LdAddPL Amo.LdEorPL Amo.LdClrPL Amo.LdSetPL Amo.StAddPL Amo.StEorPL Amo.StClrPL Amo.StSetPL Amo.SwpAL Amo.CasAL Amo.LdAddAL Amo.LdEorAL Amo.LdClrAL Amo.LdSetAL [Amo.Swp, RfiPA] [Amo.Cas, RfiPA] [Amo.LdAdd, RfiPA] [Amo.LdEor, RfiPA] [Amo.LdClr, RfiPA] [Amo.LdSet, RfiPA] [Amo.StAdd, RfiPA] [Amo.StEor, RfiPA] [Amo.StClr, RfiPA] [Amo.StSet, RfiPA] [Amo.Swp, RfiPQ] [Amo.Cas, RfiPQ] [Amo.LdAdd, RfiPQ] [Amo.LdEor, RfiPQ] [Amo.LdClr, RfiPQ] [Amo.LdSet, RfiPQ] [Amo.StAdd, RfiPQ] [Amo.StEor, RfiPQ] [Amo.StClr, RfiPQ] [Amo.StSet, RfiPQ] [Amo.SwpAP, RfiPA] [Amo.CasAP, RfiPA] [Amo.LdAddAP, RfiPA] [Amo.LdEorAP, RfiPA] [Amo.LdClrAP, RfiPA] [Amo.LdSetAP, RfiPA] [Amo.SwpAP, RfiPQ] [Amo.CasAP, RfiPQ] [Amo.LdAddAP, RfiPQ] [Amo.LdEorAP, RfiPQ] [Amo.LdClrAP, RfiPQ] [Amo.LdSetAP, RfiPQ] [Amo.SwpPL, RfiLA] [Amo.CasPL, RfiLA] [Amo.LdAddPL, RfiLA] [Amo.LdEorPL, RfiLA] [Amo.LdClrPL, RfiLA] [Amo.LdSetPL, RfiLA] [Amo.StAddPL, RfiLA] [Amo.StEorPL, RfiLA] [Amo.StClrPL, RfiLA] [Amo.StSetPL, RfiLA] [Amo.SwpPL, RfiLQ] [Amo.CasPL, RfiLQ] [Amo.LdAddPL, RfiLQ] [Amo.LdEorPL, RfiLQ] [Amo.LdClrPL, RfiLQ] [Amo.LdSetPL, RfiLQ] [Amo.StAddPL, RfiLQ] [Amo.StEorPL, RfiLQ] [Amo.StClrPL, RfiLQ] [Amo.StSetPL, RfiLQ] [Amo.SwpAL, RfiLA] [Amo.CasAL, RfiLA] [Amo.LdAddAL, RfiLA] [Amo.LdEorAL, RfiLA] [Amo.LdClrAL, RfiLA] [Amo.LdSetAL, RfiLA] [Amo.SwpAL, RfiLQ] [Amo.CasAL, RfiLQ] [Amo.LdAddAL, RfiLQ] [Amo.LdEorAL, RfiLQ] [Amo.LdClrAL, RfiLQ] [Amo.LdSetAL, RfiLQ] [Pod**, Amo.SwpAL] [Pod**, Amo.CasAL] [Pod**, Amo.LdAddAL] [Pod**, Amo.LdEorAL] [Pod**, Amo.LdClrAL] [Pod**, Amo.LdSetAL] [Pos**, Amo.SwpAL] [Pos**, Amo.CasAL] [Pos**, Amo.LdAddAL] [Pos**, Amo.LdEorAL] [Pos**, Amo.LdClrAL] [Pos**, Amo.LdSetAL] [Amo.SwpAL, Pod**] [Amo.CasAL, Pod**] [Amo.LdAddAL, Pod**] [Amo.LdEorAL, Pod**] [Amo.LdClrAL, Pod**] [Amo.LdSetAL, Pod**] [Amo.SwpAL, Pos**] [Amo.CasAL, Pos**] [Amo.LdAddAL, Pos**] [Amo.LdEorAL, Pos**] [Amo.LdClrAL, Pos**] [Amo.LdSetAL, Pos**] [Pod**, Amo.SwpAL, Pod**] [Pod**, Amo.CasAL, Pod**] [Pod**, Amo.LdAddAL, Pod**] [Pod**, Amo.LdEorAL, Pod**] [Pod**, Amo.LdClrAL, Pod**] [Pod**, Amo.LdSetAL, Pod**] [Pos**, Amo.SwpAL, Pos**] [Pos**, Amo.CasAL, Pos**] [Pos**, Amo.LdAddAL, Pos**] [Pos**, Amo.LdEorAL, Pos**] [Pos**, Amo.LdClrAL, Pos**] [Pos**, Amo.LdSetAL, Pos**] herd-herdtools7-1ca343e/gen/libdir/forbidden_ifetch.conf000066400000000000000000000031331475314470400233050ustar00rootroot00000000000000-arch AArch64 -relax [FreIP PodW* DC.CVAUp DSB.ISH IC.IVAUp DSB.ISH] [FreIP PosW* DC.CVAUp DSB.ISH IC.IVAUp DSB.ISH] [FreIP PodW*PI DC.CVAUp DSB.ISH IC.IVAUp DSB.ISH ISB] [FreIP PosW*PI DC.CVAUp DSB.ISH IC.IVAUp DSB.ISH ISB] [DpCtrldRPI IC.IVAUn DSB.ISH ISB FreIP PodW* DC.CVAUp DMB.ISH] [DpCtrldRPI IC.IVAUn DSB.ISH ISB FreIP PodW* DC.CVAUp DSB.ISH] [DpAddrdRPI IC.IVAUn DSB.ISH ISB FreIP PodW* DC.CVAUp DMB.ISH] [ Pod*RPI DSB.ISH IC.IVAUn DSB.ISH ISB FreIP PodW* DC.CVAUp DSB.ISH] [Pod*RPI DSB.ISH IC.IVAUn DSB.ISH ISB FreIP PodW* DC.CVAUp DMB.ISH] [ Pod*RPI DSB.ISH DC.CVAUn DSB.ISH IC.IVAUn DSB.ISH ISB FreIP] [ DpCtrldRPI DC.CVAUn DSB.ISH IC.IVAUn DSB.ISH ISB FreIP] [ DpAddrdRPI DC.CVAUn DSB.ISH IC.IVAUn DSB.ISH ISB FreIP] [Pod*RPI DMB.ISH DC.CVAUn DSB.ISH IC.IVAUn DSB.ISH ISB FreIP] [PodRRII FreIP PodW* DC.CVAUp DSB.ISH IC.IVAUp DSB.ISH] RfePI PodR*IP [DSB.ISHd*RPI ISB] [DpAddrdR, ISBd*RPI] [DpAddrdW, ISBd*RPI] [DpAddrsR, ISBs*RPI] [DpAddrsW, ISBs*RPI] [DpAddrsR, ISBd*RPI] [DpAddrsW, ISBd*RPI] [DpAddrdR, ISBs*RPI] [DpAddrdW, ISBs*RPI] -safe Rfe Fre Coe DMB.ISHd** DMB.STdWW DpAddrdR DpAddrdW DpAddrsR DpAddrsW DpDatadW DpDatasW DpCtrldW DpCtrlsW DpCtrlIsbdR [DpAddrdR, ISBd*R] [DpAddrdW, ISBd*R] DpCtrlIsbsR [DpAddrsR, ISBs*R] [DpAddrsW, ISBs*R] [DpAddrsR, ISBd*R] [DpAddrsW, ISBd*R] [DpAddrdR, ISBs*R] [DpAddrdW, ISBs*R] [DpAddrdR, Pod*W] [DpAddrdW, Pod*W] [DpAddrsR, Pos*W] [DpAddrsW, Pos*W] [DpAddrsR, Pod*W] [DpAddrsW, Pod*W] [DpAddrdR, Pos*W] [DpAddrdW, Pos*W] [DpAddrdW, Rfi] [DpDatadW, Rfi] [DpAddrsW, Rfi] [DpDatasW, Rfi] -moreedges true -ins 10 -nprocs 2 -size 4 -mix true -maxrelax 3 -variant self herd-herdtools7-1ca343e/gen/lineUtils.ml000066400000000000000000000043631475314470400202230ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Parse a line of edges + optional scope tree *) module type E = sig type edge val parse_edges : string -> edge list end module Make(E:E) :sig val parse : string -> string * E.edge list * BellInfo.scopes option end = struct let parse s = try let r = String.index s ':' in let name = String.sub s 0 r and es = String.sub s (r+1) (String.length s - (r+1)) in let es,st = try let r = String.index es '(' in let es = String.sub es 0 r and st = String.sub es r (String.length es - r) in es,Some st with Not_found -> es,None in let es = E.parse_edges es in let st = match st with | None -> None | Some st -> let module Lexer = ScopeLexer.Make(LexUtils.Default) in let lexbuf = Lexing.from_string st in let st = GenParserUtils.call_parser "_none_" lexbuf Lexer.token ScopeParser.main in Some st in name,es,st with | Not_found | Invalid_argument _ -> Warn.fatal "bad line: %s" s end herd-herdtools7-1ca343e/gen/logRelax.ml000066400000000000000000000047721475314470400200340ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module type I = sig type relax val parse : LexUtil.t -> relax end module type S = sig type relax type outcome = { name : string ; validates : bool ; relaxs : relax list ; safes : relax list ; cycle : string ; } val add_files : string list -> outcome list end module Make(R:I) : S with type relax = R.relax = struct type relax = R.relax type outcome = { name : string ; validates : bool ; relaxs : relax list ; safes : relax list ; cycle : string ; } let rec parse_relaxs = function | [] -> [] | r::rs -> try let r = R.parse r in r::parse_relaxs rs with Misc.Fatal msg -> Warn.warn_always "%s" msg ; assert false let add_outcome env name validates rs ss cy = let rs = parse_relaxs rs and ss = parse_relaxs ss in {name=name; validates=validates; relaxs=rs; safes=ss; cycle=cy; }::env let add_file env name = try Misc.input_protect (fun chan -> LexLog_gen.tokens add_outcome env (Lexing.from_channel chan)) name with Misc.Fatal msg -> Warn.warn_always "%s" msg ; env let add_files names = let all = List.fold_left add_file [] names in let all = List.sort (fun o1 o2 -> String.compare o1.name o2.name) all in all end herd-herdtools7-1ca343e/gen/machAtom.ml000066400000000000000000000065601475314470400200050ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2014-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Atomicity of events *) module type Config = sig val naturalsize : MachSize.sz option val endian : Endian.t val fullmixed : bool end module Make(C:Config) = struct module Mixed = MachMixed.Make(C) let bellatom = false module SIMD = NoSIMD type hidden_atom = Atomic | Reserve | Mixed of MachMixed.t type atom = hidden_atom let default_atom = Atomic let instr_atom = None open Code let applies_atom a d = match a,d with | Reserve,W -> false | _,_ -> true let is_ifetch _ = false let pp_plain = Code.plain let pp_as_a = None let pp_atom = function | Atomic -> "A" | Reserve -> "R" | Mixed mix -> Mixed.pp_mixed mix let compare_atom = compare let get_access_atom a = match a with | None | Some (Atomic|Reserve) -> None | Some (Mixed m) -> Some m let set_access_atom a sz = Some (match a with | None|Some (Mixed _) -> Mixed sz | Some (Atomic|Reserve as a) -> a) let fold_mixed f r = Mixed.fold_mixed (fun mix r -> f (Mixed mix) r) r let fold_non_mixed f r = f Reserve (f Atomic r) let fold_atom f r = let r = fold_mixed f r in fold_non_mixed f r let worth_final = function | Atomic -> true | Reserve -> false | Mixed _ -> false let varatom_dir _d f = f None let merge_atoms a1 a2 = if a1 = a2 then Some a1 else None let overlap_atoms a1 a2 = match a1,a2 with | ((Atomic|Reserve),_)|(_,(Atomic|Reserve)) -> true | Mixed sz1,Mixed sz2 -> MachMixed.overlap sz1 sz2 (* Single memory bank *) let atom_to_bank _ = Code.Ord (**************) (* Mixed-size *) (**************) let tr_value ao v = match ao with | None| Some (Atomic|Reserve) -> v | Some (Mixed (sz,_)) -> Mixed.tr_value sz v module ValsMixed = MachMixed.Vals (struct let naturalsize () = Misc.as_some C.naturalsize let endian = C.endian end) let overwrite_value v ao w = match ao with | None| Some (Atomic|Reserve) -> w (* total overwrite *) | Some (Mixed (sz,o)) -> ValsMixed.overwrite_value v sz o w let extract_value v ao = match ao with | None| Some (Atomic|Reserve) -> v | Some (Mixed (sz,o)) -> ValsMixed.extract_value v sz o include NoWide end herd-herdtools7-1ca343e/gen/machAtom.mli000066400000000000000000000027201475314470400201500ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2014-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Atomicity of events *) module type Config = sig val naturalsize : MachSize.sz option val endian : Endian.t val fullmixed : bool end module Make : functor (C:Config) -> sig type hidden_atom = Atomic | Reserve | Mixed of MachMixed.t include Atom.S with type atom = hidden_atom end herd-herdtools7-1ca343e/gen/machMixed.ml000066400000000000000000000077621475314470400201600ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module type Config = sig val naturalsize : MachSize.sz option val fullmixed : bool end open MachSize open Endian type offset = int type t = sz * offset let equal (sz1,o1) (sz2,o2) = MachSize.equal sz1 sz2 && Misc.int_eq o1 o2 let disjoint (l1,h1) (l2,h2) = l1 < l2 && h1 <= l2 || l2 < l1 && h2 <= l1 let tr (sz,o) = (o,o+MachSize.nbytes sz) let overlap a1 a2 = let i1 = tr a1 and i2 = tr a2 in not (disjoint i1 i2) module Make(C:Config) = struct open Printf let pp_mixed = function (sz,o) -> sprintf "%s%i" (MachSize.pp_short sz) o let do_fold f sz xs r = List.fold_right (fun o r -> f (sz,o) r) xs r let get_off = match C.naturalsize with | None -> fun _ -> [] | Some sz -> (if C.fullmixed then MachSize.get_off else MachSize.get_off_reduced) sz let fold_mixed f r = let r = do_fold f Byte (get_off Byte) r in let r = do_fold f Short (get_off Short) r in let r = do_fold f Word (get_off Word) r in let r = do_fold f Quad (get_off Quad) r in let r = do_fold f S128 (get_off S128) r in r let rec tr_value sz v = match sz with | Byte -> v | Short -> v lsl 8 + v | Word -> v lsl 24 + v lsl 16 + v lsl 8 + v | Quad -> let x = tr_value Word v in x lsl 32 + x | S128 -> assert false end module type ValsConfig = sig val naturalsize : unit -> MachSize.sz val endian : Endian.t end module Vals(C:ValsConfig) = struct let correct_offset = match C.endian with | Little -> fun _ o -> o | Big -> fun sz o -> let nsz = C.naturalsize () in let bsz = nbytes sz in let bo = o / bsz in let no = bsz * ((nbytes nsz/bsz)-bo-1) in (* Printf.eprintf "tr: %i -> %i\n" o no ; *) no let overwrite_value v sz o w = if sz = C.naturalsize () then w else let o = correct_offset sz o in let sz_bits = MachSize.nbits sz in let nshift = o * 8 in let wshifted = w lsl nshift in let mask = lnot (((1 lsl sz_bits) - 1) lsl nshift) in (v land mask) lor wshifted let extract_value v sz o = let sz_bits = MachSize.nbits sz in let o = correct_offset sz o in let nshift = o * 8 in let mask = match sz with | S128 -> assert false | Quad -> -1 | _ -> (1 lsl sz_bits) - 1 in let r = (v lsr nshift) land mask in (* Printf.eprintf "EXTRACT (%s,%i)[0x%x]: 0x%x -> 0x%x\n" (MachSize.pp sz) o mask v r ; *) r end (** Utilities for atoms supplemented with mixed accesses *) module Util(I:sig type at val plain : at end) = struct let get_access_atom = function | None -> None | Some (_,m) -> m let set_access_atom a acc = Some (match a with | None -> (I.plain,Some acc) | Some (a,_) -> (a,Some acc)) end module No = struct let get_access_atom _ = None let set_access_atom a _ = a end herd-herdtools7-1ca343e/gen/machMixed.mli000066400000000000000000000043541475314470400203230ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module type Config = sig val naturalsize : MachSize.sz option val fullmixed : bool end type offset = int type t = MachSize.sz * offset val equal : t -> t -> bool val overlap : t -> t -> bool module Make : functor (C:Config) -> sig val pp_mixed : t -> string val fold_mixed : (t -> 'a -> 'a) -> 'a -> 'a val tr_value : MachSize.sz -> int -> int end module type ValsConfig = sig val naturalsize : unit -> MachSize.sz val endian : Endian.t end module Vals : functor(C:ValsConfig) -> sig val overwrite_value : int (* old *) -> MachSize.sz -> offset -> int (* write *) -> int val extract_value : int -> MachSize.sz -> offset -> int end (** Utilities for atoms supplemented with mixed accesses *) module Util : functor (I:sig type at val plain : at end) -> sig val get_access_atom : (I.at * t option) option -> t option val set_access_atom : (I.at * t option) option -> t -> (I.at * t option) option end module No : sig val get_access_atom : 'atom option -> t option val set_access_atom : 'atom option -> t -> 'atom option end herd-herdtools7-1ca343e/gen/mexpand.ml000066400000000000000000000056001475314470400177020ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Expand candidate relaxation macros in cycle list *) open Printf let arch = ref `PPC let opts = [Util.arch_opt arch] module type Config = sig end module Make(Co:Config) (A:Arch_gen.S) = struct module E = Edge.Make(Edge.Config)(A) let parse_line s = try let r = String.index s ':' in let name = String.sub s 0 r and es = String.sub s (r+1) (String.length s - (r+1)) in let es = E.parse_edges es in name,es with | Not_found | Invalid_argument _ -> Warn.fatal "bad line: %s" s let add name (key,ps) k = let xs = try StringMap.find key k with Not_found -> [] in StringMap.add key ((name,ps)::xs) k let scan chan = let rec do_rec () = let line = input_line chan in let name,es = parse_line line in printf "%s: %s\n" name (E.pp_edges es) ; do_rec () in try do_rec () with End_of_file -> () let zyva chan = scan chan end let () = Util.parse_cmdline opts (fun _ -> raise (Arg.Bad "No argument")) let () = let module Co = struct end in let module Build = Make(Co) in (match !arch with | `X86 -> let module M = Build(X86Arch_gen) in M.zyva | `PPC -> let module M = Build(PPCArch_gen.Make(PPCArch_gen.Config)) in M.zyva | `ARM -> let module M = Build(ARMArch_gen.Make(ARMArch_gen.Config)) in M.zyva | `AArch64 -> let module M = Build(AArch64Arch_gen.Make(AArch64Arch_gen.Config)) in M.zyva | `MIPS -> let module M = Build(MIPSArch_gen.Make(MIPSArch_gen.Config)) in M.zyva | `LISA -> let module BellConfig = Config.ToLisa(Config) in let module M = Build(BellArch_gen.Make(BellConfig)) in M.zyva | _ -> assert false) stdin herd-herdtools7-1ca343e/gen/namer.ml000066400000000000000000000163651475314470400173620ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2011-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Normalised names for cycles *) open Printf open BellInfo let rec of_scope = function | Tree ("",_,ts) -> of_scopes ts | Tree (sc,ps,[]) -> String.concat "" (List.map (sprintf "%i") ps) ^ "-" ^ sc | Tree (sc,[],ts) -> of_scopes ts ^ "-" ^ sc | Tree (_,_::_,_::_) -> Warn.fatal "Namer.of_scope, irregular scope" and of_scopes ts = String.concat "-" (List.map of_scope ts) module type S = sig type edge val mk_name : string -> ?scope:BellInfo.scopes -> edge list -> string end module Make (A:Fence.S) (E:Edge.S with type dp = A.dp and type fence=A.fence and type atom = A.atom and type rmw = A.rmw) : S with type edge = E.edge = struct type edge = E.edge open Code open E let pp_com c = Misc.lowercase (pp_com c) let edge_name = function | Po (Same,_,_) -> Some "pos" | Po (Diff,_,_) -> Some "po" | Fenced (f,Same,_,_) -> Some (Misc.lowercase (A.pp_fence f) ^ "s") | Fenced (f,Diff,_,_) -> Some (Misc.lowercase (A.pp_fence f)) | Dp (dp,Same,_) -> Some (Misc.lowercase (A.pp_dp dp) ^ "s") | Dp (dp,Diff,_) -> Some (Misc.lowercase (A.pp_dp dp)) | Rf Int -> Some "rfi" | Ws Int -> Some "coi" | Fr Int -> Some "fri" | Rf Ext -> Some "rfe" | Ws Ext -> Some "coe" | Fr Ext -> Some "fre" | Rmw rmw -> (* Note: backward compatible item ("rmw") in names *) Some (Misc.lowercase (A.pp_rmw true rmw)) | Leave c -> Some ("["^pp_com c) | Back c -> Some (pp_com c^"]") | Insert f -> Some (sprintf "[%s]" (Misc.lowercase (A.pp_fence f))) | Store -> Some "store" | Node _ -> assert false | _ -> None let ambiguous_target = function | Po _|Fenced _|Dp _ -> true |Rf _|Ws _|Fr _ |Id|Hat|Leave _|Back _ |Insert _|Store|Node _|Rmw _ -> false and ambiguous_source = function | Po _|Fenced _ -> true |Dp _| Rf _|Ws _|Fr _ |Id|Hat|Leave _|Back _ |Insert _|Store|Node _|Rmw _ -> false let plain = Misc.lowercase (A.pp_plain) let atom_name = function | None -> plain | Some a -> Misc.lowercase (A.pp_atom a) let atoms_name a1 a2 = match a1,a2 with | None,None -> "" | _ -> sprintf "%s%s" (atom_name a1) (atom_name a2) let one_name no_dir e = match edge_name e.edge with | Some n -> let d = if no_dir then "" else Code.pp_extr (E.dir_tgt e) in Some (sprintf "%s%s%s" n d (atoms_name e.a1 e.a2)) | None -> None let all_same = function | x::xs -> let rec do_rec = function | y::ys -> if x = y then do_rec ys else None | [] -> Some x in do_rec xs | [] -> None let rec count_a = function | {edge=(Rf Ext|Fr Ext|Ws Ext); a2=Some a; _}:: ({edge=(Rf Ext|Fr Ext|Ws Ext);a1=Some _; _}::_ as es) -> A.pp_atom a::count_a es | {edge=(Rf Ext|Fr Ext|Ws Ext); a2=None; _}:: ({edge=(Rf Ext|Fr Ext|Ws Ext);a1=None; _}::_ as es) -> Code.plain::count_a es | _::es -> count_a es | [] -> [] let init_a = function | {edge=(Rf Ext|Fr Ext|Ws Ext);a1=Some a; _}::_ as es -> begin match Misc.last es with | {edge=(Rf Ext|Fr Ext|Ws Ext);a2=Some _; _} -> [A.pp_atom a] | _ -> [] end | {edge=(Rf Ext|Fr Ext|Ws Ext);a1=None; _}::_ as es -> begin match Misc.last es with | {edge=(Rf Ext|Fr Ext|Ws Ext);a2=None; _} -> [Code.plain] | _ -> [] end | _ -> [] let isolated_writes es = let es = List.filter (function {edge=Insert _; _} -> false | _ -> true) es in let x = init_a es @ count_a es in let x = if List.for_all (fun s -> s = Code.plain) x then [] else x in String.concat "" x (* New naming convention with '-' inbetween consecutive int edges *) let add_list xs xss = match xs with | [] -> xss | _ -> xs::xss let rec do_po_list d es = match es with | [] -> [],[] | e::es -> let d = match e.E.edge with | E.Leave _ -> d+1 | E.Back _ -> d-1 | _ -> d in let xs,xss = do_po_list d es in match E.get_full_ie e with | E.IE Ext when d <= 0 -> [],add_list xs xss | E.IE _|E.LeaveBack -> (e::xs),xss let po_list = do_po_list 0 let new_namer es = let xs,xss = po_list es in let xss = add_list xs xss in let xs = List.map (fun es -> let rec pp = function | [] -> [] | [e] -> pp_one true e [] | e::(f::_ as es) -> pp_one (not (ambiguous_target e.edge && ambiguous_source f.edge)) e es and pp_one no_dir e es = match one_name no_dir e with | Some s -> s::pp es | None -> Warn.fatal "Namer failiure" in String.concat "-" (pp es)) xss in xs let mk_name base ?scope es = let es = List.filter (fun e -> not (is_node e.E.edge)) es in let name = let xs = new_namer es in let ys = match isolated_writes es with | "" -> [] | s -> [s] in let xs = match all_same xs,xs with | Some "po",_ -> ys | Some "pos",[_] -> ys | Some _x,[_] -> xs@ys | Some x,_::_::_ -> (x ^ "s")::ys | None, _ -> xs@ys | Some _,[] -> assert false in String.concat "+" (base::xs) in let scope = match scope with | None -> "" | Some st -> "+" ^ of_scope st in name ^ scope end herd-herdtools7-1ca343e/gen/nexts.ml000066400000000000000000000070131475314470400174070ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Filter cycles list by number of accesses *) open Code open Printf let arch = ref `PPC let n = ref None let verbose = ref 0 let opts = ("-v", Arg.Unit (fun () -> incr verbose),"be verbose"):: ("-n", Arg.Int (fun x -> n := Some x), " filter cyles by number of accesses (mandatory)"):: Util.arch_opt arch:: [] module type Config = sig val verbose : int val nacc : int end module Make (Co:Config) (A:Arch_gen.S) = struct module E = Edge.Make(Edge.Config)(A) let parse_line s = try let r = String.index s ':' in let name = String.sub s 0 r and es = String.sub s (r+1) (String.length s - (r+1)) in let es = E.parse_edges es in name,es with | Not_found | Invalid_argument _ -> Warn.fatal "bad line: %s" s let count_ext es = List.fold_left (fun k e -> match E.get_ie e with | Ext -> k+1 | Int -> k) 0 es let filter chan = let rec do_rec () = let line = input_line chan in let name,es = parse_line line in let c = count_ext es in if Co.verbose > 0 then eprintf "%s: %i\n" name c ; if c = Co.nacc then printf "%s: %s\n"name (E.pp_edges es) ; do_rec () in try do_rec () with End_of_file -> () let zyva chan = filter chan end let () = Util.parse_cmdline opts (fun _ -> raise (Arg.Bad "No argument")) let () = let module Co = struct let verbose = !verbose let nacc = match !n with | None -> eprintf "Option -n is mandatory\n" ; exit 2 | Some n -> n end in let module Build = Make(Co) in (match !arch with | `X86 -> let module M = Build(X86Arch_gen) in M.zyva | `PPC -> let module M = Build(PPCArch_gen.Make(PPCArch_gen.Config)) in M.zyva | `ARM -> let module M = Build(ARMArch_gen.Make(ARMArch_gen.Config)) in M.zyva | `AArch64 -> let module A = AArch64Arch_gen.Make (struct include AArch64Arch_gen.Config let moreedges = !Config.moreedges end) in let module M = Build(A) in M.zyva | `MIPS -> let module M = Build(MIPSArch_gen.Make(MIPSArch_gen.Config)) in M.zyva | `LISA -> let module BellConfig = Config.ToLisa(Config) in let module M = Build(BellArch_gen.Make(BellConfig)) in M.zyva | _ -> assert false) stdin herd-herdtools7-1ca343e/gen/noEdge.ml000066400000000000000000000025341475314470400174520ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2019-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) type arch_edge let pp_arch_edge _ = assert false let dir_tgt _ = assert false let dir_src _ = assert false let loc_sd _ = assert false let get_ie _ = assert false let fold_edge _ r = r herd-herdtools7-1ca343e/gen/noEdge.mli000066400000000000000000000022651475314470400176240ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2019-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) include Fence.Edge herd-herdtools7-1ca343e/gen/noInfo.ml000066400000000000000000000023231475314470400174750ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2020-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* No info to compute *) let get_archinfo _ = [] herd-herdtools7-1ca343e/gen/noMixed.ml000066400000000000000000000025011475314470400176460ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Do nothing for mixed values, which should not appear *) let fold_mixed _ k = k let tr_value _ v = v let overwrite_value _ _ v = v let extract_value v _ = v herd-herdtools7-1ca343e/gen/noMixed.mli000066400000000000000000000026521475314470400200260ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Do nothing for mixed values, which should not appear *) val fold_mixed : ('a -> 'b -> 'b) -> 'b -> 'b val tr_value : 'a option -> Code.v -> Code.v val overwrite_value : Code. v -> 'a option -> Code.v -> Code.v val extract_value : Code. v -> 'a option -> Code.v herd-herdtools7-1ca343e/gen/noRmw.ml000066400000000000000000000030201475314470400173420ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2021-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** No rmw instruction *) module Make(A:sig type arch_atom end) = struct type rmw type rmw_atom = A.arch_atom let pp_rmw _ _ = assert false let is_one_instruction _ = assert false let fold_rmw _ r = r let fold_rmw_compat _ r = r let applies_atom_rmw _ _ _ = assert false let show_rmw_reg _ = assert false let compute_rmw _ _ _ = assert false end herd-herdtools7-1ca343e/gen/noRmw.mli000066400000000000000000000024571475314470400175300ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2021-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** No rmw instruction *) module Make : functor(A:sig type arch_atom end) -> sig include Rmw.S with type rmw_atom = A.arch_atom end herd-herdtools7-1ca343e/gen/noSIMD.ml000066400000000000000000000024441475314470400173420ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2021-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) type atom = unit let nregs () = 0 let pp () = "" let initial _ = [||] let step () _ _ = [||] let read () _ = [] let reduce _ = 0 herd-herdtools7-1ca343e/gen/noSIMD.mli000066400000000000000000000022641475314470400175130ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2021-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) include Atom.SIMD herd-herdtools7-1ca343e/gen/noSpecial.ml000066400000000000000000000024331475314470400201640ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2020-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Nothing special *) type special type special2 type special3 let specials = [] let specials2 = [] let specials3 = [] herd-herdtools7-1ca343e/gen/noSpecial.mli000066400000000000000000000024731475314470400203410ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2020-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Nothing special *) type special type special2 type special3 val specials : special list val specials2 : special2 list val specials3 : special3 list herd-herdtools7-1ca343e/gen/noWide.ml000066400000000000000000000023211475314470400174700ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2021-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) let as_integers _ = None let is_pair _ = false herd-herdtools7-1ca343e/gen/norm.ml000066400000000000000000000101661475314470400172240ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2018-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Normalise cycles and name them *) open Printf let arch = ref `PPC let lowercase = ref false let bell = ref None let variant = ref (fun (_:Variant_gen.t) -> false) let typ = ref TypBase.default let args = ref [] let opts = ("-lowercase", Arg.Bool (fun b -> lowercase := b), sprintf " use lowercase familly names, default %b" !lowercase):: ("-bell",Arg.String (fun f -> bell := Some f; arch := `LISA), " read bell file "):: Util.parse_tag "-arch" (fun tag -> match Archs.parse tag with | None -> false | Some a -> arch := a ; true) Archs.tags "specify architecture":: Util.parse_tag "-variant" (fun tag -> match Variant_gen.parse tag with | None -> false | Some v0 -> let ov = !variant in variant := (fun v -> v = v0 || ov v) ; true) Variant_gen.tags (sprintf "specify variant"):: Util.parse_tag "-type" (fun tag -> match TypBase.parse tag with | None -> false | Some a -> typ := a ; true) TypBase.tags (sprintf "specify base type, default %s" (TypBase.pp !typ)):: [] module type Config = sig val lowercase : bool val sufname : string option val variant : Variant_gen.t -> bool val naturalsize : MachSize.sz end module Make(Co:Config) (A:Fence.S) = struct module E = Edge.Make(Co)(A) module N = Namer.Make(A)(E) module Norm = Normaliser.Make(Co)(E) let zyva es = try let es = List.map E.parse_edge es in let base,es,_ = Norm.normalise_family (E.resolve_edges es) in let name = N.mk_name base ?scope:None es in Printf.printf "%s: %s\n" name (E.pp_edges es) with Misc.Fatal msg -> eprintf "Fatal error: %s\n" msg ; exit 2 end let () = Util.parse_cmdline opts (fun a -> args := a :: !args) let () = let args = List.rev !args in let module Co = struct let lowercase = !lowercase let sufname = None let variant = !variant let naturalsize = TypBase.get_size !typ end in let module Build = Make(Co) in (match !arch with | `X86 -> let module M = Build(X86Arch_gen) in M.zyva | `X86_64 -> assert false | `PPC -> let module M = Build(PPCArch_gen.Make(PPCArch_gen.Config)) in M.zyva | `ARM -> let module M = Build(ARMArch_gen.Make(ARMArch_gen.Config)) in M.zyva | `AArch64 -> let module A = AArch64Arch_gen.Make (struct include AArch64Arch_gen.Config let moreedges = !Config.moreedges end) in let module M = Build(A) in M.zyva | `MIPS -> let module M = Build(MIPSArch_gen.Make(MIPSArch_gen.Config)) in M.zyva | `RISCV -> let module M = Build(RISCVArch_gen.Make(RISCVArch_gen.Config)) in M.zyva | `LISA -> let module BellConfig = Config.ToLisa(Config) in let module M = Build(BellArch_gen.Make(BellConfig)) in M.zyva | `C | `CPP -> let module M = Build(CArch_gen) in M.zyva | `JAVA | `ASL | `BPF -> assert false) args herd-herdtools7-1ca343e/gen/normaliser.ml000066400000000000000000000405751475314470400204330ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2011-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Code open Printf exception CannotNormalise of string module type Config = sig val lowercase : bool end module Make : functor (C:Config) -> functor (E:Edge.S) -> sig (* Normalise, return normalised cycle *) val normalise : E.edge list -> E.edge list (* Return family name, without normalising *) val family : E.edge list -> string (* Return number of procs in test *) val get_nprocs : E.edge list -> int (* All at once *) val normalise_family : E.edge list -> string * E.edge list * int end = functor (C:Config) -> functor (E : Edge.S) -> struct let debug = false (* Cycles of edges *) module CE = struct type t = { edge : E.edge ; dir : dir option ; mutable next : t ; mutable prev : t; mutable matches : t ; } exception NotFound let find_node p n = let rec do_rec m = if p m then m else let m = m.next in if m == n then raise NotFound else do_rec m in do_rec n let find_node_rev p n = let rec do_rec m = if p m then m else let m = m.prev in if m == n then raise NotFound else do_rec m in do_rec n let e0 = E.parse_edge "Rfi" let rec nil = { edge = e0; dir=None ; next = nil ; prev = nil ; matches = nil ; } let map f n = let rec do_rec m = let y = f m in let m = m.next in if m == n then [y] else y::do_rec m in do_rec n let _edges n = map (fun n -> n.edge) n let _pp n = let xs = map (fun n -> E.pp_edge n.edge) n in String.concat " " xs let proc_list (e,o) = let rec do_rec m = if m == o then [o] else m::do_rec m.next in do_rec e let _pp_proc c = let ns = proc_list c in let xs = List.map (fun n -> E.pp_edge n.edge) ns in String.concat " " xs let dir_src e = match E.dir_src e with | Dir d -> Some d | NoDir -> None | Irr -> Warn.fatal "Unresolved direction" let find_back n = let rec find_rec k m = match m.edge.E.edge with | E.Back _ -> if k = 0 then m else find_next (k-1) m | E.Leave _ -> find_next (k+1) m | _ -> find_next k m and find_next k m = (* Cycle is not well formed anyway *) if m.next == n then raise (CannotNormalise "find_back") else find_rec k m.next in find_rec 0 n let set_matches n = let rec do_rec m = match m.edge.E.edge with | E.Leave _ -> (* eprintf "LEAVE [%s]\n" (_pp m); *) let matches = find_back m.next in (* eprintf "BACK [%s]\n" (_pp matches); *) m.matches <- matches ; matches.matches <- m ; do_next m | _ -> do_next m and do_next m = if m.next != n then do_rec m.next in do_rec n let mk_cycle es = let ms = List.map (fun e -> { edge=e; dir=dir_src e; next=nil; prev=nil; matches=nil; }) es in let patch = function | [] -> assert false | x::xs -> let rec do_rec prev = function | [] -> prev.next <- x ; x.prev <- prev | y::ys -> prev.next <- y ; y.prev <- prev ; do_rec y ys in do_rec x xs ; x in let r = patch ms in set_matches r ; if debug then eprintf "CE.cycle returned [%s]\n%!" (_pp r) ; r (* Notice, do not halt on stores... *) let ext_com e = match e.E.edge with | E.Rf Ext|E.Fr Ext|E.Ws Ext|E.Hat -> true | _ -> false (* Find skipping Leave/Back *) let find_node_out p n = let rec do_rec m = if debug then eprintf "FIND NODE OUT [%s]\n" (_pp m) ; if p m then m else do_next m and do_next m = let m = match m.edge.E.edge with | E.Leave _ -> m.matches.next | _ -> m.next in if m == n then raise NotFound else do_rec m in do_rec n let _find_edge p = find_node (fun n -> p n.edge) let find_edge_out p = find_node_out (fun n -> p n.edge) (* EXP *) (* let find_back = find_edge (fun e -> match e.E.edge with E.Back _ -> true | _ -> false) let find_leave = find_edge (fun e -> match e.E.edge with E.Leave _ -> true | _ -> false) *) (* Find node at outermost level *) let find_out n = let rec do_rec (n0,_ as c0) d m = if debug then eprintf "OUTER %i [%s]\n%!" n0 (_pp m) ; match m.edge.E.edge with | E.Leave _ -> do_next c0 (d+1) m | E.Back _ -> let c0 = let d = d-1 in let d0,n0 = c0 in if d < d0 then begin if debug then eprintf "CHANGE: %s -> %s\n%!" (E.pp_edge n0.edge) (E.pp_edge m.next.edge) ; (d,m.next) end else c0 in do_next c0 (d-1) m | _ -> do_next c0 d m and do_next c d m = if m.next == n then snd c else do_rec c d m.next in do_rec (0,n) 0 n (* * Warning: * split_proc below has to be the same as in cycle.ml * for diy to name tests properly when no familly is given. *) let find_non_pseudo_prev n = find_node_rev (fun n -> E.is_non_pseudo n.edge.E.edge) n let find_start_proc n = if debug then eprintf "Start proc [%s]\n%!" (_pp n) ; let n = find_out n in if debug then eprintf "Found out [%s]\n%!" (_pp n) ; let p = find_non_pseudo_prev n.prev in if ext_com p.edge then p.next else try let n = find_edge_out ext_com n in n.next with NotFound -> (* "No external communication in cycle" *) raise (CannotNormalise "find_start") let split_procs n = try let n = find_start_proc n in (* n is the entry of a proc *) assert (ext_com n.prev.edge) ; let rec do_rec m = if debug then eprintf "REC: '%s'\n" (_pp m) ; let e = m in let o = find_edge_out ext_com m in if o.next == n then [(e,o)] else (e,o)::do_rec o.next in let ns = do_rec n in if debug then begin if debug then eprintf "Split -> %!" ; eprintf "[%i]\n" (List.length ns) ; List.iter (fun n -> eprintf " %s\n" (_pp_proc n)) ns end ; ns with e -> if debug then eprintf "Exc in split_procs: '%s'\n" (Printexc.to_string e) ; raise e let compare_edges e1 e2 = let open E in match e1.edge,e2.edge with | (Po _|Rf _),(Fenced _|Dp _) | Dp _,Fenced _ -> 1 | (Fenced _|Dp _),(Po _|Rf _) | Fenced _,Dp _ -> -1 | _,_ -> Misc.polymorphic_compare e1 e2 let ninternals n = let rec do_rec r m = match E.get_ie m.edge with | Ext -> r | Int -> if m.next == n then r else do_rec (r+1) m.next in do_rec 0 n let compare_edges_cycle n1 n2 = let rec do_rec m1 m2 = match compare_edges m1.edge m2.edge with | 0 -> let m1 = m1.next and m2 = m2.next in if m1 == n1 && m2 == n2 then 0 else begin assert (m1 != n1 && m2 != n2) ; do_rec m1 m2 end | r -> r in let i1 = ninternals n1 and i2 = ninternals n2 in match compare i1 i2 with | 0 -> do_rec n1 n2 | r -> r end (* In/Out *) module Dir = struct type t = R | W | F | J let pp = function | R -> "R" | W -> "W" | F -> "F" | J -> "J" let tr e = let d = Misc.as_some e.CE.dir in let r = match d with | Code.W -> W | Code.R -> R | Code.J -> J in if debug then eprintf "%s[%s] -> %s\n" (E.pp_edge e.CE.edge) (Code.pp_dir d) (pp r) ; r end type points = One of Dir.t | Two of Dir.t * Dir.t let order = let open Dir in [| One W; Two (W,W); Two (R,R); Two (R,F); Two (F,R); Two (F,F); Two (R,W); Two (F,W); Two (W,R); Two (W,F); One R; One F; |] let pp_points = function | One d -> Dir.pp d | Two (d1,d2) -> Dir.pp d1 ^ Dir.pp d2 let t_id = Hashtbl.create 17 let () = Array.iteri (fun k p -> Hashtbl.add t_id p k) order let id p = try Hashtbl.find t_id p with Not_found -> assert false let compare_points p1 p2 = let i1 = id p1 and i2 = id p2 in Misc.int_compare i1 i2 module CP = struct type t = { points : points ; cycle : CE.t ; mutable next : t ; } let rec nil = { points = One Dir.R; cycle = CE.nil; next = nil; } let has_dir e = match e.CE.dir with | Some _ -> true | None -> false let is_actual_edge e = has_dir e && not (E.is_node e.CE.edge.E.edge) let mk_cycle cy = let es = CE.mk_cycle cy in let eos = CE.split_procs es in let ms = List.map (fun (e,o) -> let e = CE.find_node is_actual_edge e and o = CE.find_node_rev is_actual_edge o in let p = if e == o then One (Dir.tr e) else Two (Dir.tr e,Dir.tr o) in { points=p; cycle=e; next=nil; }) eos in let patch = function | [] -> assert false | x::xs -> let rec do_rec prev = function | [] -> prev.next <- x ; | y::ys -> prev.next <- y ; do_rec y ys in do_rec x xs ; x in patch ms let map f n = let rec do_rec m = let y = f m in let m = m.next in if m == n then [y] else y::do_rec m in do_rec n let compare_points_cycle n1 n2 = let rec do_rec m1 m2 = match compare_points m1.points m2.points with | 0 -> let m1 = m1.next and m2 = m2.next in if m1 == n1 && m2 == n2 then 0 else begin assert (m1 != n1 && m2 != n2) ; do_rec m1 m2 end | r -> r in do_rec n1 n2 let compare n1 n2 = match compare_points_cycle n1 n2 with | 0 -> CE.compare_edges_cycle n1.cycle n2.cycle | r -> r let norm n = let rec do_rec r m = let cmp = compare r m in let r = if cmp < 0 then r else m in let m = m.next in if m == n then r else do_rec r m in do_rec n n.next let pp n = let xs = map (fun n -> pp_points n.points) n in String.concat "+" xs let fold f y0 n = let rec do_rec m y = let y = f m y in let m = m.next in if m == n then y else do_rec m y in do_rec n y0 let size n = fold (fun _ n -> n+1) 0 n end let pp_key allsame key = let pp = match key with | "WW" when allsame -> "CoWW" | "RW" when allsame -> "CoRW1" | "W+RW" when allsame -> "CoRW2" | "W+WR" when allsame -> "CoWR" | "W+RR" when allsame -> "CoRR" | "WR" when allsame -> "CoWR0" | "WW+RR" -> "MP" | "WW+FF" -> "MP.FF" | "WW+RF" -> "MP.RF" | "WW+FR" -> "MP.FR" | "WR+WR" -> "SB" | "WF+WR" -> "SB.FR" | "WR+WF" -> "SB.RF" | "WF+WF" -> "SB.FF" | "WR+WR+WR" -> "3.SB" | "WF+WF+WF" -> "3.SB.FFF" | "WR+WR+WR+WR" -> "4.SB" | "W+RW+RR" -> "WRC" | "W+FW+RR" -> "WRC+F+RR" | "W+FW+FF" -> "WRC+F+FF" | "W+FW+FR" -> "WRC+F+FR" | "W+FW+RF" -> "WRC+F+RF" | "W+RW+FF" -> "WRC+R+FF" | "W+RW+FR" -> "WRC+R+FR" | "W+RW+RF" -> "WRC+R+RF" | "W+RR+WR" -> "RWC" | "W+FF+WF" -> "RWC.FF.F" | "W+RF+WF" -> "RWC.RF.F" | "RW+RW" -> "LB" | "FW+RW" -> "LB.FR" | "RW+FW" -> "LB.RF" | "FW+FW" -> "LB.FF" | "RW+RW+RW" -> "3.LB" | "FW+FW+FW" -> "3.LB.FFF" | "RW+RW+RW+RW" -> "4.LB" | "WW+WR" -> "R" | "W+RW+WR" -> "WRW+WR" | "W+RR+WW" -> "WRR+2W" | "WW+RW" -> "S" | "W+RW+RW" -> "WWC" | "WW+WW" -> "2+2W" | "WW+WW+WW" -> "3.2W" | "WW+WW+WW+WW" -> "4.2W" | "W+RW+WW" -> "WRW+2W" | "WW+RR+WR" -> "W+RWC" | "WW+FF+WF" -> "W+RWC.F.FF" | "WW+RW+RR" -> "ISA2" | "WW+FW+FF" -> "ISA2.F.FF" | "W+RR+W+RR" -> "IRIW" | "W+RR+W+RW"|"W+RW+W+RR" -> "IRRWIW" | "W+RW+W+RW" -> "IRWIW" | "WW+RW+WR" -> "Z6.0" | "WW+WW+RW" -> "Z6.1" | "WW+RW+RW" -> "Z6.2" | "WW+WW+RR" -> "Z6.3" | "WW+WR+WR" -> "Z6.4" | "WW+WW+WR" -> "Z6.5" | "WW+FW" -> "S.F" | "WW+WF" -> "R.F" | "W+RF+WR " -> "RWC.RF.R" | "WW+FW+FR" -> "ISA2.F.FR" | "WW+FW+RF" -> "ISA2.F.RF" | "WW+FW+RR" -> "ISA2.F.RR" | "WW+RW+FF" -> "ISA2.R.FF" | "WW+RW+FR" -> "ISA2.R.FR" | "WW+RW+RF" -> "ISA2.R.RF" | "RW+FW+FW" -> "3.LB.R.F.F" | "RW+RW+FW" -> "3.LB.R.R.F" | "WR+WF+WF" -> "3.SB.R.F.F" | "WR+WR+WF" -> "3.SB.R.R.F" | "WW+FW+WF" -> "Z6.0.F.F" | "WW+FW+WR" -> "Z6.0.F.R" | "WW+RW+WF" -> "Z6.0.R.F" | "WW+WW+FW" -> "Z6.1.F" | "WW+FW+FW" -> "Z6.2.F.F" | "WW+FW+RW" -> "Z6.2.F.R" | "WW+RW+FW" -> "Z6.2.R.F" | "WW+WW+FF" -> "Z6.3.FF" | "WW+WW+FR" -> "Z6.3.FR" | "WW+WW+RF" -> "Z6.3.RF" | "WW+WF+WF" -> "Z6.4.F.F" | "WW+WF+WR" -> "Z6.4.F.R" | "WW+WR+WF" -> "Z6.4.R.F" | "WW+WW+WF" -> "Z6.5.F" | "W+RW+FW " -> "WWC.R.F" | "W+RF+WW " -> "WRR+2W.RF" | "WW+FF+WR" -> "W+RWC.FF.R" | "WW+FR+WF" -> "W+RWC.FR.F" | "WW+FR+WR" -> "W+RWC.FR.R" | "WW+RF+WF" -> "W+RWC.RF.F" | "WW+RF+WR" -> "W+RWC.RF.R" | "WW+RR+WF" -> "W+RWC.RR.F" | k -> k in if C.lowercase then Misc.lowercase pp else pp let normalise cy = try let ps = CP.mk_cycle cy in let ps = CP.norm ps in let cy = CE.map (fun e -> e.CE.edge) ps.CP.cycle in cy with CE.NotFound -> raise (CannotNormalise "normalise") let allsame cy = List.for_all (fun e -> match E.loc_sd e with | Same -> true | Diff -> false) cy let family cy = let ps = CP.mk_cycle cy in let key = CP.pp ps in pp_key (allsame cy) key let get_nprocs cy = let ps = CP.mk_cycle cy in CP.size ps let normalise_family cy = try let ps = CP.mk_cycle cy in let ps = CP.norm ps in let key = CP.pp ps in let cy = CE.map (fun e -> e.CE.edge) ps.CP.cycle in pp_key (allsame cy) key,cy,CP.size ps with CE.NotFound -> raise (CannotNormalise "normalise_family") end herd-herdtools7-1ca343e/gen/pteVal_gen.ml000066400000000000000000000030261475314470400203320ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2021-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module type S = sig type pte_atom type t val pp : t -> string val default : string -> t val compare : t -> t -> int val set_pteval : pte_atom -> t -> (unit -> string) -> t end module No(A:sig type arch_atom end) = struct type pte_atom = A.arch_atom type t = string let pp a = a let default s = s let compare _ _ = 0 let set_pteval _ p _ = p end herd-herdtools7-1ca343e/gen/readRelax.ml000066400000000000000000000123551475314470400201620ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Printf let arch = ref (`PPC: Archs.t) let names = ref [] let verbose = ref 0 let opts = ("-v",Arg.Unit (fun () -> incr verbose),"be verbose"):: Util.parse_tag "-arch" (fun tag -> match Archs.parse tag with | None -> false | Some a -> arch := a ; true) Archs.tags "specify architecture"::[] let () = Util.parse_cmdline opts (fun name -> names := name :: !names) module Top = struct (* Simplified relaxation: just strings... *) module R = struct open LexUtil type relax = LexUtil.t let parse r = r let pp_relax = function | One r -> r | Seq rs -> "[" ^ String.concat "," rs ^ "]" let rec lex_str r1 r2 = match r1,r2 with | [],[] -> 0 | _::_,[] -> 1 | [],_::_ -> -1 | r1::rs1,r2::rs2 -> let c = String.compare r1 r2 in match c with | 0 -> lex_str rs1 rs2 | _ -> c let compare r1 r2 = match r1,r2 with | One r1,Seq [r2] | Seq [r1],One r2 | One r1,One r2 | Seq [r1],Seq [r2] -> String.compare r1 r2 | One _,Seq _ -> -1 | Seq _,One _ -> 1 | Seq r1,Seq r2 -> lex_str r1 r2 module Set = MySet.Make (struct type t = relax let compare = compare end) let pp_relax_set chan t = fprintf chan "{" ; Set.pp chan ", " (fun chan r -> fprintf chan "%s" (pp_relax r)) t ; fprintf chan "}" module SetSet = MySet.Make(Set) let pp_relax_set_set chan ts = SetSet.pp chan " " pp_relax_set ts let pp_nr chan ts = SetSet.pp chan "\n" pp_relax_set ts end module M = LogRelax.Make(R) open M let pp_relaxs rs = String.concat " " (List.map R.pp_relax rs) let pp_os chan = List.iter (fun o -> fprintf chan "%s %s With Safe %s\n" o.name (pp_relaxs o.relaxs) (pp_relaxs o.safes)) module RelaxMap = Map.Make (struct type t = R.Set.t let compare = R.Set.compare end) let collect_relax os = List.fold_left (fun k o -> let relax = R.Set.of_list o.relaxs in let old = try RelaxMap.find relax k with Not_found -> R.SetSet.empty in RelaxMap.add relax (R.SetSet.add (R.Set.of_list o.safes) old) k) RelaxMap.empty os let collect_non_relax rmap os = List.fold_left (fun k o -> let relax = R.Set.of_list o.relaxs in try ignore (RelaxMap.find relax rmap) ; k with Not_found -> R.SetSet.add relax k) R.SetSet.empty os let pp_map chan m = RelaxMap.iter (fun k v -> R.pp_relax_set chan k ; output_string chan " With " ; R.pp_relax_set_set chan v ; output_char chan '\n') m let pp_sumary chan os = pp_map chan (collect_relax os) let suggest rmap nrset = let r = RelaxMap.fold (fun rs _ k -> R.Set.union rs k) rmap R.Set.empty and s = R.SetSet.fold (fun rs k -> R.Set.union rs k) nrset R.Set.empty in R.Set.diff s r let zyva names chan = let os = M.add_files names in let yes,no = List.partition (fun t -> t.validates) os in fprintf chan "** Relaxations **\n" ; pp_os chan yes ; fprintf chan "** Non-Relaxations **\n" ; pp_os chan no ; fprintf chan "** Relaxation summary **\n" ; let rmap = collect_relax yes in pp_map chan rmap ; if !verbose > 0 then begin fprintf chan "** Non-Relaxation summary **\n" ; let nrset = collect_non_relax rmap no in R.pp_nr chan nrset ; fprintf chan "\n" ; let sug = suggest rmap nrset in if not (R.Set.is_empty sug) then begin fprintf chan "** Safe suggestion **\n" ; R.pp_relax_set chan sug ; fprintf chan "\n" end end ; () end let read_names = function | [] -> let rec read_rec k = let o = try Some (read_line ()) with End_of_file -> None in match o with | Some x -> read_rec (x::k) | None -> k in read_rec [] | xs -> xs let names = read_names !names let () = Top.zyva names stdout herd-herdtools7-1ca343e/gen/relax.ml000066400000000000000000000410241475314470400173610ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Printf open Code module type S = sig type fence type dp type edge type relax = (* Sequence of edges (eg Cumulativity) *) | ERS of edge list | PPO val ac_fence : fence -> sd -> extr -> extr -> relax val bc_fence : fence -> sd -> extr -> extr -> relax val bc_dp : dp -> sd -> extr -> relax (* Call function over all reckognized relaxations *) val fold_relax : (relax -> 'a -> 'a) -> 'a -> 'a val compare : relax -> relax -> int val pp_relax : relax -> string val pp_relax_list : relax list -> string val edges_of : relax -> edge list (* Replace Irr directions in par expansion to W and R *) val expand_relaxs : ((relax -> relax list -> relax list) -> relax list -> relax list) -> relax list -> relax list val expand_relax_seq : relax list -> relax list list val com : relax list val po : relax list (* parsing *) val parse_relax : LexUtil.t -> relax val parse_relaxs : LexUtil.t list -> relax list (* parsing, with macro expansion *) val expand_relax_macro : LexUtil.t -> relax list (* NB use for set of relaxations only *) val expand_relax_macros : LexUtil.t list -> relax list (* Sets *) module Set : MySet.S with type elt = relax val pp_set : out_channel -> Set.t -> unit (* All fences present *) val all_fences : Set.t -> fence list (* All cumulative fences present *) val all_cumul_fences : Set.t -> fence list (* Presence of cumulativity relaxations in a set *) val cumul_in : Set.t -> bool (* Remove cumulativity relaxations from set *) val remove_cumul : Set.t -> Set.t (* Expand cumulativity relaxations in set *) val expand_cumul : Set.t -> Set.t module SetSet : MySet.S with type elt = Set.t val pp_set_set : out_channel -> SetSet.t -> unit (* Apply expand cumul to all sets in a set of sets *) val expand_cumuls : SetSet.t -> SetSet.t (* Map *) module Map : Map.S with type key = relax (* From edge cycle to relax cycle *) val relaxs_of : Set.t -> edge list -> SetSet.t (* Sequence (po) relaxations *) val compact_sequence : relax -> relax -> Set.t end module Make (F:Fence.S) (E:Edge.S with type fence = F.fence and type dp = F.dp) : S with type fence = E.fence and type dp = E.dp and type edge = E.edge = struct type fence = E.fence type dp = E.dp type edge = E.edge type relax = | ERS of edge list | PPO let edges_of r = match r with | ERS es -> es | PPO -> assert false let rec compare_edges es1 es2 = match es1,es2 with | [],[] -> 0 | [],_::_ -> -1 | _::_,[] -> 1 | e1::es1,e2::es2 -> begin match E.compare e1 e2 with | 0 -> compare_edges es1 es2 | r -> r end let compare r1 r2 = match r1,r2 with | PPO,PPO -> 0 | PPO,ERS _ -> -1 | ERS _,PPO -> 1 | ERS l1,ERS l2 -> compare_edges l1 l2 (* Cumulativity macros *) let rf = E.plain_edge (E.Rf Ext) and fenced f sl d1 d2 = E.plain_edge (E.Fenced (f,sl,d1,d2)) let ac_fence f sl d1 d2 = ERS [rf; fenced f sl d1 d2] let bc_fence f sl d1 d2 = ERS [fenced f sl d1 d2; rf] let abc_fence f sl d1 d2 = ERS [rf; fenced f sl d1 d2; rf] let bc_dp dp sl d = ERS [E.plain_edge (E.Dp (dp,sl,d)); rf] (* Pretty print, macros are filtered and printed specially *) let pp_relax r = let open E in match r with | ERS [e] -> E.pp_edge e | ERS [{edge=Rf Ext; a1=None;a2=None;}; {edge=Fenced _;a1=None; a2=None;} as e] -> sprintf "AC%s" (pp_edge e) | ERS [{edge=Fenced _; a1=None;a2=None;} as e; {edge=Rf Ext; a1=None; a2=None;}] -> sprintf "BC%s" (pp_edge e) | ERS [{edge=Rf Ext; a1=None; a2=None;}; {edge=Fenced _; a1=None; a2=None;} as e; {edge=Rf Ext; a1=None; a2=None;}] -> sprintf "ABC%s" (pp_edge e) | ERS [{edge=Dp _; a1=None; a2=None;} as e; {edge=Rf Ext; a1=None; a2=None;}] -> sprintf "BC%s" (pp_edge e) | ERS es -> sprintf "[%s]" (String.concat "," (List.map pp_edge es)) | PPO -> "PPO" let pp_relax_list lr = String.concat " " (List.map pp_relax lr) (* Fold over all relaxations *) let fold_relax f k = let k = E.fold_edges (fun e -> f (ERS [e])) k in let k = F.fold_cumul_fences (fun fe k -> let k = Code.fold_sd (fun sd k -> let k = f (abc_fence fe sd Irr Irr) k in f (abc_fence fe sd (Dir R) (Dir W)) k) k in Code.fold_sd_extr (fun sd e k -> let k = f (ac_fence fe sd Irr e) k in let k = f (ac_fence fe sd (Dir R) e) k in let k = f (bc_fence fe sd e Irr) k in f (bc_fence fe sd e (Dir W)) k) k) k in let k = F.fold_dpw (fun dpw k -> Code.fold_sd (fun sd k -> f (bc_dp dpw sd (Dir W)) k) k) k in let k = f PPO k in k let iter_relax = Misc.fold_to_iter fold_relax (***********) (* Parsing *) (***********) (* Same idea as for edges: pretty print all relaxations so as to build a table of recognized relaxations. *) (* Lexeme table *) let t = Hashtbl.create 101 (* Fill up lexeme table *) let () = iter_relax (fun e -> let pp = pp_relax e in Hashtbl.add t pp e); () let do_parse_relax s = try ERS [E.parse_edge s] (* Because some edges have special parsing *) with _ -> try Hashtbl.find t s with Not_found -> Warn.fatal "Bad relax: %s" s (*************************************************************) (* Expansion of irrelevant direction specifications in edges *) (*************************************************************) let rec do_expand_relax ppo r f = match r with | ERS es -> E.expand_edges es (fun es -> f (ERS es)) | PPO -> ppo (fun r -> do_expand_relax ppo r f) let expand_relaxs ppo rs = let expand_relax r = do_expand_relax ppo r Misc.cons in List.fold_right expand_relax rs [] let rec cross_cons rs rss = match rs with | [] -> [] | r::rs -> List.fold_right (fun rs k -> (r::rs)::k) rss (cross_cons rs rss) let expand_relax_seq rs = let rec expn rs = match rs with | [] -> [[]] | PPO ::_-> Warn.fatal "PPO in expand_relax_seq" | ERS es::rem -> let rs = E.expand_edges es (fun es k -> ERS es::k) [] in let rss = expn rem in cross_cons rs rss in expn rs let er e = ERS [E.plain_edge e] let ers es = ERS (List.map E.plain_edge es) let com = let open E in [ er (Rf Ext); er (Fr Ext); er (Ws Ext); ers [Fr Ext ; Rf Ext;]; ers [Ws Ext; Rf Ext;]; ] let po = let open E in er (Po (Diff,Irr,Irr)):: F.fold_all_fences (fun f k -> er (Fenced (f,Diff,Irr,Irr)):: (if F.orders f R R && not (F.orders f W R) then [ers [Rf Int; Fenced (f,Diff,Dir R,Dir R)]] else [])@ (if F.orders f R W && not (F.orders f W W) then [ers [Rf Int; Fenced (f,Diff,Dir R,Dir W)]] else [])@k) [] open LexUtil let parse_relax = function | One r -> do_parse_relax r | Seq [] -> Warn.fatal "Empty relaxation" | Seq es -> ERS (List.map E.parse_edge es) let parse_relaxs = List.map parse_relax (* Expand relax macros *) let er e = ERS [E.plain_edge e] let all_fences sd d1 d2 = F.fold_all_fences (fun f k -> er (E.Fenced (f,sd,Dir d1,Dir d2))::k) let some_fences sd d1 d2 = F.fold_some_fences (fun f k -> er (E.Fenced (f,sd,Dir d1,Dir d2))::k) (* Limited variations *) let app_def_dp o f r = match o with | None -> r | Some dp -> f dp r let someR sd d = er (E.Po (sd,Dir R,Dir d)):: app_def_dp (match d with R | J -> F.ddr_default | W -> F.ddw_default) (fun dp k -> er (E.Dp (dp,sd,Dir d))::k) (some_fences sd R d []) let someW sd d = er (E.Po (sd,Dir W,Dir d)):: (some_fences sd W d []) (* ALL *) let allR sd d = er (E.Po (sd,Dir R,Dir d)):: (match d with R | J -> F.fold_dpr | W -> F.fold_dpw) (fun dp k -> er (E.Dp (dp,sd,Dir d))::k) (all_fences sd R d []) let allW sd d = er (E.Po (sd,Dir W,Dir d)):: (all_fences sd W d []) let atoms_key = "atoms" let atoms_length = String.length atoms_key let _esparse_atoms s = if String.length s >= atoms_length && String.sub s 0 atoms_length = atoms_key then let suf = String.sub s atoms_length (String.length s - atoms_length) in try Some (E.parse_edge suf) with _ -> None else None let expand_relax_macro = function | One s -> begin match s with | "allRR" -> allR Diff R | "allRW" -> allR Diff W | "allWR" -> allW Diff R | "allWW" -> allW Diff W | "someRR" -> someR Diff R | "someRW" -> someR Diff W | "someWR" -> someW Diff R | "someWW" -> someW Diff W | _ -> [do_parse_relax s] end | Seq [] -> Warn.fatal "Empty relaxation" | Seq es -> [ERS (List.map E.parse_edge es)] let expand_relax_macros lus = let rs = List.map expand_relax_macro lus in let rs = List.flatten rs in rs (********) (* Sets *) (********) module Set = MySet.Make (struct type t = relax let compare = compare end) let pp_set chan t = fprintf chan "{" ; Set.pp chan ", " (fun chan r -> fprintf chan "%s" (pp_relax r)) t ; fprintf chan "}" let is_cumul r = let open E in match r with | ERS [{edge=Rf Code.Ext; a1=None; a2=None;}; {edge=Fenced _; a1=None; a2=None;}] | ERS [{edge=Fenced _; a1=None; a2=None;}; {edge=Rf Code.Ext; a1=None; a2=None;};] | ERS [{edge=Rf Code.Ext; a1=None; a2=None;}; {edge=Fenced _; a1=None; a2=None;}; {edge=Rf Code.Ext; a1=None; a2=None;};] -> true | _ -> false module FenceSet = MySet.Make (struct type t = F.fence let compare = F.compare_fence end) let add_fence r k = let open E in match r with | ERS [{edge=Fenced (f,_,_,_); _}] | ERS [{edge=Rf Code.Ext; _};{edge=Fenced (f,_,_,_);_}] | ERS [{edge=Fenced (f,_,_,_); _}; {edge=Rf Code.Ext; _};] | ERS [{edge=Rf Code.Ext; _}; {edge=Fenced (f,_,_,_); _}; {edge=Rf Code.Ext; _};] -> FenceSet.add f k | _ -> k let all_fences rs = let fs = Set.fold add_fence rs FenceSet.empty in FenceSet.elements fs module RSet = Set let add_cumul_fence r k = let open E in match r with | ERS [{edge=Rf Code.Ext; _};{edge=Fenced (f,_,_,_); _}] | ERS [{edge=Fenced (f,_,_,_); _}; {edge=Rf Code.Ext; _};] | ERS [{edge=Rf Code.Ext; _}; {edge=Fenced (f,_,_,_); _}; {edge=Rf Code.Ext; _};] -> FenceSet.add f k | _ -> k let all_cumul_fences rs = let fs = Set.fold add_cumul_fence rs FenceSet.empty in FenceSet.elements fs let cumul_in rs = Set.exists is_cumul rs let remove_cumul rs = Set.filter (fun r -> not (is_cumul r)) rs let expand_cumul rs = let er e = ERS [e] in let xs = Set.fold (fun r k -> let open E in match r with | ERS ([{edge=Rf Ext; _}; {edge=Fenced _; _};] as rs) | ERS ([{edge=Fenced _; _}; {edge=Rf Ext; _};] as rs) | ERS ([{edge=Rf Ext; _}; {edge=Fenced _; _}; {edge=Rf Ext; _};] as rs) -> RSet.of_list (List.map er rs)::k | _ -> RSet.singleton r::k) rs [] in RSet.unions xs module SetSet = MySet.Make(Set) let pp_set_set chan ts = SetSet.pp chan " " pp_set ts let expand_cumuls rss = let xs = SetSet.fold (fun rs k -> expand_cumul rs::k) rss [] in SetSet.of_list xs (*********) module Map = Map.Make (struct type t = relax let compare = compare end) (***************************************) (* From edge cycle back to relaxations *) (***************************************) let shift = function | [] -> assert false | x::xs -> xs @ [x] let rec match_edges ps es = match ps,es with | [],_ -> Some ([],es) | _::_,[] -> None | p::ps,e::es -> if p=e then match match_edges ps es with | Some (h,rem) -> Some (e::h,rem) | None -> None else None let rec match_head rs es = Set.fold (fun r k -> let ps = edges_of r in match match_edges ps es with | None -> k | Some (h,rem) -> List.fold_left (fun k rs -> (ERS h::rs)::k) k (matches rs rem)) rs [] and matches rs es = match es with | [] -> [[]] | _ -> match_head rs es let match_set rss = SetSet.of_list (List.map Set.of_list rss) let relaxs_of rs es = let rec do_rec k es = if k <= 0 then [] else match_set (matches rs es)::do_rec (k-1) (shift es) in SetSet.unions (do_rec (List.length es) es) let compact_sequence r1 r2 = match r1,r2 with | ERS es1,ERS es2 -> let e1 = Misc.last es1 and e2 = List.hd es2 in begin match E.get_ie e1, E.get_ie e2 with | Int,Int when E.can_precede e1 e2 -> let ess = E.compact_sequence es1 es2 e1 e2 in let rs = List.map (fun es -> ERS es) ess in Set.of_list rs | _,_ -> Set.empty end | _,_ -> assert false end herd-herdtools7-1ca343e/gen/rmw.mli000066400000000000000000000032461475314470400172300ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2021-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Signature of Rmw helper modules *) module type S = sig type rmw type rmw_atom val pp_rmw : bool (* backward compatibility *) -> rmw -> string val is_one_instruction : rmw -> bool val fold_rmw : (rmw -> 'a -> 'a) -> 'a -> 'a (* Second round of fold, for rmw with back compatible name *) val fold_rmw_compat : (rmw -> 'a -> 'a) -> 'a -> 'a val applies_atom_rmw : rmw -> rmw_atom option -> rmw_atom option -> bool val show_rmw_reg : rmw -> bool val compute_rmw : rmw -> int -> int -> int end herd-herdtools7-1ca343e/gen/run_gen.ml000066400000000000000000000232021475314470400177010ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2012-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Basic model run (uniproc only) *) open Printf module type Config = sig val verbose : int end module Make (O:Config) (C:ArchRun.S) : sig val run : C.C.event list list -> C.A.location C.C.EventMap.t -> (C.A.location * Code.v) list list val dump_cond : (C.A.location * Code.v) list list -> string end = struct module A = C.A module C = C.C module Rel = InnerRel.Make(C.OrderedEvent) module ESet = MySet.Make(C.OrderedEvent) (* Minimal event structure *) let order_to_rel = let rec do_rec k = function | []|[_] -> k | x::xs -> let k = List.fold_left (fun k y -> (x,y)::k) k xs in do_rec k xs in fun es -> Rel.of_list (do_rec [] es) let make_pox evts = let rec do_one k = function | [] -> k | e::es -> let k = List.fold_left (fun k f -> if Code.loc_eq e.C.loc f.C.loc then (e,f)::k else k) k es in do_one k es in let xs = List.fold_left do_one [] evts in Rel.of_list xs module Locs = Code.LocSet let make_evts ess = let es = List.map ESet.of_list ess in let es = ESet.unions es in (* Beurk alloc well behaved evt identifiers *) let idx = (ESet.max_elt es).C.idx+1 in let locs = ESet.fold (fun e -> Locs.add e.C.loc) es Locs.empty in let wsi,_ = Locs.fold (fun x (wsi,idx) -> C.make_wsi idx x::wsi,idx+1) locs ([],idx) in ESet.of_list wsi,es type str = { evts : ESet.t ; wsi : ESet.t ; pox : Rel.t ; } let make_str evts = let wsi,evts = make_evts evts and pox = make_pox evts in { pox; evts=ESet.union evts wsi; wsi; } (* Communication edges *) module LocMap = Code.LocMap module State = MyMap.Make (struct type t = A.location let compare = A.location_compare end) module StateSet = MySet.Make (struct type t = Code.v State.t let compare = State.compare Misc.int_compare end) let by_loc pred evts = ESet.fold (fun e m -> if pred e then let loc = e.C.loc in let old = LocMap.safe_find ESet.empty loc m in LocMap.add loc (ESet.add e old) m else m) evts LocMap.empty let get_possible m = LocMap.fold (fun _ es k -> let rs,ws = ESet.partition (fun e -> e.C.dir = Some Code.R) es in let rs = ESet.elements rs and ws = ESet.elements ws in List.fold_left (fun k r -> (r,ws)::k) k rs) m [] let gen_rfm kont str = let rs,ws = List.split (get_possible (by_loc (fun _ -> true) str.evts)) in Misc.fold_cross ws (fun ws k -> let rfm = List.fold_right2 C.EventMap.add rs ws C.EventMap.empty in kont str rfm k) let process_rfm kont str rfm = let rf = C.EventMap.fold (fun r w rf -> (w,r)::rf) rfm [] in let rf = Rel.of_list rf in let ws_by_loc = by_loc (fun e -> match e.C.dir with | Some Code.W -> true | None|Some Code.R|Some Code.J -> false) str.evts in let wsi_by_loc = ESet.fold (fun w k -> LocMap.add w.C.loc w k) str.wsi LocMap.empty in let orders = LocMap.fold (fun loc ws k -> let wi = try LocMap.find loc wsi_by_loc with Not_found -> assert false in let vb_loc = ESet.fold (fun w k -> if C.OrderedEvent.compare wi w = 0 then k else (wi,w)::k) ws [] in let orders_loc = Rel.all_topos (O.verbose > 1) ws (Rel.of_list vb_loc) in orders_loc::k) ws_by_loc [] in Misc.fold_cross_gen (fun x xs -> x::xs) [] orders (kont str rfm rf) let make_com rfm co = let co = Rel.unions (List.map order_to_rel co) in let co_map = Rel.fold (fun (w1,w2) k -> let old = C.EventMap.safe_find ESet.empty w1 k in C.EventMap.add w1 (ESet.add w2 old) k) co C.EventMap.empty in let rf = C.EventMap.fold (fun r w k -> (w,r)::k) rfm [] in let rf = Rel.of_list rf in let fr = C.EventMap.fold (fun r w0 -> let ws = C.EventMap.safe_find ESet.empty w0 co_map in ESet.fold (fun w k -> (r,w)::k) ws) rfm [] in let fr = Rel.of_list fr in Rel.unions [rf;co;fr] let process_co kont str rfm _rf co k = let com = make_com rfm co in let seq = Rel.union com str.pox in if Rel.is_acyclic seq then kont rfm co k else k let kont m rfm co k = let fs = List.fold_left (fun fs ws -> match ws with | []|[_] -> fs | _ -> let w = Misc.last ws in State.add (A.of_loc w.C.loc) w.C.v fs) State.empty co in let fs = C.EventMap.fold (fun r reg fs -> try let w = C.EventMap.find r rfm in (* Can fail because some registers steems from atomic writes... *) let v = w.C.v in State.add reg v fs with Not_found -> fs) m fs in (* pp_state stderr fs ; eprintf "\n" ; *) StateSet.add fs k let run evts m = let str = make_str evts in let kont = kont m in let process_co = process_co kont in let process_rfm = process_rfm process_co in let sts = gen_rfm process_rfm str StateSet.empty in (* eprintf "Candidates: %i\n" (StateSet.cardinal sts) ; *) List.map State.bindings (StateSet.elements sts) (* Dump condition *) type cond = | Atom of A.location * Code.v | Or of cond list | And of cond list module OV = struct type t = Code.v let compare = Misc.int_compare end module VSet = MySet.Make(OV) module VMap = Map.Make(OV) let best_col m = let mt = Misc.transpose m in let cs = List.map (fun col -> let vs = List.map (fun (_,v) -> v) col in VSet.cardinal (VSet.of_list vs)) mt in let rec best_rec k (kb,b as p) = function | [] -> kb | c::cs -> if c < b then best_rec (k+1) (k,c) cs else best_rec (k+1) p cs in best_rec 0 (-1,max_int) cs let swap_list = let rec swap_list k prev xs = match xs with | [] -> assert false | x::xs -> if k <= 0 then x::List.rev_append prev xs else swap_list (k-1) (x::prev) xs in fun k xs -> swap_list k [] xs let swap_col k m = let mt = Misc.transpose m in let mt = swap_list k mt in Misc.transpose mt let extract_column xss = match xss with | []|[]::_ -> assert false | ((loc0,_)::_)::_ -> loc0, List.map (fun row -> match row with | (loc,v)::ps -> assert (A.location_compare loc0 loc = 0) ; v,ps | [] -> assert false) xss let group_rows ps = List.fold_left (fun m (v,ps) -> let pss = try VMap.find v m with Not_found -> [] in VMap.add v (ps::pss) m) VMap.empty ps let rec compile_cond m = let k = best_col m in let loc,ps = extract_column (swap_col k m) in let m = group_rows ps in match ps with | [] -> assert false | (_,[])::_ -> Or (VMap.fold (fun v _ k -> Atom (loc,v)::k) m []) | _ -> Or (VMap.fold (fun v m k -> And [Atom (loc,v);compile_cond m]::k) m []) let cond_of_finals fs = compile_cond fs let rec do_dumps op fs = match fs with | [] -> assert false | [f] -> do_dump f | _ -> let pp = String.concat op (List.map do_dump fs) in sprintf "(%s)" pp and do_dump = function | Or [] -> "false" | And [] -> "true" | Or fs -> do_dumps " \\/ " fs | And fs -> do_dumps " /\\ " fs | Atom (loc,v) -> sprintf "%s=%i" (A.pp_location loc) v let dump_cond fs = do_dump (cond_of_finals fs) end herd-herdtools7-1ca343e/gen/scope.ml000066400000000000000000000044641475314470400173660ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Scope tags *) type t = | No | Default | One of BellInfo.scopes | Gen of (string * int * int) list | All let tags = ["none";"default";"all";"(::)+"] let parse_gen tag = let i = String.index_from tag 0 ':' in let j = String.index_from tag (i+1) ':' in let sc = String.sub tag 0 i in let min = int_of_string (String.sub tag (i+1) (j-i-1)) in let max = int_of_string (String.sub tag (j+1) (String.length tag-(j+1))) in sc,min,max let some_colon s = try ignore (String.index s ':') ; true with Not_found -> false let parse tag = match tag with | "none"|"no" -> Some No | "default"|"def" -> Some Default | "all" -> Some All | _ -> if some_colon tag then begin try let tags = LexSplit.strings tag in let t = Gen (List.map (fun tag -> parse_gen tag) tags) in Some t with _ -> None end else let module Lexer = ScopeLexer.Make(LexUtils.Default) in let lexbuf = Lexing.from_string tag in let st = GenParserUtils.call_parser "_none_" lexbuf Lexer.token ScopeParser.main in Some (One st) herd-herdtools7-1ca343e/gen/scope.mli000066400000000000000000000025211475314470400175270ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Scope tags *) type t = | No | Default | One of BellInfo.scopes | Gen of (string * int * int) list | All val tags : string list val parse : string -> t option herd-herdtools7-1ca343e/gen/scopeGen.ml000066400000000000000000000106321475314470400200120ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module type Config = sig val debug : bool val info : BellModel.info end module type S = sig val default : int -> BellInfo.scopes val gen : (string * int * int) list -> int -> (BellInfo.scopes -> 'a -> 'a) -> 'a -> 'a val all : int -> (BellInfo.scopes -> 'a -> 'a) -> 'a -> 'a end module Make(O:Config) : S = struct open BellInfo let bad_order () = Warn.fatal "unsuitable or no order in bell file" let default n = try let o = BellModel.get_order BellName.scopes O.info in let tops = StringRel.leaves o in let top = StringSet.choose tops in Tree (top,Misc.interval 0 n,[]) with | Not_found -> bad_order () (***********************) (* Partition generator *) (***********************) let add_elt y yss k res = let rec add_rec prev yss res = match yss with | [] -> res | ys::yss -> let res = k (prev ((y::ys)::yss)) res in add_rec (fun yss -> prev (ys::yss)) yss res in add_rec (fun yss -> yss) yss res let part minsz maxsize xs k res = let rec do_rec sz yss xs res = match xs with | [] -> if sz >= minsz then k yss res else res | x::xs -> let res = if sz+1 > maxsize then res else do_rec (sz+1) ([x]::yss) xs res in add_elt x yss (fun yss res -> do_rec sz yss xs res) res in do_rec 0 [] (List.rev xs) res (******************) (* Tree generator *) (******************) open BellInfo let gen_leaf sc min max xs k res = part min max xs (fun yss res -> let sts = List.map (fun ys -> Tree (sc,ys,[])) yss in k sts res) res let children sc ts = Tree (sc,[],ts) let contract = if O.debug then Misc.identity else BellInfo.contract let rec do_gen : 'a. (string * int * int) list -> int list -> (BellInfo.scopes list -> 'a -> 'a) -> 'a -> 'a = fun scs xs k res -> match scs with | [] -> assert false | [sc,min,max] -> gen_leaf sc min max xs k res | (sc,min,max)::scs -> part min max xs (fun yss res -> let ysss = List.map (fun ys -> do_gen scs ys Misc.cons []) yss in Misc.fold_cross ysss (fun stss res -> k (List.map (children sc) stss) res) res) res let gen scs n k res = do_gen scs (Misc.interval 0 n) (fun ts res -> k (contract (children "" ts)) res) res let get_scopes () = try let o = BellModel.get_order BellName.scopes O.info in let tops = StringRel.leaves o and bots = StringRel.roots o in let top = StringSet.choose tops and bot = StringSet.choose bots in List.rev (StringRel.path bot top o) with | Not_found -> bad_order () let all n k res = let scs = get_scopes () in match scs with | [] -> bad_order () | top::rem -> let scs = List.map (fun sc -> sc,1,n) rem in do_gen scs (Misc.interval 0 n) (fun ts res -> let t = contract (children top ts) in k t res) res end module NoGen = struct let fail () = Warn.fatal "no scope information" let default _ = fail () let gen _ = fail () let all _ = fail () end herd-herdtools7-1ca343e/gen/showGen.ml000066400000000000000000000025771475314470400176720ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) type t = Edges | Annotations | Fences let parse = function | "edges" -> Edges | "annot"|"annotations" -> Annotations | "fences" -> Fences | _ -> raise (Arg.Bad "Wrong show, choose edges, annotations or fences") herd-herdtools7-1ca343e/gen/showGen.mli000066400000000000000000000024341475314470400200330ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* What to show for generators *) type t = Edges | Annotations | Fences (* May raise Failure *) val parse : string -> t herd-herdtools7-1ca343e/gen/topUtils.ml000066400000000000000000000226651475314470400201030ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2014-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module type Config = sig val optcoherence : bool val do_observers : Config.do_observers val obs_type : Config.obs_type val poll : bool val hexa : bool end module Make : functor (O:Config) -> functor (C:ArchRun.S) -> sig (* Coherence utilities *) type cos0 = (string * (C.C.node * IntSet.t) list list) list type cos = (string * (Code.v array * IntSet.t) list list) list val pp_coherence : cos0 -> unit val last_map : cos0 -> C.C.event StringMap.t val compute_cos : cos0 -> cos (* prefetch *) type pt = { ploc:Code.loc ; pdir:Code.dir; } (* In thread/Out thread *) val io_of_thread : C.C.node list -> (pt * pt) option val io_of_detour : C.C.node -> (pt * pt) option val compile_prefetch_ios : int -> (pt * pt) option list -> string (* affinity *) val compile_coms : C.C.node list list -> string list (* Misc *) val comp_loc_writes : C.C.node -> StringSet.t val comp_atoms : C.C.node -> StringSet.t val find_next_pte_write : C.C.node -> C.C.node option val check_here : C.C.node -> bool val do_poll : C.C.node -> bool val fetch_val : C.C.node -> Code.v end = functor (O:Config) -> functor (C:ArchRun.S) -> struct type cos0 = (string * (C.C.node * IntSet.t) list list) list type cos = (string * (Code.v array * IntSet.t) list list) list open Printf open Code let pp_v = if O.hexa then sprintf "0x%x" else sprintf "%i" let pp_cell t = match Array.length t with | 0 -> "" | 1 -> pp_v t.(0) | _ -> sprintf "[%s]" (String.concat "," (List.map pp_v (Array.to_list t))) let pp_coherence cos0 = eprintf "COHERENCE: " ; Misc.pp_list stderr "" (fun chan (x,vs) -> fprintf chan "<%s:%a>" x (fun chan -> Misc.pp_list chan "|" (fun chan -> Misc.pp_list chan "," (fun chan (n,obs) -> let pp chan = fprintf chan "%s{%s}" in pp chan (pp_cell n.C.C.evt.C.C.cell) (IntSet.pp_str "," (sprintf "%i") obs) ))) vs) cos0 ; eprintf "\n%!" (****************************) (* Last in coherence orders *) (****************************) let rec find_last = function | [] -> assert false | [xs] -> Misc.last xs | _::xss -> find_last xss let do_last_map cos = let lsts = List.map (fun (loc,xss) -> let r,_ = find_last xss in loc,r) cos in List.fold_left (fun m (loc,lst) -> StringMap.add loc lst.C.C.evt m) StringMap.empty lsts let last_map cos = match O.do_observers with | Config.Local when O.optcoherence -> do_last_map cos | _ -> StringMap.empty let compute_cos = List.map (fun (loc,ns) -> loc, List.map (*NOTYET*) (List.map (fun (n,obs) -> let cells = if Misc.check_atag loc then n.C.C.evt.C.C.tcell else n.C.C.evt.C.C.cell in cells,obs)) ns) (******************) (* Prefetch hints *) (******************) (* In thread/Out thread *) type pt = { ploc:Code.loc ; pdir:Code.dir; } let io_of_node n = {ploc=n.C.C.evt.C.C.loc; pdir=Misc.as_some n.C.C.evt.C.C.dir;} let io_of_thread n = match n with | []|[_] -> None | n0::rem -> let n0 = C.C.find_non_insert_store n0 and n1 = C.C.find_non_insert_store_prev (Misc.last rem) in Some (io_of_node n0,io_of_node n1) let io_of_detour _n = None let add_data f loc k = if Code.is_data loc then f loc::k else k let compile_prefetch_ios = let rec do_rec p = function | [] -> [] | None::rem -> do_rec (p+1) rem | Some (i,o)::rem -> let k = do_rec (p+1) rem in if i.ploc = o.ploc then k else add_data (fun loc -> sprintf "%i:%s=F" p (Code.pp_loc loc)) i.ploc (add_data (fun loc -> sprintf "%i:%s=%s" p (Code.pp_loc loc) (match o.pdir with W -> "W" | R -> "T" | J -> "I")) o.ploc k) in fun fst ios -> String.concat "," (do_rec fst ios) (******************) (* Affinity hints *) (******************) (* Most of placement computation is now by litmus *) let write_before m = let rec do_rec n = if m == n then false else let e = n.C.C.edge in match C.E.loc_sd e with | Same -> begin match n.C.C.evt.C.C.dir with | Some W -> true | None|Some R|Some J -> do_rec n.C.C.prev end | Diff -> false in do_rec m.C.C.prev let write_after m = let rec do_rec n = let e = n.C.C.edge in (* eprintf "After %s\n" (C.E.pp_edge e) ; *) begin match n.C.C.evt.C.C.dir with | Some W -> true | None|Some R|Some J -> let nxt = n.C.C.next in if nxt == m then false else begin match C.E.loc_sd e with | Same -> do_rec nxt | Diff -> false end end in do_rec m.C.C.next let last_edge ns = let n = Misc.last ns in let open C.E in match n.C.C.edge.C.E.edge with | Hat -> let wb = write_before n and wa = write_after n in begin match wb,wa with | true,true -> Ws Ext | true,false -> Rf Ext | false,true -> Fr Ext | false,false -> Warn.fatal "Incorrect Hat: read chains are not allowed" end | e -> e let compile_coms nss = List.map (fun ns -> let open C.E in match last_edge ns with | Fr _|Leave CFr|Back CFr -> "Fr" | Rf _|Leave CRf|Back CRf -> "Rf" | Ws _|Leave CWs|Back CWs -> "Co" | _ -> assert false) nss (********) (* Misc *) (********) (* Local writes *) let comp_loc_writes n0 = let rec do_rec n = let k = if n.C.C.next == n0 then StringSet.empty else do_rec n.C.C.next in let k = let e = n.C.C.evt in match e.C.C.dir,e.C.C.loc with | Some W,Data loc -> StringSet.add loc k | ((Some R|None|Some J),_)|(Some W,Code _) -> k in k in do_rec n0 (* Atomic accesses *) let comp_atoms n0 = let rec do_rec n = let k = if n.C.C.next == n0 then StringSet.empty else do_rec n.C.C.next in let k = let e = n.C.C.evt in match e.C.C.atom,e.C.C.loc with | (None,_)|(_,Code _) -> k | Some a,Data loc -> if C.A.worth_final a then StringSet.add loc k else k in k in do_rec n0 (* Worth inserting local check *) let find_next_pte_write n = let loc = n.C.C.evt.C.C.loc in try let r = C.C.find_node (fun m -> let e = m.C.C.evt in if Code.loc_eq loc e.C.C.loc then match e.C.C.dir,e.C.C.bank with | Some W,Pte -> true | _,_ -> false else raise Not_found) n.C.C.next in Some r with Not_found -> None let is_load_init e = e.C.C.dir = Some R && e.C.C.v = 0 let check_edge = function | C.E.Ws Ext | C.E.Fr Ext | C.E.Leave (CFr|CWs) | C.E.Back(CFr|CWs) -> true | _-> false let check_here n = match n.C.C.evt.C.C.bank with | Pte -> begin match find_next_pte_write n with | None -> false | Some m -> not (m == n || C.C.po_pred m n) end | Ord|Pair|Tag|CapaTag|CapaSeal|VecReg _|Instr -> check_edge n.C.C.edge.C.E.edge && not (is_load_init n.C.C.evt) (* Poll for value is possible *) let do_poll n = match O.poll,n.C.C.prev.C.C.edge.C.E.edge,n.C.C.evt.C.C.v with | true, (C.E.Rf Ext|C.E.Leave CRf|C.E.Back CRf),1 -> true | _,_,_ -> false let fetch_val n = let n = C.C.find_node (fun n -> C.E.is_com n.C.C.edge) n.C.C.prev in match n.C.C.edge.C.E.edge with | C.E.Rf _-> 2 | C.E.Fr _ -> 1 | _ -> 0 end herd-herdtools7-1ca343e/gen/top_gen.ml000066400000000000000000001014751475314470400177100ustar00rootroot00000000000000(****************************************************************************) (* The diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Code open Printf module type Config = sig val verbose : int val generator : string val debug : Debug_gen.t val hout : Hint.out val cond : Config.cond val neg : bool val nprocs : int val eprocs : bool val do_observers : Config.do_observers val obs_type : Config.obs_type val optcond : bool val overload : int option val poll : bool val optcoherence : bool val docheck : bool val typ : TypBase.t val hexa : bool val variant : Variant_gen.t -> bool val cycleonly: bool val metadata : bool end module Make (O:Config) (Comp:XXXCompile_gen.S) : Builder.S = struct (* Config *) module A = Comp.A module E = Comp.E type check = Comp.check module R = Comp.R module C = Comp.C let ppo = Comp.ppo open E type edge = E.edge type node = C.node module F = Final.Make(O)(Comp) let add_init_check chk p o init = match chk,o with | true,Some r -> (A.Reg (p,r),Some (A.S "-1"))::init | _,_ -> init type typ = Typ of TypBase.t | Array of TypBase.t * int type test = { name : string ; com : string ; info : Code.info ; edges : edge list ; init : A.init ; prog : A.pseudo list list ; scopes : BellInfo.scopes option ; final : F.final ; env : typ A.LocMap.t } let get_nprocs t = List.length t.prog let get_name t = t.name let set_name t n = { t with name=n; } let set_scope t sc = let pp = BellInfo.pp_scopes sc in { t with scopes = Some sc; info = ("Scopes",pp)::t.info; } let do_add_info key v k = match v with "" -> k | _ -> (key,v)::k let add_info t k i = { t with info = do_add_info k i t.info; } let extract_edges {edges=es; _} = es (* Utilities *) module U = TopUtils.Make(O)(Comp) (***************) (* Compilation *) (***************) let rec emit_overload st p init ov loc = if ov <= 0 then init,[],st else let loc_ov = sprintf "%s%i" loc ov in let _,init,i,st = Comp.emit_load st p init loc_ov in let init,is,st = emit_overload st p init (ov-1) loc in init,i@is,st let insert_overload n = match n.C.edge.E.edge with | Po (_,Dir R,Dir (W|R)) -> true | _ -> false type prev_load = | No (* Non-existent or irrelevant *) | Yes of E.dp * A.arch_reg * C.node (* Catch exchanges at the very last moment... *) let as_rmw n = match n.C.edge.E.edge with | Rmw rmw -> rmw | _ -> assert false let call_emit_access st p init n = let e = n.C.evt in if e.C.rmw then match e.C.dir with | Some R -> Comp.emit_rmw (as_rmw n) st p init e n.C.next.C.evt | Some W|None -> None,init,[],st | Some J -> assert false else if match e.C.atom with | None -> true | Some a -> begin match e.C.dir with | None -> false | Some d -> A.applies_atom a d end then Comp.emit_access st p init e else Warn.fatal "annotation mismatch on edge %s, annotation '%s' on %s" (E.pp_edge n.C.edge) (E.pp_atom_option e.C.atom) (Misc.app_opt_def "_" pp_dir e.C.dir) let call_emit_access_dep st p init n dp r1 n1 = let e = n.C.evt in if e.C.rmw then match e.C.dir with | Some R -> Comp.emit_rmw_dep (as_rmw n) st p init e n.C.next.C.evt dp r1 n1 | Some W|None -> None,init,[],st | Some J -> assert false else Comp.emit_access_dep st p init e dp r1 n1 (* Encodes load of first non-initial value in chain, can poll on value in place of checking it *) let emit_access ro_prev st p init n = let init,ip,st = match O.overload,n.C.evt.C.loc with | Some ov,Data loc when insert_overload n -> emit_overload st p init ov loc | _ -> init,[],st in let o,init,i,st = match ro_prev,n.C.evt.C.loc with | No,Data loc -> if U.do_poll n then let r,init,i,st = Comp.emit_load_one st p init loc in Some r,init,i,st else call_emit_access st p init n | No,Code _ -> call_emit_access st p init n | Yes (dp,r1,n1),_ -> call_emit_access_dep st p init n dp r1 n1 in o,init,ip@i,st let edge_to_prev_load o n = match o with | None -> No | Some r -> begin match n.C.edge.E.edge with | Dp (dp,_,_) -> Yes (dp,r,n) | _ -> No end let get_fence n = match n.C.edge.E.edge with | E.Fenced (fe,_,_,_) -> Some fe | _ -> None let no_check_load init st = init,Misc.identity,st let rec collect_inserts = function | [] -> [],[] | n::ns as all -> match n.C.edge.E.edge with | E.Insert f -> let fs,ns = collect_inserts ns in f::fs,ns | _ -> [],all let rec compile_proc pref chk loc_writes st p ro_prev init ns = match ns with | [] -> init,pref [],(C.EventMap.empty,[]),st | n::ns -> if O.verbose > 1 then eprintf "COMPILE PROC: <%s>\n" (C.str_node n); begin match n.C.edge.E.edge with | E.Node _ -> let fs,ns = collect_inserts ns in compile_proc (fun is -> pref (List.fold_right (fun f is -> let _,cs,_ = Comp.emit_fence st p init n f in cs@is) fs is)) chk loc_writes st p ro_prev init ns | E.Insert f -> let ro_prev,init,cs,st, n1 = match ro_prev with | No -> let init, cs, st = Comp.emit_fence st p init n f in None, init, cs, st, n | Yes (dp,r1,n1) -> let ro_prev,init,cs,st = Comp.emit_fence_dp st p init n f dp r1 n1 in ro_prev,init,cs,st, n1 in let init,is,finals,st = compile_proc pref chk loc_writes st p (edge_to_prev_load ro_prev n1) init ns in init,cs@is,finals,st | _ -> let o,init,i,st = emit_access ro_prev st p init n in let nchk,add_check = match O.docheck,n.C.evt.C.dir,o,ns with | true,Some R,Some r,_::_ -> true,Comp.check_load p r n.C.evt | _ -> chk,no_check_load in let init,mk_c,st = add_check init st in let init,is,finals,st = compile_proc pref nchk loc_writes st p (edge_to_prev_load o n) init ns in let init,cf,st = match get_fence n with | Some fe -> Comp.emit_fence st p init n fe | None -> init,[],st in add_init_check chk p o init, i@ mk_c (cf@is), (match n.C.evt.C.loc with | Data loc -> let call_add = StringSet.mem loc loc_writes && not (U.do_poll n) in if call_add then F.add_final (A.get_friends st) p o n finals else begin finals end | Code _ -> begin match o with | None -> finals (* Code write *) | Some r -> (* fetch! *) let m,fenv = finals in m,F.add_final_v p r (IntSet.singleton (U.fetch_val n)) fenv end), st end (*************) (* Observers *) (*************) let last_observation st p i x v = let r,i,c,_st = Comp.emit_obs Ord st p i x in i,c,F.add_final_v p r v [] let rec straight_observer st p i x = function | [] -> i,[],[] | [v] -> last_observation st p i x v | v::vs -> let r,i,c,st = Comp.emit_obs Ord st p i x in let i,cs,fs = straight_observer st p i x vs in i,c@cs,F.add_final_v p r v fs let rec fenced_observer st p i x = function | [] -> i,[],[] | [v] -> last_observation st p i x v | v::vs -> let r,i,c,st = Comp.emit_obs Ord st p i x in let i,f,st = Comp.emit_fence st p i C.nil Comp.stronger_fence in let i,cs,fs = fenced_observer st p i x vs in i,c@f@cs,F.add_final_v p r v fs let loop_observer st p i x = function | []|[_] -> i,[],[] | v::vs -> let r,i,c,st = Comp.emit_obs_not_zero st p i x in let rec do_loop st i prev_r = function | [] -> assert false | [v] -> let r,i,c,_st = Comp.emit_obs_not_eq st p i x prev_r in i,c,F.add_final_v p r v [] | v::vs -> let r,i,c,st = Comp.emit_obs_not_eq st p i x prev_r in let i,cs,fs = do_loop st i r vs in i,c@cs,F.add_final_v p r v fs in let i,cs,fs = do_loop st i r vs in i,c@cs,F.add_final_v p r v fs let rec split_last = function | [] -> assert false | [v] -> [],v | v::vs -> let vs,w = split_last vs in v::vs,w let rec do_opt_coherence k obs = function | [] -> [k] | (v,vobs)::co -> let i = IntSet.inter obs vobs in if IntSet.is_empty i then begin k:: do_opt_coherence (IntSet.singleton v) vobs co end else do_opt_coherence (IntSet.add v k) vobs co let opt_coherence = function | [] -> assert false | (v,obs)::co -> do_opt_coherence (IntSet.singleton v) obs co let min_set = IntSet.min_elt let max_set = IntSet.max_elt let min_max xs = let ps = List.map (fun x -> min_set x, max_set x) xs in match ps with | []|[_] -> [] | (_,x)::rem -> let rec remove_last = function | [] -> assert false | [x,_] -> [x] | (x,y)::rem -> if x=y then x::remove_last rem else x::y::remove_last rem in List.map IntSet.singleton (x::remove_last rem) exception NoObserver let build_observer st p i x vs = let vs,f = if O.optcoherence && O.obs_type <> Config.Loop then let vs = opt_coherence vs in if O.verbose > 1 then begin eprintf "OPT:" ; List.iter (fun vs -> eprintf " {%s}" (IntSet.pp_str "," (sprintf "%i") vs)) vs ; eprintf "\n%!" end ; match vs with | []|[_] -> raise NoObserver | _ -> if List.for_all (fun is -> match IntSet.as_singleton is with | Some _ -> true | None -> false) vs then let ws,w = split_last vs in (match ws with [_] -> [] | _ -> ws),[A.Loc x, w] else min_max vs,[] else let vs = List.map (fun (v,_obs) -> IntSet.singleton v) vs in vs,[] in let i,cs,fs = let open Config in match O.obs_type with | Straight -> straight_observer st p i x vs | Config.Fenced -> fenced_observer st p i x vs | Loop -> loop_observer st p i x vs in i,cs,F.add_int_sets fs f let rec build_observers p i x arg = let open Config in match arg,O.do_observers with | [],_ -> i,[],[] | []::vss,_ | [_]::vss,(Avoid|Accept) -> build_observers p i x vss | vs::vss,_ -> let i0 = i in try let i,c,f = build_observer A.st0 p i x vs in begin match c,O.do_observers with | _::_,Avoid -> Warn.fatal "Observer" | _,_ -> () end ; match c with | [] -> let i,cs,fs = build_observers p i0 x vss in i,cs,f@fs | _ -> let i,cs,fs = build_observers (p+1) i x vss in i,c::cs,f@fs with NoObserver -> build_observers p i x vss let check_writes env_wide atoms = let call_build_observers p i x vs = if StringMap.mem x env_wide then Warn.user_error "No observers on wide accesses" else let vs = List.map (Misc.filter_map (fun (v,obs) -> if Array.length v > 0 then Some (v.(0),obs) else None )) vs in build_observers p i x vs in let cons_one x v fs = let loc = A.Loc x in if StringMap.mem x env_wide then F.cons_vec loc v fs else if Array.length v > 0 then (* For MTE locations, we may have only a tag write and not an *) (* Ord write. We therefore need a length check here. *) F.cons_int (A.Loc x) v.(0) fs else fs in let add_look_loc loc v k = if (not (StringSet.mem loc atoms) && O.optcond) then k else cons_one loc v k in let rec check_rec p i = let open Config in function | [] -> i,[],[] | (x,vs)::xvs -> let i,c,f = match O.cond with | Observe -> let vs = List.flatten vs in begin match vs with | [] -> i,[],[] | _::_ -> let v,_ = Misc.last vs in i,[],cons_one x v [] end | Unicond -> assert false | Cycle -> begin match vs with | [] -> i,[],[] | [[(v,_)]] -> i,[],add_look_loc x v [] | [[_;(v,_)]] -> begin match O.do_observers with | Local -> i,[],add_look_loc x v [] | Avoid|Accept|Three|Four|Infinity -> i,[],cons_one x v [] | Enforce -> let i,c,f = call_build_observers p i x vs in i,c,add_look_loc x v f end | _ -> let vs_flat = List.flatten vs in let v,_ = Misc.last vs_flat in begin match O.do_observers with | Local -> i,[],add_look_loc x v [] | Three -> begin match vs_flat with | _x1::_x2::_x3::_x4::_ -> Warn.fatal "More than three writes" | _ -> i,[],cons_one x v [] end |Four -> begin match vs_flat with | _x1::_x2::_x3::_x4::_x5::_ -> Warn.fatal "More than four writes" | _ -> i,[],cons_one x v [] end | Infinity -> i,[],cons_one x v [] | _ -> let i,c,f = call_build_observers p i x vs in i,c,add_look_loc x v f end end in let i,cs,fs = check_rec (p+List.length c) i xvs in i,c@cs,f@fs in check_rec let compile_store st p init n = let ro,init,c,st = call_emit_access st p init n in assert (ro=None) ; init,c,st let rec compile_stores st p i ns c = match ns with | [] -> i,c,st | n::ns -> let sto = n.C.store in if sto == C.nil then compile_stores st p i ns c else let i,c0,st = compile_store st p i sto in let i,c,st = compile_stores st p i ns c in i,c0@c,st (* Local check of coherence *) let do_add_load bank st p i f x v = let r,i,c,st = Comp.emit_obs bank st p i x in let v = match bank with | Pair -> v+v | _ -> v in i,c,F.add_final_v p r (IntSet.singleton v) f,st let do_add_loop st p i f x v w = let r,i,c,st = Comp.emit_obs_not_value st p i x v in i,c,F.add_final_v p r (IntSet.singleton w) f,st let rec do_observe_local bank obs_type st p i code f x prev_v v = match obs_type with | Config.Straight -> let i,c,f,st = do_add_load bank st p i f x v in i,code@c,f,st | Config.Fenced -> let i,c,f,st = do_add_load bank st p i f x v in let i,c',st = Comp.emit_fence st p i C.nil Comp.stronger_fence in let c = c'@c in i,code@c,f,st | Config.Loop -> begin match prev_v with | Some prev_v -> begin match bank with | Pair -> Warn.user_error "No loop observer for pairs" | _ -> () end ; let i,c,f,st = do_add_loop st p i f x prev_v v in i,code@c,f,st | None -> do_observe_local bank Config.Fenced st p i code f x None v end let do_observe_local_simd st p i code f x bank nxt = let vs = nxt.C.vecreg in let r,i,c,st = Comp.emit_obs bank st p i x in let i,c,st = match O.obs_type with | Config.Straight -> i,c,st | Config.Fenced|Config.Loop -> (* No loop observed, too complex *) let i,c',st = Comp.emit_fence st p i C.nil Comp.stronger_fence in i,c'@c,st in let rs = r::A.get_friends st r in let f = List.fold_right2 (fun r v -> F.add_final_loc p r (Code.add_vector O.hexa v)) rs vs f in i,code@c,f,st let do_add_local_check_pte avoid st p i code f n x = if StringSet.mem (Misc.add_pte x) avoid then i,code,f,st else match U.find_next_pte_write n with | None -> assert false (* As U.check_here n returned true *) | Some nxt -> let v = nxt.C.evt.C.pte in let r,i,c,st = Comp.emit_obs Pte st p i x in i,code@c,F.add_final_pte p r v f,st let add_co_local_check_pte avoid ns st p i code f = let lst = Misc.last ns in if U.check_here lst then match lst.C.evt.C.loc,lst.C.evt.C.bank with | Data x,Pte -> do_add_local_check_pte avoid st p i code f lst x | _ -> i,code,f,st else i,code,f,st let add_co_local_check avoid_ptes lsts ns st p i code f = let lst = Misc.last ns in if U.check_here lst then match lst.C.evt.C.loc,lst.C.evt.C.bank with | Data x,(Ord|Pair|Instr) -> (* TODO check for -obs local mode and pairs *) let nxt = lst.C.next.C.evt in let bank = nxt.C.bank in begin match bank with | VecReg _ -> do_observe_local_simd st p i code f x bank nxt | _ -> let v = nxt.C.v and prev_v = lst.C.evt.C.v in let all_lst = try StringMap.find x lsts with Not_found -> C.evt_null in if C.OrderedEvent.compare all_lst lst.C.next.C.evt = 0 then i,code,F.cons_int_set (A.Loc x,IntSet.singleton v) f,st else let bank = match bank with | Pair -> Pair | _ -> Ord in do_observe_local bank O.obs_type st p i code f x (Some prev_v) v end | Data x,Tag -> let v = lst.C.next.C.evt.C.v in let r,i,c,st = Comp.emit_obs Tag st p i x in i,code@c,F.add_final_loc p r (Code.add_tag x v) f,st | Data x,CapaTag -> let v = lst.C.next.C.evt.C.v in let r,i,c,st = Comp.emit_obs CapaTag st p i x in i,code@c,F.add_final_loc p r (Code.add_capability x v) f,st | Data x,CapaSeal -> let v = lst.C.next.C.evt.C.v in let r,i,c,st = Comp.emit_obs CapaSeal st p i x in i,code@c,F.add_final_loc p r (Code.add_capability x v) f,st | Data x,Pte -> do_add_local_check_pte avoid_ptes st p i code f lst x | Data x,(VecReg _)-> let nxt = lst.C.next.C.evt in let bank = nxt.C.bank in begin match bank with | Ord|Pair -> let v = nxt.C.v in do_observe_local bank O.obs_type st p i code f x None v | VecReg _ -> do_observe_local_simd st p i code f x bank nxt | _ -> Warn.user_error "Mixing SIMD and other variants" end | Code _,_ -> i,code,f,st else i,code,f,st (******************************************) (* Compile cycle, ie generate test proper *) (******************************************) let gather_final_oks p st = let npairs = A.get_noks st in if npairs > 0 then [A.Loc (as_data (Code.myok_proc p)),IntSet.singleton npairs] else [] let do_memtag = O.variant Variant_gen.MemTag let do_morello = O.variant Variant_gen.Morello let do_kvm = Variant_gen.is_kvm O.variant let compile_cycle ok initvals n = if O.verbose > 0 then begin Printf.eprintf "COMPILE CYCLE:\n%a" C.debug_cycle n end ; let open Config in Label.reset () ; let env_wide = C.get_wide n in let env_pair = if StringMap.is_empty env_wide then StringSet.empty else C.get_pair n in let splitted = C.split_procs n in (* Split before, as proc numbers added by side effet.. *) let cos0 = C.coherence n in let lsts = U.last_map cos0 in let cos = U.compute_cos cos0 in let last_ptes = if do_kvm then C.last_ptes n else [] in if O.verbose > 1 then Printf.eprintf "Last_Ptes: %s\n" (String.concat "," (List.map (fun (loc,v) -> Printf.sprintf "%s->%s" loc (C.PteVal.pp v)) last_ptes)) ; let no_local_ptes = StringSet.of_list (List.map fst last_ptes) in if O.verbose > 1 then U.pp_coherence cos0 ; let loc_writes = U.comp_loc_writes n in let rec do_rec p i = function | [] -> List.rev i,[],(C.EventMap.empty,[]),[],A.LocMap.empty | n::ns -> let i,c,(m,f),st = compile_proc Misc.identity false loc_writes A.st0 p No i n in let i,c,st = compile_stores st p i n c in let xenv = Comp.get_xstore_results c in let f = List.fold_left (fun f (r,v) -> F.add_final_v p r (IntSet.singleton v) f) f xenv in let i,c,f,st = match O.cond with | Unicond -> i,c,f,st | Cycle|Observe -> match O.do_observers with | Local -> add_co_local_check no_local_ptes lsts n st p i c f | Avoid|Accept|Enforce|Three|Four|Infinity -> add_co_local_check_pte no_local_ptes n st p i c f in let i,c,st = Comp.postlude st p i c in let env_p = A.get_env st in let foks = gather_final_oks p st in let i,cs,(ms,fs),ios,env = do_rec (p+1) i ns in let io = U.io_of_thread n in i,c::cs, (C.union_map m ms,F.add_int_sets (f@fs) foks), io::ios, A.LocMap.union_std (fun loc t1 t2 -> if TypBase.equal t1 t2 then Some t1 else Warn.fatal "Location %s defined with contradictory types %s and %s" (A.pp_location loc) (TypBase.pp t1) (TypBase.pp t2)) env_p env in let i,obsc,f = match O.cond with | Unicond -> [],[],[] | Cycle|Observe -> let atoms = U.comp_atoms n in check_writes env_wide atoms 0 [] cos in match splitted,O.cond with | [],_ -> Warn.fatal "No proc" (* | [_],Cycle -> Warn.fatal "One proc" *) | _,_ -> let i,c,(m,f),ios,env = if let len = List.length splitted in O.nprocs <= 0 || (if O.eprocs then len = O.nprocs else len <= O.nprocs) then let ess = List.map (List.map (fun n -> n.C.edge)) splitted in if ok ess then let i,cs,(m,fs),ios,env = do_rec (List.length obsc) i splitted in i,obsc@cs,(m,f@fs),ios,env else Warn.fatal "Last minute check" else Warn.fatal "Too many procs" in let env = A.LocMap.map (fun t -> Typ t) env in let env = StringMap.fold (fun loc sz k -> let aloc = A.Loc loc in assert (not (A.LocMap.mem aloc k)) ; let ty = if StringSet.mem loc env_pair then O.typ else TypBase.Int in A.LocMap.add aloc (Array (ty,sz)) k) env_wide env in let env = let ptes = A.LocSet.of_list (F.extract_ptes f) in List.fold_left (fun m (loc,_) -> try (* Do not override previous typing bindings *) ignore (A.LocMap.find loc m); m with Not_found -> let t = if A.LocSet.mem loc ptes then TypBase.pteval_t else O.typ in A.LocMap.add loc (Typ t) m) env f in let env = let globals = C.get_globals ~init:initvals n in let typ = if do_morello then TypBase.Std (TypBase.Unsigned,MachSize.S128) else O.typ in let typ = Typ typ in List.fold_left (fun m loc -> let loc = A.Loc loc in if A.LocMap.mem loc m then m else A.LocMap.add loc typ m) env globals in let flts = if O.variant Variant_gen.NoFault then [] else if do_memtag then let tagchange = let ts = List.fold_left (fun k ns -> List.fold_left (fun k n -> match n.C.evt.C.dir,n.C.evt.C.loc,n.C.evt.C.bank with | Some W,Data x,Tag -> x::k | _ -> k) k ns) [] splitted in StringSet.of_list ts in let get_locs ns = let xs = List.fold_left (fun k n -> match n.C.evt.C.loc,n.C.evt.C.bank with | Data x,Ord when StringSet.mem x tagchange -> x::k | _ -> k) [] ns in StringSet.of_list xs in let flts = List.mapi (fun i ns -> i,get_locs ns) splitted in List.filter (fun (_,xs) -> not (StringSet.is_empty xs)) flts else if do_morello then let tagchange ns = let ts = List.fold_left (fun k n -> match n.C.prev.C.edge.edge,n.C.evt.C.loc,n.C.evt.C.bank with | Dp (dp,_,_),Data x,CapaTag when A.is_addr dp -> x::k | Dp (dp,_,_),Data x,CapaSeal when A.is_addr dp -> x::k | _ -> k) [] ns in StringSet.of_list ts in let flts = List.mapi (fun i ns -> i,tagchange ns) splitted in List.filter (fun (_,xs) -> not (StringSet.is_empty xs)) flts else if do_kvm then let get_locs ns = let xs = List.fold_left (fun k n -> let e = n.C.evt in match e.C.loc,e.C.bank with | Data x,Ord -> x::k | _ -> k) [] ns in StringSet.of_list xs in let flts = List.mapi (fun i ns -> i,get_locs ns) splitted in List.filter (fun (_,xs) -> not (StringSet.is_empty xs)) flts else [] in let f = List.fold_left (fun f (x,p) -> F.cons_pteval (A.Loc x) p f) f last_ptes in let fc = match O.cond with | Unicond -> let evts = List.map (List.map (fun n -> n.C.evt)) splitted in F.run evts m | Cycle -> F.check f | Observe -> F.observe f in let i = if do_kvm then A.complete_init O.hexa initvals i else i in (i,c,fc flts,env), (U.compile_prefetch_ios (List.length obsc) ios, U.compile_coms splitted) (********) (* Dump *) (********) let get_proc = function | A.Loc _ -> -1 | A.Reg (p,_) -> p (* let pp_pointer t = let open TypBase in let open MachSize in match t with | Int|Std (Signed,Word) -> "" | _ -> sprintf "%s* " (TypBase.pp t) *) let dump_init chan inits env = let locs_init = List.fold_left (fun k (loc,_) -> A.LocSet.add loc k) A.LocSet.empty inits in fprintf chan "{" ; let pp = A.LocMap.fold (fun loc t k -> match t with | Array (ty,sz) -> sprintf "%s %s[%d];" (TypBase.pp ty) (A.pp_location loc) sz::k | Typ t -> if A.LocSet.mem loc locs_init then k else let open TypBase in let open MachSize in match t with | Int|Std (Signed,Word) -> k | _ -> sprintf "%s %s;" (TypBase.pp t) (A.pp_location loc)::k) env [] in begin match pp with | [] -> () | _::_ -> fprintf chan "\n%s\n" (String.concat " " pp) end ; let rec p_rec q = function | [] -> fprintf chan "\n}\n" | (left,loc)::rem -> let p = get_proc left in if p <> q then fprintf chan "\n" else fprintf chan " " ; fprintf chan "%s%s%s;" (match loc with | Some _ -> begin try let t = match A.LocMap.find left env with | Typ t -> t | _ -> raise Not_found in TypBase.pp t ^ " " with Not_found -> "" end | None -> "") (A.pp_location left) (match loc with | Some v -> sprintf "=%s" (A.pp_initval v) | None -> "") ; p_rec p rem in p_rec (-1) inits let rec dump_pseudo = function | [] -> [] | A.Instruction ins::rem -> A.dump_instruction ins::dump_pseudo rem | A.Label (lbl,ins)::rem -> sprintf "%s:" lbl::dump_pseudo (ins::rem) | A.Nop::rem -> dump_pseudo rem | A.Symbolic _::_ -> assert false (* no symbolic in diy *) | A.Macro (m,args)::rem -> sprintf "%s(%s)" m (String.concat "," (List.map A.pp_reg args)):: dump_pseudo rem let fmt_cols = let rec fmt_col p k = function | [] -> k | cs::prog -> (pp_proc p::dump_pseudo cs):: fmt_col (p+1) k prog in fmt_col 0 [] let dump_code chan code = let pp = fmt_cols code in Misc.pp_prog chan pp let dump_test_channel_full chan t = fprintf chan "%s %s\n" (Archs.pp A.arch) t.name ; if O.metadata then begin if t.com <> "" then fprintf chan "\"%s\"\n" t.com ; List.iter (fun (k,v) -> fprintf chan "%s=%s\n" k v) t.info ; Hint.dump O.hout t.name t.info end ; dump_init chan t.init t.env ; dump_code chan t.prog ; begin match t.scopes with | None -> () | Some st -> fprintf chan "scopes: %s\n" (BellInfo.pp_scopes st) end ; F.dump_final chan t.final ; () let dump_test_channel chan t = if O.cycleonly then if t.com <> "" then fprintf chan "%s: %s\n" t.name t.com else Warn.fatal "-cycleonly=true requested but no cycle generated" else dump_test_channel_full chan t let num_labels = let rec num_ins p m = function | A.Label (lab,i) -> num_ins p (StringMap.add lab p m) i | _ -> m in let num_code p = List.fold_left (num_ins p) in let rec num_rec p m = function | [] -> m | c::cs -> num_rec (p+1) (num_code p m c) cs in num_rec 0 StringMap.empty let tr_labs m env = List.map (fun bd -> match bd with | (loc,Some (A.S v)) -> begin try let v = let p = StringMap.find v m in sprintf "%s:%s" (pp_proc p) v in loc,Some (A.S v) with Not_found -> bd end | (_,(Some (A.P _)|None)) as bd -> bd) env let do_self = O.variant Variant_gen.Self let test_of_cycle name ?com ?(info=[]) ?(check=(fun _ -> true)) ?scope ?(init=[]) es c = let com = match com with None -> pp_edges es | Some com -> com in let (init,prog,final,env),(prf,coms) = compile_cycle check init c in let archinfo = Comp.get_archinfo c in let m_labs = num_labels prog in let init = tr_labs m_labs init in let coms = String.concat " " coms in let info = let myinfo = (if do_self then fun k -> k else do_add_info "Prefetch" prf) (do_add_info "Com" coms (do_add_info "Orig" com [])) in let myinfo = match scope with | None -> myinfo | Some st -> ("Scopes",BellInfo.pp_scopes st)::myinfo in let myinfo = ("Generator",O.generator)::myinfo in info@myinfo@archinfo in { name=name ; info=info; com=com ; edges = es ; init=init ; prog=prog ; scopes = scope; final=final ; env=env; } let make_test name ?com ?info ?check ?scope es = try if O.verbose > 1 then eprintf "**Test %s**\n" name ; if O.verbose > 2 then eprintf "**Cycle %s**\n" (pp_edges es) ; let es,c,init = C.make es in test_of_cycle name ?com ?info ?check ?scope ~init es c with | Misc.Fatal msg|Misc.UserError msg -> Warn.fatal "Test %s [%s] failed:\n%s" name (pp_edges es) msg end herd-herdtools7-1ca343e/gen/typBase.ml000066400000000000000000000060371475314470400176620ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2014-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Base type for produced tests *) open MachSize type sgn = Signed | Unsigned type t = Int | Std of sgn * MachSize.sz | Pteval let tags = ["int"; "int8_t"; "uint8_t"; "int16_t"; "uint16_t"; "int32_t"; "uint32_t"; "int64_t"; "uint64_t"; "int128_t"; "uint128_t"; "__int128"; "__uint128"; ] let parse s = match s with | "int" -> Some Int | "int8_t" -> Some (Std (Signed,Byte)) | "uint8_t" -> Some (Std (Unsigned,Byte)) | "int16_t" -> Some (Std (Signed,Short)) | "uint16_t" -> Some (Std (Unsigned,Short)) | "int32_t" -> Some (Std (Signed,Word)) | "uint32_t" -> Some (Std (Unsigned,Word)) | "int64_t" -> Some (Std (Signed,Quad)) | "uint64_t" -> Some (Std (Unsigned,Quad)) | "int128_t" -> Some (Std (Signed,S128)) | "uint128_t" -> Some (Std (Unsigned,S128)) | "__int128" -> Some (Std (Signed,S128)) | "__uint128" -> Some (Std (Unsigned,S128)) | _ -> None let pp = function | Int -> "int" | Std (Signed,Byte) -> "int8_t" | Std (Unsigned,Byte) -> "uint8_t" | Std (Signed,Short) -> "int16_t" | Std (Unsigned,Short) -> "uint16_t" | Std (Signed,Word) -> "int32_t" | Std (Unsigned,Word) -> "uint32_t" | Std (Signed,Quad) -> "int64_t" | Std (Unsigned,Quad) -> "uint64_t" | Std (Signed,S128) -> "__int128" | Std (Unsigned,S128) -> "__uint128" | Pteval -> "pteval_t" let sign_equal s1 s2 = match s1,s2 with | (Unsigned,Unsigned) | (Signed,Signed) -> true | (Unsigned,Signed) | (Signed,Unsigned) -> false let equal t1 t2 = match t1,t2 with | (Int,Int) | (Pteval,Pteval) -> true | (Std (s1,sz1),Std (s2,sz2)) -> sign_equal s1 s2 && MachSize.equal sz1 sz2 | ((Int|Pteval),Std _) | (Std _,(Int|Pteval)) | (Int,Pteval) | (Pteval,Int) -> false let default = Int let is_default = function | Int -> true | _ -> false let pteval_t = Pteval let is_pteval_t = function | Pteval -> true | _ -> false let get_size = function | Int -> Word | Std (_,sz) -> sz | Pteval -> Quad herd-herdtools7-1ca343e/gen/typBase.mli000066400000000000000000000027711475314470400200340ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2014-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Base type for produced tests *) type sgn = Signed | Unsigned type t = Int | Std of sgn * MachSize.sz | Pteval val tags : string list val parse : string -> t option val pp : t -> string val equal : t -> t -> bool val default : t val is_default : t -> bool val pteval_t : t val is_pteval_t : t -> bool val get_size : t -> MachSize.sz herd-herdtools7-1ca343e/gen/util.ml000066400000000000000000000045151475314470400172270ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Printf type spec = string * Arg.spec * string let parse_tag opt set tags msg = opt, Arg.String (fun tag -> match set tag with | false -> raise (Arg.Bad (sprintf "bad tags for %s, allowed tag are %s" opt (String.concat "," tags))) | true -> ()), sprintf "<%s> %s" (String.concat "|" tags) msg let parse_tags opt set_one all_tags msg = opt, Arg.String (fun tags -> let tags = Misc.split_comma tags in List.iter (fun tag -> match set_one tag with | false -> raise (Arg.Bad (sprintf "bad tags for %s, allowed tag are %s" opt (String.concat "," all_tags))) | true -> ()) tags), sprintf "<%s> %s" (String.concat "|" all_tags) msg let arch_opt arch = let d = !arch in parse_tag "-arch" (fun tag -> match Archs.parse tag with | None -> false | Some a -> arch := a ; true) Archs.tags (sprintf "specify architecture, default %s" (Archs.pp d)) let parse_cmdline options get_cmd_arg = Arg.parse options get_cmd_arg (sprintf "Usage %s [options] [arg]*\noptions are:" Sys.argv.(0)) herd-herdtools7-1ca343e/gen/util.mli000066400000000000000000000030311475314470400173700ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) type spec = string * Arg.spec * string val parse_tag : string -> (string -> bool) -> string list -> string -> string * Arg.spec * string val parse_tags : string -> (string -> bool) -> string list -> string -> string * Arg.spec * string val arch_opt : Archs.t ref -> spec val parse_cmdline : spec list -> (string -> unit) -> unit herd-herdtools7-1ca343e/gen/varAtomic.ml000066400000000000000000000073241475314470400202000ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2011-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Edge variations on plain/atomic/reserve *) module type S = sig type edge val varatom_one : edge list -> edge list list val varatom_es : edge list list -> edge list list end module type Fold = sig type atom val fold : (atom option -> 'a -> 'a) -> 'a -> 'a end module Make(E:Edge.S) (F:Fold with type atom = E.atom) : S with type edge = E.edge = struct type edge = E.edge open E (* Notice, var_src si applied second, hence RMW check *) let can_set_src e a = match e.E.edge with | E.Rmw _ -> E.compare_atomo e.E.a2 a = 0 | _ -> true let var_src e es = match e.E.a1 with | None -> F.fold (fun ao k -> if can_set_src e ao then ({ e with a1=ao }::es)::k else k) [] | Some _ -> [e::es] let var_tgt e es = match e.E.a2 with | None -> F.fold (fun ao k -> ({ e with a2=ao }::es)::k) [] | Some _ -> [e::es] let var_edge e1 e2 es = match e1.E.a2,e2.E.a1 with | None,None -> F.fold (fun ao k -> if can_set_src e2 ao then ({ e1 with a2 = ao}::{ e2 with a1 = ao}::es)::k else k) [] | _,_ -> [e1::e2::es] (* let var_both e = match e.E.edge with | E.Rmw -> begin match e.E.a1,e.E.a2 with | None,None -> (* RMW have identical atomic specs for source and targets *) F.fold (fun ao k -> { e with a1=ao; a2=ao; }::k) [] | _,_ -> [e] end | _ -> begin match e.E.a1,e.E.a2 with | None,None -> F.fold (fun ao1 k -> F.fold (fun ao2 k -> { e with a1=ao1; a2=ao2; }::k) k) [] | None,Some _ -> F.fold (fun ao1 k -> { e with a1=ao1;}::k) [] | Some _,None -> F.fold (fun ao2 k -> { e with a2=ao2;}::k) [] | Some _,Some _ -> [e] end *) (* Variation of composite relaxation candidate *) let as_cons = function | e::es -> e,es | [] -> assert false let rec varatom_inside = function | [] -> assert false | [e] -> var_tgt e [] | e1::(_::_ as ess) -> let ess = varatom_inside ess in List.fold_right (fun es k -> let e2,rem = as_cons es in var_edge e1 e2 rem@k) ess [] let varatom_ones es k = match es with | [] -> k | _ -> let ess = varatom_inside es in List.fold_right (fun es k -> let e,es = as_cons es in var_src e es@k) ess k let varatom_one es = varatom_ones es [] let varatom_es es = List.fold_right varatom_ones es [] end herd-herdtools7-1ca343e/gen/variant_gen.ml000066400000000000000000000065111475314470400205450ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2018-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) type t = (* RISCV: tagged accesses as amo's with x0 as arg (load) or result (store) *) | AsAmo | ConstsInInit (* Mixed size (diy only, see alt.ml) *) | Mixed (* Lift the default restriction of mixed-size annotation to depth one *) | FullMixed (* Allow non-overlapping mixed accesses *) | MixedDisjoint (* Require strict overlap *) | MixedStrictOverlap (* Self-modifying code *) | Self (* MTE = Memory tagging *) | MemTag (* C: Prevents the use of Volatile to capture bugs in compilation *) | NoVolatile (* Morello C64 instruction set *) | Morello (* Explicit virtual memory *) | KVM | FullKVM | NoFault (* Neon AArch64 extension *) | Neon (* Scalable Vector extension (AArch64) *) | SVE (* Scalable Matrix extension (AArch64) *) | SME (* Constrained Unpredictable *) | ConstrainedUnpredictable let tags = ["AsAmo";"ConstsInInit"; "Mixed";"FullMixed";"MixedDisjoint"; "MixedStrictOverlap"; "Self"; "MemTag"; "NoVolatile"; "Morello"; "kvm"; "FullKvm"; "NoFault"; "Neon"; "ConstrainedUnpredictable"; ] let parse tag = match Misc.lowercase tag with | "asamo" -> Some AsAmo | "constsininit" -> Some ConstsInInit | "mixed" -> Some Mixed | "fullmixed" -> Some FullMixed | "mixeddisjoint"|"disjoint" -> Some MixedDisjoint | "mixedstrictoverlap"|"strictoverlap" -> Some MixedStrictOverlap | "self" -> Some Self | "memtag" -> Some MemTag | "novolatile" -> Some NoVolatile | "morello" -> Some Morello | "kvm" -> Some KVM | "fullkvm" -> Some FullKVM | "nofault" -> Some NoFault | "neon" -> Some Neon | "sve" -> Some SVE | "sme" -> Some SME | "constrainedunpredictable"|"cu" -> Some ConstrainedUnpredictable | _ -> None let pp = function | AsAmo -> "AsAmo" | ConstsInInit -> "ConstsInInit" | Mixed -> "Mixed" | FullMixed -> "FullMixed" | MixedDisjoint -> "MixedDisjoint" | MixedStrictOverlap -> "MixedStrictOverlap" | Self -> "Self" | MemTag -> "MemTag" | NoVolatile -> "NoVolatile" | Morello -> "Morello" | KVM -> "kvm" | FullKVM -> "FullKvm" | NoFault -> "NoFault" | Neon -> "Neon" | SVE -> "sve" | SME -> "sme" | ConstrainedUnpredictable -> "ConstrainedUnpredictable" let is_mixed v = v Mixed || v FullMixed let is_kvm v = v KVM || v FullKVM herd-herdtools7-1ca343e/gen/variant_gen.mli000066400000000000000000000043431475314470400207170ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2018-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) type t = (* RISCV: tagged accesses as amo's with x0 as arg (load) or result (store) *) | AsAmo | ConstsInInit (* Mixed size -> diy specific *) | Mixed (* Lift the default restriction of mixed-size annotation to depth one *) | FullMixed (* Allow non-overlapping mixed accesses *) | MixedDisjoint (* Require strict overlap *) | MixedStrictOverlap (* Self-modifying code *) | Self (* MTE = Memory tagging *) | MemTag (* C: Prevents the use of Volatile to capture bugs in compilation *) | NoVolatile (* Morello C64 instruction set *) | Morello (* Explicit virtual memory *) | KVM | FullKVM (* Do not observe faults, in KVM mode *) | NoFault (* Neon AArch64 extension *) | Neon (* SVE AArch64 extension *) | SVE (* SME AArch64 extension *) | SME (* Constrained Unpredictable, ie generate tests thar may exhibit such behaviours. Typically LDXR / STXR of different size or address. *) | ConstrainedUnpredictable val tags : string list val parse : string -> t option val pp : t -> string val is_mixed : (t -> bool) -> bool val is_kvm : (t -> bool) -> bool herd-herdtools7-1ca343e/herd/000077500000000000000000000000001475314470400160645ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/AArch64ASLParseTest.ml000066400000000000000000000051041475314470400217410ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make(Conf:RunTest.Config)(ModelConfig:MemCat.Config) = struct let is_morello = Conf.variant Variant.Morello module LexConfig = struct let debug = Conf.debug.Debug_herd.lexer let is_morello = is_morello end module ArchConfig = SemExtra.ConfigToArchConfig(Conf) module AArch64ASLValue = AArch64ASLValue.Make (struct let is_morello = is_morello end) module AArch64ASLArch = AArch64Arch_herd.Make(ArchConfig)(AArch64ASLValue) module AArch64ASLLexParse = struct type instruction = AArch64ASLArch.parsedPseudo type token = AArch64Parser.token module Lexer = AArch64Lexer.Make(LexConfig) let lexer = Lexer.token let parser = AArch64Parser.main end let run dirty start_time name chan env splitted = let module SemConf = struct module C = Conf let dirty = ModelConfig.dirty let procs_user = ProcsUser.get splitted.Splitter.info let sve_vector_length = Conf.sve_vector_length let sme_vector_length = Conf.sme_vector_length end in let module AArch64ASLS = AArch64ASLSem.Make(SemConf)(AArch64ASLValue) in let module AArch64ASLM = MemCat.Make(ModelConfig)(AArch64ASLS) in let module P = GenParser.Make (Conf) (AArch64ASLArch) (AArch64ASLLexParse) in let module X = RunTest.Make (AArch64ASLS) (P) (AArch64ASLM) (Conf) in X.run dirty start_time name chan env splitted end herd-herdtools7-1ca343e/herd/AArch64ASLSem.ml000066400000000000000000001321031475314470400205530ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Authors: *) (* Hadrien Renaud, University College London, UK. *) (****************************************************************************) let aarch64_iico_ctrl = "aarch64_iico_ctrl" let aarch64_iico_data = "aarch64_iico_data" let aarch64_iico_order = "aarch64_iico_order" let return_0 = let open Asllib.AST in let open Asllib.ASTUtils in add_dummy_annotation (S_Return (Some (expr_of_int 0))) let end_profile t0 msg : unit = let t1 = Sys.time () in if t1 -. t0 > 1. (* We log only executions that took more than 1 second *) then Printf.eprintf "AArch64+ASL sem took %fs to evaluate %s.\n%!" (t1 -. t0) msg module Make (TopConf : AArch64Sig.Config) (V : Value.AArch64ASL) : AArch64Sig.Semantics with module A.V = V = struct module AArch64S = AArch64Sem.Make (TopConf) (V) include AArch64S let ( ||| ) = M.( ||| ) let ( let* ) = M.( >>= ) let return = M.unitT let _dbg = TopConf.C.debug.Debug_herd.monad let _profile = TopConf.C.debug.Debug_herd.profile_asl let start_profile = if _profile then Sys.time else Fun.const 0. let end_profile = if _profile then end_profile else fun _ _ -> () let profile msg f = if _profile then let t0 = start_profile () in let res = f () in let () = end_profile t0 msg in res else f () module Mixed (SZ : ByteSize.S) : sig val build_semantics : test -> A.inst_instance_id -> (proc * branch) M.t val spurious_setaf : V.v -> unit M.t end = struct module AArch64Mixed = AArch64S.Mixed (SZ) let aarch64_iico = StringSet.of_list [ aarch64_iico_ctrl; aarch64_iico_data; aarch64_iico_order ] module ASLConf = struct include TopConf.C module PC = struct include TopConf.C.PC let doshow = aarch64_iico let showevents = PrettyConf.AllEvents let showpo = true let showraw = aarch64_iico end let variant = function Variant.ASL_AArch64 -> true | c -> variant c end module ASLS = ASLSem.Make (ASLConf) module ASLE = ASLS.E module EMap = ASLE.EventMap module ESet = ASLE.EventSet module ASLVC = ASLS.M.VC module ASLTH = Test_herd.Make (ASLS.A) module MCConf = struct include ASLConf let byte = SZ.byte let dirty = TopConf.dirty let initwrites = false end module MC = Mem.Make (MCConf) (ASLS) module MU = MemUtils.Make (ASLS) type asl_exec = ASLS.concrete * ASLVC.cnstrnts * ASLS.set_pp * ASLS.rel_pp let tr_cond = let open AArch64Base in (* Cf ARM Architecture Reference Manual, section C1.2.4, table C1-1 *) function | EQ -> 0b0000 | NE -> 0b0001 | CS -> 0b0010 | CC -> 0b0011 | MI -> 0b0100 | PL -> 0b0101 | VS -> 0b0110 | VC -> 0b0111 | HI -> 0b1000 | LS -> 0b1001 | GE -> 0b1010 | LT -> 0b1011 | GT -> 0b1100 | LE -> 0b1101 | AL -> 0b1111 (* Also possible [0b1110] *) let barrier_domain = let open AArch64Base in function | NSH -> "MBReqDomain_Nonshareable" | ISH -> "MBReqDomain_InnerShareable" | OSH -> "MBReqDomain_OuterShareable" | SY -> "MBReqDomain_FullSystem" and barrier_typ = let open AArch64Base in function | LD -> "MBReqTypes_Reads" | ST -> "MBReqTypes_Writes" | FULL -> "MBReqTypes_All" let unalias ii = let i0 = ii.A.inst in let i = AArch64Base.unalias i0 in if i == i0 then ii else { ii with A.inst = i } let opext_decode_shift = let open AArch64Base.OpExt in function | LSL _ -> "ShiftType_LSL" | LSR _ -> "ShiftType_LSR" | ASR _ -> "ShiftType_ASR" | ROR _ -> "ShiftType_ROR" let memext_decode_ext = let open AArch64Base.MemExt in function | UXTW -> "ExtendType_UXTW" | SXTW -> "ExtendType_SXTW" | SXTX -> "ExtendType_SXTX" | LSL -> "ExtendType_UXTX" let opext_shift_amount = let open AArch64Base.OpExt in function LSL k | LSR k | ASR k | ROR k -> k let decode_acquire = let open AArch64 in function RMW_P | RMW_L -> false | RMW_A | RMW_AL -> true and decode_release = let open AArch64 in function RMW_P | RMW_A -> false | RMW_L | RMW_AL -> true let decode_inst ii = let ii = unalias ii in let open Asllib.AST in let with_pos desc = Asllib.ASTUtils.add_dummy_annotation ~version:V0 desc in let ( ^= ) x e = S_Decl (LDK_Let, LDI_Var x, None, Some e) |> with_pos in let ( ^^= ) x e = let le_x = LE_Var x |> with_pos in S_Assign (le_x, e) |> with_pos in let lit v = E_Literal v |> with_pos in let liti i = lit (L_Int (Z.of_int i)) in let litb b = lit (L_Bool b) in let litbv v i = lit (L_BitVector (Asllib.Bitvector.of_int_sized v i)) in let var x = E_Var x |> with_pos in let variant v = AArch64Base.variant_raw v |> liti in let cond c = tr_cond c |> liti in let stmt = Asllib.ASTUtils.stmt_from_list in let open AArch64Base in let reg = function (* To use with caution, sometimes it doesn't work. *) | Ireg r -> ASLBase.arch_reg_to_int r |> liti | ZR -> liti 31 | SP -> liti 31 | NZCV -> Warn.fatal "NZCV is not an addressable register" | r -> Warn.fatal "Unsupported register: %s." (pp_reg r) in match ii.A.inst with | I_NOP -> let added = (* ASL implementation is "return;" that our interpreter rejects, expecting integer return... *) ASLBase.stmts_from_string "return 0;" in Some ("system/hints/NOP_HI_hints.opn",stmt [added;]) | I_B lab -> let off = tgt2offset ii lab in Some ("branch/unconditional/immediate/B_only_branch_imm.opn", stmt [ "offset" ^= litbv 64 off; "_PC" ^^= litbv 64 ii.A.addr; ]) | I_CBZ (v,rt,lab) | I_CBNZ (v,rt,lab) as i -> let off = tgt2offset ii lab in let file = match i with | I_CBZ _ -> "CBZ_32_compbranch.opn" | I_CBNZ _ -> "CBNZ_32_compbranch.opn" | _ -> assert false in Some ("branch/conditional/compare/" ^ file, stmt [ "t" ^= reg rt; "datasize" ^= variant v; "offset" ^= litbv 64 off; "_PC" ^^= litbv 64 ii.A.addr; ]) | I_BC (c,lab) -> let off = tgt2offset ii lab in Some ("branch/conditional/cond/B_only_condbranch.opn", stmt [ "offset" ^= litbv 64 off; "cond" ^= cond c; "_PC" ^^= litbv 64 ii.A.addr; ]) | I_SWP (v, t, rs, rt, rn) -> Some ( "memory/atomicops/swp/SWP_32_memop.opn", stmt [ "s" ^= reg rs; "t" ^= reg rt; "n" ^= reg rn; "datasize" ^= variant v; "regsize" ^= liti 64; "acquire" ^= litb (decode_acquire t && rt <> ZR); "release" ^= litb (decode_release t); "tagchecked" ^= litb (rn <> SP); ] ) | I_CAS (v, t, rs, rt, rn) -> Some ( "memory/atomicops/cas/single/CAS_C32_comswap.opn", stmt [ "s" ^= reg rs; "t" ^= reg rt; "n" ^= reg rn; "datasize" ^= variant v; "regsize" ^= variant v; "acquire" ^= litb (decode_acquire t); "release" ^= litb (decode_release t); "tagchecked" ^= litb (rn <> SP); ] ) | I_LDOP (op,v,rmw,rs,rt,rn) -> let fname = Printf.sprintf "memory/atomicops/ld/LD%s_32_memop.opn" (pp_aop op) in Some (fname, stmt [ "s" ^= reg rs; "t" ^= reg rt; "n" ^= reg rn; "datasize" ^= variant v; "regsize" ^= variant v; "acquire" ^= litb (decode_acquire rmw && rt <> ZR); "release" ^= litb (decode_release rmw); "tagchecked" ^= litb (rn <> SP); ]) | I_CSEL (v, rd, rn, rm, c, opsel) -> let fname = match opsel with | Cpy -> "CSEL_32_condsel.opn" | Inc -> "CSINC_32_condsel.opn" | Inv -> "CSINV_32_condsel.opn" | Neg -> "CSNEG_32_condsel.opn" in Some ( "integer/conditional/select/" ^ fname, stmt [ "d" ^= reg rd; "n" ^= reg rn; "m" ^= reg rm; "datasize" ^= variant v; "cond" ^= cond c; ] ) | ( I_MOVZ (v, rd, k, ((S_NOEXT | S_LSL (0 | 16 | 32 | 48)) as s)) | I_MOVN (v, rd, k, ((S_NOEXT | S_LSL (0 | 16 | 32 | 48)) as s)) ) as i -> let datasize = variant_raw v in let pos = match s with S_NOEXT -> 0 | S_LSL s -> s | _ -> assert false in let fname = match i with | I_MOVZ _ -> "MOVZ_32_movewide.opn" | I_MOVN _ -> "MOVN_32_movewide.opn" | _ -> assert false in Some ( "integer/ins-ext/insert/movewide/" ^ fname, stmt [ "d" ^= reg rd; "imm16" ^= litbv 16 k; "datasize" ^= liti datasize; "pos" ^= liti pos; ] ) | I_ABS (v, rd, rn) -> let datasize = variant_raw v in Some ( "integer/arithmetic/unary/abs/ABS_32_dp_1src.opn", stmt [ "d" ^= reg rd; "n" ^= reg rn; "datasize" ^= liti datasize ] ) | I_RBIT (v, rd, rn) -> let datasize = variant_raw v in Some ( "integer/arithmetic/rbit/RBIT_32_dp_1src.opn", stmt [ "d" ^= reg rd; "n" ^= reg rn; "datasize" ^= liti datasize ] ) (* * Does not work, because instruction code uses the Elem * setter `Elem[..] = ...`. This setter relies on passing argument * by reference. *) (* | I_REV (rv,rd,rn) -> let datasize = variant_of_rev rv |> variant_raw in let csz = container_size rv |> MachSize.nbits in Printf.eprintf "REV: sz=%i, csz=%i\n%!" datasize csz ; let fname = match rv with | RV16 _ -> "REV16_32_dp_1src.opn" | RV32 -> "REV32_64_dp_1src.opn" | RV64 _ -> "REV_32_dp_1src.opn" in Some ("/integer/arithmetic/rev/" ^ fname, stmt [ "d" ^= reg rd; "n" ^= reg rn; "datasize" ^= liti datasize; "container_size" ^= liti csz; ]) *) | I_EXTR (v,rd,rn,rm,imms) -> Some ("integer/ins-ext/extract/immediate/EXTR_32_extract.opn", stmt [ "d" ^= reg rd; "n" ^= reg rn; "m" ^= reg rm; "datasize" ^= variant v; "lsb" ^= liti imms;]) | I_UBFM (v, rd, rn, immr, imms) | I_SBFM (v, rd, rn, immr, imms) -> let datasize = variant_raw v in let bitvariant = let open AArch64Base in match v with V64 -> 1 | V32 -> 0 | V128 -> assert false in let extend = match ii.A.inst with | I_SBFM _ -> true | I_UBFM _ -> false | _ -> assert false in let added = ASLBase.stmts_from_string "let r = UInt(immr);\n\ let s = UInt(imms);\n\ var wmask : bits(datasize);\n\ var tmask : bits(datasize) ;\n\ (wmask,tmask) = DecodeBitMasks{datasize}(N, imms, immr, FALSE, datasize);" in let fname = if extend then "integer/bitfield/SBFM_32M_bitfield.opn" else "integer/bitfield/UBFM_32M_bitfield.opn" in Some ( fname, stmt ([ "d" ^= reg rd; "n" ^= reg rn; "immr" ^= litbv 6 immr; "imms" ^= litbv 6 imms; "N" ^= litbv 1 bitvariant; "datasize" ^= liti datasize; "inzero" ^= litb true; ] @ [ added ]) ) | I_ADDSUBEXT (v, Ext.((ADD | ADDS | SUB | SUBS) as op), rd, rn, (_vm, rm), (e, ko)) -> let datasize = variant_raw v in let fname = let open Ext in match op with | ADD -> "ADD_32_addsub_ext.opn" | ADDS -> "ADDS_32_addsub_ext.opn" | SUB -> "SUB_32_addsub_ext.opn" | SUBS -> "SUBS_32_addsub_ext.opn" in let base = "integer/arithmetic/add-sub/extendedreg/" in let extend_type = let open Ext in match e with | UXTB -> "ExtendType_UXTB" | UXTH -> "ExtendType_UXTH" | UXTW -> "ExtendType_UXTW" | UXTX -> "ExtendType_UXTX" | SXTB -> "ExtendType_SXTB" | SXTH -> "ExtendType_SXTH" | SXTW -> "ExtendType_SXTW" | SXTX -> "ExtendType_SXTX" in let shift = match ko with None -> 0 | Some k -> k in Some ( base ^ fname, stmt [ "d" ^= reg rd; "n" ^= reg rn; "m" ^= reg rm; "datasize" ^= liti datasize; "extend_type" ^= var extend_type; "shift" ^= liti shift; ] ) | I_MOPL (sop, rd, rn, rm, ra) -> let fname = let open MOPLExt in match sop with | Signed, ADD -> "SMADDL_64WA_dp_3src.opn" | Signed, SUB -> "SMSUBL_64WA_dp_3src.opn" | Unsigned, ADD -> "UMADDL_64WA_dp_3src.opn" | Unsigned, SUB -> "UMSUBL_64WA_dp_3src.opn" in Some ( "integer/arithmetic/mul/widening/32-64/" ^ fname, stmt [ "d" ^= reg rd; "n" ^= reg rn; "m" ^= reg rm; "a" ^= reg ra; ] ) | I_MOP (op,v,rd,rn,rm,ra) -> let fname = let open MOPExt in match op with | ADD -> "MADD_32A_dp_3src.opn" | SUB -> "MSUB_32A_dp_3src.opn" in Some ( "integer/arithmetic/mul/uniform/add-sub/" ^ fname, stmt ["destsize" ^= variant v; "d" ^= reg rd; "n" ^= reg rn; "m" ^= reg rm; "a" ^= reg ra; ]) | I_OP3 ( v, (( ADD | ADDS | SUB | SUBS | AND | ANDS | BIC | BICS | EOR | EON | ORN | ORR ) as op), rd, rn, OpExt.Reg (rm, s) ) -> let base = match op with | ADD | ADDS | SUB | SUBS -> "integer/arithmetic/add-sub/shiftedreg/" | AND | ANDS | BIC | BICS | EOR | EON | ORN | ORR -> "integer/logical/shiftedreg/" | _ -> assert false and fname = match op with | ADD -> "ADD_32_addsub_shift.opn" | ADDS -> "ADDS_32_addsub_shift.opn" | SUB -> "SUB_32_addsub_shift.opn" | SUBS -> "SUBS_32_addsub_shift.opn" | AND -> "AND_32_log_shift.opn" | ANDS -> "ANDS_32_log_shift.opn" | BIC -> "BIC_32_log_shift.opn" | BICS -> "BICS_32_log_shift.opn" | EOR -> "EOR_32_log_shift.opn" | EON -> "EON_32_log_shift.opn" | ORR -> "ORR_32_log_shift.opn" | ORN -> "ORN_32_log_shift.opn" | _ -> assert false in Some ( base ^ fname, stmt [ "d" ^= reg rd; "n" ^= reg rn; "m" ^= reg rm; "datasize" ^= variant v; "shift_type" ^= var (opext_decode_shift s); "shift_amount" ^= liti (opext_shift_amount s); ] ) | I_OP3 (v, ((ADD | ADDS | SUB | SUBS) as op), rd, rn, OpExt.Imm (k, s)) -> let datasize = variant_raw v in let k = k lsl s in let fname = match op with | ADD -> "ADD_32_addsub_imm.opn" | ADDS -> "ADDS_32S_addsub_imm.opn" | SUB -> "SUB_32_addsub_imm.opn" | SUBS -> "SUBS_32S_addsub_imm.opn" | _ -> assert false in Some ( "integer/arithmetic/add-sub/immediate/" ^ fname, stmt [ "d" ^= reg rd; "n" ^= reg rn; "imm" ^= litbv datasize k; "datasize" ^= liti datasize; ] ) | I_OP3 (v, ((AND | ANDS | EOR | ORR) as op), rd, rn, OpExt.Imm (k, 0)) -> let datasize = variant_raw v in let fname = match op with | AND -> "AND_32_log_imm.opn" | ANDS -> "ANDS_32S_log_imm.opn" | EOR -> "EOR_32_log_imm.opn" | ORR -> "ORR_32_log_imm.opn" | _ -> assert false in Some ( "integer/logical/immediate/" ^ fname, stmt [ "d" ^= reg rd; "n" ^= reg rn; "imm" ^= litbv datasize k; "datasize" ^= liti datasize; ] ) | I_OP3 (v,(ASR|LSL|LSR|ROR as op), rd,rn,OpExt.Reg (rm, s)) when OpExt.is_no_shift s -> let shift_type,fname = match op with | ASR -> "ShiftType_ASR","ASRV_32_dp_2src.opn" | LSL -> "ShiftType_LSL","LSLV_32_dp_2src.opn" | LSR -> "ShiftType_LSR","LSRV_32_dp_2src.opn" | ROR -> "ShiftType_ROR","RORV_32_dp_2src.opn" | _ -> assert false in Some ("integer/shift/variable/" ^ fname, stmt [ "d" ^= reg rd; "n" ^= reg rn; "m" ^= reg rm; "datasize" ^= variant v; "shift_type" ^= var shift_type;]) | ( I_STR (v, rt, rn, MemExt.Reg (_vm, rm, e, s)) | I_LDR (v, rt, rn, MemExt.Reg (_vm, rm, e, s)) ) as i -> let fname = match i with | I_STR _ -> "STR_32_ldst_regoff.opn" | I_LDR _ -> "LDR_32_ldst_regoff.opn" | _ -> assert false and extend_type = memext_decode_ext e in Some ( "memory/single/general/register/" ^ fname, stmt [ "t" ^= reg rt; "n" ^= reg rn; "m" ^= reg rm; "extend_type" ^= var extend_type; "shift" ^= liti s; "datasize" ^= variant v; "regsize" ^= variant v; ] ) | I_LDRSW (rt, rn, MemExt.Reg (_vm, rm, e, s)) -> let extend_type = memext_decode_ext e in Some ( "memory/single/general/register/LDRSW_64_ldst_regoff.opn", stmt [ "t" ^= reg rt; "n" ^= reg rn; "m" ^= reg rm; "extend_type" ^= var extend_type; "shift" ^= liti s; ] ) | I_STR (v, rt, rn, MemExt.Imm (k, idx)) | I_LDR (v, rt, rn, MemExt.Imm (k, idx)) -> let memop, fname = match ii.A.inst with | I_STR _ -> ("MemOp_STORE", "STR_32_ldst_immpost.opn") | I_LDR _ -> ("MemOp_LOAD", "LDR_32_ldst_immpost.opn") | _ -> assert false in let wback, postindex = match idx with | Idx -> (false, false) | PreIdx -> (true, false) | PostIdx -> (true, true) in Some ( "memory/single/general/immediate/signed/post-idx/" ^ fname, stmt [ "t" ^= reg rt; "n" ^= reg rn; "offset" ^= litbv 64 k; "wback" ^= litb wback; "postindex" ^= litb postindex; "signed" ^= litb false; "nontemporal" ^= litb false; "memop" ^= var memop; "tagchecked" ^= litb (wback || rn <> SP); "datasize" ^= variant v; "regsize" ^= variant v; "rt_unknown" ^= litb false; "wb_unknown" ^= litb false; ] ) | I_LDRSW (rt, rn, MemExt.Imm (k, idx)) -> let wback, postindex = match idx with | Idx -> (false, false) | PreIdx -> (true, false) | PostIdx -> (true, true) in Some ( "memory/single/general/immediate/signed/post-idx/LDRSW_64_ldst_immpost.opn", stmt [ "t" ^= reg rt; "n" ^= reg rn; "offset" ^= litbv 64 k; "wback" ^= litb wback; "postindex" ^= litb postindex; "tagchecked" ^= litb (wback || rn <> SP); "wb_unknown" ^= litb false; ] ) | I_STLR (v, rt, rn) -> Some ( "memory/ordered/STLR_SL32_ldstord.opn", stmt [ "t" ^= reg rt; "n" ^= reg rn; "wback" ^= litb false; "rt_unknown" ^= litb false; "tagchecked" ^= litb (rn <> SP); "offset" ^= liti 0; "datasize" ^= variant v; ] ) | I_LDAR (v, AA, rt, rn) -> Some ( "memory/ordered/LDAR_LR32_ldstord.opn", stmt [ "t" ^= reg rt; "n" ^= reg rn; "tagchecked" ^= litb (rn <> SP); "regsize" ^= variant v; "elsize" ^= variant v; ] ) | I_LDAR (v, ((XX | AX) as a), rt, rn) -> let fname = match a with | XX -> "LDXR_LR32_ldstexclr.opn" | AX -> "LDAXR_LR32_ldstexclr.opn" | _ -> assert false in Some ( "memory/exclusive/single/" ^ fname, stmt [ "t" ^= reg rt; "n" ^= reg rn; "tagchecked" ^= litb (rn <> SP); "regsize" ^= variant v; "elsize" ^= variant v; ] ) | I_LDAR (v, AQ, rt, rn) -> Some ( "memory/ordered-rcpc/LDAPR_32L_memop.opn", stmt [ "t" ^= reg rt; "n" ^= reg rn; "wback" ^= litb false; "offset" ^= liti 0; "wb_unknown" ^= litb false; "tagchecked" ^= litb (rn <> SP); "regsize" ^= variant v; "elsize" ^= variant v; "datasize" ^= variant v; ] ) | I_STXR (v, t, rs, rt, rn) -> let fname = match t with | YY -> "STXR_SR32_ldstexclr.opn" | LY -> "STLXR_SR32_ldstexclr.opn" in Some ( "memory/exclusive/single/" ^ fname, stmt [ "n" ^= reg rn; "t" ^= reg rt; "s" ^= reg rs; "elsize" ^= variant v; "tagchecked" ^= litb (rn <> SP); "rt_unknown" ^= litb false; "rn_unknown" ^= litb false; ] ) | I_FENCE ISB -> Some ("system/barriers/isb/ISB_BI_barriers.opn", stmt []) | I_FENCE (DMB (dom, btyp)) -> Some ( "system/barriers/dmb/DMB_BO_barriers.opn", stmt [ "domain" ^= var (barrier_domain dom); "types" ^= var (barrier_typ btyp); ] ) | I_FENCE (DSB (dom, btyp)) -> Some ( "system/barriers/dsb/DSB_BO_barriers.opn", stmt [ "nXS" ^= litb false; "alias" ^= var "DSBAlias_DSB"; "domain" ^= var (barrier_domain dom); "types" ^= var (barrier_typ btyp); ] ) | I_UDF k when C.variant Variant.ASL_AArch64_UDF -> Some ("udf/UDF_only_perm_undef.opn", stmt [ "imm16" ^= litbv 16 k ]) | i -> let () = if _dbg then Printf.eprintf "Unsupported now: %s\nFalling back on regular semantics.\n" (A.pp_instruction PPMode.Ascii i) in None let tr_cst tr = Constant.map tr (fun _ -> Warn.fatal "Cannot translate PTE") (fun _ -> Warn.fatal "Cannot translate instruction") let aarch64_to_asl_bv = function | V.Var v -> ASLS.A.V.Var v | V.Val cst -> ASLS.A.V.Val (tr_cst ASLScalar.as_bv cst) let aarch64_to_asl = function | V.Var v -> ASLS.A.V.Var v | V.Val cst -> ASLS.A.V.Val (tr_cst Misc.identity cst) let asl_to_aarch64 = function | ASLS.A.V.Var v -> V.Var v | ASLS.A.V.Val cst -> V.Val (tr_cst Misc.identity cst) let is_experimental = TopConf.C.variant Variant.ASLExperimental let not_cutoff = not (TopConf.C.variant Variant.CutOff) let fake_test ii fname decode = profile "build fake test" @@ fun () -> let init = [] in let prog = let version = if TopConf.C.variant (Variant.ASLVersion `ASLv0) then `ASLv0 else if TopConf.C.variant (Variant.ASLVersion `ASLv1) then `ASLv1 else `Any in let () = if _dbg then Format.eprintf "Trying with ASL parser for version %a.@." Asllib.PP.pp_version version in let main = let execute = Filename.concat "asl-pseudocode/aarch64/instrs" fname |> TopConf.C.libfind |> ASLBase.build_ast_from_file ~ast_type:`Opn version in let open Asllib.AST in let open Asllib.ASTUtils in match execute with | [ ({ desc = D_Func ({ body = SB_ASL s; _ } as f); _ } as d) ] -> let s = stmt_from_list [ decode; s; return_0 ] in D_Func { f with body = SB_ASL s } |> add_pos_from_st d | _ -> assert false in let () = if _dbg then Format.eprintf "@[Executing main:@ %a@]@." Asllib.PP.pp_t [ main ] in [ ((ii.A.proc, None, MiscParser.Main), [ ASLBase.Instruction [ main ] ]) ] in let t = { MiscParser.init; prog; info = []; filter = None; condition = ConstrGen.ExistsState (ConstrGen.And []); locations = []; extra_data = MiscParser.empty_extra; } in let name = Name.{ name = "ASL (fake)"; file = ""; texname = ""; doc = "" } in let test = ASLTH.build name t in let init = let global_loc name = ASLS.A.Location_reg (ii.A.proc, ASLBase.(ASLLocalId (Scope.Global true, name))) in let st = List.fold_left (fun st reg -> match A.look_reg reg ii.A.env.A.regs with | Some v -> ASLS.A.state_add st (ASLS.A.Location_reg (ii.A.proc, ASLBase.ArchReg reg)) (aarch64_to_asl v) | _ -> st) ASLS.A.state_empty ASLBase.gregs in let nzcv = AArch64Base.NZCV and _nzcv = global_loc (if is_experimental then "_NZCV" else "PSTATE") in let st = match A.look_reg nzcv ii.A.env.A.regs with | Some v -> let v = aarch64_to_asl_bv v in ASLS.A.state_add st _nzcv v | _ -> st in let regq = AArch64Base.ResAddr and resaddr = global_loc "RESADDR" in let v = match A.look_reg regq ii.A.env.A.regs with | Some v -> Some (aarch64_to_asl v) | None -> None in match v with Some v -> ASLS.A.state_add st resaddr v | None -> st in let test = { test with Test_herd.init_state = init } in let () = if _dbg then Printf.eprintf "Building fake test with initial state:\n\t%s\n" (ASLS.A.dump_state test.Test_herd.init_state) in test module Translator : sig val tr_execution : AArch64.inst_instance_id -> asl_exec -> (proc * branch) M.t end = struct module IMap = Map.Make (Int) let tr_v v = asl_to_aarch64 v let tr_loc ii loc = let nloc = match loc with | ASLS.A.Location_global x -> Some (A.Location_global (tr_v x)) | ASLS.A.Location_reg (_proc, ASLBase.ArchReg reg) -> Some (A.Location_reg (ii.A.proc, reg)) | ASLS.A.Location_reg (_proc, ASLBase.ASLLocalId _) -> None in let () = if _dbg then Printf.eprintf "tr_loc %s ->%s\n%!" (ASLS.A.pp_location loc) (match nloc with | None -> "" | Some loc -> " " ^ A.pp_location loc) in nloc let tr_op op acc v1 v2 = (M.VC.Binop (op, tr_v v1, tr_v v2), acc) let tr_arch_op1 op acc v = (M.VC.Unop (Op.ArchOp1 (AArch64Op.Extra op), tr_v v), acc) let tr_op1 = let open Op in function | ArchOp1 op -> tr_arch_op1 op | op -> let new_op = match op with | Not -> Not | SetBit i -> SetBit i | UnSetBit i -> UnSetBit i | ReadBit i -> ReadBit i | LeftShift i -> LeftShift i | LogicalRightShift i -> LogicalRightShift i | ArithRightShift i -> ArithRightShift i | AddK i -> AddK i | AndK i -> AndK i | Inv -> Inv | Abs -> Abs | Mask sz -> Mask sz | Sxt sz -> Sxt sz | Rbit sz -> Rbit sz | RevBytes (csz, sz) -> RevBytes (csz, sz) | TagLoc -> TagLoc | CapaTagLoc -> CapaTagLoc | TagExtract -> TagExtract | LocExtract -> LocExtract | UnSetXBits (nbBits, from) -> UnSetXBits (nbBits, from) | CapaGetTag -> CapaGetTag | CheckSealed -> CheckSealed | CapaStrip -> CapaStrip | TLBLoc -> TLBLoc | PTELoc -> PTELoc | Offset -> Offset | IsVirtual -> IsVirtual | IsInstr -> IsInstr | Promote -> Promote | Demote -> Demote | ArchOp1 _ -> assert false in fun acc v -> (M.VC.Unop (new_op, tr_v v), acc) let tr_action is_bcc e ii = let exp = AArch64.Exp in function | ASLS.Act.Access (dir, loc, v, sz, a) -> ( match tr_loc ii loc with | None -> None | Some loc -> let ac = Act.access_of_location_std loc in Some (Act.Access (dir, loc, tr_v v, a, exp, sz, ac))) | ASLS.Act.Barrier b -> Some (Act.Barrier b) | ASLS.Act.Branching txt -> let ct = if is_bcc e then Act.Bcc else Act.Pred in Some (Act.Commit (ct,txt)) | ASLS.Act.NoAction -> (* As long as aarch64.cat ignores "NoAction" effects *) None | ASLS.Act.CutOff msg -> Some (Act.CutOff msg) let tr_expr acc = function | ASLVC.Atom a -> (M.VC.Atom (tr_v a), acc) | ASLVC.ReadInit _ -> assert false | ASLVC.Unop (op, v) -> tr_op1 op acc v | ASLVC.Binop (op, v1, v2) -> tr_op op acc v1 v2 | ASLVC.Terop (op, a1, a2, a3) -> (M.VC.Terop (op, tr_v a1, tr_v a2, tr_v a3), acc) let tr_cnstrnt acc = function | ASLVC.Warn s -> M.VC.Warn s :: acc | ASLVC.Failed e -> M.VC.Failed e :: acc | ASLVC.Assign (la, ex) -> let expr, acc = tr_expr acc ex in M.VC.Assign (tr_v la, expr) :: acc let tr_cnstrnts cs = List.fold_left tr_cnstrnt [] cs let event_to_monad ii is_bcc is_data event = let { ASLE.action; ASLE.iiid; _ } = event in let () = if _dbg then Printf.eprintf "%s:%s%s" (ASLE.pp_eiid event) (ASLE.Act.pp_action action) (if is_data event then "(data)" else "") in match (iiid, tr_action is_bcc event ii action) with | ASLE.IdInit, _ | _, None -> let () = if _dbg then Printf.eprintf ", " in None | _, Some action' -> let () = if _dbg then Printf.eprintf "(=%s), " (Act.pp_action action') in let m = M.mk_singleton_es action' ii |> (if is_data event then M.as_data_port else Fun.id) |> M.force_once in Some (event, m) let rel_to_monad event_to_monad_map comb rel = let one_pair (e1, e2) = let () = if _dbg then Printf.eprintf "%s->%s, " (ASLE.pp_eiid e1) (ASLE.pp_eiid e2) in match ( EMap.find_opt e1 event_to_monad_map, EMap.find_opt e2 event_to_monad_map ) with | Some m1, Some m2 -> comb m1 (fun () -> m2) | _ -> M.unitT () in let monads = Seq.map one_pair (ASLE.EventRel.to_seq rel) in Seq.fold_left ( ||| ) (return ()) monads let tr_execution ii (conc, cs, set_pp, vbpp) = profile "translate execution" @@ fun () -> let get_cat_show get x = match StringMap.find_opt x set_pp with | Some e -> get e | None -> get ESet.empty in let () = if _dbg then Printf.eprintf "Translating event structure:\n" in let () = if _dbg then ( Printf.eprintf "\t-all events:\n"; ESet.iter (fun e -> Printf.eprintf "\t\t- %s:%s\n" (ASLE.pp_eiid e) (ASLE.Act.pp_action e.ASLE.action)) conc.ASLS.str.ASLE.events) in let events = get_cat_show ESet.to_seq "AArch64" in let is_data = let data_set = get_cat_show Misc.identity "AArch64_DATA" in fun e -> ESet.mem e data_set in let is_bcc = let bcc = get_cat_show Misc.identity "AArch64_BCC" in fun e -> ASLE.EventSet.mem e bcc in let () = if _dbg then Printf.eprintf "\t- events: " in let event_list = List.of_seq events in let event_to_monad_map = Seq.filter_map (event_to_monad ii is_bcc is_data) events |> EMap.of_seq in let events_m = let folder _e1 m1 acc = m1 ||| acc in EMap.fold folder event_to_monad_map (return ()) in let () = if _dbg then Printf.eprintf "\n" in let translate_maybe_rel comb name = match List.assoc_opt name vbpp with | Some rel -> let () = if _dbg then Printf.eprintf "\t- %s: " name in let res = rel_to_monad event_to_monad_map comb rel in let () = if _dbg then Printf.eprintf "\n" in res | None -> return () in let iico_data = translate_maybe_rel M.( >>= ) aarch64_iico_data in let iico_ctrl = translate_maybe_rel M.( >>*= ) aarch64_iico_ctrl in let iico_order = translate_maybe_rel M.bind_order aarch64_iico_order in let branch = let one_event bds event = match event.ASLE.action with | ASLS.Act.Access (Dir.W, ASLS.A.Location_reg (_, ASLBase.ArchReg reg), v, _, _) -> let v = tr_v v in let () = if _dbg then Printf.eprintf "Recording %s <- %s\n%!" (AArch64Base.pp_reg reg) (A.V.pp_v v) in (reg,v)::bds | ASLS.Act.Access (Dir.W, loc , v, _, _) -> if _dbg then Printf.eprintf "Not recorded in B.Next: %s <- %s\n" (ASLS.A.pp_location loc) (ASLS.A.V.pp_v v) ; bds | _ -> bds in let bds = List.fold_left one_event [] event_list in let finals = get_cat_show Misc.identity "AArch64Finals" in let pc = let n_pc = (* Count writes to PC *) List.fold_left (fun c (r,_) -> match r with | AArch64Base.PC -> c+1 | _ -> c) 0 bds in (* Branching instructions all generate one, initial, * PC assignement and a second PC assignement * that gives the branch target. This applies even * for non-taken conditional branches where * the second assignment is to the next instruction. * This second write event is the final write to PC. * Non-branching instructions neither read nor * write the PC, cf. case [None] below. *) if n_pc <= 1 then None else ESet.fold (fun e r -> match e.ASLE.action with | ASLS.Act.Access (Dir.W, ASLS.A.Location_reg (_, ASLBase.ArchReg AArch64Base.PC), v, _, _) -> Some (tr_v v) | _ -> r) finals None in match Misc.seq_opt A.V.as_int pc with | Some v -> B.Jump (B.Addr v,bds) | None -> B.Next bds in let () = if _dbg then match branch with | B.Next bds -> let pp = List.map (fun (r, v) -> Printf.sprintf "(%s,%s)" (AArch64Base.pp_reg r) (AArch64.V.pp_v v)) bds in let pp = String.concat "; " pp in Printf.eprintf "Next [%s]\n%!" pp | _ -> () in let constraints = let () = if _dbg then Printf.eprintf "\t- constraints:\n%s\n" (ASLVC.pp_cnstrnts cs) in M.restrict (tr_cnstrnts cs) in let () = if _dbg then Printf.eprintf "\n" in let* () = events_m ||| iico_data ||| iico_ctrl ||| iico_order ||| constraints in M.addT (A.next_po_index ii.A.program_order_index) (return branch) end let check_event_structure model = let module MemConfig = struct include ASLConf let model = model let bell_model_info = None let debug = ASLConf.debug.Debug_herd.barrier let debug_files = ASLConf.debug.Debug_herd.files let profile = ASLConf.debug.Debug_herd.profile_cat let showsome = true let skipchecks = StringSet.empty let strictskip = true let through = Model.ThroughAll let cycles = StringSet.empty let dirty = TopConf.dirty end in let module ASL64M = MemCat.Make (MemConfig) (ASLS) in ASL64M.check_event_structure let build_model_from_file fname = profile "build asl model" @@ fun () -> let module P = ParseModel.Make (struct include LexUtils.Default let libfind = ASLConf.libfind end) in let fname,m = P.find_parse fname in Model.Generic (fname,m) let is_strict = C.variant Variant.Strict let is_warn = C.variant Variant.Warn && not is_strict let check_strict test ii = if is_strict then Warn.fatal "No ASL implemention for instruction %s" (A.dump_instruction ii.A.inst); if is_warn then Warn.warn_always "No ASL implemention for instruction %s" (A.dump_instruction ii.A.inst); AArch64Mixed.build_semantics test ii let check_cutoff test = if not_cutoff then Fun.const true else let flitmus = test.Test_herd.name.Name.file in let tbl = Hashtbl.create 13 in fun (_i, _cs, es) -> profile "Check cutoff" @@ fun () -> let open ASLS.E in match ASLS.find_cutoff es.events with | None -> true | Some msg -> if Hashtbl.mem tbl msg then () else ( Hashtbl.add tbl msg true; Warn.warn_always "%a: %s, some legal outcomes may be missing" Pos.pp_pos0 flitmus msg); false let solve_regs test (_i, cs, es) = profile "solve regs" @@ fun () -> let () = if _dbg then Printf.eprintf "** Events **\n %a\n%!" (fun chan -> ASLE.EventSet.pp chan "\n " ASLE.debug_event) es.ASLE.events; in MC.solve_regs test es cs let build_semantics test_aarch64 ii = let () = if _dbg then Printf.eprintf "\n\nExecuting %s by proc %s\n%!" (A.pp_instruction PPMode.Ascii ii.A.inst) (Proc.pp ii.A.proc) in match decode_inst ii with | None -> check_strict test_aarch64 ii | Some _ when AArch64.is_mixed -> check_strict test_aarch64 ii | Some (fname, args) -> ( profile "build AArch64 semantics from ASL" @@ fun () -> let test_asl = fake_test ii fname args in let model = build_model_from_file "asl.cat" in let { MC.event_structures = rfms; _ }, test_asl = profile "run ASL Semantics" @@ fun () -> MC.glommed_event_structures test_asl in let () = if _dbg then Printf.eprintf "Got rfms back: %d of them.\n%!" (List.length rfms) in let build_conc str rfmap = profile "build conc" @@ fun () -> let partial_po = let open ASLE in EventTransRel.to_implicitely_transitive_rel str.partial_po in ASLS.{ ASLS.conc_zero with str; rfmap; partial_po; } in let check_rfm_and_translate acc (es, rfm, cs) = let conc = build_conc es rfm in let t0 = start_profile () in let kfail acc = let () = end_profile t0 "ASL cat, failed" in let () = if _dbg then prerr_endline "ASL cat, failure" in acc in let ksuccess conc _fs (out_sets, out_show) _flags acc = let () = if _dbg then prerr_endline "ASL cat, success" in let c = (conc, cs, Lazy.force out_sets, Lazy.force out_show) in let () = end_profile t0 "ASL cat, success" in Translator.tr_execution ii c :: acc in check_event_structure model test_asl conc kfail ksuccess acc in let check_and_translate acc c = profile "check and translate" @@ fun () -> if check_cutoff test_asl c then match solve_regs test_asl c with | None -> acc | Some c -> check_rfm_and_translate acc c else acc in let monads = List.fold_left check_and_translate [] rfms in let () = if _dbg then Printf.eprintf "Got %d complete executions.\n\ End of ASL execution for %s.\n\n\ %!" (List.length monads) (A.pp_instruction PPMode.Ascii ii.A.inst) in match monads with | [] -> Warn.fatal "No possible ASL execution." | h :: t -> List.fold_left M.altT h t) let spurious_setaf _ = assert false end end herd-herdtools7-1ca343e/herd/AArch64Annot.ml000066400000000000000000000041231475314470400205460ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) type t = A | XA | L | XL | X | N | Q | XQ | NoRet | S | NTA (* Non-Temporal, avoid clash with NT in AArch64Base *) let is_speculated = function | S -> true | _ -> false let is_non_temporal = function | NTA -> true | _ -> false let is_atomic = function | XA | XQ | XL | X | NoRet -> true | _ -> false let is_noreturn = function | NoRet -> true | _ -> false let is_acquire = function | A | XA -> true | _ -> false let is_acquire_pc = function | Q | XQ -> true | _ -> false let is_release = function | L | XL -> true | _ -> false let sets = [ "X", is_atomic; "A", is_acquire; "Q", is_acquire_pc; "L", is_release; "NoRet", is_noreturn; "S", is_speculated; "NT",is_non_temporal; ] let pp = function | XA -> "Acq*" | A -> "Acq" | Q -> "AcqPc" | XQ -> "AcqPc*" | XL -> "Rel*" | L -> "Rel" | X -> "*" | N -> "" | NoRet -> "NoRet" | S -> "^s" | NTA -> "NT" herd-herdtools7-1ca343e/herd/AArch64Arch_herd.ml000066400000000000000000000464051475314470400213570ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Types = struct type annot = AArch64Annot.t type nexp = AF|DB|AFDB|IFetch|Other type explicit = Exp | NExp of nexp type lannot = annot end module Make (C:Arch_herd.Config)(V:Value.AArch64) = struct include MakeAArch64Base.Make (struct let is_morello = C.variant Variant.Morello end) module V = V let is_kvm = C.variant Variant.VMSA let is_amo _ = false let pp_barrier_short = pp_barrier let reject_mixed = true include Types let empty_annot = AArch64Annot.N let exp_annot = Exp let nexp_annot = NExp Other let nexp_ifetch = NExp IFetch let is_atomic = AArch64Annot.is_atomic let is_explicit_annot = function | Exp -> true | NExp _ -> false and is_not_explicit_annot = function | NExp _ -> true | Exp -> false and is_ifetch_annot = function | NExp IFetch -> true | NExp (AF|DB|AFDB|Other)|Exp -> false let is_barrier b1 b2 = barrier_compare b1 b2 = 0 let is_af = function (* Setting of access flag *) | NExp (AF|AFDB)-> true | NExp (DB|IFetch|Other)|Exp -> false and is_db = function (* Setting of dirty bit flag *) | NExp (DB|AFDB) -> true | NExp (AF|IFetch|Other)|Exp -> false module CMO = struct type t = | DC of AArch64Base.DC.op | IC of AArch64Base.IC.op let pp cmo loc = let loc = (Misc.pp_opt_arg Fun.id loc) in match cmo with | DC op -> Printf.sprintf "DC(%s%s)" (AArch64Base.DC.pp_op op) loc | IC op -> Printf.sprintf "IC(%s%s)" (AArch64Base.IC.pp_op op) loc end (* Holds of an instruction iff modifying it or with it while it is being * fetched is subject to special restrictions. * Returns false iff its argument is any of: * B, B.cond, BL, BRK, CBNZ, CBZ, HVC, ISB, NOP, SMC, SVC, TBNZ and TBZ * For the other instructions, a concurrent modification and an execution * represent a conflict. The list is taken from: * Arm ARM B2.2.5 "Concurrent modification and execution of instructions" *) let is_cmodx_restricted_instruction = function | I_B _| I_BL _| I_CBNZ _| I_CBZ _| I_FENCE ISB | I_NOP | I_TBNZ _| I_TBZ _ | I_SVC _ -> false | I_ADD_SIMD _| I_ADD_SIMD_S _| I_ADR _| I_ALIGND _| I_ALIGNU _| I_BC _ | I_BLR _| I_BR _| I_BUILD _| I_CAS _| I_CASBH _| I_CASP _| I_CHKEQ _| I_CHKSLD _ | I_CHKTGD _| I_CLRTAG _| I_CPYTYPE _| I_CPYVALUE _| I_CSEAL _| I_CSEL _| I_DC _ | I_OP3_SIMD _| I_ERET| I_FENCE _| I_GC _| I_IC _| I_LD1 _| I_LD1M _| I_LD1R _ | I_LDAP1 _ | I_LD2 _| I_LD2M _| I_LD2R _| I_LD3 _| I_LD3M _| I_LD3R _| I_LD4 _| I_LD4M _ | I_LD4R _| I_LDAR _| I_LDARBH _| I_LDCT _| I_LDG _| I_LDOP _| I_LDOPBH _ | I_LDP _| I_LDP_SIMD _| I_LDPSW _| I_LDR _ | I_LDRSW _ | I_LDR_SIMD _ | I_LDAPUR_SIMD _ | I_LDRBH _| I_LDRS _| I_LDUR _| I_LDUR_SIMD _| I_LDXP _| I_MOV _ | I_FMOV_TG _ | I_ADDV _| I_DUP _ | I_MOV_FG _| I_MOV_S _| I_MOV_TG _| I_MOV_V _| I_MOV_VE _| I_MOVI_S _ | I_MOVI_V _| I_MOVK _| I_MOVZ _| I_MOVN _| I_MRS _| I_MSR _| I_OP3 _| I_RBIT _ | I_RET _ | I_SBFM _| I_SC _| I_SEAL _| I_ST1 _| I_STL1 _| I_ST1M _| I_ST2 _| I_ST2M _| I_ST3 _ | I_ST3M _| I_ST4 _| I_ST4M _| I_STCT _| I_STG _| I_STLR _| I_STLRBH _| I_STOP _ | I_STOPBH _| I_STP _| I_STP_SIMD _| I_STR _ | I_STLUR_SIMD _ | I_STR_SIMD _| I_STRBH _| I_STUR_SIMD _| I_STXP _| I_STXR _ | I_STXRBH _| I_STZG _| I_STZ2G _ | I_SWP _| I_SWPBH _| I_SXTW _| I_TLBI _| I_UBFM _ | I_UDF _| I_UNSEAL _ | I_ADDSUBEXT _ | I_ABS _ | I_REV _ | I_EXTR _ | I_MOPL _ | I_MOP _ | I_WHILELT _ | I_WHILELE _ | I_WHILELO _ | I_WHILELS _ | I_UADDV _ | I_LD1SP _ | I_LD2SP _ | I_LD3SP _ | I_LD4SP _ | I_ST1SP _ | I_ST2SP _ | I_ST3SP _ | I_ST4SP _ | I_MOV_SV _ | I_INDEX_SI _ | I_INDEX_IS _ | I_INDEX_SS _ | I_INDEX_II _ | I_RDVL _ | I_ADDVL _ | I_CNT_INC_SVE _ | I_DUP_SV _ | I_ADD_SV _ | I_PTRUE _ | I_NEG_SV _ | I_OP3_SV _ | I_MOVPRFX _ | I_SMSTART _ | I_SMSTOP _ | I_LD1SPT _ | I_ST1SPT _ | I_MOVA_TV _ | I_MOVA_VT _ | I_ADDA _ -> true let is_cmodx_restricted_value = let open Constant in function | V.Val Instruction i -> is_cmodx_restricted_instruction i | V.Val (Symbolic _|Concrete _|ConcreteVector _|ConcreteRecord _| Label _|Tag _|PteVal _|Frozen _) | V.Var _ -> false let ifetch_value_sets = [("Restricted-CMODX",is_cmodx_restricted_value)] let barrier_sets = do_fold_dmb_dsb false true (fun b k -> let tag = pp_barrier_dot b in (tag,is_barrier b)::k) ["ISB",is_barrier ISB] let cmo_sets = DC.fold_op (fun op1 k -> let tag = DC.pp_dot op1 in let p = function | CMO.DC op2 -> DC.equal op1 op2 | _ -> false in (tag,p)::k) (IC.fold_op (fun op1 k -> let tag = IC.pp_dot op1 in let p = function | CMO.IC op2 -> IC.equal op1 op2 | _ -> false in (tag,p)::k) []) let annot_sets = AArch64Annot.sets let explicit_sets = [ "AF", is_af; "DB", is_db; ] let pteval_sets = if is_kvm then let open AArch64PteVal in [ "PTEINV",(fun p -> p.valid=0); "PTEV",(fun p -> p.valid=1); "PTEAF0",(fun p -> p.af=0); "PTEDB0",(fun p -> p.db=0); ] else [] let dirty_sets = let read_only = (fun t p -> let open DirtyBit in let open AArch64PteVal in let af = p.af=1 and db = p.db=1 and dbm = p.dbm=1 in (af || not af && t.my_ha ()) && (db && (not (t.my_hd ()) || dbm))) in [ "ReadOnly",read_only; ] let is_isync = is_barrier ISB let pp_isync = "isb" let pp_annot = AArch64Annot.pp let pp_explicit = function | Exp -> if is_kvm && C.verbose > 2 then "Exp" else "" | NExp Other-> "NExp" | NExp IFetch-> "IFetch" | NExp AF-> "NExpAF" | NExp DB-> "NExpDB" | NExp AFDB-> "NExpAFDB" let promote_int64 x = let sc = V.Cst.Scalar.of_int64 x |> V.Cst.Scalar.promote in V.Val (Constant.Concrete sc) and promote_int x = let sc = V.Cst.Scalar.of_int x |> V.Cst.Scalar.promote in V.Val (Constant.Concrete sc) let zero_promoted = promote_int 0 and one_promoted = promote_int 1 let neon_mask esize = let mask = match esize with | 8 -> 0xffL | 16 -> 0xffffL | 32 -> 0xffffffffL | 64 -> 0xffffffffffffffffL | _ -> assert false in promote_int64 mask let neon_getlane cur_val esize idx = let mask = V.op1 (Op.LeftShift (idx*esize)) (neon_mask esize) in let masked_val = V.op Op.And mask cur_val in V.op1 (Op.LogicalRightShift (idx*esize)) masked_val let neon_getvec nelem esize v = let get_concrete v = match v with | V.Val c -> c | _ -> assert false in let rec get_rec idx = if idx < nelem then get_concrete (neon_getlane v esize idx):: get_rec (idx+1) else [] in let vs = get_rec 0 in V.Val (Constant.ConcreteVector vs) let predicate_mask psize = let mask = match psize with | 1 -> 0x1 | 2 -> 0x3 | 4 -> 0x7 | 8 -> 0xff | _ -> assert false in promote_int mask let scalable_mask = neon_mask let simd_mem_access_size rs = match List.hd rs with | Vreg (_,(_,8)) -> MachSize.Byte | Vreg (_,(_,16)) -> MachSize.Short | Vreg (_,(_,32)) -> MachSize.Word | Vreg (_,(_,64)) -> MachSize.Quad | _ -> assert false (* Unsupported arrangement specifier *) let mem_access_size = function | I_LDPSW _ | I_LDRSW _ -> Some MachSize.Word | I_LDR (v,_,_,_) | I_LDP (_,v,_,_,_,_) | I_LDXP (v,_,_,_,_) | I_LDUR (v,_,_,_) | I_STR (v,_,_,_) | I_STLR (v,_,_) | I_STXR (v,_,_,_,_) | I_STP (_,v,_,_,_,_) | I_STXP (v,_,_,_,_,_) | I_CAS (v,_,_,_,_) | I_CASP (v,_,_,_,_,_,_) | I_SWP (v,_,_,_,_) | I_LDOP (_,v,_,_,_,_) | I_STOP (_,v,_,_,_) -> Some (tr_variant v) | I_STZG _|I_STZ2G _ -> Some MachSize.granule | I_LDR_SIMD (v,_,_,_) | I_LDP_SIMD (_,v,_,_,_,_) | I_STR_SIMD (v,_,_,_) | I_STP_SIMD (_,v,_,_,_,_) | I_LDUR_SIMD (v,_,_,_) | I_STUR_SIMD (v,_,_,_) | I_LDAPUR_SIMD (v,_,_,_) | I_STLUR_SIMD (v,_,_,_) -> Some (tr_simd_variant v) | I_LD1 (rs,_,_,_) | I_LD1R (rs,_,_) | I_ST1 (rs,_,_,_) | I_LDAP1 (rs,_,_,_) | I_STL1 (rs,_,_,_) | I_LD1M (rs,_,_) | I_ST1M (rs,_,_) | I_LD2 (rs,_,_,_) | I_LD2R (rs,_,_) | I_ST2 (rs,_,_,_) | I_LD2M (rs,_,_) | I_ST2M (rs,_,_) | I_LD3 (rs,_,_,_) | I_LD3R (rs,_,_) | I_ST3 (rs,_,_,_) | I_LD3M (rs,_,_) | I_ST3M (rs,_,_) | I_LD4 (rs,_,_,_) | I_LD4R (rs,_,_) | I_ST4 (rs,_,_,_) | I_LD4M (rs,_,_) | I_ST4M (rs,_,_) -> Some (simd_mem_access_size rs) | I_LD1SPT (v,_,_,_,_,_,_) | I_ST1SPT (v,_,_,_,_,_,_) | I_LD1SP (v,_,_,_,_) | I_ST1SP (v,_,_,_,_) | I_LD2SP (v,_,_,_,_) | I_ST2SP (v,_,_,_,_) | I_LD3SP (v,_,_,_,_) | I_ST3SP (v,_,_,_,_) | I_LD4SP (v,_,_,_,_) | I_ST4SP (v,_,_,_,_) -> Some (tr_simd_variant v) | I_LDRBH (v,_,_,_) | I_LDARBH (v,_,_,_) | I_LDRS ((_,v),_,_,_) | I_STRBH (v,_,_,_) | I_STLRBH (v,_,_) | I_STXRBH (v,_,_,_,_) | I_CASBH (v,_,_,_,_) | I_SWPBH (v,_,_,_,_) | I_LDOPBH (_,v,_,_,_,_) | I_STOPBH (_,v,_,_,_) -> Some (bh_to_sz v) | I_NOP|I_B _|I_BR _|I_BC (_, _)|I_CBZ (_, _, _) | I_CBNZ (_, _, _)|I_BL _|I_BLR _|I_RET _|I_ERET| I_SVC _ | I_LDAR (_, _, _, _) | I_TBNZ(_,_,_,_) | I_TBZ (_,_,_,_) | I_MOVZ (_,_,_,_) | I_MOVK(_,_,_,_) | I_MOVN _ | I_MOV (_, _, _)|I_SXTW (_, _)|I_OP3 (_, _, _, _, _) | I_ADR (_, _)|I_RBIT (_, _, _)|I_ABS _|I_REV _|I_EXTR _|I_FENCE _ | I_SBFM (_,_,_,_,_) | I_UBFM (_,_,_,_,_) | I_CSEL (_, _, _, _, _, _)|I_IC (_, _)|I_DC (_, _)|I_MRS (_, _)|I_MSR (_, _) | I_STG _ | I_LDG _ | I_ALIGND _| I_ALIGNU _|I_BUILD _|I_CHKEQ _|I_CHKSLD _|I_CHKTGD _ | I_CLRTAG _|I_CPYTYPE _|I_CPYVALUE _|I_CSEAL _|I_GC _|I_LDCT _|I_SEAL _ | I_STCT _|I_UNSEAL _ | I_SC _ | I_TLBI (_,_) | I_MOV_V _ | I_MOV_VE _ | I_MOV_S _ | I_MOV_TG _ | I_MOV_FG _ | I_MOVI_S _ | I_MOVI_V _ | I_ADDV _ | I_DUP _ | I_FMOV_TG _ | I_OP3_SIMD _ | I_ADD_SIMD _ | I_ADD_SIMD_S _ | I_UDF _ | I_ADDSUBEXT _ | I_MOPL _ | I_MOP _ | I_WHILELT _ | I_WHILELE _ | I_WHILELO _ | I_WHILELS _ | I_UADDV _ | I_MOV_SV _ | I_DUP_SV _ | I_ADD_SV _ | I_PTRUE _ | I_NEG_SV _ | I_MOVPRFX _ | I_OP3_SV _ | I_INDEX_SI _ | I_INDEX_IS _ | I_INDEX_SS _ | I_INDEX_II _ | I_RDVL _ | I_ADDVL _ | I_CNT_INC_SVE _ | I_SMSTART _ | I_SMSTOP _ | I_MOVA_TV _ | I_MOVA_VT _ | I_ADDA _ -> None let all_regs = all_gprs@vregs (* Should be enough, only those are tracked *) let all_streaming_regs = zregs@pregs let opt_env = true let killed_idx r = function | (_,Idx) -> Misc.identity | (_,(PostIdx|PreIdx)) -> fun k -> r::k let killed i = match i with | I_LDP (_,_,r1,r2,ra,idx) |I_LDPSW (r1,r2,ra,idx) -> killed_idx ra idx [r1; r2;] | I_STG (_,r,idx)|I_STZG (_,r,idx)|I_STZ2G (_,r,idx) | I_STP (_,_,_,_,r,idx) -> killed_idx r idx [] | I_STR (_,_,r,MemExt.Imm (_,(PreIdx|PostIdx))) | I_STRBH (_,_,r,MemExt.Imm (_,(PreIdx|PostIdx))) -> [r;] | I_B _| I_BR _ | I_BC _ | I_CBZ _ | I_CBNZ _ | I_STR _ | I_STLR _ | I_STRBH _ | I_STLRBH _ | I_STOP _ | I_STOPBH _ | I_FENCE _ | I_IC _|I_DC _|I_TLBI _ | I_NOP|I_TBZ _|I_TBNZ _ | I_BL _ | I_BLR _ | I_RET _ | I_ERET | I_SVC _ | I_UDF _ | I_ST1SP _ | I_ST2SP _ | I_ST3SP _ | I_ST4SP _ | I_ST1SPT _ -> [] (* For -variant self only ? *) | I_LDR (_,r1,r2,MemExt.Imm (_,(PreIdx|PostIdx))) | I_LDRBH (_,r1,r2,MemExt.Imm (_,(PreIdx|PostIdx))) | I_LDRSW (r1,r2,MemExt.Imm (_,(PreIdx|PostIdx))) | I_LDRS (_,r1,r2,MemExt.Imm (_,(PreIdx|PostIdx))) -> [r1;r2;] | I_LDR (_,r,_,_) | I_LDRSW (r,_,_) | I_LDRBH (_,r,_,_) | I_LDRS (_,r,_,_) | I_LDUR (_,r,_,_) | I_LDAR (_,_,r,_) |I_LDARBH (_,_,r,_) | I_SWP (_,_,_,r,_) | I_SWPBH (_,_,_,r,_) | I_STXR (_,_,r,_,_) | I_STXP (_,_,r,_,_, _) | I_STXRBH (_,_,r,_,_) | I_CAS (_,_,r,_,_) | I_CASBH (_,_,r,_,_) | I_LDOP (_,_,_,_,r,_) | I_LDOPBH (_,_,_,_,r,_) | I_MOV (_,r,_) | I_MOVZ (_,r,_,_) | I_MOVN (_,r,_,_) | I_MOVK (_,r,_,_) | I_SXTW (r,_) | I_OP3 (_,_,r,_,_) | I_ADR (r,_) | I_RBIT (_,r,_) | I_ABS (_,r,_) | I_REV (_,r,_) | I_EXTR (_,r,_,_,_) | I_CSEL (_,r,_,_,_,_) | I_MRS (r,_) | I_UBFM (_,r,_,_,_) | I_SBFM (_,r,_,_,_) | I_ADDSUBEXT (_,_,r,_,_,_) | I_MOPL (_,r,_,_,_) | I_MOP (_,_,r,_,_,_) | I_ADDV (_,r,_) | I_DUP (r,_,_) | I_FMOV_TG (_,r,_,_) | I_WHILELT (r,_,_,_) | I_WHILELE (r,_,_,_) | I_WHILELO (r,_,_,_) | I_WHILELS (r,_,_,_) | I_UADDV (_,r,_,_) | I_MOV_SV (r,_,_) | I_DUP_SV (r,_,_) | I_ADD_SV (r,_,_) | I_PTRUE (r,_) | I_NEG_SV (r,_,_) | I_MOVPRFX (r,_,_) | I_OP3_SV (_,r,_,_) | I_INDEX_SI (r,_,_,_) | I_INDEX_IS (r,_,_,_) | I_INDEX_SS (r,_,_,_) | I_INDEX_II (r,_,_) | I_RDVL (r,_) | I_ADDVL (r,_,_) | I_CNT_INC_SVE (_,r,_,_) | I_LD1SPT (_,r,_,_,_,_,_) | I_MOVA_TV (r,_,_,_,_) | I_MOVA_VT (r,_,_,_,_) | I_ADDA (_,r,_,_,_) -> [r] | I_MSR (sr,_) -> [(SysReg sr)] | I_LDXP (_,_,r1,r2,_) -> [r1;r2;] | I_LD1SP (_,rs,_,_,_) | I_LD2SP (_,rs,_,_,_) | I_LD3SP (_,rs,_,_,_) | I_LD4SP (_,rs,_,_,_) -> rs | I_SMSTART _ | I_SMSTOP _ -> all_streaming_regs | I_LDAP1 _ | I_STL1 _ | I_LD1 _|I_LD1M _|I_LD1R _|I_LD2 _ | I_LD2M _|I_LD2R _|I_LD3 _|I_LD3M _ | I_LD3R _|I_LD4 _|I_LD4M _|I_LD4R _ | I_ST1 _|I_ST1M _|I_ST2 _|I_ST2M _ | I_ST3 _|I_ST3M _|I_ST4 _|I_ST4M _ | I_LDP_SIMD _|I_STP_SIMD _ | I_LDR_SIMD _|I_STR_SIMD _ | I_LDUR_SIMD _|I_LDAPUR_SIMD _|I_STUR_SIMD _|I_STLUR_SIMD _ | I_MOV_VE _ | I_MOV_V _|I_MOV_TG _|I_MOV_FG _ | I_MOV_S _|I_MOVI_V _|I_MOVI_S _ | I_OP3_SIMD _|I_ADD_SIMD _|I_ADD_SIMD_S _ | I_ALIGND _|I_ALIGNU _ | I_BUILD _|I_CHKEQ _|I_CHKSLD _|I_CHKTGD _|I_CLRTAG _ | I_CPYTYPE _|I_CPYVALUE _|I_CSEAL _|I_GC _ | I_LDCT _|I_SC _|I_SEAL _|I_STCT _ | I_UNSEAL _|I_LDG _ | I_CASP _ -> all_regs (* safe approximation *) let get_lx_sz = function | I_LDAR (var,(XX|AX),_,_)|I_LDXP (var,_,_,_,_) -> MachSize.Ld (tr_variant var) | I_LDARBH (bh,(XX|AX),_,_) -> MachSize.Ld (bh_to_sz bh) | I_STXR _|I_STXRBH _ | I_STXP _ -> MachSize.St | I_LDAR (_, (AA|AQ), _, _)|I_LDARBH (_, (AA|AQ), _, _) | I_NOP|I_B _|I_BR _|I_BC _|I_CBZ _|I_CBNZ _ | I_TBNZ _|I_TBZ _|I_BL _|I_BLR _|I_RET _|I_ERET | I_SVC _ | I_UBFM _ | I_SBFM _ | I_LDR _|I_LDRSW _|I_LDRS _|I_LDUR _|I_LD1 _|I_LDAP1 _ | I_LD1M _|I_LD1R _|I_LD2 _|I_LD2M _ | I_LD2R _|I_LD3 _|I_LD3M _|I_LD3R _ | I_LD4 _|I_LD4M _|I_LD4R _|I_ST1 _|I_STL1 _ | I_ST1M _|I_ST2 _|I_ST2M _|I_ST3 _ | I_ST3M _|I_ST4 _|I_ST4M _ | I_LDP_SIMD _|I_STP_SIMD _ | I_LDR_SIMD _|I_STR_SIMD _ | I_LDUR_SIMD _|I_LDAPUR_SIMD _|I_STUR_SIMD _|I_STLUR_SIMD _ | I_MOV_VE _ | I_MOV_V _|I_MOV_TG _|I_MOV_FG _ | I_MOV_S _|I_MOVI_V _|I_MOVI_S _ | I_ADDV _| I_DUP _ | I_FMOV_TG _ | I_OP3_SIMD _|I_ADD_SIMD _|I_ADD_SIMD_S _ | I_LDP _|I_LDPSW _|I_STP _ | I_STR _|I_STLR _|I_ALIGND _|I_ALIGNU _ | I_BUILD _|I_CHKEQ _|I_CHKSLD _|I_CHKTGD _|I_CLRTAG _ | I_CPYTYPE _|I_CPYVALUE _|I_CSEAL _|I_GC _ | I_LDCT _|I_SC _|I_SEAL _|I_STCT _ | I_UNSEAL _|I_LDRBH _|I_STRBH _ | I_STLRBH _|I_CAS _|I_CASBH _ | I_CASP _ | I_SWP _|I_SWPBH _|I_LDOP _ | I_LDOPBH _|I_STOP _|I_STOPBH _ | I_MOV _|I_MOVZ _|I_MOVN _|I_MOVK _|I_SXTW _ | I_OP3 _|I_ADR _|I_RBIT _|I_ABS _|I_REV _|I_EXTR _|I_FENCE _ | I_CSEL _|I_IC _|I_DC _|I_TLBI _|I_MRS _|I_MSR _ | I_STG _|I_STZG _|I_STZ2G _|I_LDG _|I_UDF _ | I_ADDSUBEXT _|I_MOPL _ | I_MOP _ | I_WHILELT _ | I_WHILELE _ | I_WHILELO _ | I_WHILELS _ | I_UADDV _ | I_LD1SP _ | I_LD2SP _ | I_LD3SP _ | I_LD4SP _ | I_ST1SP _ | I_ST2SP _ | I_ST3SP _ | I_ST4SP _ | I_ADD_SV _ | I_PTRUE _ | I_NEG_SV _ | I_MOVPRFX _ | I_OP3_SV _ | I_MOV_SV _ | I_DUP_SV _ | I_INDEX_SI _ | I_INDEX_IS _ | I_INDEX_SS _ | I_INDEX_II _ | I_RDVL _ | I_ADDVL _ | I_CNT_INC_SVE _ | I_SMSTART _ | I_SMSTOP _ | I_LD1SPT _ | I_ST1SPT _ | I_MOVA_TV _| I_MOVA_VT _ | I_ADDA _ -> MachSize.No let reg_defaults = if C.variant Variant.SME then [ZA; SM;] else [] include ArchExtra_herd.Make(C) (struct module V = V let endian = endian type arch_reg = reg let pp_reg = pp_reg let reg_compare = reg_compare let fromto_of_instr _ = None let get_val reg v = match reg with | AArch64Base.Vreg(_,(nelem,esize)) -> neon_getvec nelem esize v | _ -> v module FaultType = FaultType.AArch64 end) module MemType = MemoryType.No module NoConf = struct type v = V.v type loc = location type value_set = V.ValueSet.t type solution = V.solution type arch_lannot = lannot type arch_explicit = explicit end module ArchAction = ArchAction.No(NoConf) module Barrier = AllBarrier.No(struct type a = barrier end) let check tst = let open MiscParser in if List.exists (fun (_,(t,_)) -> TestType.is_array t) tst.init && List.exists (fun (_,code) -> exists_pseudo_code (function | I_STZG _ -> true | _ -> false) code) tst.prog && not is_mixed then Warn.user_error "Array location and STZG instruction without -variant mixed" end herd-herdtools7-1ca343e/herd/AArch64ParseTest.ml000066400000000000000000000077721475314470400214160ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make(Conf:RunTest.Config)(ModelConfig:MemCat.Config) = struct module ArchConfig = SemExtra.ConfigToArchConfig(Conf) module LexConfig = struct let debug = Conf.debug.Debug_herd.lexer end let run dirty start_time name chan env splitted = let module Top (MakeSem:AArch64Sig.MakeSemantics) = struct let is_morello = Conf.variant Variant.Morello module ConfMorello = struct let is_morello = is_morello end module AArch64Make (V:Value.AArch64) = struct module AArch64 = AArch64Arch_herd.Make(ArchConfig)(V) module AArch64LexParse = struct type instruction = AArch64.parsedPseudo type token = AArch64Parser.token module Lexer = AArch64Lexer.Make (struct include LexConfig let is_morello = Conf.variant Variant.Morello end) let lexer = Lexer.token let parser = (*MiscParser.mach2generic*) AArch64Parser.main end module AArch64SemConf = struct module C = Conf let dirty = ModelConfig.dirty let procs_user = ProcsUser.get splitted.Splitter.info let sve_vector_length = Conf.sve_vector_length let sme_vector_length = Conf.sme_vector_length end module AArch64S = MakeSem(AArch64SemConf)(V) module AArch64M = MemCat.Make(ModelConfig)(AArch64S) module P0 = GenParser.Make (Conf) (AArch64) (AArch64LexParse) module P = struct type pseudo = AArch64.pseudo let parse chan splitted = let tst = P0.parse chan splitted in let () = AArch64.check tst in tst end module X = RunTest.Make (AArch64S) (P) (AArch64M) (Conf) end (* * Markers START/END below are for excluding source * when compiling the web interface *) let run = (* START NOTWWW *) if is_morello then let module AArch64Value = CapabilityValue.Make(ConfMorello) in let module X = AArch64Make(AArch64Value) in X.X.run else if Conf.variant Variant.Neon then let module AArch64Value = NeonValue.Make(ConfMorello) in let module X = AArch64Make(AArch64Value) in X.X.run else if Conf.variant Variant.SVE || Conf.variant Variant.SME then let module AArch64Value = SVEValue.Make(ConfMorello) in let module X = AArch64Make(AArch64Value) in X.X.run else (* END NOTWWW *) let module AArch64Value = AArch64Value.Make(ConfMorello) in let module X = AArch64Make(AArch64Value) in X.X.run end in let module Run = Top(AArch64Sem.Make) in Run.run dirty start_time name chan env splitted end herd-herdtools7-1ca343e/herd/AArch64Sem.ml000066400000000000000000005224551475314470400202300ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make (TopConf:AArch64Sig.Config) (V:Value.AArch64 with type Cst.Instr.t = AArch64Base.instruction) = struct module C = TopConf.C module ConfLoc = SemExtra.ConfigToArchConfig(C) module AArch64 = AArch64Arch_herd.Make(ConfLoc)(V) module Act = MachAction.Make(ConfLoc)(AArch64) module Annot = AArch64Annot include SemExtra.Make(C)(AArch64)(Act) let dirty = match TopConf.dirty with | None -> DirtyBit.soft | Some d -> d let mixed = AArch64.is_mixed (* We need to be aware of endianness for 128-bit Neon LDR/STR, because * these are always little endian *) let endian = AArch64.endian let memtag = C.variant Variant.MemTag let morello = C.variant Variant.Morello let sme = C.variant Variant.SME let sve = C.variant Variant.SVE || sme let neon = C.variant Variant.Neon || sve let kvm = C.variant Variant.VMSA let is_branching = kvm && not (C.variant Variant.NoPteBranch) let pte2 = kvm && C.variant Variant.PTE2 let do_cu = C.variant Variant.ConstrainedUnpredictable let self = C.variant Variant.Ifetch let check_mixed ins = if not mixed then Warn.user_error "%s without -variant mixed" ins let check_memtag ins = if not memtag then Warn.user_error "%s without -variant memtag" ins let check_morello inst = if not morello then Warn.user_error "morello instruction %s require -variant morello" (AArch64.dump_instruction inst) let check_neon inst = if not neon then Warn.user_error "Neon instruction %s requires -variant neon" (AArch64.dump_instruction inst) let check_sve inst = if not sve then Warn.user_error "SVE instruction %s requires -variant sve" (AArch64.dump_instruction inst) let check_sme inst = if not sme then Warn.user_error "SME instruction %s requires -variant sme" (AArch64.dump_instruction inst) (* Barrier pretty print *) let barriers = let bs = AArch64Base.do_fold_dmb_dsb false true (fun h t -> h::t) [] in List.map (fun b -> { barrier = b; pp = Misc.lowercase (AArch64Base.pp_barrier b)}) bs let isync = Some { barrier = AArch64Base.ISB;pp = "isb";} let atomic_pair_allowed _ _ = true let quad = MachSize.Quad (* This machine natural size *) and aexp = AArch64.Exp (* Explicit accesses *) let tnt2annot = let open Annot in function | AArch64.TT -> N | AArch64.NT -> NTA (* Semantics proper *) module Mixed(SZ:ByteSize.S) : sig val build_semantics : test -> A.inst_instance_id -> (proc * branch) M.t val spurious_setaf : V.v -> unit M.t end = struct module Mixed = M.Mixed(SZ) let (>>=) = M.(>>=) let (>>==) = M.(>>==) let (>>*=) = M.(>>*=) let (>>*==) = M.(>>*==) let (>>**==) = M.(>>**==) let (>>|) = M.(>>|) let (>>||) = M.para_atomic let (>>!) = M.(>>!) let (>>::) = M.(>>::) let sxt_op sz = M.op1 (Op.Sxt sz) and uxt_op sz = M.op1 (Op.Mask sz) let sxtw_op = sxt_op MachSize.Word and uxtw_op = uxt_op MachSize.Word let mask32 ty m = let open AArch64Base in match ty with | V32 -> fun v -> uxtw_op v >>= m | V64 when not morello -> m | V64 -> fun v -> uxt_op MachSize.Quad v >>= m | V128 -> m (* Promotion/Demotion *) let promote = M.op1 Op.Promote and demote = M.op1 Op.Demote let is_zero v = M.op Op.Eq v V.zero and is_not_zero v = M.op Op.Ne v V.zero and add_if ok k = if ok then fun a -> M.add a (V.intToV k) else M.unitT (* Ordinary access action *) let access_anexp anexp d loc v ac = Act.Access (d,loc,v,Annot.N,anexp,quad,ac) let access_ord d loc v ac = access_anexp aexp d loc v ac (* Basic read, from register *) let mk_read sz an anexp loc v = let ac = Act.access_of_location_std loc in Act.Access (Dir.R, loc, v, an, anexp, sz, ac) let has_handler ii = match ii.A.env.A.fh_code with | Some _ -> true | None -> false let mk_fault a dir annot ii ft msg = let fh = has_handler ii in let is_sync_exc_entry = match ft with | Some FaultType.AArch64.TagCheck -> (C.variant Variant.MemTag) && ((dir = Dir.R && (C.mte_precision = Precision.Synchronous || C.mte_precision = Precision.Asymmetric)) || (dir = Dir.W && C.mte_precision = Precision.Synchronous)) | _ -> true in let loc = Misc.map_opt (fun a -> A.Location_global a) a in M.mk_singleton_es (Act.Fault (ii,loc,dir,annot,fh || is_sync_exc_entry,ft,msg)) ii let read_reg is_data r ii = match r with | AArch64.ZR -> M.unitT V.zero | _ -> M.read_loc is_data (mk_read quad Annot.N aexp) (A.Location_reg (ii.A.proc,r)) ii let read_reg_morello is_data r ii = if not morello then Warn.user_error "capabilities require -variant morello" ; match r with | AArch64.ZR -> M.unitT V.zero | _ -> M.read_loc is_data (mk_read MachSize.S128 Annot.N aexp) (A.Location_reg (ii.A.proc,r)) ii let read_reg_neon is_data r ii = let vr = match r with | AArch64Base.SIMDreg _ -> r | AArch64Base.Vreg(vr',_) -> (AArch64Base.SIMDreg vr') | _ -> assert false in let location = A.Location_reg (ii.A.proc,vr) in M.read_loc is_data (mk_read MachSize.S128 Annot.N aexp) location ii let neon_getlane cur_val idx esize = let mask = V.op1 (Op.LeftShift (idx*esize)) (AArch64.neon_mask esize) in M.op Op.And mask cur_val >>= fun masked_val -> M.op1 (Op.LogicalRightShift (idx*esize)) masked_val let read_reg_neon_elem is_data r idx ii = match r with | AArch64Base.Vreg (_,(_,esize)) -> read_reg_neon is_data r ii >>= fun cur_val -> neon_getlane cur_val idx esize | _ -> assert false let read_reg_sz sz is_data r ii = match sz with | MachSize.S128 -> read_reg_morello is_data r ii | MachSize.Quad when not morello || not is_data -> read_reg is_data r ii | MachSize.Quad|MachSize.Word|MachSize.Short|MachSize.Byte -> read_reg is_data r ii >>= uxt_op sz let read_reg_ord = read_reg_sz quad false let read_reg_ord_sz sz = read_reg_sz sz false let read_reg_data sz = read_reg_sz sz true (* Fetch of an instruction, i.e., a read from a label *) let mk_fetch an loc v = let ac = Access.VIR in (* Instruction fetch seen as ordinary, non PTE, access *) Act.Access (Dir.R, loc, v, an, AArch64.nexp_ifetch, MachSize.Word, ac) (* Basic write, to register *) let mk_write sz an anexp ac v loc = Act.Access (Dir.W, loc, v, an, anexp, sz, ac) let write_reg r v ii = match r with | AArch64.ZR -> M.unitT () | _ -> M.write_loc (mk_write quad Annot.N aexp Access.REG v) (A.Location_reg (ii.A.proc,r)) ii let write_reg_dest r v ii = match r with | AArch64.ZR -> M.unitT V.zero | _ -> write_reg r v ii >>= fun () -> M.unitT v let write_reg_morello r v ii = if not morello then Warn.user_error "capabilities require -variant morello" ; M.write_loc (mk_write MachSize.S128 Annot.N aexp Access.REG v) (A.Location_reg (ii.A.proc,r)) ii let neon_setlane old_val idx esize v = let mask = V.op1 (Op.LeftShift (idx*esize)) (AArch64.neon_mask esize) in let invert = V.op1 Op.Inv mask in M.op1 (Op.LeftShift (idx*esize)) v >>= fun new_val -> M.op Op.And invert old_val >>| M.op Op.And mask new_val >>= fun (v1,v2) -> M.op Op.Or v1 v2 let rec neon_replicate old_val nelem esize v = if nelem <= 0 then M.unitT old_val else neon_setlane old_val (nelem-1) esize v >>= fun old_val -> neon_replicate old_val (nelem-1) esize v let write_reg_neon_sz sz r v ii = let vr = match r with | AArch64Base.SIMDreg _ -> r | AArch64Base.Vreg(vr',_) -> (AArch64Base.SIMDreg vr') | _ -> assert false in (* Clear unused register bits (zero extend) *) promote v >>= uxt_op sz >>= fun v -> let location = A.Location_reg (ii.A.proc,vr) in M.write_loc (mk_write MachSize.S128 Annot.N aexp Access.REG v) location ii let write_reg_neon = write_reg_neon_sz MachSize.S128 let write_reg_neon_elem sz r idx v ii = match r with | AArch64Base.Vreg (_,(_,esize)) -> read_reg_neon false r ii >>= fun old_val -> neon_setlane old_val idx esize v >>= fun new_val -> write_reg_neon_sz sz r new_val ii | _ -> assert false let write_reg_neon_rep sz r v ii = match r with | AArch64Base.Vreg (_,(nelem,esize)) -> neon_replicate v nelem esize v >>= fun new_val -> write_reg_neon_sz sz r new_val ii | _ -> assert false let scalable_nbits = if C.variant Variant.SME && C.variant Variant.SVE && (TopConf.sme_vector_length != TopConf.sve_vector_length) then Warn.user_error "Mismatch vector lengths: SME VL%d != SVE VL%d" TopConf.sme_vector_length TopConf.sve_vector_length else if C.variant Variant.SME then TopConf.sme_vector_length else if C.variant Variant.SVE then TopConf.sve_vector_length else 0 let scalable_nbytes = scalable_nbits / 8 let predicate_psize r = match r with | AArch64Base.Preg (_,esize) (* Infer predicate bitsize from Z or ZA register *) | AArch64Base.ZAreg (_,_,esize) | AArch64Base.Zreg (_,esize) -> esize / 8 | _ -> assert false let predicate_nelem r = match r with | AArch64Base.Preg (_,esize) (* Infer predicate elements from Z or ZA register *) | AArch64Base.ZAreg (_,_,esize) | AArch64Base.Zreg (_,esize) -> scalable_nbits / esize | _ -> assert false let predicate_count predicate nelem = let open AArch64 in match predicate with | VL1 when nelem >= 1 -> 1 | VL2 when nelem >= 2 -> 2 | VL3 when nelem >= 3 -> 3 | VL4 when nelem >= 4 -> 4 | VL5 when nelem >= 5 -> 5 | VL6 when nelem >= 6 -> 6 | VL7 when nelem >= 7 -> 7 | VL8 when nelem >= 8 -> 8 | VL16 when nelem >= 16 -> 16 | VL32 when nelem >= 32 -> 32 | VL128 when nelem >= 128 -> 128 | VL256 when nelem >= 256 -> 256 | MUL3 -> nelem - (nelem mod 3) | MUL4 -> nelem - (nelem mod 4) | ALL -> nelem | POW2 -> let rec calc n = if nelem >= (Int.shift_left 1 n) then calc (n+1) else Int.shift_left 1 (n-1) in calc 1 | _ -> 0 let read_reg_predicate is_data r ii = let vr = match r with | AArch64Base.Preg(_,_) | AArch64Base.PMreg(_,_) -> r | _ -> assert false in let location = A.Location_reg (ii.A.proc,vr) in M.read_loc is_data (mk_read MachSize.S128 Annot.N aexp) location ii let predicate_setlane old_val idx psize v = let mask = V.op1 (Op.LeftShift (idx*psize)) (AArch64.predicate_mask psize) in let invert = V.op1 Op.Inv mask in M.op1 (Op.LeftShift (idx*psize)) v >>= fun new_val -> M.op Op.And invert old_val >>| M.op Op.And mask new_val >>= fun (v1,v2) -> M.op Op.Or v1 v2 let predicate_getlane cur_val idx psize = let mask = V.op1 (Op.LeftShift (idx*psize)) (AArch64.predicate_mask psize) in M.op Op.And mask cur_val >>= fun masked_val -> M.op1 (Op.LogicalRightShift (idx*psize)) masked_val let write_reg_predicate r v ii = let pr = match r with | AArch64Base.Preg(_,_) -> r | _ -> assert false in let location = A.Location_reg (ii.A.proc,pr) in M.write_loc (mk_write MachSize.S128 Annot.N aexp Access.REG v) location ii let get_predicate_last pred psize idx = predicate_getlane pred idx psize >>= M.op Op.And AArch64.one_promoted >>= M.op Op.Ne AArch64.zero_promoted let get_predicate_any pred psize nelem = let mask idx = V.op1 (Op.LeftShift (idx*psize)) (AArch64.predicate_mask psize) in let ops = List.map mask (Misc.interval 0 nelem) in let allmask = List.fold_right (V.op Op.Or) ops AArch64.zero_promoted in M.op Op.And pred allmask >>= fun all -> M.op Op.Ne all AArch64.zero_promoted let scalable_esize r = match r with | AArch64Base.ZAreg (_,_,esize) | AArch64Base.Zreg (_,esize) -> esize | _ -> assert false let scalable_nelem r = match r with | AArch64Base.ZAreg (_,_,esize) | AArch64Base.Zreg (_,esize) -> scalable_nbits / esize | _ -> assert false let read_reg_scalable is_data r ii = let vr = match r with | AArch64Base.Zreg _ -> r | _ -> assert false in let location = A.Location_reg (ii.A.proc,vr) in M.read_loc is_data (mk_read MachSize.S128 Annot.N aexp) location ii let scalable_setlane old_val idx esize v = let mask = V.op1 (Op.LeftShift (idx*esize)) (AArch64.scalable_mask esize) in let invert = V.op1 Op.Inv mask in M.op1 (Op.LeftShift (idx*esize)) v >>= fun new_val -> M.op Op.And invert old_val >>| M.op Op.And mask new_val >>= fun (v1,v2) -> M.op Op.Or v1 v2 let scalable_getlane cur_val idx esize = let mask = V.op1 (Op.LeftShift (idx*esize)) (AArch64.scalable_mask esize) in M.op Op.And mask cur_val >>= fun masked_val -> M.op1 (Op.LogicalRightShift (idx*esize)) masked_val let rec scalable_replicate old_val nelem esize v = match nelem with | 0 -> M.unitT old_val | _ -> scalable_setlane old_val (nelem-1) esize v >>= fun old_val -> scalable_replicate old_val (nelem-1) esize v let write_reg_scalable_sz sz r v ii = let pr = match r with | AArch64Base.Zreg(_,_) -> r | _ -> assert false in (* Clear unused register bits (zero extend) *) M.op1 (Op.Mask sz) v >>= fun v -> let location = A.Location_reg (ii.A.proc,pr) in M.write_loc (mk_write MachSize.S128 Annot.N aexp Access.REG v) location ii let write_reg_scalable = write_reg_scalable_sz MachSize.S128 (* ZA offset, in bits, see ARM ARM B.1.4.10 "ZA tile access" *) let za_getoffset tile slice idx esize = let esize_to_shift = function | 8 -> 0 | 16 -> 1 | 32 -> 2 | 64 -> 3 | 128 -> 4 | _ -> assert false in let shift = esize_to_shift esize in let mk_shift k = M.op1 (Op.LeftShift k) in begin begin mk_shift shift slice >>= M.add (V.intToV tile) >>= M.op Op.Mul (V.intToV scalable_nbits) end >>| mk_shift (shift+3) idx end >>= fun (base,idx) -> M.add base idx let za_getoffset_dir dir tile slice idx esize = match dir with | AArch64Base.Horizontal -> za_getoffset tile slice idx esize | AArch64Base.Vertical -> za_getoffset tile idx slice esize let za_getlane cur_val tile slice idx esize = let mask = AArch64.scalable_mask esize in za_getoffset tile slice idx esize >>= fun amount -> M.op Op.ShiftLeft mask amount >>= fun mask -> M.op Op.And mask cur_val >>= fun masked_val -> M.op Op.ShiftRight masked_val amount let za_getlane_dir dir cur_val tile slice idx esize = match dir with | AArch64Base.Horizontal -> za_getlane cur_val tile slice idx esize | AArch64Base.Vertical -> za_getlane cur_val tile idx slice esize let za_setlane old_val tile slice idx esize v = let mask = AArch64.scalable_mask esize in za_getoffset tile slice idx esize >>= fun amount -> M.op Op.ShiftLeft mask amount >>= fun mask -> M.op1 Op.Inv mask >>= fun invert -> M.op Op.And invert old_val >>| (M.op Op.ShiftLeft v amount >>= fun new_val -> M.op Op.And mask new_val) >>= fun (v1,v2) -> M.op Op.Or v1 v2 let za_setlane_dir dir old_val tile slice idx esize v = match dir with | AArch64Base.Horizontal -> za_setlane old_val tile slice idx esize v | AArch64Base.Vertical -> za_setlane old_val tile idx slice esize v let read_reg_za is_data r ii = let vr = match r with | AArch64Base.ZAreg _ -> r | _ -> assert false in let location = A.Location_reg (ii.A.proc,vr) in M.read_loc is_data (mk_read MachSize.S128 Annot.N aexp) location ii let write_reg_za_sz sz r v ii = let pr = match r with | AArch64Base.ZAreg(_,_,_) -> r | _ -> assert false in (* Clear unused register bits (zero extend) *) M.op1 (Op.Mask sz) v >>= fun v -> let location = A.Location_reg (ii.A.proc,pr) in M.write_loc (mk_write MachSize.S128 Annot.N aexp Access.REG v) location ii let write_reg_za = write_reg_za_sz MachSize.S128 let write_reg_scalable_rep r v ii = let nelem = scalable_nelem r in let esize = scalable_esize r in scalable_replicate v nelem esize v >>= fun new_val -> write_reg_scalable r new_val ii let do_write_reg_sz mop sz r v ii = match r with | AArch64.ZR -> M.unitT () | _ -> match sz with | MachSize.S128 -> write_reg_morello r v ii | MachSize.Quad when not morello -> write_reg r v ii | MachSize.Quad|MachSize.Word|MachSize.Short|MachSize.Byte -> mop sz v >>= fun v -> write_reg r v ii let write_reg_sz = do_write_reg_sz uxt_op let write_reg_sz_dest sz r v ii = write_reg_sz sz r v ii >>= fun () -> M.unitT v let write_reg_op op sz r v ii = match r with | AArch64.ZR -> M.unitT () | _ -> match sz with | MachSize.S128 -> write_reg_morello r v ii | MachSize.Quad|MachSize.Word|MachSize.Short|MachSize.Byte -> op v >>= fun v -> write_reg r v ii let write_reg_sz_non_mixed = if mixed then fun _sz -> write_reg else write_reg_sz (* Emit commit event *) let commit_bcc ii = M.mk_singleton_es (Act.Commit (Act.Bcc,None)) ii and commit_pred_txt txt ii = M.mk_singleton_es (Act.Commit (Act.Pred,txt)) ii let commit_pred ii = commit_pred_txt None ii (* Fence *) let create_barrier b ii = M.mk_singleton_es (Act.Barrier b) ii (* Page tables and TLBs *) let inv_loc op loc ii = let oloc = if A.TLBI.inv_all op then None else Some loc in M.mk_singleton_es (Act.Inv (op,oloc)) ii (* Neon size *) let neon_esize r = match r with | AArch64Base.Vreg (_,(_,esize)) -> esize | _ -> assert false let neon_nelem r = match r with | AArch64Base.Vreg (_,(nelem,_)) -> nelem | _ -> assert false let neon_sz r = let size = match r with | AArch64Base.Vreg(_,(0,esize)) -> esize | AArch64Base.Vreg(_,(nelem,esize)) -> nelem * esize | _ -> assert false in match size with | 64 -> MachSize.Quad | 128 -> MachSize.S128 | _ -> assert false let neon_sz_k var = let open AArch64Base in match var with | VSIMD8 -> (V.intToV 1) | VSIMD16 -> (V.intToV 2) | VSIMD32 -> (V.intToV 4) | VSIMD64 -> (V.intToV 8) | VSIMD128 -> (V.intToV 16) (******************) (* Memory Tagging *) (******************) (* Decompose tagged location *) let tag_extract a = M.op1 Op.TagExtract a let loc_extract a = M.op1 Op.LocExtract a (* Low level tag access *) let do_read_tag a ii = M.read_loc false (fun loc v -> access_ord Dir.R loc v Access.TAG) (A.Location_global a) ii and do_read_tag_nexp a ii = M.read_loc false (fun loc v -> access_anexp AArch64.nexp_annot Dir.R loc v Access.TAG) (A.Location_global a) ii and do_write_tag a v ii = let loc = A.Location_global a in M.mk_singleton_es (access_ord Dir.W loc v Access.TAG) ii let do_read_morello_tag a ii = M.add_atomic_tag_read (M.unitT M.A.V.one) a (fun loc v -> Act.tag_access quad Dir.R loc v) ii >>= fun tagged -> M.op1 Op.CapaGetTag tagged and do_write_morello_tag a v ii = M.add_atomic_tag_write (M.unitT ()) a v (fun loc v -> Act.tag_access quad Dir.W loc v) ii (* Read tag from memory *) let read_tag_mem a ii = M.op1 Op.TagLoc a >>= fun atag -> do_read_tag_nexp atag ii (*******************) (* Memory accesses *) (*******************) (* Tag checking, MTE *) let delayed_check_tags a_virt a_phy ma ii m1 m2 = let (+++) = M.data_input_union in let rtag = read_tag_mem (match a_phy with None -> a_virt | Some a -> a) ii in let commit = commit_pred_txt (Some "color") ii in let choice c ma = M.choiceT c (m1 ma) (m2 ma) in let m = rtag +++ fun tag1 -> tag_extract a_virt +++ fun tag2 -> M.op Op.Eq tag1 tag2 in let m = let (>>=) = match a_phy with None -> (+++) | Some _ -> (>>=) in m >>= fun cond -> commit +++ fun _ -> M.unitT cond in M.delay_kont "check_tags" m (fun c m -> let ma = (* NB output to initial ma *) match a_phy with | None -> ma >>== fun a -> m >>== fun _ -> loc_extract a | Some _ -> M.bind_ctrldata ma (fun a -> m >>== fun _ -> M.unitT a) in choice c ma) (* Tag checking Morello *) let do_append_commit ma txt ii = ma >>== fun a -> commit_pred_txt txt ii >>= fun () -> M.unitT a let mzero = M.unitT M.A.V.zero let mzero_promoted = mzero >>= promote let check_morello_tag a ma mv mok mfault = M.op1 Op.CapaGetTag a >>= fun x -> M.op Op.Ne x V.zero >>= fun cond -> M.choiceT cond (mok ma mv) (mfault ma mzero) let check_morello_sealed a ma mv mok mfault = M.op1 Op.CheckSealed a >>= fun x -> M.op Op.Ne x V.zero >>= fun cond -> M.choiceT cond (mfault ma mzero) (mok ma mv) (* Semantics has changed, no ctrl-dep on mv *) let check_morello_perms a ma mv perms mok mfault = M.delay_kont "morello_perms" mv (fun v mv -> let v = if String.contains perms 'w' && String.contains perms 'c' then v else M.A.V.zero in M.op (Op.CheckPerms perms) a v >>= fun cond -> M.choiceT cond (mok ma mv) (mfault ma mv)) let process_read_capability sz a m ii = match sz with | MachSize.S128 -> (M.op1 Op.CapaStrip a >>= fun a -> M.add_atomic_tag_read (m a) a (fun loc v -> Act.tag_access quad Dir.R loc v) ii) >>= fun v -> M.op Op.SquashMutable a v | _ -> M.op1 Op.CapaStrip a >>= fun a -> m a >>= fun v -> M.op Op.CapaSetTag v V.zero (****************) (* PTW checking *) (****************) (* Group pteval components together *) type ipte = { oa_v : V.v; af_v : V.v; db_v : V.v; dbm_v : V.v; valid_v : V.v; el0_v : V.v; tagged_v : V.v; } let arch_op1 op = M.op1 (Op.ArchOp1 op) let extract_af v = arch_op1 AArch64Op.AF v let extract_db v = arch_op1 AArch64Op.DB v let extract_dbm v = arch_op1 AArch64Op.DBM v let extract_valid v = arch_op1 AArch64Op.Valid v let extract_el0 v = arch_op1 AArch64Op.EL0 v let extract_oa v = arch_op1 AArch64Op.OA v let extract_tagged v = arch_op1 AArch64Op.Tagged v let mextract_whole_pte_val an nexp a_pte iiid = (M.do_read_loc false (fun loc v -> Act.Access (Dir.R,loc,v,an,nexp,quad,Access.PTE)) (A.Location_global a_pte) iiid) and write_whole_pte_val an explicit a_pte v iiid = M.do_write_loc (mk_write quad an explicit Access.PTE v) (A.Location_global a_pte) iiid let op_of_set = let open AArch64 in function | AF -> AArch64Op.SetAF | DB -> AArch64Op.SetDB | IFetch|Other|AFDB -> assert false let do_test_and_set_bit combine cond set a_pte iiid = let nexp = AArch64.NExp set in mextract_whole_pte_val Annot.X nexp a_pte iiid >>= fun pte_v -> cond pte_v >>*= fun c -> combine c (arch_op1 (op_of_set set) pte_v >>= fun v -> write_whole_pte_val Annot.X nexp a_pte v iiid) (M.unitT ()) let test_and_set_bit_succeeds cond = do_test_and_set_bit (fun c m _ -> M.assertT c m) cond let bit_is_zero op v = arch_op1 op v >>= is_zero let bit_is_not_zero op v = arch_op1 op v >>= is_not_zero let m_op op m1 m2 = (m1 >>| m2) >>= fun (v1,v2) -> M.op op v1 v2 let do_set_bit an a_pte pte_v ii = let nexp = AArch64.NExp an in arch_op1 (op_of_set an) pte_v >>= fun v -> write_whole_pte_val Annot.X nexp a_pte v (E.IdSome ii) let set_af = do_set_bit AArch64.AF let set_afdb a_pte pte_v ii = let nexp = AArch64.NExp AArch64.AFDB in arch_op1 (AArch64Op.SetAF) pte_v >>= arch_op1 (AArch64Op.SetDB) >>= fun v -> write_whole_pte_val Annot.X nexp a_pte v (E.IdSome ii) let cond_af v = m_op Op.And (bit_is_zero AArch64Op.AF v) (bit_is_not_zero AArch64Op.Valid v) let test_and_set_af_succeeds = test_and_set_bit_succeeds cond_af AArch64.AF let mextract_pte_vals pte_v = (extract_oa pte_v >>| extract_el0 pte_v >>| extract_valid pte_v >>| extract_af pte_v >>| extract_db pte_v >>| extract_dbm pte_v >>| extract_tagged pte_v) >>= (fun ((((((oa_v,el0_v),valid_v),af_v),db_v),dbm_v),tagged_v) -> M.unitT {oa_v; af_v; db_v; dbm_v; valid_v; el0_v; tagged_v}) let get_oa a_virt mpte = (M.op1 Op.Offset a_virt >>| mpte) >>= fun (o,(_,ipte)) -> M.add ipte.oa_v o (************************************************) (* Add commit events, when commanded by options *) (************************************************) let append_commit ma txt ii = if is_branching then do_append_commit ma txt ii else ma let do_insert_commit m1 m2 ii = (* Notice the complex dependency >>*== from branch to instructions events *) m1 >>= fun a -> commit_pred ii >>*== fun _ -> m2 a let do_insert_commit_to_fault m1 m2 txt ii = (* Dependencies to fault are simple: Rpte -data-> Branch -> Fault *) M.bind_data_to_minimals m1 (fun a -> commit_pred_txt txt ii >>*= fun () -> m2 a) let insert_commit_to_fault m1 m2 txt ii = if is_branching || morello then do_insert_commit_to_fault m1 m2 txt ii else m1 >>*= m2 (* Direct control dependency to fault *) (******************) (* Checking flags *) (******************) (* With choice operator *) let do_check_cond m m_cond k1 k2 = M.delay_kont "1" (m >>= fun (_,pte_v as p) -> m_cond pte_v >>= fun c -> M.unitT (c,p)) (fun (c,p) m -> let m = m >>= fun _ -> M.unitT p in M.choiceT c (k1 m) (k2 m)) (* Summary of access flag and dirty bit management. * Without HW-management (on old CPUs, or where TCR_ELx.{HA,HD} == {0,0}): A load/store to x where pte_x has the access flag clear will raise a permission fault A store to x where pte_x has the dirty bit clear will raise a permission fault and SW is expected to deal with this by updating the translation tables with explicit stores or atomics * With HW management (i.e. when ARMv8.1-TTHM is implemented) where TCR_ELx.HA = 1: A load/store to x where pte_x has the access flag clear results in the MMU updating the translation table entry to set the access flag, and continuing without a fault. A store where pte_x has the dirty bit clear will raise a permission fault. * With HW management (i.e. when ARMv8.1-TTHM is implemented) where TCR_ELx.{HA,HD} == {1,1}: A load/store to x where pte_x has the access flag clear results in the MMU updating the translation table entry to set the access flag, and continuing without a fault. A store to x where pte_x has the dirty bit clear and also has DBM clear will raise a permission fault A store to x where pte_x has the dirty bit clear and has DBM set results in the MMU updating the translation table entry to set the dirty bit, and continuing without a fault. Notice: The dirty bit correspond to HW level write permission in PTE's. Hence, in simple (stage 1) case, we have AP[2] == 0b1 for clean, and AP[2] == 0b0 for dirty, with AP[2] == 0b0 being more directly "writable". *) let mk_pte_fault a ma dir an ii = let open FaultType.AArch64 in let ft = Some (MMU Permission) in insert_commit_to_fault ma (fun _ -> mk_fault (Some a) dir an ii ft (Some "EL0")) None ii >>! B.Exit let an_xpte = let open Annot in function | A|XA -> XA | Q|XQ -> XQ | L|XL -> XL | X|N -> X | NoRet|S|NTA -> X (* Does it occur? *) let an_pte = let open Annot in function | A|XA -> A | Q|XQ -> Q | L|XL -> L | X|N -> N | NoRet|S|NTA -> N let check_ptw proc dir updatedb is_tag a_virt ma an ii mdirect mok mfault = let is_el0 = List.exists (Proc.equal proc) TopConf.procs_user in let check_el0 m = (* Handler runs at level more priviledged than EL0 *) if not ii.A.in_handler && is_el0 then fun pte_v -> m_op Op.Or (is_zero pte_v.el0_v) (m pte_v) else m in let open DirtyBit in let tthm = dirty.tthm proc and ha = dirty.ha proc and hd = dirty.hd proc in let ha = ha || hd in (* As far as we know hd => ha *) let mfault (_,ipte) m = let open FaultType.AArch64 in (is_zero ipte.valid_v) >>= (fun c -> M.choiceT c (M.unitT (Some (MMU Translation))) (if ha then M.unitT (Some (MMU Permission)) else begin (is_zero ipte.af_v) >>= (fun c -> M.choiceT c (M.unitT (Some (MMU AccessFlag))) (M.unitT (Some (MMU Permission)))) end) >>= fun t -> mfault (get_oa a_virt m) a_virt t) and mok (pte_v,ipte) a_pte m a = let m = let msg = match dir with | Dir.W -> if hd then "valid:1 && (db:1 || dbm:1 && hd)" else if ha then "valid:1 && db:1" else "valid:1 && af:1 && db:1" | Dir.R -> if ha then "valid:1" else "valid:1 && af:1" in let prefix = if is_tag then "Tag, " else "Data, " in let msg = if memtag then prefix ^ msg else msg in let m = append_commit m (Some msg) ii in let add_setbits cond txt set no = cond >>= fun c -> M.choiceT c (m >>**== (fun _ -> commit_pred_txt (Some txt) ii >>*= fun _ -> set a_pte pte_v ii) >>== fun () -> M.unitT (pte_v,ipte)) no in let add_setbits_db ipte m = add_setbits (m_op Op.Or (is_zero ipte.af_v) (is_zero ipte.db_v)) "af:0 || db:0" set_afdb m in let add_setbits_af ipte m = add_setbits (is_zero ipte.af_v) "af:0" set_af m in let setbits = match dir with | Dir.W -> if hd && updatedb then add_setbits_db ipte m else if ha then add_setbits_af ipte m else m | Dir.R -> if hd && updatedb then (* The case of a failed CAS with no write, but with a db update *) M.altT ( add_setbits_db ipte m )( (* no need to check ha, because hd implies ha *) add_setbits_af ipte m ) else if ha then add_setbits_af ipte m else m in setbits in mok m a in (* Action on case of page table access. Delay is used so as to have correct dependencies, getting content of PTE by anticipation. *) let mvirt = begin M.delay_kont "3" begin ma >>= fun _ -> M.op1 Op.PTELoc a_virt >>= fun a_pte -> let an,nexp = if hd then (* Atomic accesses, tagged with updated bits *) an_xpte an,AArch64.NExp AArch64.AFDB else if ha then an_xpte an,AArch64.NExp AArch64.AF else (* Ordinary non-explicit access *) an_pte an,AArch64.nexp_annot in mextract_whole_pte_val an nexp a_pte (E.IdSome ii) >>== fun pte_v -> (mextract_pte_vals pte_v) >>= fun ipte -> M.unitT ((pte_v,ipte),a_pte) end (fun (pair_pte,a_pte) ma -> (* now we have PTE content *) (* Monad will carry changing internal pte value *) let ma = ma >>= fun (p,_) -> M.unitT p in (* wrapping of success/failure continuations, only pte value may have changed *) let mok ma = mok pair_pte a_pte ma a_virt (* a_virt was (if pte2 then a_virt else pte_v.oa_v), why? *) and mno ma = mfault pair_pte ma in let check_cond cond = do_check_cond ma (check_el0 cond) mno mok in if (not tthm || (tthm && (not ha && not hd))) then (* No HW management *) let cond_R pte_v = m_op Op.Or (is_zero pte_v.valid_v) (is_zero pte_v.af_v) in let cond = match dir with (* No mercy, check all flags *) | Dir.R -> cond_R | Dir.W -> fun pte_v -> m_op Op.Or (cond_R pte_v) (is_zero pte_v.db_v) in check_cond cond else if (tthm && ha && not hd) then (* HW managment of AF *) let cond = match dir with (* Do not check AF *) | Dir.R -> fun pte_v -> is_zero pte_v.valid_v | Dir.W -> fun pte_v -> m_op Op.Or (is_zero pte_v.valid_v) (is_zero pte_v.db_v) in check_cond cond else (* HW management of AF and DB *) let cond = match dir with (* Do not check AF *) | Dir.R -> fun pte_v -> is_zero pte_v.valid_v | Dir.W -> (* Check DB when dirty bit management disabled for this page *) fun pte_v -> m_op Op.Or (is_zero pte_v.valid_v) (m_op Op.And (is_zero pte_v.db_v) (is_zero pte_v.dbm_v)) in check_cond cond) end in if pte2 then mvirt else M.op1 Op.IsVirtual a_virt >>= fun cond -> M.choiceT cond mvirt (* Non-virtual accesses are disallowed from EL0. For instance, user code cannot access the page table. *) (if is_el0 then mk_pte_fault a_virt ma dir an ii else mdirect) (* Read memory, return value read *) let do_read_mem_ret sz an anexp ac a ii = let m a = if mixed then begin Mixed.read_mixed false sz (fun sz -> mk_read sz an anexp) a ii end else begin let mk_act loc v = Act.Access (Dir.R,loc,v,an,anexp,sz,ac) in let loc = A.Location_global a in M.read_loc false mk_act loc ii end in if morello then process_read_capability sz a m ii else m a (* Save value read in register rd *) let do_read_mem_op op sz an anexp ac rd a ii = do_read_mem_ret sz an anexp ac a ii >>= fun v -> write_reg_op op sz rd v ii >>= fun () -> B.nextT let do_read_mem sz = do_read_mem_op (uxt_op sz) sz let read_mem_acquire sz = do_read_mem sz Annot.A let read_mem_acquire_pc sz = do_read_mem sz Annot.Q let read_mem_reserve sz an anexp ac rd a ii = let m a = (write_reg AArch64.ResAddr a ii >>| do_read_mem sz an anexp ac rd a ii) >>= fun ((),b) -> M.unitT b in if morello then M.op1 Op.CapaStrip a >>= m else m a (* Post-Indexed load immediate. Note: a (effective address) can be physical address, while postindex must apply to virtual address. *) let read_mem_postindexed a_virt op sz an anexp ac rd rs k a ii = let m a = begin (M.add a_virt (V.intToV k) >>= fun b -> write_reg rs b ii) >>| do_read_mem_op op sz an anexp ac rd a ii end >>= fun ((),r) -> M.unitT r in if morello then M.op1 Op.CapaStrip a >>= m else m a (* Write *) let check_mixed_write_mem sz an anexp ac a v ii = if mixed then begin Mixed.write_mixed sz (fun sz loc v -> mk_write sz an anexp ac v loc) a v ii end else M.write_loc (mk_write sz an anexp ac v) (A.Location_global a) ii let check_morello_for_write m a v ii = if morello then M.op1 Op.CapaStrip a >>| M.op1 Op.CapaGetTag v >>= fun (a,tag) -> M.add_atomic_tag_write (m a) a tag (fun loc v -> Act.tag_access quad Dir.W loc v) ii else m a let do_write_mem sz an anexp ac a v ii = check_morello_for_write (fun a -> check_mixed_write_mem sz an anexp ac a v ii) a v ii let write_mem sz = do_write_mem sz Annot.N (* Write atomic *) let write_mem_atomic sz an anexp ac a v resa ii = check_morello_for_write (fun a -> ((if do_cu (* If CU allowed, write may succeed whatever the address _a_ is *) then M.unitT () else M.assign a resa) >>| check_mixed_write_mem sz an anexp ac a v ii) >>! ()) a v ii (* Page tables and TLBs *) let do_inv op a ii = inv_loc op (A.Location_global a) ii (************************) (* Conditions and flags *) (************************) (* Force integer representation of booleans. Useful for the ASL case *) let forceIntBool b = M.op3 Op.If b V.one V.zero let tr_cond = (* Utils for writing formulas: Here we do operations on functions that will generate the underlying monadic operations. We first define our fake variables, then a few logical operations on those.*) (* Variables *) let n = M.op1 (Op.ReadBit 3) in let z = M.op1 (Op.ReadBit 2) in let c = M.op1 (Op.ReadBit 1) in let v = M.op1 (Op.ReadBit 0) in let true_ = fun _flags -> M.unitT V.one in (* Operators *) (* Note: I use [!a] as a shortcut for [a == 0], and [a] as a shortcut for [a == 1] (the expended version is the one written in the ARM ARM). *) let ( ! ) f flags = f flags >>= M.op Op.Eq V.zero in let make_op op f1 f2 flags = f1 flags >>| f2 flags >>= fun (v1, v2) -> M.op op v1 v2 in let ( == ) = fun f1 f2 flags -> make_op Op.Eq f1 f2 flags >>= forceIntBool in let ( || ) = make_op Op.Or in let ( && ) = make_op Op.And in (* Note : I use [a <> b] as a shortcut for [!a == b] (the expended version is the one written in the ARM ARM). *) let ( <> ) = make_op Op.Xor in let open AArch64Base in (* The real operations, as defined by the ARM ARM. *) function | NE -> !z | EQ -> z | GE -> n == v | GT -> n == v && !z (* Note: for LE, the ARM ARM gives [!(!z && n == v)] here, but I've applied De Morgan's law. *) | LE -> n <> v || z | LT -> n <> v | CS -> c | CC -> !c | MI -> n | PL -> !n | VS -> v | VC -> !v | HI -> c && !z (* Note: for LS, the ARM ARM gives [!(c && !z)] here, but I've applied De Morgan's law. *) | LS -> !c || z | AL -> true_ (* Arithmetic flags handling *) let op_set_flags op ty = let open AArch64Base in (* Utils for writing formulas - We use a base functional type, this surely impacts performance, but clarity is improved. - We surcharge common operators to use our own functional types. - The main values come from the three arguments passed to every functions - The performance cost is never on operations that do not set flags, and mainly on ADDS/SUBS. It consists on an extra monad for every variable used. *) (* Main variables *) let res v0 _v1 _v2 = M.unitT v0 in let x _v0 v1 _v2 = M.unitT v1 in let y _v0 _v1 v2 = M.unitT v2 in (* Operators on those variables *) let make_op op f1 f2 v0 v1 v2 = f1 v0 v1 v2 >>| f2 v0 v1 v2 >>= fun (a, b) -> M.op op a b in let make_op1 fop f v0 v1 v2 = f v0 v1 v2 >>= fop in let ( ! ) = make_op1 (M.op1 Op.Inv) in let ( & ) = make_op Op.And in let ( || ) = make_op Op.Or in let ( + ) = make_op Op.Xor in let ( === ) f v = (* Force integer result of comparison *) fun v0 v1 v2 -> f v0 v1 v2 >>= M.op Op.Eq v >>= forceIntBool in let ( << ) f i = make_op1 (M.op1 (Op.LeftShift i)) f in let sign_bit = MachSize.nbits (AArch64Base.tr_variant ty) - 1 in let read_sign_bit = make_op1 (M.op1 (Op.ReadBit sign_bit)) in let ( ---> ) f i = ( read_sign_bit f ) << i in (* Computation of nz flags *) let compute_nz = let compute_z = ( res === V.zero ) << 2 in let compute_n = read_sign_bit res << 3 in compute_z || compute_n in (* Operation specific computations For specific formulae, see Hacker's Delight, 2-13.*) match op with |ADD|EOR|EON|ORR|ORN|SUB|AND|ASR|LSR|ROR|LSL|BIC -> None |ANDS|BICS -> Some compute_nz |ADDS -> let x = make_op Op.ToInteger x res and y = make_op Op.ToInteger y (fun _ _ _ -> mzero) in let compute_c = ((x & y) || ((x || y) & !res)) ---> 1 in let compute_v = ((res + x) & (res + y)) ---> 0 in Some (compute_nz || compute_c || compute_v) | SUBS -> (* This is the formula give by Hacker's Delight for the carry in an unsigned subtraction: (!x & y) || ((!x || y) & res) But I use the formula given by Hacker's Delight for the carry in an unsigned addition, with y replaced by !y, as the Arm ARM specifies the subtraction as: x - y := x + !y + 1 This gives the following formula, which seems to produce the same results as hardware: *) let x = make_op Op.ToInteger x res and y = make_op Op.ToInteger y (fun _ _ _ -> mzero) in let compute_c = ((x & !y) || ((x || !y) & !res)) ---> 1 in let compute_v = ((x + y) & (res + x)) ---> 0 in Some (compute_nz || compute_c || compute_v) let mop3 inst v op rd margs ii = let open AArch64Base in margs >>= begin let with_correct_size f arg = f arg >>= mask32 v M.unitT in let do_write_reg v = write_reg_dest rd v ii in let write_reg_no_flags f arg = let without_flags v = M.unitT (v, None) in with_correct_size f arg >>= do_write_reg >>= without_flags in match v with | V128 -> check_morello inst; let tr_op = function | ADD -> Op.CapaAdd | SUB -> Op.CapaSub | SUBS -> Op.CapaSubs | op -> Warn.fatal "Operation '%s' is not available in morello mode" (AArch64.pp_op op) in write_reg_no_flags (fun (v1,v2) -> M.op (tr_op op) v1 v2) | (V64|V32) -> let get_res (v1,v2) = match op with | ADD | ADDS -> M.add v1 v2 | EOR -> M.op Op.Xor v1 v2 | EON -> M.op1 Op.Inv v2 >>= M.op Op.Xor v1 | ORR -> M.op Op.Or v1 v2 | ORN -> M.op1 Op.Inv v2 >>= M.op Op.Or v1 | SUB | SUBS -> M.op Op.Sub v1 v2 | AND | ANDS -> M.op Op.And v1 v2 | ASR -> M.op1 (Op.Mask (tr_variant v)) v2 >>= M.op Op.ASR v1 | LSR -> M.op1 (Op.Mask (tr_variant v)) v2 >>= M.op Op.Lsr v1 | LSL -> M.op1 (Op.Mask (tr_variant v)) v2 >>= M.op Op.ShiftLeft v1 | ROR -> let sz = tr_variant v in let nbits = MachSize.nbits sz in M.op1 (Op.Mask sz) v2 >>= fun v2 -> (M.op Op.Lsr v1 v2 >>| (M.op Op.Sub (V.intToV nbits) v2 >>= M.op Op.ShiftLeft v1)) >>= fun (v1,v2) -> M.op Op.Or v1 v2 | BIC | BICS -> M.op Op.AndNot2 v1 v2 in match op_set_flags op v with | None -> write_reg_no_flags get_res | Some get_flags -> let do_write_flags flags = write_reg_dest NZCV flags ii in let return_flags flags = M.unitT (Some flags) in let compute_and_write_flags res v1 v2 = get_flags res v1 v2 >>= do_write_flags >>= return_flags in fun (v1, v2 as p) -> with_correct_size get_res p >>= fun res -> do_write_reg res >>| compute_and_write_flags res v1 v2 end >>= fun (v,wo) -> begin match wo with | None -> B.nextSetT rd v | Some w -> M.unitT (B.Next [rd,v; NZCV,w]) end (***************************) (* Various lift functions. *) (***************************) (* Those fonction take genric 'mop' memory operations, and change their behaviour according to variants. Most lift function introduce validity checks on addresses. Thus the resulting monads will possess extra dependencies w.r.t the simple case. *) (* memtag faults *) let get_instr_label ii = match Label.norm ii.A.labels with | Some hd -> ii.A.addr2v hd | None -> V.intToV ii.A.addr let set_elr_el1 v ii = write_reg AArch64Base.elr_el1 v ii let lift_fault_memtag mfault mm dir ii = let lbl_v = get_instr_label ii in if has_handler ii then fun ma -> M.bind_ctrldata ma (fun _ -> mfault >>| set_elr_el1 lbl_v ii) >>! B.Fault [AArch64Base.elr_el1, lbl_v] else let open Precision in match C.mte_precision,dir with | (Synchronous,_)|(Asymmetric,(Dir.R)) -> fun ma -> ma >>*= (fun _ -> mfault >>| set_elr_el1 lbl_v ii) >>! B.Fault [AArch64Base.elr_el1, lbl_v] | (Asynchronous,_)|(Asymmetric,Dir.W) -> fun ma -> let set_tfsr = write_reg AArch64Base.tfsr V.one ii in let ma = ma >>*== (fun a -> (set_tfsr >>| mfault) >>! a) in mm ma >>! B.Next [] (* KVM mode *) let some_ha = dirty.DirtyBit.some_ha || dirty.DirtyBit.some_hd let fire_spurious_af dir a m = if some_ha && (let v = C.variant Variant.PhantomOnLoad in match dir with Dir.W -> not v | Dir.R -> v) then (m >>| M.altT (test_and_set_af_succeeds a E.IdSpurious) (M.unitT ())) >>= fun (r,_) -> M.unitT r else m let lift_kvm dir updatedb mop ma an ii mphy = let lbl_v = get_instr_label ii in let mfault ma a ft = insert_commit_to_fault ma (fun _ -> set_elr_el1 lbl_v ii >>| mk_fault (Some a) dir an ii ft None) None ii >>! B.Fault [AArch64Base.elr_el1, lbl_v] in let maccess a ma = check_ptw ii.AArch64.proc dir updatedb false a ma an ii ((let m = mop Access.PTE ma in fire_spurious_af dir a m) >>= M.ignore >>= B.next1T) mphy mfault in M.delay_kont "6" ma ( if pte2 then maccess else fun a ma -> match Act.access_of_location_std (A.Location_global a) with | Access.VIR|Access.PTE when not (A.V.is_instrloc a) -> maccess a ma | ac -> mop ac ma >>= M.ignore >>= B.next1T ) let lift_memtag_phy dir mop ma an ii mphy = let checked_op mpte_d a_virt = let mok mpte_t = let ma = M.para_bind_output_right mpte_t (fun _ -> mpte_d) in mphy ma a_virt >>= M.ignore >>= B.next1T and mno mpte_t = let ma = M.para_bind_output_right mpte_t (fun _ -> mpte_d) in let ft = Some FaultType.AArch64.TagCheck in let mm ma = ma >>= M.ignore >>= B.next1T in let fault = lift_fault_memtag (mk_fault (Some a_virt) dir an ii ft None) mm dir ii in fault ma >>! B.Fault [] in let check_tag moa a_virt = let do_check_tag a_phy moa = delayed_check_tags a_virt (Some a_phy) moa ii mok mno in M.delay_kont "check_tag" moa do_check_tag in let cond_check_tag mpte_t a_virt = (* Only read and check the tag if the PTE of the tag op allows it *) M.delay_kont "cond_check_tag" mpte_t @@ fun (_,ipte) mpte_t -> let moa = get_oa a_virt mpte_t in M.choiceT (ipte.tagged_v) (check_tag moa a_virt) (mok moa) and mfault ma a ft = let ma = let commit _ = commit_pred_txt None ii in ma >>= commit in let ma = M.para_bind_output_right ma (fun _ -> mpte_d) in let lbl_v = get_instr_label ii in ma >>*= fun _ -> set_elr_el1 lbl_v ii >>| mk_fault (Some a) dir an ii ft None >>! B.Fault [AArch64Base.elr_el1, lbl_v] in M.delay_kont "tag_ptw" ma @@ fun a ma -> let mdirect = let m = mop Access.PTE ma in fire_spurious_af dir a m >>= M.ignore >>= B.next1T in check_ptw ii.AArch64.proc Dir.R false true a ma an ii mdirect cond_check_tag mfault in fun mpte a_virt -> M.delay_kont "need_check_tag" mpte @@ fun (_,ipte) mpte -> M.choiceT (ipte.tagged_v) (checked_op mpte a_virt) (mphy mpte a_virt) let lift_memtag_virt mop ma dir an ii = M.delay_kont "5" ma (fun a_virt ma -> let mm = mop Access.VIR in let ft = Some FaultType.AArch64.TagCheck in delayed_check_tags a_virt None ma ii (fun ma -> mm ma >>= M.ignore >>= B.next1T) (lift_fault_memtag (mk_fault (Some a_virt) dir an ii ft None) mm dir ii)) let lift_morello mop perms ma mv dir an ii = let mfault msg ma mv = let ft = None in (* FIXME *) do_insert_commit (ma >>| mv) (fun (a,_v) -> mk_fault (Some a) dir an ii ft (Some msg)) ii >>! B.Exit in M.delay_kont "morello" ma (fun a ma -> (* Notice: virtual access only, because morello # kvm *) let mok ma mv = mop Access.VIR ma mv in check_morello_tag a ma mv (fun ma mv -> check_morello_sealed a ma mv (fun ma mv -> check_morello_perms a ma mv perms (fun ma mv -> mok ma mv >>= M.ignore >>= B.next1T) (mfault "CapPerms")) (mfault "CapSeal")) (mfault "CapTag")) (* Main choice between supported variants, notice: + memtag and kvm can be combined, other variants cannot. + mv abstracted for morello sake only + ma abstracted for all variants *) let to_perms str sz = str ^ if sz = MachSize.S128 then "_c" else "" let apply_mv mop mv = fun ac ma -> mop ac ma mv let is_this_reg rA e = match E.location_reg_of e with | None -> false | Some rB -> AArch64.reg_compare rA rB=0 let lift_memop rA (* Base address register *) dir updatedb checked mop perms ma mv an ii = if morello then lift_morello mop perms ma mv dir an ii else let mop = apply_mv mop mv in if kvm then let mphy ma a_virt = let ma = get_oa a_virt ma in if pte2 then M.op1 Op.IsVirtual a_virt >>= fun c -> M.choiceT c (mop Access.PHY ma) (fire_spurious_af dir a_virt (mop Access.PHY_PTE ma)) >>= M.ignore >>= B.next1T else mop Access.PHY ma >>= M.ignore >>= B.next1T in let mphy = if checked then lift_memtag_phy dir mop ma an ii mphy else mphy in let m = lift_kvm dir updatedb mop ma an ii mphy in (* M.short will add an iico_data only if memtag is enabled *) M.short (is_this_reg rA) (E.is_pred_txt (Some "color")) m else if checked then lift_memtag_virt mop ma dir an ii else mop Access.VIR ma >>= M.ignore >>= B.next1T let do_ldr rA sz an mop ma ii = (* Generic load *) lift_memop rA Dir.R false memtag (fun ac ma _mv -> (* value fake here *) let open Precision in let memtag_sync = memtag && (C.mte_precision = Synchronous || C.mte_precision = Asymmetric) in if memtag_sync || Access.is_physical ac then M.bind_ctrldata ma (mop ac) else ma >>= mop ac) (to_perms "r" sz) ma mzero an ii (* Generic store *) let do_str rA mop sz an ma mv ii = lift_memop rA Dir.W true memtag (fun ac ma mv -> let open Precision in let memtag_sync = memtag && C.mte_precision = Synchronous in if memtag_sync || (is_branching && Access.is_physical ac) then begin (* additional ctrl dep on address *) M.bind_ctrldata_data ma mv (fun a v -> mop ac a v ii) end else if morello then (* additional ctrl dep on address and data *) do_insert_commit (ma >>| mv) (fun (a,v) -> mop ac a v ii) ii else (ma >>| mv) >>= fun (a,v) -> mop ac a v ii) (to_perms "w" sz) ma mv an ii (***********************) (* Memory instructions *) (***********************) (* Compute shifts, signed and unsigned extension, etc. *) let do_shift op k = match k with | 0 -> M.unitT | _ -> M.op1 op let lsl_op k = do_shift (Op.LeftShift k) k and lsr_op sz k v = uxt_op sz v >>= do_shift (Op.LogicalRightShift k) k and asr_op sz k v = sxt_op sz v >>= do_shift (Op.ArithRightShift k) k let ror_op sz k v = let n = MachSize.nbits sz in let m = k mod n in begin lsr_op sz m v >>| lsl_op (n-m) v end >>= fun (v1,v2) -> M.op Op.Or v1 v2 let opext_shift sz = let open AArch64Base.OpExt in function | LSL s -> lsl_op s | LSR s -> lsr_op sz s | ASR s -> asr_op sz s | ROR s -> ror_op sz s let ext_sext e ko v = let k = match ko with None -> 0 | Some k -> k in lsl_op k v >>= M.op1 begin let open AArch64.Ext in let open MachSize in match e with | UXTB -> Op.Mask Byte | UXTH -> Op.Mask Short | UXTW -> Op.Mask Word | UXTX -> Op.Mask Quad | SXTB -> Op.Sxt Byte | SXTH -> Op.Sxt Short | SXTW -> Op.Sxt Word | SXTX -> Op.Sxt Quad end (* Apply a shift as monadic op *) let shift sz s = let open AArch64Base in match s with | S_NOEXT -> M.unitT | S_LSL(n) | S_MSL(n) -> lsl_op n | S_LSR(n) -> lsr_op sz n | S_ASR(n) -> asr_op sz n let memext_sext sext s v = let open AArch64Base.MemExt in let m_shift = lsl_op s and m_sext = match sext with | UXTW -> uxtw_op | SXTW -> sxtw_op | LSL|SXTX -> M.unitT in m_sext v >>= m_shift (* Complete effective adress computation *) let get_ea rs kr s ii = let open AArch64Base in match kr, s with | K 0, S_NOEXT -> (* Immediate with no shift*) read_reg_ord rs ii | K k, s -> (* Immediate with offset, with shift *) read_reg_ord rs ii >>= fun v -> shift MachSize.Quad s (V.intToV k) >>= M.add v | RV(_,r), S_NOEXT -> (* register, no shift *) (read_reg_ord rs ii >>| read_reg_ord r ii) >>= fun (v1,v2) -> M.add v2 v1 | RV(v,r), s -> (* register, with shift *) (read_reg_ord rs ii >>| read_reg_ord r ii) >>= fun (v1,v2) -> shift (tr_variant v) s v2 >>= fun v2 -> M.add v1 v2 let get_ea_idx rs k ii = get_ea rs (AArch64.K k) AArch64.S_NOEXT ii let get_ea_preindexed rs k ii = get_ea_idx rs k ii >>== fun v -> write_reg_dest rs v ii let get_ea_reg rs _v ri sext s ii = read_reg_ord rs ii >>| (read_reg_ord ri ii >>= memext_sext sext s) >>= fun (v1,v2) -> M.add v1 v2 let add_size a sz = M.add a (V.intToV (MachSize.nbytes sz)) let post_kr rA addr kr ii = let open AArch64Base in let get_k = match kr with | K k -> M.unitT (V.intToV k) | RV(_,rO) -> read_reg_ord rO ii in get_k >>= fun k -> if V.is_var_determined k && V.is_zero k then M.unitT() else M.add addr k >>= fun new_addr -> write_reg rA new_addr ii (* Ordinary loads *) let ldr0 op sz rd rs e ii = let open AArch64Base in let open MemExt in let mop ac a = do_read_mem_op op sz Annot.N aexp ac rd a ii in match e with | Imm (k,Idx) -> do_ldr rs sz Annot.N mop (get_ea_idx rs k ii) ii | Imm (k,PreIdx) -> do_ldr rs sz Annot.N mop (get_ea_preindexed rs k ii) ii | Reg (v,ri,sext,s) -> do_ldr rs sz Annot.N mop (get_ea_reg rs v ri sext s ii) ii | Imm (k,PostIdx) -> (* This case differs signicantly from others, * as update of base address register is part * of the "read memory" monad, which thus departs * from the ordinary `do_read_mem`. *) M.delay_kont "ldr_postindex" (read_reg_ord rs ii) (fun a_virt ma -> do_ldr rs sz Annot.N (fun ac a -> read_mem_postindexed a_virt op sz Annot.N aexp ac rd rs k a ii) ma ii) | _ -> assert false let ldr sz = ldr0 (uxt_op sz) sz and ldrsw rd rs e ii = let sz = MachSize.Word in ldr0 (sxt_op sz) sz rd rs e ii and ldrs sz var = (* * Load signed - sign extends to either 32 or 64 bit value * load either 8 or 16 bit value (sz), * then sign extend based on register size (var) *) let op = match var with | MachSize.Quad -> sxt_op sz | MachSize.Word -> fun v -> sxt_op sz v >>= uxt_op MachSize.Word | _ -> assert false in ldr0 op sz module LoadPair (Read: sig val read_mem : MachSize.sz -> AArch64.lannot -> AArch64.explicit -> Access.t -> AArch64.reg -> V.v -> M.A.inst_instance_id -> B.t M.t end) = struct let ldp_wback sz an rd1 rd2 rs k post ii = let m = M.delay_kont "ldp_wback" (read_reg_ord rs ii >>= add_if (not post) k) (fun a_virt ma -> do_ldr rs sz Annot.N (fun ac a -> (add_if post k a_virt >>= fun b -> write_reg rs b ii) >>| let (>>|) = match an with | Annot.Q -> assert post ; M.seq_mem | _ -> (>>|) in (Read.read_mem sz an aexp ac rd1 a ii >>| begin add_size a sz >>= fun a -> Read.read_mem sz an aexp ac rd2 a ii end)) ma ii >>= fun _ -> add_if post k a_virt >>= fun a -> M.unitT (B.Next [rs,a])) in if kvm then M.upOneRW (is_this_reg rs) m else m let ldp tnt sz rd1 rd2 rs (k,md) ii = let an = let open AArch64 in let open Annot in match tnt with | Pa -> N | PaN -> NTA | PaI -> Q in let open AArch64 in match md with | Idx -> let (>>|) = match an with | Annot.Q -> M.seq_mem | _ -> (>>|) in do_ldr rs sz Annot.N (fun ac a -> Read.read_mem sz an aexp ac rd1 a ii >>| begin add_size a sz >>= fun a -> Read.read_mem sz an aexp ac rd2 a ii end) (get_ea_idx rs k ii) ii | PostIdx -> ldp_wback sz an rd1 rd2 rs k true ii | PreIdx -> ldp_wback sz an rd1 rd2 rs k false ii end let ldp = let module LDP = LoadPair (struct let read_mem = do_read_mem end) in LDP.ldp let ldpsw = let module LDPSW = LoadPair (struct let read_mem = do_read_mem_op sxtw_op end) in LDPSW.ldp AArch64.Pa MachSize.Word let ldxp sz t rd1 rd2 rs ii = let open AArch64 in let open Annot in let an = match t with XP -> X | AXP -> XA in do_ldr rs sz an (fun ac a -> read_mem_reserve sz an aexp ac rd1 a ii >>|| begin add_size a sz >>= fun a -> do_read_mem sz an aexp ac rd2 a ii end) (read_reg_ord rs ii) ii and ldar sz t rd rs ii = let open AArch64 in let an = match t with | XX -> Annot.X | AA -> Annot.A | AX -> Annot.XA | AQ -> Annot.Q in do_ldr rs sz an (fun ac a -> let read = match t with | XX -> read_mem_reserve sz Annot.X | AA -> read_mem_acquire sz | AX -> read_mem_reserve sz Annot.XA | AQ -> read_mem_acquire_pc sz in read aexp ac rd a ii) (read_reg_ord rs ii) ii let str_simple sz rs rd m_ea ii = do_str rd (fun ac a _ ii -> M.data_input_next (read_reg_data sz rs ii) (fun v -> do_write_mem sz Annot.N aexp ac a v ii)) sz Annot.N m_ea (M.unitT V.zero) ii let str sz rs rd e ii = let open AArch64Base in let open MemExt in match e with | Imm (k,Idx) -> str_simple sz rs rd (get_ea_idx rd k ii) ii | Imm (k,PostIdx) -> let m = M.delay_kont "str_post" (read_reg_ord rd ii) (fun a_virt ma -> do_str rd (fun ac a _ ii -> M.add a_virt (V.intToV k) >>= fun b -> write_reg rd b ii >>| M.data_input_next (read_reg_data sz rs ii) (fun v -> do_write_mem sz Annot.N aexp ac a v ii)) sz Annot.N ma (M.unitT V.zero) ii) in if kvm then M.upOneRW (is_this_reg rd) m else m | Imm (k,PreIdx) -> str_simple sz rs rd (get_ea_preindexed rd k ii) ii | Reg (v,ri,sext,s) -> str_simple sz rs rd (get_ea_reg rd v ri sext s ii) ii | _ -> assert false let stp_wback = let (>>>) = M.data_input_next in fun sz an rs1 rs2 rd k post ii -> let m = M.delay_kont "stp_wback" (read_reg_ord rd ii >>= add_if (not post) k) (fun a_virt ma -> do_str rd (fun ac a _ ii -> (add_if post k a_virt >>= fun b -> write_reg rd b ii) >>| let (>>|) = match an with | Annot.L -> assert (not post) ; fun m1 m2 -> M.seq_mem m2 m1 | _ -> (>>|) in ((read_reg_data sz rs1 ii >>> fun v -> do_write_mem sz an aexp ac a v ii) >>| (add_size a sz >>= fun a -> read_reg_data sz rs2 ii >>> fun v -> do_write_mem sz an aexp ac a v ii))) sz Annot.N ma (M.unitT V.zero) ii >>= fun _ -> add_if post k a_virt >>= fun a -> M.unitT (B.Next [rd,a])) in if kvm then M.upOneRW (is_this_reg rd) m else m let stp tnt sz rs1 rs2 rd (k,md) ii = let an = let open AArch64 in let open Annot in match tnt with | Pa -> N | PaN -> NTA | PaI -> L in match md with | AArch64.Idx -> let (>>|) = match tnt with | AArch64.(Pa|PaN) -> (>>|) | AArch64.PaI -> M.seq_mem in let (>>>) = M.data_input_next in do_str rd (fun ac a _ ii -> (read_reg_data sz rs1 ii >>> fun v -> do_write_mem sz an aexp ac a v ii) >>| (add_size a sz >>= fun a -> read_reg_data sz rs2 ii >>> fun v -> do_write_mem sz an aexp ac a v ii)) sz Annot.N (get_ea_idx rd k ii) (M.unitT V.zero) ii | AArch64.PostIdx -> stp_wback sz an rs1 rs2 rd k true ii | AArch64.PreIdx -> stp_wback sz an rs1 rs2 rd k false ii let stlr sz rs rd ii = do_str rd (do_write_mem sz Annot.L aexp) sz Annot.L (read_reg_ord rd ii) (read_reg_data sz rs ii) ii and do_stxr ms mw sz t rr rd ii = let open AArch64Base in let an = match t with | YY -> Annot.X | LY -> Annot.XL in lift_memop rd Dir.W true memtag (fun ac ma mv -> let must_fail = begin let open AArch64 in match ii.env.lx_sz with | None -> true (* No LoadExcl at all. always fail *) | Some szr -> (* Some, must fail when size differ and cu is disallowed *) not (do_cu || MachSize.equal szr sz) end in M.aarch64_store_conditional must_fail (read_reg_ord ResAddr ii) mv ma (write_reg ResAddr V.zero ii) (fun v -> write_reg rr v ii) (mw an ac)) (to_perms "w" sz) (read_reg_ord rd ii) ms an ii let stxr sz t rr rs rd ii = do_stxr (read_reg_data sz rs ii) (fun an ac ea resa v -> write_mem_atomic sz an aexp ac ea v resa ii) sz t rr rd ii let stxp sz t rr rs1 rs2 rd ii = let (>>>) = M.data_input_next in do_stxr (M.unitT (V.zero)) (fun an ac ea resa _ -> begin (read_reg_data sz rs1 ii >>> fun v -> write_mem_atomic sz an aexp ac ea v resa ii) >>|| (add_size ea sz >>= fun a -> read_reg_data sz rs2 ii >>> fun v -> check_morello_for_write (fun a -> check_mixed_write_mem sz an aexp ac a v ii) a v ii) end >>! ()) sz t rr rd ii (* AMO instructions *) let rmw_amo_read sz rmw = let open AArch64 in let open Annot in match rmw with | RMW_A|RMW_AL -> do_read_mem_ret sz XA Exp | RMW_L|RMW_P -> do_read_mem_ret sz X Exp and rmw_amo_write sz rmw = let open AArch64 in let open Annot in match rmw with | RMW_L|RMW_AL -> do_write_mem sz XL Exp | RMW_P|RMW_A -> do_write_mem sz X Exp let rmw_to_read rmw = let open AArch64 in let open Annot in match rmw with | RMW_P | RMW_L -> N | RMW_A | RMW_AL -> A let swp sz rmw r1 r2 r3 ii = lift_memop r3 Dir.W true (* swp is a write for the purpose of DB *) memtag (fun ac ma mv -> let noret = match r2 with | AArch64.ZR -> true | _ -> false in let r2 = mv and w2 v = write_reg_sz sz r2 v ii and r1 a = if noret then do_read_mem_ret sz Annot.NoRet aexp ac a ii else rmw_amo_read sz rmw ac a ii and w1 a v = rmw_amo_write sz rmw ac a v ii in M.swp (Access.is_physical ac) ma r1 r2 w1 w2) (to_perms "rw" sz) (read_reg_ord r3 ii) (read_reg_data sz r1 ii) (rmw_to_read rmw) ii let cas sz rmw rs rt rn ii = let an = rmw_to_read rmw in let read_rs = read_reg_data sz rs ii and write_rs v = write_reg_sz sz rs v ii in let noret = match rs with | AArch64.ZR -> true | _ -> false in let branch a = let cond = Printf.sprintf "[%s]==%d:%s" (V.pp_v a) ii.A.proc (A.pp_reg rs) in commit_pred_txt (Some cond) ii in let mop_fail_no_wb ac ma _ = (* CAS fails, there is no Explicit Write Effect *) let read_mem a = if noret then do_read_mem_ret sz Annot.NoRet aexp ac a ii else do_read_mem_ret sz an aexp ac a ii in M.aarch64_cas_no (Access.is_physical ac) ma read_rs write_rs read_mem branch M.neqT in let mop_fail_with_wb ac ma _ = (* CAS fails, there is an Explicit Write Effect writing back *) (* the value that is already in memory *) let read_mem a = if noret then do_read_mem_ret sz Annot.NoRet aexp ac a ii else rmw_amo_read sz rmw ac a ii and write_mem a v = rmw_amo_write sz rmw ac a v ii in M.aarch64_cas_no_with_writeback (Access.is_physical ac) ma read_rs write_rs read_mem write_mem branch M.neqT in let mop_success ac ma mv = (* CAS succeeds, there is an Explicit Write Effect *) (* mv is read new value from reg, not important as this code is not executed in morello mode *) let read_rt = mv and read_mem a = if noret then do_read_mem_ret sz Annot.NoRet aexp ac a ii else rmw_amo_read sz rmw ac a ii and write_mem a v = rmw_amo_write sz rmw ac a v ii in M.aarch64_cas_ok (Access.is_physical ac) ma read_rs read_rt write_rs read_mem write_mem branch M.eqT in M.altT ( (* CAS succeeds and generates an Explicit Write Effect *) (* there must be an update to the dirty bit of the TTD *) lift_memop rn Dir.W true memtag mop_success (to_perms "rw" sz) (read_reg_ord rn ii) (read_reg_data sz rt ii) an ii )( (* CAS fails *) M.altT ( (* CAS generates an Explicit Write Effect *) (* there must be an update to the dirty bit of the TTD *) lift_memop rn Dir.W true memtag mop_fail_with_wb (to_perms "rw" sz) (read_reg_ord rn ii) (read_reg_data sz rt ii) an ii )( (* CAS does not generate an Explicit Write Effect *) (* It is IMPLEMENTATION SPECIFIC if there is an update to *) (* the dirty bit of the TTD *) (* Note: the combination of dir=Dir.R and updatedb=true *) (* triggers an alternative in check_ptw *) lift_memop rn Dir.R true memtag mop_fail_no_wb (to_perms "rw" sz) (read_reg_ord rn ii) (read_reg_data sz rt ii) an ii ) ) let casp sz rmw rs1 rs2 rt1 rt2 rn ii = let an = rmw_to_read rmw in let (>>>) = M.data_input_next in let read_rs = read_reg_data sz rs1 ii >>| read_reg_data sz rs2 ii and write_rs (v1,v2) = write_reg_sz sz rs1 v1 ii >>| write_reg_sz sz rs2 v2 ii >>= fun _ -> M.unitT () and branch a = let cond = Printf.sprintf "[%s]=={%d:%s,%d:%s}" (V.pp_v a) ii.A.proc (A.pp_reg rs1) ii.A.proc (A.pp_reg rs1) in commit_pred_txt (Some cond) ii in let neqp (v1,v2) (x1,x2) = M.op Op.Eq v1 x1 >>| M.op Op.Eq v2 x2 >>= fun (b1,b2) -> M.op Op.And b1 b2 >>= M.eqT V.zero and eqp (v1,v2) (x1,x2) = M.eqT v1 x1 >>| M.eqT v2 x2 >>= fun _ -> M.unitT () in let mop_fail_no_wb ac ma _ = (* CASP fails, there are no Explicit Write Effects *) let read_mem a = do_read_mem_ret sz an aexp ac a ii >>| (add_size a sz >>= fun a -> do_read_mem_ret sz an aexp ac a ii) in M.aarch64_cas_no (Access.is_physical ac) ma read_rs write_rs read_mem branch neqp in let mop_fail_with_wb ac ma _ = (* CASP fails, there are Explicit Write Effects writing back *) (* the value that is already in memory *) let read_mem a = do_read_mem_ret sz an aexp ac a ii >>| (add_size a sz >>= fun a -> do_read_mem_ret sz an aexp ac a ii) and write_mem a (v1,v2) = rmw_amo_write sz rmw ac a v1 ii >>| (add_size a sz >>= fun a2 -> rmw_amo_write sz rmw ac a2 v2 ii) >>= fun _ -> M.unitT () in M.aarch64_cas_no_with_writeback (Access.is_physical ac) ma read_rs write_rs read_mem write_mem branch neqp in let mop_success ac ma _ = (* CASP succeeds, there are Explicit Write Effects *) let read_rt = read_reg_data sz rt1 ii >>| read_reg_data sz rt2 ii and read_mem a = rmw_amo_read sz rmw ac a ii >>| (add_size a sz >>= fun a -> rmw_amo_read sz rmw ac a ii) and write_mem a (v1,v2) = rmw_amo_write sz rmw ac a v1 ii >>| (add_size a sz >>= fun a2 -> rmw_amo_write sz rmw ac a2 v2 ii) >>= fun _ -> M.unitT () in M.aarch64_cas_ok (Access.is_physical ac) ma read_rs read_rt write_rs read_mem write_mem branch eqp in M.altT ( (* CASP succeeds and generates Explicit Write Effects *) (* there must be an update to the dirty bit of the TTD *) lift_memop rn Dir.W true memtag mop_success (to_perms "rw" sz) (read_reg_ord rn ii) (read_reg_data sz rt1 ii >>> fun _ -> read_reg_data sz rt2 ii) an ii )( (* CASP fails *) M.altT ( (* CASP generates Explicit Write Effects *) (* there must be an update to the dirty bit of the TTD *) lift_memop rn Dir.W true memtag mop_fail_with_wb (to_perms "rw" sz) (read_reg_ord rn ii) (read_reg_data sz rt1 ii >>> fun _ -> read_reg_data sz rt2 ii) an ii )( (* CASP does not generate Explicit Write Effects *) (* It is IMPLEMENTATION SPECIFIC if there is an update to *) (* the dirty bit of the TTD *) (* Note: the combination of dir=Dir.R and updatedb=true *) (* triggers an alternative in check_ptw *) lift_memop rn Dir.R true memtag mop_fail_no_wb (to_perms "rw" sz) (read_reg_ord rn ii) (read_reg_data sz rt1 ii >>> fun _ -> read_reg_data sz rt2 ii) an ii ) ) (* Temporary morello variation of CAS *) let cas_morello sz rmw rs rt rn ii = (* As morello and kvm are incompatible, all accesses are virtual *) lift_morello (fun ac ma mv -> let read_mem sz = rmw_amo_read sz rmw in let mrs = read_reg_data sz rs ii in let mrt = mv in M.delay ma >>| M.delay mrs >>| M.delay mrt >>= fun (((_,ma),(_,mrs)),(_,mrt)) -> let muncond = ma >>| mrs >>| mrt in let mmem = ma >>= fun a -> read_mem sz ac a ii in let write_rs mv = mv >>= fun v -> write_reg_sz_non_mixed sz rs v ii in let branch = fun mrs mmem mavoid m1 m2 -> let (++) = M.bind_ctrl_avoid mavoid in (mrs >>| mmem >>= fun (rs,mem) -> (M.op Op.Eq rs mem) >>= fun cond -> commit_pred ii >>! cond) ++ fun cond -> M.choiceT cond m1 m2 in let mop = fun ma mv mmem -> let write_mem a v = rmw_amo_write sz rmw ac a v ii in M.aarch64_cas_ok_morello ma mv mmem write_mem in M.delay mmem >>= fun (_,mmem) -> branch mrs mmem (muncond >>| mmem) (mop ma mrt mmem) (mrt >>! ()) >>| write_rs mmem) (to_perms "rw" sz) (read_reg_ord rn ii) (read_reg_data sz rt ii) Dir.W (rmw_to_read rmw) ii let ldop op sz rmw rs rt rn ii = let open AArch64 in let tr_input = match op with |A_SMIN|A_SMAX -> (* For int64 signed comparison to work on int32, int16, int8 *) sxt_op sz |A_ADD|A_EOR|A_SET|A_CLR|A_UMAX|A_UMIN -> M.unitT in let an = rmw_to_read rmw in lift_memop rn Dir.W true memtag (fun ac ma mv -> let noret = match rt with | ZR -> true | _ -> false in let op = match op with | A_ADD -> Op.Add | A_EOR -> Op.Xor | A_SET -> Op.Or | A_CLR -> Op.AndNot2 | A_SMAX -> Op.Max | A_SMIN -> Op.Min | A_UMAX -> Op.UMax | A_UMIN -> Op.UMin in let read_mem = if noret then fun sz -> do_read_mem_ret sz Annot.NoRet Exp ac else fun sz -> rmw_amo_read sz rmw ac and write_mem = fun sz -> rmw_amo_write sz rmw ac in M.amo_strict (Access.is_physical ac) op ma (fun a -> read_mem sz a ii >>= tr_input) mv (fun a v -> write_mem sz a v ii) (fun w -> if noret then M.unitT () else write_reg_sz sz rt w ii)) (to_perms "rw" sz) (read_reg_ord rn ii) (read_reg_data sz rs ii >>= tr_input) an ii (* Neon/SVE/SME instructions *) let (let>*) = M.bind_control_set_data_input_first let (let>=) = M.(>>=) let (and*) = M.(>>|) let (let<>=) = M.bind_data_to_output (* Utility that performes an `N`-bit load as two independent `N/2`-bit * loads. Used by 128-bit Neon LDR. * * This instruction is endianness-aware (i.e. performing an 128-bit * load as two 64-bit loads will take the endianness of the CPU into * account). This is, indeed, a difference in semantics with Neon * with respect to, e.g., `LDR` vs `LD1`. *) let do_read_mem_2_ops_ret sz an anexp ac addr1 ii = let open MachSize in assert (sz != MachSize.Byte); let sz_half = MachSize.pred sz in (do_read_mem_ret sz_half an anexp ac addr1 ii >>= promote) >>| begin M.add addr1 (V.intToV (nbytes sz_half)) >>= fun addr2 -> do_read_mem_ret sz_half an anexp ac addr2 ii >>= promote end >>= fun (v1, v2) -> let v_lo, v_hi = match endian with (* Because an 128-bit Neon STR is allowed to be broken up into * 64-bit loads, this means that we do need to take endianness into * account *) | Endian.Little -> v1, v2 | Endian.Big -> v2, v1 in M.op1 (Op.LeftShift (nbits sz_half)) v_hi >>= fun v_hi_shifted -> M.op Op.Or v_lo v_hi_shifted (* Utility that performes an `N`-bit store as two independent `N/2`-bit * stores. Used by Neon instructions. *) let do_write_mem_2_ops sz an anexp ac addr1 v ii = let open MachSize in assert (sz != MachSize.Byte); let sz_half = MachSize.pred sz in let comp_lo = M.op1 (Op.Mask sz_half) v in let comp_hi = M.op1 (Op.LogicalRightShift (nbits sz_half)) v in let (comp_v1, comp_v2) = match endian with (* Because an 128-bit Neon STR is allowed to be broken up into * 64-bit loads, this means that we do need to take endianness into * account *) | Endian.Little -> comp_lo, comp_hi | Endian.Big -> comp_hi, comp_lo in begin comp_v1 >>= demote >>= fun v1 -> do_write_mem sz_half an anexp ac addr1 v1 ii end >>| begin M.add addr1 (V.intToV (nbytes sz_half)) >>| (comp_v2 >>= demote) >>= fun (addr2, v2) -> do_write_mem sz_half an anexp ac addr2 v2 ii end let write_mem_2_ops sz = do_write_mem_2_ops sz Annot.N (* Neon extension, memory accesses return B.Next, as they cannot fail *) let do_simd_ldr an sz addr rd ii = (* 128-bit Neon LDR/STR and friends are split into two 64-bit * single-copy atomic accesses. *) let mem_op = begin if sz == MachSize.S128 then do_read_mem_2_ops_ret else do_read_mem_ret end in mem_op sz an aexp Access.VIR addr ii >>= fun v -> write_reg_neon_sz sz rd v ii let simd_ldr = do_simd_ldr Annot.N let simd_ldar = do_simd_ldr Annot.Q let do_simd_str an sz ma rd ii = ma >>| read_reg_neon true rd ii >>= fun (addr,v) -> if sz == MachSize.S128 then do_write_mem_2_ops sz an aexp Access.VIR addr v ii >>= B.next2T else demote v >>= fun v -> do_write_mem sz an aexp Access.VIR addr v ii >>= B.next1T let simd_str = do_simd_str Annot.N let simd_stlr = do_simd_str Annot.L let simd_str_p sz ma rd rs k ii = ma >>| read_reg_neon true rd ii >>= fun (addr,v) -> if sz == MachSize.S128 then (* 128-bit Neon LDR/STR and friends are split into two 64-bit * single-copy atomic accesses. *) write_mem_2_ops sz aexp Access.VIR addr v ii >>| post_kr rs addr k ii >>= B.next3T else demote v >>= fun v -> write_mem sz aexp Access.VIR addr v ii >>| post_kr rs addr k ii >>= B.next2T let simd_ldp tnt var addr1 rd1 rd2 ii = let an = tnt2annot tnt in let open AArch64Base in let sz = tr_simd_variant var in do_simd_ldr an sz addr1 rd1 ii >>| begin M.add addr1 (neon_sz_k var) >>= fun addr2 -> do_simd_ldr an sz addr2 rd2 ii end >>= B.next2T let simd_stp tnt var addr1 rd1 rd2 ii = let an = tnt2annot tnt in let open AArch64Base in let sz = tr_simd_variant var in if sz == MachSize.S128 then (* 128-bit Neon LDR/STR are not single-copy atomic, but they * are single-copy atomic for each of the two 64-bit quantities * they access. This means that a 2x128-bit LDP/STP with Neon * registers results in 4 single-copy atomic accesses. *) begin read_reg_neon true rd1 ii >>= fun v1 -> do_write_mem_2_ops sz an aexp Access.VIR addr1 v1 ii end >>| begin M.add addr1 (neon_sz_k var) >>| read_reg_neon true rd2 ii >>= fun (addr2, v2) -> do_write_mem_2_ops sz an aexp Access.VIR addr2 v2 ii end >>= fun ((a, b), (c, d)) -> B.next4T (((a, b), c), d) else begin read_reg_neon true rd1 ii >>= fun v1 -> write_mem sz aexp Access.VIR addr1 v1 ii end >>| begin M.add addr1 (neon_sz_k var) >>| read_reg_neon true rd2 ii >>= fun (addr2, v2) -> write_mem sz aexp Access.VIR addr2 v2 ii end >>= B.next2T let m128 k = promote (V.intToV k) let movi_v r k shift ii = let open AArch64Base in let sz = neon_sz r and esize = neon_esize r in begin match esize, shift with | 8, S_NOEXT | 16, S_NOEXT | 32, S_NOEXT | 64, S_NOEXT | 128, S_NOEXT -> m128 k | 8, S_LSL(0 as amount) | 16, S_LSL(0|8 as amount) | 32, S_LSL(0|8|16|24 as amount) | 32, S_MSL(8|16 as amount) -> m128 k >>= M.op1 (Op.LeftShift amount) | _, S_LSL(n) -> Warn.fatal "illegal shift immediate %d in %d-bit instruction movi" n esize | _, s -> Warn.fatal "illegal shift operand %s in %d-bit instruction movi" (pp_barrel_shift "," s pp_imm) esize end >>= fun v -> write_reg_neon_rep sz r v ii let movi_s var r k ii = let open AArch64Base in begin match var with | VSIMD64 -> m128 k | _ -> Warn.fatal "illegal scalar register size in instruction movi" end >>= (fun v -> write_reg_neon_sz (tr_simd_variant var) r v ii) let sum_elems (v1,v2) = M.add v1 v2 let simd_add r1 r2 r3 ii = let nelem = neon_nelem r1 in let esize = neon_esize r1 in read_reg_neon false r3 ii >>| read_reg_neon false r2 ii >>= fun (v1,v2) -> let aux cur_val idx = neon_getlane v1 idx esize >>| neon_getlane v2 idx esize >>= sum_elems >>= fun v -> neon_setlane cur_val idx esize v in let rec reduce idx op = match idx with | 0 -> op >>= fun old_val -> aux old_val idx | _ -> reduce (idx-1) (op >>= fun old_val -> aux old_val idx) in reduce (nelem-1) mzero >>= fun v -> write_reg_neon r1 v ii let addv var r1 r2 ii = let open AArch64Base in let nelem = neon_nelem r2 in let sz = tr_simd_variant var in let rec reduce n op = match n with | 0 -> op >>| read_reg_neon_elem false r2 0 ii >>= sum_elems | _ -> reduce (n-1) (op >>| read_reg_neon_elem false r2 n ii >>= sum_elems) in reduce (nelem-1) mzero >>= fun v -> write_reg_neon_sz sz r1 v ii let uaddv var r1 p src ii = let nelem = predicate_nelem src in let psize = predicate_psize src in let esize = scalable_esize src in read_reg_predicate false p ii >>= fun pred -> get_predicate_any pred psize nelem >>= fun any -> M.choiceT any (read_reg_scalable false src ii >>= fun src -> let read_active_elem_or_zero idx cur_val = get_predicate_last pred psize idx >>= fun last -> M.choiceT last (scalable_getlane cur_val idx esize) mzero in let rec reduce cur_val n op = match n with | 0 -> op >>| read_active_elem_or_zero n cur_val >>= sum_elems | _ -> reduce cur_val (n-1) (op >>| read_active_elem_or_zero n cur_val >>= sum_elems) in reduce src (nelem-1) mzero) mzero >>= fun v -> let sz = AArch64Base.tr_simd_variant var in write_reg_neon_sz sz r1 v ii let add_sv r1 r2 r3 ii = let nelem = scalable_nelem r1 in let esize = scalable_esize r1 in read_reg_scalable false r3 ii >>| read_reg_scalable false r2 ii >>= fun (v1,v2) -> let add cur_val idx = scalable_getlane v1 idx esize >>| scalable_getlane v2 idx esize >>= sum_elems >>= scalable_setlane cur_val idx esize in let rec reduce idx op = match idx with | 0 -> op >>= fun old_val -> add old_val idx | _ -> reduce (idx-1) (op >>= fun old_val -> add old_val idx) in reduce (nelem-1) mzero >>= fun v -> write_reg_scalable r1 v ii let movprfx dst pg src ii = let nelem = predicate_nelem src in let psize = predicate_psize src in let esize = scalable_esize dst in let orig = match pg with | AArch64Base.PMreg (_,AArch64Base.Zero) -> mzero | AArch64Base.PMreg (_,AArch64Base.Merge) -> read_reg_scalable false dst ii | _ -> assert false in orig >>| read_reg_predicate false pg ii >>= fun (orig,pred) -> get_predicate_any pred psize nelem >>= fun any -> M.choiceT any (read_reg_scalable false src ii >>= fun src -> let copy orig cur_val idx = get_predicate_last pred psize idx >>= fun last -> M.choiceT last (scalable_getlane cur_val idx esize) (scalable_getlane orig idx esize) >>= fun v -> scalable_setlane cur_val idx esize v in let rec reduce orig n op = match n with | 0 -> op >>= fun old_val -> copy orig old_val n | _ -> reduce orig (n-1) (op >>= fun old_val -> copy orig old_val n) in reduce orig (nelem-1) (M.unitT src)) (M.unitT orig) >>= fun v -> write_reg_scalable dst v ii let neg dst pg src ii = let nelem = predicate_nelem src in let psize = predicate_psize src in let esize = scalable_esize dst in read_reg_scalable false dst ii >>| read_reg_predicate false pg ii >>= fun (orig,pred) -> get_predicate_any pred psize nelem >>= fun any -> M.choiceT any (read_reg_scalable false src ii >>= fun src -> let negate orig cur_val idx = get_predicate_last pred psize idx >>= fun last -> M.choiceT last (scalable_getlane cur_val idx esize >>= M.op Op.Sub V.zero) (scalable_getlane orig idx esize) >>= fun v -> scalable_setlane cur_val idx esize v in let rec reduce orig n op = match n with | 0 -> op >>= fun old_val -> negate orig old_val n | _ -> reduce orig (n-1) (op >>= fun old_val -> negate orig old_val n) in reduce orig (nelem-1) (M.unitT src)) (M.unitT orig) >>= fun v -> write_reg_scalable dst v ii let while_op compare unsigned p var r1 r2 ii = let psize = predicate_psize p in let nelem = predicate_nelem p in let sz = AArch64Base.tr_variant var in let extend = if unsigned then uxt_op sz else sxt_op sz in read_reg_ord_sz sz r1 ii >>| read_reg_ord_sz sz r2 ii >>= fun (v1,v2) -> let rec repeat old_val idx v1 v2 last = if idx < nelem then extend v1 >>| extend v2 >>= fun (v1,v2) -> compare v1 v2 >>= fun (cond) -> M.op Op.And last cond >>= fun last -> predicate_setlane old_val idx psize last >>| M.add v1 V.one >>= fun (old_val, v1) -> repeat old_val (idx+1) v1 v2 last else M.unitT old_val in repeat V.zero 0 v1 v2 V.one >>= fun (new_val) -> write_reg_predicate p new_val ii >>| ( let last idx = get_predicate_last new_val psize idx in (* Fisrt active *) let n = last 0 >>= fun v -> M.op1 (Op.LeftShift 3) v in (* Non active *) let z = let rec reduce idx op = match idx with | 0 -> op >>| last idx >>= fun (v1,v2) -> M.op Op.Or v1 v2 | _ -> reduce (idx-1) (op >>| last idx >>= fun (v1,v2) -> M.op Op.Or v1 v2) in reduce (nelem-1) mzero >>= fun v -> M.op1 Op.Not v >>= fun v -> M.op1 (Op.LeftShift 2) v in (* Not last active*) let c = last (nelem-1) >>= fun v -> M.op1 Op.Not v >>= fun v -> M.op1 (Op.LeftShift 1) v in (* v always 0 *) let flags = n >>| z >>= fun (v1,v2) -> M.op Op.Or v1 v2 >>| c >>= fun (v1,v2) -> M.op Op.Or v1 v2 in flags >>= fun flags -> write_reg AArch64Base.NZCV flags ii ) >>! new_val let ptrue p pattern ii = let psize = predicate_psize p in let nelem = predicate_nelem p in let count = predicate_count pattern nelem in let rec repeat old_val idx = if idx < nelem then let v = if idx < count then AArch64.one_promoted else AArch64.zero_promoted in predicate_setlane old_val idx psize v >>= fun old_val -> repeat old_val (idx+1) else M.unitT old_val in repeat AArch64.zero_promoted 0 >>= fun new_val -> write_reg_predicate p new_val ii >>! new_val let mov_sv r k shift ii = let open AArch64Base in begin match shift with | S_NOEXT | S_LSL(0) -> M.unitT (AArch64.promote_int k) | S_LSL(8 as amount) -> M.op1 (Op.LeftShift amount) (AArch64.promote_int k) | S_LSL(n) -> Warn.fatal "illegal shift immediate %d in instruction mov" n | s -> Warn.fatal "illegal shift operand %s in in instruction mov" (pp_barrel_shift "," s pp_imm) end >>= fun v -> write_reg_scalable_rep r v ii let index r v1 v2 ii = let nelem = scalable_nelem r in let esize = scalable_esize r in let increment cur_val idx o = M.add v1 o >>= promote >>= scalable_setlane cur_val idx esize in let rec reduce n op = let i = V.op Op.Mul (V.intToV n) v2 in match n with | 0 -> op >>= fun old_val -> increment old_val n i | _ -> reduce (n-1) (op >>= fun old_val -> increment old_val n i) in reduce (nelem-1) mzero >>= fun v -> write_reg_scalable r v ii >>! v let cnt_inc (op,v) r pat k ii = let open AArch64 in let nelem = scalable_nbytes / simd_variant_nbytes v in let off = predicate_count pat nelem * k in let sz = MachSize.Quad in (match op with | CNT -> mzero | INC -> read_reg_ord_sz sz r ii) >>= M.op1 (Op.AddK off) >>= fun v -> write_reg_sz_dest sz r v ii let reset_sm v ii = let z = AArch64.zero_promoted in let zop = List.map (fun r -> write_reg_scalable r z ii) AArch64.zregs in let pop = List.map (fun r -> write_reg_predicate r z ii) AArch64.pregs in let zval = List.map (fun r -> r,z) AArch64.zregs in let pval = List.map (fun r -> r,z) AArch64.pregs in let ops = zop@pop@[write_reg AArch64.SM v ii] in let vals = zval@pval@[AArch64.SM,v] in ops,vals let reset_za v ii = let z = AArch64.zero_promoted in let r = AArch64.ZAreg(0,None,0) in let ops = [write_reg_za r z ii; write_reg AArch64.ZA v ii] in let vals = [r,z;AArch64.ZA,v] in ops,vals let mova_vt r ri k pg src ii = let dst,tile,dir = match r with | AArch64Base.ZAreg (tile,Some dir,_) -> r,tile,dir | _ -> assert false in let psize = predicate_psize src in let esize = scalable_esize src in let dim = scalable_nbits / esize; in read_reg_ord ri ii >>= fun index -> M.add index (V.intToV k) >>= fun slice -> M.op Op.Rem slice (V.intToV dim) >>= fun slice -> read_reg_za false dst ii >>| read_reg_predicate false pg ii >>| read_reg_scalable false src ii >>= fun ((orig,pred),src) -> let mova cur_val idx = get_predicate_last pred psize idx >>= fun last -> M.choiceT last (scalable_getlane src idx esize) (za_getlane_dir dir orig tile slice (V.intToV idx) esize) >>= fun v -> za_setlane_dir dir cur_val tile slice (V.intToV idx) esize v in let rec reduce n op = match n with | 0 -> op >>= fun old_val -> mova old_val n | _ -> reduce (n-1) (op >>= fun old_val -> mova old_val n) in reduce (dim-1) (M.unitT orig) >>= fun v -> write_reg_za dst v ii >>! v let mova_tv dst pg r ri k ii = let src,tile,dir = match r with | AArch64Base.ZAreg (tile,Some dir,_) -> r,tile,dir | _ -> assert false in let psize = predicate_psize dst in let esize = scalable_esize dst in let dim = scalable_nbits / esize; in read_reg_ord ri ii >>= fun index -> M.add index (V.intToV k) >>= fun slice -> M.op Op.Rem slice (V.intToV dim) >>= fun slice -> read_reg_za false src ii >>| read_reg_predicate false pg ii >>| read_reg_scalable false dst ii >>= fun ((src,pred),orig) -> let mova cur_val idx = get_predicate_last pred psize idx >>= fun last -> M.choiceT last (za_getlane_dir dir src tile slice (V.intToV idx) esize) (scalable_getlane orig idx esize) >>= fun v -> scalable_setlane cur_val idx esize v in let rec reduce n op = match n with | 0 -> op >>= fun old_val -> mova old_val n | _ -> reduce (n-1) (op >>= fun old_val -> mova old_val n) in reduce (dim-1) mzero_promoted >>= fun v -> write_reg_scalable dst v ii >>! v let adda dir dst pslice pelem src ii = let acc,tile,dir = match dst with | AArch64Base.ZAreg (tile,None,_) -> dst,tile,dir | _ -> assert false in let psize = predicate_psize src in let esize = scalable_esize src in let dim = scalable_nbits / esize; in read_reg_za false acc ii >>| read_reg_predicate false pslice ii >>| read_reg_predicate false pelem ii >>| read_reg_scalable false src ii >>= fun (((acc,p1),p2),src) -> let add cur_val slice idx = get_predicate_last p1 psize slice >>| get_predicate_last p2 psize idx >>= fun (v1,v2) -> M.op Op.And v1 v2 >>= fun last -> M.choiceT last (let slice_v = V.intToV slice and idx_v = V.intToV idx in begin scalable_getlane src idx esize >>| za_getlane_dir dir acc tile slice_v idx_v esize end >>= sum_elems >>= fun v -> za_setlane_dir dir cur_val tile slice_v idx_v esize v) (M.unitT cur_val) in let rec repeat_row old_val slice idx = if idx < dim then add old_val slice idx >>= fun old_val -> repeat_row old_val slice (idx+1) else M.unitT old_val in let rec repeat_col old_val slice = if slice < dim then repeat_row old_val slice 0 >>= fun old_val -> repeat_col old_val (slice+1) else M.unitT old_val in repeat_col acc 0 >>= fun v -> write_reg_za dst v ii >>! v (******************************) (* Move constant instructions *) (******************************) let movzn inv sz rd k os ii = let open AArch64Base in assert (MachSize.is_imm16 k); begin match sz, os with | V32, S_NOEXT | V64, S_NOEXT -> (* Or'ing zero with value should zero out what's left *) M.unitT (V.intToV k) | V32, S_LSL(0|16 as s) | V64, S_LSL((0|16|32|48 as s)) -> M.op1 (Op.LeftShift s) (V.intToV k) | _, S_LSL(_) | _, _ -> Warn.fatal "illegal instruction %s" (AArch64.dump_instruction (I_MOVZ (sz, rd, k, os))) end >>= begin if inv then M.op1 Op.Inv else M.unitT end >>= fun v -> write_reg_dest rd v ii let movz = movzn false and movn = movzn true let m_movk msk v1 v2 = M.op Op.AndNot2 v2 msk >>= M.op Op.Or v1 let movk var rd k os ii = let open AArch64Base in let msk = let v = V.op1 (Op.LeftShift 16) V.one in V.op Op.Sub v V.one in assert (MachSize.is_imm16 k); let sz = tr_variant var in begin match var, os with | V32, S_NOEXT | V64, S_NOEXT -> read_reg_data sz rd ii >>= m_movk msk (V.intToV k) | V32, S_LSL(0|16 as s) | V64, S_LSL((0|16|32|48 as s)) -> let msk = V.op1 (Op.LeftShift s) msk in let v1 = V.op1 (Op.LeftShift s) (V.intToV k) in read_reg_data sz rd ii >>= m_movk msk v1 | _, S_LSL(n) -> Warn.fatal "illegal shift immediate %d in %s instruction movk" n (pp_variant var) | _, s -> Warn.fatal "illegal shift operand %s in %s instruction movk" (pp_barrel_shift "," s pp_imm) (pp_variant var) end >>= fun v -> write_reg_dest rd v ii (* * "Sign"-extend high-order bit of pattern.\ * Notice that computation can be performed on 64bits, * masking is performed later, while writing * into register. *) let xtmsb imms v = let hsb = 63 in let msk = String.concat "" ("0b1"::Misc.replicate imms "0") in M.op1 (Op.AndK msk) v >>= M.op1 (Op.LeftShift (hsb-imms)) >>= M.op1 (Op.ArithRightShift (hsb-imms)) >>= M.op Op.Or v let xbfm signed v rd rn kr ks ii = let open AArch64Base in let sz = tr_variant v in let regsize = match v with | V32 -> 32 | V64 -> 64 | _ -> assert false in let hex_mask = begin let f = if ks >= kr then (fun v -> if v < kr || v > ks then "0" else "1") else (fun v -> if v > ks then "0" else "1") in let bitmask = List.rev (List.init regsize f) in let dec_mask = Int64.of_string (Printf.sprintf "0b%s" (String.concat "" bitmask)) in Printf.sprintf "0x%Lx" dec_mask end in let shift_sz = if ks >= kr then kr else regsize-kr in let shift_op = if ks >= kr then Op.ShiftRight else Op.ShiftLeft in read_reg_data sz rn ii >>= M.op1 (Op.AndK hex_mask) >>= fun v -> M.op shift_op v (V.intToV shift_sz) >>= begin if signed then xtmsb (if ks >= kr then ks-kr else regsize-kr+ks) else fun v -> M.unitT v end >>= fun v -> write_reg rd v ii >>= B.next1T let csel_op op v = let open AArch64Base in match op with | Cpy -> M.unitT v | Inc -> M.op Op.Add v V.one | Neg -> M.op Op.Sub V.zero v | Inv -> M.op1 Op.Inv v let do_load_elem an sz i r addr ii = let access_size = AArch64.simd_mem_access_size [r] in do_read_mem_ret access_size an aexp Access.VIR addr ii >>= promote >>= fun v -> write_reg_neon_elem sz r i v ii let load_elem = do_load_elem Annot.N let load_elem_ldar = do_load_elem Annot.Q let load_elem_rep sz r addr ii = let access_size = AArch64.simd_mem_access_size [r] in do_read_mem_ret access_size Annot.N aexp Access.VIR addr ii >>= fun v -> write_reg_neon_rep sz r v ii let do_store_elem an i r addr ii = let access_size = AArch64.simd_mem_access_size [r] in read_reg_neon_elem true r i ii >>= demote >>= fun v -> do_write_mem access_size an aexp Access.VIR addr v ii let store_elem = do_store_elem Annot.N let store_elem_stlr = do_store_elem Annot.L (* Single structure memory access *) let mem_ss memop addr rs ii = let op r o = M.add o addr >>= fun addr -> memop r addr ii in let os = List.mapi (fun i r -> V.intToV (i * neon_esize r / 8)) rs in List.fold_right (>>::) (List.map2 op rs os) (M.unitT [()]) let rec reduce_ord l = match l with | [] -> M.unitT () | h::t -> h >>= fun () -> reduce_ord t let neon_memops memop addr idx rs ii = let calc_offset i r = (V.intToV ((idx*(List.length rs)+i) * neon_esize r / 8)) in let op r o = M.add o addr >>= fun addr -> memop idx r addr ii in List.map2 op rs (List.mapi calc_offset rs) let load_m addr rlist ii = let op i = let ops = neon_memops (load_elem MachSize.S128) addr i rlist ii in reduce_ord ops in let ops = List.map op (Misc.interval 0 (neon_nelem (List.hd rlist))) in reduce_ord ops let store_m addr rlist ii = let op i = let ops = neon_memops store_elem addr i rlist ii in List.fold_right (>>::) ops (M.unitT [()]) in let ops = List.map op (Misc.interval 0 (neon_nelem (List.hd rlist))) in List.fold_right (>>::) ops (M.unitT [[()]]) let neon_memops_contigous memop addr step r ii = let op idx = let o = (idx + step) * neon_esize r / 8 in M.add (V.intToV o) addr >>= fun addr -> memop idx r addr ii in List.map op (Misc.interval 0 (neon_nelem r)) let load_m_contigous addr rlist ii = let op i r = let step = i*(neon_nelem r) in let ops = neon_memops_contigous (load_elem MachSize.S128) addr step r ii in reduce_ord ops in let ops = List.mapi op rlist in reduce_ord ops let store_m_contigous addr rlist ii = let op i r = let step = i*(neon_nelem r) in let ops = neon_memops_contigous store_elem addr step r ii in List.fold_right (>>::) ops (M.unitT [()]) in let ops = List.mapi op rlist in List.fold_right (>>::) ops (M.unitT [[()]]) (** branch on whether [p]'s value [pred] has any active elements. add [iico_causality_ctrl] from the predicate read to [mtrue] or [mfalse] *) let any_active p pred psize nelem ii mtrue mfalse = let>= any = get_predicate_any pred psize nelem in let>* () = let cond = Printf.sprintf "AnyActive(%s)" (A.pp_reg p) in commit_pred_txt (Some cond) ii in M.choiceT any mtrue mfalse (** check the element [idx] in predicate [pred] and add [mtrue] if active, or [mfalse] otherwise. add [iico_causality_ctrl] from the predicate read to [mtrue] or [mfalse] *) let is_active_element p pred psize idx ii mtrue mfalse = let>= last = get_predicate_last pred psize idx in let>* () = let cond = Printf.sprintf "ActiveElem(%s, %d)" (A.pp_reg p) idx in commit_pred_txt (Some cond) ii in M.choiceT last mtrue mfalse let no_action = M.mk_singleton_es Act.NoAction (** perform [ops] in parallel and fold right on results *) let para_fold_right mbind ops munit = let final results = List.fold_right (fun v macc -> macc >>= mbind v) results munit in M.data_output_union (List.fold_right ( >>:: ) ops (M.unitT [])) final let load_predicated_elem_or_zero_m sz p ma rlist ii = let r = List.hd rlist in let nelem = scalable_nelem r in let psize = predicate_psize r in let esize = scalable_esize r in let nregs = List.length rlist in let>= results = let<>= base = ma in let>= pred = read_reg_predicate false p ii in let ops i = let op idx = let load = let offset = (idx * nregs + i) * MachSize.nbytes sz in let>= addr = M.op1 (Op.AddK offset) base in let>= v = do_read_mem_ret sz Annot.N aexp Access.VIR addr ii in let>= v = promote v in M.op1 (Op.LeftShift (idx * esize)) v in is_active_element p pred psize idx ii load (no_action ii >>! M.A.V.zero) in let ops = List.map op (Misc.interval 0 nelem) in para_fold_right (M.op Op.Or) ops mzero in let ops = List.map ops (Misc.interval 0 nregs) in List.fold_right ( >>:: ) ops (M.unitT []) in let f (r, result) macc = write_reg_scalable r result ii >>:: macc in List.fold_right f (List.combine rlist results) (M.unitT [()]) let store_predicated_elem_or_merge_m sz p ma rlist ii = let r = List.hd rlist in let nelem = scalable_nelem r in let psize = predicate_psize r in let esize = scalable_esize r in let nregs = List.length rlist in let<>= base = ma in let>= pred = read_reg_predicate false p ii in let ops i r = let<>= v = any_active p pred psize nelem ii (read_reg_scalable true r ii) mzero in let op idx = let store = let offset = (idx * nregs + i) * MachSize.nbytes sz in let>= addr = M.op1 (Op.AddK offset) base and* v = scalable_getlane v idx esize >>= demote in write_mem sz aexp Access.VIR addr v ii in is_active_element p pred psize idx ii store (M.unitT ()) in let ops = List.map op (Misc.interval 0 nelem) in List.fold_right M.seq_mem_list ops (M.unitT []) (* List.fold_right M.seq_mem_list ops (M.unitT [()]) *) in let ops = List.mapi ops rlist in List.fold_right M.seq_mem_list ops (M.unitT []) let load_gather_predicated_elem_or_zero sz p ma mo rs e k ii = let r = List.hd rs in let psize = predicate_psize r in let nelem = scalable_nelem r in let esize = scalable_esize r in let>= pred = read_reg_predicate false p ii in let>= result = let<>= (base, offsets) = any_active p pred psize nelem ii (ma >>| mo) (M.unitT M.A.V.(zero, zero)) in let op idx = let load = let>= lane = scalable_getlane offsets idx esize in let>= lane = demote lane in let>= o = memext_sext e k lane in let>= addr = M.add base o in let>= v = do_read_mem_ret sz Annot.N aexp Access.VIR addr ii in let>= v = promote v in M.op1 (Op.LeftShift (idx * esize)) v in is_active_element p pred psize idx ii load (no_action ii >>! M.A.V.zero) in let ops = List.map op (Misc.interval 0 nelem) in para_fold_right (M.op Op.Or) ops mzero in write_reg_scalable r result ii let store_scatter_predicated_elem_or_merge sz p ma mo rs e k ii = let r = List.hd rs in let psize = predicate_psize r in let nelem = scalable_nelem r in let esize = scalable_esize r in let>= pred = read_reg_predicate false p ii in let<>= ((base, offsets), v) = any_active p pred psize nelem ii (ma >>| mo >>| read_reg_scalable true r ii) (M.unitT ((M.A.V.zero, M.A.V.zero), M.A.V.zero)) in let op idx = let store = let>= lane = scalable_getlane offsets idx esize in let>= lane = demote lane in let>= o = memext_sext e k lane in let>= addr = M.add base o in let>= v = scalable_getlane v idx esize in let>= v = demote v in write_mem sz aexp Access.VIR addr v ii in is_active_element r pred psize idx ii store (M.unitT ()) in let ops = List.map op (Misc.interval 0 nelem) in List.fold_right M.seq_mem_list ops (M.unitT [()]) let load_predicated_slice sz r ri k p ma ii = let dst,tile,dir,esize = match r with | AArch64Base.ZAreg (tile,Some(dir),esize) -> r,tile,dir,esize | _ -> assert false in let psize = predicate_psize dst in let dim = scalable_nbits / esize; in ma >>| read_reg_za false dst ii >>| read_reg_predicate false p ii >>| (read_reg_ord ri ii >>= fun index -> M.add index (V.intToV k) >>= fun slice -> M.op Op.Rem slice (V.intToV dim)) >>= fun ((((base,orig)),pred),slice) -> let load idx = let offset = idx * MachSize.nbytes sz in get_predicate_last pred psize idx >>= fun last -> M.choiceT last (M.op1 (Op.AddK offset) base >>= fun addr -> do_read_mem_ret sz Annot.N aexp Access.VIR addr ii) mzero >>= promote >>| za_getoffset_dir dir tile slice (V.intToV idx) esize >>= fun (v,amount) -> M.op Op.ShiftLeft v amount in let rec reduce idx op = match idx with | 0 -> op >>| load idx >>= fun (v1,v2) -> M.op Op.Or v1 v2 | _ -> reduce (idx-1) (op >>| load idx >>= fun (v1,v2) -> M.op Op.Or v1 v2) in reduce (dim-1) mzero_promoted >>| ( let mask idx = za_getoffset_dir dir tile slice (V.intToV idx) esize >>= fun amount -> M.op Op.ShiftLeft (AArch64.scalable_mask esize) amount in let rec genmask idx op = match idx with | 0 -> op >>| mask idx >>= fun (v1,v2) -> M.op Op.Or v1 v2 | _ -> genmask (idx-1) (op >>| mask idx >>= fun (v1,v2) -> M.op Op.Or v1 v2) in genmask (dim-1) mzero_promoted >>= M.op1 Op.Inv >>= fun invert -> M.op Op.And invert orig) >>= fun (new_val,old_val) -> M.op Op.Or new_val old_val >>= fun v -> write_reg_za dst v ii let store_predicated_slice sz r ri k p ma ii = let src,tile,dir,esize = match r with | AArch64Base.ZAreg (tile,Some(dir),esize) -> r,tile,dir,esize | _ -> assert false in let psize = predicate_psize src in let dim = scalable_nbits / esize; in ma >>| read_reg_za false src ii >>| read_reg_predicate false p ii >>| (read_reg_ord ri ii >>= fun index -> M.add index (V.intToV k) >>= fun slice -> M.op Op.Rem slice (V.intToV dim)) >>= fun ((((base,orig)),pred),slice) -> let store idx = let offset = idx * MachSize.nbytes sz in get_predicate_last pred psize idx >>= fun last -> M.choiceT last (M.op1 (Op.AddK offset) base >>| (za_getlane_dir dir orig tile slice (V.intToV idx) esize >>= demote) >>= fun (addr,v) -> write_mem sz aexp Access.VIR addr v ii) (M.unitT ()) in let rec reduce idx op = match idx with | 0 -> store idx >>:: op | _ -> reduce (idx-1) (store idx >>:: op) in reduce (dim-1) (M.unitT [()]) (* Data cache operations *) let dc_loc op a ii = let mk_act loc = Act.CMO (AArch64.CMO.DC op,Some loc) in let loc = A.Location_global a in M.mk_singleton_es (mk_act loc) ii let do_dc op rd ii = if AArch64Base.DC.sw op then M.mk_singleton_es (Act.CMO (AArch64.CMO.DC op, None)) ii >>= B.next1T else begin (* TODO: The size for DC should be a cache line *) let mop _ac a = dc_loc op a ii in let dir = match op.AArch64Base.DC.funct with | AArch64Base.DC.I -> Dir.W | _ -> Dir.R in (* CMO by VA other than DC ZVA are Tag Unchecked *) lift_memop rd dir false false (fun ac ma _mv -> (* value fake here *) if Access.is_physical ac then M.bind_ctrldata ma (mop ac) else ma >>= mop ac) (to_perms "r" MachSize.Word) (read_reg_ord rd ii) mzero Annot.N ii end let do_ic op rd ii = if AArch64Base.IC.all op then (* IC IALLU *) M.mk_singleton_es (Act.CMO (AArch64.CMO.IC op, None)) ii >>= B.next1T else begin (* IC IVAU *) read_reg_ord rd ii >>= fun a -> let loc = A.Location_global a in let act = Act.CMO (AArch64.CMO.IC op,Some loc) in M.mk_singleton_es act ii >>= B.next1T end let ldg rt rn k ii = let ma = get_ea rn (AArch64.K k) AArch64.S_NOEXT ii in let do_ldg a_virt ac ma = let ( let* ) = (>>=) in let _do_ldg a = let* atag = M.op1 Op.TagLoc a in let* tag = do_read_tag atag ii in let* v = M.op Op.SetTag a_virt tag in let* () = write_reg rt v ii in B.nextT in if Access.is_physical ac then M.bind_ctrldata ma _do_ldg else ma >>= _do_ldg in M.delay_kont "ldg" ma (fun a_virt ma -> let do_ldg = do_ldg a_virt in lift_memop rn Dir.R false false (fun ac ma _mv -> do_ldg ac ma) (to_perms "w" MachSize.S128) ma mzero Annot.N ii) type double = Once|Twice let stg d rt rn k ii = let ma = get_ea rn (AArch64.K k) AArch64.S_NOEXT ii and mv = read_reg_data MachSize.Quad rt ii >>= tag_extract in let do_stg ac ma mv = let __do_stg a v = M.op1 Op.TagLoc a >>= fun a -> do_write_tag a v ii in let _do_stg = match d with | Once -> fun a v -> __do_stg a v | Twice -> fun a v -> begin __do_stg a v >>| (M.op1 (Op.AddK MachSize.granule_nbytes) a >>= fun a -> __do_stg a v) end >>! () in if Access.is_physical ac then M.bind_ctrldata_data ma mv _do_stg else (ma >>| mv) >>= fun (a,v) -> _do_stg a v in lift_memop rn Dir.W true false (fun ac ma mv -> do_stg ac ma mv) (to_perms "w" MachSize.granule) ma mv Annot.N ii let stz d rn k ii = let sz = MachSize.granule in let mop = match d with | Once -> do_write_mem sz Annot.N aexp | Twice -> fun ac a v ii -> let mop1 = do_write_mem sz Annot.N aexp ac a v ii and mop2 = M.op1 (Op.AddK MachSize.granule_nbytes) a >>= fun a -> do_write_mem sz Annot.N aexp ac a v ii in (mop1 >>| mop2) >>! () in let ma = get_ea rn (AArch64.K k) AArch64.S_NOEXT ii >>= loc_extract in lift_memop rn Dir.W true false (* Unchecked *) (fun ac ma mv -> if Access.is_physical ac then begin (* additional ctrl dep on address *) M.bind_ctrldata_data ma mv (fun a v -> mop ac a v ii) end else (ma >>| mv) >>= fun (a,v) -> mop ac a v ii) (to_perms "w" sz) ma mzero Annot.N ii let do_stzg d rt rn k ii = let do_stz = stz d rn k ii in let do_stg = stg d rt rn k ii in if kvm then (* The two operations include their own translations, if there is a fault, it has to be ordered after any other event of the instruction *) M.altT (M.delay_kont "do_stg" do_stg (function | B.Next _ -> fun mstg -> M.para_bind_output_right mstg (fun _ -> do_stz) | B.Fault _ -> fun mstg -> mstg | _ -> Warn.fatal "Unexpected return value do_stz")) (M.delay_kont "do_stz" do_stz (function | B.Next _ -> fun mstz -> M.delay_kont "do_stg" do_stg (function | B.Next _ -> (* Force the solver to drop this, already handled above *) fun _ -> M.assertT V.zero B.nextT | B.Fault _ -> fun mstg -> M.para_bind_output_right mstz (fun _ -> mstg) | _ -> Warn.fatal "Unexpected return value do_stg") | B.Fault _ -> fun mstz -> mstz | _ -> Warn.fatal "Unexpected return value do_stz")) else do_stg >>| do_stz >>= M.ignore >>= B.next1T let stzg = do_stzg Once and stz2g = do_stzg Twice (*********************) (* Instruction fetch *) (*********************) let make_label_value proc lbl_str = A.V.cstToV (Constant.Label (proc, lbl_str)) let read_loc_instr a ii = M.read_loc false (mk_fetch Annot.N) a ii (************) (* Branches *) (************) let v2tgt = let open Constant in function | M.A.V.Val(Label (_, lbl)) -> Some (B.Lbl lbl) | M.A.V.Val (Concrete i) -> Some (B.Addr (M.A.V.Cst.Scalar.to_int i)) | _ -> None let do_indirect_jump test bds i ii v = match v2tgt v with | Some tgt -> commit_bcc ii >>= fun () -> M.unitT (B.Jump (tgt,bds)) | None -> match v with | M.A.V.Var(_) as v -> let lbls = get_exported_labels test in if Label.Full.Set.is_empty lbls then begin if C.variant Variant.Telechat then M.unitT () >>! B.Exit else Warn.fatal "Could find no potential target for indirect branch %s \ (potential targets are statically known labels)" (AArch64.dump_instruction i) end else commit_bcc ii >>= fun () -> B.indirectBranchT v lbls bds | _ -> Warn.fatal "illegal argument for the indirect branch instruction %s \ (must be a label)" (AArch64.dump_instruction i) let get_link_addr test ii = let lbl = let a = ii.A.addr + 4 in let lbls = test.Test_herd.entry_points a in Label.norm lbls in match lbl with | Some l -> ii.A.addr2v l | None -> V.intToV (ii.A.addr + 4) (********************) (* Main entry point *) (********************) (* Additonal type checking, control over discarded values. Namely, discarded value cannot be of type B.t, this would mean discarding a control flow result and replacing it systematically by B.Next. That way, some exit to end of code instructions would be ignored. See issue #287. *) let (!!!!) (m1:(unit list list * unit) M.t) = m1 >>= M.ignore >>= B.next1T let (!!!) (m1:(unit list * unit) M.t) = m1 >>= M.ignore >>= B.next1T let (!!) (m1:(unit * unit) M.t) = m1 >>= B.next2T let (!) (m1:unit M.t) = m1 >>= B.next1T let nextSet = B.nextSetT (* And now, just forget about >>! *) let [@warning "-32"](>>!) (_:unit) (_:unit) = () let do_build_semantics test inst ii = let open AArch64Base in match inst with | I_NOP ->(* Instructions nop and branch below do not generate events, use a placeholder *) !(M.mk_singleton_es (Act.NoAction) ii) (* Branches *) | I_B l -> M.mk_singleton_es (Act.NoAction) ii >>= fun () -> M.unitT (B.Jump (tgt2tgt ii l,[])) | I_BC(c,l)-> read_reg_ord NZCV ii >>= tr_cond c >>= fun v -> commit_bcc ii >>= fun () -> M.unitT (B.CondJump (v,tgt2tgt ii l)) | I_BL l -> let v_ret = get_link_addr test ii in let write_linkreg = write_reg AArch64Base.linkreg v_ret ii in let branch () = M.unitT (B.Jump (tgt2tgt ii l,[AArch64Base.linkreg,v_ret])) in M.bind_order write_linkreg branch | I_BR r as i -> read_reg_ord r ii >>= do_indirect_jump test [] i ii | I_BLR r as i -> let v_ret = get_link_addr test ii in let read_rn = read_reg_ord r ii in let branch = read_rn >>= do_indirect_jump test [AArch64Base.linkreg,v_ret] i ii in let write_linkreg = write_reg AArch64Base.linkreg v_ret ii in write_linkreg >>| branch >>= fun (_, b) -> M.unitT b | I_RET None when C.variant Variant.Telechat -> M.unitT B.Exit | I_RET ro as i -> let r = match ro with | None -> AArch64Base.linkreg | Some r -> r in read_reg_ord r ii >>= do_indirect_jump test [] i ii | I_ERET -> let eret_to_addr = function | M.A.V.Val(Constant.Label (_, l)) -> B.faultRetT l | _ -> Warn.fatal "Cannot determine ERET target" in let commit_eret ii = M.mk_singleton_es (Act.Commit (Act.ExcReturn,None)) ii in commit_eret ii >>= fun () -> read_reg_ord AArch64.elr_el1 ii >>= eret_to_addr | I_SVC _ -> let (>>!) = M.(>>!) in let ft = Some FaultType.AArch64.SupervisorCall in let m_fault = mk_fault None Dir.R Annot.N ii ft None in let lbl_v = get_instr_label ii in let lbl_ret = get_link_addr test ii in m_fault >>| set_elr_el1 lbl_ret ii >>! B.Fault [AArch64Base.elr_el1, lbl_v] | I_CBZ(_,r,l) -> (read_reg_ord r ii) >>= is_zero >>= fun v -> commit_bcc ii >>= fun () -> M.unitT (B.CondJump (v,tgt2tgt ii l)) | I_CBNZ(_,r,l) -> (read_reg_ord r ii) >>= is_not_zero >>= fun v -> commit_bcc ii >>= fun () -> M.unitT (B.CondJump (v,tgt2tgt ii l)) | I_TBZ(_,r,k,l) -> (read_reg_ord r ii) >>= M.op1 (Op.ReadBit k) >>= is_zero >>= fun v -> commit_bcc ii >>= fun () -> M.unitT (B.CondJump (v,tgt2tgt ii l)) | I_TBNZ(_,r,k,l) -> (read_reg_ord r ii) >>= M.op1 (Op.ReadBit k) >>= is_not_zero >>= fun v -> commit_bcc ii >>= fun () -> M.unitT (B.CondJump (v,tgt2tgt ii l)) (* Load and Store *) | I_LDR(var,rd,rs,e) -> let sz = tr_variant var in ldr sz rd rs e ii | I_LDRSW(rd,rs,e) -> ldrsw rd rs e ii | I_LDRBH (bh, rd, rs, e) -> let sz = bh_to_sz bh in ldr sz rd rs e ii | I_LDRS ((v, bh), rd, rs, e) -> let sz = bh_to_sz bh in ldrs sz (tr_variant v) rd rs e ii | I_LDUR(var,rd,rs,k) -> let sz = tr_variant var in ldr sz rd rs (MemExt.k2idx k) ii | I_LDAR(var,t,rd,rs) -> let sz = tr_variant var in ldar sz t rd rs ii | I_LDARBH(bh,t,rd,rs) -> let sz = bh_to_sz bh in ldar sz t rd rs ii | I_STR(var,rs,rd,e) -> str (tr_variant var) rs rd e ii | I_STRBH(bh,rs,rd,e) -> str (bh_to_sz bh) rs rd e ii | I_STLR(var,rs,rd) -> stlr (tr_variant var) rs rd ii | I_STLRBH(bh,rs,rd) -> stlr (bh_to_sz bh) rs rd ii | I_STZG(rt,rn,(k,Idx)) -> check_memtag "STZG" ; stzg rt rn k ii | I_STZ2G(rt,rn,(k,Idx)) -> check_memtag "STZ2G" ; check_mixed "STZ2G" ; stz2g rt rn k ii | I_STG(rt,rn,(k,Idx)) -> check_memtag "STG" ; stg Once rt rn k ii | I_LDG (rt,rn,k) -> check_memtag "LDG" ; ldg rt rn k ii | I_STXR(var,t,rr,rs,rd) -> stxr (tr_variant var) t rr rs rd ii | I_STXRBH(bh,t,rr,rs,rd) -> stxr (bh_to_sz bh) t rr rs rd ii (* Neon operations *) | I_ADDV(var,r1,r2) -> check_neon inst; !(addv var r1 r2 ii) | I_DUP(r1,var,r2) -> check_neon inst; !(let sz = tr_variant var in read_reg_ord_sz sz r2 ii >>= promote >>= fun v -> write_reg_neon_rep (neon_sz r1) r1 v ii) | I_FMOV_TG(_,r1,_,r2) -> check_neon inst; read_reg_neon false r2 ii >>= demote >>= fun v -> write_reg_dest r1 v ii >>= nextSet r1 | I_MOV_VE(r1,i1,r2,i2) -> check_neon inst; !(read_reg_neon_elem false r2 i2 ii >>= fun v -> write_reg_neon_elem MachSize.S128 r1 i1 v ii) | I_MOV_FG(r1,i,var,r2) -> check_neon inst; !(let sz = tr_variant var in read_reg_ord_sz sz r2 ii >>= promote >>= fun v -> write_reg_neon_elem MachSize.S128 r1 i v ii) | I_MOV_TG(_,r1,r2,i) -> check_neon inst; !(read_reg_neon_elem false r2 i ii >>= demote >>= fun v -> write_reg r1 v ii) | I_MOV_V(r1,r2) -> check_neon inst; !(read_reg_neon false r2 ii >>= fun v -> write_reg_neon r1 v ii) | I_MOV_S(var,r1,r2,i) -> check_neon inst; !(let sz = tr_simd_variant var in read_reg_neon_elem false r2 i ii >>= fun v -> write_reg_neon_sz sz r1 v ii) | I_MOVI_V(r,k,shift) -> check_neon inst; !(movi_v r k shift ii) | I_MOVI_S(var,r,k) -> check_neon inst; !(movi_s var r k ii) | I_OP3_SIMD(EOR,r1,r2,r3) -> check_neon inst; let sz = neon_sz r1 in !(read_reg_neon false r3 ii >>| read_reg_neon false r2 ii >>= fun (v1,v2) -> M.op Op.Xor v1 v2 >>= fun v -> write_reg_neon_sz sz r1 v ii) | I_ADD_SIMD(r1,r2,r3) -> check_neon inst; !(simd_add r1 r2 r3 ii) | I_ADD_SIMD_S(r1,r2,r3) -> check_neon inst; let sz = MachSize.Quad in !(read_reg_neon false r3 ii >>| read_reg_neon false r2 ii >>= sum_elems >>= fun v -> write_reg_neon_sz sz r1 v ii) (* Neon loads and stores *) | I_LDAP1(rs,i,rA,kr) -> check_neon inst; !!!(read_reg_ord rA ii >>= fun addr -> (mem_ss (load_elem_ldar MachSize.S128 i) addr rs ii >>| post_kr rA addr kr ii)) | I_LD1(rs,i,rA,kr) | I_LD2(rs,i,rA,kr) | I_LD3(rs,i,rA,kr) | I_LD4(rs,i,rA,kr) -> check_neon inst; !!!(read_reg_ord rA ii >>= fun addr -> (mem_ss (load_elem MachSize.S128 i) addr rs ii >>| post_kr rA addr kr ii)) | I_LD1R(rs,rA,kr) | I_LD2R(rs,rA,kr) | I_LD3R(rs,rA,kr) | I_LD4R(rs,rA,kr) -> check_neon inst; !!!(read_reg_ord rA ii >>= fun addr -> (mem_ss (load_elem_rep MachSize.S128) addr rs ii >>| post_kr rA addr kr ii)) | I_LD1M(rs,rA,kr) -> check_neon inst; !!(read_reg_ord rA ii >>= fun addr -> (load_m_contigous addr rs ii >>| post_kr rA addr kr ii)) | I_LD2M(rs,rA,kr) | I_LD3M(rs,rA,kr) | I_LD4M(rs,rA,kr) -> check_neon inst; !!(read_reg_ord rA ii >>= fun addr -> (load_m addr rs ii >>| post_kr rA addr kr ii)) | I_STL1(rs,i,rA,kr) -> check_neon inst; !!!(read_reg_ord rA ii >>= fun addr -> (mem_ss (store_elem_stlr i) addr rs ii >>| post_kr rA addr kr ii)) | I_ST1(rs,i,rA,kr) | I_ST2(rs,i,rA,kr) | I_ST3(rs,i,rA,kr) | I_ST4(rs,i,rA,kr) -> check_neon inst; !!!(read_reg_ord rA ii >>= fun addr -> (mem_ss (store_elem i) addr rs ii >>| post_kr rA addr kr ii)) | I_ST1M(rs,rA,kr) -> check_neon inst; !!!!(read_reg_ord rA ii >>= fun addr -> (store_m_contigous addr rs ii >>| post_kr rA addr kr ii)) | I_ST2M(rs,rA,kr) | I_ST3M(rs,rA,kr) | I_ST4M(rs,rA,kr) -> check_neon inst; !!!!(read_reg_ord rA ii >>= fun addr -> (store_m addr rs ii >>| post_kr rA addr kr ii)) | I_LDR_SIMD(var,r1,rA,MemExt.Reg(v,kr,sext,s)) -> check_neon inst; let access_size = tr_simd_variant var in get_ea_reg rA v kr sext s ii >>= fun addr -> simd_ldr access_size addr r1 ii >>= B.next1T | I_LDR_SIMD(var,r1,rA,MemExt.Imm (k,Idx)) -> check_neon inst; let access_size = tr_simd_variant var in get_ea_idx rA k ii >>= fun addr -> simd_ldr access_size addr r1 ii >>= B.next1T | I_LDR_SIMD(var,r1,rA,MemExt.Imm (k,PreIdx)) -> check_neon inst; let access_size = tr_simd_variant var in get_ea_preindexed rA k ii >>= fun addr -> simd_ldr access_size addr r1 ii >>= B.next1T | I_LDR_SIMD(var,r1,rA,MemExt.Imm (k,PostIdx)) -> check_neon inst; let access_size = tr_simd_variant var in read_reg_ord rA ii >>= fun addr -> simd_ldr access_size addr r1 ii >>| post_kr rA addr (K k) ii >>= B.next2T | I_LDUR_SIMD(var,r1,rA,k) -> check_neon inst; let access_size = tr_simd_variant var in get_ea rA (K k) S_NOEXT ii >>= fun addr -> simd_ldr access_size addr r1 ii >>= B.next1T | I_LDAPUR_SIMD(var,r1,rA,k) -> check_neon inst; let access_size = tr_simd_variant var in get_ea rA (K k) S_NOEXT ii >>= fun addr -> simd_ldar access_size addr r1 ii >>= B.next1T | I_STR_SIMD(var,r1,rA,MemExt.Reg (v,kr,sext,s)) -> check_neon inst; let access_size = tr_simd_variant var in let ma = get_ea_reg rA v kr sext s ii in simd_str access_size ma r1 ii | I_STR_SIMD(var,r1,rA,MemExt.Imm (k,Idx)) -> check_neon inst; let access_size = tr_simd_variant var in let ma = get_ea_idx rA k ii in simd_str access_size ma r1 ii | I_STR_SIMD(var,r1,rA,MemExt.Imm (k,PreIdx)) -> check_neon inst; let access_size = tr_simd_variant var in let ma = get_ea_preindexed rA k ii in simd_str access_size ma r1 ii | I_STR_SIMD(var,r1,rA,MemExt.Imm (k,PostIdx)) -> check_neon inst; let access_size = tr_simd_variant var in let ma = read_reg_ord rA ii in simd_str_p access_size ma r1 rA (K k) ii | I_STUR_SIMD(var,r1,rA,k) -> check_neon inst; let access_size = tr_simd_variant var in let ma = get_ea_idx rA k ii in simd_str access_size ma r1 ii | I_STLUR_SIMD(var,r1,rA,k) -> check_neon inst; let access_size = tr_simd_variant var in let ma = get_ea_idx rA k ii in simd_stlr access_size ma r1 ii | I_LDP_SIMD(tnt,var,r1,r2,r3,idx) -> check_neon inst; begin match idx with | k,Idx -> get_ea_idx r3 k ii >>= fun addr -> simd_ldp tnt var addr r1 r2 ii | k,PreIdx -> get_ea_preindexed r3 k ii >>= fun addr -> simd_ldp tnt var addr r1 r2 ii | k,PostIdx -> read_reg_ord r3 ii >>= fun addr -> (simd_ldp tnt var addr r1 r2 ii >>| post_kr r3 addr (K k) ii) >>= fun (b,()) -> M.unitT b end | I_STP_SIMD(tnt,var,r1,r2,r3,idx) -> check_neon inst; begin match idx with | k,Idx -> get_ea_idx r3 k ii >>= fun addr -> simd_stp tnt var addr r1 r2 ii | k,PreIdx -> get_ea_preindexed r3 k ii >>= fun addr -> simd_stp tnt var addr r1 r2 ii | k,PostIdx -> read_reg_ord r3 ii >>= fun addr -> (simd_stp tnt var addr r1 r2 ii >>| post_kr r3 addr (K k) ii) >>= fun (b,()) -> M.unitT b end (* Scalable vector instructions *) | I_LD1SP(var,rs,p,rA,MemExt.Imm (k,Idx)) | I_LD2SP(var,rs,p,rA,MemExt.Imm (k,Idx)) | I_LD3SP(var,rs,p,rA,MemExt.Imm (k,Idx)) | I_LD4SP(var,rs,p,rA,MemExt.Imm (k,Idx)) -> check_sve inst; !!!(let sz = tr_simd_variant var in let ma = get_ea_idx rA k ii in load_predicated_elem_or_zero_m sz p ma rs ii >>| M.unitT ()) | I_LD1SP(var,rs,p,rA,MemExt.Reg (V64,rM,MemExt.LSL,s)) | I_LD2SP(var,rs,p,rA,MemExt.Reg (V64,rM,MemExt.LSL,s)) | I_LD3SP(var,rs,p,rA,MemExt.Reg (V64,rM,MemExt.LSL,s)) | I_LD4SP(var,rs,p,rA,MemExt.Reg (V64,rM,MemExt.LSL,s)) -> check_sve inst; !!!(let sz = tr_simd_variant var in let ma = get_ea_reg rA V64 rM MemExt.LSL s ii in load_predicated_elem_or_zero_m sz p ma rs ii >>| M.unitT ()) | I_LD1SP (var,rs,p,rA,MemExt.ZReg (rM,sext,s)) -> check_sve inst; !(let sz = tr_simd_variant var in let ma = read_reg_ord rA ii in let mo = read_reg_scalable false rM ii in load_gather_predicated_elem_or_zero sz p ma mo rs sext s ii) | I_ST1SP(var,rs,p,rA,MemExt.Imm (k,Idx)) | I_ST2SP(var,rs,p,rA,MemExt.Imm (k,Idx)) | I_ST3SP(var,rs,p,rA,MemExt.Imm (k,Idx)) | I_ST4SP(var,rs,p,rA,MemExt.Imm (k,Idx)) -> check_sve inst; !!!!(let sz = tr_simd_variant var in let ma = get_ea_idx rA k ii in store_predicated_elem_or_merge_m sz p ma rs ii >>| M.unitT ()) | I_ST1SP(var,rs,p,rA,MemExt.Reg (V64,rM,MemExt.LSL,s)) | I_ST2SP(var,rs,p,rA,MemExt.Reg (V64,rM,MemExt.LSL,s)) | I_ST3SP(var,rs,p,rA,MemExt.Reg (V64,rM,MemExt.LSL,s)) | I_ST4SP(var,rs,p,rA,MemExt.Reg (V64,rM,MemExt.LSL,s)) -> check_sve inst; !!!!(let sz = tr_simd_variant var in let ma = get_ea_reg rA V64 rM MemExt.LSL s ii in store_predicated_elem_or_merge_m sz p ma rs ii >>| M.unitT ()) | I_ST1SP (var,rs,p,rA,MemExt.ZReg (rM,sext,s)) -> check_sve inst; !!!(let sz = tr_simd_variant var in let ma = read_reg_ord rA ii in let mo = read_reg_scalable false rM ii in store_scatter_predicated_elem_or_merge sz p ma mo rs sext s ii >>| M.unitT ()) | I_PTRUE(p,pattern) -> check_sve inst; ptrue p pattern ii >>= nextSet p | I_WHILELT(p,var,r1,r2) -> check_sve inst; while_op (M.op Op.Lt) false p var r1 r2 ii >>= nextSet p | I_WHILELO(p,var,r1,r2) -> check_sve inst; while_op (M.op Op.Lt) true p var r1 r2 ii >>= nextSet p | I_WHILELE(p,var,r1,r2) -> check_sve inst; while_op (M.op Op.Le) false p var r1 r2 ii >>= nextSet p | I_WHILELS(p,var,r1,r2) -> check_sve inst; while_op (M.op Op.Le) true p var r1 r2 ii >>= nextSet p | I_ADD_SV (r1,r2,r3) -> check_sve inst; !(add_sv r1 r2 r3 ii) | I_OP3_SV (EOR,r1,r2,r3) -> check_sve inst; !(read_reg_scalable false r3 ii >>| read_reg_scalable false r2 ii >>= fun (v1,v2) -> M.op Op.Xor v1 v2 >>= fun v -> write_reg_scalable r1 v ii) | I_UADDV(var,v,p,z) -> check_sve inst; !(uaddv var v p z ii) | I_MOVPRFX(r1,pg,r2) -> check_sve inst; !(movprfx r1 pg r2 ii) | I_NEG_SV(r1,pg,r2) -> check_sve inst; !(neg r1 pg r2 ii) | I_MOV_SV(r,k,shift) -> check_sve inst; !(mov_sv r k shift ii) | I_DUP_SV(r1,var,r2) -> check_sve inst; !(let sz = tr_variant var in read_reg_ord_sz sz r2 ii >>= promote >>= fun v -> write_reg_scalable_rep r1 v ii) | I_INDEX_SI (r1,var,r2,k) -> check_sve inst; let sz = tr_variant var in let v2 = V.intToV k in read_reg_ord_sz sz r2 ii >>= fun v1 -> index r1 v1 v2 ii >>= nextSet r1 | I_INDEX_IS (r1,var,k,r2) -> check_sve inst; let sz = tr_variant var in let v1 = V.intToV k in read_reg_ord_sz sz r2 ii >>= fun v2 -> index r1 v1 v2 ii >>= nextSet r1 | I_INDEX_SS (r1,var,r2,r3) -> check_sve inst; let sz = tr_variant var in read_reg_ord_sz sz r2 ii >>| read_reg_ord_sz sz r3 ii >>= fun (v1,v2) -> index r1 v1 v2 ii >>= nextSet r1 | I_INDEX_II (r1,k1,k2) -> check_sve inst; let v1 = V.intToV k1 in let v2 = V.intToV k2 in index r1 v1 v2 ii >>= nextSet r1 | I_RDVL (rd,k) -> check_sve inst; let v = scalable_nbytes * k |> V.intToV in write_reg_sz_dest MachSize.Quad rd v ii >>= nextSet rd |I_ADDVL (rd,rn,k) -> check_sve inst; let sz = MachSize.Quad in let off = scalable_nbytes * k in read_reg_ord_sz sz rn ii >>= M.op1 (Op.AddK off) >>= fun v -> write_reg_sz_dest sz rd v ii >>= nextSet rd | I_CNT_INC_SVE (op,r,pat,k) -> check_sve inst; cnt_inc op r pat k ii >>= nextSet r | I_SMSTART (None) -> check_sme inst; let ops1,vals1 = reset_sm V.one ii in let ops2,vals2 = reset_za V.one ii in read_reg_ord AArch64.SM ii >>| read_reg_ord AArch64.ZA ii >>= fun (sm,za) -> M.op Op.Ne sm V.one >>| M.op Op.Ne za V.one >>= fun (diffsm,diffza) -> M.choiceT diffsm (M.choiceT diffza (List.fold_right (>>::) (ops1@ops2) (M.unitT [()]) >>= M.ignore >>= fun () -> M.unitT (B.Next (vals1@vals2))) (List.fold_right (>>::) ops1 (M.unitT [()]) >>= M.ignore >>= fun () -> M.unitT (B.Next vals1))) (M.choiceT diffza (List.fold_right (>>::) ops2 (M.unitT [()]) >>= M.ignore >>= fun () -> M.unitT (B.Next vals2)) (B.nextT)) | I_SMSTART (Some(SM)) -> check_sme inst; let ops,vals = reset_sm V.one ii in read_reg_ord AArch64.SM ii >>= fun sm -> M.op Op.Ne sm V.one >>= fun diff -> M.choiceT diff (List.fold_right (>>::) ops (M.unitT [()]) >>= M.ignore >>= fun () -> M.unitT (B.Next vals)) (B.nextT) | I_SMSTART (Some(ZA)) -> check_sme inst; let ops,vals = reset_za V.one ii in read_reg_ord AArch64.ZA ii >>= fun sm -> M.op Op.Ne sm V.one >>= fun diff -> M.choiceT diff (List.fold_right (>>::) ops (M.unitT [()]) >>= M.ignore >>= fun () -> M.unitT (B.Next vals)) (B.nextT) | I_SMSTOP (None) -> let ops1,vals1 = reset_sm V.zero ii in let ops2,vals2 = reset_za V.zero ii in read_reg_ord AArch64.SM ii >>| read_reg_ord AArch64.ZA ii >>= fun (sm,za) -> M.op Op.Ne sm V.zero >>| M.op Op.Ne za V.zero >>= fun (diffsm,diffza) -> M.choiceT diffsm (M.choiceT diffza (List.fold_right (>>::) (ops1@ops2) (M.unitT [()]) >>= M.ignore >>= fun () -> M.unitT (B.Next (vals1@vals2))) (List.fold_right (>>::) ops1 (M.unitT [()]) >>= M.ignore >>= fun () -> M.unitT (B.Next vals1))) (M.choiceT diffza (List.fold_right (>>::) ops2 (M.unitT [()]) >>= M.ignore >>= fun () -> M.unitT (B.Next vals2)) (B.nextT)) | I_SMSTOP (Some(SM)) -> check_sme inst; let ops,vals = reset_sm V.zero ii in read_reg_ord AArch64.SM ii >>= fun sm -> M.op Op.Ne sm V.zero >>= fun diff -> M.choiceT diff (List.fold_right (>>::) ops (M.unitT [()]) >>= M.ignore >>= fun () -> M.unitT (B.Next vals)) (B.nextT) | I_SMSTOP (Some(ZA)) -> check_sme inst; let ops,vals = reset_za V.zero ii in read_reg_ord AArch64.ZA ii >>= fun sm -> M.op Op.Ne sm V.zero >>= fun diff -> M.choiceT diff (List.fold_right (>>::) ops (M.unitT [()]) >>= M.ignore >>= fun () -> M.unitT (B.Next vals)) (B.nextT) | I_MOVA_VT (za,ri,k,p,z) -> check_sme inst; mova_vt za ri k p z ii >>= nextSet za | I_MOVA_TV (z,p,za,ri,k) -> check_sme inst; mova_tv z p za ri k ii >>= nextSet z | I_ADDA (dir,za,p1,p2,z) -> check_sme inst; let pslice, pelem = match dir with | AArch64.Vertical -> p2,p1 | AArch64.Horizontal -> p1,p2 in adda dir za pslice pelem z ii >>= nextSet za | I_LD1SPT (var,za,ri,k,p,rA,MemExt.Imm(0,Idx)) -> check_sme inst; !(let sz = tr_simd_variant var in let ma = read_reg_ord rA ii in load_predicated_slice sz za ri k p ma ii) | I_LD1SPT(var,za,ri,k,p,rA,MemExt.Reg (V64,rM,MemExt.LSL,s)) -> !(let sz = tr_simd_variant var in let ma = get_ea_reg rA V64 rM MemExt.LSL s ii in load_predicated_slice sz za ri k p ma ii) | I_ST1SPT (var,za,ri,k,p,rA,MemExt.Imm(0,Idx)) -> check_sme inst; !!!(let sz = tr_simd_variant var in let ma = read_reg_ord rA ii in store_predicated_slice sz za ri k p ma ii >>| M.unitT ()) | I_ST1SPT (var,za,ri,k,p,rA,MemExt.Reg (V64,rM,MemExt.LSL,s)) -> !!!(let sz = tr_simd_variant var in let ma = get_ea_reg rA V64 rM MemExt.LSL s ii in store_predicated_slice sz za ri k p ma ii >>| M.unitT ()) (* Morello instructions *) | I_ALIGND(rd,rn,k) -> check_morello inst ; !((read_reg_ord_sz MachSize.S128 rn ii >>= fun v -> M.op Op.Alignd v (V.intToV k)) >>= fun v -> write_reg_sz MachSize.S128 rd v ii) | I_ALIGNU(rd,rn,k) -> check_morello inst ; !((read_reg_ord_sz MachSize.S128 rn ii >>= fun v -> M.op Op.Alignu v (V.intToV k)) >>= fun v -> write_reg_sz MachSize.S128 rd v ii) | I_BUILD(rd,rn,rm) -> check_morello inst ; !(begin read_reg_ord_sz MachSize.S128 rn ii >>| read_reg_ord_sz MachSize.S128 rm ii end >>= fun (a,b) -> M.op Op.Build a b >>= fun v -> write_reg_sz MachSize.S128 rd v ii) | I_CHKEQ(rn,rm) -> check_morello inst ; !(begin read_reg_ord_sz MachSize.S128 rn ii >>| read_reg_ord_sz MachSize.S128 rm ii end >>= fun (v1,v2) -> M.op Op.Eq v1 v2 >>= fun v -> M.op1 (Op.LeftShift 2) v >>= fun v -> write_reg NZCV v ii) | I_CHKSLD(rn) -> check_morello inst ; !(read_reg_ord_sz MachSize.S128 rn ii >>= fun v -> M.op1 Op.CheckSealed v >>= fun v -> write_reg NZCV v ii) | I_CHKTGD(rn) -> check_morello inst ; !(read_reg_ord_sz MachSize.S128 rn ii >>= fun v -> M.op1 Op.CapaGetTag v >>= fun v -> M.op1 (Op.LeftShift 1) v >>= fun v -> write_reg NZCV v ii) | I_CLRTAG(rd,rn) -> check_morello inst ; !(read_reg_ord_sz MachSize.S128 rn ii >>= fun (v) -> M.op Op.CapaSetTag v V.zero >>= fun v -> write_reg_sz MachSize.S128 rd v ii) | I_CPYTYPE(rd,rn,rm) -> check_morello inst ; !(begin read_reg_ord_sz MachSize.S128 rn ii >>| read_reg_ord_sz MachSize.S128 rm ii end >>= fun (v1,v2) -> M.op Op.CpyType v1 v2 >>= fun v -> write_reg_sz MachSize.S128 rd v ii) | I_CPYVALUE(rd,rn,rm) -> check_morello inst ; !(begin read_reg_ord_sz MachSize.S128 rn ii >>| read_reg_ord_sz MachSize.S128 rm ii end >>= fun (v1,v2) -> M.op Op.SetValue v1 v2 >>= fun v -> write_reg_sz MachSize.S128 rd v ii) | I_CSEAL(rd,rn,rm) -> check_morello inst ; !(begin read_reg_ord_sz MachSize.S128 rn ii >>| read_reg_ord_sz MachSize.S128 rm ii end >>= fun (v1,v2) -> M.op Op.CSeal v1 v2 >>= fun v -> write_reg_sz MachSize.S128 rd v ii >>= fun _ -> (* TODO: PSTATE overflow flag would need to be conditionally set *) write_reg NZCV M.A.V.zero ii) | I_GC(op,rd,rn) -> check_morello inst ; !(read_reg_ord_sz MachSize.S128 rn ii >>= begin fun c -> match op with | CFHI -> M.op1 (Op.LogicalRightShift 64) c | GCFLGS -> M.op1 (Op.AndK "0xff00000000000000") c | GCPERM -> M.op1 (Op.LogicalRightShift 110) c | GCSEAL -> M.op1 (Op.LeftShift 18) c >>= fun v -> M.op1 (Op.LogicalRightShift 113) v >>= fun v -> is_not_zero v | GCTAG -> M.op1 Op.CapaGetTag c | GCTYPE -> M.op1 (Op.LeftShift 18) c >>= fun v -> M.op1 (Op.LogicalRightShift 113) v | GCVALUE -> M.op1 (Op.Mask MachSize.Quad) c end >>= fun v -> write_reg_sz MachSize.Quad rd v ii) | I_SC(op,rd,rn,rm) -> check_morello inst ; !(begin read_reg_ord_sz MachSize.S128 rn ii >>| read_reg_ord_sz MachSize.Quad rm ii end >>= begin fun (cn, xm) -> match op with | CLRPERM -> M.op Op.ClrPerm cn xm | CTHI -> M.op Op.Cthi cn xm | SCFLGS -> begin M.op1 (Op.AndK "0x00ffffffffffffff") cn >>| M.op1 (Op.AndK "0xff00000000000000") xm end >>= fun (v,k) -> M.op Op.Or v k >>= fun v -> M.op Op.SetValue cn v | SCTAG -> M.op1 (Op.ReadBit 0) xm >>= fun cond -> M.op Op.CapaSetTag cn cond | SCVALUE -> M.op Op.SetValue cn xm end >>= fun v -> write_reg_sz MachSize.S128 rd v ii) | I_SEAL(rd,rn,rm) -> check_morello inst ; !(begin read_reg_ord_sz MachSize.S128 rn ii >>| read_reg_ord_sz MachSize.S128 rm ii end >>= fun (a,b) -> M.op Op.Seal a b >>= fun v -> write_reg_sz MachSize.S128 rd v ii) | I_STCT(rt,rn) -> check_morello inst ; (* NB: only 1 access implemented out of the 4 *) lift_morello (fun _ac ma mv -> do_insert_commit (ma >>| mv) (fun (a,v) -> !(do_write_morello_tag a v ii)) ii) (to_perms "tw" MachSize.S128) (read_reg_ord rn ii) (read_reg_data MachSize.Quad rt ii) Dir.W Annot.N ii | I_LDCT(rt,rn) -> check_morello inst ; (* NB: only 1 access implemented out of the 4 *) lift_morello (fun _ac ma _mv -> M.delay_kont "LDCT" ma (fun _a ma -> do_insert_commit ma (fun a -> (* Why check permissions again ? *) M.op (Op.CheckPerms "tr_c") a M.A.V.zero >>= fun v -> M.choiceT v (do_read_morello_tag a ii) mzero >>= fun tag -> !(write_reg_sz quad rt tag ii)) ii)) (to_perms "r" MachSize.S128) (read_reg_ord rn ii) mzero Dir.R Annot.N ii | I_UNSEAL(rd,rn,rm) -> check_morello inst ; !(begin read_reg_ord_sz MachSize.S128 rn ii >>| read_reg_ord_sz MachSize.S128 rm ii end >>= fun (a,b) -> M.op Op.Unseal a b >>= fun v -> write_reg_sz MachSize.S128 rd v ii) (* Operations *) | I_MOV(var,r,K k) -> mask32 var (fun k -> write_reg_dest r k ii >>= nextSet r) (V.intToV k) | I_MOV(var,r1,RV (_,r2)) -> let sz = tr_variant var in read_reg_ord_sz sz r2 ii >>= fun v -> write_reg_dest r1 v ii >>= nextSet r1 | I_MOVZ(var,rd,k,os) -> movz var rd k os ii >>= nextSet rd | I_MOVN (var,rd,k,os) -> movn var rd k os ii >>= nextSet rd | I_MOVK(var,rd,k,os) -> movk var rd k os ii >>= nextSet rd | I_ADR (r,tgt) -> let lbl = let open BranchTarget in match tgt with | Lbl lbl -> Some lbl | Offset o -> begin let a = ii.A.addr + o in let lbls = test.Test_herd.entry_points a in Label.norm lbls end in begin match lbl with | Some lbl -> let v = ii.A.addr2v lbl in write_reg_dest r v ii >>= nextSet r | None -> (* Delay error, only a poor fix. A complete possible fix would be having code addresses as values *) M.failT (Misc.Fatal "Overwriting with ADR, cannot handle") B.Exit end | I_RBIT (v,rd,rn) -> let sz = tr_variant v in read_reg_ord_sz sz rn ii >>= M.op1 (Op.Rbit sz) >>= fun v -> write_reg_dest rd v ii >>= nextSet rd | I_SXTW(rd,rs) -> read_reg_ord_sz MachSize.Word rs ii >>= sxtw_op >>= fun v -> write_reg_dest rd v ii >>= nextSet rd | I_ABS (v,rd,rs) -> let sz = tr_variant v in read_reg_ord_sz sz rs ii >>= sxt_op sz >>= M.op1 Op.Abs >>=fun v -> write_reg_dest rd v ii >>= nextSet rd | I_REV (rv,rd,rs) -> let sz = variant_of_rev rv |> tr_variant in read_reg_ord_sz sz rs ii >>= M.op1 (Op.RevBytes (container_size rv,sz)) >>= fun v -> write_reg_dest rd v ii >>= nextSet rd | I_OP3(v,op,rd,rn,e) -> let margs = let sz = tr_variant v in let mn = read_reg_ord_sz sz rn ii in begin let open AArch64.OpExt in match e with | Imm (k,s) -> mn >>| lsl_op s (V.intToV k) | OpExt.Reg (r,s) when AArch64Base.reg_compare rn r = 0 -> mn >>= fun v1 -> M.unitT v1 >>| opext_shift sz s v1 | Reg (r,s) -> mn >>| (read_reg_ord_sz sz r ii >>= opext_shift sz s) end in mop3 inst v op rd margs ii | I_EXTR (v,rd,rn,rm,lsb) -> let sz = tr_variant v in let nbits = MachSize.nbits sz in begin (read_reg_ord_sz sz rm ii >>= M.op1 (Op.LogicalRightShift lsb)) >>| (read_reg_ord_sz sz rn ii >>= M.op1 (Op.LeftShift (nbits-lsb))) end >>= fun (v1,v2) -> M.op Op.Or v1 v2 >>= fun v -> write_reg_dest rd v ii >>= nextSet rd | I_ADDSUBEXT (v,op,r1,r2,(v3,r3),(e,ko)) -> let op = match op with | Ext.ADD -> ADD | Ext.ADDS -> ADDS | Ext.SUB -> SUB | Ext.SUBS -> SUBS in let sz = tr_variant v in let m2 = read_reg_ord_sz sz r2 ii in let m3 = read_reg_ord_sz (tr_variant v3) r3 ii >>= ext_sext e ko in mop3 inst v op r1 (m2 >>| m3) ii | I_MOPL ((s,op),rd,rn,rm,ra) -> let ext = match s with | MOPLExt.Signed -> sxtw_op | MOPLExt.Unsigned -> M.unitT and op = match op with | MOPLExt.ADD -> Op.Add | MOPLExt.SUB -> Op.Sub in begin (read_reg_ord_sz MachSize.Word rn ii >>= ext) >>| (read_reg_ord_sz MachSize.Word rm ii >>= ext) >>| read_reg_ord_sz MachSize.Quad ra ii end >>= fun ((vn,vm),va) -> M.op Op.Mul vn vm >>= M.op op va >>= fun v -> write_reg_dest rd v ii >>= nextSet rd | I_MOP (op,v,rd,rn,rm,ra) -> let op = match op with | MOPExt.ADD -> Op.Add | MOPExt.SUB -> Op.Sub and sz = tr_variant v in begin (read_reg_ord_sz sz rn ii) >>| (read_reg_ord_sz sz rm ii) >>| read_reg_ord_sz sz ra ii end >>= fun ((vn,vm),va) -> M.op Op.Mul vn vm >>= M.op op va >>= fun v -> write_reg_dest rd v ii >>= nextSet rd (* Barrier *) | I_FENCE b -> !(create_barrier b ii) (* Conditional selection *) | I_CSEL (var,r1,r2,r3,c,op) -> let sz = tr_variant var in let mask = match op with | Cpy -> fun m -> m | Inc|Inv|Neg -> mask32 var in !(if not (C.variant Variant.NotWeakPredicated) then let(>>*=) = M.bind_control_set_data_input_first in let mok = commit_pred_txt (Some (pp_cond c)) ii >>*= fun () -> read_reg_data sz r2 ii >>= fun v -> write_reg r1 v ii in let mno = commit_pred_txt None ii >>*= fun () -> read_reg_data sz r3 ii >>= csel_op op >>= mask (fun v -> write_reg r1 v ii) in read_reg_ord NZCV ii >>= tr_cond c >>= fun v -> M.choiceT v mok mno else begin (read_reg_ord NZCV ii >>= tr_cond c) >>| read_reg_data sz r2 ii >>| read_reg_data sz r3 ii end >>= fun ((v,v2),v3) -> M.condPredT v (M.unitT ()) (write_reg r1 v2 ii) (csel_op op v3 >>= mask (fun v -> write_reg r1 v ii))) | I_SBFM (v,rd,rn,kr,ks) -> xbfm true v rd rn kr ks ii | I_UBFM (v,rd,rn,kr,ks) -> xbfm false v rd rn kr ks ii (* Swap *) | I_SWP (v,rmw,r1,r2,r3) -> swp (tr_variant v) rmw r1 r2 r3 ii | I_SWPBH (v,rmw,r1,r2,r3) -> swp (bh_to_sz v) rmw r1 r2 r3 ii (* Compare & Swap *) | I_CAS (v,rmw,rs,rt,rn) -> (* TODO: unify cas functions *) let cas = if morello then cas_morello else cas in cas (tr_variant v) rmw rs rt rn ii | I_CASBH (v,rmw,rs,rt,rn) -> (* TODO: unify cas functions *) let cas = if morello then cas_morello else cas in cas (bh_to_sz v) rmw rs rt rn ii | I_CASP (v,rmw,rs1,rs2,rt1,rt2,rn) -> casp (tr_variant v) rmw rs1 rs2 rt1 rt2 rn ii (* Fetch and Op *) | I_STOP (op,v,w,rs,rn) -> ldop op (tr_variant v) (w_to_rmw w) rs ZR rn ii | I_LDOP (op,v,rmw,rs,rt,rn) -> ldop op (tr_variant v) rmw rs rt rn ii | I_STOPBH (op,v,w,rs,rn) -> ldop op (bh_to_sz v) (w_to_rmw w) rs ZR rn ii | I_LDOPBH (op,v,rmw,rs,rt,rn) -> ldop op (bh_to_sz v) rmw rs rt rn ii (* Page tables and TLBs *) | I_TLBI (op, rd) -> !(read_reg_ord rd ii >>= fun a -> do_inv op a ii) (* Data cache instructions *) | I_DC (op,rd) -> do_dc op rd ii (* Instruction-cache maintenance instruction *) | I_IC (op,rd) -> do_ic op rd ii (* Load/Store pairs *) | I_LDP (tnt,v,r1,r2,r3,idx) -> ldp tnt (tr_variant v) r1 r2 r3 idx ii | I_LDPSW (r1,r2,r3,idx) -> ldpsw r1 r2 r3 idx ii | I_STP (tnt,v,r1,r2,r3,idx) -> stp tnt (tr_variant v) r1 r2 r3 idx ii | I_LDXP (v,t,r1,r2,r3) -> ldxp (tr_variant v) t r1 r2 r3 ii | I_STXP (v,t,r1,r2,r3,r4) -> stxp (tr_variant v) t r1 r2 r3 r4 ii (* * Read/Write system registers. * Notice thar NZCV is special: * Our NZCV register is a direct representation of * PSTATE., while SYS_NZCV is here only * as an argument to the MRS and MSR instructions. *) | I_MSR (sreg,xt) -> begin let sz = MachSize.Quad in match sreg with | SYS_NZCV -> read_reg_ord_sz sz xt ii >>= fun v -> M.op1 (Op.LogicalRightShift 28) v >>= M.op1 (Op.AndK "0b1111") >>= fun v -> write_reg_dest NZCV v ii >>= nextSet NZCV | _ -> begin let off = AArch64.sysreg_nv2off sreg in match C.variant Variant.NV2, off with | true, Some off -> let rd = SysReg AArch64.VNCR_EL2 in str_simple sz xt rd (get_ea_idx rd off ii) ii | _, _ -> read_reg_ord_sz sz xt ii >>= fun v -> write_reg_dest (SysReg sreg) v ii >>= nextSet (SysReg sreg) end end | I_MRS (xt,sreg) -> begin match sreg with | SYS_NZCV -> read_reg_ord NZCV ii >>= M.op1 (Op.LeftShift 28) >>= fun v -> write_reg_dest xt v ii >>= nextSet xt | _ -> begin let sz = MachSize.Quad in let off = AArch64.sysreg_nv2off sreg in match C.variant Variant.NV2, off with | true, Some off -> let rs = SysReg AArch64.VNCR_EL2 in let e = MemExt.Imm (off, Idx) in ldr sz xt rs e ii | _, _ -> read_reg_ord_sz sz (SysReg sreg) ii >>= fun v -> write_reg_dest xt v ii >>= nextSet xt end end | I_UDF _ -> let (>>!) = M.(>>!) in let ft = Some FaultType.AArch64.UndefinedInstruction in let m_fault = mk_fault None Dir.R Annot.N ii ft None in let lbl_v = get_instr_label ii in m_fault >>| set_elr_el1 lbl_v ii >>! B.Fault [AArch64Base.elr_el1, lbl_v] (* Cannot handle *) (* | I_BL _|I_BLR _|I_BR _|I_RET _ *) | (I_STG _|I_STZG _|I_STZ2G _ | I_OP3_SIMD _ | I_OP3_SV _ | I_LDR_SIMD _| I_STR_SIMD _ | I_LD1SP _| I_LD2SP _| I_LD3SP _| I_LD4SP _ | I_ST1SP _|I_ST2SP _|I_ST3SP _|I_ST4SP _ | I_SMSTART _ | I_SMSTOP _ |I_LD1SPT _ |I_ST1SPT _) as i -> Warn.fatal "illegal instruction: %s" (AArch64.dump_instruction i) (* Compute a safe set of instructions that can * overwrite another. By convention, those are * instructions pointed to by "exported" labels. *) let get_overwriting_instrs test = AArch64.state_fold (fun _ v k -> match v with | V.Val (Constant.Instruction i) -> i::k | _ -> k) test.Test_herd.init_state [] (* Test all possible instructions, when appropriate *) let check_self test ii = let module InstrSet = AArch64.V.Cst.Instr.Set in let inst = ii.A.inst in let lbls = get_exported_labels test in let is_exported = Label.Set.exists (fun lbl -> Label.Full.Set.exists (fun (_,lbl0) -> Misc.string_eq lbl lbl0) lbls) ii.A.labels in if is_exported then match Label.norm ii.A.labels with | None -> assert false | Some hd -> let insts = InstrSet.of_list (get_overwriting_instrs test) in let insts = InstrSet.add inst (InstrSet.filter AArch64.can_overwrite insts) in (* Shadow default control sequencing operator *) let(>>*=) = M.bind_control_set_data_input_first in let a_v = make_label_value ii.A.fetch_proc hd in let a = (* Normalised address of instruction *) A.Location_global a_v in read_loc_instr a ii >>= fun actual_val -> InstrSet.fold (fun inst k -> M.op Op.Eq actual_val (V.instructionToV inst) >>== fun cond -> M.choiceT cond (commit_pred ii >>*= fun () -> do_build_semantics test inst ii) k) insts begin (* Anything else than a legit instruction is a failure *) let (>>!) = M.(>>!) in let m_fault = mk_fault None Dir.R Annot.N ii (Some FaultType.AArch64.UndefinedInstruction) (Some "Invalid") in let lbl_v = get_instr_label ii in commit_pred ii >>*= fun () -> m_fault >>| set_elr_el1 lbl_v ii >>! B.Fault [AArch64Base.elr_el1, lbl_v] end else do_build_semantics test inst ii let build_semantics test ii = M.addT (A.next_po_index ii.A.program_order_index) begin if self then check_self test ii else do_build_semantics test ii.A.inst ii end let spurious_setaf v = test_and_set_af_succeeds v E.IdSpurious end end herd-herdtools7-1ca343e/herd/AArch64Sig.mli000066400000000000000000000036251475314470400203700ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2022-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Signatures of AArch64 "Sem" modules *) module type SubConfig = sig include GenParser.Config include Top_herd.CommonConfig include Sem.Config val libfind : string -> string val byte : MachSize.Tag.t end module type Config = sig module C : SubConfig val dirty : DirtyBit.t option val procs_user : Proc.t list val sve_vector_length : int val sme_vector_length : int end module type Semantics = Sem.Semantics with type A.instruction = AArch64Base.instruction and type A.parsedInstruction = AArch64Base.parsedInstruction and type A.reg = AArch64Base.reg and type 'ins A.kpseudo = 'ins AArch64Base.kpseudo module type MakeSemantics = functor(C:Config) -> functor(V:Value.AArch64) -> Semantics with module A.V = V herd-herdtools7-1ca343e/herd/ARMArch_herd.ml000066400000000000000000000112401475314470400206330ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Define ARM architecture *) module Types = struct type annot = A | L | X | XL | XA | N | NoRet type lannot = annot type explicit = Exp | NExp end module Make (C:Arch_herd.Config) (V:Value.S) = struct include ARMBase let is_amo _ = false let pp_barrier_short = pp_barrier let reject_mixed = false include Types let get_machsize _ = V.Cst.Scalar.machsize (* No mixed size instruction *) let empty_annot = N include PteValSets.No let is_barrier b1 b2 = barrier_compare b1 b2 = 0 let is_atomic = function | A | L | X | XL | XA | NoRet -> true | _ -> false let is_acquire = function | A | XA -> true | _ -> false let is_release = function | L | XL -> true | _ -> false let is_noreturn = function | NoRet -> true | _ -> false let ifetch_value_sets = [] let barrier_sets = [ "DMB",is_barrier (DMB SY); "DMB.ISH",is_barrier (DMB ISH); "DSB",is_barrier (DSB SY); "DMB.ST",is_barrier (DMB ST); "DSB.ST",is_barrier (DSB ST); "ISB", is_barrier ISB; ] let cmo_sets = [] let annot_sets = [ "X", is_atomic; "A", is_acquire; "L", is_release; "AL", is_acquire; "NoRet", is_noreturn; ] let explicit_sets = [ ] let pp_explicit = function | Exp -> "Exp" | NExp -> "" let is_explicit_annot = function | Exp -> true | NExp -> false and is_not_explicit_annot = function | NExp -> true | Exp -> false and is_ifetch_annot _ = false let nexp_annot = NExp let exp_annot = Exp let is_isync = is_barrier ISB let pp_isync = "isb" let pp_annot annot = match annot with | A -> "Acq" | L -> "Rel" | XA -> "Acq*" | XL -> "Rel*" | NoRet -> "NoRet" | N -> "" | X -> "*" module V = V let mem_access_size = function | I_NOP | I_ADD _ | I_ADD3 _ | I_SUB _ | I_SUB3 _ | I_AND _ | I_ORR _ | I_B _ | I_BX _ | I_BEQ _ | I_BNE _ | I_CB _ | I_CMPI _ | I_ANDC _ | I_CMP _ | I_MOVI _ | I_MOV _ | I_MOVW _ | I_MOVT _ | I_XOR _ | I_DMB _ | I_DSB _ | I_ISB | I_SADD16 _ | I_SEL _ -> None | I_LDR _ | I_LDREX _ | I_LDR3 _ | I_STR _ | I_STREX _ | I_STR3 _ | I_STL _ | I_LDA _|I_LDAEX _|I_STLEX _ | I_STR3_S _| I_LDR3_S _ | I_LDRO _ | I_LDM2 _ | I_LDM3 _ | I_LDRD _ -> Some MachSize.Word include NoSemEnv include NoLevelNorTLBI include ArchExtra_herd.Make(C) (struct module V = V let endian = endian type arch_reg = reg let pp_reg = pp_reg let reg_compare = reg_compare let fromto_of_instr _ = None let get_val _ v = v module FaultType=FaultType.No end) module MemType=MemoryType.No module NoConf = struct type v = V.v type loc = location type value_set = V.ValueSet.t type solution = V.solution type arch_lannot = lannot type arch_explicit = explicit end module ArchAction = ArchAction.No(NoConf) module Barrier = struct type a = barrier let a_to_b = let module N = AllBarrier in function | DSB SY -> N.DSB | DMB SY -> N.DMB | DMB ST -> N.DMBST | DSB ST -> N.DSBST | ISB -> N.ISB | a -> Warn.fatal "Barrier %s not implemented for CAV12" (pp_barrier a) let pp_isync = "isb" end module CMO = Cmo.No end herd-herdtools7-1ca343e/herd/ARMParseTest.ml000066400000000000000000000036541475314470400207000ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make(Conf:RunTest.Config)(ModelConfig:MemWithCav12.Config) = struct module LexConfig = struct let debug = Conf.debug.Debug_herd.lexer end module ArchConfig = SemExtra.ConfigToArchConfig(Conf) module ARMValue = Int32Value.Make(ARMBase.Instr) module ARM = ARMArch_herd.Make(ArchConfig)(ARMValue) module ARMLexParse = struct type instruction = ARM.parsedPseudo type token = ARMParser.token module Lexer = ARMLexer.Make(LexConfig) let lexer = Lexer.token let parser = MiscParser.mach2generic ARMParser.main end module ARMS = ARMSem.Make(Conf)(ARMValue) module ARMM = MemWithCav12.Make(ModelConfig)(ARMS) module P = GenParser.Make (Conf) (ARM) (ARMLexParse) module X = RunTest.Make (ARMS) (P) (ARMM) (Conf) let run = X.run end herd-herdtools7-1ca343e/herd/ARMParseTest.mli000066400000000000000000000024551475314470400210470ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make : functor(Conf:RunTest.Config) -> functor(ModelConfig:MemWithCav12.Config) -> sig val run : RunTest.runfun end herd-herdtools7-1ca343e/herd/ARMSem.ml000066400000000000000000000450371475314470400175130ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Semantics of ARM instructions *) module Make (C:Sem.Config) (V:Value.S with type Cst.Instr.t = ARMBase.instruction) = struct module ARM = ARMArch_herd.Make(SemExtra.ConfigToArchConfig(C))(V) module Act = MachAction.Make(C.PC)(ARM) include SemExtra.Make(C)(ARM)(Act) let aexp = ARM.Exp (* Explicit accesses *) (* Barrier pretty print *) let dmb = ARMBase.fold_barrier_option (fun o k -> { barrier = ARMBase.DMB o; pp = Misc.lowercase (ARMBase.pp_barrier_option "dmb" o);}::k) [] let dsb = ARMBase.fold_barrier_option (fun o k -> { barrier = ARMBase.DSB o; pp = Misc.lowercase (ARMBase.pp_barrier_option "dsb" o);}::k) dmb let barriers = dsb let isync = Some { barrier = ARMBase.ISB;pp = "isb";} let atomic_pair_allowed _ _ = true let v2tgt = let open Constant in function | M.A.V.Val(Label (_, lbl)) -> Some (B.Lbl lbl) | M.A.V.Val (Concrete i) -> Some (B.Addr (M.A.V.Cst.Scalar.to_int i)) | _ -> None (********************) (* Semantics proper *) (********************) module Mixed(SZ:ByteSize.S) = struct let (>>=) = M.(>>=) let (>>*=) = M.(>>*=) let (>>|) = M.(>>|) let (>>!) = M.(>>!) let (>>::) = M.(>>::) let do_indirect_jump test bds i v = match v2tgt v with | Some tgt -> M.unitT (B.Jump (tgt,bds)) | None -> match v with | M.A.V.Var(_) as v -> let lbls = get_exported_labels test in if Label.Full.Set.is_empty lbls then begin if C.variant Variant.Telechat then M.unitT () >>! B.Exit else Warn.fatal "Could find no potential target for indirect branch %s \ (potential targets are statically known labels)" (ARM.dump_instruction i) end else B.indirectBranchT v lbls bds | _ -> Warn.fatal "illegal argument for the indirect branch instruction %s \ (must be a label)" (ARM.dump_instruction i) let reg_sz = V.Cst.Scalar.machsize and nat_sz = V.Cst.Scalar.machsize let mk_read ato sz loc v = Act.Access (Dir.R, loc, v, ato,ARM.Exp, sz, Act.access_of_location_std loc) let read_reg is_data r ii = M.read_loc is_data (mk_read ARM.N reg_sz) (A.Location_reg (ii.A.proc,r)) ii let read_reg_ord = read_reg false let read_reg_data = read_reg true let read_mem sz a ii = M.read_loc false (mk_read ARM.N sz) (A.Location_global a) ii let read_mem_atomic sz a ii = M.read_loc false (mk_read ARM.X sz) (A.Location_global a) ii let do_read_mem_ret sz an anexp ac a ii = let mk_act loc v = Act.Access (Dir.R,loc,v,an,anexp,sz,ac) in let loc = A.Location_global a in M.read_loc false mk_act loc ii let write_loc sz loc v ii = let ac = Act.access_of_location_std loc in M.mk_singleton_es (Act.Access (Dir.W, loc, v, ARM.N, ARM.Exp, sz, ac)) ii let write_reg r v ii = M.mk_singleton_es (Act.Access (Dir.W, (A.Location_reg (ii.A.proc,r)), v, ARM.N, ARM.exp_annot, reg_sz, Access.REG)) ii let write_mem sz a v ii = M.mk_singleton_es (Act.Access (Dir.W, A.Location_global a, v, ARM.N, ARM.Exp, sz, Access.VIR)) ii (* Acquire / release semantics like AArch64 *) let do_read_mem sz an anexp ac rd a ii = do_read_mem_ret sz an anexp ac a ii >>= fun v -> write_reg rd v ii >>= fun () -> B.nextT let read_mem_acquire sz = do_read_mem sz ARM.A aexp Access.VIR let read_mem_acquire_ex sz = do_read_mem sz ARM.XA aexp Access.VIR let write_mem_atomic sz a v resa ii = let eq = [M.VC.Assign (a,M.VC.Atom resa)] in M.mk_singleton_es_eq (Act.Access (Dir.W, A.Location_global a, v, ARM.X, ARM.Exp, sz, Access.VIR)) eq ii let write_mem_atomic_release sz a v resa ii = let eq = [M.VC.Assign (a,M.VC.Atom resa)] in M.mk_singleton_es_eq (Act.Access (Dir.W, A.Location_global a, v, ARM.XL, ARM.Exp, sz, Access.VIR)) eq ii let write_mem_release sz a v ii = M.mk_singleton_es (Act.Access (Dir.W, A.Location_global a, v, ARM.L, ARM.Exp, sz, Access.VIR)) ii let write_flag r o v1 v2 ii = M.addT (A.Location_reg (ii.A.proc,r)) (M.op o v1 v2) >>= (fun (loc,v) -> write_loc reg_sz loc v ii) let create_barrier b ii = M.mk_singleton_es (Act.Barrier b) ii let commit bcc ii = M.mk_singleton_es (Act.Commit (bcc,None)) ii let flip_flag v = M.op Op.Xor v V.one let is_zero v = M.op Op.Eq v V.zero let is_not_zero v = M.op Op.Ne v V.zero let check_flag = function |ARM.AL -> assert false |ARM.NE -> flip_flag |ARM.EQ -> M.unitT let check_flag_op mf op ii = mf ii >>*= fun b -> M.choiceT b (op ii) (M.unitT ()) >>= B.next1T let checkZ op c ii = match c with | ARM.AL -> op ii >>= B.next1T | ARM.NE -> check_flag_op (fun ii -> read_reg_ord ARM.Z ii >>= flip_flag) op ii | ARM.EQ -> check_flag_op (read_reg_ord ARM.Z) op ii let write_flags set v1 v2 ii = match set with | ARM.SetFlags -> write_flag ARM.Z Op.Eq v1 v2 ii | ARM.DontSetFlags -> M.unitT () let build_semantics test ii = M.addT (A.next_po_index ii.A.program_order_index) begin match ii.A.inst with | ARM.I_NOP -> B.nextT | ARM.I_ADD (set,rd,rs,v) -> ((read_reg_ord rs ii) >>= (fun vs -> M.add vs (V.intToV v)) >>= (fun vres -> (write_reg rd vres ii) >>| write_flags set vres (V.intToV 0) ii)) >>= B.next2T | ARM.I_SUB (set,rd,rs,v) -> ((read_reg_ord rs ii) >>= (fun vs -> M.op Op.Sub vs (V.intToV v)) >>= (fun vres -> (write_reg rd vres ii) >>| write_flags set vres (V.intToV 0) ii)) >>= B.next2T | ARM.I_ADD3 (set,rd,rn,rm) -> (((read_reg_ord rn ii) >>| (read_reg_ord rm ii)) >>= (fun (vn,vm) -> M.op Op.Add vn vm >>= (fun vd -> write_reg rd vd ii >>| write_flags set vd (V.intToV 0) ii))) >>= B.next2T | ARM.I_SUB3 (set,rd,rn,rm) -> (((read_reg_ord rn ii) >>| (read_reg_ord rm ii)) >>= (fun (vn,vm) -> M.op Op.Sub vn vm >>= (fun vd -> write_reg rd vd ii >>| write_flags set vd (V.intToV 0) ii))) >>= B.next2T | ARM.I_AND (set,rd,rs,v) -> ((read_reg_ord rs ii) >>= (fun vs -> M.op Op.And vs (V.intToV v)) >>= (fun vres -> write_reg rd vres ii >>| write_flags set vres (V.intToV 0) ii)) >>= B.next2T | ARM.I_ANDC (c,rd,rs,rs2) -> let andc ii = ((read_reg_ord rs ii) >>| (read_reg_ord rs2 ii) >>= (fun (v1,v2) -> M.op Op.And v1 v2) >>= (fun vres -> write_reg rd vres ii)) in checkZ andc c ii | ARM.I_ORR (set,rd,rs,v) -> ((read_reg_ord rs ii) >>= (fun vs -> M.op Op.Or vs (V.intToV v)) >>= (fun vres -> write_reg rd vres ii >>| write_flags set vres (V.intToV 0) ii)) >>= B.next2T | ARM.I_B lbl -> B.branchT lbl | ARM.I_BEQ (lbl) -> read_reg_ord ARM.Z ii >>= fun v -> commit Act.Bcc ii >>= fun () -> B.bccT v lbl | ARM.I_BNE (lbl) -> read_reg_ord ARM.Z ii >>= fun v -> flip_flag v >>= fun vneg -> commit Act.Bcc ii >>= fun () -> B.bccT vneg lbl | ARM.I_BX r as i-> read_reg_ord r ii >>= do_indirect_jump test [] i | ARM.I_CB (n,r,lbl) -> let cond = if n then is_not_zero else is_zero in read_reg_ord r ii >>= cond >>= fun v -> commit Act.Bcc ii >>= fun () -> B.bccT v lbl | ARM.I_CMPI (r,v) -> ((read_reg_ord r ii) >>= (fun vr -> write_flags ARM.SetFlags vr (V.intToV v) ii)) >>= B.next1T | ARM.I_CMP (r1,r2) -> (((read_reg_ord r1 ii) >>| (read_reg_ord r2 ii)) >>= (fun (v1,v2) -> write_flags ARM.SetFlags v1 v2 ii)) >>= B.next1T | ARM.I_LDR (rt,rn,c) -> let ldr ii = (read_reg_ord rn ii) >>= (fun vn -> (read_mem nat_sz vn ii) >>= (fun v -> write_reg rt v ii)) in checkZ ldr c ii | ARM.I_LDRD (rd1,rd2,ra, None) -> read_reg_ord ra ii >>= fun a -> (read_mem nat_sz a ii) >>| (M.add a (V.intToV 4) >>= fun a2->read_mem nat_sz a2 ii) >>= fun (v1,v2) -> write_reg rd1 v1 ii >>| write_reg rd2 v2 ii >>= B.next2T | ARM.I_LDRD (rd1,rd2,ra, Some k) -> read_reg_ord ra ii >>= fun a -> (M.add a (V.intToV k) >>= fun a-> ((read_mem nat_sz a ii) >>| (M.add a (V.intToV 4) >>= fun a2->read_mem nat_sz a2 ii))) >>= fun (v1,v2) -> write_reg rd1 v1 ii >>| write_reg rd2 v2 ii >>= B.next2T | ARM.I_LDM2 (ra,r1,r2,i) -> (read_reg_ord ra ii) >>= (fun va -> (match i with | ARM.NO -> M.unitT va | ARM.IB -> (M.add va (V.intToV 4))) >>= fun va -> (read_mem nat_sz va ii) >>| (M.add va (V.intToV 4) >>= fun vb -> read_mem nat_sz vb ii)) >>= fun (v1,v2) -> (write_reg r1 v1 ii >>| write_reg r2 v2 ii) >>= B.next2T | ARM.I_LDM3 (ra,r1,r2,r3,i) -> (read_reg_ord ra ii) >>= (fun va -> (match i with | ARM.NO -> M.unitT va | ARM.IB -> (M.add va (V.intToV 4))) >>= fun va -> (M.unitT va >>| M.add va (V.intToV 4) >>| M.add va (V.intToV 8)) >>= fun ((v1,v2),v3) -> (read_mem nat_sz v1 ii >>| (read_mem nat_sz v2 ii >>| read_mem nat_sz v3 ii))) >>= fun (v1,(v2,v3)) -> (write_reg r1 v1 ii >>| write_reg r2 v2 ii >>| write_reg r3 v3 ii) >>= B.next3T | ARM.I_LDRO (rd,rs,v,c) -> let ldr ii = read_reg_ord rs ii >>= (fun vn -> M.add vn (V.intToV v) >>= fun vn -> read_mem nat_sz vn ii >>= fun v -> write_reg rd v ii) in checkZ ldr c ii | ARM.I_LDREX (rt,rn) -> let ldr ii = (read_reg_ord rn ii) >>= (fun vn -> write_reg ARM.RESADDR vn ii >>| (read_mem_atomic nat_sz vn ii >>= fun v -> write_reg rt v ii)) in ldr ii >>= B.next2T | ARM.I_LDAEX (rt,rn) -> (read_reg_ord rn ii) >>= (fun vn -> write_reg ARM.RESADDR vn ii >>| (read_mem_acquire_ex nat_sz rt vn ii)) >>= fun (_,_) -> B.nextT | ARM.I_LDA (rt,rn) -> (read_reg_ord rn ii) >>= fun vn -> read_mem_acquire nat_sz rt vn ii >>= fun _ -> B.nextT | ARM.I_LDR3 (rt,rn,rm,c) -> let ldr3 ii = ((read_reg_ord rn ii) >>| (read_reg_ord rm ii)) >>= (fun (vn,vm) -> (M.add vn vm) >>= (fun vaddr -> (read_mem nat_sz vaddr ii) >>= (fun v -> write_reg rt v ii))) in checkZ ldr3 c ii | ARM.I_LDR3_S (rt,rn,rm,ARM.S_LSL k, c) -> let ldr3 ii = ((read_reg_ord rn ii) >>| (read_reg_ord rm ii)) >>= (fun (vn,vm) -> (M.op1 (Op.LeftShift k) vm) >>= fun vm -> (M.add vn vm) >>= (fun vaddr -> (read_mem nat_sz vaddr ii) >>= (fun v -> write_reg rt v ii))) in checkZ ldr3 c ii | ARM.I_STR (rt,rn,c) -> let str ii = ((read_reg_ord rn ii) >>| (read_reg_data rt ii)) >>= (fun (vn,vt) -> let a = vn in (write_mem nat_sz a vt ii)) in checkZ str c ii | ARM.I_STL (rt,rn,c) -> let str ii = ((read_reg_ord rn ii) >>| (read_reg_data rt ii)) >>= (fun (vn,vt) -> let a = vn in (write_mem_release nat_sz a vt ii)) in checkZ str c ii | ARM.I_STR3 (rt,rn,rm,c) -> let str3 ii = (((read_reg_ord rm ii) >>| ((read_reg_ord rn ii) >>| (read_reg_data rt ii))) >>= (fun (vm,(vn,vt)) -> (M.add vn vm) >>= (fun a -> (write_mem nat_sz a vt ii)))) in checkZ str3 c ii | ARM.I_STR3_S (rt,rn,rm,ARM.S_LSL k, c) -> let str3 ii = (((read_reg_ord rm ii) >>| ((read_reg_ord rn ii) >>| (read_reg_data rt ii))) >>= (fun (vm,(vn,vt)) -> (M.op1 (Op.LeftShift k) vm) >>= fun vm -> (M.add vn vm) >>= (fun a -> (write_mem nat_sz a vt ii)))) in checkZ str3 c ii | ARM.I_STREX (r1,r2,r3,c) -> let strex ii = (read_reg_ord ARM.RESADDR ii >>| read_reg_data r2 ii >>| read_reg_ord r3 ii) >>= fun ((resa,v),a) -> (write_reg ARM.RESADDR V.zero ii >>| M.altT (write_reg r1 V.one ii) ((write_reg r1 V.zero ii >>| write_mem_atomic nat_sz a v resa ii) >>! ())) >>! () in checkZ strex c ii | ARM.I_STLEX (r1,r2,r3) -> let stlex ii = (read_reg_ord ARM.RESADDR ii >>| read_reg_data r2 ii >>| read_reg_ord r3 ii) >>= fun ((resa,v),a) -> (write_reg ARM.RESADDR V.zero ii >>| M.altT (write_reg r1 V.one ii) ((write_reg r1 V.zero ii >>| write_mem_atomic_release nat_sz a v resa ii) >>! ())) >>! () in checkZ stlex ARM.AL ii | ARM.I_MOV (rd, rs, c) -> let mov ii = read_reg_ord rs ii >>= fun v -> write_reg rd v ii in checkZ mov c ii | ARM.I_MOVI (rt, i, c) -> let movi ii = write_reg rt (V.intToV i) ii in checkZ movi c ii | ARM.I_MOVW (rt, k, c) -> assert (MachSize.is_imm16 k); let movi ii = write_reg rt (V.intToV k) ii in checkZ movi c ii | ARM.I_MOVT (rt, k, c) -> assert (MachSize.is_imm16 k); let movi ii = M.op1 (Op.LeftShift 16) (V.intToV k) >>= fun k -> write_reg rt k ii in checkZ movi c ii | ARM.I_XOR (set,r3,r1,r2) -> (((read_reg_ord r1 ii) >>| (read_reg_ord r2 ii)) >>= (fun (v1,v2) -> M.op Op.Xor v1 v2 >>= (fun v3 -> write_reg r3 v3 ii >>| write_flags set v3 (V.intToV 0) ii))) >>= B.next2T | ARM.I_DMB o -> (create_barrier (ARM.DMB o) ii) >>= B.next1T | ARM.I_DSB o -> (create_barrier (ARM.DSB o) ii) >>= B.next1T | ARM.I_ISB -> (create_barrier ARM.ISB ii) >>= B.next1T | ARM.I_SADD16 _ -> Warn.user_error "SADD16 not implemented" | ARM.I_SEL _ -> Warn.user_error "SEL not implemented" end let spurious_setaf _ = assert false end end herd-herdtools7-1ca343e/herd/ASLAction.ml000066400000000000000000000232351475314470400202000ustar00rootroot00000000000000(******************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (******************************************************************************) (* Authors: *) (* Hadrien Renaud, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) open Dir module type Config = sig val hexa: bool end module type S = sig include Arch_herd.S val is_local : reg -> bool val is_pc : reg -> bool end module Make (C: Config) (A : S) = struct module A = A module V = A.V type action = | Access of dirn * A.location * A.V.v * MachSize.sz * AArch64Annot.t | Barrier of A.barrier | Branching of string option | CutOff of string | NoAction let mk_init_write loc sz v = Access (W, loc, v, sz, AArch64Annot.N) let pp_action = function | Access (d, l, v, _sz,a) -> Printf.sprintf "%s%s=%s%s" (pp_dirn d) (A.pp_location l) (V.pp C.hexa v) (let open AArch64Annot in match a with | N -> "" | _ -> AArch64Annot.pp a) | Barrier b -> A.pp_barrier_short b | Branching txt -> Printf.sprintf "Branching(%s)" (Misc.app_opt_def "" Misc.identity txt) | CutOff msg -> Printf.sprintf "CutOff:%s" msg | NoAction -> "" let is_local = function | Access (_, A.Location_reg (_, r), _, _, _) -> A.is_local r | Access _|Barrier _|Branching _|CutOff _|NoAction -> false (** Write to PC *) let is_wpc = function | Access (Dir.W, A.Location_reg (_, r), _, _, _) -> A.is_pc r | _ -> false (* Some architecture-specific sets and relations, with their definitions *) let arch_sets = [ ("ASLLocal", is_local); ("WPC",is_wpc); ] let arch_rels = [] let arch_dirty = [] let is_isync _ = false let pp_isync = "ISYNC" (**************************************) (* Access to sub_components of events *) (**************************************) let value_of = function | Access (_, _, v, _, _) -> Some v | Barrier _|Branching _|CutOff _|NoAction -> None let read_of = function | Access (R, _, v, _, _) -> Some v | Access _|Barrier _|Branching _|CutOff _|NoAction -> None let written_of = function | Access (W, _, v, _, _) -> Some v | Access _|Barrier _| Branching _|CutOff _|NoAction -> None let location_of = function | Access (_, l, _, _, _) -> Some l | Branching _|Barrier _|CutOff _|NoAction -> None (************************) (* Predicates on events *) (************************) (* relative to memory *) let is_mem_store = function | Access (W, A.Location_global _, _, _, _) -> true | Access _| Branching _|Barrier _|CutOff _|NoAction -> false let is_mem_load = function | Access (R, A.Location_global _, _, _, _) -> true | Access _| Branching _|Barrier _|CutOff _|NoAction -> false let is_additional_mem_load = function | Access _| Branching _|Barrier _|CutOff _|NoAction -> false let is_mem = function | Access (_, A.Location_global _, _, _, _) -> true | Access _| Branching _|Barrier _|CutOff _|NoAction -> false let is_ifetch = function | Access _| Branching _|Barrier _|CutOff _|NoAction -> false let is_tag = function | Access _| Branching _|Barrier _|CutOff _|NoAction -> false let is_additional_mem = function | Access _| Branching _|Barrier _|CutOff _|NoAction -> false let is_atomic = function | Access _| Branching _|Barrier _|CutOff _|NoAction -> false let is_fault = function | Access _| Branching _|Barrier _|CutOff _|NoAction -> false let to_fault = function | Access _| Branching _|Barrier _|CutOff _|NoAction -> None let get_mem_dir = function | Access (d, A.Location_global _, _, _, _) -> d | Access _| Branching _|Barrier _|CutOff _|NoAction -> assert false let get_mem_size = function | Access (_, A.Location_global _, _, sz, _) -> sz | Access _| Branching _|Barrier _|CutOff _|NoAction -> assert false let is_pte_access = function | Access _| Branching _|Barrier _|CutOff _|NoAction -> false let is_explicit = function | Access _| Branching _|Barrier _|CutOff _|NoAction -> false let is_not_explicit = function | Access _| Branching _|Barrier _|CutOff _|NoAction -> false (* relative to the registers of the given proc *) let is_reg_store = function | Access (W, A.Location_reg (p, _), _, _, _) -> Proc.equal p | Access _|Barrier _|Branching _|CutOff _|NoAction -> fun _ -> false let is_reg_load = function | Access (R, A.Location_reg (p, _), _, _, _) -> Proc.equal p | Access _|Barrier _|Branching _|CutOff _|NoAction -> fun _ -> false let is_reg = function | Access (_, A.Location_reg (p, _), _, _, _) -> Proc.equal p | Access _|Barrier _|Branching _|CutOff _|NoAction -> fun _ -> false (* Reg events, proc not specified *) let is_reg_store_any = function | Access (W, A.Location_reg _, _, _, _) -> true | Access _|Barrier _|Branching _|CutOff _|NoAction -> false let is_reg_load_any = function | Access (R, A.Location_reg _, _, _, _) -> true | Access _|Barrier _|Branching _|CutOff _|NoAction -> false let is_reg_any = function | Access (_, A.Location_reg _, _, _, _) -> true | Access _|Barrier _|Branching _|CutOff _|NoAction -> false (* Store/Load to memory or register *) let is_store = function | Access (W, _, _, _, _) -> true | Access _|Barrier _|Branching _|CutOff _|NoAction -> false let is_load = function | Access (R, _, _, _, _) -> true | Access _|Barrier _|Branching _|CutOff _|NoAction -> false (* Compatible accesses *) let compatible_accesses _a1 _a2 = true (* for bell annotations *) let annot_in_list _str _act = false (* Barriers *) let is_barrier = function | Barrier _ -> true | Access _|Branching _|CutOff _|NoAction -> false let barrier_of = function | Barrier b -> Some b | Access _|Branching _|CutOff _|NoAction -> None let same_barrier_id _a1 _a2 = assert false (* Commits *) let is_bcc = function | Access _| Branching _|Barrier _|CutOff _|NoAction -> false let is_pred ?(cond=None) = function | Branching cond0 -> Option.is_none cond || Option.equal String.equal cond cond0 | Access _|Barrier _|CutOff _|NoAction -> false let is_commit = function | Branching _ -> true | Access _|Barrier _|CutOff _|NoAction -> false (* Unrolling control *) let cutoff msg = CutOff msg let is_cutoff = function | CutOff _ -> true | Access _|Barrier _|Branching _|NoAction -> false and as_cutoff = function | CutOff msg -> Some msg | Access _|Barrier _|Branching _|NoAction -> None (********************) (* Equation solving *) (********************) let undetermined_vars_in_action = function | Access (_, l, v, _, _) -> V.ValueSet.union (A.undetermined_vars_in_loc l) (V.undetermined_vars v) | Barrier _ | Branching _| CutOff _ | NoAction -> V.ValueSet.empty let simplify_vars_in_action soln a = match a with | Access (d, l, v, sz, a) -> Access (d, A.simplify_vars_in_loc soln l, V.simplify_var soln v, sz, a) | Barrier _ | Branching _ | CutOff _ | NoAction -> a end module FakeModuleForCheckingSignatures (C: Config) (A : S) : Action.S with module A = A = Make (C) (A) herd-herdtools7-1ca343e/herd/ASLParseTest.ml000066400000000000000000000065511475314470400206770ustar00rootroot00000000000000(******************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (******************************************************************************) (* Authors: *) (* Hadrien Renaud, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) module Make (Conf : RunTest.Config) (ModelConfig : MemCat.Config) = struct module ArchConfig = SemExtra.ConfigToArchConfig (Conf) module ASLS = ASLSem.Make (Conf) module ASLA = ASLS.A module ASLLexParse = struct type instruction = ASLA.parsedPseudo type token = Asllib.Tokens.token let lexer = let module Lexer = Asllib.Lexer.Make(struct let allow_double_underscore = false let allow_unknown = false end) in Lexer.token let parser = let version = if Conf.variant (Variant.ASLVersion `ASLv0) then `ASLv0 else `ASLv1 in ASLBase.asl_generic_parser version end module ASLM = MemCat.Make (ModelConfig) (ASLS) module P = GenParser.Make (Conf) (ASLA) (ASLLexParse) module X = RunTest.Make (ASLS) (P) (ASLM) (Conf) let run = X.run end herd-herdtools7-1ca343e/herd/ASLParseTest.mli000066400000000000000000000052351475314470400210460ustar00rootroot00000000000000(******************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (******************************************************************************) (* Authors: *) (* Hadrien Renaud, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) module Make : functor (Conf : RunTest.Config) (ModelConfig : MemCat.Config) -> sig val run : RunTest.runfun end herd-herdtools7-1ca343e/herd/ASLSem.ml000066400000000000000000001075521475314470400175140ustar00rootroot00000000000000(******************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (******************************************************************************) (* Authors: *) (* Hadrien Renaud, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* Jade Alglave, Arm Ltd and UCL, UK. *) (******************************************************************************) (* Disclaimer: *) (* This material covers both ASLv0 (viz, the existing ASL pseudocode language *) (* which appears in the Arm Architecture Reference Manual) and ASLv1, a new, *) (* experimental, and as yet unreleased version of ASL. *) (* This material is work in progress, more precisely at pre-Alpha quality as *) (* per Arm’s quality standards. *) (* In particular, this means that it would be premature to base any *) (* production tool development on this material. *) (* However, any feedback, question, query and feature request would be most *) (* welcome; those can be sent to Arm’s Architecture Formal Team Lead *) (* Jade Alglave , or by raising issues or PRs to the *) (* herdtools7 github repository. *) (******************************************************************************) (* A quick note on monads: ----------------------- We use three main connecters here: - the classic data binder ( [>>=] ) - a control binder ( [>>*=] or assimilate) - a sequencing operator ( [M.para_bind_output_right] ) And some specialized others: - the parallel operator ( [>>|] ) - a choice operation Monad type has: - input: EventSet - output: EventSet - data_input: EventSet - ctrl_output: EventSet - iico_data: EventRel - iico_ctrl: EventRel Description of the main data binders: - _data_ binders: iico_data U= 1.output X 2.data_input input = 1.input (or 2.input if 1 is empty) same with data_input output = 2.ouput (or 1.output if 2.output is None) same-ish with ctrl_output - _seq_ binder (called [para_bind_output_right]): input = 1.input U 2.input same with data_input output = 2.output ctrl_output = 1.ctrl_output U 2.ctrl_output - _ctrl_ binder (called [bind_ctrl_seq_data]): iico_ctrl U= 1.ctrl_output X 2.input input = 1.input (or 2.input if 1 is empty) same with data_input output = 2.output (or 1.output if 2.output is None) same-ish with ctrl_output *) module AST = Asllib.AST module ASTUtils = Asllib.ASTUtils open ASLBase module type Config = sig include Sem.Config val libfind : string -> string end module Make (C : Config) = struct module V = ASLValue.V module ConfLoc = struct include SemExtra.ConfigToArchConfig (C) let default_to_symb = C.variant Variant.ASL end module ASL64AH = struct include GenericArch_herd.Make (ASLBase) (ConfLoc) (V) include ASLBase let opt_env = true end module Act = ASLAction.Make (C.PC) (ASL64AH) include SemExtra.Make (C) (ASL64AH) (Act) let is_experimental = C.variant Variant.ASLExperimental module TypeCheck = Asllib.Typing.Annotate (struct let check = let open Asllib.Typing in if C.variant (Variant.ASLType `Warn) then Warn else if C.variant (Variant.ASLType `TypeCheck) then TypeCheckNoWarn else Silence let output_format = Asllib.Error.HumanReadable let print_typed = false let use_field_getter_extension = is_experimental end) module ASLInterpreterConfig = struct let unroll = match C.unroll with None -> Opts.unroll_default `ASL | Some u -> u let error_handling_time = Asllib.Error.Dynamic module Instr = Asllib.Instrumentation.SemanticsNoInstr end let barriers = [] let isync = None let atomic_pair_allowed _ _ = true let aneutral = AArch64Annot.N module Mixed (SZ : ByteSize.S) : sig val build_semantics : test -> A.inst_instance_id -> (proc * branch) M.t val spurious_setaf : A.V.v -> unit M.t end = struct module Mixed = M.Mixed (SZ) let ( let* ) = M.asl_data let ( let*| ) = M.asl_seq let ( and* ) = M.( >>| ) let return = M.unitT let ( >>= ) = M.asl_data let ( >>! ) = M.( >>! ) (**************************************************************************) (* ASL-PO handling *) (**************************************************************************) let incr (poi : A.program_order_index ref) : A.program_order_index = let i = !poi in let () = poi := A.next_po_index i in i let use_ii_with_poi ii poi = let program_order_index = incr poi in { ii with A.program_order_index } (**************************************************************************) (* Values handling *) (**************************************************************************) (* * Non-resolved values are "frozen" into constants. * Useful for storing them into vector of constants. * Notice: such "constants" are usable only when * extracted from vectors. * See `unfreeze` below. *) let as_constant = function | V.Val c -> c | V.Var id -> Constant.Frozen id let v_unknown_of_type ~eval_expr_sef:(_: Asllib.AST.expr -> V.v M.t) _t = return (V.fresh_var ()) let v_of_literal = let open AST in let open ASLScalar in let concrete v = Constant.Concrete v in let tr = function | L_Int i -> S_Int i |> concrete | L_Bool b -> S_Bool b |> concrete | L_BitVector bv -> S_BitVector bv |> concrete | L_Real _f -> Printf.eprintf "real: %s\n%!" (Q.to_string _f); Warn.fatal "Cannot use reals yet." | L_String _f -> Warn.fatal "Cannot instantiate strings in herd yet." | L_Label s -> S_Label s |> concrete in fun v -> V.Val (tr v) let v_to_z = function | V.Val (Constant.Concrete (ASLScalar.S_Int i)) -> Some i | _ -> None let v_to_label = function | V.Val (Constant.Concrete (ASLScalar.S_Label l)) -> l | v -> Warn.fatal "Cannot make a label out of value %s" (V.pp_v v) let v_as_int = function | V.Val (Constant.Concrete i) -> V.Cst.Scalar.to_int i | v -> Warn.fatal "Cannot concretise symbolic value: %s" (V.pp_v v) let v_as_record = function | V.Val (Constant.ConcreteRecord map) -> map | v -> Warn.fatal "Cannot concretise symbolic value %s as a record" (V.pp_v v) let v_as_bool = function | Constant.Concrete (ASLScalar.S_Bool b) -> b | c -> Warn.fatal "Cannot concretise symbolic value %s as a boolean" (V.pp_v (V.Val c)) let datasize_to_machsize v = match v_as_int v with | 32 -> MachSize.Word | 64 -> MachSize.Quad | 128 -> MachSize.S128 | _ -> Warn.fatal "Cannot access a register or memory with size %s" (V.pp_v v) let access_bool_field v f map = try StringMap.find f map |> v_as_bool with Not_found -> Warn.fatal "Record %s has no %s field" (V.pp_v v) f let accdesc_to_annot is_read accdesc = let open AArch64Annot in let map = v_as_record accdesc in let is_release = access_bool_field accdesc "relsc" map and is_acquiresc = access_bool_field accdesc "acqsc" map and is_acquirepc = access_bool_field accdesc "acqpc" map and is_atomic = access_bool_field accdesc "atomicop" map and is_exclusive = access_bool_field accdesc "exclusive" map in let is_ax x n = if is_atomic || is_exclusive then x else n in let an = if (not is_read) && is_release then is_ax XL L else if is_read && is_acquiresc then is_ax XA A else if is_read && is_acquirepc then is_ax XQ Q else is_ax X N in let () = if false && an <> N then Printf.eprintf "ASL -> AArch64 Memory annotation %s\n%!" (AArch64Annot.pp an) in an let to_bv sz = M.op1 (Op.ArchOp1 (ASLOp.ToBV (MachSize.nbits sz))) let to_int_unsigned = M.op1 (Op.ArchOp1 ASLOp.ToIntU) let to_int_signed = M.op1 (Op.ArchOp1 ASLOp.ToIntS) (**************************************************************************) (* Special monad interactions *) (**************************************************************************) let create_barrier b ii = M.mk_singleton_es (Act.Barrier b) ii >>! [] let resize_from_quad = function | MachSize.Quad -> return | sz -> ( function | V.Val (Constant.Symbolic _) as v -> return v | v -> M.op1 (Op.Mask sz) v) let write_loc sz loc v a ii = let* resized_v = resize_from_quad sz v in let mk_action loc' = Act.Access (Dir.W, loc', resized_v, sz, a) in M.write_loc mk_action loc ii let read_loc sz loc a ii = let mk_action loc' v' = Act.Access (Dir.R, loc', v', sz, a) in let* v = M.read_loc false mk_action loc ii in resize_from_quad sz v >>= to_bv sz (**************************************************************************) (* ASL-Backend implementation *) (**************************************************************************) let commit (ii, poi) msg = M.mk_singleton_es (Act.Branching msg) (use_ii_with_poi ii poi) let choice (m1 : V.v M.t) (m2 : 'b M.t) (m3 : 'b M.t) : 'b M.t = M.asl_data m1 @@ function | V.Val (Constant.Concrete (ASLScalar.S_Bool b)) -> if b then m2 else m3 | b -> M.choiceT b m2 m3 let logor v1 v2 = match (v1, v2) with | V.Val (Constant.Concrete (ASLScalar.S_BitVector bv)), v when Asllib.Bitvector.is_zeros bv -> return v | v, V.Val (Constant.Concrete (ASLScalar.S_BitVector bv)) when Asllib.Bitvector.is_zeros bv -> return v | _ -> M.op Op.Or v1 v2 let boolop herdop shortcut v1 v2 = match (v1, v2) with | V.Val (Constant.Concrete (ASLScalar.S_Bool b)), v | v, V.Val (Constant.Concrete (ASLScalar.S_Bool b)) -> return @@ shortcut b v | _ -> M.op herdop v1 v2 let concat v1 v2 = match (v1, v2) with | V.Val (Constant.Concrete (ASLScalar.S_BitVector bv)), v when Asllib.Bitvector.length bv = 0 -> return v | v, V.Val (Constant.Concrete (ASLScalar.S_BitVector bv)) when Asllib.Bitvector.length bv = 0 -> return v | _ -> M.op (Op.ArchOp ASLOp.Concat) v1 v2 let binop = let open AST in let v_true = V.Val (Constant.Concrete (ASLScalar.S_Bool true)) and v_false = V.Val (Constant.Concrete (ASLScalar.S_Bool false)) in function | AND -> M.op Op.And | BAND -> boolop Op.And (fun b v -> if b then v else v_false) | BEQ -> M.op Op.Eq | BOR -> boolop Op.Or (fun b v -> if b then v_true else v) | DIV -> M.op Op.Div | MOD -> M.op Op.Rem | DIVRM -> M.op (Op.ArchOp ASLOp.Divrm) | EOR -> M.op Op.Xor | EQ_OP -> M.op Op.Eq | GT -> M.op Op.Gt | GEQ -> M.op Op.Ge | LT -> M.op Op.Lt | LEQ -> M.op Op.Le | MINUS -> M.op Op.Sub | MUL -> M.op Op.Mul | NEQ -> M.op Op.Ne | OR -> logor | PLUS -> M.op Op.Add | SHL -> M.op Op.ShiftLeft | SHR -> M.op Op.ShiftRight | BV_CONCAT -> concat | (POW | IMPL | RDIV) as op -> Warn.fatal "ASL operation %s not yet implement in ASLSem." (Asllib.PP.binop_to_string op) let unop op = let open AST in match op with | BNOT -> M.op1 (Op.ArchOp1 ASLOp.BoolNot) | NEG -> M.op Op.Sub V.zero | NOT -> M.op1 Op.Inv let ternary = function | V.Val (Constant.Concrete (ASLScalar.S_Bool true)) -> fun m1 _ -> m1 () | V.Val (Constant.Concrete (ASLScalar.S_Bool false)) -> fun _ m2 -> m2 () | V.Val (Constant.Concrete _) as v -> Warn.fatal "ASL Type error: got %s for a ternary." (V.pp_v v) | v -> fun m1 m2 -> let* v1 = m1 () and* v2 = m2 () in M.op3 Op.If v v1 v2 (* * Any access to `PSTATE` (experimental `_NZCV`) * emits an access to NZCV. * Notice that the value is casted into an integer. *) let is_nzcv = if is_experimental then fun x scope -> match (x, scope) with | "_NZCV", Scope.Global false -> true | _ -> false else fun x scope -> match (x, scope) with | "PSTATE", Scope.Global false -> true | _ -> false let is_resaddr x scope = match (x, scope) with "RESADDR", Scope.Global false -> true | _ -> false let loc_of_scoped_id ii x scope = if is_nzcv x scope then A.Location_reg (ii.A.proc, ASLBase.ArchReg AArch64Base.NZCV) else if is_resaddr x scope then A.Location_reg (ii.A.proc, ASLBase.ArchReg AArch64Base.ResAddr) else A.Location_reg (ii.A.proc, ASLBase.ASLLocalId (scope, x)) let on_access_identifier dir (ii, poi) x scope v = let loc = loc_of_scoped_id ii x scope in let m v = let action = Act.Access (dir, loc, v, MachSize.Quad, aneutral) in M.mk_singleton_es action (use_ii_with_poi ii poi) in if is_nzcv x scope then M.op1 (Op.ArchOp1 ASLOp.ToIntU) v >>= m else m v let on_write_identifier = on_access_identifier Dir.W and on_read_identifier = on_access_identifier Dir.R let create_vector li = let li = List.map as_constant li in return (V.Val (Constant.ConcreteVector li)) let create_record li = let record = List.to_seq li |> Seq.map (fun (x, v) -> (x, as_constant v)) |> StringMap.of_seq in return (V.Val (Constant.ConcreteRecord record)) let create_exception = create_record let freeze = function V.Val c -> V.Val c | V.Var i -> V.Val (V.freeze i) let unfreeze = function | V.Val (Constant.Frozen i) -> return (V.Var i) | v -> return v let get_index i v = M.op1 (Op.ArchOp1 (ASLOp.GetIndex i)) v >>= unfreeze let set_index i v vec = M.op (Op.ArchOp (ASLOp.SetIndex i)) vec (freeze v) let get_field name v = M.op1 (Op.ArchOp1 (ASLOp.GetField name)) v >>= unfreeze let set_field name v record = M.op (Op.ArchOp (ASLOp.SetField name)) record (freeze v) let read_from_bitvector positions bvs = let positions = Asllib.ASTUtils.slices_to_positions v_as_int positions in let arch_op1 = ASLOp.BVSlice positions in M.op1 (Op.ArchOp1 arch_op1) bvs let write_to_bitvector positions w v = let positions = Asllib.ASTUtils.slices_to_positions v_as_int positions in M.op (Op.ArchOp (ASLOp.BVSliceSet positions)) v w let concat_bitvectors bvs = let bvs = let filter = function | V.Val (Constant.Concrete (ASLScalar.S_BitVector bv)) -> Asllib.Bitvector.length bv > 0 | _ -> true in List.filter filter bvs in match bvs with | [] -> V.Val (Constant.Concrete ASLScalar.empty) |> return | [ x ] -> return x | h :: t -> let folder acc v = let* acc = acc in M.op (Op.ArchOp ASLOp.Concat) acc v in List.fold_left folder (return h) t let bitvector_length v = M.op1 (Op.ArchOp1 ASLOp.BVLength) v (**************************************************************************) (* Primitives and helpers *) (**************************************************************************) type primitive_t = V.v M.t list -> V.v M.t list -> V.v M.t list M.t let vbool b = V.Val (Constant.Concrete (ASLScalar.S_Bool b)) (* * Add equation, the effect will be silent * discard of execution candidate if a * contradiction appears. *) let checkprop _ m_prop = let* vprop = m_prop in M.assign (vbool true) vprop >>! [] (* * Split the current execution candidate into two: * one candidate, has variable [v] value to be TRUE, * while the value is FALSE for the other. *) let somebool _ _ = let v = V.fresh_var () in let mbool b = (* The underlying choice operator operates * by adding equations ToInt(v) := 1 * and ToInt(v) := 0, which our naive solver * does not resolve as v=TRUE and v=FALSE, * Thereby leaving the equation unsolved. * To correct this, we add * the direct equations on "v": * v := TRUE and v := FALSE in the * positive and negative branches of choice. *) let* () = M.assign v (vbool b) in M.unitT (vbool b) in (* Using "choice" and not returning "v" directly performs the split *) choice (M.unitT v) (mbool true) (mbool false) (* * Primitives that generate fence events. * Notice that ASL fence events take * an AArch64 barrier as argument. *) let cutoffT (ii,poi) msg v = M.cutoffT msg (use_ii_with_poi ii poi) v let primitive_isb (ii, poi) () = create_barrier AArch64Base.ISB (use_ii_with_poi ii poi) let dom_of = let open AArch64Base in function 0 -> NSH | 1 -> ISH | 2 -> OSH | 3 -> SY | _ -> assert false and btyp_of = let open AArch64Base in function 0 -> LD | 1 -> ST | 2 -> FULL | _ -> assert false let primitive_db constr (ii, poi) dom_m btyp_m = let* dom = dom_m and* btyp = btyp_m in let dom = v_as_int dom and btyp = v_as_int btyp in let dom = dom_of dom and btyp = btyp_of btyp in create_barrier (constr (dom, btyp)) (use_ii_with_poi ii poi) let primitive_dmb = primitive_db (fun (d, t) -> AArch64Base.DMB (d, t)) and primitive_dsb = primitive_db (fun (d, t) -> AArch64Base.DSB (d, t)) (* * Prinitives for read and write events. *) let virtual_to_loc_reg = let tgprs = Array.of_list AArch64Base.gprs in fun rv ii -> let i = v_as_int rv in if i >= Array.length tgprs || i < 0 then Warn.fatal "Invalid register number: %d" i else let arch_reg = AArch64Base.Ireg tgprs.(i) in A.Location_reg (ii.A.proc, ASLBase.ArchReg arch_reg) let read_register (ii, poi) r_m = let* rval = r_m in let loc = virtual_to_loc_reg rval ii in read_loc MachSize.Quad loc aneutral (use_ii_with_poi ii poi) let write_register (ii, poi) r_m v_m = let* v = v_m >>= to_int_signed and* r = r_m in let loc = virtual_to_loc_reg r ii in write_loc MachSize.Quad loc v aneutral (use_ii_with_poi ii poi) >>! [] let loc_pc ii = A.Location_reg (ii.A.proc, ASLBase.ArchReg AArch64Base.PC) let read_pc (ii,poi) () = read_loc MachSize.Quad (loc_pc ii) aneutral (use_ii_with_poi ii poi) let write_pc (ii,poi) v_m = let* v = v_m >>= to_int_unsigned in write_loc MachSize.Quad (loc_pc ii) v aneutral (use_ii_with_poi ii poi) >>! [] let do_read_memory (ii, poi) addr_m datasize_m an = let* addr = addr_m and* datasize = datasize_m in let sz = datasize_to_machsize datasize in read_loc sz (A.Location_global addr) an (use_ii_with_poi ii poi) let read_memory ii datasize_m addr_m = do_read_memory ii addr_m datasize_m aneutral let read_memory_gen ii datasize_m addr_m accdesc_m = let* accdesc = accdesc_m in do_read_memory ii addr_m datasize_m (accdesc_to_annot true accdesc) let do_write_memory (ii, poi) addr_m datasize_m value_m an = let value_m = M.as_data_port value_m in let* addr = addr_m and* datasize = datasize_m and* value = value_m in let sz = datasize_to_machsize datasize in write_loc sz (A.Location_global addr) value an (use_ii_with_poi ii poi) >>! [] let write_memory ii datasize_m addr_m value_m = do_write_memory ii addr_m datasize_m value_m AArch64Annot.N let write_memory_gen ii datasize_m addr_m value_m accdesc_m = let* accdesc = accdesc_m in do_write_memory ii addr_m datasize_m value_m (accdesc_to_annot false accdesc) let loc_sp ii = A.Location_reg (ii.A.proc, ASLBase.ArchReg AArch64Base.SP) let read_sp (ii, poi) () = read_loc MachSize.Quad (loc_sp ii) aneutral (use_ii_with_poi ii poi) let write_sp (ii, poi) v_m = let* v = v_m >>= to_int_signed in write_loc MachSize.Quad (loc_sp ii) v aneutral (use_ii_with_poi ii poi) >>! [] let uint _ bv_m = bv_m >>= to_int_unsigned let sint _ bv_m = bv_m >>= to_int_signed let processor_id (ii, _poi) () = return (V.intToV ii.A.proc) let can_predict_from _ v_m w_m = let diff_case = v_m in let eq_case = M.altT v_m w_m in let*| v = v_m and* w = w_m in let*| c = M.op Op.Eq v w in M.choiceT c eq_case diff_case (**************************************************************************) (* ASL environment *) (**************************************************************************) (* Helpers *) let build_primitive ?(args = []) ?returns ?(parameters = []) ~side_effecting name f : AST.func * (_ -> primitive_t) = let open AST in let subprogram_type = match returns with None -> ST_Procedure | _ -> ST_Function and body = SB_Primitive side_effecting and recurse_limit = None and return_type = returns in ( { name; args; body; return_type; parameters; subprogram_type; recurse_limit; builtin = true; } [@warning "-40-42"], f ) (* * Functions that build primitives from underlying OCaml functions. * * The function [pX] is building primitives with arity X * and no return value. * The function [pXr] is building primitives with arity X * and a return value. * All those conveniently ignore the parameters, * which can thus be of any type in any number. * * A few primitive builder pass parameters to the * underlying OCaml function: for instance, * `p1a3` accepts one parameter, three arguments * and returns no value. *) (** Build a primitive with arity 0 and no return value. *) let p0 name ?parameters ?(side_effecting = false) f = let f ii_env _ = function | [] -> f ii_env () | _ :: _ -> Warn.fatal "Arity error for function %s." name in build_primitive ?parameters ~side_effecting name f (** Build a primitive with arity 0 and a return value. *) let p0r name ~returns ?(side_effecting = false) f = let f ii_env _ = function | [] -> return [ f ii_env () ] | _ :: _ -> Warn.fatal "Arity error for function %s." name in build_primitive ?returns:(Some returns) ~side_effecting name f (** Build a primitive with arity 1 and no return value. *) let p1 name arg ?parameters ?(side_effecting = false) f = let f ii_env _ = function | [ v ] -> f ii_env v | [] | _ :: _ -> Warn.fatal "Arity error for function %s." name in build_primitive ~args:[ arg ] ~side_effecting ?parameters name f (** Build a primitive with arity 1 and a return value. *) let p1r name arg ~returns ?(side_effecting = false) ?parameters f = let f ii_env _ = function | [ v ] -> return [ f ii_env v ] | [] | _ :: _ :: _ -> Warn.fatal "Arity error for function %s." name in build_primitive ?returns:(Some returns) ~args:[ arg ] ~side_effecting ?parameters name f (** Build a primitive with arity 2 and no return value. *) let p2 name arg1 arg2 ?parameters ?(side_effecting = false) f = let f ii_env _ = function | [ v1; v2 ] -> f ii_env v1 v2 | _ -> Warn.fatal "Arity error for function %s." name in build_primitive ~args:[ arg1; arg2 ] ~side_effecting ?parameters name f (** Build a primitive with arity 2 and a return value. *) let p2r name arg1 arg2 ~returns ?(side_effecting = false) ?parameters f = let f ii_env _ = function | [ v1; v2 ] -> return [ f ii_env v1 v2 ] | _ -> Warn.fatal "Arity error for function %s." name in build_primitive ?returns:(Some returns) ~args:[ arg1; arg2 ] ~side_effecting ?parameters name f (** Build various primitives with 1 parameter. *) let p1a1r name param1 arg1 ?(side_effecting = false) ~returns f = let f ii_env params args = match (params, args) with | [ v1 ], [ v2 ] -> return [ f ii_env v1 v2 ] | _ -> Warn.fatal "Arity error for function %s." name in build_primitive ?returns:(Some returns) ~args:[ arg1 ] ~parameters:[ param1 ] ~side_effecting name f let p1a2 name param1 arg1 arg2 ?(side_effecting = false) f = let f ii_env params args = match (params, args) with | [ v1 ], [ v2; v3 ] -> f ii_env v1 v2 v3 | _ -> Warn.fatal "Arity error for function %s." name in build_primitive ~args:[ arg1; arg2 ] ~parameters:[ param1 ] ~side_effecting name f let p1a2r name param1 arg1 arg2 ~returns ?(side_effecting = false) f = let f ii_env params args = match (params, args) with | [ v1 ], [ v2; v3 ] -> return [ f ii_env v1 v2 v3 ] | _ -> Warn.fatal "Arity error for function %s." name in build_primitive ?returns:(Some returns) ~side_effecting ~args:[ arg1; arg2 ] ~parameters:[ param1 ] name f let p1a3 name param1 arg1 arg2 arg3 ?(side_effecting = false) f = let f ii_env params args = match (params, args) with | [ v1 ], [ v2; v3; v4 ] -> f ii_env v1 v2 v3 v4 | _ -> Warn.fatal "Arity error for function %s." name in build_primitive ~args:[ arg1; arg2; arg3 ] ~parameters:[ param1 ] ~side_effecting name f (* Primitives *) let extra_funcs = let open AST in let with_pos e = Asllib.ASTUtils.add_dummy_annotation ~version:V0 e in let integer = Asllib.ASTUtils.integer in let int_ctnt e1 e2 = T_Int (WellConstrained [ Constraint_Range (e1, e2) ]) |> with_pos in let boolean = Asllib.ASTUtils.boolean in let reg = integer in let var x = E_Var x |> with_pos in let lit x = E_Literal (L_Int (Z.of_int x)) |> with_pos in let bv x = T_Bits (x, []) |> with_pos in let bv_var x = bv @@ var x in let bv_lit x = bv @@ lit x in let bv_64 = bv_lit 64 in let binop = Asllib.ASTUtils.binop in let minus_one e = binop MINUS e (lit 1) in let pow_2 = binop POW (lit 2) in let t_named x = T_Named x |> with_pos in let side_effecting = true in let uint_returns = int_ctnt (lit 0) (minus_one (pow_2 (var "N"))) and sint_returns = let big_pow = pow_2 (minus_one (var "N")) in int_ctnt (E_Unop (NEG, big_pow) |> with_pos) (minus_one big_pow) in [ (* Fences *) p0 "primitive_isb" ~side_effecting primitive_isb; p2 "primitive_dmb" ~side_effecting ("d", integer) ("t", integer) primitive_dmb; p2 "primitive_dsb" ~side_effecting ("d", integer) ("t", integer) primitive_dsb; (* Registers *) p1r "read_register" ~side_effecting ("reg", reg) ~returns:bv_64 read_register; p2 "write_register" ~side_effecting ("data", bv_64) ("reg", reg) write_register; p0r "read_pc" ~side_effecting ~returns:bv_64 read_pc; p1 "write_pc" ~side_effecting ("data", bv_64) write_pc; p0r "SP_EL0" ~side_effecting ~returns:bv_64 read_sp; p1 "SP_EL0" ~side_effecting ("data", bv_64) write_sp; (* Memory *) p1a1r "read_memory" ("N", None) ("addr", bv_64) ~returns:(bv_var "N") ~side_effecting read_memory; p1a2r "read_memory_gen" ("N", None) ("addr", bv_64) ("accdesc", t_named "AccessDescriptor") ~returns:(bv_var "N") read_memory_gen; p1a2 "write_memory" ~side_effecting ("size", None) ("addr", bv_64) ("data", bv_var "size") write_memory; p1a3 "write_memory_gen" ~side_effecting ("size", None) ("addr", bv_64) ("data", bv_var "size") ("accdesc", t_named "AccessDescriptor") write_memory_gen; (* Translations *) p1r "UInt" ~parameters:[ ("N", None) ] ("x", bv_var "N") ~returns:uint_returns uint; p1r "SInt" ~parameters:[ ("N", None) ] ("x", bv_var "N") ~returns:sint_returns sint; (* Misc *) p0r ~side_effecting "ProcessorID" ~returns:integer processor_id; p2r ~side_effecting "CanPredictFrom" ~parameters:[ ("N", None) ] ("predicted", bv_var "N") ("from", bv_var "N") ~returns:(bv_var "N") can_predict_from; p0r ~side_effecting "SomeBoolean" ~returns:boolean somebool; p1 ~side_effecting "CheckProp" ("prop", boolean) checkprop; ] let make_extra_funcs ii_env = List.map (fun (func, make_primitive) -> (func, make_primitive ii_env)) extra_funcs let build_shared_pseudocode () = let open AST in let open ASTUtils in let is_primitive = let set = List.fold_left (fun [@warning "-42"] acc ({ name; body = _; _ }, _) -> ISet.add name acc) ISet.empty extra_funcs in fun name -> ISet.mem name set in let build ?ast_type version fname = Filename.concat "asl-pseudocode" fname |> C.libfind |> ASLBase.build_ast_from_file ?ast_type version in let patches = let patches = build `ASLv1 "patches.asl" in if is_experimental then (* Replace default "PSTATE" definition by experimental ones. *) let pstate = build `ASLv1 "pstate-exp.asl" in List.fold_right (fun d k -> match identifier_of_decl d with | "PSTATE" -> pstate @ k | _ -> d :: k) patches [] else patches and custom_implems = List.append (build `ASLv1 "implementations.asl") (build `ASLv0 "implementations0.asl") and shared = build `ASLv0 "shared_pseudocode.asl" in let shared = (* * Remove from shared pseudocode the functions declared in stdlib because: * 1. it avoids name clashes at type-checking time; * 2. when debugging, we know what function is called; * 3. stdlib functions usually out-perform their shared-pseudocode * counterparts when executed in herd. *) let filter d = let open AST in match[@warning "-42"] d.desc with | D_Func { name; body = _; _ } -> let should_remove = Asllib.Builder.is_stdlib_name name || is_primitive name in let () = if false && should_remove then Printf.eprintf "Subprogram %s removed from shared\n%!" name in not should_remove | _ -> true in List.filter filter shared in let ( @! ) = List.rev_append in let ast = patch ~patches:(custom_implems @! patches) ~src:shared in ast |> Asllib.Builder.with_stdlib |> Asllib.Builder.with_primitives extra_funcs |> TypeCheck.type_check_ast let typed_shared_pseudocode : unit -> AST.t * Asllib.StaticEnv.global = let if_asl_aarch64 = Lazy.from_fun build_shared_pseudocode and otherwise = lazy (Lazy.force Asllib.Builder.stdlib |> Asllib.Builder.with_primitives extra_funcs |> TypeCheck.type_check_ast) in fun () -> Lazy.force @@ if C.variant Variant.ASL_AArch64 then if_asl_aarch64 else otherwise (**************************************************************************) (* Execution *) (**************************************************************************) let build_semantics t ii = let ii_env = (ii, ref ii.A.program_order_index) in let module ASLBackend = struct module Scope = Scope type value = V.v type value_range = value * value type 'a m = 'a M.t type primitive = primitive_t let debug_value = V.pp_v let is_undetermined = function V.Var _ -> true | V.Val _ -> false let v_of_int = V.intToV let v_of_literal = v_of_literal let v_to_z = v_to_z let v_to_label = v_to_label let bind_data = M.asl_data let bind_seq = M.asl_seq let bind_ctrl = M.asl_ctrl let prod_par = M.( >>| ) let appl_data m f = m >>= fun v -> return (f v) let debugT = M.debugT let commit = commit ii_env let choice = choice let delay m k = M.delay_kont "ASL" m k let return = M.unitT let cutoffT msg v = cutoffT ii_env msg v let on_write_identifier = on_write_identifier ii_env let on_read_identifier = on_read_identifier ii_env let binop = binop let unop = unop let ternary = ternary let create_vector = create_vector let create_record = create_record let create_exception = create_exception let get_index = get_index let set_index = set_index let get_field = get_field let set_field = set_field let read_from_bitvector = read_from_bitvector let write_to_bitvector = write_to_bitvector let concat_bitvectors = concat_bitvectors let bitvector_length = bitvector_length let v_unknown_of_type = v_unknown_of_type let primitives = make_extra_funcs ii_env end in let module ASLInterpreter = Asllib.Interpreter.Make (ASLBackend) (ASLInterpreterConfig) in let ast, tenv = let shared_ast, shared_tenv = typed_shared_pseudocode () in let main, tenv = TypeCheck.type_check_ast_in_env shared_tenv ii.A.inst in (List.rev_append main shared_ast, tenv) in let () = if false then Format.eprintf "Completed AST: %a.@." Asllib.PP.pp_t ast in let env = A.state_fold (fun loc v env -> match loc with | A.Location_reg (_, ASLLocalId (Scope.Global _, name)) -> (name, v) :: env | _ -> env) t.Test_herd.init_state [] in let exec () = ASLInterpreter.run_typed_env env tenv ast in let* i = match Asllib.Error.intercept exec () with | Ok m -> m | Error err -> Asllib.Error.error_to_string err |> Warn.fatal "%s" in assert (V.equal i V.zero); M.addT !(snd ii_env) B.nextT let spurious_setaf _ = assert false end end herd-herdtools7-1ca343e/herd/AllBarrier.ml000066400000000000000000000032751475314470400204440ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Union of relevant PPC, ARM, X86, and PTX barriers *) type b = | SYNC | LWSYNC | ISYNC | EIEIO (* PPC memory model barrier *) | DSB | DMB | ISB (* ARM barrier *) | DSBST | DMBST | MFENCE | SFENCE | LFENCE (* X86 *) module type S = sig type a (* Native arch barrier *) val a_to_b : a -> b val pp_isync : string end module No(B:sig type a end) = struct type a = B.a (* assert false below can be raised if CAV12 model is applied *) let a_to_b _ = assert false let pp_isync = "???" end herd-herdtools7-1ca343e/herd/AllBarrier.mli000066400000000000000000000031261475314470400206100ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Union of relevant PPC, ARM, x86 barriers. Used by CAV12 model *) type b = | SYNC | LWSYNC | ISYNC | EIEIO (* PPC memory model barrier *) | DSB | DMB | ISB (* ARM barrier *) | DSBST | DMBST | MFENCE | SFENCE | LFENCE (* X86 *) module type S = sig type a (* Native arch barrier *) val a_to_b : a -> b val pp_isync : string end module No : functor(B:sig type a end) -> S with type a = B.a herd-herdtools7-1ca343e/herd/BPFArch_herd.ml000066400000000000000000000054631475314470400206350ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Copyright (c) 2024 Puranjay Mohan *) (* *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Define BPF architecture *) module Make (C : Arch_herd.Config) (V : Value.S with type Cst.Instr.t = BPFBase.instruction) = struct include BPFBase let is_amo = function | AMO _ -> true | _ -> false ;; let pp_barrier_short = pp_barrier let reject_mixed = false let get_machsize _ = V.Cst.Scalar.machsize let empty_annot = N let is_sc = function | SC -> true | _ -> false ;; let is_atomic = function | X | SC -> true | _ -> false ;; let is_acquire = function | A -> true | _ -> false ;; let is_release = function | R -> true | _ -> false ;; let ifetch_value_sets = [] let barrier_sets = [] let cmo_sets = [] let annot_sets = [ "X", is_atomic; "SC", is_sc; "AQ", is_acquire; "RL", is_release; ] include Explicit.No include PteValSets.No let is_isync _ = false let pp_isync = "???" let pp_annot = function | X -> "*" | SC -> "SC" | N -> "" | A -> "AQ" | R -> "RL" ;; module V = V let mem_access_size = function | AMO (_, w, _, _, _, _, _) | LOAD (w, _, _, _, _) | STORE (w, _, _, _) -> Some (tr_width w) | _ -> None ;; include NoSemEnv include NoLevelNorTLBI include ArchExtra_herd.Make (C) (struct module V = V let endian = endian type arch_reg = reg let pp_reg = pp_reg let reg_compare = reg_compare let fromto_of_instr _ = None let get_val _ v = v module FaultType = FaultType.No end) module MemType = MemoryType.No module NoConf = struct type v = V.v type loc = location type value_set = V.ValueSet.t type solution = V.solution type arch_lannot = lannot type arch_explicit = explicit end module ArchAction = ArchAction.No (NoConf) module Barrier = AllBarrier.No (struct type a = barrier end) module CMO = Cmo.No end herd-herdtools7-1ca343e/herd/BPFParseTest.ml000066400000000000000000000033151475314470400206620ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Copyright (c) 2024 Puranjay Mohan *) (* *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make (Conf : RunTest.Config) (ModelConfig : MemWithCav12.Config) = struct module LexConfig = struct let debug = Conf.debug.Debug_herd.lexer end module ArchConfig = SemExtra.ConfigToArchConfig (Conf) module BPFValue = Int64Value.Make (BPFBase.Instr) module BPF = BPFArch_herd.Make (ArchConfig) (BPFValue) module BPFLexParse = struct type instruction = BPF.pseudo type token = BPFParser.token module Lexer = BPFLexer.Make (LexConfig) let lexer = Lexer.token let parser = MiscParser.mach2generic BPFParser.main end module BPFS = BPFSem.Make (Conf) (BPFValue) module BPFM = MemWithCav12.Make (ModelConfig) (BPFS) module P = GenParser.Make (Conf) (BPF) (BPFLexParse) module X = RunTest.Make (BPFS) (P) (BPFM) (Conf) let run = X.run end herd-herdtools7-1ca343e/herd/BPFParseTest.mli000066400000000000000000000020551475314470400210330ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Copyright (c) 2024 Puranjay Mohan *) (* *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make : functor (Conf : RunTest.Config) (ModelConfig : MemWithCav12.Config) -> sig val run : RunTest.runfun end herd-herdtools7-1ca343e/herd/BPFSem.ml000066400000000000000000000200541475314470400174730ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Copyright (c) 2024 Puranjay Mohan *) (* *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Semantics of BPF instructions *) module Make (C : Sem.Config) (V : Value.S with type Cst.Instr.t = BPFBase.instruction) = struct module BPF = BPFArch_herd.Make (SemExtra.ConfigToArchConfig (C)) (V) module Act = MachAction.Make (C.PC) (BPF) include SemExtra.Make (C) (BPF) (Act) (* Barrier pretty print *) let sync = None let barriers = [] let isync = None (* TODO: let nat_sz = MachSize.Quad (* 64-bit Registers *) *) let nat_sz = V.Cst.Scalar.machsize let atomic_pair_allowed _ _ = true (********************) (* Semantics proper *) (********************) module Mixed (SZ : ByteSize.S) = struct let ( >>= ) = M.( >>= ) let ( >>*= ) = M.( >>*= ) let ( >>| ) = M.( >>| ) let ( >>! ) = M.( >>! ) let ( >>:: ) = M.( >>:: ) let unimplemented op = Warn.user_error "BPF operation %s is not implemented (yet)" op let tr_opamo op = match op with | BPF.AMOXCHG -> assert false | BPF.ADD -> Op.Add | BPF.AND -> Op.And | BPF.OR -> Op.Or | BPF.XOR -> Op.Xor | BPF.AMOCMPXCHG -> assert false | _ -> unimplemented "atomic op" ;; let tr_op = function | BPF.ADD -> Op.Add | BPF.SUB -> Op.Sub | BPF.AND -> Op.And | BPF.OR -> Op.Or | BPF.XOR -> Op.Xor | BPF.MUL -> Op.Mul | BPF.DIV -> Op.Div | BPF.REM -> Op.Rem | BPF.LSL -> Op.ShiftLeft | BPF.LSR -> Op.Lsr | BPF.ASR -> unimplemented (BPF.pp_op BPF.ASR) | BPF.AMOCMPXCHG -> unimplemented "non-atomic CMPXCHG" | BPF.AMOXCHG -> unimplemented "non-atomic XCHG" ;; let tr_cond cond = match cond with | BPF.EQ -> Op.Eq | BPF.NE -> Op.Ne | BPF.LT -> Op.Lt | BPF.GE -> Op.Ge ;; let mk_read sz ato loc v = Act.Access (Dir.R, loc, v, ato, (), sz, Act.access_of_location_std loc) ;; let read_reg is_data r ii = M.read_loc is_data (mk_read nat_sz BPF.N) (A.Location_reg (ii.A.proc, r)) ii ;; let read_reg_ord = read_reg false let read_reg_data = read_reg true let do_read_mem sz ato a ii = M.read_loc false (mk_read sz ato) (A.Location_global a) ii ;; let read_mem sz a ii = do_read_mem sz BPF.N a ii let read_mem_sc sz a ii = do_read_mem sz BPF.SC a ii let read_mem_acq sz a ii = do_read_mem sz BPF.A a ii let write_reg r v ii = M.mk_singleton_es (Act.Access (Dir.W, A.Location_reg (ii.A.proc, r), v, BPF.N, (), nat_sz, Access.REG)) ii ;; let write_mem_rel sz a v ii = M.mk_singleton_es (Act.Access (Dir.W, A.Location_global a, v, BPF.R, (), sz, Access.VIR)) ii ;; let write_mem_sc sz a v ii = M.mk_singleton_es (Act.Access (Dir.W, A.Location_global a, v, BPF.SC, (), sz, Access.VIR)) ii ;; let write_mem sz a v ii = M.mk_singleton_es (Act.Access (Dir.W, A.Location_global a, v, BPF.N, (), sz, Access.VIR)) ii ;; let commit ii = M.mk_singleton_es (Act.Commit (Act.Bcc, None)) ii (* Signed *) let imm16ToV k = V.Cst.Scalar.of_int (k land 0xffff) |> V.Cst.Scalar.sxt MachSize.Short |> fun sc -> V.Val (Constant.Concrete sc) ;; let amo sz op an rd rs k f ii = let open BPF in let ra = read_reg_ord rd ii and rv = read_reg_data rs ii and r0 = read_reg_data (IReg R0) ii and rmem_sc vloc = read_mem_sc sz vloc ii and rmem vloc = read_mem sz vloc ii and wmem_sc vloc v = write_mem_sc sz vloc v ii >>! () and ca v = M.add v (imm16ToV k) in let ra_c = ra >>= fun a -> ca a in match op with | AMOXCHG -> ra >>| rv >>= (fun (ea, vstore) -> ca ea >>= fun loc -> M.read_loc false (fun loc v -> Act.Amo (loc, v, vstore, an, (), sz, Access.VIR)) (A.Location_global loc) ii) >>= fun r -> write_reg rs r ii | AMOCMPXCHG -> M.altT (M.linux_cmpexch_ok ra_c r0 rv rmem_sc wmem_sc M.assign) (M.linux_cmpexch_no ra_c r0 rmem M.neqT) >>= fun r -> write_reg (IReg R0) r ii | _ -> ra >>| rv >>= (fun (ea, v) -> ca ea >>= fun loc -> M.fetch (tr_opamo op) v (fun v vstored -> Act.Amo (A.Location_global loc, v, vstored, an, (), sz, Access.VIR)) ii) >>= fun v -> (match f with | true -> write_reg rs v ii | false -> M.unitT ()) ;; (* Entry point *) let tr_sz = BPF.tr_width let build_semantics _ ii = M.addT (A.next_po_index ii.A.program_order_index) (match ii.A.inst with | BPF.OP (op, r1, r2) -> read_reg_data r1 ii >>| read_reg_data r2 ii >>= (fun (v1, v2) -> M.op (tr_op op) v1 v2) >>= (fun v -> write_reg r1 v ii) >>= B.next1T | BPF.OPI (op, r1, k) -> read_reg_data r1 ii >>= fun v -> M.op (tr_op op) v (V.intToV k) >>= fun v -> write_reg r1 v ii >>= B.next1T | BPF.LOAD (w, _s, r1, r2, k) -> let sz = tr_sz w in read_reg_ord r2 ii >>= (fun a -> M.add a (imm16ToV k)) >>= (fun ea -> read_mem sz ea ii) >>= (fun v -> write_reg r1 v ii) >>= B.next1T | BPF.LDAQ (w, r1, r2, k) -> let sz = tr_sz w in read_reg_ord r2 ii >>= (fun a -> M.add a (imm16ToV k)) >>= (fun ea -> read_mem_acq sz ea ii) >>= (fun v -> write_reg r1 v ii) >>= B.next1T | BPF.STORE (sz, r1, k, r2) -> read_reg_ord r1 ii >>| read_reg_data r2 ii >>= (fun (a, d) -> M.add a (imm16ToV k) >>= fun ea -> write_mem (tr_sz sz) ea d ii) >>= B.next1T | BPF.STRL (sz, r1, k, r2) -> read_reg_ord r1 ii >>| read_reg_data r2 ii >>= (fun (a, d) -> M.add a (imm16ToV k) >>= fun ea -> write_mem_rel (tr_sz sz) ea d ii) >>= B.next1T | BPF.STOREI (sz, r1, k1, k2) -> read_reg_ord r1 ii >>= (fun a -> M.add a (imm16ToV k1) >>= fun ea -> write_mem (tr_sz sz) ea (V.intToV k2) ii) >>= B.next1T | BPF.MOV (rd, rs) -> read_reg_data rs ii >>= fun v -> write_reg rd v ii >>= B.next1T | BPF.MOVI (rd, k) -> write_reg rd (V.intToV k) ii >>= B.next1T | BPF.AMO (aop, w, rd, k, rs, annot, f) -> amo (tr_sz w) aop annot rd rs k f ii >>= B.next1T | BPF.GOTO lbl -> B.branchT lbl | BPF.JCOND (c, r1, r2, lbl) -> read_reg_ord r1 ii >>| read_reg_ord r2 ii >>= fun (v1, v2) -> M.op (tr_cond c) v1 v2 >>= fun v -> commit ii >>= fun () -> B.bccT v lbl | BPF.JCONDI (c, r1, k, lbl) -> read_reg_data r1 ii >>= fun v -> M.op (tr_cond c) v (V.intToV k) >>= fun v -> commit ii >>= fun () -> B.bccT v lbl) ;; let spurious_setaf _ = assert false end end herd-herdtools7-1ca343e/herd/BellAction.ml000066400000000000000000000153601475314470400204370ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Implementation of the action interface for Bell *) module Make (A : Arch_herd.S) : sig type action = | Access of Dir.dirn * A.location * A.V.v * bool * string list * MachSize.sz | Barrier of string list * (Label.Set.t * Label.Set.t) option | Commit | CutOff of string include Action.S with module A = A and type action := action end = struct module A = A module V = A.V open Dir type action = | Access of dirn * A.location * V.v * bool (* atomicity flag *) * string list * MachSize.sz | Barrier of string list * (Label.Set.t * Label.Set.t) option | Commit | CutOff of string (* I think this is right... *) let mk_init_write l sz v = Access(W,l,v,false,[],sz) (* Quite ad-hoc, should devise a more general mechanism *) let tr_annot = function | "rcu_read_unlock" -> "rcu-unlock" | "rcu_read_lock" -> "rcu-lock" | "sync" -> "sync-rcu" | s -> s let pp_annots = function | [] -> "" | xs -> let xs = List.map tr_annot xs in "[" ^ BellBase.string_of_annot_list xs ^ "]" let pp_action a = match a with | Access (d,l,v,ato,s,_sz) -> Printf.sprintf "%s%s%s%s=%s" (pp_dirn d) (pp_annots s) (A.pp_location l) (if ato then "*" else "") (V.pp_v v) | Barrier (s,o) -> (match o with | None -> Printf.sprintf "F%s" (pp_annots s) | Some(s1, s2) -> Printf.sprintf "F%s{%s}{%s}" (pp_annots s) (BellBase.string_of_labels s1) (BellBase.string_of_labels s2) ) | Commit -> "Commit" | CutOff msg -> "CutOff:" ^ msg (* Utility functions to pick out components *) let value_of a = match a with | Access (_,_ ,v,_,_,_) -> Some v | _ -> None let read_of = value_of and written_of = value_of let location_of a = match a with | Access (_,loc, _,_,_,_) -> Some loc | _ -> None (* relative to memory *) let is_mem_store a = match a with | Access (W,A.Location_global _,_,_,_,_) -> true | _ -> false let is_mem_load a = match a with | Access (R,A.Location_global _,_,_,_,_z) -> true | _ -> false let is_additional_mem_load _ = false let is_mem a = match a with | Access (_,A.Location_global _,_,_,_,_) -> true | _ -> false (* None of those below *) let is_ifetch _ = false let is_tag _ = false let is_additional_mem _ = false (* Unimplemented *) let is_pte_access _ = assert false (* All accesses are explicit *) include Explicit.NoAction let is_atomic a = match a with | Access (_,_,_,true,_,_) -> assert (is_mem a); true | _ -> false let is_fault _ = false let to_fault _ = None let get_mem_dir a = match a with | Access (d,A.Location_global _,_,_,_,_) -> d | _ -> assert false (* No mixed-size *) let get_mem_size a = match a with | Access (_,A.Location_global _,_,_,_,sz) -> sz | _ -> assert false (* relative to the registers of the given proc *) let is_reg_store a (p:int) = match a with | Access (W,A.Location_reg (q,_),_,_,_,_) -> p = q | _ -> false let is_reg_load a (p:int) = match a with | Access (R,A.Location_reg (q,_),_,_,_,_) -> p = q | _ -> false let is_reg a (p:int) = match a with | Access (_,A.Location_reg (q,_),_,_,_,_) -> p = q | _ -> false (* Store/Load anywhere *) let is_store a = match a with | Access (W,_,_,_,_,_) -> true | _ -> false let is_load a = match a with | Access (R,_,_,_,_,_) -> true | _ -> false let is_reg_any a = match a with | Access (_,A.Location_reg _,_,_,_,_) -> true | _ -> false let is_reg_store_any a = match a with | Access (W,A.Location_reg _,_,_,_,_) -> true | _ -> false let is_reg_load_any a = match a with | Access (R,A.Location_reg _,_,_,_,_) -> true | _ -> false let compatible_accesses a1 a2 = (is_mem a1 && is_mem a2) || (is_reg_any a1 && is_reg_any a2) (* Barriers *) let is_barrier a = match a with | Barrier _ -> true | _ -> false let is_total_barrier a = match a with | Barrier (_,None) -> true | _ -> false let barrier_of _a = None let same_barrier_id _ _ = false (* Commits, bcc only *) let is_bcc a = match a with | Commit -> true | _ -> false let is_pred ?cond:_ _ = false let is_commit = is_bcc (* Unroll control *) let cutoff msg = CutOff msg let is_cutoff = function | CutOff _ -> true | _ -> false let as_cutoff = function | CutOff msg -> Some msg | _ -> None (* Equations *) let undetermined_vars_in_action a = match a with | Access (_,l,v,_,_,_) -> V.ValueSet.union (A.undetermined_vars_in_loc l) (V.undetermined_vars v) | Barrier _|Commit|CutOff _ -> V.ValueSet.empty let simplify_vars_in_action soln a = match a with | Access (d,l,v,ato,s,sz) -> let l' = A.simplify_vars_in_loc soln l in let v' = V.simplify_var soln v in Access (d,l',v',ato,s,sz) | Barrier _ | Commit| CutOff _ -> a (*************************************************************) (* Add together event structures from different instructions *) (*************************************************************) (* Update the arch_sets based on the bell file *) let list_contains s st = List.mem st s let annot_in_list st ac = match ac with | Access(_,_,_,_,s,_) | Barrier(s,_) -> (list_contains s st) (*jade: il manque les branches ici; et peut etre les rmw sauf s'ils sont dans Access?*) | _ -> false let pp_isync = "" let is_isync _a = false let arch_sets = [ "X",is_atomic; "RMW",is_atomic; "Ftotal",is_total_barrier; ] let arch_rels = [] let arch_dirty = [] end herd-herdtools7-1ca343e/herd/BellArch_herd.ml000066400000000000000000000041251475314470400210760ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Define Bell architecture *) module Make (C:Arch_herd.Config) (V:Value.S with type Cst.Instr.t = BellBase.instruction) = struct include BellBase let is_amo = function | Prmw _ -> true | Pnop|Pld _|Pst _|Pfence _|Pcall _|Pbranch _|Pmov _ -> false let pp_barrier_short = pp_barrier let reject_mixed = false let mem_access_size _ = None include NoSemEnv module V = V include NoLevelNorTLBI include ArchExtra_herd.Make(C) (struct module V = V let endian = endian type arch_reg = reg let pp_reg = pp_reg let reg_compare = reg_compare let fromto_of_instr ins = match ins with | Pfence(Fence(_,ft)) -> ft | _ -> None let get_val _ v = v module FaultType=FaultType.No end) module MemType=MemoryType.No module Barrier = AllBarrier.No(struct type a = barrier end) module CMO = Cmo.No end herd-herdtools7-1ca343e/herd/BellMem.ml000066400000000000000000000040621475314470400177350ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Entry to models for Bell *) module type Config = sig val model : Model.t val bell_model_info : (string * BellModel.info) option include Model.Config end module Make (O:Config) (S:Sem.Semantics) : XXXMem.S with module S = S = struct open Model let model = O.model (* let bell_model = match O.bell_model with | Some m -> m | None -> Warn.fatal "Running a bell test requires a .bell file" *) module S = S let check_event_structure test = match O.model with | Generic (fname,m) -> let module X = MachModelChecker.Make (struct let fname = fname let m = m let wide_po = false include O end)(S) in X.check_event_structure test | File _ -> assert false | m -> Warn.fatal "Model %s not implemented for Bell" (Model.pp m) end herd-herdtools7-1ca343e/herd/BellSem.ml000066400000000000000000000157251475314470400177530ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Semantics of Bell *) module Make (C:Sem.Config) (V:Value.S with type Cst.Instr.t = BellBase.instruction) = struct module Bell = BellArch_herd.Make(SemExtra.ConfigToArchConfig(C))(V) module Act = BellAction.Make(Bell) include SemExtra.Make(C)(Bell)(Act) let compat = C.variant Variant.BackCompat (* Not doing barrier pretty print *) let barriers = [] let isync = None (* Simple size *) let reg_sz = V.Cst.Scalar.machsize and nat_sz = V.Cst.Scalar.machsize let atomic_pair_allowed _ _ = true (****************************) (* Build semantics function *) (****************************) module Mixed(SZ : ByteSize.S) = struct let (>>=) = M.(>>=) let (>>*=) = M.(>>*=) let (>>|) = M.(>>|) let (>>::) = M.(>>::) let (>>!) = M.(>>!) let mk_read sz ato s loc v = Act.Access (Dir.R, loc, v, ato, s, sz) let read_reg is_data ?(stack=[]) r ii = try let v = List.assoc r stack in (M.unitT v) with Not_found -> M.read_loc is_data (mk_read reg_sz false []) (A.Location_reg (ii.A.proc,r)) ii let read_reg_ord = read_reg false and read_reg_data = read_reg true let read_mem sz a s ii = M.read_loc false (mk_read sz false s) (A.Location_global a) ii let read_mem_atom sz a s ii = M.read_loc false (mk_read sz true s) (A.Location_global a) ii (* let read_mem_atom cop a ii = M.read_loc (mk_read true cop) (A.Location_global a) ii *) let write_reg r v ii = M.mk_singleton_es (Act.Access (Dir.W, (A.Location_reg (ii.A.proc,r)), v, false, [], reg_sz)) ii let write_mem sz a v s ii = M.mk_singleton_es (Act.Access (Dir.W, A.Location_global a, v, false, s, sz)) ii let write_mem_atom sz a v s ii = M.mk_singleton_es (Act.Access (Dir.W, A.Location_global a, v, true, s, sz)) ii let commit ii = M.mk_singleton_es (Act.Commit) ii let create_barrier b o ii = M.mk_singleton_es (Act.Barrier(b,o)) ii let read_roa is_data ?(stack=[]) roa ii = match roa with | BellBase.Rega r -> read_reg is_data ~stack:stack r ii | BellBase.Abs a -> (M.unitT (V.nameToV a)) let read_roi is_data roi ii = match roi with | BellBase.Regi r -> read_reg is_data r ii | BellBase.Imm i -> (M.unitT (V.intToV i)) let read_iar is_data ?(stack=[]) roi ii = match roi with | BellBase.IAR_roa roa -> read_roa is_data ~stack:stack roa ii | BellBase.IAR_imm i -> (M.unitT (V.intToV i)) let solve_addr_op ao ii = match ao with | BellBase.Addr_op_atom roa -> read_roa false roa ii | BellBase.Addr_op_add(roa,roi) -> (read_roa false roa ii >>| read_roi false roi ii) >>= (fun (v1,v2) -> M.op Op.Add v1 v2) let tr_op ?(stack=[]) ii = function | BellBase.OP(bell_op,x,y) -> let op = match bell_op with | BellBase.Xor -> Op.Xor | BellBase.Add -> Op.Add | BellBase.And -> Op.And | BellBase.Eq -> Op.Eq | BellBase.Neq -> Op.Ne in ((read_iar false ~stack:stack x ii) >>| (read_iar false ~stack:stack y ii)) >>= (fun (v1,v2) -> M.op op v1 v2) | BellBase.RAI(i) -> (read_iar false ~stack:stack i ii) let tr_mov r op ii = (tr_op ii op) >>= (fun v -> write_reg r v ii) let build_semantics _ ii = let build_semantics_inner ii = match ii.A.inst with | BellBase.Pnop -> B.nextT | BellBase.Pld(r,addr_op,[("deref"|"lderef")]) when compat -> solve_addr_op addr_op ii >>= fun addr -> read_mem nat_sz addr ["once"] ii >>= fun v -> write_reg r v ii >>*= fun () -> create_barrier ["rb_dep"] None ii >>= B.next1T | BellBase.Pld(r,addr_op,s) -> solve_addr_op addr_op ii >>= (fun addr -> read_mem nat_sz addr s ii) >>= (fun v -> write_reg r v ii) >>= B.next1T | BellBase.Pst(addr_op, roi, s) -> let s = match s with | ["assign"] when compat -> ["release"] | _ -> s in (solve_addr_op addr_op ii >>| read_roi true roi ii) >>= fun (addr,v) -> write_mem nat_sz addr v s ii >>= B.next1T | BellBase.Pfence(BellBase.Fence (s,o)) -> create_barrier s o ii >>= B.next1T | BellBase.Pcall _ -> Warn.fatal "Obsolete 'call' instruction in BellSem\n" | BellBase.Prmw(r,op,addr_op,s) -> let rloc = solve_addr_op addr_op ii in if BellBase.r_in_op r op then rloc >>= (fun x -> (read_mem_atom nat_sz x s ii) >>= (fun v_read -> (tr_op ~stack:[(r,v_read)] ii op) >>= (fun v -> write_reg r v_read ii >>| write_mem_atom nat_sz x v s ii))) >>= fun ((),()) -> B.nextT else begin rloc >>= (fun x -> let r1 = read_mem_atom nat_sz x s ii and r2 = tr_op ii op and w1 = fun v -> write_mem_atom nat_sz x v s ii and w2 = fun v -> write_reg r v ii in M.exch r1 r2 w1 w2) >>= fun ((),()) -> B.nextT end | BellBase.Pbranch(Some r,lbl,_) -> (read_reg false r ii) >>= (fun v -> commit ii >>= fun () -> B.bccT v lbl) | BellBase.Pbranch(None ,lbl,_) -> B.branchT lbl | BellBase.Pmov(r,op) -> (tr_mov r op ii) >>= B.next1T in M.addT (A.next_po_index ii.A.program_order_index) (build_semantics_inner ii) let spurious_setaf _ = assert false end end herd-herdtools7-1ca343e/herd/CAV12.ml000066400000000000000000000400161475314470400171730ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2011-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Sela Haim's axiomatic model for PPC, second version *) open Printf open AllBarrier module type Config = sig val opt : Model.cav12_opt include Model.Config end module Make (O:Config) (S:Sem.Semantics) = struct (************************) (* Static configuration *) (************************) (* Compute fixpoint completely, even for cyclic rels *) let doall = true (* Opens and module definitions *) open Model module S = S module A = S.A module B = A.Barrier module E = S.E module U = MemUtils.Make(S) module MU = ModelUtils.Make(O)(S) let is_fence x = match E.barrier_of x with | Some a -> begin match B.a_to_b a with | SYNC|LWSYNC|EIEIO | DMB|DSB|DMBST|DSBST | MFENCE|LFENCE|SFENCE -> true | _ -> false end | None -> false module SE = SelaEvent.Make(S) (struct type event = S.event let visible_fence = is_fence end) (* Pretty print *) let show_failure test conc msg vb_pp = if O.debug then let module PP = Pretty.Make(S) in let legend = sprintf "%s: %s" test.Test_herd.name.Name.name msg in eprintf "%s\n%!" legend ; PP.show_legend test legend conc (Lazy.force vb_pp) (* Utilities *) let proc_eq = Misc.int_eq let one_store (e1,e2) = E.is_mem_store e1 || E.is_mem_store e2 and same_proc (e1,e2) = E.same_proc e1 e2 and diff_proc (e1,e2) = not (E.same_proc e1 e2) and get_proc e = match E.proc_of e with | Some p -> p | None -> -1 let is_fence_exe e = match e.SE.nature with | SE.Exe -> begin match E.barrier_of e.SE.event with | Some _ -> true | None -> false end | _ -> false let is_self_propagate e = match e.SE.nature with | SE.Prop j -> proc_eq j (get_proc e.SE.event) | _ -> false (* Meaningless events *) let is_bad e = is_fence_exe e || is_self_propagate e let is_that_fence b x = match E.barrier_of x with | Some a -> B.a_to_b a = b | None -> false let is_eieio x = is_that_fence EIEIO x let is_strong x = is_that_fence SYNC x || is_that_fence DMB x || is_that_fence DSB x || is_that_fence MFENCE x || (O.opt.strongst && (is_that_fence DSBST x || is_that_fence DMBST x)) (* let is_light x = is_that_fence LWSYNC x || is_that_fence EIEIO x || (not O.opt.strongst && (is_that_fence DSBST x || is_that_fence DMBST x)) *) let is_isync x = is_that_fence ISYNC x || is_that_fence ISB x (* Parameters of Sela's "generic" model *) let fbefore (x,y) = (E.is_mem_store x && is_fence y) || (is_fence x && E.is_mem_store y) let fafter (x,y) = E.event_compare x y <> 0 && is_strong x && is_strong y (****************************************************) (* Main relation builders of Sela's "generic" model *) (****************************************************) (* evord computation, it's recursive *) let fixpoint pp eq f = let rec fix k v0 = if O.debug && O.verbose > 2 then pp k v0 ; let v1 = f v0 in if eq v0 v1 then v0 else fix (k+1) v1 in fix 0 let eq_st (r0,(a0,b0)) (r1,(a1,b1)) = SE.SplittedRel.subset r1 r0 && (* checking after/before is optional, gives beter images *) begin if not doall then E.EventRel.subset a1 a0 && E.EventRel.subset b1 b0 else true end let before_sources m evord = SE.SplittedRel.fold (fun (x1e,y1e) k -> let x = x1e.SE.event and y = y1e.SE.event in let py = get_proc y in if m.SE.fbefore (x,y) && SE.relevant_to_proc x1e py && SE.relevant_to_proc y1e py then (x,y)::k else k) evord [] let before_of m evord = E.EventRel.of_list (before_sources m evord) let after_sources m evord = SE.SplittedRel.fold (fun (x1e,y1e) k -> let x = x1e.SE.event and y = y1e.SE.event in let px = get_proc x in if m.SE.fafter (x,y) && SE.relevant_to_proc x1e px then (x,y)::k else k) evord [] let show_reduced = true (* Pretty print of evord *) let vb_pp_reduced br ar evord vb_pp = let rt = SE.SplittedRel.remove_transitive_edges in if show_reduced then let evord = SE.SplittedRel.filter (fun (e1,e2) -> let x = e1.SE.event and y = e2.SE.event in not (E.EventRel.mem (x,y) ar || E.EventRel.mem (x,y) br)) (rt evord) in ("Before",br)::("After",ar):: SE.vb_pp_splitted evord @ Lazy.force vb_pp else ("Before",br)::("After",ar):: SE.vb_pp_splitted (rt evord) @ Lazy.force vb_pp (* Compute nature of relevant events *) let nature_of_relevant i x = if SE.globally_visible x then begin if proc_eq (get_proc x) i then SE.Com else SE.Prop i end else if E.is_mem_load x then SE.Exe else raise Exit let add_relevants ps xys = List.fold_left (fun k (x,y) -> List.fold_left (fun k i -> try let nx = nature_of_relevant i x and ny = nature_of_relevant i y in ({ SE.nature=nx ; event=x; },{ SE.nature=ny ; event=y; })::k with Exit -> k) k ps) [] xys let seq2 r = SE.SplittedRel.union r (SE.SplittedRel.sequence r r) let mk_evord m test conc evts vb_pp _po com rf _co loc_ord = let pp_st k (evord,(br,ar)) = if O.debug && O.verbose > 2 then begin let pp = vb_pp_reduced br ar evord vb_pp in let cy = match SE.SplittedRel.get_cycle evord with | Some cy -> eprintf "Cycle:" ; List.iter (fun e -> eprintf " %s" (SE.pp_splitted e)) cy ; eprintf "\n" ; let rec to_rel = function | [_]|[] -> E.EventRel.empty | x::(y::_ as rem) -> E.EventRel.add (y.SE.event,x.SE.event) (to_rel rem) in to_rel cy | None -> E.EventRel.empty in let pp = ("CY",cy)::pp in show_failure test conc (sprintf "Step %i" k) (lazy pp) end in pp_st (-1) (loc_ord,(E.EventRel.empty,E.EventRel.empty)) ; let ps = E.procs_of conc.S.str in (* Initial evord *) let evord0 = (* Local edges *) let r1 = loc_ord (* Read-from executed *) and r2 = let pairs = E.EventRel.fold (fun (w,r) k -> if E.same_proc w r then ({SE.nature=SE.Exe; event=w;},{SE.nature=SE.Exe; event=r;})::k else k) rf [] in SE.SplittedRel.of_list pairs (* Complete-after-execute *) and r3 = let pairs = E.EventSet.fold (fun e k -> if is_fence e then k else ({SE.nature=SE.Exe; event=e;},{SE.nature=SE.Com; event=e;})::k) evts [] in SE.SplittedRel.of_list pairs (* Propagate after complete *) and r4 = let pairs = E.EventSet.fold (fun e k -> if SE.globally_visible e then let j = get_proc e and ecom = { SE.nature = SE.Com ; event = e; } in List.fold_left (fun k i -> if proc_eq j i then k else (ecom,{ SE.nature=SE.Prop i ; event = e; })::k) k ps else k) evts [] in SE.SplittedRel.of_list pairs (* Communication edges *) and r5 = let pairs = E.EventRel.fold (fun (x,y as p) k -> if diff_proc p then let open E in match get_mem_dir x, get_mem_dir y with | Dir.R,Dir.R -> assert false | Dir.R,Dir.W -> ({ SE.nature = SE.Exe ; event = x ; }, { SE.nature = SE.Prop (get_proc x) ; event = y ; })::k | Dir.W,Dir.R -> ({ SE.nature = SE.Prop (get_proc y) ; event = x ; }, { SE.nature = SE.Exe ; event = y ; })::k | Dir.W,Dir.W -> if !Misc.switch then k else ({ SE.nature = SE.Com ; event = x ; }, { SE.nature = SE.Prop (get_proc x) ; event = y ; })::k else k) com [] in SE.SplittedRel.of_list pairs in SE.SplittedRel.unions [r1;r2;r3;r4;r5;] in let evord0 = SE.SplittedRel.filter (fun (x,y) -> not (is_bad x || is_bad y)) evord0 in (* eprintf "EVORD0: %s\n" (SE.pp_splitted_rel evord0) ; *) let f (evord,_ as p) = (* Simplification (for pictures) if already cyclic, no need to go on *) if not doall && SE.SplittedRel.is_cyclic evord then p else let br,bef = let srcs = before_sources m evord in let pairs = add_relevants ps srcs in E.EventRel.of_list srcs,SE.SplittedRel.of_list pairs and ar,aft = let srcs = after_sources m evord in let pairs = add_relevants ps srcs in E.EventRel.of_list srcs,SE.SplittedRel.of_list pairs in let evord,(br,ar) = SE.SplittedRel.unions [evord; aft; bef; ],(br,ar) in seq2 evord,(br,ar) in fixpoint pp_st eq_st f (evord0,(E.EventRel.empty,E.EventRel.empty)) (* Compute cord *) let mk_cord m co evord = let r1 = co and r2 = let srcs = before_sources m evord in E.EventRel.of_list srcs in E.EventRel.unions [r1;r2;] (***************) (* Entry point *) (***************) let check_event_structure test conc _kfail = if E.EventSet.exists (fun x -> (is_that_fence DSBST x || is_that_fence DMBST x)) conc.S.str.E.events then Warn.user_error "ST qualifier not handled by CAV12" ; let pr = MU.make_procrels is_isync conc in if O.debug && O.verbose > 0 then begin let module PP = Pretty.Make(S) in let vb_pp = MU.pp_procrels (Some B.pp_isync) pr in let legend = sprintf "%s: dependencies" test.Test_herd.name.Name.name in eprintf "%s\n%!" legend ; PP.show_legend test legend conc vb_pp end ; let flocal xe ye ze = let mem = E.EventRel.mem in let open SE in let x = xe.event and y = ye.event in let p = (x,y) in begin SE.is_satisfy xe && (SE.is_satisfy ye || SE.is_init ye) && (mem p pr.S.addr || mem p pr.S.data) end || begin SE.is_satisfy xe && SE.is_satisfy ye && is_that_fence LWSYNC ze.SE.event (* Ok for lwsync here: read/read *) end || begin SE.is_commit xe && SE.is_commit ye && (mem p pr.S.addr || mem p pr.S.data || mem p pr.S.ctrl) end || begin E.is_mem x && E.is_mem y && SE.is_commit xe && SE.is_commit ye && E.same_location x y end || begin SE.is_commit xe && SE.is_commit ye && (is_fence x || is_fence y) && (not ((E.is_load x && is_eieio y) || (E.is_load y && is_eieio x))) end || begin SE.is_commit xe && SE.is_commit ye && E.is_commit x end || begin E.is_mem x && E.is_mem y && SE.is_commit xe && SE.is_commit ye && mem (x,ze.SE.event) pr.S.addr end || (* USELESS and dangerous (should be e->e anyway by detour begin SE.is_commit xe && E.is_load x && E.is_load y && U.rext conc y && E.same_location x y && not (U.same_source conc x y) end || *) begin SE.is_commit xe && SE.is_satisfy ye && (is_isync x || is_strong x) end in (****************) (* Model proper *) (****************) (* Group Sela's parameters *) let m = {SE.fbefore;fafter;flocal;} in (* Restrict to relevant *) let po = E.EventRel.restrict_domain SE.evt_relevant conc.S.po in let evts = E.EventSet.filter SE.evt_relevant conc.S.str.E.events in (* No co dependence *) let rf = U.make_rf conc in let loc_ord = SE.splitted_loc_ord m conc evts rf po in fun kont res -> let process_co co res = let co = S.tr co in let fr = U.make_fr conc co in let com = E.EventRel.unions [rf;fr;co] in let vb_pp = lazy begin ("fr",fr)::("co",S.rt co)::[] end in (* Sela's coherence tests *) if match O.through with | ThroughAll -> false | ThroughInvalid|ThroughNone -> let complus = S.tr com in E.EventRel.exists (fun (e1,e2 as p) -> E.same_proc e1 e2 && not (E.EventRel.mem p po)) complus then begin show_failure test conc "Failure of coherence" vb_pp ; res end else begin let evord,(br,ar) = mk_evord m test conc evts vb_pp po com rf co loc_ord in let cord = mk_cord m co evord in let ok_cord = not O.opt.cord || E.EventRel.is_acyclic cord in if match O.through with | ThroughAll|ThroughInvalid -> false | ThroughNone -> not ok_cord then begin let vb_pp = lazy begin let cord = S.rt (E.EventRel.diff cord (E.EventRel.union br ar)) in ("cord",cord):: ("Before",br):: Lazy.force vb_pp end in show_failure test conc "cord is cyclic" vb_pp ; res end else let vb_pp = lazy begin vb_pp_reduced br ar evord vb_pp end in let ok_evord = SE.SplittedRel.is_acyclic evord in if match O.through with | ThroughAll|ThroughInvalid -> false | ThroughNone -> not ok_evord then begin show_failure test conc "evord is cyclic" vb_pp ; res end else begin kont conc conc.S.fs (lazy StringMap.empty,vb_pp) Flag.Set.empty res end end in U.apply_process_co test conc process_co res end herd-herdtools7-1ca343e/herd/CAction.ml000066400000000000000000000266441475314470400177520ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Printf module Make (A : Arch_herd.S) : sig type lock_arg = | LockC11 of bool (* true <=> success *) | LockLinux of Dir.dirn (* Linux locks represented as RMW *) type action = | Access of Dir.dirn * A.location * A.V.v * MemOrderOrAnnot.t * bool (* from RWM op *) * MachSize.sz | Fence of MemOrderOrAnnot.t (* LM: ??? RMW (location, read, written, mo) *) | RMW of A.location * A.V.v * A.V.v * MemOrder.t * MachSize.sz (* Specific actions for locks *) | Lock of A.location * lock_arg | Unlock of A.location * CBase.mutex_kind | TryLock of A.location (* Failed trylock, returns 1 *) (* true -> from lock, false -> from unlokk *) | ReadLock of A.location * bool (* SRCU : location, nature, and optional value (for lock/unlock) *) | SRCU of A.location * MemOrderOrAnnot.annot * A.V.v option (* CutOff: unroll too much *) | CutOff of string include Action.S with type action := action and module A = A end = struct module A = A module V = A.V open Dir open MemOrderOrAnnot type lock_arg = | LockC11 of bool (* true <=> success *) | LockLinux of Dir.dirn (* Linux locks represented as RMW *) type action = | Access of dirn * A.location * V.v * MemOrderOrAnnot.t * bool * MachSize.sz | Fence of MemOrderOrAnnot.t | RMW of A.location * V.v * V.v * MemOrder.t * MachSize.sz | Lock of A.location * lock_arg | Unlock of A.location * CBase.mutex_kind | TryLock of A.location (* Failed trylock *) | ReadLock of A.location * bool | SRCU of A.location * annot * V.v option | CutOff of string let mk_init_write l sz v = Access (W,l,v,AN [],false,sz) let par f x = sprintf "(%s)" (f x) let bra f x = sprintf "[%s]" (f x) let pp_action a = match a with | Access (d,l,v,mo,at,_) -> sprintf "%s%s%s%s=%s" (pp_dirn d) (if at then "*" else "") (match mo with | MO mo -> par MemOrder.pp_mem_order_short mo | AN [] -> "" | AN a -> bra pp_annot a) (A.pp_location l) (V.pp_v v) | Fence mo -> sprintf "F%s" (match mo with | MO mo -> par MemOrder.pp_mem_order_short mo | AN a -> bra pp_annot a) | RMW (l,v1,v2,mo,_) -> sprintf "RMW(%s)%s(%s>%s)" (MemOrder.pp_mem_order_short mo) (A.pp_location l) (V.pp_v v1) (V.pp_v v2) | Lock (l,LockC11 o) -> sprintf "L%s%s" (if o then "S" else "B") (A.pp_location l) | Unlock (l,CBase.MutexC11) -> sprintf "U%s" (A.pp_location l) | Lock (l,LockLinux d) -> sprintf "Lock(%s,%s)" (A.pp_location l) (pp_dirn d) | Unlock (l,CBase.MutexLinux) -> sprintf "Unlock(%s)" (A.pp_location l) | TryLock (l) -> sprintf "TryLock(%s,1)" (A.pp_location l) | ReadLock (l,ok) -> sprintf "ReadLock(%s,%c)" (A.pp_location l) (if ok then '1' else '0') | SRCU (l,an,None) -> sprintf "SRCU%s(%s)" (bra pp_annot an) (A.pp_location l) | SRCU (l,an,Some v) -> sprintf "SRCU%s(%s,%s)" (bra pp_annot an) (A.pp_location l) (V.pp_v v) | CutOff msg -> "CutOff:" ^ msg (* Utility functions to pick out components *) let value_of a = match a with | Access (_,_ ,v,_,_,_) | SRCU (_,_,Some v) -> Some v | _ -> None let read_of a = match a with | Access (R,_ , v,_,_,_) | RMW (_,v,_,_,_) -> Some v | _ -> None let written_of a = match a with | Access (W,_ , v,_,_,_) | RMW (_,_,v,_,_) -> Some v | _ -> None let location_of a = match a with | Access (_, loc, _,_,_,_) | Lock (loc,_) | Unlock (loc,_) | TryLock (loc) | ReadLock (loc,_) | RMW (loc,_,_,_,_) | SRCU (loc,_,_) -> Some loc | Fence _|CutOff _ -> None (* relative to memory *) let is_mem_store a = match a with | Access (W,A.Location_global _,_,_,_,_) | RMW (A.Location_global _,_,_,_,_) -> true | _ -> false let is_mem_load a = match a with | Access (R,A.Location_global _,_,_,_,_) | RMW (A.Location_global _,_,_,_,_) -> true | _ -> false let is_additional_mem_load a = match a with | TryLock _|ReadLock _ -> true | _ -> false let is_mem a = match a with | Access (_,A.Location_global _,_,_,_,_) | RMW (A.Location_global _,_,_,_,_) -> true | _ -> false let is_ifetch _ = false let is_tag _ = false let is_additional_mem a = match a with | Lock _|Unlock _|TryLock _|ReadLock _ -> true | _ -> false (* Unimplemented *) let is_pte_access _ = assert false (* All accesses are explicit *) include Explicit.NoAction (* The following definition of is_atomic is quite arbitrary. *) let old_is_atomic a = match a with | Access (_,A.Location_global _,_,AN _,_,_) -> false | Access (_,A.Location_global _,_,MO _,_,_) -> true | RMW _ -> true | _ -> false (* LM: This one is for R and W issued by RWM *) let is_atomic = function | Access (_,A.Location_global _,_,_,at,_) -> at | _ -> false let is_fault _ = false let to_fault _ = None let get_mem_dir a = match a with | Access (d,A.Location_global _,_,_,_,_) -> d | _ -> assert false let get_mem_size a = match a with | Access (_,A.Location_global _,_,_,_,sz) -> sz | _ -> assert false (* relative to the registers of the given proc *) let is_reg_store a (p:int) = match a with | Access (W,A.Location_reg (q,_),_,_,_,_) -> p = q | _ -> false let is_reg_load a (p:int) = match a with | Access (R,A.Location_reg (q,_),_,_,_,_) -> p = q | _ -> false let is_reg a (p:int) = match a with | Access (_,A.Location_reg (q,_),_,_,_,_) -> p = q | _ -> false (* Store/Load anywhere *) let is_store a = match a with | Access (W,_,_,_,_,_) | RMW _ -> true | _ -> false let is_load a = match a with | Access (R,_,_,_,_,_) | RMW _ -> true | _ -> false let is_reg_any a = match a with | Access (_,A.Location_reg _,_,_,_,_) -> true | _ -> false let is_reg_store_any a = match a with | Access (W,A.Location_reg _,_,_,_,_) -> true | _ -> false let is_reg_load_any a = match a with | Access (R,A.Location_reg _,_,_,_,_) -> true | _ -> false let compatible_accesses a1 a2 = (is_mem a1 && is_mem a2) || (is_reg_any a1 && is_reg_any a2) (* Barriers *) let is_barrier = function | Fence _ -> true | _ -> false let barrier_of _ = assert false let same_barrier_id _ _ = assert false (* (No) commits *) let is_bcc _ = false let is_pred ?cond:_ _ = false let is_commit _ = false (* Unrolling control *) let cutoff msg = CutOff msg let is_cutoff = function | CutOff _ -> true | _ -> false let as_cutoff = function | CutOff msg -> Some msg | _ -> None (* RMWs *) let is_rmw a = match a with | RMW _ -> true | _ -> false (* Mutex operations *) let is_lock a = match a with | Lock _ -> true | _ -> false let is_lock_read a = match a with | Lock (_,LockLinux R) -> true | _ -> false let is_lock_write a = match a with | Lock (_,LockLinux W) -> true | _ -> false let is_successful_lock a = match a with | Lock (_,LockC11 true) -> true | _ -> false let is_failed_lock a = match a with | Lock (_,LockC11 false) | TryLock (_) -> true | _ -> false let is_read_locked a = match a with | ReadLock (_,b) -> b | _ -> false let is_read_unlocked a = match a with | ReadLock (_,b) -> not b | _ -> false let is_unlock a = match a with | Unlock _ -> true | _ -> false let mo_matches target a = match a with | Access(_,_,_,MO mo,_,_) | RMW (_,_,_,mo,_) | Fence (MO mo) -> mo=target | _ -> false (* Architecture-specific sets *) let arch_sets = [ "RMW",(fun e -> is_rmw e || is_atomic e); "LK", is_lock; "LKR", is_lock_read; "LKW",is_lock_write; "LS", is_successful_lock;"LF", is_failed_lock; "UL", is_unlock; "RL",is_read_locked; "RU",is_read_unlocked; "ACQ", mo_matches MemOrder.Acq; "SC", mo_matches MemOrder.SC; "REL", mo_matches MemOrder.Rel; "ACQ_REL", mo_matches MemOrder.Acq_Rel; "RLX", mo_matches MemOrder.Rlx; "CON", mo_matches MemOrder.Con; (* For C11 RCU, Linux RCU implemented with bell file !! *) "A",old_is_atomic; "NA",(fun a -> not (old_is_atomic a)); "annot", (fun a -> match a with | Access (_,_,_,AN a,_,_) | Fence (AN a) when a != [] -> true | _ -> false) ] let arch_rels = [] and arch_dirty = [] let is_isync _ = raise Misc.NoIsync let pp_isync = "???" (* Equations *) let undetermined_vars_in_action a = match a with | Access (_,l,v,_,_,_) | SRCU (l,_,Some v) -> V.ValueSet.union (A.undetermined_vars_in_loc l) (V.undetermined_vars v) | RMW(l,v1,v2,_,_) -> V.ValueSet.union3 (A.undetermined_vars_in_loc l) (V.undetermined_vars v1) (V.undetermined_vars v2) | TryLock (l) | Lock(l,_) | Unlock (l,_) | ReadLock (l,_) | SRCU(l,_,None) -> A.undetermined_vars_in_loc l | Fence _|CutOff _ -> V.ValueSet.empty let simplify_vars_in_action soln a = match a with | Access (d,l,v,mo,at,sz) -> let l' = A.simplify_vars_in_loc soln l in let v' = V.simplify_var soln v in Access (d,l',v',mo,at,sz) | RMW(l,v1,v2,mo,sz) -> let l' = A.simplify_vars_in_loc soln l in let v1' = V.simplify_var soln v1 in let v2' = V.simplify_var soln v2 in RMW(l',v1',v2',mo,sz) | Lock(l,a) -> let l' = A.simplify_vars_in_loc soln l in Lock(l',a) | Unlock (l,k) -> let l' = A.simplify_vars_in_loc soln l in Unlock (l',k) | TryLock (l) -> let l' = A.simplify_vars_in_loc soln l in TryLock (l') | ReadLock (l,b) -> let l' = A.simplify_vars_in_loc soln l in ReadLock (l',b) | SRCU(l,a,vo) -> let l' = A.simplify_vars_in_loc soln l in SRCU(l',a,Misc.app_opt (V.simplify_var soln) vo) | Fence _|CutOff _ -> a (*************************************************************) (* Add together event structures from different instructions *) (*************************************************************) let annot_in_list str ac = match ac with | Access (_,_,_,AN a,_,_) | Fence (AN a) | SRCU(_,a,_) -> List.exists (fun a -> Misc.string_eq str a) a | Access (_, _, _, MO _,_,_)|Fence (MO _)|RMW (_, _, _, _,_) | Lock _|Unlock _|TryLock _|ReadLock _|CutOff _ -> false end herd-herdtools7-1ca343e/herd/CArch_herd.ml000066400000000000000000000036151475314470400204050ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make (C:Arch_herd.Config) (V:Value.S) = struct include CBase (* Not so simple, should consider expressions... *) let is_amo _ = assert false let pp_barrier_short = pp_barrier let reject_mixed = false let mem_access_size _ = None include NoSemEnv module V = V include NoLevelNorTLBI include ArchExtra_herd.Make(C) (struct module V = V let endian = endian type arch_reg = reg let pp_reg = pp_reg let reg_compare = reg_compare let fromto_of_instr _ = None let get_val _ v = v module FaultType=FaultType.No end) module MemType=MemoryType.No module Barrier = AllBarrier.No(struct type a = barrier end) module CMO = Cmo.No end herd-herdtools7-1ca343e/herd/CMem.ml000066400000000000000000000037131475314470400172430ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Entry to models for CPP11 *) module type Config = sig val model : Model.t val bell_model_info : (string * BellModel.info) option include Model.Config val statelessrc11 : bool end module Make (O:Config) (S:Sem.Semantics) : (XXXMem.S with module S = S) = struct open Model let model = O.model module S = S let check_event_structure test = match O.model with | Generic (fname,m) -> let module X = MachModelChecker.Make (struct let fname = fname let m = m let wide_po = true include O end)(S) in X.check_event_structure test | File _ -> assert false | m -> Warn.fatal "Model %s not implemented for C" (Model.pp m) end herd-herdtools7-1ca343e/herd/CParseTest.ml000066400000000000000000000050011475314470400204270ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make(Conf:RunTest.Config)(ModelConfig:CMem.Config) = struct module LexConfig = struct let debug = Conf.debug.Debug_herd.lexer end module ArchConfig = SemExtra.ConfigToArchConfig(Conf) module MakeRun (CValue:Value.S with module Cst.Instr=CBase.Instr and type arch_op = CBase.arch_op) = struct module CS = CSem.Make(Conf)(CValue) module CM = CMem.Make(ModelConfig)(CS) module C = CArch_herd.Make(ArchConfig)(CValue) module CLexParse = struct (* Parsing *) type pseudo = C.pseudo type token = CParser.token module Lexer = CLexer.Make(LexConfig) let shallow_lexer = Lexer.token false let deep_lexer = Lexer.token true let shallow_parser = CParser.shallow_main let deep_parser = CParser.deep_main (* Macros *) type macro = C.macro let macros_parser = CParser.macros let macros_expand = CBase.expand end module P = CGenParser_lib.Make (Conf) (C) (CLexParse) module X = RunTest.Make (CS) (P) (CM) (Conf) end let run = if Conf.variant Variant.S128 then let module CValue = Int128Value.Make(CBase.Instr) in let module Run = MakeRun(CValue) in Run.X.run else let module CValue = Int32Value.Make(CBase.Instr) in let module Run = MakeRun(CValue) in Run.X.run end herd-herdtools7-1ca343e/herd/CParseTest.mli000066400000000000000000000024451475314470400206110ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make : functor(Conf:RunTest.Config) -> functor(ModelConfig:CMem.Config) -> sig val run : RunTest.runfun end herd-herdtools7-1ca343e/herd/CSem.ml000066400000000000000000000472211475314470400172530ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module type Config = sig include Sem.Config end module Make (Conf:Config) (V:Value.S with type Cst.Instr.t = CBase.instruction and type arch_op = CBase.arch_op) = struct let unroll = match Conf.unroll with | None -> Opts.unroll_default `C | Some u -> u (* We check if the variant does not match any of the others rather than explicitly checking if it matchs v1 to get v1 as default even if no variant is given. If more variants are added, this condition needs to be updated. *) let lkmmv1 = not (Conf.variant (Variant.LKMMVersion `lkmmv2)) module C = CArch_herd.Make(SemExtra.ConfigToArchConfig(Conf))(V) module Act = CAction.Make(C) include SemExtra.Make(Conf)(C)(Act) let barriers = [] let isync = None (* TODO: No real mixed size for C, as access sizes depend upon types... *) let nat_sz = V.Cst.Scalar.machsize let atomic_pair_allowed e1 e2 = match e1.E.iiid, e2.E.iiid with | E.IdSome i1,E.IdSome i2 -> i1 == i2 | _,_ -> false (****************************) (* Build semantics function *) (****************************) module Mixed(SZ : ByteSize.S) = struct let (>>=) = M.(>>=) let (>>==) = M.(>>==) let (>>*=) = M.(>>*=) let (>>|) = M.(>>|) let (>>::) = M.(>>::) let (>>!) = M.(>>!) let (>>>) = M.cseq let (>>>>) = M.(>>>>) let next0 = B.Next [] module MOorAN = MemOrderOrAnnot let a_once = ["once"] let a_noreturn = ["noreturn"] let an_once = MOorAN.AN a_once let a_mb = ["mb"] let a_rb_dep = ["rb_dep"] let no_mo = MOorAN.AN [] let mo_as_anmo mo = MOorAN.MO mo let mk_cutoff msg ii = M.mk_singleton_es (Act.CutOff msg) ii let read_loc is_data mo = M.read_loc is_data (fun loc v -> Act.Access (Dir.R, loc, v, mo, false, nat_sz)) let read_exchange is_data vstored mo = M.read_loc is_data (fun loc v -> Act.RMW (loc,v,vstored,mo,nat_sz)) let read_reg is_data r ii = read_loc is_data no_mo (A.Location_reg (ii.A.proc,r)) ii let read_mem is_data mo a = read_loc is_data mo (A.Location_global a) let read_mem_atomic is_data a loc = M.read_loc is_data (fun loc v -> Act.Access (Dir.R, loc, v, a, true, nat_sz)) (A.Location_global loc) let read_mem_atomic_known is_data a loc v = M.read_loc is_data (fun loc _v -> Act.Access (Dir.R, loc, v, a, true, nat_sz)) (A.Location_global loc) let write_loc mo loc v ii = M.mk_singleton_es (Act.Access (Dir.W, loc, v, mo, false, nat_sz)) ii >>! v let write_reg r v ii = write_loc no_mo (A.Location_reg (ii.A.proc,r)) v ii let write_mem mo a = write_loc mo (A.Location_global a) let write_mem_atomic a loc v ii = M.mk_singleton_es (Act.Access (Dir.W, A.Location_global loc, v, a, true,nat_sz)) ii >>! v let mk_fence_a a ii = M.mk_fence (Act.Fence (MOorAN.AN a)) ii let mk_mb ii = mk_fence_a a_mb ii let mk_rb_dep ii = mk_fence_a a_rb_dep ii let xchg is_data rloc re a ii = let add_mb = match a with | ["mb"] -> true | _ -> false in let aw = (if lkmmv1 then match a with | ["release"] -> MOorAN.AN a | _ -> an_once else MOorAN.AN a) and ar = (if lkmmv1 then match a with | ["acquire"] -> MOorAN.AN a | _ -> an_once else MOorAN.AN a) in let rmem = fun loc -> read_mem_atomic is_data ar loc ii and wmem = fun loc v -> write_mem_atomic aw loc v ii >>! () in let exch = M.linux_exch rloc re rmem wmem in if lkmmv1 && add_mb then mk_fence_a a ii >>*= fun () -> exch >>*= fun v -> mk_fence_a a ii >>! v else exch let cxchg is_data rloc re mo v_loc ii = let m = match mo with | MemOrder.SC | MemOrder.Rlx -> (mo, mo) | MemOrder.Rel -> (MemOrder.Rlx, mo) | MemOrder.Acq -> (mo, MemOrder.Rlx) | MemOrder.Acq_Rel -> (MemOrder.Acq, MemOrder.Rel) | _ -> assert false in let rmem = match v_loc with | None -> fun loc -> read_mem_atomic is_data (MOorAN.MO (fst m)) loc ii | Some x -> fun loc -> read_mem_atomic_known is_data (MOorAN.MO (fst m)) loc x ii and wmem = fun loc v -> write_mem_atomic (MOorAN.MO (snd m)) loc v ii >>! () in let exch = M.linux_exch rloc re rmem wmem in exch let linux_lock loc ii = M.mk_singleton_es (Act.Lock (A.Location_global loc,Act.LockLinux Dir.R)) ii >>*= fun () -> M.mk_singleton_es (Act.Lock (A.Location_global loc,Act.LockLinux Dir.W)) ii let rec build_semantics_expr is_data e ii : V.v M.t = match e with | C.Const v -> M.unitT (V.maybevToV v) | C.LoadReg r -> read_reg is_data r ii | C.LoadMem(loc,mo) -> let open MemOrderOrAnnot in (match mo with | AN [] | MO _ -> build_semantics_expr is_data loc ii | AN (_::_) -> begin match loc with | C.LoadMem (loc,AN []) -> build_semantics_expr is_data loc ii | _ -> Warn.user_error "Bad __load argument: %s" (C.dump_expr loc) end) >>= fun l -> begin match mo with | AN [("deref"|"lderef")] -> (* Cannot do this with a macro, by lack of sequencing expression operator *) read_mem is_data an_once l ii >>*= fun v -> mk_rb_dep ii >>! v | _ -> read_mem is_data mo l ii end | C.TryLock (_,C.MutexC11) -> assert false | C.TryLock (loc,C.MutexLinux) -> build_semantics_expr is_data loc ii >>= fun l -> M.altT (linux_lock l ii >>! V.one) (M.mk_singleton_es (Act.TryLock (A.Location_global l)) ii >>! V.zero) | C.IsLocked (_,C.MutexC11) -> assert false | C.IsLocked (loc,C.MutexLinux) -> build_semantics_expr is_data loc ii >>= fun l -> M.altT (M.mk_singleton_es (* Read from lock *) (Act.ReadLock (A.Location_global l,true)) ii >>! V.one) (M.mk_singleton_es (* Read from a unlock *) (Act.ReadLock (A.Location_global l,false)) ii >>! V.zero) | C.Op(op,e1,e2) -> (build_semantics_expr is_data e1 ii >>| build_semantics_expr is_data e2 ii) >>= fun (v1,v2) -> M.op op v1 v2 | C.Exchange(l,e,(MOorAN.AN a)) -> let re = build_semantics_expr true e ii and rloc = build_semantics_expr false l ii in xchg is_data rloc re a ii | C.Exchange(l,e,MOorAN.MO mo) -> if Conf.variant Variant.NoRMW then let re = build_semantics_expr true e ii and rloc = build_semantics_expr false l ii in cxchg is_data rloc re mo None ii else (build_semantics_expr true e ii >>| build_semantics_expr false l ii) >>= (fun (v,l) -> read_exchange is_data v mo (A.Location_global l) ii) | C.CmpExchange (eloc,eold,enew,a) -> let mloc = build_semantics_expr false eloc ii and mold = build_semantics_expr true eold ii in let add_mb r = (if lkmmv1 then (match a with | ["mb"] -> mk_mb ii >>*= fun () -> r >>*= fun v -> mk_mb ii >>! v | _ -> r) else r) and arok = (if lkmmv1 then (match a with | ["acquire"] -> MOorAN.AN a | _ -> an_once) else MOorAN.AN a) and awok = (if lkmmv1 then (match a with | ["release"] -> MOorAN.AN a | _ -> an_once) else MOorAN.AN a) and arnok = (if lkmmv1 then an_once else MOorAN.AN a) in M.altT (let r = let mnew = build_semantics_expr true enew ii and rmem vloc = read_mem_atomic true arok vloc ii and wmem vloc w = write_mem_atomic awok vloc w ii >>! () in M.linux_cmpexch_ok mloc mold mnew rmem wmem M.assign in add_mb r) (M.linux_cmpexch_no mloc mold (fun vloc -> read_mem_atomic true arnok vloc ii) M.neqT) | C.Fetch(l,op,e,mo) -> (build_semantics_expr true e ii >>| build_semantics_expr false l ii) >>= (fun (v,l) -> fetch_op op v mo l ii) | C.ECas(obj,exp,des,success,failure,strong) -> (* Obtain location of "expected" value *) build_semantics_expr false exp ii >>= fun loc_exp -> (* Obtain location of object *) build_semantics_expr false obj ii >>= fun loc_obj -> (* Non-atomically read the value at "expected" location *) read_mem true no_mo loc_exp ii >>*= fun v_exp -> (* Non-deterministic choice *) M.altT (read_mem true (mo_as_anmo failure) loc_obj ii >>*= fun v_obj -> (* For "strong" cas: fail only when v_obj != v_exp *) (if strong then M.neqT v_obj v_exp else M.unitT ()) >>= fun () -> (* Non-atomically write that value into the "expected" location *) write_mem no_mo loc_exp v_obj ii >>! V.zero) (* Obtain "desired" value *) (build_semantics_expr true des ii >>= fun v_des -> if Conf.variant Variant.NoRMW then let re = build_semantics_expr true des ii and rloc = build_semantics_expr false obj ii in cxchg is_data rloc re success (Some v_exp) ii >>! V.one else (* Do RMW action on "object", to change its value from "expected" to "desired", using memory order "success" *) M.mk_singleton_es (Act.RMW (A.Location_global loc_obj,v_exp,v_des,success,nat_sz)) ii >>! V.one) | C.AtomicOpReturn (eloc,op,e,ret,a) -> if lkmmv1 then begin match a with | ["mb"] -> mk_mb ii >>*= fun () -> build_atomic_op ret a_once a_once eloc op e ii >>*= fun v -> mk_mb ii >>! v | _ -> build_atomic_op ret (match a with ["acquire"] -> a | _ -> a_once) (match a with ["release"] -> a | _ -> a_once) eloc op e ii end else build_atomic_op ret a a eloc op e ii | C.AtomicAddUnless (eloc,ea,eu,retbool,a) -> (* read arguments *) let mloc = build_semantics_expr false eloc ii and mu = build_semantics_expr true eu ii and mrmem loc = read_mem_atomic true (if lkmmv1 then an_once else (MOorAN.AN a)) loc ii in M.altT (let r = M.linux_add_unless_ok mloc (build_semantics_expr true ea ii) mu mrmem (fun loc v -> write_mem_atomic (if lkmmv1 then an_once else (MOorAN.AN a)) loc v ii >>! ()) M.neqT M.add (if retbool then Some V.one else None) in (if lkmmv1 then mk_mb ii >>*= fun () -> r >>*= fun v -> mk_mb ii >>! v else r)) (M.linux_add_unless_no mloc mu mrmem M.assign (if retbool then Some V.zero else None)) | C.ExpSRCU(eloc,a) -> let r = match a with | ["srcu-lock"] -> Some (A.V.intToV ((ii.A.proc +1)* 307 + ii.A.program_order_index * 599)) | _ -> None in build_semantics_expr false eloc ii >>= fun (vloc) -> M.mk_singleton_es (Act.SRCU (A.Location_global vloc,a,r)) ii >>! (match r with None -> V.zero | Some v -> v) | C.ECall (f,_) -> Warn.fatal "Macro call %s in CSem" f and build_atomic_op ret a_read a_write eloc op e ii = build_semantics_expr true e ii >>| (build_semantics_expr false eloc ii >>= fun loc -> (read_mem_atomic true (MOorAN.AN a_read) loc ii >>| M.unitT loc)) >>== (* Notice '==' as atomic_op 'ouput' iico depends on R *) (fun (v,(vloc,loc)) -> M.op op vloc v >>= fun w -> let a = MOorAN.AN a_write in match ret with | C.OpReturn -> write_mem_atomic a loc w ii | C.FetchOp -> write_mem_atomic a loc w ii >>! vloc) and fetch_op op v mo loc ii = if Conf.variant Variant.NoRMW then read_mem_atomic true (MOorAN.MO (MemOrder.extract_read mo)) loc ii >>= fun oldv -> M.op op oldv v >>= fun w -> write_mem_atomic (MOorAN.MO (MemOrder.extract_write mo)) loc w ii >>! oldv else M.fetch op v (fun v vstored -> Act.RMW (A.Location_global loc,v,vstored,mo,nat_sz)) ii let zero = ParsedConstant.zero let build_cond e ii = let open Op in let e = match e with | C.Op ((Lt|Gt|Eq|Ne|Le|Ge),_,_) -> e | _ -> C.Op (Ne,e,C.Const zero) in build_semantics_expr false e ii let rec build_semantics test ii : (A.program_order_index * B.t) M.t = let ii = {ii with A.program_order_index = A.next_po_index ii.A.program_order_index;} in match ii.A.inst with | C.Seq (insts,_) -> build_semantics_list test insts ii | C.If(c,t,Some e) -> build_cond c ii >>>> fun ret -> let ii' = {ii with A.program_order_index = A.next_po_index ii.A.program_order_index;} in let then_branch = build_semantics test {ii' with A.inst = t} in let else_branch = build_semantics test {ii' with A.inst = e} in M.choiceT ret then_branch else_branch | C.If(c,t,None) -> build_cond c ii >>>> fun ret -> let ii' = {ii with A.program_order_index = A.next_po_index ii.A.program_order_index;} in let then_branch = build_semantics test {ii' with A.inst = t} in M.choiceT ret then_branch (build_semantics_list test [] ii) | C.While(c,t,n) -> build_cond c ii >>>> begin let else_branch = M.unitT (ii.A.program_order_index, next0) and then_branch = if n >= unroll then mk_cutoff "While" ii >>= fun () -> M.unitT (ii.A.program_order_index, B.Exit) else build_semantics test {ii with A.inst = t} >>> fun (prog_order, _branch) -> build_semantics test {ii with A.program_order_index = prog_order; A.inst = C.While(c,t,n+1);} in fun ret -> M.choiceT ret then_branch else_branch end | C.DeclReg _ -> M.unitT (ii.A.program_order_index, next0) | C.CastExpr e -> build_semantics_expr true e ii >>= fun _ -> M.unitT (ii.A.program_order_index, next0) | C.StoreReg(_,Some r,e) -> build_semantics_expr true e ii >>= fun v -> write_reg r v ii >>= fun _ -> M.unitT (ii.A.program_order_index, next0) | C.StoreReg(_,None,e) -> build_semantics_expr true e ii >>= fun _ -> M.unitT (ii.A.program_order_index, next0) | C.StoreMem(loc,e,mo) -> (begin let open MemOrderOrAnnot in match mo with | AN [] | MO _ -> build_semantics_expr false loc ii | AN (_::_) -> match loc with | C.LoadMem (loc,AN []) -> build_semantics_expr false loc ii | _ -> Warn.user_error "Bad __store argument: %s" (C.dump_expr loc) end >>| build_semantics_expr true e ii) >>= fun (l,v) -> write_mem mo l v ii >>= fun _ -> M.unitT (ii.A.program_order_index, next0) (* C11 mutex, not sure about them... *) | C.Lock (l,k) -> build_semantics_expr false l ii >>= fun l -> begin match k with | C.MutexC11 -> (* C11 Lock always successful, oversimplification? *) (M.mk_singleton_es (Act.Lock (A.Location_global l, Act.LockC11 true)) ii) | C.MutexLinux -> linux_lock l ii end >>= fun () -> M.unitT (ii.A.program_order_index, next0) | C.Unlock (l,k) -> build_semantics_expr false l ii >>= fun l -> M.mk_singleton_es (Act.Unlock (A.Location_global l,k)) ii >>= fun _ -> M.unitT (ii.A.program_order_index, next0) (********************) | C.AtomicOp (eloc,op,e,a) -> let ar = (if lkmmv1 then a_noreturn else a) and aw = (if lkmmv1 then a_once else a) in build_atomic_op C.OpReturn ar aw eloc op e ii >>= fun _ -> M.unitT (ii.A.program_order_index, next0) (********************) | C.Fence(mo) -> M.mk_fence (Act.Fence mo) ii >>= fun _ -> M.unitT (ii.A.program_order_index, next0) (********************) | C.InstrSRCU(e,a,oe) -> build_semantics_expr false e ii >>| (match oe with | None -> M.unitT None | Some e -> build_semantics_expr true e ii >>= fun v -> M.unitT (Some v)) >>= fun (l,v) -> M.mk_singleton_es (Act.SRCU (A.Location_global l,a,v)) ii >>= fun _ -> M.unitT (ii.A.program_order_index, next0) (********************) | C.Symb _ -> Warn.fatal "No symbolic instructions allowed." | C.PCall (f,_) -> Warn.fatal "Procedure call %s in CSem" f and build_semantics_list test insts ii = match insts with | [] -> M.unitT (ii.A.program_order_index, next0) | inst :: insts -> let ii = {ii with A.inst=inst; } in build_semantics test ii >>> fun (prog_order, _branch) -> build_semantics_list test insts {ii with A.program_order_index = prog_order;} let spurious_setaf _ = assert false end end herd-herdtools7-1ca343e/herd/GenericArch_herd.ml000066400000000000000000000045141475314470400215760ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Authors: *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* Hadrien Renaud, University College London, UK. *) (****************************************************************************) module type ArchBaseHerd = sig include ArchBase.S val endian : Endian.t end module Make (B : ArchBaseHerd) (C : Arch_herd.Config) (V : Value.S) = struct module V = V include B include NoSemEnv include NoLevelNorTLBI let is_amo _ = false let pp_barrier_short = pp_barrier let reject_mixed = false let mem_access_size _ = None include ArchExtra_herd.Make (C) (struct module V = V module FaultType = FaultType.No type arch_reg = reg let endian = endian let pp_reg = pp_reg let reg_compare = reg_compare let fromto_of_instr _ = None let get_val _ v = v end) module MemType = MemoryType.No module Barrier = AllBarrier.No (struct type a = barrier end) module CMO = Cmo.No end herd-herdtools7-1ca343e/herd/JAVAParseTest.ml000066400000000000000000000036701475314470400210000ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make(Conf:RunTest.Config)(ModelConfig:CMem.Config) = struct module LexConfig = struct let debug = Conf.debug.Debug_herd.lexer end module ArchConfig = SemExtra.ConfigToArchConfig(Conf) module JavaValue = Int64Value.Make(JavaBase.Instr) module Java = JavaArch_herd.Make(ArchConfig)(JavaValue) module JavaLexParse = struct type pseudo = Java.pseudo type token = JavaParser.token module Lexer = JavaLexer.Make(LexConfig) let lexer = Lexer.token let parser = JavaParser.main end module JavaS = JavaSem.Make(Conf)(JavaValue) module JavaM = CMem.Make(ModelConfig)(JavaS) module P = JavaGenParser_lib.Make (Conf) (Java) (JavaLexParse) module X = RunTest.Make (JavaS) (P) (JavaM) (Conf) let run = X.run end herd-herdtools7-1ca343e/herd/JAVAParseTest.mli000066400000000000000000000024451475314470400211500ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make : functor(Conf:RunTest.Config) -> functor(ModelConfig:CMem.Config) -> sig val run : RunTest.runfun end herd-herdtools7-1ca343e/herd/JavaAction.ml000066400000000000000000000154061475314470400204430ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make (A : Arch_herd.S) : sig type action = | Access of Dir.dirn * A.location * A.V.v * AccessModes.t * MachSize.sz | Fence of AccessModes.t | RMW of A.location * A.V.v * A.V.v * AccessModes.t * MachSize.sz | CutOff of string include Action.S with type action := action and module A = A end = struct module A = A module V = A.V open Dir open Printf type action = | Access of Dir.dirn * A.location * A.V.v * AccessModes.t * MachSize.sz | Fence of AccessModes.t | RMW of A.location * A.V.v * A.V.v * AccessModes.t * MachSize.sz | CutOff of string let mk_init_write l sz v = Access (W, l, v, AccessModes.NA, sz) let par f x = sprintf "(%s)" (f x) (*for access modes*) let pp_action a = match a with | Access (d, l, v, am, _) -> (sprintf "%s%s%s=%s" (pp_dirn d) (par AccessModes.pp_access_modes am) (A.pp_location l) (V.pp_v v)) | Fence b -> sprintf "Fence%s" (par AccessModes.pp_access_modes b) | RMW (l, v1, v2, am, _) -> (sprintf "RMW(%s)%s(%s>%s)" (AccessModes.pp_access_modes am) (A.pp_location l) (V.pp_v v1) (V.pp_v v2)) | CutOff m -> (sprintf "CutOff: %s" m) let is_isync _ = raise Misc.NoIsync let pp_isync = "???" let is_barrier a = match a with | Fence _ -> true | _ -> false let barrier_of _ = assert false let same_barrier_id _ _ = assert false let is_rmw a = match a with | RMW _ -> true | _ -> false let is_reg a (p:int) = match a with | Access (_,A.Location_reg (q,_),_,_,_) -> p = q | _ -> false let is_mem a = match a with | Access (_,A.Location_global _,_,_,_) -> true | RMW (A.Location_global _,_,_,_,_) -> true | _ -> false let is_ifetch _ = false let is_additional_mem _ = false let is_additional_mem_load _ = false let is_atomic a = match a with | Access (_,A.Location_global _,_,_,_) -> true | RMW _ -> true | _ -> false let to_fault _ = None let is_reg_store a (p:int) = match a with | Access (W,A.Location_reg (q,_),_,_,_) -> p = q | _ -> false let is_reg_load a (p:int) = match a with | Access (R,A.Location_reg (q,_),_,_,_) -> p = q | _ -> false (* let is_reg_any a = match a with | Access (_,A.Location_reg _,_,_,_) -> true | _ -> false *) let get_mem_dir a = match a with | Access (d,A.Location_global _,_,_,_) -> d | _ -> assert false let get_mem_size a = match a with | Access (_,A.Location_global _,_,_,sz) -> sz | _ -> assert false let is_pte_access _ = false let is_mem_store a = match a with | Access (W,A.Location_global _,_,_,_) | RMW (A.Location_global _,_,_,_,_) -> true | _ -> false let is_mem_load a = match a with | Access (R,A.Location_global _,_,_,_) | RMW (A.Location_global _,_,_,_,_) -> true | _ -> false let value_of a = match a with | Access (_,_,v,_,_) -> Some v | _ -> None let read_of a = match a with | Access (R,_ , v,_,_) | RMW (_,v,_,_,_) -> Some v | _ -> None let written_of a = match a with | Access (W,_ , v,_,_) | RMW (_,_,v,_,_) -> Some v | _ -> None let location_of a = match a with | Access (_, l, _,_,_) -> Some l | RMW (l,_,_,_,_) -> Some l | Fence _ -> None | _ -> None (* Store/Load anywhere *) let is_store a = match a with | Access (W,_,_,_,_) | RMW _ -> true | _ -> false let is_load a = match a with | Access (R,_,_,_,_) | RMW _ -> true | _ -> false let is_reg_any a = match a with | Access (_,A.Location_reg _,_,_,_) -> true | _ -> false let is_reg_store_any a = match a with | Access (W,A.Location_reg _,_,_,_) -> true | _ -> false let is_reg_load_any a = match a with | Access (R,A.Location_reg _,_,_,_) -> true | _ -> false let compatible_accesses a1 a2 = (is_mem a1 && is_mem a2) || (is_reg_any a1 && is_reg_any a2) let arch_rels = [] let arch_dirty = [] let is_fault _ = false let is_tag _ = false let cutoff msg = CutOff msg let is_cutoff = function | CutOff _ -> true | _ -> false let as_cutoff = function | CutOff msg -> Some msg | _ -> None let is_bcc _ = false let is_pred ?cond:_ _ = false let is_commit _ = false include Explicit.NoAction let annot_in_list _ _ = false let mo_matches target a = match a with | Access(_,_,_,mo,_) | RMW (_,_,_,mo,_) | Fence (mo) -> (mo = target) | _ -> false let undetermined_vars_in_action a = match a with | Access (_,l,v,_,_)-> V.ValueSet.union (A.undetermined_vars_in_loc l) (V.undetermined_vars v) | RMW (l,v1,v2,_,_) -> V.ValueSet.union3 (A.undetermined_vars_in_loc l) (V.undetermined_vars v1) (V.undetermined_vars v2) | Fence _ -> V.ValueSet.empty | CutOff _ -> assert false let simplify_vars_in_action soln a = match a with | Access (d,l,v,mo,sz) -> let l' = A.simplify_vars_in_loc soln l in let v' = V.simplify_var soln v in Access (d,l',v',mo,sz) | RMW(l,v1,v2,mo,sz) -> let l' = A.simplify_vars_in_loc soln l in let v1' = V.simplify_var soln v1 in let v2' = V.simplify_var soln v2 in RMW(l',v1',v2',mo,sz) | Fence _ -> a | CutOff _ -> assert false let arch_sets = [ "RMW", (fun e -> is_rmw e); "REL", mo_matches AccessModes.Release; "V", mo_matches AccessModes.Volatile; "ACQ", mo_matches AccessModes.Acquire; "RA", (fun e -> mo_matches AccessModes.Acquire e || mo_matches AccessModes.Release e); "O", mo_matches AccessModes.Opaque ] (* let arch_fences = [] *) end herd-herdtools7-1ca343e/herd/JavaArch_herd.ml000066400000000000000000000036561475314470400211110ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Define Java architecture *) module Make (C:Arch_herd.Config) (V:Value.S) = struct include JavaBase let is_amo _ = false let pp_barrier_short = pp_barrier let reject_mixed = false let mem_access_size _ = None include NoSemEnv module V = V include NoLevelNorTLBI include ArchExtra_herd.Make(C) (struct module V = V let endian = endian type arch_reg = reg let pp_reg = pp_reg let reg_compare = reg_compare let fromto_of_instr _ = None let get_val _ v = v module FaultType=FaultType.No end) module MemType=MemoryType.No module Barrier = AllBarrier.No(struct type a = barrier end) module CMO = Cmo.No end herd-herdtools7-1ca343e/herd/JavaSem.ml000066400000000000000000000167271475314470400177610ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Java instruction semantics *) module Make (Conf:Sem.Config) (V:Value.S with type Cst.Instr.t = JavaBase.instruction and type arch_op = JavaBase.arch_op) = struct module Java = JavaArch_herd.Make(SemExtra.ConfigToArchConfig(Conf))(V) module Act = JavaAction.Make(Java) include SemExtra.Make(Conf)(Java)(Act) let barriers = [] let isync = None let nat_sz = V.Cst.Scalar.machsize let atomic_pair_allowed e1 e2 = (e1.E.iiid == e2.E.iiid) module Mixed(SZ : ByteSize.S) = struct let (>>=) = M.(>>=) let (>>*=) = M.(>>*=) let (>>|) = M.(>>|) let (>>!) = M.(>>!) let (>>>) = M.cseq let (>>>>) = M.(>>>>) let no_mo = AccessModes.NA let read_loc is_data mo = M.read_loc is_data (fun loc v -> Act.Access (Dir.R, loc, v, mo, nat_sz)) let read_exchange is_data vstored mo = M.read_loc is_data (fun loc v -> Act.RMW (loc,v,vstored,mo,nat_sz)) let read_reg is_data r ii = read_loc is_data no_mo (A.Location_reg (ii.A.proc,r)) ii let read_mem is_data mo a = read_loc is_data mo (A.Location_global a) let read_mem_atomic is_data a loc = M.read_loc is_data (fun loc v -> Act.Access (Dir.R, loc, v, a, nat_sz)) (A.Location_global loc) let read_mem_atomic_known is_data a loc v = M.read_loc is_data (fun loc _v -> Act.Access (Dir.R, loc, v, a, nat_sz)) (A.Location_global loc) let write_loc mo loc v ii = M.mk_singleton_es (Act.Access (Dir.W, loc, v, mo, nat_sz)) ii >>! v let write_reg r v ii = write_loc no_mo (A.Location_reg (ii.A.proc,r)) v ii let write_mem mo a = write_loc mo (A.Location_global a) let write_mem_atomic a loc v ii = M.mk_singleton_es (Act.Access (Dir.W, A.Location_global loc, v, a, nat_sz)) ii >>! v let fetch_op op v am l ii = M.fetch op v (fun v vstored -> Act.RMW (A.Location_global l, v, vstored, am, nat_sz)) ii let rec build_semantics_expr is_data e ii : V.v M.t = match e with | JavaBase.LoadReg reg -> read_reg is_data reg ii | JavaBase.LoadMem (vh, am) -> (read_reg is_data vh ii) >>= (fun l -> read_mem is_data am l ii) | JavaBase.Const i -> M.unitT (V.maybevToV (ParsedConstant.intToV i)) | JavaBase.Op (op, e1, e2) -> (build_semantics_expr is_data e1 ii >>| build_semantics_expr is_data e2 ii) >>= fun (v1, v2) -> M.op op v1 v2 | JavaBase.Rmw (vh, (op, am), e) -> (read_reg is_data vh ii) >>| (build_semantics_expr true e ii) >>= (fun (l , v) -> fetch_op op v am l ii) | JavaBase.CAS (vh, (read_am, write_am), expect, dest) -> (read_reg is_data vh ii) >>= fun loc_vh -> (build_semantics_expr true expect ii) >>= fun v_expect -> (read_mem true read_am loc_vh ii) >>*= fun v_vh -> M.altT ((M.neqT v_vh v_expect) >>! v_vh) ((build_semantics_expr true dest ii) >>= fun v_dest -> (M.mk_singleton_es (Act.RMW (A.Location_global loc_vh, v_expect, v_dest, (match read_am , write_am with | AccessModes.Acquire, AccessModes.Plain -> read_am | AccessModes.Plain, AccessModes.Release -> write_am | _ -> write_am), nat_sz)) ii) >>! v_expect) let build_cond e ii = let open Op in let e = match e with | JavaBase.Op (_,_,_) -> e | _ -> JavaBase.Op (Ne,e,Java.Const 0) in build_semantics_expr false e ii let rec build_semantics test ii : (A.program_order_index * B.t) M.t = let ii = {ii with A.program_order_index = A.next_po_index ii.A.program_order_index} in match ii.A.inst with | JavaBase.StoreReg (reg, exp) -> ( (build_semantics_expr true exp ii) >>= (fun v -> write_reg reg v ii) >>= (fun _ -> M.unitT (ii.A.program_order_index, B.Next []))) | JavaBase.StoreMem (vh, am, e) -> ( (read_reg false vh ii) >>| (build_semantics_expr true e ii) >>= (fun (l, v) -> write_mem am l v ii) >>= (fun _ -> M.unitT (ii.A.program_order_index, B.Next []))) | JavaBase.If (grd, thn, Some e) -> ( build_cond grd ii >>>> fun ret -> let ii' = { ii with A.program_order_index = A.next_po_index ii.A.program_order_index; } in let then_branch = build_semantics test {ii' with A.inst = thn} in let else_branch = build_semantics test {ii' with A.inst = e} in M.choiceT ret then_branch else_branch ) | JavaBase.If (grd, thn, None) -> ( build_cond grd ii >>>> fun ret -> let ii' = { ii with A.program_order_index = A.next_po_index ii.A.program_order_index; } in let then_branch = build_semantics test {ii' with A.inst = thn} in M.choiceT ret then_branch (build_semantics_list test [] ii) ) | JavaBase.Seq ins_lst -> build_semantics_list test ins_lst ii | JavaBase.Fence mo -> M.mk_fence (Act.Fence mo) ii >>= fun _ -> M.unitT (ii.A.program_order_index, B.Next []) | _ -> assert false (* others are not implemented yet *) and build_semantics_list test insts ii = match insts with | [] -> M.unitT (ii.A.program_order_index, B.Next []) | hd :: tl -> let ii = {ii with A.inst = hd; } in (build_semantics test ii) >>> fun (prog_order, _branch) -> build_semantics_list test tl {ii with A.program_order_index = prog_order;} let spurious_setaf _ = assert false end end herd-herdtools7-1ca343e/herd/LISAParseTest.ml000066400000000000000000000046501475314470400210060ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make(Conf:RunTest.Config)(ModelConfig:BellMem.Config) = struct module LexConfig = struct let debug = Conf.debug.Debug_herd.lexer end module ArchConfig = SemExtra.ConfigToArchConfig(Conf) module LISAValue = Int64Value.Make(BellBase.Instr) module Bell = BellArch_herd.Make(ArchConfig)(LISAValue) module BellLexParse = struct type instruction = Bell.parsedPseudo type token = LISAParser.token module Lexer = BellLexer.Make(LexConfig) let lexer = Lexer.token let parser = LISAParser.main end module BellS = BellSem.Make(Conf)(LISAValue) module BellM = BellMem.Make(ModelConfig)(BellS) module BellC = BellCheck.Make (struct let debug = Conf.debug.Debug_herd.barrier let compat = Conf.variant Variant.BackCompat end) (Bell) (struct let info = Misc.snd_opt Conf.bell_model_info let get_id_and_list = Bell.get_id_and_list let set_list = Bell.set_list let tr_compat = Bell.tr_compat end) module P = struct module P = GenParser.Make (Conf) (Bell) (BellLexParse) type pseudo = P.pseudo let parse chan splitted = BellC.check (P.parse chan splitted) end module X = RunTest.Make (BellS) (P) (BellM) (Conf) let run = X.run end herd-herdtools7-1ca343e/herd/LISAParseTest.mli000066400000000000000000000024501475314470400211530ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make : functor(Conf:RunTest.Config) -> functor(ModelConfig:BellMem.Config) -> sig val run : RunTest.runfun end herd-herdtools7-1ca343e/herd/MIPSArch_herd.ml000066400000000000000000000054571475314470400210010ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2014-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Define MIPS architecture *) module Make (C:Arch_herd.Config) (V:Value.S with type Cst.Instr.t = MIPSBase.instruction ) = struct include MIPSBase let is_amo _ = false let pp_barrier_short = pp_barrier let reject_mixed = false type lannot = bool (* atomicity *) let get_machsize _ = V.Cst.Scalar.machsize let empty_annot = false let is_atomic annot = annot let ifetch_value_sets = [] let barrier_sets = ["SYNC",(function Sync -> true);] let cmo_sets = [] let annot_sets = ["X", is_atomic] include Explicit.No include PteValSets.No let is_isync _ = false let pp_isync = "???" let pp_annot annot = if annot then "*" else "" module V = V (* Technically wrong, but it does not matter as there is no mixed-size *) let mem_access_size _ = None include NoSemEnv include NoLevelNorTLBI include ArchExtra_herd.Make(C) (struct module V = V let endian = endian type arch_reg = reg let pp_reg = pp_reg let reg_compare = reg_compare let fromto_of_instr _ = None let get_val _ v = v module FaultType=FaultType.No end) module MemType=MemoryType.No module NoConf = struct type v = V.v type loc = location type value_set = V.ValueSet.t type solution = V.solution type arch_lannot = lannot type arch_explicit = explicit end module ArchAction = ArchAction.No(NoConf) module Barrier = struct type a = barrier let a_to_b = function | Sync -> AllBarrier.SYNC let pp_isync = "???" end module CMO = Cmo.No end herd-herdtools7-1ca343e/herd/MIPSParseTest.ml000066400000000000000000000036711475314470400210300ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make(Conf:RunTest.Config)(ModelConfig:MemWithCav12.Config) = struct module LexConfig = struct let debug = Conf.debug.Debug_herd.lexer end module ArchConfig = SemExtra.ConfigToArchConfig(Conf) module MIPSValue = Int64Value.Make(MIPSBase.Instr) module MIPS = MIPSArch_herd.Make(ArchConfig)(MIPSValue) module MIPSLexParse = struct type instruction = MIPS.pseudo type token = MIPSParser.token module Lexer = MIPSLexer.Make(LexConfig) let lexer = Lexer.token let parser = MiscParser.mach2generic MIPSParser.main end module MIPSS = MIPSSem.Make(Conf)(MIPSValue) module MIPSM = MemWithCav12.Make(ModelConfig)(MIPSS) module P = GenParser.Make (Conf) (MIPS) (MIPSLexParse) module X = RunTest.Make (MIPSS) (P) (MIPSM) (Conf) let run = X.run end herd-herdtools7-1ca343e/herd/MIPSParseTest.mli000066400000000000000000000024551475314470400212000ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make : functor(Conf:RunTest.Config) -> functor(ModelConfig:MemWithCav12.Config) -> sig val run : RunTest.runfun end herd-herdtools7-1ca343e/herd/MIPSSem.ml000066400000000000000000000243071475314470400176410ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2014-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Semantics of MIPS instructions *) module Make (C:Sem.Config) (V:Value.S with type Cst.Instr.t = MIPSBase.instruction) = struct module MIPS = MIPSArch_herd.Make(SemExtra.ConfigToArchConfig(C))(V) module Act = MachAction.Make(C.PC)(MIPS) include SemExtra.Make(C)(MIPS)(Act) (* Barrier pretty print *) let sync = {barrier=MIPS.Sync; pp="sync";} let barriers = [sync;] let isync = None let nat_sz =V.Cst.Scalar.machsize let atomic_pair_allowed _ _ = true (********************) (* Semantics proper *) (********************) module Mixed(SZ:ByteSize.S) = struct let (>>=) = M.(>>=) let (>>*=) = M.(>>*=) let (>>|) = M.(>>|) let (>>!) = M.(>>!) let (>>::) = M.(>>::) let tr_op = function | MIPS.ADD|MIPS.ADDU|MIPS.DADDU -> Op.Add (* NB confusing ADD and ADDU... *) | MIPS.SUB|MIPS.SUBU -> Op.Sub (* NB confusing SUB and SUBU... *) | MIPS.SLT|MIPS.SLTU -> Op.Lt (* NB confusing SLT and SLTU... *) | MIPS.AND -> Op.And | MIPS.OR -> Op.Or | MIPS.XOR -> Op.Xor | MIPS.NOR -> Op.Nor | MIPS.DSLL -> Op.ShiftLeft let mk_read sz ato loc v = Act.Access (Dir.R, loc, v, ato, (), sz, Act.access_of_location_std loc) let read_reg is_data r ii = match r with | MIPS.IReg MIPS.R0 -> M.unitT V.zero | _ -> M.read_loc is_data (mk_read nat_sz false) (A.Location_reg (ii.A.proc,r)) ii let read_reg_ord = read_reg false let read_reg_data = read_reg true let do_read_mem sz ato a ii = M.read_loc false (mk_read sz ato) (A.Location_global a) ii let read_mem sz a ii = do_read_mem sz false a ii let read_mem_atomic sz a ii = do_read_mem sz true a ii let write_reg r v ii = match r with | MIPS.IReg MIPS.R0 -> M.unitT () | _ -> M.mk_singleton_es (Act.Access (Dir.W, (A.Location_reg (ii.A.proc,r)), v, false, (), nat_sz, Access.REG)) ii let write_mem sz a v ii = M.mk_singleton_es (Act.Access (Dir.W, A.Location_global a, v, false, (), sz, Access.VIR)) ii let write_mem_atomic sz a v resa ii = let eq = [M.VC.Assign (a,M.VC.Atom resa)] in M.mk_singleton_es_eq (Act.Access (Dir.W, A.Location_global a, v, true, (), sz, Access.VIR)) eq ii let create_barrier b ii = M.mk_singleton_es (Act.Barrier b) ii let commit ii = M.mk_singleton_es (Act.Commit (Act.Bcc,None)) ii let v2tgt = let open Constant in function | M.A.V.Val(Label (_, lbl)) -> Some (B.Lbl lbl) | M.A.V.Val (Concrete i) -> Some (B.Addr (M.A.V.Cst.Scalar.to_int i)) | _ -> None let do_indirect_jump test bds i v = match v2tgt v with | Some tgt -> M.unitT (B.Jump (tgt,bds)) | None -> match v with | M.A.V.Var(_) as v -> let lbls = get_exported_labels test in if Label.Full.Set.is_empty lbls && C.variant Variant.Telechat then (* We assume a ret/branch is an exit *) M.unitT () >>! B.Exit else if Label.Full.Set.is_empty lbls then Warn.fatal "Could find no potential target for indirect branch %s \ (potential targets are statically known labels)" (MIPS.dump_instruction i) else B.indirectBranchT v lbls bds | _ -> Warn.fatal "illegal argument for the indirect branch instruction %s \ (must be a label)" (MIPS.dump_instruction i) (* Promote 16bit immediates to values *) (* Signed *) let imm16ToV k = V.Cst.Scalar.of_int (k land 0xffff) |> V.Cst.Scalar.sxt MachSize.Short |> fun sc -> V.Val (Constant.Concrete sc) (* Unsigned *) let immu16ToV k = V.Cst.Scalar.of_int (k land 0xffff) |> fun sc -> V.Val (Constant.Concrete sc) let is_logical = let open MIPS in function | ADD|ADDU|DADDU | SUB|SUBU | SLT|SLTU -> false | OR|AND|XOR|NOR|DSLL -> true let imm16 op = if is_logical op then immu16ToV else imm16ToV (* Entry point *) let build_semantics test ii = M.addT (A.next_po_index ii.A.program_order_index) begin match ii.A.inst with | MIPS.NOP -> B.nextT | MIPS.LUI (r1,k) -> M.op Op.ShiftLeft (V.intToV k) (V.intToV 16) >>= M.op1 (Op.Sxt MachSize.Word) >>= fun v -> write_reg r1 v ii >>= B.next1T | MIPS.LI (r,k) -> write_reg r (immu16ToV k) ii >>= B.next1T | MIPS.MOVE (r1,r2) -> read_reg_data r2 ii >>= fun v -> write_reg r1 v ii >>= B.next1T | MIPS.OP (op,r1,r2,r3) -> (read_reg_ord r2 ii >>| read_reg_ord r3 ii) >>= (fun (v1,v2) -> M.op (tr_op op) v1 v2) >>= (fun v -> write_reg r1 v ii) >>= B.next1T | MIPS.OPI (MIPS.DSLL,r1,r2,k) -> read_reg_ord r2 ii >>= M.op1 (Op.LeftShift k) >>= fun v -> write_reg r1 v ii >>= B.next1T | MIPS.OPI (op,r1,r2,k) -> read_reg_ord r2 ii >>= fun v -> M.op (tr_op op) v (imm16 op k) >>= fun v -> write_reg r1 v ii >>= B.next1T | MIPS.JR (MIPS.IReg MIPS.R31) when C.variant Variant.Telechat -> (* Telechat return *) M.unitT B.Exit | MIPS.JR r as t -> read_reg_ord r ii >>= do_indirect_jump test [] t | MIPS.B lbl -> B.branchT lbl | MIPS.BC (cond,r1,r2,lbl) -> (read_reg_ord r1 ii >>| read_reg_ord r2 ii) >>= (fun (v1,v2) -> M.op (match cond with MIPS.EQ -> Op.Eq | MIPS.NE -> Op.Ne) v1 v2) >>= fun v -> commit ii >>= fun () -> B.bccT v lbl | MIPS.BCZ (cond,r,lbl) -> read_reg_ord r ii >>= fun v -> M.op (match cond with | MIPS.LEZ -> Op.Le | MIPS.GTZ -> Op.Gt | MIPS.LTZ -> Op.Lt | MIPS.GEZ -> Op.Ge) v V.zero >>= fun v -> commit ii >>= fun () -> B.bccT v lbl | MIPS.LW (r1,k,r2) -> let sz = MachSize.Word in read_reg_ord r2 ii >>= (fun a -> M.add a (imm16ToV k)) >>= (fun ea -> read_mem sz ea ii) >>= M.op1 (Op.Sxt sz) >>= (fun v -> write_reg r1 v ii) >>= B.next1T | MIPS.LD (r1,k,r2) -> read_reg_ord r2 ii >>= (fun a -> M.add a (imm16ToV k)) >>= (fun ea -> read_mem MachSize.Quad ea ii) >>= (fun v -> write_reg r1 v ii) >>= B.next1T | MIPS.SW (r1,k,r2) -> (read_reg_data r1 ii >>| read_reg_ord r2 ii) >>= (fun (d,a) -> (M.add a (imm16ToV k)) >>= (fun ea -> write_mem nat_sz ea d ii)) >>= B.next1T | MIPS.LL (r1,k,r2) -> read_reg_ord r2 ii >>= (fun a -> (M.add a (imm16ToV k) >>= (fun ea -> write_reg MIPS.RESADDR ea ii >>| (read_mem_atomic nat_sz ea ii >>= fun v -> write_reg r1 v ii)))) >>= B.next2T | MIPS.SC (r1,k,r2) -> (read_reg_ord MIPS.RESADDR ii >>| read_reg_data r1 ii >>| read_reg_ord r2 ii) >>= (fun ((resa,v),a) -> M.add a (imm16ToV k) >>= (fun ea -> write_reg MIPS.RESADDR V.zero ii >>| (* Cancel reservation... *) M.altT (write_reg r1 V.zero ii) (* Failure *) ((write_reg r1 V.one ii >>| write_mem_atomic nat_sz ea v resa ii) >>! ()))) >>= B.next2T | MIPS.EBF (r1,r2,k1,k2) -> let lsb = k1 in let msbd = k2 - 1 in let hex_mask = begin (* similar to UBFM/SBFM in AArch64*) let f x = if x < lsb then "0" else if x > lsb+msbd then "0" else "1" in let bitmask = List.rev (List.init 64 f) in let dec_mask = Int64.of_string (Printf.sprintf "0b%s" (String.concat "" bitmask)) in Printf.sprintf "0x%Lx" dec_mask end in read_reg_data r2 ii >>= M.op1 (Op.AndK hex_mask) >>= M.op1 (Op.LogicalRightShift lsb) >>= fun v -> write_reg r1 v ii >>= B.next1T | MIPS.SYNC -> create_barrier MIPS.Sync ii >>= B.next1T end let spurious_setaf _ = assert false end end herd-herdtools7-1ca343e/herd/MemCat.ml000066400000000000000000000036241475314470400175710ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2022-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Simple entry to models: cat models only *) module type Config = sig val model : Model.t val bell_model_info : (string * BellModel.info) option include Model.Config end module Make (O:Config) (S:Sem.Semantics) : XXXMem.S with module S = S = struct open Model module S = S let model = O.model let check_event_structure test = match O.model with | Generic (fname,m) -> let module X = MachModelChecker.Make (struct let fname = fname let m = m let wide_po = false include O end)(S) in X.check_event_structure test | _ -> failwith "This architecture accepts cat models only." end herd-herdtools7-1ca343e/herd/MemWithCav12.ml000066400000000000000000000041631475314470400205710ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2022-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Entry to models for arch that support the CAV12 model *) module type Config = sig val model : Model.t include Model.Config end module Make (O:Config) (S:Sem.Semantics) : XXXMem.S with module S = S = struct open Model module S = S let model = O.model module ModelConfig = (O : Model.Config) let check_event_structure test = match O.model with | CAV12 opt -> let module X = CAV12.Make (struct let opt = opt include ModelConfig end) (S) in X.check_event_structure test | Generic (fname,m) -> let module X = MachModelChecker.Make (struct let fname = fname let m = m let bell_model_info = None let wide_po = false include ModelConfig end)(S) in X.check_event_structure test | File _ -> assert false end herd-herdtools7-1ca343e/herd/PPCArch_herd.ml000066400000000000000000000074011475314470400206420ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Define PPC architecture *) module Make (C:Arch_herd.Config) (V:Value.S) = struct include PPCBase let is_amo _ = false let pp_barrier_short = pp_barrier let reject_mixed = false type lannot = bool (* atomicity *) let get_machsize _ = V.Cst.Scalar.machsize let empty_annot = false let is_atomic annot = annot let is_barrier b1 b2 = barrier_compare b1 b2 = 0 let ifetch_value_sets = [] let barrier_sets = [ "SYNC",is_barrier Sync; "ISYNC",is_barrier Isync; "LWSYNC",is_barrier Lwsync; "EIEIO",is_barrier Eieio; ] let cmo_sets = [] let annot_sets = ["X",is_atomic] let is_isync = is_barrier Isync let pp_isync = "isync" let pp_annot annot = if annot then "*" else "" include Explicit.No include PteValSets.No (* Now global locations, that include reservations *) module V = V let mem_access_size = function | Pnop | Padd _ | Psub _ | Psubf _ | Por _ | Pand _ | Pxor _ | Pmull _ | Pdiv _ | Paddi _ | Paddis _ | Pori _ | Pandi _ | Pxori _ | Pmulli _ | Prlwinm _ | Prlwimi _ | Pclrldi _ | Pli _ | Pb _ | Pbcc _ | Pcmpwi _ | Pcmpw _ | Plis _ | Pmr _ | Psync | Peieio | Pisync | Plwsync | Pcmplwi _ | Pextsw _ | Pdcbf _ | Pblr | Pnor _ | Pneg _ | Pslw _ | Psrawi _| Psraw _ | Pbl _ | Pmtlr _ | Pmflr _ | Pmfcr _ | Plmw _ | Pstmw _ | Pcomment _ -> None | Plwzu _ | Plwa _ | Pstwu _ | Plwarx _ | Pstwcx _ -> Some MachSize.Word | Pload (sz,_,_,_) | Ploadx (sz,_,_,_) | Plwax (sz,_,_,_) | Pstore (sz,_,_,_) | Pstorex (sz,_,_,_) -> Some sz include NoSemEnv include NoLevelNorTLBI include ArchExtra_herd.Make(C) (struct module V = V let endian = endian type arch_reg = reg let pp_reg = pp_reg let reg_compare = reg_compare let fromto_of_instr _ = None let get_val _ v = v module FaultType=FaultType.No end) module MemType=MemoryType.No module NoConf = struct type v = V.v type loc = location type value_set = V.ValueSet.t type solution = V.solution type arch_lannot = lannot type arch_explicit = explicit end module ArchAction = ArchAction.No(NoConf) module Barrier = struct type a = barrier let a_to_b a = let open AllBarrier in match a with | Sync -> SYNC | Lwsync -> LWSYNC | Isync -> ISYNC | Eieio -> EIEIO let pp_isync = "isync" end module CMO = Cmo.No end herd-herdtools7-1ca343e/herd/PPCParseTest.ml000066400000000000000000000036531475314470400207020ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make(Conf:RunTest.Config)(ModelConfig:MemWithCav12.Config) = struct module LexConfig = struct let debug = Conf.debug.Debug_herd.lexer end module ArchConfig = SemExtra.ConfigToArchConfig(Conf) module PPCValue = Int64Value.Make(PPCBase.Instr) module PPC = PPCArch_herd.Make(ArchConfig)(PPCValue) module PPCLexParse = struct type instruction = PPC.parsedPseudo type token = PPCParser.token module Lexer = PPCLexer.Make(LexConfig) let lexer = Lexer.token let parser = MiscParser.mach2generic PPCParser.main end module PPCS = PPCSem.Make(Conf)(PPCValue) module PPCM = MemWithCav12.Make(ModelConfig)(PPCS) module P = GenParser.Make (Conf) (PPC) (PPCLexParse) module X = RunTest.Make (PPCS) (P) (PPCM) (Conf) let run = X.run end herd-herdtools7-1ca343e/herd/PPCParseTest.mli000066400000000000000000000024431475314470400210470ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make : functor(Conf:RunTest.Config) -> functor(ModelConfig:MemWithCav12.Config) -> sig val run : RunTest.runfun end herd-herdtools7-1ca343e/herd/PPCSem.ml000066400000000000000000000434441475314470400175160ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Semantics of PPC instructions *) module Make (C:Sem.Config) (V:Value.S with type Cst.Instr.t = PPCBase.instruction) = struct open MachSize module PPC = PPCArch_herd.Make(SemExtra.ConfigToArchConfig(C))(V) module Act = MachAction.Make(C.PC)(PPC) include SemExtra.Make(C)(PPC)(Act) let mixed = PPC.is_mixed (* barrier pretty print *) let sync = {barrier=PPC.Sync; pp="sync";} let lwsync = {barrier=PPC.Lwsync; pp="lwsync";} let eieio = {barrier=PPC.Eieio; pp="eieio";} let barriers = [sync;lwsync;eieio;] let isync = Some {barrier=PPC.Isync; pp="isync";} let nat_sz = V.Cst.Scalar.machsize let atomic_pair_allowed _ _ = true let () = assert (nat_sz = MachSize.Quad) (****************************) (* Build semantics function *) (****************************) module Mixed(SZ : ByteSize.S) = struct module Mixed = M.Mixed(SZ) let (>>=) = M.(>>=) let (>>*=) = M.(>>*=) let (>>|) = M.(>>|) let (>>::) = M.(>>::) let (>>!) = M.(>>!) let mk_read sz ato loc v = let ac = Act.access_of_location_std loc in Act.Access (Dir.R, loc, v, ato, (), sz, ac) let read_reg is_data r ii = M.read_loc is_data (mk_read nat_sz false) (A.Location_reg (ii.A.proc,r)) ii let read_reg_data = read_reg true and read_reg_ord = read_reg false let do_read_mem sz ato a ii = if mixed then Mixed.read_mixed false sz (fun sz -> mk_read sz ato) a ii else M.read_loc false (mk_read sz ato) (A.Location_global a) ii let read_mem sz a ii = do_read_mem sz false a ii let read_mem_atomic sz a ii = do_read_mem sz true a ii let write_loc sz loc v ii = let ac = Act.access_of_location_std loc in M.mk_singleton_es (Act.Access (Dir.W, loc, v, false, (), sz, ac)) ii let write_reg r v ii = M.mk_singleton_es (Act.Access (Dir.W, (A.Location_reg (ii.A.proc,r)), v, false, (), nat_sz,Access.REG)) ii let do_write_mem sz ato a v ii = if mixed then Mixed.write_mixed sz (fun sz loc v -> Act.Access (Dir.W, loc , v, ato, (), sz, Access.VIR)) a v ii else M.mk_singleton_es (Act.Access (Dir.W, A.Location_global a, v, ato, (), sz, Access.VIR)) ii let write_mem sz a v ii = do_write_mem sz false a v ii let write_mem_atomic sz a v ii = do_write_mem sz true a v ii let write_flag r o v1 v2 ii = M.addT (A.Location_reg (ii.A.proc,r)) (M.op o v1 v2) >>= (fun (loc,v) -> write_loc nat_sz loc v ii) let create_barrier b ii = M.mk_singleton_es (Act.Barrier b) ii let commit ii = M.mk_singleton_es (Act.Commit (Act.Bcc,None)) ii let write_addr a v ii = write_mem a v ii let write_addr_conditional sz a v rr ar ii = let eq = [M.VC.Assign (a, M.VC.Atom ar); M.VC.Assign (rr,M.VC.Atom V.one)] in M.mk_singleton_es_eq (Act.Access (Dir.W, A.Location_global a, v, true, (), sz, Access.VIR)) (* a rr ar *) eq ii let read_addr a ii = read_mem a ii let read_addr_res a ii = read_mem_atomic a ii let read_reg_or_zero is_data r ii = match r with | PPC.Ireg PPC.GPR0 -> M.unitT V.zero | _ -> read_reg is_data r ii (**********************) (* Condition register *) (**********************) let bit_lt = 0 and bit_gt = 1 and bit_eq = 2 let cr0 = PPC.CRField 0 (* ISA notation is 0 for high-order, sigh *) let caml_bitof bitidx = 3-bitidx and ppc_bitreg cr bit = PPC.CRBit (32+4*cr+bit) let read_flag cr bit ii = read_reg_ord (PPC.CRField cr) ii >>= M.op1 (Op.ReadBit (caml_bitof bit)) (* Set flags by comparing v1 v2 *) let mask bit = V.intToV (1 lsl (caml_bitof bit)) let ifT bit op v1 v2 k = (M.op op v1 v2 >>| k) >>= fun (vb,vk) -> M.op3 Op.If vb (mask bit) vk let write_cr cr v1 v2 ii = ifT bit_lt Op.Lt v1 v2 (ifT bit_gt Op.Gt v1 v2 (M.unitT (mask bit_eq))) >>= (* [not Lt /\ not Gt] => Eq *) fun v -> write_reg (PPC.CRField cr) v ii let flags with_flags cr v1 v2 ii = if with_flags then write_cr cr v1 v2 ii >>! () else M.unitT () (* sets the CR0[EQ] bit to veq *) let flags_res veq ii = let cr = 0 in write_reg (PPC.CRField cr) (if veq then mask bit_eq else V.zero) ii (* operations RD <- RA op RB *) let op3regs ii op set rD rA rB = let with_flags = match set with | PPC.SetCR0 -> true | PPC.DontSetCR0 -> false in let proc = ii.PPC.proc in ((read_reg_ord rA ii >>| read_reg_ord rB ii) >>= (fun (vA,vB) -> M.addT (PPC.Location_reg (proc,rD)) (M.op op vA vB) >>= (fun (l,v) -> write_loc nat_sz l v ii >>| flags with_flags 0 v V.zero ii))) >>= B.next2T (* operations RD <- RA op im *) let op2regi ii op with_flags rD rA im = let proc = ii.PPC.proc in (read_reg_ord rA ii >>= (fun vA -> M.addT (PPC.Location_reg (proc,rD)) (M.op op vA im) >>= (fun (l,v) -> write_loc nat_sz l v ii >>| flags with_flags 0 v V.zero ii))) >>= B.next2T let bcc_yes cr bit ii lbl = read_flag cr bit ii >>= fun v -> commit ii >>= fun () -> B.bccT v lbl let bcc_no cr bit ii lbl = read_flag cr bit ii >>= M.op1 Op.Not >>= fun v -> commit ii >>= fun () -> B.bccT v lbl (**********) (* Rotate *) (**********) let rot64 x n = let n = n mod 64 in begin M.op1 (Op.LeftShift n) x >>| M.op1 (Op.LogicalRightShift (63-n)) x end >>= fun (x,y) -> M.op Op.Or x y let rot32 x n = M.op1 (Op.Mask MachSize.Word) x >>= fun x -> M.op1 (Op.LeftShift 32) x >>= fun y -> M.op Op.Or x y >>= fun x -> rot64 x n (****************************) (* Mask auxiliary functions *) (****************************) let op_and_mask msk = M.op1 (Op.AndK ("0b" ^ msk)) let mask k1 k2 = let msk = if k1 <= k2 then let msk = Bytes.make 64 '0' in for k=k1 to k2 do Bytes.set msk k '1' done ; msk else let msk = Bytes.make 64 '1' in for k = k2+1 to k1-1 do Bytes.set msk k '0' done ; msk in Bytes.to_string msk let not_mask msk = let len = String.length msk in let r = Bytes.create len in for k=0 to len-1 do let c = match msk.[k] with | '0' -> '1' | '1' -> '0' | _ -> assert false in Bytes.set r k c done ; Bytes.to_string r let build_semantics _ ii = M.addT (A.next_po_index ii.A.program_order_index) begin match ii.A.inst with | PPC.Pnop -> B.nextT (* 3 regs ops *) | PPC.Padd (set,rD,rA,rB) -> op3regs ii Op.Add set rD rA rB | PPC.Psub (set,rD,rA,rB) -> op3regs ii Op.Sub set rD rA rB | PPC.Psubf (set,rD,rA,rB) -> op3regs ii Op.Sub set rD rB rA (* subtract from -> swap args *) | PPC.Por (set,rD,rA,rB) -> op3regs ii Op.Or set rD rA rB | PPC.Pand (set,rD,rA,rB) -> op3regs ii Op.And set rD rA rB | PPC.Pxor (set,rD,rA,rB) -> op3regs ii Op.Xor set rD rA rB | PPC.Pmull (set,rD,rA,rB) -> op3regs ii Op.Mul set rD rA rB | PPC.Pdiv (set,rD,rA,rB) -> op3regs ii Op.Div set rD rA rB (* A very specific 3 regs op *) | PPC.Pmr (rD,rS) -> let too_far = false in if too_far then (* Hum, maybe of an exageration, 2 read events, against one *) op3regs ii Op.Or PPC.DontSetCR0 rD rS rS else read_reg_ord rS ii >>= fun v -> write_reg rD v ii >>= B.next1T (* rotate instructions *) | PPC.Pextsw (rD,rA) -> read_reg_ord rA ii >>= M.op1 (Op.Sxt Word) >>= fun v -> write_reg rD v ii >>= B.next1T | PPC.Prlwinm (rD,rA,k1,k2,k3) -> (* rotate left word immediate and mask *) let m = mask (k2+32) (k3+32) in read_reg_ord rA ii >>= fun a -> rot32 a k1 >>= op_and_mask m >>= fun v -> write_reg rD v ii >>= B.next1T | PPC.Prlwimi (rD,rA,k1,k2,k3) -> (* rotate left word immediate mask insert*) let m = mask (k2+32) (k3+32) in let not_m = not_mask m in (read_reg_ord rD ii >>| read_reg_ord rA ii) >>= fun (d,a) -> rot32 a k1 >>= fun a -> op_and_mask m a >>| op_and_mask not_m d >>= fun (d,a) -> (* unlike RLWINM, this instruction preserves bits*) M.op Op.Or d a >>= fun v -> write_reg rD v ii >>= B.next1T | PPC.Pclrldi (rD,rA,k) -> (* create 1 mask from 0-(k-1), 0 mask for the rest *) (* AND with contents of rA, store in rD *) let m = mask k 63 in read_reg_ord rA ii >>= op_and_mask m >>= fun v -> (* unlike RLWINM, this instruction preserves bits*) (* We can simply OR (shifted rA) and (masked rD) *) write_reg rD v ii >>= B.next1T (* 2 reg + immediate *) | PPC.Plis (rD,v) -> M.op Op.ShiftLeft (V.intToV v) (V.intToV 16) >>= fun v -> write_reg rD v ii >>= B.next1T | PPC.Pli (rD,v) | PPC.Paddi (rD,PPC.Ireg (PPC.GPR0),v) -> (* Believe it or not Power ISA, p. 62 says so, In addi r,GPR0,v GPR0 is interpreted as constant 0 ! *) write_reg rD (V.intToV v) ii >>= B.next1T | PPC.Paddi (rD,rA,simm) -> op2regi ii Op.Add false rD rA (V.intToV simm) | PPC.Paddis (rD,PPC.Ireg PPC.GPR0,simm) -> write_reg rD (V.intToV (simm lsl 16)) ii >>= B.next1T | PPC.Paddis (rD,rA,simm) -> op2regi ii Op.Add false rD rA (V.intToV (simm lsl 16)) | PPC.Pori (rD,rA,simm) -> op2regi ii Op.Or false rD rA (V.intToV simm) | PPC.Pxori (rD,rA,simm) -> op2regi ii Op.Xor false rD rA (V.intToV simm) | PPC.Pandi (rD,rA,simm) -> (* ISA p. 75: CR0 is set *) op2regi ii Op.And true rD rA (V.intToV simm) | PPC.Pmulli (rD,rA,simm) -> op2regi ii Op.Mul false rD rA (V.intToV simm) (* Branch *) | PPC.Pb lbl -> B.branchT lbl (* Conditional branches, over cr0 only *) | PPC.Pbcc(PPC.Lt,lbl) -> bcc_yes 0 bit_lt ii lbl | PPC.Pbcc(PPC.Ge,lbl) -> bcc_no 0 bit_lt ii lbl | PPC.Pbcc(PPC.Gt,lbl) -> bcc_yes 0 bit_gt ii lbl | PPC.Pbcc(PPC.Le,lbl) -> bcc_no 0 bit_gt ii lbl | PPC.Pbcc(PPC.Eq,lbl) -> bcc_yes 0 bit_eq ii lbl | PPC.Pbcc(PPC.Ne,lbl) -> bcc_no 0 bit_eq ii lbl | PPC.Pblr when C.variant Variant.Telechat -> (* We assume a jump to the callee*) (* in the link register is an exit from the program*) M.unitT () >>! B.Exit (* Compare, to result in any cr *) | PPC.Pcmpwi (cr,rA,v) -> read_reg_ord rA ii >>= fun vA -> flags true cr vA (V.intToV v) ii >>= B.next1T | PPC.Pcmpw (cr,rA,rB) -> (read_reg_ord rA ii >>| read_reg_ord rB ii) >>= fun (vA,vB) -> flags true cr vA vB ii >>= B.next1T | PPC.Pcmplwi (cr,rA,v) -> (read_reg_ord rA ii) >>= M.op1 (Op.Mask MachSize.Word) >>= fun vA -> flags true cr vA (V.intToV (v land 0xffff)) ii >>= B.next1T | PPC.Pmfcr rA -> read_reg_ord (PPC.CRField 0) ii >>= fun v -> write_reg rA v ii >>= B.next1T (* memory loads/stores *) | PPC.Pload(sz,rD,d,rA) -> read_reg_ord rA ii >>= fun aA -> M.add aA (V.intToV d) >>= fun a -> read_addr sz a ii >>= fun v -> write_reg rD v ii >>= B.next1T | PPC.Plwa(rD,d,rA) -> read_reg_ord rA ii >>= fun aA -> M.add aA (V.intToV d) >>= fun a -> read_addr Word a ii >>= M.op1 (Op.Sxt Word) >>= fun v -> write_reg rD v ii >>= B.next1T | PPC.Plwzu (rD,d,rA) -> read_reg_ord rA ii >>= fun aA -> M.add aA (V.intToV d) >>= (fun a -> let load = read_addr Word a ii >>= fun v -> write_reg rD v ii in if rA <> PPC.r0 && rA <> rD then (write_reg rA a ii >>| load) >>= B.next2T else load >>= B.next1T) | PPC.Plwax(sz,rD,rA,rB) | PPC.Ploadx(sz,rD,rA,rB) as i -> (read_reg_or_zero false rA ii >>| read_reg_ord rB ii) >>= fun (aA,aB) -> M.add aA aB >>= fun a -> read_addr sz a ii >>= (match i with | PPC.Plwax _ -> M.op1 (Op.Sxt sz) | _ -> M.unitT) >>= fun v -> write_reg rD v ii >>= B.next1T | PPC.Pstore(sz,rS,d,rA) -> (read_reg_data rS ii >>| read_reg_ord rA ii) >>= (fun (vS,aA) -> M.add aA (V.intToV d) >>= fun a -> write_addr sz a vS ii >>= B.next1T) | PPC.Pstwu(rS,d,rA) -> if rA <> PPC.r0 then M.stu (read_reg_data rS ii) (read_reg_ord rA ii >>= fun a -> M.add a (V.intToV d)) (fun a -> write_reg rA a ii) (fun (vS,a) -> write_addr Word a vS ii) >>= B.next1T else (read_reg_data rS ii >>| read_reg_ord rA ii) >>= (fun (vS,aA) -> M.add aA (V.intToV d) >>= fun a -> write_addr Word a vS ii >>= B.next1T) | PPC.Pstorex(sz,rS,rA,rB) -> (read_reg_data rS ii >>| (* Enforce right associativity of >>| *) (read_reg_or_zero false rA ii >>| read_reg_ord rB ii)) >>= (fun (vS,(aA,aB)) -> M.add aA aB >>= fun a -> write_addr sz a vS ii >>= B.next1T) | PPC.Plwarx(rD,rA,rB) -> (read_reg_or_zero false rA ii >>| read_reg_ord rB ii) >>= fun (aA,aB) -> M.add aA aB >>= (fun a -> write_reg PPC.RES V.one ii >>| write_reg PPC.RESADDR a ii >>| (read_addr_res Word a ii >>= fun v -> write_reg rD v ii)) >>= fun (((),()),()) -> B.nextT | PPC.Pstwcx(rS,rA,rB) -> ((read_reg_data rS ii >>| read_reg_data PPC.RES ii >>| read_reg_data PPC.RESADDR ii) >>| (* Enforce right associativity of >>| *) (read_reg_or_zero false rA ii >>| read_reg_ord rB ii)) >>= fun (((vS,vR),aR),(aA,aB)) -> M.add aA aB >>= fun a -> M.altT ((write_reg PPC.RES V.zero ii >>| flags_res false ii) >>= B.next2T) (write_reg PPC.RES V.zero ii >>| (write_addr_conditional Word a vS vR aR ii >>| flags_res true ii) >>= fun ((),((),())) -> B.nextT) |PPC.Peieio -> create_barrier PPC.Eieio ii >>= B.next1T |PPC.Psync -> create_barrier PPC.Sync ii >>= B.next1T |PPC.Plwsync -> create_barrier PPC.Lwsync ii >>= B.next1T |PPC.Pisync -> create_barrier PPC.Isync ii >>= B.next1T |PPC.Pdcbf (_rA,_rB) -> B.nextT | PPC.Pcomment _ -> Warn.warn_always "Instruction %s interpreted as a NOP" (PPC.dump_instruction ii.A.inst); B.nextT | PPC.Pnor (_, _, _, _) | PPC.Pneg (_, _, _) | PPC.Pslw (_, _, _, _) | PPC.Psrawi (_, _, _, _) | PPC.Psraw (_, _, _, _) | PPC.Pbl _ | PPC.Pmtlr _ | PPC.Pmflr _ | PPC.Pstmw _ | PPC.Plmw _ | PPC.Pblr -> Warn.fatal "Instruction %s not implemented" (PPC.dump_instruction ii.A.inst) end let spurious_setaf _ = assert false end end herd-herdtools7-1ca343e/herd/Pretty.ml000066400000000000000000001401771475314470400177170ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Producing .dot output *) open Test_herd open Printf module type S = sig module S : SemExtra.S open S val init_pretty : unit -> unit val pp_no_solutions : out_channel -> S.test -> string -> unit (* Standard dump (to dot file) just_dump chan test es rfm rels vos. - chan is output channel - es is event_structure (includes intra_causality and atomicity) - legend is a legend. - rels is a list of (tags,relation) to be pictured tag will label the edges *) val dump_legend : out_channel ->S.test -> string -> S.concrete -> ?sets : S.set_pp -> S.rel_pp -> unit (* Simpler function, just to dump event structures with and without rfmaps *) val dump_es : out_channel -> test -> event_structure -> unit val dump_es_rfm : out_channel -> test -> event_structure -> rfmap -> unit (************************************) (* Show feature: pop up a gv window *) (************************************) val show_es_rfm : test -> event_structure -> rfmap -> unit val show_legend : S.test -> string -> S.concrete -> ?sets : S.set_pp -> S.rel_pp -> unit end module Make (S:SemExtra.S) : S with module S = S = struct module S = S module A = S.A module E = S.E module PC = S.O.PC let dbg = false let pc_symetric = StringSet.union PC.symetric PC.noid (* One init *) let one_init = match PC.graph with | Graph.Columns -> PC.oneinit | Graph.Free|Graph.Cluster -> false (* Attempt *) let _reduces_more r1 r2 = let open E.EventRel in filter (fun (e1,_e2) -> not (E.EventSet.is_empty (succs r2 e1)) && not (E.EventSet.is_empty (preds r2 e1))) r1 open PrettyConf open PPMode let show_all_events = match PC.showevents with | AllEvents -> true | MemEvents|NonRegEvents|MemFenceEvents -> false (* Printing the program with the nice_prog field *) (* Please avoid insterting references to Global in, for instance X86Base.ml, since this source file is shared with litmus.new & gen.new, It is nicer if TeX processing belongs to this module, Pretty *) (* partial escaping of strings into legal tex command identifiers *) let escape_tex s = let buff = Buffer.create 16 in for k=0 to String.length s-1 do let c = s.[k] in begin match c with | '_' -> Buffer.add_char buff '\\' | _ -> () end ; Buffer.add_char buff c done ; Buffer.contents buff let escape_dot s = let buff = Buffer.create 16 in for k=0 to String.length s-1 do let c = s.[k] in begin match c with | '\\'|'"' -> Buffer.add_char buff '\\' | _ -> () end ; Buffer.add_char buff c done ; Buffer.contents buff let escape_html s = let buff = Buffer.create 16 in for k=0 to String.length s-1 do let c = s.[k] in begin match c with | '<' -> Buffer.add_string buff "<" | '>' -> Buffer.add_string buff ">" | '&' -> Buffer.add_string buff "&er;" | _ -> Buffer.add_char buff c end done ; Buffer.contents buff let escape_label dm = match dm with | Plain -> escape_dot | Fig -> (fun s -> escape_dot (escape_tex s)) let a_pp_instruction dm m i = let bodytext = A.pp_instruction m i in let pp = if PC.texmacros then "\\asm{" ^ bodytext ^ "}" else bodytext in escape_label dm pp (* Pretty printing and display *) let pp_color chan color = if not PC.mono then fprintf chan "[color=%s]" color (* dot pretty printing *) let pp_no_solutions chan test msg = let legend = escape_dot(readable_name test) ^ ": " ^ test.Test_herd.name.Name.doc in fprintf chan "digraph G {\n\n" ; fprintf chan "/* legend */\n" ; fprintf chan "label=\"%s\" ; \n\n" legend ; fprintf chan "no_solns [shape=box] %a" pp_color "red" ; fprintf chan "[label=\" %s\\l\"]\n}\n" msg let pp_instruction dm m chan iiid = match iiid with | E.IdInit -> fprintf chan "Init" | E.IdSpurious -> fprintf chan "Spurious" | E.IdSome iiid -> let instruction = iiid.A.inst in fprintf chan "%s" (a_pp_instruction dm m instruction) let extra_thick = "setlinewidth(3)" (* Scales that depend upon font size *) let pt2inch f = f /. 72.0 let defaultpenwidth = 1.0 let scalepenwidth = match PC.penwidth with | Some f -> fun x -> ((x *. f) /. defaultpenwidth) | None -> fun x -> x let defaultfontsize = 14.0 let dsize = defaultfontsize /. 72.0 let fscale = match PC.fontsize with | None -> 1.0 | Some f -> float_of_int f /. defaultfontsize (* let condensednode = sprintf "[fixedsize=\"true\"][width=\"%f\"][height=\"%f\"]" (fscale *.0.4) (fscale *. 0.1) *) let pp_po_edge = PC.showpo let do_pp_fontsize sep chan = match PC.fontsize with | None -> () | Some f -> fprintf chan "%c fontsize=%i" sep f let pp_fontsize = do_pp_fontsize ',' let do_pp_fontsize_edge sep chan = match PC.fontsize with | None -> () | Some f -> fprintf chan "%c fontsize=%i" sep (f+PC.edgedelta) let pp_fontsize_edge = do_pp_fontsize_edge ',' let pp_penwidth chan = match PC.penwidth with | Some f -> fprintf chan ", penwidth=\"%f\"" f | None -> () let pp_arrowsize chan = match PC.arrowsize with | Some f -> fprintf chan ", arrowsize=\"%f\"" f | None -> () (* Edges attributes as a function of label, or of prefix label.... *) type edge_attr = { color:string ; style:string ; } let ea_t = Hashtbl.create 17 let def_ea = {color="black" ; style="" } let add_ea key a1 a2 = Hashtbl.add ea_t key (a1,a2) let add_eas lbls a1 a2 = List.iter (fun lbl -> add_ea lbl a1 a2) lbls let relabel_t = Hashtbl.create 17 let merge_labels2 lbl lbl2 nlbl = Hashtbl.add relabel_t lbl nlbl ; Hashtbl.add relabel_t lbl2 nlbl let merge_labels lbl lbl2 = let nlbl = sprintf "%s/%s" lbl lbl2 in merge_labels2 lbl lbl2 nlbl let relabel lbl = try Hashtbl.find relabel_t lbl with Not_found -> lbl let init_pretty () = (* Relabeling *) if PC.relabel then begin merge_labels "dmb" "sync" ; merge_labels "isb" "isync" ; merge_labels2 "ctrlisb" "ctrlisync" "ctrlisb/isync"; () end ; (* Colors *) add_ea "rf" {color="red" ; style = "" ; } {color="black" ; style="" ; } ; add_eas ["vo:" ; "seq"; ] {def_ea with color="magenta"; } {def_ea with color="grey30"; } ; add_eas ["po"; "po:"] def_ea {color="black" ; style="" ; } ; add_eas ["grf" ; "ppo"; "A/B:" ; "ppo-ext:";"ppoext"; "membar:"; "poloc"; "w*w*"; "ppo-direct"] { color="brown" ; style="" ; } { color="black" ; style="" ; } ; add_eas ["ppo-sela";] { color="#00b000" ; style="" ; } { color="black" ; style="" ; } ; add_eas ["fr" ] {color="#ffa040"; style=""; } {color="black" ; style =""; }; add_eas [ "lwfence"; "lwf"; "ffence"; "ff"; "implied"; "mfence"; "dmb"; "lwsync"; "eieio" ; "sync" ; "dmb-cumul" ; "dsb"; "dmb.st"; "dsb.st" ; "dmb.ld"; "dsb.ld" ; "dmb.sy"; "dsb.sy"; "dmbst"; "dsbst" ; "dsb-cumul"; "sync-cumul"; "lwsync-cumul"; "sync_cumul" ; "lwsync_cumul" ; "syncext";"lwsyncext";"dmbext";"dsbext";] {color="darkgreen"; style=""; } {color="black"; style="" ; } ; add_eas ["A" ; "B"; "co"; "ws"; "ca";] {color="blue" ; style = "" ; } {color="black" ; style = "" ; } ; add_eas ["LL" ; "LS" ; "PML"; "ll" ; "ls"; "pml"; "isync"; "dep"; "ctrl"; "data"; "addr"; "ctrlisync"; "isync"; "isb"; "ctrlisb";"ppo";"success";] { color="indigo" ; style = "" ; } { color="black" ; style = "" ; } ; add_ea "iico" { def_ea with color="black" ; } { def_ea with color="black" ; } ; add_ea "iico_data" { def_ea with color="black" ; } { def_ea with color="black" ; } ; add_ea "iico_ctrl" { def_ea with color="grey" ; } { def_ea with color="grey" ; } ; add_ea "iico_order" { def_ea with color="darkgrey" ; } { def_ea with color="darkgrey" ; } ; add_eas ["After";] {color="orange" ; style = extra_thick ; } {color="black" ; style= extra_thick ; } ; add_eas ["Before";] {color="blue" ; style = extra_thick ; } {color="black" ; style= extra_thick ; } ; add_eas ["CY";] {color="black" ; style = extra_thick ; } {color="black" ; style= extra_thick ; } ; () let () = init_pretty () (* Get complexified *) let get_ea def_color lbl = let col,mono = let key = try let idx = String.index lbl ':' in String.sub lbl 0 (idx+1) with Not_found -> lbl in try Hashtbl.find ea_t key with Not_found -> def_color def_ea ,def_ea in if PC.mono then mono else col let pp_attr chan attr value = match value with | "" -> () | _ -> fprintf chan ", %s=\"%s\"" attr value and pp_extra chan attr_value = match attr_value with | "" -> () | _ -> fprintf chan ", %s" attr_value (*******************) (* Sort out events *) (*******************) (* Collect events (1) by proc, (2) by poi. As a list of list of events. The second "list of" follows po order *) module PU = PrettyUtils.Make(S) let rec order_one_proc = function | []|[_] -> [] | i1::(i2::_ as rem) -> E.EventRel.cartesian i1 i2::order_one_proc rem let shift_max = let r = ref 0.0 in for k = 0 to Array.length PC.shift-1 do let x = PC.shift.(k) in if !r < x then r := x done ; !r let get_shift p = if p >= Array.length PC.shift then 0.0 else PC.shift.(p) let make_posy y env (p,es) = let s = get_shift p in let rec do_make_posy y env = function | [] -> env | e::es -> do_make_posy (y -. 1.0) (E.EventMap.add e y env) es in do_make_posy (y -. s) env es let order_events es by_proc_and_poi = let iico = E.iico es in let iicos = E.proj_rel es iico in let rs = List.map2 (fun ess iico -> let r = S.unions (iico::order_one_proc ess) and es = E.EventSet.unions ess in try E.EventRel.topo es r with E.EventRel.Cyclic -> assert false) by_proc_and_poi iicos in let max = List.fold_left (fun n es -> max n (List.length es)) 0 rs in let max = max-1 in let max = float_of_int max in let max = max +. shift_max in let rs = List.mapi (fun k es -> k,es) rs in let env = List.fold_left (make_posy max) E.EventMap.empty rs in max,env,E.EventMap.empty let debug_event_set chan s = output_char chan '{' ; E.EventSet.pp chan "," (fun chan e -> fprintf chan "%s" (E.pp_eiid e)) s; output_char chan '}' let pp_by_proc_and_poi chan s = List.iteri (fun i ess -> fprintf chan "P%i:" i ; List.iter (fun es -> fprintf stderr " %a" debug_event_set es) ess ; eprintf "\n") s ; flush stderr let make_posy_mult y env (p,ess) = let s = get_shift p in let rec do_make_posy y env = function | [] -> env | es::ess -> let env = E.EventSet.fold (fun e env -> E.EventMap.add e y env) es env in do_make_posy (y -. 1.0) env ess in do_make_posy (y -. s) env ess let dsiy = PC.dsiy let siwidth = PC.siwidth let order_events_mult es by_proc_and_poi = let iico = E.iico es in let by_proc_and_poi = List.map (fun ess -> List.fold_right (fun es k -> E.EventRel.strata es iico @ k) ess []) by_proc_and_poi in if dbg then pp_by_proc_and_poi stderr by_proc_and_poi ; let max = List.fold_left (fun n ess -> max n (List.length ess)) 0 by_proc_and_poi in let max = max-1 in let max = float_of_int max in let max = max +. shift_max in if dbg then eprintf "max=%.02f\n%!" max ; let ps = List.mapi (fun k es -> k,es) by_proc_and_poi in let envy = List.fold_left (make_posy_mult max) E.EventMap.empty ps in let envx,envy = List.fold_left (fun envp (k,ess) -> let kf = float_of_int k in List.fold_left (fun (envx,envy as envp) es -> let n = E.EventSet.cardinal es in match n with | 1 -> E.EventSet.fold (fun e env -> E.EventMap.add e kf env) es envx,envy | n -> assert (n > 1) ; let nf = float_of_int n in let delta = siwidth /. (nf -. 1.0) in let _,envp = E.EventSet.fold (fun e ((dx,dy),(envx,envy)) -> let envx = E.EventMap.add e dx envx and envy = try let old = E.EventMap.find e envy in E.EventMap.add e (old +. dy) envy with Not_found -> envy in (dx +. delta,0.0 -. dy),(envx,envy)) es ((kf -.0.5 +. (1.0 -. siwidth) *. 0.5,if k mod 2 = 0 then dsiy else -. dsiy),envp) in envp) envp ess) (E.EventMap.empty,envy) ps in max,envy,envx (*******************************) (* Build "visible" po relation *) (*******************************) (* Only successor edges are shown, and only from maximal intra-causality to minimal intra-causality. *) (* Non deps mode *) let rec min_max_to_succ = function | []|[_] -> E.EventRel.empty | (_xmin,xmax)::((ymin,_ymax)::_ as rem) -> E.EventRel.union (E.EventRel.cartesian xmax ymin) (min_max_to_succ rem) let make_visible_po_nodeps es by_proc_and_poi = let intra = E.EventRel.transitive_closure (E.iico es) in let min_max_list = List.map (List.map (fun es -> let mins = E.EventSet.filter (fun e -> not (E.EventRel.exists_pred intra e)) es and maxs = E.EventSet.filter (fun e -> not (E.EventRel.exists_succ intra e)) es in mins,maxs)) by_proc_and_poi in E.EventRel.unions (List.map min_max_to_succ min_max_list) (* Deps mode *) let make_visible_po_deps es by_proc_and_poi = let iico = E.EventRel.transitive_closure (E.iico es) in let _,po0 = es.E.po in let po = E.EventRel.diff po0 iico in let po = E.EventRel.remove_transitive_edges po in let mins,maxs = List.fold_left (fun p ess -> List.fold_left (fun (min,max) es -> let min2 = E.EventSet.filter (fun e -> not (E.EventRel.exists_pred (*po_*)iico e)) es and max2 = E.EventSet.filter (fun e -> not (E.EventRel.exists_succ (*po_*)iico e)) es in E.EventSet.union min min2,E.EventSet.union max max2) p ess ) (E.EventSet.empty, E.EventSet.empty) by_proc_and_poi in let r = E.EventRel.filter (fun (e1,e2) -> E.EventSet.mem e1 maxs && E.EventSet.mem e2 mins) po in if dbg then eprintf "make_visible_po {%a} => \n {%a} \n%!" E.debug_rel po0 E.debug_rel r; r let make_visible_po = if S.do_deps then make_visible_po_deps else make_visible_po_nodeps let dm = PC.dotmode let m = match dm with | Plain -> Ascii| Fig -> DotFig let mmode = m let pp_edge_label movelabel lbl = let lbl = if PC.relabel then relabel lbl else lbl in let lbl = if PC.movelabel && movelabel then let sz = String.length lbl in if PC.texmacros then sprintf "%s" lbl else lbl ^ String.make sz ' ' else lbl in let lbl = if PC.tikz then sprintf "{\\small %s}" lbl else lbl in escape_label dm lbl let pp_thread chan i = let pp = if PC.showthread then if PC.texmacros then sprintf "\\myth{%i}" i else sprintf "Thread %i" i else "" in fprintf chan "%s" (escape_label dm pp) module StringPair = struct type t = string * string let compare (e1,e2) (e3,e4) = match String.compare e1 e3 with | 0 -> String.compare e2 e4 | r -> r end module PairSet = MySet.Make(StringPair) module PairMap = MyMap.Make(StringPair) type info = { ikey:string; icolor:string; } let edges = ref PairMap.empty let edges_seen = ref StringMap.empty let reset_pairs () = edges := PairMap.empty ; edges_seen := StringMap.empty ; () let find_pair p m = try PairMap.find p m with Not_found -> [] let add_if_new p i m add = let old = find_pair p m in if List.exists (fun {ikey=k; _} -> k = i.ikey) old then m else PairMap.add p (add i old) m let do_add_pair p i m = add_if_new p i m (fun i old -> i::old) let add_end p i m = add_if_new p i m (fun i old -> old@[i]) let handle_symetric m = let yes,no = PairMap.fold (fun (n1,n2 as p) infos (m_yes,m_no) -> let yes,no = List.partition (fun i -> StringSet.mem i.ikey pc_symetric) infos in let m_yes = let q = if String.compare n2 n1 < 0 then (n2,n1) else p in List.fold_left (fun m_yes i -> ((q,i)::m_yes)) m_yes yes and m_no = match no with | [] -> m_no | _ -> PairMap.add p no m_no in m_yes,m_no) m ([],PairMap.empty) in let new_m,rem = List.fold_left (fun (new_m,rem) ((n1,n2 as p),i) -> let q = n2,n1 in let no_p = find_pair p no and no_q = find_pair q no in match no_p,no_q with | [],[] -> new_m,(p,i)::rem | [],_ -> add_end q i new_m,rem | _,[] -> add_end p i new_m,rem | _,_ -> add_end p i (add_end q i new_m),rem) (no,[]) yes in List.fold_left (fun m (p,i) -> do_add_pair p i m) new_m rem let compute_colors cs = (* NB keep order *) let rec do_rec = function | [] -> [] | c::cs -> if List.mem c cs then do_rec cs else c::do_rec cs in String.concat ":" (do_rec cs) let fmt_merged_label fst i = let pp_label = escape_html i.ikey in let pp_label = pp_edge_label false pp_label in sprintf "%s%s" i.icolor (if fst then "" else "") pp_label let fmt_merged_labels infos = match infos with | [] -> [] | i::rem -> fmt_merged_label true i:: List.map (fmt_merged_label false) rem let dump_pairs chan = let new_edges = handle_symetric !edges in PairMap.iter (fun (n1,n2) infos -> let all_syms = List.for_all (fun i -> StringSet.mem i.ikey pc_symetric) infos in let colors = compute_colors (List.map (fun i -> i.icolor) infos) and lbl = String.concat "" (fmt_merged_labels infos) in fprintf chan "%s -> %s [label=<%s>, color=\"%s\"" n1 n2 lbl colors ; pp_fontsize_edge chan ; pp_penwidth chan ; pp_arrowsize chan ; if all_syms then pp_attr chan "arrowhead" "none" ; fprintf chan "];\n" ; ()) new_edges ; reset_pairs () let add_pair p i = edges := do_add_pair p i !edges let do_merge_edge n1 n2 lbl def_color = let color = try DotEdgeAttr.find lbl "color" PC.edgeattrs with Not_found -> let {color;_} = get_ea def_color lbl in color in add_pair (n1,n2) {ikey=lbl; icolor=color; } let real_do_pp_edge chan n1 n2 lbl def_color override_style extra_attr backwards movelbl = let backwards = match PC.graph with | Graph.Cluster|Graph.Free -> false | Graph.Columns -> if lbl = "po" then false else backwards in let overridden a = try ignore (DotEdgeAttr.find lbl a PC.edgeattrs) ; true with Not_found -> false in let checklabel a = try begin match DotEdgeAttr.find a "label" PC.edgeattrs with | "tail" -> "taillabel" | "head" -> "headlabel" | _ -> "label" end with | Not_found -> "label" in let {color=color ; style=style; } = get_ea def_color lbl in fprintf chan "%s -> %s [%s=\"%s\"" (if backwards then n2 else n1) (if backwards then n1 else n2) (if not (overridden "label") && PC.movelabel && movelbl then "taillabel" else checklabel lbl) (pp_edge_label movelbl lbl) ; if StringSet.mem lbl pc_symetric then pp_attr chan "arrowhead" "none" ; if not (overridden "color") then begin pp_attr chan "color" color ; if not (PC.tikz) then pp_attr chan "fontcolor" color end ; if PC.tikz then pp_attr chan "lblstyle" "auto, midway, inner sep=0.7mm"; if not PC.tikz && not (overridden "fontsize") then pp_fontsize_edge chan; if not (overridden "penwidth") then pp_penwidth chan ; if not (overridden "arrowsize") then pp_arrowsize chan ; if not (overridden "style") then pp_attr chan "style" (if override_style = "" then style else override_style) ; pp_extra chan extra_attr ; if backwards then pp_attr chan "dir" "back" ; List.iter (fun (a,v) -> match a with | "color" -> pp_attr chan "color" v ; pp_attr chan "fontcolor" v | "label" -> () | _ -> pp_attr chan a v) (DotEdgeAttr.find_all lbl PC.edgeattrs) ; fprintf chan "];\n" ; () let get_edge_seen lbl = StringMap.safe_find PairSet.empty lbl !edges_seen let known_edge n1 n2 lbl = let seen = get_edge_seen lbl in PairSet.mem (n1,n2) seen || PairSet.mem (n2,n1) seen let record_edge_seen n1 n2 lbl = let seen = get_edge_seen lbl in edges_seen := StringMap.add lbl (PairSet.add (n1,n2) seen) !edges_seen let do_pp_edge chan n1 n2 lbl def_color override_style extra_attr backwards movelbl = try if StringSet.mem lbl PC.unshow then raise Exit ; let is_symetric = StringSet.mem lbl pc_symetric in if is_symetric then begin if known_edge n1 n2 lbl then raise Exit ; record_edge_seen n1 n2 lbl end ; if PC.edgemerge then do_merge_edge n1 n2 lbl def_color else real_do_pp_edge chan n1 n2 lbl def_color override_style extra_attr (backwards && not is_symetric) movelbl with Exit -> () let pp_edge chan n1 n2 lbl backwards = do_pp_edge chan n1 n2 lbl (fun x -> x) "" "" backwards let pp_point chan n lbl pos = let {color=color;_} = get_ea (fun x -> x) lbl in let sz = (pt2inch (scalepenwidth PC.ptscale)) in fprintf chan "%s [shape=point, height=%.2f, width=%.2f" n sz sz ; pp_attr chan "color" color ; pp_extra chan pos ; fprintf chan "];\n" let pp_none chan n pos = fprintf chan "%s [shape=none, height=0.0, width=0.0, label=\"\"" n ; pp_extra chan pos ; fprintf chan "];\n" let pp_node_eiid_label e = match dm with | Plain | Fig -> sprintf "%s: " (E.pp_eiid e) let pp_node_eiid e = sprintf "eiid%i" e.E.eiid let pp_node_ii chan ii = match ii with | E.IdInit|E.IdSpurious -> () | E.IdSome ii -> fprintf chan "proc:%s poi:%i\\l" (Proc.pp ii.A.proc) ii.A.program_order_index (* This complex function is not meant to be used directly, in case you wish, here is its type... val pp_dot_event_structure : out_channel -> test -> string option -> (* Legend *) event_structure -> rfmap -> rel_pp -> (* Relations *) event_set -> (* Nodes to be marked *) -> unit *) let do_pp_dot_event_structure chan _test legend es rfmap sets vbss mark = if dbg then begin prerr_endline "SETS:" ; StringMap.iter (fun tag evts -> eprintf "%s: %a\n" tag debug_event_set evts) sets end ; let stes = StringMap.fold (fun tag es m -> E.EventSet.fold (fun e m -> let tags = S.E.EventMap.safe_find StringSet.empty e m in S.E.EventMap.add e (StringSet.add tag tags) m) es m) sets S.E.EventMap.empty in let stes = S.E.EventMap.map (fun tags -> StringSet.map (fun tag -> (get_ea Misc.identity tag).color) tags) stes in let vbss = List.fold_right (fun (tag,r) k -> if StringSet.mem tag PC.unshow then k else let r = if StringSet.mem tag PC.noid then E.EventRel.filter (fun (e1,e2) -> not (E.event_equal e1 e2)) r else r in (tag,r)::k) vbss [] in let pl = fprintf chan "%s\n" and pf fmt = fprintf chan fmt in (************************) (* Position computation *) (************************) let max_proc = Misc.last (E.procs_of es) in (* Collect events (1) by proc, then (2) by poi *) let events_by_proc_and_poi = PU.make_by_proc_and_poi es in let maxy,envy,envx = let mult = true in if mult then order_events_mult es events_by_proc_and_poi else order_events es events_by_proc_and_poi in let inits = E.mem_stores_init_of es.E.events in let n_inits = E.EventSet.cardinal inits in let init_envx = if one_init then let w1 = float_of_int max_proc in let x = match PC.initpos with | Some (x,_) -> x | None -> match max_proc with | 1 -> -0.3333 | _ -> (w1 /. 2.0) -. 0.5 in E.EventSet.fold (fun e env -> E.EventMap.add e x env) inits E.EventMap.empty else let delta = if max_proc+1 >= n_inits then 1.0 else 0.75 in let w1 = float_of_int (max_proc+1) and w2 = float_of_int n_inits *. delta in let xinit = Misc.proj_opt 0.0 (Misc.app_opt fst PC.initpos) in (* eprintf "w1=%f, w2=%f\n" w1 w2 ; *) let shift = (w1 -. w2) /. 2.0 +. xinit in let _,r = E.EventSet.fold (fun e (k,env) -> k+1, let x = shift +. (float_of_int k) *. delta in (* eprintf "k=%i, x=%f\n" k x ; *) E.EventMap.add e x env) inits (0,E.EventMap.empty) in r in let pp_node_eiid = if one_init then fun e -> if E.EventSet.mem e inits then "eiidinit" else pp_node_eiid e else pp_node_eiid in let yinit = Misc.proj_opt 0.66667 (Misc.app_opt snd PC.initpos) in let maxy = if E.EventSet.is_empty inits then maxy else maxy +. yinit in let get_proc e = match E.proc_of e with | Some p -> p | None -> (-1) in let get_posx_int e = get_proc e in let get_posx e = if E.is_mem_store_init e then try E.EventMap.find e init_envx with Not_found -> assert false else try E.EventMap.find e envx with Not_found -> float_of_int (get_posx_int e) in let get_posy e = if E.is_mem_store_init e then maxy else try E.EventMap.find e envy with Not_found -> 10.0 in let is_even e1 e2 = let d = abs (get_posx_int e1 - get_posx_int e2) in d >= 2 && (d mod 2) = 0 in (* Hum... At least it seems that, -> right label below <- left label above Or... *) let is_up e1 e2 = let d = abs (get_posx_int e1 - get_posx_int e2) in d >= 2 && not (is_even e1 e2) && get_posy e1 < get_posy e2 in let back = false in let is_back e1 e2 = back && get_posx_int e1 < get_posx_int e2 in let xorigin=1.0 in (* Size of one step, horizontal *) let xstep = 1.0 in (*Was begin match max_proc with | 3 -> if PC.condensed then 0.7 else 2.0 | 2 -> if PC.condensed then 0.7 (*WAS 1.0*) else 2.5 | _ -> if PC.condensed then 0.7 (*WAS 1.0*) else 3.0 end *) (* size of one step, vertical *) let ystep = 0.75 in (* WAS begin match maxy with | 2 -> if PC.condensed then 0.35 else 2.0 | 5 -> if PC.condensed then 0.35 else 1.0 (* SS: HACK!! for ppo1/ppo3. We should take this as input maybe *) | _ -> if PC.condensed then 0.35 else 3.0 end *) let xscale= PC.scale *. PC.xscale *. xstep in let yscale= PC.scale *. PC.yscale *. ystep in (* Pick out the vertical edges of the last thread. so that the edge label can be put on their rhs, to reduce the label overlaps *) let last_thread e e' = let p = get_proc e and p' = get_proc e' in p = p' && p = max_proc in (* Position of events *) let xfinal f = xscale *. f +. xorigin and yfinal f = yscale *. f in let xevent e = xfinal (get_posx e) in let yevent e = yfinal (get_posy e) in let pp_event_position = match PC.graph with | Graph.Columns -> fun chan e -> fprintf chan ", pos=\"%f,%f!\"" (xevent e) (yevent e) | Graph.Free|Graph.Cluster -> fun _chan _e -> () in let pp_init_rf_position = match PC.graph with | Graph.Cluster|Graph.Free -> fun _e -> "" | Graph.Columns -> fun e -> let x = xevent e and y = yevent e in let dx,dy = PC.initdotpos in sprintf "pos=\"%f,%f!\"" (x +. xscale *. dx) (y +. yscale *. dy) in let pp_final_rf_position = match PC.graph with | Graph.Cluster|Graph.Free -> fun _e -> "" | Graph.Columns -> fun e -> let x = xevent e and y = yevent e in let dx,dy = PC.finaldotpos in sprintf "pos=\"%f,%f!\"" (x +. xscale *. dx) (y +. yscale *. dy) in let pp_action e = let pp = E.pp_action e in let pp = if E.EventSet.mem e mark then sprintf "*%s*" pp else pp in pp in let boxwidth = xscale *. 0.65 *. PC.boxscale in let boxheight = yscale *. 0.25 in let pp_loc e = match E.location_of e with | None -> assert false | Some (A.Location_global v) -> (* No brackets, old style *) A.V.pp_v_old v | Some loc -> A.pp_location loc in let pp_event ?lbl isinit color chan e = let act = pp_action e in let act = if PC.verbose > 0 then begin if E.EventSet.mem e es.E.data_ports then act ^ " (data)" else if E.EventSet.mem e es.E.success_ports then act ^ " (success)" else act end else act in let is_ghost = E.EventSet.mem e es.E.speculated in if not PC.squished then begin begin match lbl with | None -> fprintf chan "%s [label=\"%s%s%s%s\\l%a%a\"" (pp_node_eiid e) (pp_node_eiid_label e) (escape_label dm act) (if is_ghost then " (ghost)" else "") (if E.EventSet.mem e es.E.data_ports then " (data)" else "") pp_node_ii e.E.iiid (pp_instruction dm m) e.E.iiid | Some _ -> fprintf chan "eiidinit [label=\"Init\"" end ; pp_attr chan "shape" "box" ; pp_fontsize chan ; pp_attr chan "color" color ; fprintf chan "];\n" end else begin let act = if is_ghost then act^" (ghost)" else act in let act = match lbl with | None -> let eiid_lab = if PC.labelinit && isinit then sprintf "i%s:" (pp_loc e) else pp_node_eiid_label e in fprintf chan "%s [%slabel=\"%s%s\"" (pp_node_eiid e) (if is_ghost then "fontcolor=\"grey64\", " else "") (eiid_lab) (escape_label dm act) ; act | Some es -> let acts = E.EventSet.fold (fun e k -> let act = pp_action e in if PC.labelinit then let loc = pp_loc e in sprintf "i%s: %s" loc act::k else act::k) es [] in let acts = String.concat ", " acts in fprintf chan "eiidinit [label=\"%s\"" (escape_label dm acts) ; acts in let cl = try let cl = StringSet.choose (S.E.EventMap.find e stes) in Some cl with Not_found -> None in let is_shape,color = (PC.verbose > 2 || cl <> None), (match cl with| None -> color | Some cl -> cl) in pp_attr chan "shape" (if is_shape then "box" else "none") ; pp_fontsize chan ; if is_shape then pp_attr chan "color" color ; pp_event_position chan e ; pp_attr chan "fixedsize" (if PC.fixedsize then "true" else "false") ; pp_attr chan "height" (sprintf "%f" (if PC.fixedsize then boxheight else fscale *. dsize)) ; pp_attr chan "width" (sprintf "%f" (* For neato to route splines... *) (if PC.fixedsize then boxwidth else (float_of_int (String.length act) +. PC.extrachars) *. PC.boxscale *. fscale *. dsize)) ; fprintf chan "];\n" end in let pp_init_event color chan inits = let e = try E.EventSet.choose inits with Not_found -> assert false in pp_event ~lbl:inits false color chan e in let pp_event_structure chan vbss es = (* Extract relation to represent as classes, if any *) let asclass = match PC.classes with | Some n -> begin try eprintf "classes=\"%s\"\n" n ; let equiv = List.assoc n vbss in let cls = E.EventRel.classes equiv in eprintf "%s\n" (E.EventRel.pp_str " " (fun (e1,e2) -> sprintf "%s-%s" (E.pp_eiid e1) (E.pp_eiid e2)) equiv) ; List.iter (fun es -> eprintf " {%s}" (E.EventSet.pp_str "," E.pp_eiid es)) cls ; eprintf "\n" ; Some (n,cls) with Not_found -> None end | None -> None in let pl = fprintf chan "%s\n" in (* Init events, if any *) if not (E.EventSet.is_empty inits) then begin pl "" ; pl "/* init events */" ; if one_init then pp_init_event "blue" chan inits else E.EventSet.iter (fun ew -> pp_event true "blue" chan ew) inits end ; pl "" ; pl "/* the unlocked events */" ; Misc.iteri (fun n evtss -> (* Prelude *) begin match PC.graph with | Graph.Cluster -> fprintf chan "subgraph cluster_proc%i" n ; fprintf chan " { rank=sink; label = \"%a\"%a; %sshape=box;\n" pp_thread n (fun chan () -> do_pp_fontsize ';' chan) () (if not PC.mono then "color=magenta; " else "") | Graph.Columns -> if PC.showthread then begin let pos = sprintf "%f,%f" (xfinal (float_of_int n)) (yfinal (maxy +. PC.threadposy)) in fprintf chan "proc%i_label_node [shape=%s%a, label=\"%a\", pos=\"%s!\", fixedsize=true, width=%f, height=%f]\n" n (if PC.verbose > 2 then "box" else "none") (fun chan () -> pp_fontsize chan) () pp_thread n pos boxwidth boxheight end | Graph.Free -> () end ; (* Now output events *) let pp_events = match asclass with | None -> fun _m pp_evt evts -> E.EventSet.pp chan "" pp_evt evts | Some (name,cls) -> let color = lazy begin try DotEdgeAttr.find name "color" PC.edgeattrs with Not_found -> let {color;_} = get_ea (fun r -> { r with color="blue";}) name in color end in fun m pp_evt evts -> let cls,evts = List.fold_left (fun (cls,k) cl -> let cl = E.EventSet.inter cl evts in if E.EventSet.is_empty cl then (cls,k) else (cl::cls, E.EventSet.diff k cl)) ([],evts) cls in E.EventSet.pp chan "" pp_evt evts ; Misc.iteri (fun j cl -> let color = Lazy.force color in fprintf chan "subgraph cluster_class_%02i_%02i_%02i" n m j ; fprintf chan " { %s label=\"%s\"; shape=box;\n" (if not PC.mono then sprintf "color=%s;" color else "color=\"grey30\"; style=dashed; ") "" ; E.EventSet.pp chan "" pp_evt cl ; fprintf chan "}\n") cls in Misc.iteri (fun m evts -> (* evts = all events from one instruction.. *) if PC.withbox && (show_all_events || not (E.EventSet.is_singleton evts)) then begin let pp_ins = if PC.labelbox then let e0 = try E.EventSet.choose evts with Not_found -> assert false in let ins = match e0.E.iiid with | E.IdSome iiid -> iiid.A.inst | E.IdInit|E.IdSpurious -> assert false in E.pp_instance e0 ^ " " ^ a_pp_instruction dm mmode ins else "" in fprintf chan "subgraph cluster_proc%i_poi%i" n m ; fprintf chan " { %s label = \"%s\"; labelloc=\"b\"; shape=box;\n" (if not PC.mono then "color=green;" else "color=\"grey30\"; style=dashed; ") pp_ins ; (* assuming atomicity sets are always full instructions *) pp_events m (pp_event false "blue") evts ; fprintf chan "}\n" end else begin (* no green box around one event only *) pp_events m (pp_event false "blue") evts end) evtss; (* Postlude *) begin match PC.graph with | Graph.Cluster -> fprintf chan "}\n" | Graph.Free|Graph.Columns -> () end) events_by_proc_and_poi ; pl "" ; let spurious_es = PU.spurious_events es in if not (E.EventSet.is_empty spurious_es) then begin pl "/* Spurious events */" ; E.EventSet.pp chan "" (pp_event false "red") spurious_es ; () end ; pl "/* the intra_causality_data edges */\n" ; E.EventRel.pp chan "" (fun chan (e,e') -> pp_edge chan (pp_node_eiid e) (pp_node_eiid e') "iico_data" false false) es.E.intra_causality_data ; pl "" ; pl "/* the intra_causality_control edges */" ; E.EventRel.pp chan "" (fun chan (e,e') -> pp_edge chan (pp_node_eiid e) (pp_node_eiid e') "iico_ctrl" false false) es.E.intra_causality_control ; E.EventRel.pp chan "" (fun chan (e,e') -> pp_edge chan (pp_node_eiid e) (pp_node_eiid e') "iico_order" false false) es.E.intra_causality_order ; (****************) (* new po edges *) (****************) let make_rf_from_rfmap rfmap = S.RFMap.fold (fun wt rf k -> match wt,rf with | S.Load er,S.Store ew when E.is_mem er -> E.EventRel.add (ew,er) k | _ -> k) rfmap E.EventRel.empty in if pp_po_edge then begin let replaces_po = match PC.graph with | Graph.Columns|Graph.Cluster -> let all_vbss = E.EventRel.unions (List.map snd vbss) in let rf = make_rf_from_rfmap rfmap in let r = E.EventRel.union rf all_vbss in E.EventRel.union r (E.EventRel.inverse r) | Graph.Free -> E.EventRel.empty in let po_edges = make_visible_po es events_by_proc_and_poi in let po_edges = E.EventRel.diff po_edges replaces_po in (* let po_edges = reduces_more po_edges replaces_po in *) pl "" ; pl "/* the poi edges */" ; E.EventRel.pp chan "" (fun chan (e,e') -> let lbl = match PC.graph with | Graph.Free -> if PC.showthread then sprintf "po:%i" (get_proc e) else "po" | Graph.Columns|Graph.Cluster -> "po" in pp_edge chan (pp_node_eiid e) (pp_node_eiid e') lbl (last_thread e e') (is_even e e')) po_edges end ; vbss in reset_pairs () ; pl "digraph G {" ; pl "" ; begin match PC.dotheader with | Some h -> pl h | None -> (* Best trade-off for those two parameters, beware of changes... *) begin match PC.splines with | Some s -> pf "splines=%s;\n" (Splines.pp s) | None -> () end ; begin match PC.overlap with | Some s -> pf "overlap=%s;\n" s | None -> () end ; (* pl "compound=true;\n " ; *) begin match PC.margin with | None -> () | Some f -> pf "margin=\"%f\";\n" f end ; begin match PC.pad with | None -> () | Some f -> pf "pad=\"%f\";\n" f end ; begin match PC.fontname with | Some s -> pf "fontname=\"%s\";\n" s | None -> () end ; begin match PC.sep with | None-> () | Some s -> pf "sep=\"%s\"\n" s end ; (* pl "bgcolor=\"transparent\";\n " ; *) end ; pl "" ; begin match legend with | Some legend -> pl "/* legend */" ; begin match PC.fontsize with | None -> () | Some f -> pf "fontsize=%i;\n" f end ; pf "label=\"%s\";\n\n" (escape_dot legend) ; () | None -> () end ; let vbss = pp_event_structure chan vbss es in pl "/* the rfmap edges */" ; let show_ref_rel = List.exists (fun (lab,_) -> lab = "rf") vbss in S.pp_rfmap chan "" (fun chan wt rf -> match wt,rf with | S.Load er,S.Store ew -> if not show_ref_rel then pp_edge chan (pp_node_eiid ew) (pp_node_eiid er) "rf" (last_thread ew er || is_up ew er || is_back ew er) (is_even ew er) | S.Final _,S.Store ew -> if PC.showfinalrf then let final_id = "final"^pp_node_eiid ew in pp_none chan final_id (pp_final_rf_position ew); pp_edge chan (pp_node_eiid ew) final_id "rf" false false else () | S.Load er,S.Init -> if PC.showinitrf then begin let init_id = "init"^pp_node_eiid er in pp_point chan init_id "rf" (pp_init_rf_position er); pp_edge chan init_id (pp_node_eiid er) "rf" false false end | S.Final _,S.Init -> ()) rfmap ; pl "" ; (* A bunch of arrows *) pl "" ; pl "/* The viewed-before edges */" ; if dbg then begin let ns = List.map fst vbss in eprintf "Names: {%s}\n" (String.concat "," ns) end ; List.iter (fun (label,vbs) -> if dbg then eprintf "label=%s\n%!" label; E.EventRel.pp chan "" (fun chan (e,e') -> do_pp_edge chan (pp_node_eiid e) (pp_node_eiid e') label (* Overides default color... *) (fun s -> { s with color="brown" ; }) (* Overides any style given *) (if (try "mo" = String.sub label 0 2 with Invalid_argument _ -> false) && E.is_mem_store e && E.is_mem_store e' then "" (*"penwidth=10.0"*) else "") (* Extra attributes, overrides nothing *) "" (last_thread e e' || is_up e e' || is_back e e') (is_even e e')) vbs) vbss ; dump_pairs chan ; pl "}" (*********************************************) (* get rid of register events before dumping *) (*********************************************) let select_non_init = if PC.showinitwrites then fun _ -> true else fun e -> not (E.is_mem_store_init e) let select_event = match PC.showevents with | AllEvents -> (fun _ -> true) | MemEvents -> E.is_mem | NonRegEvents -> (fun e -> not (E.is_reg_any e)) | MemFenceEvents -> let open Misc in E.is_mem ||| E.is_barrier let select_event = let open Misc in select_event &&& select_non_init let select_events = E.EventSet.filter select_event let select_rel = E.EventRel.filter (fun (e1,e2) -> select_event e1 && select_event e2) let select_es es = { es with E.events = select_events es.E.events ; speculated = select_events es.E.speculated; po = begin let s,po = es.E.po in s,select_rel po end; intra_causality_data = select_rel es.E.intra_causality_data; intra_causality_control = select_rel es.E.intra_causality_control; intra_causality_order = select_rel es.E.intra_causality_order; } let select_rfmap rfm = S.RFMap.fold (fun wt rf k -> match wt,rf with | (S.Load e1,S.Store e2) -> begin match select_event e1, select_event e2 with | true,true -> S.RFMap.add wt rf k | true,false -> if E.is_mem_store_init e2 then S.RFMap.add wt S.Init k else k | _,_ -> k end | (S.Final _,S.Store e) | (S.Load e,S.Init) -> if select_event e then S.RFMap.add wt rf k else k | S.Final _,S.Init -> k) rfm S.RFMap.empty let pp_dot_event_structure chan test legend es rfmap sets vbss _conc = let obs = if PC.showobserved then PU.observed test es else E.EventSet.empty in do_pp_dot_event_structure chan test legend (select_es es) (select_rfmap rfmap) (StringMap.map (fun s -> select_events s) sets) (List.map (fun (tag,rel) -> tag,select_rel rel) vbss) obs let dump_legend chan test legend conc ?(sets=StringMap.empty) vbs = pp_dot_event_structure chan test (if PC.showlegend then Some legend else None) conc.S.str conc.S.rfmap sets vbs S.conc_zero let dump_es_rfm_legend chan legend test es rfm = pp_dot_event_structure chan test legend es rfm StringMap.empty [] S.conc_zero let dump_es chan test es = dump_es_rfm_legend chan None test es S.RFMap.empty let dump_es_rfm chan = dump_es_rfm_legend chan None (* Showed versions of dump functions *) module SHOW = Show.Make(PC) let show_es_rfm test es rfm = SHOW.show (fun chan -> dump_es_rfm chan test es rfm) let show_legend test legend conc ?(sets = StringMap.empty) vbs = SHOW.show (fun chan -> let legend = if PC.showlegend then Some legend else None in pp_dot_event_structure chan test legend conc.S.str conc.S.rfmap sets vbs conc) end herd-herdtools7-1ca343e/herd/RISCVArch_herd.ml000066400000000000000000000110141475314470400211010ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2017-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Define herd RISCV architecture *) open Printf module Make (C:Arch_herd.Config) (V:Value.S) = struct include RISCVBase let is_amo = function | Amo _ -> true | INop|Ret|J _|Bcc _|Load _|Store _|LoadReserve _ | OpI _|OpI2 _|OpIW _|Op _|OpW _|OpA _ |StoreConditional _|FenceIns _ |AUIPC _| Ext _ -> false let pp_barrier_short = function | FenceI -> "fence.i" | FenceTSO -> "fence.tso" | Fence (a1,a2) -> sprintf "F %s,%s" (pp_access a1) (pp_access a2) let reject_mixed = false type lannot = P of mo | X of mo let get_machsize _ = V.Cst.Scalar.machsize (* TODO, consider machsizes *) let empty_annot = P Rlx include Explicit.No include PteValSets.No let is_atomic = function | X _ -> true | P _ -> false let is_explicit = function | _ -> true let is_not_explicit = function | _ -> false let is_acquire = function | X Acq|P Acq -> true | X (Rlx|AcqRel|Rel|Sc)| P (Rlx|AcqRel|Rel) -> false | P Sc -> assert false let is_release = function | X Rel|P Rel -> true | X (Rlx|AcqRel|Acq|Sc)| P (Rlx|AcqRel|Acq) -> false | P Sc -> assert false let is_acquire_release = function | X AcqRel|P AcqRel -> true | X (Rlx|Rel|Acq|Sc)| P (Rlx|Rel|Acq) -> false | P Sc -> assert false let is_sc = function | X Sc -> true | P Sc -> assert false | X (Rlx|Rel|Acq|AcqRel)| P (Rlx|Rel|Acq|AcqRel) -> false let same_barrier b = fun c -> barrier_equal_semantics b c let ifetch_value_sets = [] let barrier_sets = fold_barrier (fun f k -> let tag = Misc.capitalize (pp_barrier_dot f) and pred = same_barrier f in (tag,pred)::k) [] let cmo_sets = [] let annot_sets = ["X", is_atomic; "Acq", is_acquire; "Rel", is_release; "AcqRel",is_acquire_release;"Sc",is_sc] let isync = FenceI let is_isync = same_barrier isync let pp_isync = Misc.capitalize (pp_barrier_dot isync) let pp_annot = let pp_mo = function | Rlx -> "" | Acq -> "Acq" | Rel -> "Rel" | AcqRel -> "AcqRel" | Sc -> "Sc" in function | P a -> pp_mo a | X a -> sprintf "%s*" (pp_mo a) module V = V let mem_access_size = function | INop | Ret | OpI _ | OpI2 _ | OpIW _ | Op _ | OpW _ | J _ | Bcc _ | FenceIns _ | OpA _ | AUIPC _ | Ext _ -> None | Load (w,_,_,_,_,_) | Store (w,_,_,_,_) | LoadReserve (w,_,_,_) | StoreConditional (w,_,_,_,_) | Amo (_,w,_,_,_,_) -> Some (tr_width w) include NoSemEnv include NoLevelNorTLBI include ArchExtra_herd.Make(C) (struct module V = V let endian = endian type arch_reg = reg let pp_reg = pp_reg let reg_compare = reg_compare let fromto_of_instr _ = None let get_val _ v = v module FaultType=FaultType.No end) module MemType=MemoryType.No module NoConf = struct type v = V.v type loc = location type value_set = V.ValueSet.t type solution = V.solution type arch_lannot = lannot type arch_explicit = explicit end module ArchAction = ArchAction.No(NoConf) module Barrier = AllBarrier.No(struct type a = barrier end) module CMO = Cmo.No end herd-herdtools7-1ca343e/herd/RISCVParseTest.ml000066400000000000000000000037051475314470400211440ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make(Conf:RunTest.Config)(ModelConfig:MemCat.Config) = struct module LexConfig = struct let debug = Conf.debug.Debug_herd.lexer end module ArchConfig = SemExtra.ConfigToArchConfig(Conf) module RISCVValue = Int64Value.Make(RISCVBase.Instr) module RISCV = RISCVArch_herd.Make(ArchConfig)(RISCVValue) module RISCVLexParse = struct type instruction = RISCV.parsedPseudo type token = RISCVParser.token module Lexer = RISCVLexer.Make(LexConfig) let lexer = Lexer.token let parser = MiscParser.mach2generic RISCVParser.main end module RISCVS = RISCVSem.Make(Conf)(RISCVValue) module RISCVM = MemCat.Make(ModelConfig)(RISCVS) module P = GenParser.Make (Conf) (RISCV) (RISCVLexParse) module X = RunTest.Make (RISCVS) (P) (RISCVM) (Conf) let run = X.run end herd-herdtools7-1ca343e/herd/RISCVParseTest.mli000066400000000000000000000024471475314470400213170ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make : functor(Conf:RunTest.Config) -> functor(ModelConfig:MemCat.Config) -> sig val run : RunTest.runfun end herd-herdtools7-1ca343e/herd/RISCVSem.ml000066400000000000000000000331101475314470400177470ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2017-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Semantics of RISC-V instructions *) module Make (C:Sem.Config) (V:Value.S with type Cst.Instr.t = RISCVBase.instruction) = struct module RISCV = RISCVArch_herd.Make(SemExtra.ConfigToArchConfig(C))(V) module Act = MachAction.Make(C.PC)(RISCV) include SemExtra.Make(C)(RISCV)(Act) let mixed = RISCV.is_mixed (* Barrier pretty print *) let barriers = RISCV.do_fold_fence (fun f k -> {barrier=f; pp=RISCV.pp_barrier_dot f;}::k) [] let isync = Some {barrier=RISCV.FenceI; pp="fenceI";} let nat_sz = V.Cst.Scalar.machsize let atomic_pair_allowed _ _ = true (* Semantics proper *) module Mixed(SZ:ByteSize.S) = struct module Mixed = M.Mixed(SZ) let (>>=) = M.(>>=) let (>>*=) = M.(>>*=) let (>>|) = M.(>>|) let (>>!) = M.(>>!) let (>>::) = M.(>>::) let unimplemented op = Warn.user_error "RISCV operation %s is not implemented (yet)" op let tr_opi op = match op with | RISCV.ADDI -> Op.Add | RISCV.SLTI -> Op.Lt | RISCV.ANDI -> Op.And | RISCV.ORI -> Op.Or | RISCV.XORI -> Op.Xor | RISCV.SLLI -> Op.ShiftLeft | RISCV.SRLI -> Op.ShiftRight | RISCV.SLTIU|RISCV.SRAI -> unimplemented (RISCV.pp_opi op) let tr_op op = match op with | RISCV.ADD -> Op.Add | RISCV.SLT -> Op.Lt | RISCV.AND -> Op.And | RISCV.OR -> Op.Or | RISCV.XOR -> Op.Xor | RISCV.SLL -> Op.ShiftLeft | RISCV.SUB -> Op.Sub | RISCV.SLTU|RISCV.SRA|RISCV.SRL -> unimplemented (RISCV.pp_op op) let tr_opiw op = match op with | RISCV.ADDIW -> Op.Add | RISCV.SLLIW -> Op.ShiftLeft | RISCV.SRLIW|RISCV.SRAIW -> unimplemented (RISCV.pp_opiw op) let tr_opw op = match op with | RISCV.ADDW -> Op.Add | RISCV.SLLW -> Op.ShiftLeft | RISCV.SUBW -> Op.Sub | RISCV.SRLW|RISCV.SRAW -> unimplemented (RISCV.pp_opw op) let tr_opamo op = match op with | RISCV.AMOSWAP -> assert false | RISCV.AMOADD -> Op.Add | RISCV.AMOAND -> Op.And | RISCV.AMOOR -> Op.Or | RISCV.AMOXOR -> Op.Xor | RISCV.AMOMAX -> Op.Max | RISCV.AMOMIN -> Op.Min | RISCV.AMOMAXU|RISCV.AMOMINU -> unimplemented (RISCV.pp_opamo op) let tr_cond cond = match cond with | RISCV.EQ -> Op.Eq | RISCV.NE -> Op.Ne | RISCV.LT -> Op.Lt | RISCV.GE -> Op.Ge | RISCV.LTU|RISCV.GEU -> unimplemented (RISCV.pp_bcc cond) let mk_read sz ato loc v = let ac = Act.access_of_location_std loc in Act.Access (Dir.R, loc, v, ato, (), sz, ac) let plain = RISCV.(P Rlx) let read_reg is_data r ii = match r with | RISCV.Ireg RISCV.X0 -> M.unitT V.zero | _ -> M.read_loc is_data (mk_read nat_sz plain) (A.Location_reg (ii.A.proc,r)) ii let read_reg_ord = read_reg false let read_reg_data = read_reg true let read_mem_annot sz an a ii = if mixed then Mixed.read_mixed false sz (fun sz a v -> mk_read sz an a v) a ii else M.read_loc false (mk_read sz an) (A.Location_global a) ii let read_mem sz mo = read_mem_annot sz (RISCV.P mo) let read_mem_atomic sz mo = read_mem_annot sz (RISCV.X mo) let write_loc_annot sz an loc v ii = M.mk_singleton_es (Act.Access (Dir.W, loc, v, an, (), sz, Access.VIR)) ii let do_write_reg mk r v ii = match r with | RISCV.Ireg RISCV.X0 -> M.unitT () | _ -> mk (Act.Access (Dir.W, (A.Location_reg (ii.A.proc,r)), v, plain, (), nat_sz, Access.REG)) ii let write_reg = do_write_reg M.mk_singleton_es let write_reg_success = do_write_reg (if O.variant Variant.Success then M.mk_singleton_es_success else M.mk_singleton_es) let do_write_mem sz an a v ii = if mixed then Mixed.write_mixed sz (fun sz a v -> Act.Access (Dir.W, a, v, an, (), sz, Access.VIR)) a v ii else M.mk_singleton_es (Act.Access (Dir.W, A.Location_global a, v, an, (), sz, Access.VIR)) ii let write_mem sz an = do_write_mem sz (RISCV.P an) let lrscdiffok = C.variant Variant.LrScDiffOk let write_mem_conditional sz an a v resa ii = if lrscdiffok then (M.mk_singleton_es_eq (Act.Access (Dir.W, A.Location_global a, v, RISCV.X an, (), sz,Access.VIR)) [] ii >>| M.neqT resa V.zero) >>! () (* resa = zero <-> no matching load reserve *) else let eq = [M.VC.Assign (a,M.VC.Atom resa)] in M.mk_singleton_es_eq (Act.Access (Dir.W, A.Location_global a, v, RISCV.X an, (), sz,Access.VIR)) eq ii let write_mem_atomic sz an = do_write_mem sz (RISCV.X an) let create_barrier b ii = M.mk_singleton_es (Act.Barrier b) ii let commit ii = M.mk_singleton_es (Act.Commit (Act.Bcc,None)) ii (* Compute amo semantics anotations from syntactic ones, Notice that Sc is exclusively semantics, cf. assert false below *) (* RMW events *) let rmw_events = not (C.variant Variant.SplittedRMW) let specialX0 = C.variant Variant.SpecialX0 let asfence = C.variant Variant.AcqRelAsFence let read_amo = let open RISCV in if specialX0 then fun mo -> match mo with | Rlx|Acq|AcqRel -> mo | Rel -> Rlx | Sc -> assert false else fun mo -> match mo with | Rlx|Acq -> mo | Rel -> Rlx | AcqRel -> Sc (* Compatibility, may disappear in future *) | Sc -> assert false and write_amo = let open RISCV in if specialX0 then fun mo -> match mo with | Rlx|Rel|AcqRel -> mo | Acq -> Rlx | Sc -> assert false else fun mo -> match mo with | Rlx|Rel -> mo | Acq -> Rlx | AcqRel -> Sc (* Compatibility, may disappear in future *) | Sc -> assert false let amo sz op an rd rv ra ii = let open RISCV in if rmw_events then let ra = read_reg_ord ra ii and rv = read_reg_data rv ii in match op with | AMOSWAP -> (ra >>| rv) >>= (fun (loc,vstore) -> M.read_loc false (fun loc v -> Act.Amo (loc,v,vstore,X an,(),sz,Access.VIR)) (A.Location_global loc) ii) >>= fun r -> write_reg rd r ii | _ -> (ra >>| rv) >>= (fun (loc,v) -> M.fetch (tr_opamo op) v (fun v vstored -> Act.Amo (A.Location_global loc,v,vstored,RISCV.X an,(),sz,Access.VIR)) ii) >>= fun v -> write_reg rd v ii else match specialX0,op,rd,rv with | true,AMOSWAP,Ireg X0,_ -> (read_reg_data rv ii >>| read_reg_ord ra ii) >>= fun (d,a) -> write_mem sz (write_amo an) a d ii | true,(AMOOR|AMOADD),_,Ireg X0 -> read_reg_ord ra ii >>= fun a -> read_mem sz (read_amo an) a ii >>= fun v -> write_reg rd v ii | _ -> let amo an = let ra = read_reg_ord ra ii and rv = read_reg_data rv ii and rmem = fun loc -> read_mem_atomic sz (read_amo an) loc ii and wmem = fun loc v -> write_mem_atomic sz (write_amo an) loc v ii in (match op with | AMOSWAP -> M.linux_exch | _ -> M.amo (tr_opamo op)) ra rv rmem wmem >>= fun r -> write_reg rd r ii in amo an (* Entry point *) let tr_sz = RISCV.tr_width let build_semantics _ ii = M.addT (A.next_po_index ii.A.program_order_index) begin match ii.A.inst with | RISCV.INop-> B.next1T () | RISCV.Ret when O.variant Variant.Telechat -> M.unitT () >>! B.Exit | RISCV.OpI2 (RISCV.LUI,r1,k) -> (* put k into upper half of r1*) M.op (Op.ShiftLeft) (V.intToV k) (V.intToV 12) >>= fun v -> write_reg r1 v ii >>= B.next1T | RISCV.OpI (RISCV.ADDI,r1,r2,0) -> (* A MV*) read_reg_data r2 ii >>= fun v -> write_reg r1 v ii >>= B.next1T | RISCV.OpI (op,r1,r2,k) -> read_reg_ord r2 ii >>= fun v -> M.op (tr_opi op) v (V.intToV k) >>= fun v -> write_reg r1 v ii >>= B.next1T | RISCV.OpA (RISCV.LA,r1,lbl) -> let v = ii.A.addr2v lbl in write_reg r1 v ii >>= B.next1T | RISCV.OpIW (op,r1,r2,k) -> read_reg_ord r2 ii >>= fun v -> M.op (tr_opiw op) v (V.intToV k) >>= fun v -> write_reg r1 v ii >>= B.next1T | RISCV.Op (op,r1,r2,r3) -> (read_reg_ord r2 ii >>| read_reg_ord r3 ii) >>= (fun (v1,v2) -> M.op (tr_op op) v1 v2) >>= (fun v -> write_reg r1 v ii) >>= B.next1T | RISCV.OpW (op,r1,r2,r3) -> (read_reg_ord r2 ii >>| read_reg_ord r3 ii) >>= (fun (v1,v2) -> M.op (tr_opw op) v1 v2) >>= (fun v -> write_reg r1 v ii) >>= B.next1T | RISCV.J lbl -> B.branchT lbl | RISCV.Bcc (cond,r1,r2,lbl) -> (read_reg_ord r1 ii >>| read_reg_ord r2 ii) >>= fun (v1,v2) -> M.op (tr_cond cond) v1 v2 >>= fun v -> commit ii >>= fun () -> B.bccT v lbl | RISCV.Load (sz,_s,mo,r1,k,r2) -> let mk_load mo = read_reg_ord r2 ii >>= (fun a -> M.add a (V.intToV k)) >>= (fun ea -> read_mem (tr_sz sz) mo ea ii) >>= (fun v -> write_reg r1 v ii) in if specialX0 then mk_load mo >>= B.next1T else if asfence then let open RISCV in let ld = match mo with | AcqRel -> create_barrier (Fence (RW,RW)) ii >>*= fun () -> mk_load Rlx | Rel|Acq|Rlx -> mk_load Rlx | Sc -> assert false in let ld = match mo with |Acq|AcqRel -> ld >>*= fun () -> create_barrier (Fence (R,RW)) ii | Rlx|Rel -> ld | Sc -> assert false in ld >>= B.next1T else mk_load mo >>= B.next1T | RISCV.Store (sz,mo,r1,k,r2) -> let mk_store mo = (read_reg_data r1 ii >>| read_reg_ord r2 ii) >>= (fun (d,a) -> (M.add a (V.intToV k)) >>= (fun ea -> write_mem (tr_sz sz) mo ea d ii)) in if specialX0 then mk_store mo >>= B.next1T else if asfence then let open RISCV in let sd () = mk_store Rlx in let sd = match mo with | Rel -> create_barrier (Fence (RW,W)) ii >>*= sd | AcqRel -> create_barrier (Fence (RW,RW)) ii >>*= sd | Acq|Rlx -> sd () | Sc -> assert false in sd >>= B.next1T else mk_store mo >>= B.next1T | RISCV.LoadReserve ((RISCV.Double|RISCV.Word as sz),mo,r1,r2) -> read_reg_ord r2 ii >>= (fun ea -> write_reg RISCV.RESADDR ea ii >>| (read_mem_atomic (tr_sz sz) mo ea ii >>= fun v -> write_reg r1 v ii)) >>= B.next2T | RISCV.StoreConditional ((RISCV.Double|RISCV.Word as sz),mo,r1,r2,r3) -> M.riscv_store_conditional (read_reg_ord RISCV.RESADDR ii) (read_reg_data r2 ii) (read_reg_ord r3 ii) (write_reg RISCV.RESADDR V.zero ii) (fun v -> write_reg_success r1 v ii) (fun ea resa v -> write_mem_conditional (tr_sz sz) mo ea v resa ii) >>= B.next1T | RISCV.Amo (op,sz,mo,r1,r2,r3) -> amo (tr_sz sz) op mo r1 r2 r3 ii >>= B.next1T | RISCV.FenceIns b -> create_barrier b ii >>= B.next1T | RISCV.Ext (_,w,r1,r2) -> read_reg_data r2 ii >>= M.op1 (Op.Sxt (RISCV.tr_width w)) >>= fun v -> write_reg r1 v ii >>= B.next1T | ins -> Warn.fatal "RISCV, instruction '%s' not handled" (RISCV.dump_instruction ins) end let spurious_setaf _ = assert false end end herd-herdtools7-1ca343e/herd/SelaEvent.ml000066400000000000000000000216301475314470400203060ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2011-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Utilities for Sela's models *) open Printf module type S = sig type event type event_set type event_rel type concrete (* Events relevant to Sela's models *) val evt_relevant : event -> bool val globally_visible : event -> bool type nature = Exe | Com | Prop of int type splitted = { nature:nature ; event:event; } val is_satisfy : splitted -> bool val is_init : splitted -> bool val is_commit : splitted -> bool val relevant_to_proc : splitted -> int -> bool val pp_splitted : splitted -> string type e2pred = event * event -> bool type model = { fbefore:e2pred ; fafter:e2pred; flocal: splitted -> splitted -> splitted -> bool; } (* Set and maps on splitted events *) module SplittedSet : MySet.S with type elt = splitted module SplittedRel : InnerRel.S with type elt0 = splitted and module Elts = SplittedSet val pp_splitted_rel : SplittedRel.t -> string val vb_pp_splitted : SplittedRel.t -> (string * event_rel) list (* Local order *) type loc_ord val pp_loc_ord : loc_ord -> (string * event_rel) list val proj_loc_ord : SplittedRel.t -> loc_ord val splitted_loc_ord : model -> concrete -> event_set -> event_rel -> event_rel -> SplittedRel.t val mk_loc_ord : model -> concrete -> event_set -> event_rel -> event_rel -> loc_ord val mem_loc_ord : (splitted * splitted) -> loc_ord -> bool end module type Conf = sig type event val visible_fence : event -> bool end module Make(S:Sem.Semantics) (Conf:Conf with type event = S.event) : S with type event = S.event and type event_set = S.event_set and type event_rel = S.event_rel and type concrete = S.concrete = struct type event = S.event type event_set = S.event_set type event_rel = S.event_rel type concrete = S.concrete module E = S.E (* Events relevant to Sela's model *) let evt_relevant x = E.is_mem x || E.is_commit x || E.is_barrier x let globally_visible x = E.is_mem_store x || Conf.visible_fence x type nature = Exe | Com | Prop of int let pp_nature = function | Exe -> "e" | Com -> "c" | Prop i -> sprintf "t%i" i let nature_compare n1 n2 = compare n1 n2 type splitted = { nature:nature ; event:event; } let pp_splitted e = sprintf "%s-%s" (S.E.pp_eiid e.event) (pp_nature e.nature) let splitted_compare e1 e2 = match S.E.event_compare e1.event e2.event with | 0 -> nature_compare e1.nature e2.nature | r -> r let is_satisfy e = E.is_load e.event && (match e.nature with | Exe -> true | _ -> false) let is_init e = E.is_store e.event && (match e.nature with | Exe -> true | _ -> false) let is_commit e = match e.nature with | Com -> true | _ -> false let locally_relevant xe = if globally_visible xe.event then match xe.nature with | Com -> true | Exe|Prop _ -> false else match xe.nature with | Exe -> true | Com|Prop _ -> false let proc_eq = Misc.int_eq let relevant_to_proc xe i = let x = xe.event in let px = match E.proc_of x with | Some px -> px | None -> assert false in if proc_eq px i then locally_relevant xe else match xe.nature with | Prop j -> proc_eq i j | Exe|Com -> false type e2pred = event * event -> bool type model = { fbefore:e2pred ; fafter:e2pred; flocal: splitted -> splitted -> splitted -> bool; } module OrderedSplitted = struct type t = splitted let compare = splitted_compare end module SplittedSet = MySet.Make(OrderedSplitted) module SplittedRel = InnerRel.Make(OrderedSplitted) let pp_splitted_rel r = SplittedRel.pp_str "" (fun (e1,e2) -> sprintf "<%s,%s>\n" (pp_splitted e1) (pp_splitted e2)) r module M = Map.Make (struct type t = nature * nature let compare = compare end) let add_pair k (x,y as v) m = if E.event_compare x y <> 0 then let vs = try M.find k m with Not_found -> [] in M.add k (v::vs) m else m let rt = E.EventRel.remove_transitive_edges let spiltted2r r = let m = SplittedRel.fold (fun (xe,ye) -> add_pair (xe.nature,ye.nature) (xe.event,ye.event)) r M.empty in let vb_pp = M.fold (fun (n1,n2) pairs k -> let tag = sprintf "%s -> %s" (pp_nature n1) (pp_nature n2) and r = E.EventRel.of_list pairs in (tag,r)::k) m [] in List.map (fun (tag,r) -> tag, rt r) vb_pp let vb_pp_splitted r = spiltted2r r (***************) (* Local order *) (***************) (* Projection of loc_ord onto four event relations *) type loc_ord = {eord:E.EventRel.t; cord:E.EventRel.t; e2c:E.EventRel.t; c2e:E.EventRel.t; } let rt = E.EventRel.remove_transitive_edges let pp_loc_ord loc_ord = ("eord",rt loc_ord.eord):: ("cord",rt loc_ord.cord):: ("e2c",rt loc_ord.e2c):: ("c2e",rt loc_ord.c2e)::[] let loc_ord0 = {eord=E.EventRel.empty ; cord=E.EventRel.empty ; e2c=E.EventRel.empty ; c2e=E.EventRel.empty ; } let proj_loc_ord r = SplittedRel.fold (fun (xe,ye) k -> let x = xe.event and y = ye.event in match xe.nature,ye.nature with | Exe,Exe -> { k with eord = E.EventRel.add (x,y) k.eord; } | Com,Com -> { k with cord = E.EventRel.add (x,y) k.cord; } | Exe,Com -> { k with e2c = E.EventRel.add (x,y) k.e2c; } | Com,Exe -> { k with c2e = E.EventRel.add (x,y) k.c2e; } | Prop _,_ | _,Prop _ -> assert false) r loc_ord0 (* Big loc_ord (on events) *) let fold_se f e k = f { nature=Exe; event=e;} (f { nature=Com; event=e;} k) let fold_se3 f x y z = fold_se (fun xe -> fold_se (fun ye -> fold_se (fun ze -> f xe ye ze) z) y) x let flocal m xe ye ze k = if m.flocal xe ye ze then (xe,ye)::k else k let splitted_loc_ord m conc evts rf po = let pos = E.proj_proc_view conc.S.str po in let r1 = let rs = List.map (fun po -> let pairs = E.EventRel.fold (fun (x,y) k -> let zs = E.EventSet.inter (E.EventRel.reachable x po) (E.EventRel.up y po) in E.EventSet.fold (fun z k -> fold_se3 (flocal m) x y z k) zs k) po [] in SplittedRel.of_list pairs) pos in rs and r2 = let pairs = E.EventRel.fold (fun (w,r) k -> if E.same_proc w r then ({nature = Exe ; event=w;}, {nature = Exe ; event=r;})::k else k) rf [] in SplittedRel.of_list pairs and r3 = let pairs = E.EventSet.fold (fun e k -> ({nature = Exe ; event=e;}, {nature = Com ; event=e;})::k) evts [] in SplittedRel.of_list pairs in SplittedRel.transitive_closure (SplittedRel.unions (r3::r2::r1)) let mk_loc_ord m conc evts rf po = let r = splitted_loc_ord m conc evts rf po in proj_loc_ord r let mem_loc_ord (e1,e2) loc_ord = let r = match e1.nature,e2.nature with | Exe,Exe -> loc_ord.eord | Exe,Com -> loc_ord.e2c | Com,Exe -> loc_ord.c2e | Com,Com -> loc_ord.cord | Prop _,_ | _,Prop _ -> assert false in E.EventRel.mem (e1.event,e2.event) r end herd-herdtools7-1ca343e/herd/X86Arch_herd.ml000066400000000000000000000064321475314470400206100ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Define X86 architecture *) module Make (C:Arch_herd.Config)(V:Value.S) = struct include X86Base let is_amo = function |I_LOCK _ | I_XCHG _ -> true |I_NOP|I_LFENCE|I_SFENCE|I_MFENCE|I_MOVSD|I_JMP _|I_JCC _|I_READ _ |I_ADD _|I_XOR _|I_OR _|I_MOV _|I_DEC _|I_CMP _|I_CMOVC _ |I_INC _|I_XCHG_UNLOCKED _|I_CMPXCHG _|I_SETNB _ |I_MOVB _|I_MOVW _|I_MOVL _|I_MOVQ _|I_MOVT _ -> false let pp_barrier_short = pp_barrier let reject_mixed = false type lannot = bool (* atomicity *) let get_machsize _ = V.Cst.Scalar.machsize let empty_annot = false let is_atomic annot = annot let is_barrier b1 b2 = barrier_compare b1 b2 = 0 let ifetch_value_sets = [] let barrier_sets = [ "MFENCE",is_barrier Mfence; "SFENCE",is_barrier Sfence; "LFENCE",is_barrier Lfence; ] let cmo_sets = [] let annot_sets = ["X",is_atomic] include Explicit.No include PteValSets.No let is_isync _ = false let pp_isync = "???" let pp_annot annot = if annot then "*" else "" module V = V (* Technically wrong, but it does not matter as there is no mixed-size *) let mem_access_size _ = None include NoSemEnv include NoLevelNorTLBI include ArchExtra_herd.Make (C)(struct module V = V let endian = endian type arch_reg = reg let pp_reg = pp_reg let reg_compare = reg_compare let fromto_of_instr _ = None let get_val _ v = v module FaultType=FaultType.No end) module MemType=MemoryType.No module NoConf = struct type v = V.v type loc = location type value_set = V.ValueSet.t type solution = V.solution type arch_lannot = lannot type arch_explicit = explicit end module ArchAction = ArchAction.No(NoConf) module Barrier = struct type a = barrier let a_to_b = let open AllBarrier in function | Mfence -> MFENCE | Sfence -> SFENCE | Lfence -> LFENCE let pp_isync = "???" end module CMO = Cmo.No end herd-herdtools7-1ca343e/herd/X86ParseTest.ml000066400000000000000000000036451475314470400206460ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make(Conf:RunTest.Config)(ModelConfig:MemWithCav12.Config) = struct module LexConfig = struct let debug = Conf.debug.Debug_herd.lexer end module ArchConfig = SemExtra.ConfigToArchConfig(Conf) module X86Value = Int32Value.Make(X86Base.Instr) module X86 = X86Arch_herd.Make(ArchConfig)(X86Value) module X86LexParse = struct type instruction = X86.pseudo type token = X86Parser.token module Lexer = X86Lexer.Make(LexConfig) let lexer = Lexer.token let parser = MiscParser.mach2generic X86Parser.main end module X86S = X86Sem.Make(Conf)(X86Value) module X86M = MemWithCav12.Make(ModelConfig)(X86S) module P = GenParser.Make (Conf) (X86) (X86LexParse) module X = RunTest.Make (X86S) (P) (X86M) (Conf) let run = X.run end herd-herdtools7-1ca343e/herd/X86ParseTest.mli000066400000000000000000000024551475314470400210150ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make : functor(Conf:RunTest.Config) -> functor(ModelConfig:MemWithCav12.Config) -> sig val run : RunTest.runfun end herd-herdtools7-1ca343e/herd/X86Sem.ml000066400000000000000000000265221475314470400174570ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Semantics of X86 instructions *) module Make (C:Sem.Config) (V:Value.S with type Cst.Instr.t = X86Base.instruction) = struct module X86 = X86Arch_herd.Make(SemExtra.ConfigToArchConfig(C))(V) module Act = MachAction.Make(C.PC)(X86) include SemExtra.Make(C)(X86)(Act) (* barrier pretty print *) let mfence = {barrier=X86.Mfence; pp="mfence";} let sfence = {barrier=X86.Sfence; pp="sfence";} let lfence = {barrier=X86.Lfence; pp="lfence";} let barriers = [mfence; lfence;sfence;] let isync = None let nat_sz = V.Cst.Scalar.machsize let is_global = A.is_global let atomic_pair_allowed e1 e2 = match e1.E.iiid, e2.E.iiid with | E.IdSome i1,E.IdSome i2 -> i1 == i2 | _,_ -> false (********************) (* semantics proper *) (********************) module Mixed(SZ:ByteSize.S) = struct let (>>=) = M.(>>=) let (>>*=) = M.(>>*=) let (>>|) = M.(>>|) let (>>!) = M.(>>!) let mk_read sz ato loc v = let ac = Act.access_of_location_std loc in Act.Access (Dir.R, loc, v, ato, (), sz, ac) let read_loc sz is_d = M.read_loc is_d (mk_read sz false) let mk_read_choose_atomic sz loc = mk_read sz (is_global loc) loc let read_reg is_data r ii = M.read_loc is_data (mk_read nat_sz false) (A.Location_reg (ii.A.proc,r)) ii let read_mem sz a ii = M.read_loc false (mk_read sz false) (A.Location_global a) ii let read_mem_atomic sz a ii = M.read_loc false (mk_read sz true) (A.Location_global a) ii let read_loc_atomic sz is_d = M.read_loc is_d (mk_read_choose_atomic sz) let read_loc_gen sz data locked loc ii = match loc with | A.Location_global _ -> M.read_loc data (mk_read sz locked) loc ii | _ -> M.read_loc data (mk_read nat_sz false) loc ii let write_loc_gen sz locked loc v ii = match loc with | A.Location_global _ -> M.mk_singleton_es (Act.Access (Dir.W, loc, v, locked, (), sz, Access.VIR)) ii | _ -> M.mk_singleton_es (Act.Access (Dir.W, loc, v, locked, (), nat_sz, Access.VIR)) ii let write_loc sz loc v ii = let ac = Act.access_of_location_std loc in M.mk_singleton_es (Act.Access (Dir.W, loc, v, false, (), sz, ac)) ii let write_reg r v ii = M.mk_singleton_es (Act.Access (Dir.W, (A.Location_reg (ii.A.proc,r)), v, false, (), nat_sz, Access.REG)) ii let write_mem sz a v ii = M.mk_singleton_es (Act.Access (Dir.W, A.Location_global a, v, false, (), sz, Access.VIR)) ii let write_mem_atomic sz a v ii = M.mk_singleton_es (Act.Access (Dir.W, A.Location_global a, v, true, (), sz, Access.VIR)) ii let write_loc_atomic sz loc v ii = let ac = Act.access_of_location_std loc in M.mk_singleton_es (Act.Access (Dir.W, loc, v, (is_global loc), (), sz, ac)) ii let write_flag r o v1 v2 ii = M.addT (A.Location_reg (ii.A.proc,r)) (M.op o v1 v2) >>= (fun (loc,v) -> write_loc nat_sz loc v ii) let create_barrier b ii = M.mk_singleton_es (Act.Barrier b) ii let lval_ea ea ii = match ea with | X86.Effaddr_rm32 (X86.Rm32_reg r)-> M.unitT (X86.Location_reg (ii.X86.proc,r)) | X86.Effaddr_rm32 (X86.Rm32_deref r) -> read_reg false r ii >>= fun vreg -> M.unitT (X86.Location_global vreg) | X86.Effaddr_rm32 (X86.Rm32_abs v)-> M.unitT (X86.maybev_to_location v) let rval_ea sz locked ea ii = lval_ea ea ii >>= fun loc -> read_loc sz locked loc ii let rval_op sz locked op ii = match op with | X86.Operand_effaddr ea -> rval_ea sz locked ea ii | X86.Operand_immediate s -> M.unitT (V.intToV s) let flip_flag v = M.op Op.Xor v V.one (* Set flags by comparing v1 v2 *) let write_zf v1 v2 ii = write_flag X86.ZF Op.Eq v1 v2 ii let write_sf v1 v2 ii = write_flag X86.SF Op.Gt v1 v2 ii let write_all_flags v1 v2 ii = (write_zf v1 v2 ii >>| write_sf v1 v2 ii >>| write_flag X86.CF Op.Eq V.zero V.one ii) (* Carry was always zero! *) >>! () (* Exchange *) let xchg sz ea1 ea2 ii = (lval_ea ea1 ii >>| lval_ea ea2 ii) >>= (fun (l1,l2) -> let r1 = read_loc_atomic sz true l1 ii and r2 = read_loc_atomic sz true l2 ii and w1 = fun v -> write_loc_atomic sz l1 v ii and w2 = fun v -> write_loc_atomic sz l2 v ii in M.exch r1 r2 w1 w2) >>= B.next2T let do_op sz locked o ea op ii = (lval_ea ea ii >>= fun loc -> M.addT loc (read_loc_gen sz true locked loc ii) >>| rval_op sz locked op ii) >>= fun ((loc,v_ea),v_op) -> M.op o v_ea v_op >>= fun v_result -> (write_loc_gen sz locked loc v_result ii >>| write_all_flags v_result V.zero ii) >>= B.next2T let build_semantics _ ii = let rec build_semantics_inner locked ii = match ii.A.inst with | X86.I_NOP -> B.nextT | X86.I_XOR (ea,op) -> do_op nat_sz locked Op.Xor ea op ii | X86.I_OR (ea,op) -> do_op nat_sz locked Op.Or ea op ii | X86.I_ADD (ea,op) -> do_op nat_sz locked Op.Add ea op ii | X86.I_MOV (ea,op)|X86.I_MOVB (ea,op)|X86.I_MOVW (ea,op)|X86.I_MOVL (ea,op)|X86.I_MOVQ (ea,op) | X86.I_MOVT (ea,op) as i -> let sz = match i with | X86.I_MOV _|X86.I_MOVL _ -> MachSize.Word | X86.I_MOVB _ -> MachSize.Byte | X86.I_MOVW _ -> MachSize.Short | X86.I_MOVQ _ -> MachSize.Quad | _ -> assert false in (lval_ea ea ii >>| rval_op sz locked op ii) >>= fun (loc,v_op) -> write_loc_gen sz locked loc v_op ii >>= B.next1T | X86.I_READ (op) -> rval_op nat_sz locked op ii >>= fun _ -> M.unitT () >>= B.next1T | X86.I_DEC (ea) -> lval_ea ea ii >>= fun loc -> read_loc_gen nat_sz true locked loc ii >>= fun v -> M.op Op.Sub v V.one >>= fun v -> (write_loc_gen nat_sz locked loc v ii >>| write_sf v V.zero ii >>| write_zf v V.zero ii) >>= fun (((),()),()) -> B.nextT | X86.I_INC (ea) -> lval_ea ea ii >>= fun loc -> read_loc_gen nat_sz true locked loc ii >>= fun v -> M.add v V.one >>= fun v -> (write_loc_gen nat_sz locked loc v ii >>| write_sf v V.zero ii >>| write_zf v V.zero ii) >>= fun (((),()),()) -> B.nextT | X86.I_CMP (ea,op) -> (rval_ea nat_sz locked ea ii >>| rval_op nat_sz locked op ii) >>= fun (v_ea,v_op) -> write_all_flags v_ea v_op ii >>= B.next1T | X86.I_CMOVC (r,ea) -> read_reg false X86.CF ii >>*= (fun vcf -> M.choiceT vcf (rval_ea nat_sz locked ea ii >>= fun vea -> write_reg r vea ii >>= B.next1T) B.nextT) | X86.I_JMP lbl -> B.branchT lbl (* Conditional branZch, I need to look at doc for interpretation of conditions *) | X86.I_JCC (X86.C_LE,lbl) -> read_reg false X86.SF ii >>= (* control, data ? no event generated after this read anyway *) fun sf -> (* LE simply is the negation of GT, given by sign flag *) flip_flag sf >>= fun v -> B.bccT v lbl | X86.I_JCC (X86.C_LT,lbl) -> (read_reg false X86.ZF ii >>| (read_reg false X86.SF ii >>= flip_flag)) >>= fun (v1,v2) -> M.op Op.Or v1 v2 >>= fun v -> B.bccT v lbl | X86.I_JCC (X86.C_GE,lbl) -> (read_reg false X86.ZF ii >>| read_reg false X86.SF ii) >>= fun (v1,v2) -> M.op Op.Or v1 v2 >>= fun v -> B.bccT v lbl | X86.I_JCC (X86.C_GT,lbl) -> read_reg false X86.SF ii >>= fun v -> B.bccT v lbl | X86.I_JCC (X86.C_EQ,lbl) -> read_reg false X86.ZF ii >>= fun v -> B.bccT v lbl | X86.I_JCC (X86.C_NE,lbl) -> read_reg false X86.ZF ii >>= flip_flag >>= fun v -> B.bccT v lbl | X86.I_JCC (X86.C_S,lbl) -> read_reg false X86.SF ii >>= fun v -> B.bccT v lbl | X86.I_JCC (X86.C_NS,lbl) -> read_reg false X86.SF ii >>= flip_flag >>= fun v -> B.bccT v lbl | X86.I_LOCK inst -> begin let open X86 in match inst with | I_XCHG _ | I_XCHG_UNLOCKED _ | I_ADD _ | I_XOR _ | I_DEC _ | I_INC _ -> build_semantics_inner true {ii with A.inst = inst} | _ -> Warn.user_error "Illegal lock prefix on instruction %s" (dump_instruction inst) end | X86.I_SETNB (ea) -> (lval_ea ea ii >>| read_reg false X86.CF ii) >>= fun (loc,cf) -> flip_flag cf >>= fun v -> write_loc nat_sz loc v ii >>= B.next1T | X86.I_XCHG (ea1,ea2) -> xchg nat_sz ea1 ea2 ii | X86.I_XCHG_UNLOCKED (ea1,ea2) -> xchg nat_sz ea1 ea2 ii | X86.I_CMPXCHG (_,_) -> Warn.fatal "I_CMPXCHG not implemented" | X86.I_LFENCE -> create_barrier X86.Lfence ii >>= B.next1T | X86.I_SFENCE -> create_barrier X86.Sfence ii >>= B.next1T | X86.I_MFENCE -> create_barrier X86.Mfence ii >>= B.next1T | X86.I_MOVSD -> Warn.fatal "I_MOVSD not implemented" in M.addT (A.next_po_index ii.A.program_order_index) (build_semantics_inner false ii) let spurious_setaf _ = assert false end end herd-herdtools7-1ca343e/herd/X86_64Arch_herd.ml000066400000000000000000000125041475314470400211160ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Define X86_64 architecture *) module Make (C:Arch_herd.Config)(V:Value.S) = struct include X86_64Base let is_amo = function | I_LOCK _ | I_EFF_EFF (I_XCHG,_,_,_) -> true | I_NOP | I_RET | I_EFF_OP _ | I_EFF _ | I_EFF_EFF _ | I_CMPXCHG _ | I_JMP _ | I_JCC _ | I_CMOVC _ | I_MOVNTI _ | I_FENCE _ | I_MOVD _ | I_MOVNTDQA _ | I_CLFLUSH _ -> false let pp_barrier_short = pp_barrier let reject_mixed = false type lannot = Plain|Atomic|NonTemporal let get_machsize _ = V.Cst.Scalar.machsize let empty_annot = Plain let is_atomic = function | Atomic -> true | Plain|NonTemporal -> false and is_nt = function | NonTemporal -> true | Plain|Atomic -> false let is_barrier b1 b2 = barrier_compare b1 b2 = 0 let ifetch_value_sets = [] let barrier_sets = [ "MFENCE",is_barrier MFENCE; "SFENCE",is_barrier SFENCE; "LFENCE",is_barrier LFENCE; ] let cmo_sets = [] let annot_sets = ["X",is_atomic; "NT",is_nt;] include Explicit.No include PteValSets.No let is_isync _ = false let pp_isync = "???" let pp_annot annot = match annot with | Atomic -> "*" | Plain -> "" | NonTemporal -> "NT" let inst_size_to_mach_size = function | I8b -> MachSize.Byte | I16b -> MachSize.Short | I32b | INSb -> MachSize.Word | I64b -> MachSize.Quad let reg_part_to_mach_size = function | R8bL | R8bH -> MachSize.Byte | R16b -> MachSize.Short | R32b -> MachSize.Word | R64b -> MachSize.Quad let reg_to_mach_size r = match r with | Ireg (_,p) -> reg_part_to_mach_size p | RIP | CS | Symbolic_reg _ | Internal _ | Flag _ | XMM _ -> Warn.fatal "No size for register %s" (pp_reg r) let mem_access_size = function | I_NOP | I_RET | I_JMP _ | I_JCC _ | I_LOCK _ | I_FENCE _ | I_CLFLUSH _ | I_MOVNTDQA _ (* twice a quad in fact *) -> None | I_EFF_OP (_, sz, _, _) | I_EFF (_, sz, _) | I_EFF_EFF (_, sz, _, _) | I_CMPXCHG (sz, _, _) | I_CMOVC (sz, _, _) | I_MOVNTI (sz,_,_) | I_MOVD (sz,_,_) -> Some (inst_size_to_mach_size sz) include NoSemEnv (********************) (* global locations *) (********************) module V = V include NoLevelNorTLBI include ArchExtra_herd.Make (C) (struct module V = V let endian = endian type arch_reg = reg let pp_reg = pp_reg let reg_compare = reg_compare let fromto_of_instr _ = None let get_val _ v = v module FaultType=FaultType.No end) module MemType=MemoryType.X86_64 module ArchAction = struct type t = ClFlush of opt * location type v = V.v type loc = location type value_set = V.ValueSet.t type solution = V.solution type arch_lannot = lannot type arch_explicit = explicit let pp_opt = function | NoOpt -> "" | Opt -> "Opt" let pp (ClFlush (opt,loc)) = Printf.sprintf "ClFlush%s %s" (pp_opt opt) (pp_location loc) let get_lannot _ = Plain let get_explicit _ = exp_annot let value_of _ = None let read_of _ = None let written_of _ = None let location_of (ClFlush (_,loc)) = Some loc let is_store _ = false let is_load _ = false let get_size _ = assert false let get_kind _ = assert false let undetermined_vars (ClFlush (_,loc)) = undetermined_vars_in_loc loc let simplify_vars sol (ClFlush (opt,loc)) = ClFlush (opt,simplify_vars_in_loc sol loc) let is_opt (ClFlush (opt,_)) = match opt with | NoOpt -> false | Opt -> true let sets = ["ClFlush",(fun a -> not (is_opt a)); "ClFlushOpt",(fun a -> is_opt a);] end module Barrier = struct type a = barrier let a_to_b = let module N = AllBarrier in function | MFENCE -> N.MFENCE | SFENCE -> N.SFENCE | LFENCE -> N.LFENCE let pp_isync = "???" end module CMO = Cmo.No end herd-herdtools7-1ca343e/herd/X86_64ParseTest.ml000066400000000000000000000037301475314470400211520ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make(Conf:RunTest.Config)(ModelConfig:MemWithCav12.Config) = struct module LexConfig = struct let debug = Conf.debug.Debug_herd.lexer end module ArchConfig = SemExtra.ConfigToArchConfig(Conf) module X86_64Value = Int64Value.Make(X86_64Base.Instr) module X86_64 = X86_64Arch_herd.Make(ArchConfig)(X86_64Value) module X86_64LexParse = struct type instruction = X86_64.pseudo type token = X86_64Parser.token module Lexer = X86_64Lexer.Make(LexConfig) let lexer = Lexer.token let parser = MiscParser.mach2generic X86_64Parser.main end module X86_64S = X86_64Sem.Make(Conf)(X86_64Value) module X86_64M = MemWithCav12.Make(ModelConfig)(X86_64S) module P = GenParser.Make(Conf)(X86_64)(X86_64LexParse) module X = RunTest.Make(X86_64S)(P)(X86_64M)(Conf) let run = X.run end herd-herdtools7-1ca343e/herd/X86_64ParseTest.mli000066400000000000000000000024551475314470400213260ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make : functor(Conf:RunTest.Config) -> functor(ModelConfig:MemWithCav12.Config) -> sig val run : RunTest.runfun end herd-herdtools7-1ca343e/herd/X86_64Sem.ml000066400000000000000000000417561475314470400177760ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Semantics of X86_64 instructions *) module Make (C:Sem.Config) (V:Value.S with type Cst.Instr.t = X86_64Base.instruction) = struct module X86_64 = X86_64Arch_herd.Make(SemExtra.ConfigToArchConfig(C))(V) module Act = MachAction.Make(C.PC)(X86_64) include SemExtra.Make(C)(X86_64)(Act) let mixed = C.variant Variant.Mixed (* barrier pretty print *) let barriers = let mfence = {barrier=X86_64.MFENCE; pp="mfence";} and sfence = {barrier=X86_64.SFENCE; pp="sfence";} and lfence = {barrier=X86_64.LFENCE; pp="lfence";} in [mfence; sfence; lfence;] let isync = None let nat_sz = V.Cst.Scalar.machsize let is_global = A.is_global let atomic_pair_allowed e1 e2 = match e1.E.iiid, e2.E.iiid with | E.IdSome i1,E.IdSome i2 -> i1 == i2 | _,_ -> false (* semantics proper *) module Mixed(SZ : ByteSize.S) = struct module Mixed = M.Mixed(SZ) let (>>=) = M.(>>=) let (>>*=) = M.(>>*=) let (>>|) = M.(>>|) let (>>!) = M.(>>!) let inst_size_to_mach_size = X86_64.inst_size_to_mach_size let reg_size_to_mach_size sz = match sz with | X86_64.R8bL | X86_64.R8bH -> MachSize.Byte | X86_64.R16b -> MachSize.Short | X86_64.R32b -> MachSize.Word | X86_64.R64b -> MachSize.Quad let mk_read sz an loc v = let ac = Act.access_of_location_std loc in Act.Access (Dir.R, loc, v, an, (), sz, ac) let read_loc sz is_d = M.read_loc is_d (mk_read sz X86_64.Plain) let plain = X86_64.Plain and atomic = X86_64.Atomic let atomic_when_global loc = if is_global loc then atomic else plain let mk_read_choose_atomic sz loc = mk_read sz (atomic_when_global loc) loc let mask_from_reg_part = function | X86_64.R8bH -> fun w -> M.op1 (Op.LogicalRightShift 8) w >>= fun v -> M.op1 (Op.UnSetXBits (56, 8)) v | X86_64.R8bL -> fun v -> M.op1 (Op.UnSetXBits (56, 8)) v | X86_64.R16b -> fun v -> M.op1 (Op.UnSetXBits (48, 16)) v | X86_64.R32b -> fun v -> M.op1 (Op.UnSetXBits (32, 32)) v | X86_64.R64b -> M.unitT let inst_size_to_reg_size = function | X86_64.I8b -> X86_64.R8bL | X86_64.I16b -> X86_64.R16b | X86_64.I32b -> X86_64.R32b | X86_64.I64b |X86_64.INSb -> X86_64.R64b let get_inst_size inst = let open X86_64 in match inst with | I_NOP | I_RET | I_FENCE _ | I_LOCK _ | I_JMP _ | I_JCC _ | I_MOVNTDQA _ | I_CLFLUSH _ -> INSb | I_EFF_OP (_, sz, _, _) | I_EFF (_, sz, _) | I_EFF_EFF (_, sz, _, _) | I_CMPXCHG (sz, _, _) | I_CMOVC (sz, _, _) | I_MOVNTI (sz,_,_) | I_MOVD (sz,_,_) -> sz let read_reg is_data r ii = if is_data then match r with | X86_64.Ireg (_, p) -> let sz = reg_size_to_mach_size p in read_loc sz is_data (A.Location_reg (ii.A.proc,r)) ii >>= mask_from_reg_part p | _ -> read_loc nat_sz is_data (A.Location_reg (ii.A.proc,r)) ii else read_loc nat_sz is_data (A.Location_reg (ii.A.proc,r)) ii let read_mem sz _data an a ii = let data = false in if mixed then Mixed.read_mixed data sz (fun sz -> mk_read sz an) a ii else let a = A.Location_global a in M.read_loc data (mk_read sz an) a ii let read_mem_atomic sz a ii = read_mem sz false X86_64.Atomic a ii let read_loc_gen sz data locked loc ii = begin match loc with | A.Location_global l -> read_mem sz data locked l ii | A.Location_reg (_, reg) -> read_reg data reg ii end >>= mask_from_reg_part (if data then (inst_size_to_reg_size (get_inst_size ii.X86_64.inst)) else X86_64.R64b) let read_loc_atomic sz is_d loc ii = read_loc_gen sz is_d (atomic_when_global loc) loc ii let mk_write sz an loc v = let ac = Act.access_of_location_std loc in Act.Access (Dir.W, loc, v, an, (), sz, ac) let write_loc sz an loc v ii = M.mk_singleton_es (mk_write sz an loc v) ii let write_mem sz an a v ii = if mixed then Mixed.write_mixed sz (fun sz -> mk_write sz an) a v ii else write_loc sz an (A.Location_global a) v ii let write_reg r v ii = (* Spec from intel manual : - 64-bit operands generate a 64-bit result in the destination general-purpose register. - 32-bit operands generate a 32-bit result, zero-extended to a 64-bit result in the destination general-purpose register. - 8-bit and 16-bit operands generate an 8-bit or 16-bit result. The upper 56 bits or 48 bits (respectively) of the destination general-purpose register are not be modified by the operation. *) let normalize_register_and_value = function | X86_64.R8bH -> fun a -> M.op1 (Op.UnSetXBits (8, 8)) a | X86_64.R8bL -> fun a -> M.op1 (Op.UnSetXBits (8, 0)) a | X86_64.R16b -> fun a -> M.op1 (Op.UnSetXBits (16, 0)) a | X86_64.R32b | X86_64.R64b -> fun _a -> M.unitT V.zero in match r with | X86_64.Ireg (_, p) -> let sz = reg_size_to_mach_size p in read_reg false r ii >>= normalize_register_and_value p >>= fun nr -> M.op1 (Op.LeftShift (if p = X86_64.R8bH then 8 else 0)) v >>= fun nv -> M.op Op.Or nr nv >>= fun w -> write_loc sz plain (A.Location_reg (ii.A.proc,r)) w ii | _ -> write_loc nat_sz plain (A.Location_reg (ii.A.proc,r)) v ii let write_loc_gen sz an loc v ii = match loc with | A.Location_global l -> write_mem sz an l v ii | A.Location_reg (_, reg) -> write_reg reg v ii let write_mem_atomic sz a v ii = write_mem sz atomic a v ii let write_loc_atomic sz loc v ii = write_loc_gen sz (atomic_when_global loc) loc v ii let write_flag r o v1 v2 ii = M.addT (A.Location_reg (ii.A.proc,r)) (M.op o v1 v2) >>= (fun (loc,v) -> write_loc (reg_size_to_mach_size (X86_64.get_reg_size r)) plain loc v ii) let create_barrier b ii = M.mk_singleton_es (Act.Barrier b) ii let lval_ea ea ii = match ea with | X86_64.Effaddr_rm64 (X86_64.Rm64_reg r)-> M.unitT (X86_64.Location_reg (ii.A.proc,r)) | X86_64.Effaddr_rm64 (X86_64.Rm64_deref (r,o)) -> read_reg false r ii >>= fun v -> M.add v (V.intToV o) >>= fun vreg -> M.unitT (X86_64.Location_global vreg) | X86_64.Effaddr_rm64 (X86_64.Rm64_scaled (o1,r1,r2,o2)) -> (read_reg false r1 ii >>= fun v -> M.add v (V.intToV o1)) >>| (read_reg false r2 ii >>= fun v ->M.op Op.Mul v (V.intToV o2)) >>= fun (vreg,a) -> M.add vreg a >>= fun vreg -> M.unitT (X86_64.Location_global vreg) | X86_64.Effaddr_rm64 (X86_64.Rm64_abs v)-> M.unitT (X86_64.maybev_to_location v) let rval_ea sz locked ea ii = lval_ea ea ii >>= fun loc -> read_loc_gen sz true locked loc ii let rval_op sz locked op ii = match op with | X86_64.Operand_effaddr ea -> rval_ea sz locked ea ii | X86_64.Operand_immediate s -> M.unitT (V.intToV s) let flip_flag v = M.op Op.Xor v V.one (* Set flags by comparing v1 v2 *) let write_zf v1 v2 ii = write_flag (X86_64.Flag X86_64.ZF) Op.Eq v1 v2 ii let write_sf v1 v2 ii = write_flag (X86_64.Flag X86_64.SF) Op.Gt v1 v2 ii let write_all_flags v1 v2 ii = (write_zf v1 v2 ii >>| write_sf v1 v2 ii >>| write_flag (X86_64.Flag X86_64.CF) Op.Eq V.zero V.one ii) (* Carry was always zero! *) >>! () (* Exchange *) let xchg sz ea1 ea2 ii = (lval_ea ea1 ii >>| lval_ea ea2 ii) >>= (fun (l1,l2) -> let r1 = read_loc_atomic sz true l1 ii and r2 = read_loc_atomic sz true l2 ii and w1 = fun v -> write_loc_atomic sz l1 v ii and w2 = fun v -> write_loc_atomic sz l2 v ii in M.exch r1 r2 w1 w2) >>= B.next2T let cmpxchg sz locked ea r ii = lval_ea ea ii >>= fun loc_ea -> read_loc_gen sz true locked loc_ea ii >>= fun v_ea -> lval_ea (X86_64.Effaddr_rm64 (X86_64.Rm64_reg (X86_64.Ireg (X86_64.AX,X86_64.R64b)))) ii >>= fun loc_ra -> read_loc_gen sz true locked loc_ra ii >>= fun v_ra -> write_zf v_ea v_ra ii >>= fun _ -> rval_ea sz locked (X86_64.Effaddr_rm64 (X86_64.Rm64_reg r)) ii >>= fun v_r -> M.op Op.Eq v_ea v_ra >>= (fun vcf -> M.choiceT vcf (write_loc_gen sz locked loc_ea v_r ii) (write_loc_gen sz locked loc_ra v_ea ii)) >>= B.next1T let do_op sz locked x86_op ea op ii = let module A = X86_64 in let o = match x86_op with | A.I_ADD -> Op.Add | A.I_XOR -> Op.Xor | A.I_OR -> Op.Or | A.I_AND -> Op.And | A.I_SHL -> Op.ShiftLeft | (A.I_MOV|A.I_CMP) -> assert false in (lval_ea ea ii >>= fun loc -> M.addT loc (read_loc_gen sz true locked loc ii) >>| rval_op sz locked op ii) >>= fun ((loc,v_ea),v_op) -> M.op o v_ea v_op >>= fun v_result -> (write_loc_gen sz locked loc v_result ii >>| write_all_flags v_result V.zero ii) >>= B.next2T let clflush opt ea ii = lval_ea ea ii >>= fun a -> M.mk_singleton_es (Act.Arch (X86_64.ArchAction.ClFlush (opt,a))) ii let v2tgt = let open Constant in function | M.A.V.Val(Label (_, lbl)) -> Some (B.Lbl lbl) | M.A.V.Val (Concrete i) -> Some (B.Addr (M.A.V.Cst.Scalar.to_int i)) | _ -> None let do_indirect_jump test bds i v = match v2tgt v with | Some tgt -> M.unitT (B.Jump (tgt,bds)) | None -> match v with | M.A.V.Var(_) as v -> let lbls = get_exported_labels test in if Label.Full.Set.is_empty lbls then M.unitT () >>! B.Exit else B.indirectBranchT v lbls bds | _ -> Warn.fatal "illegal argument for the indirect branch instruction %s \ (must be a label)" (X86_64.dump_instruction i) let build_semantics test ii = let rec build_semantics_inner locked ii = match ii.A.inst with | X86_64.I_NOP -> B.nextT | X86_64.I_RET as i when C.variant Variant.Telechat -> read_reg true X86_64.RIP ii >>= do_indirect_jump test [] i | X86_64.I_EFF_OP (X86_64.I_CMP, sz, ea, op) -> let sz = inst_size_to_mach_size sz in (rval_ea sz locked ea ii >>| rval_op sz locked op ii) >>= fun (v_ea,v_op) -> write_all_flags v_ea v_op ii >>= B.next1T | X86_64.I_EFF_OP (X86_64.I_MOV, sz, ea, op) -> let sz = inst_size_to_mach_size sz in (lval_ea ea ii >>| rval_op sz locked op ii) >>= fun (loc,v_op) -> write_loc_gen sz locked loc v_op ii >>= B.next1T (* TODO add NTI annotation, at movnti is an ordinary store *) | X86_64.I_MOVNTI (sz,ea,r) -> let sz = inst_size_to_mach_size sz in (lval_ea ea ii >>| read_reg true r ii) >>= fun (loc,v) -> write_loc_gen sz X86_64.NonTemporal loc v ii >>= B.next1T | X86_64.I_EFF_OP (x86_op, sz, ea, op) -> let sz = inst_size_to_mach_size sz in do_op sz locked x86_op ea op ii (* Problem, it's not always xor but the parameter of I_EFF_OP *) | X86_64.I_EFF (X86_64.I_SETNB, sz, ea) -> let sz = inst_size_to_mach_size sz in (lval_ea ea ii >>| read_reg false (X86_64.Flag X86_64.CF) ii) >>= fun (loc,cf) -> flip_flag cf >>= fun v -> write_loc sz plain loc v ii >>= B.next1T | X86_64.I_EFF (inst, sz, ea) -> let sz = inst_size_to_mach_size sz in lval_ea ea ii >>= fun loc -> read_loc_gen sz true locked loc ii >>= fun v -> begin if inst = X86_64.I_DEC then M.op Op.Sub v V.one else M.add v V.one end >>= fun v -> (write_loc_gen sz locked loc v ii >>| write_sf v V.zero ii >>| write_zf v V.zero ii) >>= B.next3T | X86_64.I_CMOVC (sz,r,ea) -> let sz = inst_size_to_mach_size sz in read_reg false (X86_64.Flag X86_64.CF) ii >>*= (fun vcf -> M.choiceT vcf (rval_ea sz locked ea ii >>= fun vea -> write_reg r vea ii >>= B.next1T) B.nextT) | X86_64.I_JMP lbl -> B.branchT lbl (* Conditional branch, I need to look at doc for interpretation of conditions *) | X86_64.I_JCC (X86_64.C_LE,lbl) -> read_reg false (X86_64.Flag X86_64.SF) ii >>= (* control, data ? no event generated after this read anyway *) fun sf -> (* LE simply is the negation of GT, given by sign flag *) flip_flag sf >>= fun v -> B.bccT v lbl | X86_64.I_JCC (X86_64.C_LT,lbl) -> (read_reg false (X86_64.Flag X86_64.ZF) ii >>| (read_reg false (X86_64.Flag X86_64.SF) ii >>= flip_flag)) >>= fun (v1,v2) -> M.op Op.Or v1 v2 >>= fun v -> B.bccT v lbl | X86_64.I_JCC (X86_64.C_GE,lbl) -> (read_reg false (X86_64.Flag X86_64.ZF) ii >>| read_reg false (X86_64.Flag X86_64.SF) ii) >>= fun (v1,v2) -> M.op Op.Or v1 v2 >>= fun v -> B.bccT v lbl | X86_64.I_JCC (X86_64.C_GT,lbl) -> read_reg false (X86_64.Flag X86_64.SF) ii >>= fun v -> B.bccT v lbl | X86_64.I_JCC (X86_64.C_EQ,lbl) -> read_reg false (X86_64.Flag X86_64.ZF) ii >>= fun v -> B.bccT v lbl | X86_64.I_JCC (X86_64.C_NE,lbl) -> read_reg false (X86_64.Flag X86_64.ZF) ii >>= flip_flag >>= fun v -> B.bccT v lbl | X86_64.I_JCC (X86_64.C_S,lbl) -> read_reg false (X86_64.Flag X86_64.SF) ii >>= fun v -> B.bccT v lbl | X86_64.I_JCC (X86_64.C_NS,lbl) -> read_reg false (X86_64.Flag X86_64.SF) ii >>= flip_flag >>= fun v -> B.bccT v lbl | X86_64.I_LOCK inst -> begin let open X86_64 in match inst with | I_EFF_EFF _ | I_EFF_OP ((I_ADD | I_XOR), _, _, _) | I_EFF ((I_DEC | I_INC), _, _) | I_CMPXCHG _ -> build_semantics_inner atomic {ii with A.inst = inst} | _ -> Warn.user_error "Illegal lock prefix on instruction %s" (dump_instruction inst) end | X86_64.I_EFF_EFF (_,sz,ea1,ea2) -> let sz = inst_size_to_mach_size sz in xchg sz ea1 ea2 ii | X86_64.I_CMPXCHG (sz,ea,r) -> let sz = inst_size_to_mach_size sz in cmpxchg sz locked ea r ii | X86_64.I_FENCE f -> create_barrier f ii >>= B.next1T | X86_64.I_CLFLUSH (opt,ea) -> clflush opt ea ii >>= B.next1T | X86_64.I_MOVD _ | X86_64.I_RET | X86_64.I_MOVNTDQA _ as i -> Warn.fatal "X86_64Sem.ml: Instruction %s not implemented" (X86_64.dump_instruction i) in M.addT (A.next_po_index ii.A.program_order_index) (build_semantics_inner plain ii) let spurious_setaf _ = assert false end end herd-herdtools7-1ca343e/herd/XXXMem.mli000066400000000000000000000031071475314470400177160ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Common signature of PPCMem, X86Mem, ARMMem, for abstract usage *) module type S = sig val model : Model.t module S : Sem.Semantics val check_event_structure : S.test -> S.concrete -> ('a -> 'a) -> (S.concrete -> S.A.state * S.A.FaultSet.t -> (S.set_pp Lazy.t * S.rel_pp Lazy.t) -> Flag.Set.t (* Flags set during that execution *) -> 'a -> 'a) -> 'a -> 'a end herd-herdtools7-1ca343e/herd/access.ml000066400000000000000000000030421475314470400176560ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2021-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) type t = REG | VIR | PHY | PTE | TLB | TAG | PHY_PTE let pp = function | REG -> "REG" | VIR -> "VIR" | PHY -> "PHY" | PTE -> "PTE" | TLB -> "TLB" | TAG -> "TAG" | PHY_PTE -> "PHY_PTE" let is_physical = function | PHY|PHY_PTE -> true | REG|VIR|PTE|TLB|TAG -> false let compatible k1 k2 = match k1,k2 with | ((PTE|PHY_PTE),(PTE|PHY_PTE)) -> true | _,_ -> k1=k2 herd-herdtools7-1ca343e/herd/access.mli000066400000000000000000000026471475314470400200410ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2021-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** All sorts of accesses, redundant with symbol hidden in location, when symbol is known, which may not be the case *) type t = REG | VIR | PHY | PTE | TLB | TAG | PHY_PTE val pp : t -> string val is_physical : t -> bool val compatible : t -> t -> bool herd-herdtools7-1ca343e/herd/action.mli000066400000000000000000000076151475314470400200550ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** An architecture-independent interface for actions *) module type S = sig module A : Arch_herd.S type action val mk_init_write : A.location -> MachSize.sz -> A.V.v -> action val pp_action : action -> string (* Some architecture-specific sets and relations, with their definitions *) val arch_sets : (string * (action -> bool)) list val arch_rels : (string * (action -> action -> bool)) list (* To be deprecated *) val arch_dirty : (string * (DirtyBit.my_t -> action -> bool)) list (* control fence *) val is_isync : action -> bool val pp_isync : string (**************************************) (* Access to sub_components of events *) (**************************************) val value_of : action -> A.V.v option val read_of : action -> A.V.v option val written_of : action -> A.V.v option val location_of : action -> A.location option (************************) (* Predicates on events *) (************************) (* relative to memory *) val is_mem_store : action -> bool val is_mem_load : action -> bool val is_additional_mem_load : action -> bool (* trylock *) val is_mem : action -> bool val is_ifetch : action -> bool val is_tag : action -> bool val is_additional_mem : action -> bool (* abstract memory actions, eg locks *) val is_atomic : action -> bool val is_fault : action -> bool val to_fault : action -> A.fault option val get_mem_dir : action -> Dir.dirn val get_mem_size : action -> MachSize.sz val is_pte_access : action -> bool val is_explicit : action -> bool val is_not_explicit : action -> bool (* relative to the registers of the given proc *) val is_reg_store : action -> A.proc -> bool val is_reg_load : action -> A.proc -> bool val is_reg : action -> A.proc -> bool (* Reg events, proc not specified *) val is_reg_store_any : action -> bool val is_reg_load_any : action -> bool val is_reg_any : action -> bool (* Store/Load to memory or register *) val is_store : action -> bool val is_load : action -> bool (* Compatible accesses *) val compatible_accesses : action -> action -> bool (* for bell annotations *) val annot_in_list : string -> action -> bool (* Barriers *) val is_barrier : action -> bool val barrier_of : action -> A.barrier option val same_barrier_id : action -> action -> bool (* Commits *) val is_bcc : action -> bool val is_pred : ?cond:string option -> action -> bool val is_commit : action -> bool (* Unrolling control *) val cutoff : string -> action val is_cutoff : action -> bool val as_cutoff : action -> string option (********************) (* Equation solving *) (********************) val undetermined_vars_in_action : action -> A.V.ValueSet.t val simplify_vars_in_action : A.V.solution -> action -> action end herd-herdtools7-1ca343e/herd/archAction.ml000066400000000000000000000050601475314470400204720ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Action that are arch specific *) module type S = sig type t type v type loc type value_set type solution type arch_lannot type arch_explicit val pp : t -> string val get_lannot : t -> arch_lannot val get_explicit : t -> arch_explicit val value_of : t -> v option val read_of : t -> v option val written_of : t -> v option val location_of : t -> loc option val is_store : t -> bool val is_load : t -> bool val get_size: t -> MachSize.sz val get_kind : t -> Access.t val undetermined_vars : t -> value_set val simplify_vars : solution -> t -> t val sets : (string * (t -> bool)) list end module type NoConf = sig type v type loc type value_set type solution type arch_lannot type arch_explicit end module No(C:NoConf) = struct type t type v = C.v type loc = C.loc type value_set = C.value_set type solution = C.solution type arch_lannot = C.arch_lannot type arch_explicit = C.arch_explicit let pp _ = assert false let get_lannot _ = assert false let get_explicit _ = assert false let read_of _ = assert false let written_of _ = assert false let value_of _ = assert false let location_of _ = assert false let is_store _ = assert false let is_load _ = assert false let get_size _ = assert false let get_kind _ = assert false let undetermined_vars _ = assert false let simplify_vars _ = assert false let sets = [] end herd-herdtools7-1ca343e/herd/archExtra_herd.ml000066400000000000000000001063421475314470400213470ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Extra functionalities for all architectures *) (** Input signature, a reduced [Arch.ARCH] *) module type I = sig module V : Value.S val endian : Endian.t type arch_reg val pp_reg : arch_reg -> string val reg_compare : arch_reg -> arch_reg -> int val get_val : arch_reg -> V.v -> V.v val fromto_of_instr : V.Cst.Instr.t -> (Label.Set.t * Label.Set.t) option module FaultType : FaultType.S end (** Output signature, functionalities added *) module type S = sig val is_mixed : bool module I : I type global_loc = I.V.v type v = I.V.v type proc = Proc.t val pp_proc : proc -> string type program_order_index = int val pp_prog_order_index : program_order_index -> string val zero_po_index : program_order_index val next_po_index : program_order_index -> program_order_index include Location.S with type loc_reg := I.arch_reg and type loc_global := v type reg_state val reg_state_empty : reg_state val pp_reg_state : reg_state -> string (*********************************) (* Components of test structures *) (*********************************) (* Test structures represent programmes loaded in memory and ready to start, plus some items that describe the test, such as its name (cf. Test.mli) *) (* Code memory is a mapping from labels to sequences of instructions, too far from actual machine, maybe *) type instr = I.V.Cst.Instr.t type code = (int * instr) list val convert_if_imm_branch : int -> int -> int Label.Map.t -> int Label.Map.t -> instr -> instr (* Program loaded in memory *) type program = int Label.Map.t (* A starting address per proc *) type start_points = (proc * code * code option) list (* A mapping from code addresses to code *) type code_segment = (proc * code) IntMap.t (* A mapping from code addresses to sets of labels *) type entry_points = int -> Label.Set.t (* Constraints *) type prop = (location,v,I.FaultType.t) ConstrGen.prop type constr = prop ConstrGen.constr (* Register contents (when known) X size of last load exclusive *) type ii_env = { regs:reg_state; lx_sz:MachSize.sz option; fh_code:code option; } type inst_instance_id = { fetch_proc : proc; (* Fetching source *) proc : proc; (* Current thread *) program_order_index : program_order_index; inst : instr; labels : Label.Set.t; lbl2addr:program; addr : int; addr2v : string -> I.V.v; env : ii_env; in_handler : bool; } val inst_instance_compare : inst_instance_id -> inst_instance_id -> int val same_instruction : inst_instance_id -> inst_instance_id -> bool val pp_global : global_loc -> string val pp_location_old : location -> string val symbol : location -> Constant.symbol option val offset : location -> int option val symbolic_data : location -> Constant.symbolic_data option val of_symbolic_data : Constant.symbolic_data -> location (* Extra for locations *) val maybev_to_location : MiscParser.maybev -> location val do_dump_location : (string -> string) -> location -> string val do_dump_location_no_brackets : (string -> string) -> location -> string val dump_location : location -> string val undetermined_vars_in_loc_opt : location -> I.V.v option val undetermined_vars_in_loc : location -> I.V.ValueSet.t val simplify_vars_in_loc : I.V.solution -> location -> location val map_loc : (v -> v) -> location -> location val same_base_virt : location -> location -> bool (**********) (* Faults *) (**********) include Fault.S with type loc_global := v and type fault_type := I.FaultType.t (*********) (* State *) (*********) type state val state_empty : state val pp_state : state -> string val do_dump_state : (string -> string) -> state -> string val dump_state : state -> string val pp_nice_state : state -> string (* delim, as in String.concat *) -> (location -> v -> string) -> string val map_state : (v -> v) -> state -> state val build_state : (location * (TestType.t * v)) list -> state val build_concrete_state : (location * int) list -> state val state_is_empty : state -> bool val state_add : state -> location -> v -> state val state_add_if_undefined : state -> location -> v -> state val state_to_list : state -> (location * v) list val state_size : state -> int val state_fold : (location -> v -> 'a -> 'a) -> state -> 'a -> 'a val state_filter : (location -> bool) -> state -> state (* Exception raised when location is yet unknown *) exception LocUndetermined val look_address_in_state : state -> location -> v (******************) (* Register state *) (******************) val build_reg_state : proc -> I.arch_reg list -> state -> reg_state val look_reg : I.arch_reg -> reg_state -> I.V.v option val set_reg : I.arch_reg -> v -> reg_state -> reg_state val kill_regs : I.arch_reg list -> reg_state -> reg_state val fold_reg_state : (I.arch_reg -> v -> 'a -> 'a) -> reg_state -> 'a -> 'a (****************) (* Environments *) (****************) val size_of_t : string -> MachSize.sz val mem_access_size_of_t : TestType.t -> MachSize.sz val mask_type : TestType.t -> v -> v type size_env val size_env_empty : size_env val build_size_env : (location * (TestType.t * 'v)) list -> size_env val look_size : size_env -> string -> MachSize.sz val look_size_location : size_env -> location -> MachSize.sz type type_env val type_env_empty : type_env val build_type_env : (location * (TestType.t * 'v)) list -> type_env val look_type : type_env -> location -> TestType.t val look_rloc_type : type_env -> rlocation -> TestType.t val loc_of_rloc : type_env -> rlocation -> location (* Expand array rlocation to locations of its elements *) val locs_of_rloc : type_env -> rlocation -> location list (* Combine rlocs_of_rloc and value extraction from memory *) val val_of_rloc : (location -> v) -> type_env -> rlocation -> v (* Final state, our outcome *) type rstate val rstate_to_list : rstate -> (rlocation * v) list val rstate_filter : (rlocation -> bool) -> rstate -> rstate val debug_rstate : rstate -> string type final_state = rstate * FaultSet.t val do_dump_final_state : type_env -> FaultAtomSet.t -> (string -> string) -> final_state -> string (* Set of final states *) module StateSet : MySet.S with type elt = final_state (*****************************************) (* Size dependent items (for mixed-size) *) (*****************************************) module Mixed : functor (SZ : ByteSize.S) -> sig val endian : Endian.t val byte_sz : int val mask : string val nshift : int val nsz : MachSize.sz -> int (* decompose effective address increasing order, first arg is starting offset *) val byte_indices : int -> MachSize.sz -> int list (* decompose effective address increasing order, endianess order *) val byte_eas : MachSize.sz -> v -> v list val explode : MachSize.sz -> v -> v list val recompose : v list -> v (* Look what memory cell is bound to *) val look_in_state : size_env -> state -> location -> v val look_in_state_rlocs : rstate -> rlocation -> v (* State restriction to some locations *) val state_restrict_locs : bool (* keep all register bindings *) -> RLocSet.t -> type_env -> size_env -> state -> rstate end end module type Config = sig val verbose : int val texmacros : bool val hexa : bool val brackets : bool val variant : Variant.t -> bool val endian : Endian.t option val default_to_symb: bool end module Make(C:Config) (I:I) : S with module I = I = struct let is_mixed = C.variant Variant.Mixed || C.variant Variant.Morello module I = I type v = I.V.v module OV = struct type t = v let compare = I.V.compare end module VSet = MySet.Make(OV) module VMap = MyMap.Make(OV) type global_loc = v type proc = Proc.t let pp_proc = Proc.dump type program_order_index = int let pp_prog_order_index = string_of_int let zero_po_index = 0 let next_po_index po = po + 1 let pp_global = I.V.pp C.hexa module LocArg = struct type arch_reg = I.arch_reg let pp_reg = I.pp_reg let reg_compare = I.reg_compare type arch_global = v let pp_global = pp_global let global_compare = I.V.compare end include Location.Make (LocArg) module RegOrd = struct type t = I.arch_reg let compare = I.reg_compare end module RegMap = MyMap.Make(RegOrd) type reg_state = I.V.v RegMap.t let reg_state_empty = RegMap.empty let pp_reg_state = RegMap.pp_str_delim "; " (fun r v -> Printf.sprintf "%s->%s" (I.pp_reg r) (I.V.pp_v v)) (*********************************) (* Components of test structures *) (*********************************) (* Code memory is a mapping from globals locs, to instructions *) type instr = I.V.Cst.Instr.t type code = (int * instr) list (* This function is a default behaviour for all architectures. When variant -self is enabled, it fails trying to convert a branch instruction to a label into a branch-with-offset representation. *) let convert_if_imm_branch _ _ _ _ i = if C.variant Variant.Ifetch then Warn.fatal "Functionality %s not implemented for -variant self" "convert_if_imm_branch" else i (* Programm loaded in memory *) type program = int Label.Map.t (* A starting address per proc *) type start_points = (proc * code * code option) list (* Mapping from code addresses to code *) type code_segment = (proc * code) IntMap.t (* A mapping from code addresses to sets of labels *) type entry_points = int -> Label.Set.t (* Constraints *) type prop = (location,v,I.FaultType.t) ConstrGen.prop type constr = prop ConstrGen.constr type ii_env = { regs:reg_state; lx_sz:MachSize.sz option; fh_code:code option; } type inst_instance_id = { fetch_proc : proc; proc : proc; program_order_index : program_order_index; inst : instr; labels : Label.Set.t; lbl2addr : program; addr : int ; addr2v : string -> I.V.v; env : ii_env; in_handler : bool; } let inst_instance_compare i1 i2 = match Misc.int_compare i1.proc i2.proc with | 0 -> begin Misc.int_compare i1.program_order_index i2.program_order_index end | r -> r let same_instruction i1 i2 = i1.inst == i2.inst let symbol loc = let open Constant in match global loc with | Some (I.V.Val (Symbolic sym)) -> Some sym | _ -> None let offset loc = let open Constant in match symbol loc with | Some (Virtual si) -> Some si.offset | Some (Physical (_,o)) -> Some o | Some _ -> Some 0 | None -> None let symbolic_data loc = let open Constant in match global loc with | Some (I.V.Val (Symbolic (Virtual sym))) -> Some sym | _ -> None let of_symbolic_data s = Location_global (I.V.Val (Constant.of_symbolic_data s)) let maybev_to_location v = Location_global (I.V.maybevToV v) let do_brackets = if C.brackets then Printf.sprintf "[%s]" else fun s -> s let do_dump_location tr = function | Location_reg (proc,r) -> tr (string_of_int proc ^ ":" ^ I.pp_reg r) | Location_global a -> do_brackets (pp_global a) let dump_location = do_dump_location Misc.identity let do_dump_location_no_brackets tr = function | Location_reg (proc,r) -> tr (string_of_int proc ^ ":" ^ I.pp_reg r) | Location_global a -> pp_global a let do_pp_location do_brackets l = match l with | Location_reg (proc,r) -> let bodytext = string_of_int proc ^ ":" ^ I.pp_reg r in if C.texmacros then "\\asm{Proc " ^ bodytext ^ "}" else bodytext | Location_global a -> do_brackets (pp_global a) (* This redefines pp_location from Location.Make ... *) let pp_location = do_pp_location do_brackets and pp_location_old = do_pp_location Misc.identity let some_undetermined_vars_in_loc l = match l with | Location_reg _ -> false | Location_global a -> not (I.V.is_var_determined a) let undetermined_vars_in_loc_opt l = match l with | Location_reg _ | Location_global (I.V.Val _) -> None | Location_global (I.V.Var _ as v) -> Some v let undetermined_vars_in_loc l = match l with | Location_reg _ -> I.V.ValueSet.empty | Location_global a -> I.V.undetermined_vars a let simplify_vars_in_loc soln l = match l with | Location_reg _ -> l | Location_global a -> Location_global (I.V.simplify_var soln a) let map_loc fv loc = match loc with | Location_reg _ -> loc | Location_global a -> Location_global (fv a) (*********) (* Fault *) (*********) module FaultArg = struct include LocArg open Constant (* Compare id in fault and other id, at least one id must be allowed in fault *) let same_sym_fault sym1 sym2 = match sym1,sym2 with (* Both ids allowed in fault, compare *) |(Virtual {name=s1;_},Virtual {name=s2;_}) |(System (PTE,s1),System (PTE,s2)) -> Misc.string_eq s1 s2 (* One id allowed, the other on forbidden, does not match *) | (Virtual _,(System ((PTE|TLB|PTE2),_)|Physical _|TagAddr _)) | ((TagAddr _|Physical _|System ((PTE|TLB|PTE2),_)),Virtual _) | (System (PTE,_),System ((TLB|PTE2),_)) | (System ((TLB|PTE2),_),System (PTE,_)) | ((Physical _|TagAddr _),System (PTE,_)) | (System (PTE,_),(TagAddr _|Physical _)) -> false (* Both forbidden, failure *) | (TagAddr _|Physical _|System ((TLB|PTE2),_)), (TagAddr _|Physical _|System ((TLB|PTE2),_)) -> Warn.fatal "Illegal id (%s or %s) in fault" (pp_symbol sym1) (pp_symbol sym2) let same_id_fault v1 v2 = match v1,v2 with | I.V.Val (Symbolic sym1), I.V.Val (Symbolic sym2) -> same_sym_fault sym1 sym2 | I.V.Val (Constant.Label (_, l1)),I.V.Val (Constant.Label (_, l2)) -> Misc.string_eq l1 l2 | I.V.Val (Symbolic _), I.V.Val (Constant.Label (_, _)) | I.V.Val (Constant.Label (_, _)), I.V.Val (Symbolic _) -> false | _,_ -> Warn.fatal "Illegal value (%s or %s) in fault" (I.V.pp_v v1) (I.V.pp_v v2) type fault_type = I.FaultType.t let pp_fault_type = I.FaultType.pp let fault_type_compare = I.FaultType.compare end include Fault.Make(FaultArg) let same_base_virt loc1 loc2 = match loc1,loc2 with | Location_global v1,Location_global v2 -> FaultArg.same_id_fault v1 v2 | _,_ -> false (************************) (* Mixed size utilities *) (************************) module State = LocMap type state = v State.t let state_empty = State.empty let state_add st l v = State.add l v st let state_add_if_undefined st l v = try ignore (State.find l st); Warn.fatal "Address %s non-unique in init state" (dump_location l) with Not_found -> State.add l v st let state_is_empty = State.is_empty let state_to_list st = List.rev (State.fold (fun l v k -> (l,v)::k) st []) let state_size st = State.fold (fun _ _ k -> 1+k) st 0 let state_fold = State.fold let state_filter = State.filter let pp_nice_state st delim pp_bd = let bds = State.fold (fun l v k -> (pp_bd l v)::k) st [] in String.concat delim (List.rev bds) let pp_equal = if C.texmacros then "\\mathord{=}" else "=" let pp_state st = pp_nice_state st " " (fun l v -> pp_location l ^ pp_equal ^ I.V.pp C.hexa v ^";") let get_val loc v = match loc with | Location_reg (_,reg) -> I.get_val reg v | _ -> v let do_dump_state tr st = pp_nice_state st " " (fun l v -> do_dump_location tr l ^ "=" ^ I.V.pp C.hexa (get_val l v) ^";") let dump_state st = do_dump_state Misc.identity st let map_state f st = State.map f st (******************) (* Register state *) (******************) let reg_default_value = I.V.zero let build_reg_state p defaults st = List.fold_right (fun r -> RegMap.add r reg_default_value) defaults RegMap.empty |> LocMap.fold (fun loc v k -> match loc with | Location_reg (q,r) when Proc.equal p q -> RegMap.add r v k | _ -> k) st let look_reg r st = RegMap.find_opt r st let set_reg r v st = RegMap.add r v st let kill_regs rs st = List.fold_right RegMap.remove rs st let fold_reg_state = RegMap.fold (****************) (* Environments *) (****************) let size_of_t = TestType.size_of I.V.Cst.Scalar.machsize let mem_access_size_of_t t = let open TestType in match t with | Atomic b|Ty b|TyArray (b,_) -> if b = "ins_t" then MachSize.Word (* Ok for most archs... *) else size_of_t b | TyDef -> size_of_t TestType.default | TyDefPointer|Pointer _ -> I.V.Cst.Scalar.machsize let mask_type t v = let sz = mem_access_size_of_t t in I.V.map_scalar (I.V.Cst.Scalar.mask sz) v let signed_of_t t = let open TestType in match t with | Atomic b|Ty b|TyArray (b,_) -> is_signed b | TyDef -> true | TyDefPointer|Pointer _ -> false let build_state bds = List.fold_left (fun st (loc,(t,v)) -> match t with | TestType.TyArray (array_prim,total_size) -> begin (* we expand v[3] = {a,b,c} into v+0 = a; v+1 = b; v+2 = c*) (* where 1 is the sizeof the underlying primitive type *) (* e.g uint64_t -> 8 bytes, so the above is v, v+8, v+16 *) let vs = match v with | I.V.Val (Constant.ConcreteVector vs) -> if Misc.int_eq (List.length vs) total_size then vs else Warn.user_error "Vector size mismatch, %s (exepected size %d)\n" (I.V.pp_v v) total_size | _ -> Warn.user_error "Unexpected scalar value %s, vector expected" (I.V.pp_v v) in let locval = match global loc with | Some x -> x | _ -> Warn.user_error "Non-global vector assignment in init" in let prim_sz = size_of_t array_prim in let nbytes = MachSize.nbytes prim_sz in let vs = List.mapi (fun i v -> let s = I.V.pp false locval in let tag = None in let cap = 0L in let sym_data = { Constant.name=s ; tag=tag ; cap=cap ; offset=i*nbytes} in of_symbolic_data sym_data,(TestType.Ty array_prim,I.V.cstToV v)) vs in List.fold_left (fun st (loc,(_,v))-> state_add_if_undefined st loc v) st vs end (* if we have a value, store it *) | _ -> state_add_if_undefined st loc v) State.empty bds let build_concrete_state bds = List.fold_left (fun st (loc,v) -> State.add loc (I.V.intToV v) st) State.empty bds (* We might have accesses in the final state like v[2] *) (* this depends on the size of the vector types in the initial state *) (* e.g when uint64_t v, each elem is 8 bytes, so 2*8 is 16 bytes offset*) (* This function scales the offset from type information, *) (* Raises User_error, if not an array or pointer type or *) (* in case of out of bounds access. *) let size_of_array t = let open TestType in match t with | TyArray (t,sz) -> Some (size_of_t t,sz) | TyDefPointer -> Some (MachSize.Word,1) | Pointer t -> Some (size_of_t t,1) | _ -> None (* Fails with user error when t is not an array type or in case of out-of-bound access *) let scale_array_reference t loc os = let sz_elt,n_elts = match size_of_array t with | Some (a,b) -> (a,b) | None -> Warn.user_error "Location %s of type %s is used as an array" (pp_location_old loc) (TestType.pp t) in if os < 0 || os >= n_elts then Warn.user_error "Out of bounds access on array %s" (pp_location_old loc) ; if os = 0 then loc else match symbolic_data loc with | Some s -> let s = { s with Constant.offset = MachSize.nbytes sz_elt * os} in of_symbolic_data s | _ -> (* Excluded by parsing *) Warn.fatal "Location %s is not global" (pp_location_old loc) (* To get protection against wandering undetermined locations, all loads from state are by this function *) exception LocUndetermined let get_in_state loc st = try get_val loc (State.find loc st) with Not_found -> let open Constant in if C.default_to_symb then I.V.fresh_var () else match loc with | Location_global (I.V.Var _) (* As called from look_address_in_state below *) -> assert false | Location_global (I.V.Val (Symbolic (System (PTE,s)))) -> I.V.Val (PteVal (I.V.Cst.PteVal.default s)) | Location_global (I.V.Val (Symbolic (TagAddr _))) -> I.V.Val default_tag | Location_global (I.V.Val (Symbolic (System ((PTE2|TLB),_)))) -> Warn.user_error "No default value defined for location %s\n" (pp_location loc) | Location_global (I.V.Val (Concrete _|ConcreteVector _|ConcreteRecord _ |Label _|Instruction _|Frozen _ |Tag _|PteVal _)) -> Warn.user_error "Very strange location (look_address) %s\n" (pp_location loc) | Location_global (I.V.Val (Symbolic (Virtual _|Physical _))) | Location_reg _ -> reg_default_value let get_of_val st a = State.safe_find I.V.zero (Location_global a) st let look_address_in_state st loc = if some_undetermined_vars_in_loc loc then (* if loc is not determined, then we cannot get its content yet *) raise LocUndetermined else get_in_state loc st (* Sizes *) type size_env = MachSize.sz StringMap.t let size_env_empty = StringMap.empty let look_size env s = StringMap.safe_find MachSize.Word s env let look_size_location env loc = match symbolic_data loc with | Some {Constant.name=s;_} -> look_size env s | _ -> assert false let build_size_env bds = List.fold_left (fun m (loc,(t,_)) -> match symbolic_data loc with | Some sym -> StringMap.add sym.Constant.name (mem_access_size_of_t t) m | _ -> m) size_env_empty bds (* Types *) type type_env = TestType.t LocMap.t let type_env_empty = LocMap.empty let build_type_env bds = List.fold_left (fun m (loc,(t,_)) -> LocMap.add loc t m) type_env_empty bds let look_type m loc = LocMap.safe_find TestType.TyDef loc m let look_rloc_type m rloc = let open ConstrGen in match rloc with | Loc loc -> look_type m loc | Deref (loc,_) -> let t = look_type m loc in TestType.Ty (TestType.get_array_primitive_ty t) let loc_of_rloc tenv = let open ConstrGen in function | Loc loc -> loc | Deref (loc,o) -> let t = look_type tenv loc in scale_array_reference t loc o let locs_of_rloc tenv rloc = let open ConstrGen in match rloc with | Loc loc -> begin let t = look_type tenv loc in match t with | TestType.TyArray (_,sz) -> let rec do_rec o = if o >= sz then [] else scale_array_reference t loc o::do_rec (o+1) in do_rec 0 | _ -> [loc] end | Deref (loc,o) -> let t = look_type tenv loc in [scale_array_reference t loc o] let demote = function | I.V.Var _ as v -> v | I.V.Val c -> I.V.Val (Constant.map_scalar I.V.Cst.Scalar.demote c) let val_of_rloc look tenv rloc = match locs_of_rloc tenv rloc with | [loc] -> look loc |> demote | locs -> let cs = List.map (fun loc -> match look loc|> demote with | I.V.Val c -> c | I.V.Var v -> I.V.freeze v) locs in I.V.Val (Constant.ConcreteVector cs) (* Final (include faults) *) module RState = RLocMap type rstate = v RState.t let rstate_to_list st = List.rev (RState.fold (fun l v k -> (l,v)::k) st []) let rstate_filter = RState.filter let debug_rstate rs = let bds = rstate_to_list rs in List.map (fun (loc,v) -> Printf.sprintf "%s -> %s" (pp_rlocation loc) (I.V.pp true v)) bds |> String.concat "; " type final_state = rstate * FaultSet.t let pp_nice_rstate st delim pp_bd = let bds = RState.fold (fun l v k -> (pp_bd l v)::k) st [] in String.concat delim (List.rev bds) (* Scalars are always for the same effective type, (V.Cst.Scalar.t). For printing a scalar of "external" type t, the value itself is changed, masking for unsigned types, sign extension for signed types. However, in hexadecimal all scalars are seen as unsigned. *) let cast_for_pp_with_base b sc = let sz = size_of_t b in if sz = I.V.Cst.Scalar.machsize then sc else if TestType.is_signed b && not C.hexa then I.V.Cst.Scalar.sxt sz sc else I.V.Cst.Scalar.mask sz sc let cast_for_pp_with_type t = let open TestType in match t with | Atomic b|Ty b|TyArray (b,_) -> cast_for_pp_with_base b | TyDef -> cast_for_pp_with_base TestType.default | Pointer _|TyDefPointer -> Misc.identity let pp_typed t v = let max_unsigned = MachSize.equal (mem_access_size_of_t t) I.V.Cst.Scalar.machsize && not (signed_of_t t) in let v = I.V.map_scalar (cast_for_pp_with_type t) v in if max_unsigned then I.V.pp_unsigned C.hexa v else I.V.pp C.hexa v let do_dump_rstate tenv tr st = pp_nice_rstate st " " (fun l v -> let t = look_rloc_type tenv l in let dump_loc = let open ConstrGen in match l,t with | (Deref _,_) | (_,TestType.TyArray _) -> do_dump_location_no_brackets | _,_ -> do_dump_location in ConstrGen.dump_rloc (dump_loc tr) l ^ "=" ^ pp_typed t v ^";") let do_dump_final_state tenv fobs tr (st,flts) = let pp_st = do_dump_rstate tenv tr st in if FaultSet.is_empty flts && FaultAtomSet.is_empty fobs then pp_st else let noflts = FaultAtomSet.fold (fun (((p,lbl),loc,ftype) as f0) k -> if FaultSet.exists (fun f -> check_one_fatom f f0) flts then k else let tr_lbl = match lbl with | None -> Label.Set.empty | Some lbl -> Label.Set.singleton lbl in (" ~" ^ pp_fault (((p,tr_lbl),loc,ftype,None)) ^ ";")::k) fobs [] in let flts = if !Opts.dumpallfaults then flts else FaultSet.filter (fun f -> FaultAtomSet.exists (fun f0 -> check_one_fatom f f0) fobs) flts in pp_st ^ " " ^ FaultSet.pp_str " " (fun f -> pp_fault f ^ ";") flts ^ String.concat "" noflts module StateSet = MySet.Make (struct type t = final_state let compare (st1,flt1) (st2,flt2) = match RState.compare I.V.compare st1 st2 with | 0 -> FaultSet.compare flt1 flt2 | r -> r end) module Mixed (SZ : ByteSize.S) = struct let morello = C.variant Variant.Morello let byte = SZ.byte let endian = match C.endian with | None -> I.endian | Some e -> e let byte_sz = MachSize.nbytes byte let mask = match byte_sz with | 1 -> "0xff" | 2 -> "0xffff" | 4 -> "0xffffffff" | 8 -> "0xffffffffffffffff" | _ -> Warn.user_error "Size cannot be %s in mixed-size mode" (MachSize.pp byte) let nshift = MachSize.nbits byte let nsz sz = let n = MachSize.nbytes sz in if n < byte_sz then Warn.fatal "Size mismatch %s smaller than %s\n" (MachSize.debug sz) (MachSize.debug byte) ; assert (n mod byte_sz = 0) ; n / byte_sz let byte_indices o sz = let kmax = nsz sz in let rec do_rec k = if k >= kmax then [] else let ds = do_rec (k+1) in let d = k*byte_sz in o+d::ds in o::do_rec 1 let byte_eas_incr sz a = let kmax = nsz sz in let rec do_rec k = if k >= kmax then [] else let ds = do_rec (k+1) in let d = I.V.op1 (Op.AddK (k*byte_sz)) a in d::ds in a::do_rec 1 let byte_eas sz a = let r = byte_eas_incr sz a in match endian with | Endian.Little -> r | Endian.Big -> List.rev r let explode sz v = let rec do_rec k v = if k <= 1 then [I.V.op1 (Op.AndK mask) v] else let d = I.V.op1 (Op.AndK mask) v and w = I.V.op1 (Op.LogicalRightShift nshift) v in let ds = do_rec (k-1) w in d::ds in do_rec (nsz sz) v let rec recompose ds = match ds with | [] -> assert false | [d] -> d | d::ds -> let w = recompose ds in I.V.op Op.Or (I.V.op1 (Op.LeftShift nshift) w) d let look_in_state_mixed senv st loc = if some_undetermined_vars_in_loc loc then (* if loc is not determined, then we cannot get its content yet *) raise LocUndetermined else let open Constant in match loc with | Location_global (I.V.Val (Symbolic (Virtual {name=s; offset=_;_})) as a) -> let sz = look_size senv s in let eas = byte_eas sz a in let vs = List.map (get_of_val st) eas in let v = recompose vs in if morello then let ts = get_of_val st (I.V.op1 Op.CapaTagLoc a) in I.V.op Op.CapaSetTag v ts else v | Location_global (I.V.Val (Symbolic (TagAddr _))) -> get_in_state loc st | _ -> (* No mixed variant combination other than mte and morello *) if is_global loc then begin Warn.user_error "Cannot handle %s in mixed-size mode" (pp_location loc) end ; get_in_state loc st let look_in_state = if is_mixed || morello then look_in_state_mixed else fun _senv -> look_address_in_state (* No need for size-env when sizes are ignored *) let look_in_state_rlocs st rloc = if is_mixed || morello then Warn.fatal "Mixed-size look_in_state_rloc not implemented" else try RState.find rloc st with Not_found -> assert false (* Can be seen as performing two actions: 1. Change rloc into actual locations 2. Eliminate binding whose location is not listed in locs *) let reg_rlocs st = State.fold (fun loc _ k -> match loc with | Location_reg _ -> RLocSet.add (ConstrGen.Loc loc) k | Location_global _ -> k) st RLocSet.empty let add_reg_locs keep_regs st locs = if keep_regs then RLocSet.union (reg_rlocs st) locs else locs let do_state_restrict look keep_regs locs tenv st = RLocSet.fold (fun rloc r -> let v = val_of_rloc (look st) tenv rloc in RState.add rloc v r) (add_reg_locs keep_regs st locs) RState.empty let state_restrict_locs_non_mixed keep_regs locs tenv _ st = do_state_restrict look_address_in_state keep_regs locs tenv st let state_restrict_locs_mixed keep_regs locs tenv senv st = do_state_restrict (look_in_state_mixed senv) keep_regs locs tenv st let state_restrict_locs = if is_mixed || morello then state_restrict_locs_mixed else state_restrict_locs_non_mixed end end herd-herdtools7-1ca343e/herd/arch_herd.mli000066400000000000000000000047651475314470400205220ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Basic arch, ie with no definition of what a global location is *) module type Config = ArchExtra_herd.Config module type S = sig include ArchBase.S module V : Value.S with type Cst.Instr.t = instruction val is_amo : instruction -> bool val pp_barrier_short : barrier -> string val reject_mixed : bool (* perform a check that rejects mixed-size tests *) val mem_access_size : instruction -> MachSize.sz option val opt_env : bool (* environemnt optimisation is available *) val killed : instruction -> reg list val get_lx_sz : instruction -> MachSize.lr_sc (* Those register are to be initialised to the default value explicitly *) val reg_defaults : reg list include ArchExtra_herd.S with module I.V = V and type I.arch_reg = reg (* Levels are abstract, for AArch64, they are E0 to E3 *) type level val levels : level list val pp_level : level -> string module TLBI : sig type op val pp_op : op -> string val is_at_level : level -> op -> bool val inv_all : op -> bool val sets : (string * (op -> bool)) list end val convert_if_imm_branch : int -> int -> int Label.Map.t -> int Label.Map.t -> instruction -> instruction module MemType:MemoryType.S module Barrier:AllBarrier.S with type a = barrier module CMO:Cmo.S end herd-herdtools7-1ca343e/herd/branch.ml000066400000000000000000000066601475314470400176630ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Branching in code *) module type S = sig type lbl = Label.t (* From arch *) type reg type v (* t monad controls the branch machinery *) type 'a monad (* Branch information, result of our instruction semantics *) type tgt = Lbl of lbl | Addr of int type bds = (reg * v) list type t = (* continue in sequence, setting registers *) | Next of bds (* jump to arg *) | Jump of tgt * bds (* if v is one, jump to address, otherwise continue in sequence *) | CondJump of v * tgt (* Indirect Jump, with potential targets *) | IndirectJump of v * Label.Full.Set.t * bds (* Stop now *) | Exit (* Raise Fault *) | Fault of bds (* Return from Fault Handler *) | FaultRet of tgt (* Next instruction in sequence *) val nextT : t monad val next1T : unit -> t monad val next2T : (unit * unit) -> t monad val next3T : ((unit * unit) * unit) -> t monad val next4T : (((unit * unit) * unit) * unit) -> t monad val nextSetT : reg -> v -> t monad (* Non-conditional branch *) val branchT : lbl -> t monad (* Indirect branch *) val indirectBranchT : v -> Label.Full.Set.t -> bds -> t monad (* Conditional branch *) val bccT : v -> lbl -> t monad val faultRetT : lbl -> t monad end module Make(M:Monad.S) = struct type lbl = Label.t type reg = M.A.reg type v = M.A.V.v type 'a monad = 'a M.t type tgt = Lbl of lbl | Addr of int type bds = (reg * v) list type t = (* continue in sequence *) | Next of bds (* jump to arg *) | Jump of tgt * bds (* if v is one, jump to address, otherwise continue in sequence *) | CondJump of v * tgt (* Indirect Jump, with potential targets *) | IndirectJump of v * Label.Full.Set.t * bds (* Stop now *) | Exit (* Raise Fault *) | Fault of bds (* Return from Fault Handler *) | FaultRet of tgt (* Utilities *) let nextT = M.unitT (Next []) let next1T () = nextT let next2T ((),()) = nextT let next3T (((),()),()) = nextT let next4T ((((),()),()), ()) = nextT let nextSetT r v = M.unitT (Next [r,v]) let branchT tgt = M.unitT (Jump (Lbl tgt,[])) let indirectBranchT v lbls bds = M.unitT (IndirectJump (v,lbls,bds)) let bccT v lbl = M.unitT (CondJump (v,Lbl lbl)) let faultRetT lbl = M.unitT (FaultRet (Lbl lbl)) end herd-herdtools7-1ca343e/herd/byteSize.ml000066400000000000000000000023231475314470400202140ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2019-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module type S = sig val byte : MachSize.sz end herd-herdtools7-1ca343e/herd/cmo.ml000066400000000000000000000024571475314470400172040ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module type S = sig type t val pp : t -> string option -> string end module No = struct type t = unit let pp _ _ = assert false end herd-herdtools7-1ca343e/herd/cmo.mli000066400000000000000000000024131475314470400173450ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module type S = sig type t val pp : t -> string option -> string end module No : S with type t=unit herd-herdtools7-1ca343e/herd/constraints.ml000066400000000000000000000265041475314470400207740ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Constraints in litmus files *) open Printf module type Config = sig val texmacros : bool val hexa : bool end module type S = sig module A : Arch_herd.S type final_state = A.rstate * A.FaultSet.t type prop = (A.location,A.V.v,A.I.FaultType.t) ConstrGen.prop val ptrue : prop type constr = prop ConstrGen.constr (* Does loc appears in constr ? *) (* val loc_in : A.location -> constr -> bool *) val foralltrue : constr module Mixed : functor (SZ: ByteSize.S) -> sig (* Check state *) val check_prop : prop -> A.type_env -> A.size_env -> A.state * A.FaultSet.t -> bool val check_prop_rlocs : prop -> A.type_env -> final_state -> bool end (* Build a new constraint thar checks State membership *) val constr_of_finals : A.StateSet.t -> constr (* Parsable dumping *) val dump_as_kind : 'a ConstrGen.constr -> string val do_dump_constraints : (string -> string) -> out_channel -> constr -> unit val dump_constraints : out_channel -> constr -> unit val constraints_to_string : constr -> string (* Nice printing *) val pp_as_kind : 'a ConstrGen.constr -> string val pp_constraints : PPMode.t -> constr -> string end open ConstrGen module Make (C:Config) (A : Arch_herd.S) : S with module A = A = struct let dbg = false module A = A type final_state = A.rstate * A.FaultSet.t (************ Constraints ********************) module V = A.V type prop = (A.location,A.V.v,A.I.FaultType.t) ConstrGen.prop let ptrue : prop = And [] type constr = prop ConstrGen.constr let foralltrue = ForallStates ptrue let loc_in_atom loc = function | LL (l1,l2) -> A.location_compare l1 loc = 0 || A.location_compare l2 loc = 0 | LV (l,_) -> A.location_compare (loc_of_rloc l) loc = 0 | FF (_,None,_) -> false | FF (_,Some x,_) -> A.location_compare (A.Location_global x) loc = 0 let rec loc_in_prop loc p = match p with | Atom a -> loc_in_atom loc a | Not p -> loc_in_prop loc p | And ps|Or ps -> loc_in_props loc ps | Implies (p1,p2) -> loc_in_prop loc p1 || loc_in_prop loc p2 and loc_in_props loc = List.exists (loc_in_prop loc) let _loc_in loc c = match c with | ForallStates p | ExistsState p | NotExistsState p -> loc_in_prop loc p module Mixed (SZ : ByteSize.S) = struct module AM = A.Mixed(SZ) let do_check_prop look_type look_val flts = let rec do_rec = function | Atom (LV (rloc,v0)) -> let t = look_type rloc in let w0 = look_val rloc in let v = A.mask_type t v0 and w = A.mask_type t w0 in if dbg then Printf.eprintf "Loc:(%s:%s) -> %s[%s] = %s[%s]\n%!" (A.pp_rlocation rloc) (TestType.pp t) (A.V.pp_v w) (A.V.pp_v w0) (A.V.pp_v v) (A.V.pp_v v0); A.V.equal v w | Atom (LL (l1,l2)) -> let v1 = look_val (Loc l1) and v2 = look_val (Loc l2) in A.V.compare v1 v2 = 0 | Atom (FF f) -> A.check_fatom flts f | Not p -> not (do_rec p) | And ps -> List.for_all do_rec ps | Or ps -> List.exists do_rec ps | Implies (p1, p2) -> not (do_rec p1) || do_rec p2 in fun p -> try do_rec p with A.LocUndetermined -> assert false let check_prop p tenv senv (state,flts) = let look_val rloc = A.val_of_rloc (AM.look_in_state senv state) tenv rloc in do_check_prop (A.look_rloc_type tenv) look_val flts p let check_prop_rlocs p tenv (state,flts) = let look_val rloc = AM.look_in_state_rlocs state rloc in do_check_prop (A.look_rloc_type tenv) look_val flts p end let matrix_of_states fs = A.StateSet.fold (fun (f,_) k -> A.rstate_to_list f::k) fs [] let best_col m = let mt = Misc.transpose m in let cs = List.map (fun col -> let vs = List.map (fun (_,v) -> v) col in V.ValueSet.cardinal (V.ValueSet.of_list vs)) mt in let rec best_rec k (kb,b as p) = function | [] -> kb | c::cs -> if c < b then best_rec (k+1) (k,c) cs else best_rec (k+1) p cs in best_rec 0 (-1,max_int) cs let swap_list = let rec swap_list k prev xs = match xs with | [] -> assert false | x::xs -> if k <= 0 then x::List.rev_append prev xs else swap_list (k-1) (x::prev) xs in fun k xs -> swap_list k [] xs let swap_col k m = let mt = Misc.transpose m in let mt = swap_list k mt in Misc.transpose mt let extract_column xss = match xss with | []|[]::_ -> assert false | ((loc0,_)::_)::_ -> loc0, List.map (fun row -> match row with | (loc,v)::ps -> assert (A.rlocation_compare loc0 loc = 0) ; v,ps | [] -> assert false) xss let group_rows ps = List.fold_left (fun m (v,ps) -> let pss = try V.ValueMap.find v m with Not_found -> [] in V.ValueMap.add v (ps::pss) m) V.ValueMap.empty ps let rec compile_cond m = let k = best_col m in let loc,ps = extract_column (swap_col k m) in let m = group_rows ps in match ps with | [] -> assert false | (_,[])::_ -> Or (V.ValueMap.fold (fun v _ k -> Atom (LV (loc,v))::k) m []) | _ -> Or (V.ValueMap.fold (fun v m k -> And [Atom (LV (loc,v));compile_cond m]::k) m []) let cond_of_finals fs = compile_cond (matrix_of_states fs) let constr_of_finals fs = ForallStates (cond_of_finals fs) (* Pretty print *) open PPMode let pp_equal m = match m with | Ascii|Dot -> "=" | Latex -> "\\mathord{=}" | DotFig -> "\\\\mathord{=}" let pp_true m = match m with | Ascii|Dot -> "true" | Latex -> "\\top" | DotFig -> "\\\\top" let pp_false m = match m with | Ascii|Dot -> "false" | Latex -> "\\perp" | DotFig -> "\\\\perp" let pp_not m = match m with | Ascii|Dot -> "not" | Latex -> "\\neg" | DotFig -> "\\\\neg" let pp_and m = match m with | Ascii -> "/\\" | Dot -> "/\\\\" | Latex -> "\\mywedge" | DotFig -> "\\\\mywedge" let pp_or m = match m with | Ascii -> "\\/" | Dot -> "\\\\/" | Latex -> "\\vee" | DotFig -> "\\\\vee" let pp_implies m = match m with | Ascii|Dot -> "=>" | Latex -> "\\Rightarrow" | DotFig -> "\\\\Rightarrow" let mbox m s = match m with | Ascii|Dot -> s | Latex -> "\\mbox{" ^ s ^ "}" | DotFig -> "\\\\mbox{" ^ s ^ "}" let pp_loc tr m loc = match m with | Ascii|Dot -> A.do_dump_location tr loc | Latex|DotFig -> A.pp_location loc let pp_rloc tr m rloc = ConstrGen.dump_rloc (pp_loc tr m) rloc let pp_loc_no_brk tr m loc = match m with | Ascii|Dot -> A.do_dump_location_no_brackets tr loc | Latex|DotFig -> A.pp_location loc let pp_rloc_no_brk tr m rloc = ConstrGen.dump_rloc (pp_loc_no_brk tr m) rloc let do_add_asm m = match m with | Ascii|Dot -> Misc.identity | Latex|DotFig when not C.texmacros -> Misc.identity | Latex -> sprintf "\\asm{%s}" | DotFig -> sprintf "\\\\asm{%s}" let pp_atom tr m a = match a with | LV (Deref _ as rloc,v) | LV (rloc,(V.Val (Constant.ConcreteVector _) as v)) -> mbox m (pp_rloc_no_brk tr m rloc) ^ pp_equal m ^ mbox m (do_add_asm m (V.pp C.hexa (V.printable v))) | LV (rloc,v) -> mbox m (pp_rloc tr m rloc) ^ pp_equal m ^ mbox m (do_add_asm m (V.pp C.hexa (V.printable v))) | LL (l1,l2) -> mbox m (pp_loc tr m l1) ^ pp_equal m ^ mbox m (pp_loc tr m l2) | FF f -> mbox m (Fault.pp_fatom (fun v -> do_add_asm m (V.pp_v v)) A.I.FaultType.pp f) (* ascii, parsable dump *) let dump_as_kind c = pp_kind (kind_of c) let do_dump_constraints tr chan = ConstrGen.dump_constraints chan (pp_atom tr Ascii) let dump_constraints chan = ConstrGen.dump_constraints chan (pp_atom Misc.identity Ascii) let constraints_to_string = ConstrGen.constraints_to_string (pp_atom Misc.identity Ascii) (* pretty_print *) let arg m = { pp_true = pp_true m; pp_false = pp_false m; pp_not = pp_not m; pp_or = pp_or m; pp_and = pp_and m; pp_implies = pp_implies m; pp_mbox = mbox m; pp_atom = pp_atom Misc.identity m; } let pp_as_kind c = let bodytext = pp_kind (kind_of c) in if C.texmacros then bodytext ^ " Final State" else bodytext let pp_constraints m = let endollar m s = match m with | Ascii|Dot -> s | Latex -> "$" ^ s ^ "$" | DotFig -> "$" ^ s ^ "$" in let pp_prop p = endollar m (ConstrGen.pp_prop (arg m) p) in fun c -> match c with | ExistsState p | NotExistsState p | ForallStates p -> pp_as_kind c ^ ": "^ pp_prop p end herd-herdtools7-1ca343e/herd/debug_herd.ml000066400000000000000000000053751475314470400205200ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Debug tags *) type t = { solver : bool ; lexer : bool ; top : bool ; mem : bool ; monad : bool ; barrier : bool ; res : bool ; rfm : bool ; pretty : bool ; mixed : bool ; files : bool ; timeout : bool ; profile_cat: bool ; profile_asl: bool ; exc : bool ; } let tags = [ "solver"; "lexer"; "top"; "mem"; "monad"; "barrier"; "model"; (* handier synonymous *) "res"; "rfm"; "pretty"; "mixed"; "files"; "timeout"; "profile_cat"; "profile_asl"; "exception"; ] let none = { solver = false ; lexer = false ; top = false ; mem = false ; monad = false ; barrier = false ; res = false ; rfm = false ; pretty = false ; mixed = false ; files = false ; timeout = false ; profile_cat = false; profile_asl = false; exc = false ; } let parse t tag = match tag with | "solver" -> Some { t with solver = true; } | "lexer" -> Some { t with lexer = true; } | "top" -> Some { t with top = true; } | "mem" -> Some { t with mem = true; } | "monad" -> Some { t with monad = true; } | "barrier"|"model" -> Some { t with barrier = true; } | "res" -> Some { t with res = true; } | "rfm" -> Some { t with rfm = true; } | "pretty" -> Some { t with pretty = true ;} | "mixed" -> Some { t with mixed = true ;} | "files"|"file" -> Some { t with files = true ;} | "timeout" -> Some { t with timeout = true ;} | "exception"|"exc" -> Some { t with exc = true ;} | "profile_cat" -> Some { t with profile_cat = true } | "profile_asl" -> Some { t with profile_asl = true } | _ -> None herd-herdtools7-1ca343e/herd/debug_herd.mli000066400000000000000000000030221475314470400206540ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Debug tags *) type t = { solver : bool ; lexer : bool ; top : bool ; mem : bool ; monad : bool ; barrier : bool ; res : bool ; rfm : bool ; pretty : bool ; mixed : bool ; files : bool ; timeout : bool ; profile_cat: bool ; profile_asl: bool ; exc : bool ; } val none : t val tags : string list val parse : t -> string -> t option herd-herdtools7-1ca343e/herd/dir.ml000066400000000000000000000023461475314470400172010ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) type dirn = R | W let pp_dirn d = match d with R -> "R" | W -> "W" herd-herdtools7-1ca343e/herd/dir.mli000066400000000000000000000024111475314470400173430ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Directions for memory accesses: read or write. *) type dirn = R | W val pp_dirn : dirn -> string herd-herdtools7-1ca343e/herd/dotEdgeAttr.ml000066400000000000000000000032401475314470400206230ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) type t = string StringMap.t StringMap.t let empty = StringMap.empty (* label -> attribute -> value -> oldt -> newt *) let add lbl att v m = let old = try StringMap.find lbl m with Not_found -> StringMap.empty in StringMap.add lbl (StringMap.add att v old) m (* label -> attribute -> t -> value *) let find lbl att m = StringMap.find att (StringMap.find lbl m) let find_all lbl m = try let n = StringMap.find lbl m in StringMap.fold (fun a v k -> (a,v)::k) n [] with Not_found -> [] herd-herdtools7-1ca343e/herd/dotEdgeAttr.mli000066400000000000000000000027361475314470400210050ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Edge attributes in .dot files *) type t val empty : t (* label -> attribute -> value -> oldt -> newt *) val add : string -> string -> string -> t -> t (* label -> attribute -> t -> value, may raise Not_found *) val find : string -> string -> t -> string val find_all : string -> t -> (string * string) list herd-herdtools7-1ca343e/herd/dune000066400000000000000000000003751475314470400167470ustar00rootroot00000000000000(dirs :standard \ tests libdir) (rule (copy ../Version.ml Version.ml)) (ocamllex lexConf_herd) (executable (name herd) (public_name herd7) (libraries unix herdtools) (modules_without_implementation AArch64Sig action arch_herd monad sem XXXMem)) herd-herdtools7-1ca343e/herd/equivSpec.ml000066400000000000000000000107161475314470400203670ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2020-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make(S:Sem.Semantics) = struct let dbg = false module Instance = struct type t = S.A.inst_instance_id let compare = S.A.inst_instance_compare end module InstMap = MyMap.Make(Instance) module InstSet = MySet.Make(Instance) (* Utilities on instance graphs coded as neighbours maps *) let succs i m = InstMap.safe_find InstSet.empty i m let add_succ i1 i2 m = InstMap.add i1 (InstSet.add i2 (succs i1 m)) m let subrel m1 m2 = try InstMap.iter (fun i is -> let js = succs i m2 in if not (InstSet.subset is js) then raise Exit) m1 ; true with Exit -> false open Printf let pp_instance i = sprintf "{P%i:%02i}" i.S.A.proc i.S.A.program_order_index let pp_rel chan m = InstMap.iter (fun i js -> fprintf chan "%s ->" (pp_instance i) ; InstSet.iter (fun j -> fprintf chan " %s" (pp_instance j)) js ; fprintf chan "\n") m (* fold f over pairs of distinct elements *) let rec fold_pairs f xs k = match xs with | [] -> k | x::xs -> List.fold_left (fun k y -> f x y (f y x k)) (fold_pairs f xs k) xs let build rf evts = let open S in (* Build a map from (instruction) instances to events of that instance *) let m = E.EventSet.fold (fun e m -> match e.E.iiid with | E.IdInit|E.IdSpurious -> m | E.IdSome i -> InstMap.add i (E.EventSet.add e (InstMap.safe_find E.EventSet.empty i m)) m) evts InstMap.empty in let is = InstMap.fold (fun i _ k -> i::k) m [] in (* Utilities *) let inst2evts i = try InstMap.find i m with Not_found -> assert false in (* lift rf to instances *) let rf_rel = E.EventRel.fold (fun (w,r) m -> match r.E.iiid with | E.IdInit|E.IdSpurious -> assert false | E.IdSome ir -> match w.E.iiid with | E.IdInit|E.IdSpurious -> m | E.IdSome iw -> add_succ ir iw m) rf InstMap.empty in if dbg then eprintf "RF-REG:\n%a\n" pp_rel rf_rel ; let same_instr i1 i2 = i1.A.inst == i2.A.inst in let matches m is js = let ok i j = InstSet.mem i (succs j m) in InstSet.for_all (fun i -> InstSet.exists (ok i) js) is in let step m = InstMap.fold (fun i js k -> let rf_is = succs i rf_rel in InstSet.fold (fun j k -> let rf_js = succs j rf_rel in if matches m rf_is rf_js && matches m rf_js rf_is then add_succ i j k else k) js k) m InstMap.empty in let rec fix m = if dbg then eprintf "**FIX\n%a\n" pp_rel m ; let next = step m in if subrel m next then m else fix next in if dbg then eprintf "Instances: %s\n" (String.concat " " (List.map pp_instance is)) ; let m0 = fold_pairs (fun i j k -> if same_instr i j then add_succ i j k else k) is InstMap.empty in let equiv = fix m0 in let equiv = InstMap.fold (fun i js k -> let evts_i = inst2evts i in InstSet.fold (fun j k -> E.EventRel.cartesian evts_i (inst2evts j)::k) js k) equiv [] in E.EventRel.unions equiv end herd-herdtools7-1ca343e/herd/equivSpec.mli000066400000000000000000000024651475314470400205420ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2020-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Compute speculation equivalence *) module Make : functor (S:Sem.Semantics) -> sig val build : S.event_rel -> S.event_set -> S.event_rel end herd-herdtools7-1ca343e/herd/event.ml000066400000000000000000002707341475314470400175540ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Operations on events *) open Printf module type S = sig module A : Arch_herd.S module Act : Action.S type action = Act.action type eiid = int type subid = int (* eiid = unique event id iiid = IdSome id of instruction that generated this event; IdInit for init writes IdSpurious for spurious events *) type iiid = | IdSome of A.inst_instance_id | IdInit | IdSpurious type event = { eiid : eiid; subid : subid; iiid : iiid; action : action; } (* Generated by the same instruction *) val same_instruction : event -> event -> bool (* And in the exact same way *) val same_static_event : event -> event -> bool val same_instance : event -> event -> bool (* Only basic printing is here *) val pp_eiid : event -> string val pp_instance : event -> string val pp_action : event -> string val debug_event : out_channel -> event -> unit val debug_event_str : event -> string (***************************) (* Procs and program order *) (***************************) val proc_of : event -> A.proc option val same_proc : event -> event -> bool val same_proc_not_init : event -> event -> bool val progorder_of : event -> A.program_order_index option (* Is e1 before e2 w.r.t. prog order ? Nothing assumed on e1 and e2 *) val po_strict : event -> event -> bool val po_eq : event -> event -> bool (************************) (* Predicates on events *) (************************) (* relative to memory *) val is_mem_store : event -> bool val is_mem_store_init : event -> bool val is_spurious : event -> bool val is_mem_load : event -> bool val is_additional_mem_load : event -> bool (* trylock... *) val is_mem : event -> bool (* Instruction fetch *) val is_ifetch : event -> bool (* Page table access *) val is_pt : event -> bool val is_explicit : event -> bool val is_not_explicit : event -> bool (* Tag memory access *) val is_tag : event -> bool val is_mem_physical : event -> bool (* includes additional memory events, eg lock, unlocks... *) val is_additional_mem : event -> bool (* Specific memory property examination *) val is_atomic : event -> bool val is_fault : event -> bool val to_fault : event -> A.fault option val is_amo : event -> bool val get_mem_dir : event -> Dir.dirn val get_mem_size : event -> MachSize.sz (* relative to the registers of the given proc *) val is_reg_store : event -> A.proc -> bool val is_reg_load : event -> A.proc -> bool val is_reg : event -> A.proc -> bool (* Reg events, proc not specified *) val is_reg_store_any : event -> bool val is_reg_load_any : event -> bool val is_reg_any : event -> bool (* Store/Load to memory or register *) val is_store : event -> bool val is_load : event -> bool (* Access events of the same category *) val compatible_accesses : event -> event -> bool (* Barriers *) val is_barrier : event -> bool val barrier_of : event -> A.barrier option (* val same_barrier_id : event -> event -> bool *) val is_isync : event -> bool (* Commit *) val is_bcc : event -> bool val is_pred : event -> bool val is_pred_txt : string option -> event -> bool val is_commit : event -> bool (* The "CutOff" effect flags stepping beyond unrolling limit *) val is_cutoff : event -> bool val as_cutoff : event -> string option (**************) (* Event sets *) (**************) val event_compare : event -> event -> int val event_equal : event -> event -> bool module OrderedEvent : MySet.OrderedType with type t = event module EventSet : MySet.S with type elt = event type event_set = EventSet.t val debug_events : out_channel -> event_set -> unit module EventSetSet : MySet.S with type elt = event_set (*************) (* Event map *) (*************) module EventMap : MyMap.S with type key = event (************************) (* Event set restricted *) (************************) (* relative to memory *) val mem_stores_of : EventSet.t -> EventSet.t val mem_stores_init_of : EventSet.t -> EventSet.t val mem_loads_of : EventSet.t -> EventSet.t val mem_of : EventSet.t -> EventSet.t val atomics_of : EventSet.t -> EventSet.t (* relative to the registers of the given proc *) val reg_stores_of : EventSet.t -> A.proc -> EventSet.t val reg_loads_of : EventSet.t -> A.proc -> EventSet.t (* Proc not checked *) val reg_stores : EventSet.t -> EventSet.t val reg_loads : EventSet.t -> EventSet.t (* For all locations *) val stores_of : EventSet.t -> EventSet.t val loads_of : EventSet.t -> EventSet.t (* Barriers *) val barriers_of : EventSet.t -> EventSet.t (* Commit *) val commits_of : EventSet.t -> EventSet.t (***********************) (* Relations on events *) (***********************) module EventRel : InnerRel.S with type elt0 = event and module Elts = EventSet module EventTransRel : InnerTransRel.S with type elt = event and module Set = EventSet and module Rel = EventRel type event_rel = EventRel.t val debug_rel : out_channel -> event_rel -> unit type event_structure = { procs : A.proc list ; events : EventSet.t ; (* really a set *) speculated : EventSet.t ; (* really a set *) po : EventSet.t * EventRel.t; (* speculated po represented as a forest: roots first + partial order *) partial_po : EventTransRel.t; intra_causality_data : EventRel.t ; (* really a partial order relation *) intra_causality_control : EventRel.t ; (* really a partial order relation *) intra_causality_order : EventRel.t ; (* Just order *) (* If style control inside structure *) control : EventRel.t ; (* Events that lead to the data port of a W *) data_ports : EventSet.t ; (* some special output port,i.e. store conditional success as reg write *) success_ports : EventSet.t ; (* Input to structure, by default minimal iico, or iico_data *) input : EventSet.t option ; data_input : EventSet.t option ; (* Result of structure, by default maximal iico_data *) output : EventSet.t option ; (* Control output of structure, by default maximal iico *) ctrl_output : EventSet.t option ; (* Equivalence classes of events generated by the same memory accesses *) sca : EventSetSet.t ; (* Original events, before splitted in sub-accesses (mixed-size). * NB: not included in events above *) mem_accesses : EventSet.t ; (* mem_access -> corresponding sca *) aligned : (event * EventSet.t) list ; } val procs_of : event_structure -> A.proc list val locs_of : event_structure -> A.location list (* map f over all events in event_structure *) val map_event_structure : (event -> event) -> event_structure -> event_structure val do_speculate : event_structure -> event_structure (* Union of all internal causality relations *) val iico : event_structure -> EventRel.t (*****************************************************************) (* Those projection return lists of event sets/relations by proc *) (*****************************************************************) (* project events by executing proc *) val proj_events : event_structure -> event_set list (* relation must operate on events of the same proc *) val proj_rel : event_structure -> event_rel -> event_rel list (* relation must be as before, or one of the related events be a mem_store *) val proj_proc_view : event_structure -> event_rel -> event_rel list (********************) (* Equation solving *) (********************) val undetermined_vars_in_event_structure : event_structure -> A.V.ValueSet.t val simplify_vars_in_event : A.V.solution -> event -> event val simplify_vars_in_event_structure : A.V.solution -> event_structure -> event_structure (*************************************) (* Access to sub_components of events *) (*************************************) val value_of : event -> A.V.v option (* Warning: fails on RMW actions *) val read_of : event -> A.V.v option val written_of : event -> A.V.v option val location_of : event -> A.location option val location_reg_of : event -> A.reg option val global_loc_of : event -> A.global_loc option val global_index_of : event -> int option val virtual_loc_of : event -> string option (****************************) (* Convenience on locations *) (****************************) val same_location : event -> event -> bool val same_location_with_faults : event -> event -> bool val same_value : event -> event -> bool val same_low_order_bits : event -> event -> bool (* val is_visible_location : A.location -> bool *) (********************************) (* Event structure output ports *) (********************************) val debug_output : out_channel -> event_structure -> unit val debug_event_structure : out_channel -> event_structure -> unit (********************************) (* Instruction+code composition *) (********************************) val inst_code_comp : event_structure -> event_structure -> event_structure val inst_code_comp_spec : event_structure -> event_structure -> event_structure -> event_structure (************************) (* Parallel composition *) (************************) val para_comp : bool (* check disjointness *) -> event_structure -> event_structure -> event_structure option (* Memory events in arguments form one atomic access => build a sca *) val para_atomic : event_structure -> event_structure -> event_structure option (* Input in second argument *) val para_input_right : event_structure -> event_structure -> event_structure option (* Output in second argument *) val para_output_right : event_structure -> event_structure -> event_structure option (* Partial po sequencing, output in second argument *) val para_po_seq_output_right : event_structure -> event_structure -> event_structure option (* Sequence memory events, otherwise parallel composition *) val seq_mem : event_structure -> event_structure -> event_structure option (***********************************************) (* sequential composition, add data dependency *) (***********************************************) val (=*$=) : (* second es entries are minimal evts for iico_data *) event_structure -> event_structure -> event_structure option val data_input_next : (* input to second structure *) event_structure -> event_structure -> event_structure option val data_input_union : (* input to both structures *) event_structure -> event_structure -> event_structure option val data_to_output : (* input to second es output *) event_structure -> event_structure -> event_structure option val data_to_minimals : (* second es entries are minimal evts all iico *) event_structure -> event_structure -> event_structure option val data_po_seq : (* same as [=*$=], but sequences po. *) event_structure -> event_structure -> event_structure option (* Identical, keep first event structure data output as output. *) val (=$$=) : event_structure -> event_structure -> event_structure option val data_output_union : event_structure -> event_structure -> event_structure option (* sequential composition, add control dependency *) val (=**=) : event_structure -> event_structure -> event_structure option (* Identical, data input is first argument (usually commit evt) *) val bind_control_set_data_input_first : event_structure -> event_structure -> event_structure option (* Identical, keep second event structure input as input. *) val control_input_next : event_structure -> event_structure -> event_structure option (* Identical, input is union *) val control_input_union : event_structure -> event_structure -> event_structure option (* Identical, keep first event structure data output as output. *) val (=*$$=) : event_structure -> event_structure -> event_structure option (* similar, additionally avoid some evts in target links *) val bind_ctrl_avoid : event_set -> event_structure -> event_structure -> event_structure option (* Similar, but if no output in second argument, use first as output *) val bind_ctrl_sequence_data : event_structure -> event_structure -> event_structure option (* Similar, but sequencing partial po *) val bind_ctrl_sequence_data_po : event_structure -> event_structure -> event_structure option (***********************) (* Custom compositions *) (***********************) (* Compose three structures s1 s2 and s3 with s1-ctrl+data->s3 and s2-data->s3 *) val bind_ctrldata_data : event_structure -> event_structure -> event_structure -> event_structure (* Sequential composition, add ctrl+data dependency keep first event structure output as data and control output. *) val bind_ctrldata_first_outputs : event_structure -> event_structure -> event_structure option (* Sequential composition, add ctrl dependency keep first event structure output as data and control output. *) val bind_ctrl_first_outputs : event_structure -> event_structure -> event_structure option (* Order composition, same as [=*$=] but with order dependencies instead of data. *) val bind_order : event_structure -> event_structure -> event_structure option (* exchange composition : xch rx ry wx wy -> rx -data-> wy, ry -data-> wx rx -ctrl-> wx, ry -ctrl-> wy *) val exch : event_structure -> event_structure -> event_structure -> event_structure -> event_structure val swp_or_amo : bool -> (* Physical memory access *) 'op option -> (* When None this is a swp, otherwise amo *) event_structure -> event_structure -> event_structure -> event_structure -> event_structure -> event_structure val linux_exch : event_structure -> event_structure -> event_structure -> event_structure -> event_structure val amo : event_structure -> event_structure -> event_structure -> event_structure -> event_structure val linux_cmpexch_ok : event_structure -> event_structure -> event_structure -> event_structure -> event_structure -> event_structure val linux_cmpexch_no : event_structure -> event_structure -> event_structure -> event_structure val linux_add_unless_ok : event_structure -> event_structure -> event_structure -> event_structure -> event_structure -> bool -> event_structure val linux_add_unless_no : event_structure -> event_structure -> event_structure -> bool -> event_structure val riscv_sc : bool (* success *) -> event_structure -> event_structure -> event_structure -> event_structure -> event_structure -> event_structure -> event_structure val aarch64_cas_no : bool -> (* Physical memory access *) bool -> (* Add an iico_ctrl between the Branch and the Register Write *) event_structure -> event_structure -> event_structure -> event_structure -> event_structure -> event_structure val aarch64_cas_ok : bool (* Physical memory access *) -> [`DataFromRRs | `DataFromRx] -> event_structure -> event_structure -> event_structure -> event_structure -> event_structure -> event_structure -> event_structure -> event_structure val aarch64_cas_ok_morello : event_structure -> event_structure -> event_structure -> event_structure -> event_structure (* stu computation : stu rD rEA wEA wM -> rEA -data-> wEA, rEA -data-> wM, rD -data-> wM *) val stu : event_structure -> event_structure -> event_structure -> event_structure -> event_structure (* Parallel, for different instructions *) val (+|+) : event_structure -> event_structure -> event_structure option val empty_event_structure : event_structure val is_empty_event_structure : event_structure -> bool val from_events: EventSet.t -> event_structure (* Condition at instruction level *) val cond_comp : event_structure -> event_structure -> event_structure end module type Config = sig val debug : Debug_herd.t val variant : Variant.t -> bool end module Make (C:Config) (AI:Arch_herd.S) (Act:Action.S with module A = AI) : (S with module A = AI and module Act = Act) = struct module Act = Act module A = AI module V = AI.V let dbg = C.debug.Debug_herd.monad let do_deps = C.variant Variant.Deps let memtag = C.variant Variant.MemTag let kvm = C.variant Variant.VMSA let is_branching = kvm && not (C.variant Variant.NoPteBranch) let is_po_partial = A.arch = `ASL type eiid = int type subid = int type action = Act.action type iiid = | IdSome of A.inst_instance_id | IdInit | IdSpurious type event = { eiid : eiid; subid : subid; iiid : iiid; action : action; } let same_instruction e1 e2 = match e1.iiid,e2.iiid with | ((IdInit|IdSpurious),_) | (_,(IdInit|IdSpurious)) -> false | IdSome i1,IdSome i2 -> A.same_instruction i1 i2 let same_static_event e1 e2 = Misc.int_eq e1.subid e2.subid && same_instruction e1 e2 let same_instance e1 e2 = match e1.iiid,e2.iiid with | ((IdInit|IdSpurious),_) | (_,(IdInit|IdSpurious)) -> false | IdSome i1,IdSome i2 -> A.inst_instance_compare i1 i2 = 0 let pp_eiid e = if e.eiid < 26 then String.make 1 (Char.chr (Char.code 'a' + e.eiid)) else "ev"^string_of_int e.eiid let pp_instance e = match e.iiid with | IdInit -> sprintf "init(%s)" (pp_eiid e) | IdSpurious -> sprintf "spurious(%s)" (pp_eiid e) | IdSome i -> sprintf "%i:%i" i.A.proc i.A.program_order_index let pp_action e = Act.pp_action e.action let debug_event chan e = fprintf chan "(eeid=%s action=%s)" (pp_eiid e) (pp_action e) let debug_event_str e = sprintf "(eeid=%s action=%s)" (pp_eiid e) (pp_action e) (* Utility functions to pick out components *) let value_of e = Act.value_of e.action let read_of e = Act.read_of e.action let written_of e = Act.written_of e.action let location_of e = Act.location_of e.action let location_reg_of e = match location_of e with | Some (A.Location_reg (_,r)) -> Some r | _ -> None let global_loc_of e = match location_of e with | Some (A.Location_global a) -> Some a | _ -> None let global_index_of e = match global_loc_of e with | Some (V.Val (Constant.Symbolic sym)) -> Constant.get_index sym | _-> None let virtual_loc_of e = match global_loc_of e with | Some (A.V.Val c) -> Constant.as_virtual c | None|Some (A.V.Var _) -> None (* Visible locations *) (* let is_visible_location = function | A.Location_global _ -> true | A.Location_reg _ -> false *) let same_location e1 e2 = match location_of e1,location_of e2 with | (None,_)|(_,None) -> false | Some loc1,Some loc2 -> A.location_compare loc1 loc2 = 0 let same_location_with_faults e1 e2 = match location_of e1,location_of e2 with | (None,_)|(_,None) -> false | Some loc1,Some loc2 -> if Act.is_fault e1.action || Act.is_fault e2.action then A.same_base_virt loc1 loc2 else A.location_compare loc1 loc2 = 0 let same_value e1 e2 = match value_of e1, value_of e2 with | Some v1,Some v2 -> V.compare v1 v2 = 0 | _,_ -> false let same_low_order_bits e1 e2 = match global_index_of e1,global_index_of e2 with | (None,_)|(_,None) -> false | Some i1,Some i2 -> Misc.int_eq i1 i2 let proc_of e = match e.iiid with | IdSome {A.proc=p;_} -> Some p | IdSpurious|IdInit -> None let same_proc e1 e2 = match proc_of e1, proc_of e2 with | Some p1,Some p2 -> Misc.int_eq p1 p2 | (None,Some _)|(Some _,None) -> false | None,None -> true let same_proc_not_init e1 e2 = match proc_of e1, proc_of e2 with | Some p1,Some p2 -> Misc.int_eq p1 p2 | (None,Some _)|(Some _,None) | None,None -> false let progorder_of e = match e.iiid with | IdSome i -> Some i.A.program_order_index | IdInit|IdSpurious -> None (************************) (* Predicates on events *) (************************) let po_strict e1 e2 = proc_of e1 = proc_of e2 && progorder_of e1 < progorder_of e2 let po_eq e1 e2 = proc_of e1 = proc_of e2 && progorder_of e1 = progorder_of e2 (* relative to memory *) let is_mem_store e = Act.is_mem_store e.action let is_mem_store_init e = match e.iiid with | IdInit -> true | IdSpurious|IdSome _ -> false let is_spurious e = match e.iiid with | IdSpurious -> true | IdInit|IdSome _ -> false let is_mem_load e = Act.is_mem_load e.action let is_additional_mem_load e = Act.is_additional_mem_load e.action let is_mem e = Act.is_mem e.action let is_ifetch e = Act.is_ifetch e.action let is_pt e = match Act.location_of e.action with | Some (A.Location_global (V.Val c)) -> Constant.is_pt c | _ -> false let is_explicit e = Act.is_explicit e.action let is_not_explicit e = Act.is_not_explicit e.action let is_tag e = Act.is_tag e.action let is_mem_physical e = let open Constant in match Act.location_of e.action with | Some (A.Location_global (V.Val (Symbolic (Physical _)))) -> true | _ -> false let is_additional_mem e = Act.is_additional_mem e.action let is_atomic e = Act.is_atomic e.action let is_fault e = Act.is_fault e.action let to_fault e = Act.to_fault e.action let is_amo e = match e.iiid with | IdSome {A.inst=i; _} when A.is_amo i -> Act.is_mem_store e.action | _ -> false let get_mem_dir e = Act.get_mem_dir e.action let get_mem_size e = Act.get_mem_size e.action (* relative to the registers of the given proc *) let is_reg_store e (p:int) = Act.is_reg_store e.action p let is_reg_load e (p:int) = Act.is_reg_load e.action p let is_reg e (p:int) = Act.is_reg e.action p (* Store/Load anywhere *) let is_store e = Act.is_store e.action let is_load e = Act.is_load e.action let is_reg_any e = Act.is_reg_any e.action let is_reg_store_any e = Act.is_reg_store_any e.action let is_reg_load_any e = Act.is_reg_load_any e.action (* Compatible events ie accesses of the same category *) let compatible_accesses e1 e2 = Act.compatible_accesses e1.action e2.action (* Barriers *) let is_barrier e = Act.is_barrier e.action let barrier_of e = Act.barrier_of e.action (* let same_barrier_id e1 e2 = Act.same_barrier_id e1.action e2.action *) let is_isync e = Act.is_isync e.action (* Commits *) let is_bcc e = Act.is_bcc e.action let is_pred e = Act.is_pred e.action let is_pred_txt cond e = Act.is_pred ~cond e.action let is_commit e = Act.is_commit e.action (* Unrolling control *) let is_cutoff e = Act.is_cutoff e.action and as_cutoff e = Act.as_cutoff e.action (******************************) (* Build structures of events *) (******************************) let event_compare e1 e2 = Misc.int_compare e1.eiid e2.eiid let event_equal e1 e2 = Misc.int_eq e1.eiid e2.eiid module OrderedEvent = struct type t = event let compare = event_compare end module EventSet = MySet.Make(OrderedEvent) type event_set = EventSet.t let debug_events chan es = fprintf chan "{" ; EventSet.pp chan ", " debug_event es ; fprintf chan "}" ; () module EventSetSet = MySet.Make(EventSet) (* relative to memory *) let mem_stores_of = EventSet.filter is_mem_store let mem_stores_init_of = EventSet.filter is_mem_store_init let mem_loads_of es = EventSet.filter is_mem_load es let mem_of es = EventSet.filter is_mem es let atomics_of es = EventSet.filter is_atomic es (* relative to the registers of the given proc *) let reg_stores_of es p = EventSet.filter (fun e -> is_reg_store e p) es let reg_loads_of es p = EventSet.filter (fun e -> is_reg_load e p) es (* Everywhere *) let reg_stores es = EventSet.filter is_reg_store_any es let reg_loads es = EventSet.filter is_reg_load_any es let stores_of es = EventSet.filter is_store es let loads_of es = EventSet.filter is_load es (* Barriers *) let barriers_of es = EventSet.filter is_barrier es (* Commits *) let commits_of es = EventSet.filter is_commit es module EventMap = MyMap.Make(OrderedEvent) (*************) (* Relations *) (*************) module EventRel = InnerRel.Make(OrderedEvent) type event_rel = EventRel.t module EventTransRel = InnerTransRel.Make(OrderedEvent) let debug_event_in_rel chan e = fprintf chan "%s" (pp_eiid e) let debug_rel chan r = EventRel.pp chan "," (fun chan (e1,e2) -> fprintf chan "%a -> %a" debug_event_in_rel e1 debug_event_in_rel e2) r let debug_trans_rel chan tag r = let open EventTransRel in if not (EventTransRel.is_empty r) then fprintf chan "%s\n\t\ti=%a\n\t\to=%a\n\t\tr=%a\n" tag debug_events r.input debug_events r.output debug_rel r.rel type event_structure = { procs : A.proc list ; (* will prove convenient *) events : EventSet.t ; (* really a set *) speculated : EventSet.t ; (* really a set *) po : EventSet.t * EventRel.t; partial_po: EventTransRel.t; intra_causality_data : EventRel.t ; (* really a (partial order) relation *) intra_causality_control : EventRel.t ;(* really a (partial order) relation *) intra_causality_order : EventRel.t ; (* Just order *) control : EventRel.t ; data_ports : EventSet.t ; success_ports : EventSet.t ; input : EventSet.t option ; data_input : EventSet.t option ; output : EventSet.t option ; ctrl_output : EventSet.t option ; sca : EventSetSet.t ; mem_accesses : EventSet.t ; aligned : (event * EventSet.t) list ; } let procs_of es = es.procs let locs_of es = EventSet.fold (fun e k -> match location_of e with Some l -> l::k | None -> k) es.events [] let map_aligned f = List.map (fun (e,es) -> f e,EventSet.map f es) let map_event_structure f es = let map_rel = EventRel.map_nodes f and map_set = EventSet.map f in { procs = es.procs ; events = map_set es.events ; speculated = map_set es.speculated ; po = begin let r,e = es.po in (map_set r, map_rel e) end; partial_po = EventTransRel.map_nodes f es.partial_po ; intra_causality_data = map_rel es.intra_causality_data ; intra_causality_control = map_rel es.intra_causality_control ; intra_causality_order = map_rel es.intra_causality_order ; control = map_rel es.control ; data_ports = map_set es.data_ports ; success_ports = map_set es.success_ports ; input = Misc.app_opt map_set es.input ; data_input = Misc.app_opt map_set es.data_input ; output = Misc.app_opt map_set es.output ; ctrl_output = Misc.app_opt map_set es.ctrl_output ; sca = EventSetSet.map map_set es.sca ; mem_accesses = map_set es.mem_accesses ; aligned = map_aligned f es.aligned; } let do_speculate es = let s = es.events in {es with speculated = s} let iico es = EventRel.union3 es.intra_causality_data es.intra_causality_control es.intra_causality_order let empty = { procs = [] ; events = EventSet.empty ; speculated = EventSet.empty ; po = (EventSet.empty,EventRel.empty); partial_po = EventTransRel.empty; intra_causality_data = EventRel.empty ; intra_causality_control = EventRel.empty ; intra_causality_order = EventRel.empty ; control = EventRel.empty ; data_ports = EventSet.empty ; success_ports = EventSet.empty ; input = None; data_input = None; output = None ; ctrl_output = None ; sca = EventSetSet.empty ; mem_accesses = EventSet.empty ; aligned = []; } let is_empty_event_structure es = Misc.nilp es.procs && EventSet.is_empty es.events && EventRel.is_empty es.intra_causality_data && EventRel.is_empty es.intra_causality_control && EventRel.is_empty es.intra_causality_order && EventRel.is_empty es.control && EventSet.is_empty es.data_ports && EventSet.is_empty es.success_ports && Misc.is_none es.input && Misc.is_none es.output && Misc.is_none es.ctrl_output (****************************) (* Projection of event set *) (****************************) module Proj(S:MySet.S) = struct let rec add_env p e = function | [] -> assert false | (q,es as c)::env -> if Misc.int_eq p q then (q, S.add e es)::env else c::add_env p e env let proj procs_of ps es = let env = List.map (fun p -> p,S.empty) ps in let env = S.fold (fun e -> List.fold_right (fun p env -> add_env p e env) (procs_of e)) es env in List.map (fun (_p,es) -> es) env end module ProjSet = Proj(EventSet) let proj_events es = ProjSet.proj (fun e -> match proc_of e with | Some p -> [p] | None -> []) (procs_of es) es.events module ProjRel = Proj(EventRel) let proc_of_pair (e1,e2) = let p1 = proc_of e1 and p2 = proc_of e2 in match p1,p2 with | Some p1,Some p2 -> if Misc.int_eq p1 p2 then [p1] else [] | _,_ -> [] let proj_rel es rel = ProjRel.proj proc_of_pair (procs_of es) rel let proj_proc_view es rel = let proc_of (e1,e2) = let p1 = proc_of e1 and p2 = proc_of e2 in match p1,p2 with | Some p1, Some p2 -> if Misc.int_eq p1 p2 then [p1] else if is_mem_store e1 then [p2] else if is_mem_store e2 then [p1] else [] (* Can occur for X86CC -> no projected relation *) | None,Some p2 -> if is_mem_store e1 then [p2] else [] | Some p1,None -> if is_mem_store e2 then [p1] else [] | None,None -> [] in ProjRel.proj proc_of (procs_of es) rel let undetermined_vars_in_event e = Act.undetermined_vars_in_action e.action let undetermined_vars_in_event_structure es = EventSet.fold (fun e k -> V.ValueSet.union (undetermined_vars_in_event e) k) es.events V.ValueSet.empty let simplify_vars_in_event soln e = {e with action = Act.simplify_vars_in_action soln e.action} let simplify_vars_in_event_structure soln es = if V.Solution.is_empty soln then es else map_event_structure (simplify_vars_in_event soln) es (********************************) (* Event structure manipulation *) (********************************) (* Input *) let min_evts evts r = EventRel.fold (fun (_,e) k -> EventSet.remove e k) r evts let minimals es = match es.input with | None -> min_evts es.events (iico es) | Some evts -> evts let minimals_no_spurious es = EventSet.filter (fun e -> not (is_spurious e)) (minimals es) let minimals_avoid aset es = match es.input with | None -> Printf.eprintf "Minimal avoid, input is none\n%!" ; let intra_causality = let r = iico es in EventRel.filter (fun (e,_) -> not (EventSet.mem e aset)) r in min_evts (EventSet.diff es.events aset) intra_causality | Some es -> Printf.eprintf "Minimal avoid, input is {%a}\n%!" debug_events es; Warn.warn_always "minimal_avoid with explicit input" ; EventSet.diff es aset let minimals_data es = match es.data_input with | None -> min_evts es.events es.intra_causality_data | Some evts -> evts let minimals_data_no_spurious es = EventSet.filter (fun e -> not (is_spurious e)) (minimals_data es) (* Ouput *) let max_evts evts r = EventRel.fold (fun (e,_) k -> EventSet.remove e k) r evts let maximals es = max_evts es.events (iico es) let maximals_data es = max_evts es.events es.intra_causality_data let get_output es = match es.output with | None -> maximals_data es | Some o -> o let get_dinput es = match es.input with | None -> minimals es | Some es -> es let debug_opt chan (v,f,es) = match v with | None -> fprintf chan "-{%a}" debug_events (f es) | Some es -> debug_events chan es let debug_output chan es = fprintf chan "(i=%a, o=%a)" debug_opt (es.input,get_dinput,es) debug_opt (es.output,get_output,es) let debug_event_structure chan es = fprintf chan "(\n" ; fprintf chan "\tevents: %a\n" debug_events es.events ; fprintf chan "\tinput: %a\n" debug_opt (es.input,get_dinput,es) ; fprintf chan "\toutput: %a\n" debug_opt (es.output,get_output,es) ; fprintf chan "\tiico_data: %a\n" debug_rel es.intra_causality_data ; fprintf chan "\tiico_ctrl: %a\n" debug_rel es.intra_causality_control ; let _,rel = es.po in if not (EventRel.is_empty rel) then fprintf chan "\tpo: %a\n" debug_rel rel; debug_trans_rel chan "\tpartial_po: " es.partial_po; fprintf chan ")\n" let get_ctrl_output es = match es.ctrl_output with | None -> maximals es | Some o -> o let get_ctrl_output_commits es = EventSet.filter is_commit (get_ctrl_output es) (**********************************) (* Add together event structures *) (**********************************) (* Checking events sets are disjoint, disabled *) let check_disjoint do_it es1 es2 = (*assert (EventSet.disjoint es1.events es2.events) ;*) Some (do_it es1 es2) (************************) (* Parallel composition *) (************************) let do_union_output access default es1 es2 = match access es1,access es2 with | Some o1, Some o2 -> Some (EventSet.union o1 o2) | None,None -> None | None,Some o2 -> Some (EventSet.union (default es1) o2) | Some o1,None -> Some (EventSet.union o1 (default es2)) let union_output = do_union_output (fun es -> es.output) maximals_data and union_ctrl_output = do_union_output (fun es -> es.ctrl_output) maximals let debug_opt dbg chan = function | None -> fprintf chan "None" | Some e -> dbg chan e let do_union_input = do_union_output let get_input es = es.input let union_input = do_union_input get_input minimals let get_data_input es = es.data_input let union_data_input = do_union_input get_data_input minimals_data (*******************************) (* (Data-)Output in sequencing *) (*******************************) (* data-sequencing *) let sequence_data_output es1 es2 = if dbg then eprintf "Seq %a %a ->" debug_output es1 debug_output es2 ; let r = match es1.output,es2.output with | __,(Some _ as out) -> out | None,None -> None | Some out,None -> (* Tricky case, when get_output is empty, None would mean loosing the explicit output and re-including maximal elts *) let out2 = get_output es2 in if EventSet.is_empty out2 then Some out else Some out2 in if dbg then eprintf " %a\n" (debug_opt debug_events) r ; r (* Control sequencing, in all circonstances es1 output must be discarded *) let sequence_control_output _es1 es2 = Some (get_output es2) (*******************************) (* Ctrl_output in sequencing *) (*******************************) let sequence_data_ctrl_output es1 es2 = match es1.ctrl_output,es2.ctrl_output with | __,(Some _ as out) -> out | None,None -> None | Some out,None -> let out2 = get_output es2 in if EventSet.is_empty out2 then Some out else Some out2 (* Sequential composition *) let seq_partial_po = if not is_po_partial then fun _ _ -> EventTransRel.empty else fun es1 es2 -> if EventSet.is_empty es1.events then es2.partial_po else if EventSet.is_empty es2.events then es1.partial_po else EventTransRel.seq es1.partial_po es2.partial_po let inst_code_comp (*poi*) es1 es2 = { procs = [] ; events = EventSet.union es1.events es2.events; speculated = EventSet.union es1.speculated es2.speculated; po = begin if do_deps then let r1 = es1.events in if EventSet.is_empty r1 then es2.po else let r2,e2 = es2.po in (r1, EventRel.union (EventRel.cartesian r1 r2) e2) else es2.po end ; partial_po = seq_partial_po es1 es2; intra_causality_data = EventRel.union es1.intra_causality_data es2.intra_causality_data ; intra_causality_control = EventRel.union es1.intra_causality_control es2.intra_causality_control ; intra_causality_order = EventRel.union es1.intra_causality_order es2.intra_causality_order ; control = EventRel.union es1.control es2.control; data_ports = EventSet.union es1.data_ports es2.data_ports; success_ports = EventSet.union es1.success_ports es2.success_ports; input = es1.input ; data_input = es1.data_input ; output = es2.output; ctrl_output = es2.ctrl_output ; sca = EventSetSet.union es1.sca es2.sca; mem_accesses = EventSet.union es1.mem_accesses es2.mem_accesses; aligned = es1.aligned @ es2.aligned; } (* Function inst_code_comp_spec builds pod node with two branches, left and right, It is important that left and right output are single, have increasing ids and are immediate successors or the pod. *) let inst_code_comp_spec es1 es2 es3 = let outs = get_output es1 in begin match EventSet.as_singleton (EventSet.filter is_bcc es1.events) with | Some pod -> let succs = EventRel.succs es1.intra_causality_data pod in if not (EventSet.equal succs outs) then Warn.fatal "Reject complex dependance in inst_code_comp_spec" | None -> Warn.fatal "No single pod in inst_comp_code_comp_spec" end ; match EventSet.elements outs with | [lo;ro;] -> let lo,ro = if EventSet.mem ro es1.speculated then lo,ro else ro,lo in { procs = [] ; events = EventSet.union3 es1.events es2.events es3.events; speculated = EventSet.union3 es1.speculated es2.speculated es3.events; po = begin assert do_deps ; let r1 = EventSet.diff es1.events outs in let r1l = EventSet.add lo r1 and r1r = EventSet.add ro r1 in let r2,e2 = es2.po and r3,e3 = es3.po in r1, EventRel.union (EventRel.union (EventRel.cartesian r1l r2) e2) (EventRel.union (EventRel.cartesian r1r r3) e3) end ; partial_po = seq_partial_po es1 es2; intra_causality_data = EventRel.union3 es1.intra_causality_data es2.intra_causality_data es3.intra_causality_data; intra_causality_control = EventRel.union3 es1.intra_causality_control es2.intra_causality_control es3.intra_causality_control; intra_causality_order = EventRel.union3 es1.intra_causality_order es2.intra_causality_order es3.intra_causality_order; control = EventRel.union3 es1.control es2.control es3.control; data_ports = EventSet.union3 es1.data_ports es2.data_ports es3.data_ports; success_ports = EventSet.union3 es1.success_ports es2.success_ports es3.success_ports; input = None; data_input = None ; output = None; ctrl_output = None ; sca = EventSetSet.union3 es1.sca es2.sca es3.sca; mem_accesses = EventSet.union3 es1.mem_accesses es2.mem_accesses es3.mem_accesses; aligned = es1.aligned @ es2.aligned @ es3.aligned ; } | _ -> Warn.fatal "Event.inst_code_comp_spec called in wrong context" (* Two utilities *) let po_union = if do_deps then fun es1 es2 -> let r1,e1 = es1.po and r2,e2 = es2.po in (EventSet.union r1 r2, EventRel.union e1 e2) else fun es _ -> es.po let partial_po_union = if is_po_partial then fun es1 es2 -> EventTransRel.union es1.partial_po es2.partial_po else fun _ _ -> EventTransRel.empty let speculated_union = if do_deps then fun es1 es2 -> EventSet.union es1.speculated es2.speculated; else fun es _ -> es.speculated (* Standard union of two structures, specific fields to be completed *) let union es1 es2 = { procs = []; events = EventSet.union es1.events es2.events ; speculated = speculated_union es1 es2 ; po = po_union es1 es2 ; partial_po = partial_po_union es1 es2 ; intra_causality_data = EventRel.union es1.intra_causality_data es2.intra_causality_data ; intra_causality_control = EventRel.union es1.intra_causality_control es2.intra_causality_control ; intra_causality_order = EventRel.union es1.intra_causality_order es2.intra_causality_order ; control = EventRel.union es1.control es2.control ; data_ports = EventSet.union es1.data_ports es2.data_ports ; success_ports = EventSet.union es1.success_ports es2.success_ports ; input = None ; data_input = None ; output = None; ctrl_output = None ; sca = EventSetSet.union es1.sca es2.sca ; mem_accesses = EventSet.union es1.mem_accesses es2.mem_accesses ; aligned = es1.aligned @ es2.aligned ; } (* Parallel composition *) let do_para_comp es1 es2 = let r = union es1 es2 in { r with input = union_input es1 es2 ; data_input = union_data_input es1 es2 ; output = union_output es1 es2 ; ctrl_output = union_ctrl_output es1 es2 ; } let para_comp check = if check then check_disjoint do_para_comp else fun es1 es2 -> Some (do_para_comp es1 es2) let para_atomic es1 es2 = let m1 = EventSet.filter is_mem es1.events and m2 = EventSet.filter is_mem es2.events in Misc.app_opt (fun r -> { r with sca = EventSetSet.add (EventSet.union m1 m2) r.sca; }) (para_comp true es1 es2) let do_force get mk es = match get es with | None -> Some (mk es) | Some _ as i -> i let force_input tag es1 es2 = let o = do_force get_input minimals es2 in if dbg then Printf.eprintf "ForceInput%s %a(%a) %a(%a) -> %a\n%!" tag (debug_opt debug_events) es1.input debug_events es1.events (debug_opt debug_events) es2.input debug_events es2.events (debug_opt debug_events) o ; o and force_data_input = do_force get_data_input minimals_data (* Parallel composition, input on second monad argument *) let para_input_right es1 es2 = let r = union es1 es2 in let r = { r with input = force_input "ParaRight" es1 es2; data_input = force_data_input es2; output = union_output es1 es2 ; ctrl_output = union_ctrl_output es1 es2 ; } in Some r (* Parallel composition, do not include first monad argument in output *) let para_output_right es1 es2 = let r = union es1 es2 in let r = { r with input = union_input es1 es2 ; data_input = union_data_input es1 es2 ; output = Some (get_output es2); ctrl_output = union_ctrl_output es1 es2; } in Some r let para_po_seq_output_right es1 es2 = let r = union es1 es2 in let r = { r with input = union_input es1 es2 ; data_input = union_data_input es1 es2 ; output = Some (get_output es2); ctrl_output = union_ctrl_output es1 es2; partial_po = seq_partial_po es1 es2; } in Some r (* parallel composition with memory event sequencing *) let seq_mem es1 es2 = let r = do_para_comp es1 es2 in let r = { r with intra_causality_order = EventRel.union r.intra_causality_order (EventRel.cartesian (EventSet.filter is_mem es1.events) (EventSet.filter is_mem es2.events)) ; } in Some r (* Composition with intra_causality_data from first to second *) let do_seq_input access es1 es2 = if is_empty_event_structure es1 then access es2 else access es1 let seq_input es1 es2 = let o = do_seq_input get_input es1 es2 in if dbg then Printf.eprintf "SeqInput %a(%a) %a(%a) -> %a\n%!" (debug_opt debug_events) es1.input debug_events es1.events (debug_opt debug_events) es2.input debug_events es2.events (debug_opt debug_events) o ; o and seq_data_input = do_seq_input get_data_input let data_comp mini_loc mkOut es1 es2 = let r = union es1 es2 in { r with intra_causality_data = EventRel.filter (* Found that reviewing code, check by assert... *) (fun (e1,e2) -> let b = e1 != e2 in if not b then eprintf "Warning: get rid of event %a\n%!" debug_event e1 ; b) (EventRel.union r.intra_causality_data (EventRel.cartesian (get_output es1) (mini_loc es2))) ; input = seq_input es1 es2 ; data_input = seq_data_input es1 es2 ; output = mkOut es1 es2 ; ctrl_output = sequence_data_ctrl_output es1 es2 ; } let (=*$=) = check_disjoint (data_comp minimals_data sequence_data_output) let data_po_seq es1 es2 = let r = data_comp minimals sequence_data_output es1 es2 in Some { r with partial_po = seq_partial_po es1 es2; } let data_input_next es1 es2 = let r = data_comp minimals_data sequence_data_output es1 es2 in Some { r with input = force_input "Next" es1 es2; data_input = force_data_input es2; } let do_union_input_seq access default es1 es2 = if is_empty_event_structure es1 then access es2 else if is_empty_event_structure es2 then access es1 else Some (EventSet.union (default es1) (default es2)) let union_input_seq = do_union_input_seq get_input minimals and union_data_input_seq = do_union_input_seq get_data_input minimals_data let data_input_union es1 es2 = let r = data_comp (fun es -> min_evts es.events (iico es)) sequence_data_output es1 es2 in let r = { r with input = union_input_seq es1 es2 ; data_input = union_data_input_seq es1 es2 ; } in if dbg then eprintf "data_input_union %a %a -> %a\n" debug_output es1 debug_output es2 debug_output r ; Some r let data_to_minimals = check_disjoint (data_comp minimals sequence_data_output) let data_to_output es1 es2 = let r = data_comp get_output sequence_data_output es1 es2 in let r = { r with input = union_input_seq es1 es2 ; data_input = union_data_input_seq es1 es2 ; } in Some r let (=$$=) = let out es1 es2 = let out = get_output es1 in if dbg then eprintf "SeqFirst %a %a -> %a\n" debug_output es1 debug_output es2 debug_events out ; Some out in check_disjoint (data_comp minimals_data out) let data_output_union es1 es2 = let r = data_comp minimals sequence_data_output es1 es2 in Some { r with output = union_output es1 es2 ; } (* Composition with intra_causality_control from first to second *) let control_comp maxi_loc mini_loc mkOut es1 es2 = let r = union es1 es2 in { r with intra_causality_control = EventRel.union r.intra_causality_control (EventRel.cartesian (maxi_loc es1) (mini_loc es2)) ; input = seq_input es1 es2 ; data_input = seq_data_input es1 es2 ; output = mkOut es1 es2; ctrl_output = sequence_data_ctrl_output es1 es2; } (* Standard *) let (=**=) = check_disjoint (control_comp get_ctrl_output minimals sequence_control_output) (* Variant: data input restricted to first argument *) let bind_control_set_data_input_first es1 es2 = let r = control_comp get_ctrl_output minimals sequence_control_output es1 es2 in Some { r with data_input = force_data_input es1; } (* Variant that sets input on second argument *) let control_input_next es1 es2 = let r = control_comp get_ctrl_output minimals sequence_control_output es1 es2 in Some { r with input = force_input "Next" es1 es2; data_input = force_data_input es2; } let control_input_union es1 es2 = if dbg then eprintf "Control_input_union %a %a\n%!" debug_output es1 debug_output es2 ; let r = control_comp get_ctrl_output minimals sequence_control_output es1 es2 in Some { r with input = union_input es1 es2; data_input = union_data_input es1 es2; } (* Variant that set output on first argumet *) let (=*$$=) = let out es1 es2 = let out = get_output es1 in if dbg then eprintf "CtrlFirst %a %a -> %a\n" debug_output es1 debug_output es2 debug_events out ; Some out in check_disjoint (control_comp get_ctrl_output minimals out) (* Variant that removes some es2 input from iico_ctrl targets *) let bind_ctrl_avoid aset es1 es2 = Some (control_comp maximals (minimals_avoid aset) sequence_control_output es1 es2) let bind_ctrl_sequence_data = check_disjoint (control_comp get_ctrl_output minimals sequence_data_output) let bind_ctrl_sequence_data_po es1 es2 = let r = control_comp get_ctrl_output minimals sequence_data_output es1 es2 in Some { r with partial_po = seq_partial_po es1 es2 } let partial_po_union3 = if is_po_partial then fun es1 es2 es3 -> EventTransRel.union3 es1.partial_po es2.partial_po es3.partial_po else fun _ _ _ -> EventTransRel.empty let partial_po_union4 = if is_po_partial then fun es1 es2 es3 es4 -> EventTransRel.union4 es1.partial_po es2.partial_po es3.partial_po es4.partial_po else fun _ _ _ _ -> EventTransRel.empty let partial_po_union5 = if is_po_partial then fun es1 es2 es3 es4 es5 -> EventTransRel.union5 es1.partial_po es2.partial_po es3.partial_po es4.partial_po es5.partial_po else fun _ _ _ _ _ -> EventTransRel.empty let partial_po_union6 = if is_po_partial then fun es1 es2 es3 es4 es5 es6 -> EventTransRel.union6 es1.partial_po es2.partial_po es3.partial_po es4.partial_po es5.partial_po es6.partial_po else fun _ _ _ _ _ _ -> EventTransRel.empty let partial_po_unions = if is_po_partial then fun li -> List.map (fun es -> es.partial_po) li |> EventTransRel.unions else fun _ -> EventTransRel.empty let po_union4 = if do_deps then fun es1 es2 es3 es4 -> let r1,e1 = es1.po and r2,e2 = es2.po and r3,e3 = es3.po and r4,e4 = es4.po in (EventSet.union4 r1 r2 r3 r4, EventRel.union4 e1 e2 e3 e4) else fun es _ _ _ -> es.po let po_union3 = if do_deps then fun es1 es2 es3 -> let r1,e1 = es1.po and r2,e2 = es2.po and r3,e3 = es3.po in (EventSet.union3 r1 r2 r3, EventRel.union3 e1 e2 e3) else fun es _ _ -> es.po let union3 es1 es2 es3 = { procs = []; events = EventSet.union3 es1.events es2.events es3.events; speculated = begin if do_deps then EventSet.union3 es1.speculated es2.speculated es3.speculated else es1.speculated end; po = po_union3 es1 es2 es3; partial_po = partial_po_union3 es1 es2 es3; intra_causality_data = EventRel.union3 es1.intra_causality_data es2.intra_causality_data es3.intra_causality_data; intra_causality_control = EventRel.union3 es1.intra_causality_control es2.intra_causality_control es3.intra_causality_control; intra_causality_order = EventRel.union3 es1.intra_causality_order es2.intra_causality_order es3.intra_causality_order; control = EventRel.union3 es1.control es2.control es3.control; data_ports = EventSet.union3 es1.data_ports es2.data_ports es3.data_ports; success_ports = EventSet.union3 es1.success_ports es2.success_ports es3.success_ports; input = None ; data_input = None ; output = None; ctrl_output = None ; sca = EventSetSet.union3 es1.sca es2.sca es3.sca; mem_accesses = EventSet.union3 es1.mem_accesses es2.mem_accesses es3.mem_accesses; aligned = es1.aligned @ es2.aligned @ es3.aligned; } (* Build es1 -ctrl+data-> es3 <-data- es2 monad. Notice the contrast in output definition of es1 and es2 (maximals_commits vs. get_output) *) let bind_ctrldata_data es1 es2 es3 = let input_es3 = minimals es3 in let r = union3 es1 es2 es3 in { r with intra_causality_data = EventRel.union r.intra_causality_data (EventRel.cartesian (EventSet.union (get_output es1) (get_output es2)) input_es3); intra_causality_control = EventRel.union r.intra_causality_control (EventRel.cartesian (get_ctrl_output_commits es1) input_es3); input = union_input es1 es2; data_input = union_data_input es1 es2; output = sequence_data_output es2 es3; } (* Control+data composition, both output stay in first structure *) let bind_ctrldata_first_outputs es1 es2 = let data_out1 = get_output es1 and ctrl_out1 = get_ctrl_output_commits es1 in let r = union es1 es2 in let r = { r with intra_causality_data = EventRel.union r.intra_causality_data (EventRel.cartesian data_out1 (minimals_data_no_spurious es2)) ; intra_causality_control = EventRel.union r.intra_causality_control (EventRel.cartesian ctrl_out1 (minimals_no_spurious es2)) ; input = seq_input es1 es2 ; data_input = seq_data_input es1 es2 ; output = Some data_out1 ; ctrl_output = Some ctrl_out1 ; } in Some r (* Control composition, both output stay in first structure *) let bind_ctrl_first_outputs es1 es2 = let data_out1 = get_output es1 and ctrl_out1 = get_ctrl_output_commits es1 in let r = union es1 es2 in let r = { r with intra_causality_control = EventRel.union r.intra_causality_control (EventRel.cartesian ctrl_out1 es2.events) ; input = seq_input es1 es2 ; data_input = seq_data_input es1 es2 ; output = Some data_out1 ; ctrl_output = Some ctrl_out1 ; } in Some r (* Order composition. *) let bind_order es1 es2 = let r = union es1 es2 in let intra_causality_order = EventRel.union r.intra_causality_order (EventRel.cartesian (get_output es1) (minimals es2)) in Some { r with intra_causality_order } (* Multi composition for exchange *) (* rsX/wsX are from/to the same location *) let exch_comp rs1 rs2 ws1 ws2 = { procs = [] ; events = EventSet.union4 rs1.events rs2.events ws1.events ws2.events; speculated = if do_deps then EventSet.union4 rs1.speculated rs2.speculated ws1.speculated ws2.speculated else rs1.speculated; po = po_union4 rs1 rs2 ws1 ws2; partial_po = partial_po_union4 rs1 rs2 ws1 ws2; intra_causality_data = EventRel.union3 (EventRel.union4 rs1.intra_causality_data rs2.intra_causality_data ws1.intra_causality_data ws2.intra_causality_data) (EventRel.cartesian (maximals rs1) (minimals ws2)) (EventRel.cartesian (maximals rs2) (minimals ws1)); intra_causality_control = EventRel.union3 (EventRel.union4 rs1.intra_causality_control rs2.intra_causality_control ws1.intra_causality_control ws2.intra_causality_control) (EventRel.cartesian (maximals rs1) (minimals ws1)) (EventRel.cartesian (maximals rs2) (minimals ws2)); intra_causality_order = EventRel.union4 rs1.intra_causality_order rs2.intra_causality_order ws1.intra_causality_order ws2.intra_causality_order; control = EventRel.union4 rs1.control rs2.control ws1.control ws2.control; data_ports = EventSet.union4 rs1.data_ports rs2.data_ports ws1.data_ports ws2.data_ports; success_ports = EventSet.union4 rs1.success_ports rs2.success_ports ws1.success_ports ws2.success_ports; input = None ; data_input = None ; output = None; ctrl_output = None ; sca = EventSetSet.union4 rs1.sca rs2.sca ws1.sca ws2.sca; mem_accesses = EventSet.union4 rs1.mem_accesses rs2.mem_accesses ws1.mem_accesses ws2.mem_accesses ; aligned = rs1.aligned @ rs2.aligned @ ws1.aligned @ ws2.aligned ; } let po_union5 es1 es2 es3 es4 es5 = let r1,e1 = es1.po and r2,e2 = es2.po and r3,e3 = es3.po and r4,e4 = es4.po and r5,e5 = es5.po in (EventSet.union5 r1 r2 r3 r4 r5, EventRel.union5 e1 e2 e3 e4 e5) (* Notice If swp then add ctrl dependency from rmem to wmem, else (amo) add data dependency If physical and branching add dependencies *) let swp_or_amo physical op rloc rmem rreg wmem wreg = let is_amo = Misc.is_some op in let outrmem = maximals rmem and outrreg = maximals rreg and inwmem = minimals wmem and inwreg = minimals wreg and inrmem = minimals rmem in let inmem = EventSet.union inrmem inwmem in let mem2mem = EventRel.cartesian outrmem inwmem in { procs = [] ; events = EventSet.union5 rloc.events rmem.events rreg.events wmem.events wreg.events; speculated = if do_deps then EventSet.union5 rloc.speculated rmem.speculated rreg.speculated wmem.speculated wreg.speculated else rloc.speculated; po = po_union5 rloc rmem rreg wmem wreg; partial_po = partial_po_union5 rloc rmem rreg wmem wreg; intra_causality_data = EventRel.unions [EventRel.union5 rloc.intra_causality_data rmem.intra_causality_data rreg.intra_causality_data wmem.intra_causality_data wreg.intra_causality_data ; EventRel.cartesian outrmem inwreg; if is_amo then mem2mem else EventRel.empty; EventRel.cartesian outrreg inwmem; EventRel.cartesian (get_output rloc) inmem]; intra_causality_control = EventRel.unions [EventRel.unions [rloc.intra_causality_control; rmem.intra_causality_control;rreg.intra_causality_control; wmem.intra_causality_control;wreg.intra_causality_control;]; if memtag || (physical && is_branching) then (* Notice similarity with data composition. *) EventRel.cartesian (get_ctrl_output_commits rloc) (EventSet.union inmem inwreg) else EventRel.empty;]; intra_causality_order = EventRel.union (EventRel.union5 rloc.intra_causality_order rmem.intra_causality_order rreg.intra_causality_order wmem.intra_causality_order wreg.intra_causality_control) (if is_amo then EventRel.empty else mem2mem); control = EventRel.union5 rloc.control rmem.control rreg.control wmem.control wreg.control; data_ports = EventSet.union5 rloc.data_ports rmem.data_ports rreg.data_ports wmem.data_ports wreg.data_ports; success_ports = EventSet.union5 rloc.success_ports rmem.success_ports rreg.success_ports wmem.success_ports wreg.success_ports; input = None; data_input = None; output = None; ctrl_output = None ; sca = EventSetSet.union5 rloc.sca rmem.sca rreg.sca wmem.sca wreg.sca; mem_accesses = EventSet.union5 rloc.mem_accesses rmem.mem_accesses rreg.mem_accesses wmem.mem_accesses wreg.mem_accesses ; aligned = rloc.aligned @ rmem.aligned @ rreg.aligned @ wmem.aligned @ wreg.aligned ; } (* disjointness is awful *) let exch rx ry wx wy = if EventSet.disjoint rx.events ry.events && EventSet.disjoint rx.events wx.events && EventSet.disjoint rx.events wy.events && EventSet.disjoint ry.events wx.events && EventSet.disjoint ry.events wy.events && EventSet.disjoint wx.events wy.events then exch_comp rx ry wx wy else assert false let linux_exch re rloc rmem wmem = let input_wmem = minimals wmem in let output_rloc = maximals rloc in { procs = []; events = EventSet.union4 re.events rloc.events rmem.events wmem.events; speculated = if do_deps then EventSet.union4 re.speculated rloc.speculated rmem.speculated wmem.speculated else re.speculated; po = po_union4 re rloc rmem wmem; partial_po = partial_po_union4 re rloc rmem wmem; intra_causality_data = EventRel.unions [EventRel.union4 re.intra_causality_data rloc.intra_causality_data rmem.intra_causality_data wmem.intra_causality_data; EventRel.cartesian (maximals re) input_wmem; EventRel.cartesian output_rloc input_wmem; EventRel.cartesian output_rloc (minimals rmem);]; intra_causality_control = EventRel.union (EventRel.union4 re.intra_causality_control rloc.intra_causality_control rmem.intra_causality_control wmem.intra_causality_control) (EventRel.cartesian (maximals rmem) (minimals wmem)); intra_causality_order = EventRel.union4 re.intra_causality_order rloc.intra_causality_order rmem.intra_causality_order wmem.intra_causality_order; control = EventRel.union4 re.control rloc.control rmem.control wmem.control; data_ports = EventSet.union4 re.data_ports rloc.data_ports rmem.data_ports wmem.data_ports; success_ports = EventSet.union4 re.success_ports rloc.success_ports rmem.success_ports wmem.success_ports; input = None; data_input = None; output = Some (get_output rmem); ctrl_output = None ; sca = EventSetSet.union4 re.sca rloc.sca rmem.sca wmem.sca; mem_accesses = EventSet.union4 re.mem_accesses rloc.mem_accesses rmem.mem_accesses wmem.mem_accesses; aligned = re.aligned @ rloc.aligned @ rmem.aligned @ wmem.aligned ; } let amo re rloc rmem wmem = let input_wmem = minimals wmem in let output_rloc = maximals rloc in { procs = []; events = EventSet.union4 re.events rloc.events rmem.events wmem.events; speculated = if do_deps then EventSet.union4 re.speculated rloc.speculated rmem.speculated wmem.speculated else re.speculated; po = po_union4 re rloc rmem wmem; partial_po = partial_po_union4 re rloc rmem wmem; intra_causality_data = EventRel.unions [EventRel.union4 re.intra_causality_data rloc.intra_causality_data rmem.intra_causality_data wmem.intra_causality_data; EventRel.cartesian (maximals rmem) input_wmem; EventRel.cartesian (maximals re) input_wmem; EventRel.cartesian output_rloc input_wmem; EventRel.cartesian output_rloc (minimals rmem);]; intra_causality_control = EventRel.union4 re.intra_causality_control rloc.intra_causality_control rmem.intra_causality_control wmem.intra_causality_control; intra_causality_order = EventRel.union4 re.intra_causality_order rloc.intra_causality_order rmem.intra_causality_order wmem.intra_causality_order; control = EventRel.union4 re.control rloc.control rmem.control wmem.control; data_ports = EventSet.union4 re.data_ports rloc.data_ports rmem.data_ports wmem.data_ports; success_ports = EventSet.union4 re.success_ports rloc.success_ports rmem.success_ports wmem.success_ports; input = None; data_input = None; output = Some (get_output rmem); ctrl_output = None ; sca = EventSetSet.union4 re.sca rloc.sca rmem.sca wmem.sca; mem_accesses = EventSet.union4 re.mem_accesses rloc.mem_accesses rmem.mem_accesses wmem.mem_accesses; aligned = re.aligned @ rloc.aligned @ rmem.aligned @ wmem.aligned ; } (************************************) (* Compare exchange, really complex *) (************************************) (* Success *) let linux_cmpexch_ok rloc rold rnew rmem wmem = let input_wmem = minimals wmem in let input_rmem = minimals rmem in let output_rloc = maximals rloc in { procs = []; events = EventSet.union5 rloc.events rold.events rnew.events rmem.events wmem.events; speculated = if do_deps then EventSet.union5 rloc.speculated rold.speculated rnew.speculated rmem.speculated wmem.speculated else rloc.speculated; po = po_union5 rloc rold rnew rmem wmem; partial_po = partial_po_union5 rloc rold rnew rmem wmem; intra_causality_data = EventRel.unions [EventRel.union5 rloc.intra_causality_data rold.intra_causality_data rnew.intra_causality_data rmem.intra_causality_data wmem.intra_causality_data; EventRel.cartesian (maximals rnew) input_wmem; EventRel.cartesian output_rloc input_wmem; EventRel.cartesian output_rloc input_rmem;]; intra_causality_control = EventRel.unions [EventRel.union5 rloc.intra_causality_control rold.intra_causality_control rnew.intra_causality_control rmem.intra_causality_control wmem.intra_causality_control; EventRel.cartesian (maximals rold) input_wmem; EventRel.cartesian (maximals rmem) input_wmem;]; intra_causality_order = EventRel.union5 rloc.intra_causality_order rold.intra_causality_order rnew.intra_causality_order rmem.intra_causality_order wmem.intra_causality_order; control= EventRel.union5 rloc.control rold.control rnew.control rmem.control wmem.control; data_ports= EventSet.union5 rloc.data_ports rold.data_ports rnew.data_ports rmem.data_ports wmem.data_ports; input = None; data_input = None; output=Some (get_output rmem); ctrl_output = None ; success_ports= EventSet.union5 rloc.success_ports rold.success_ports rnew.success_ports rmem.success_ports wmem.success_ports; sca = EventSetSet.union5 rloc.sca rold.sca rnew.sca rmem.sca wmem.sca; mem_accesses= EventSet.union5 rloc.mem_accesses rold.mem_accesses rnew.mem_accesses rmem.mem_accesses wmem.mem_accesses; aligned = rloc.aligned @ rold.aligned @ rnew.aligned @ rmem.aligned @ wmem.aligned ; } (* Failure, a phantom write event that would iico_control depens upon rold may be an idea... Without it rold has no impact out evt_struct outcome... As another illustration of something lacking the cmpxchg introduces no new iico_control edge. *) let linux_cmpexch_no rloc rold rmem = let input_rmem = minimals rmem in let output_rloc = maximals rloc in { procs = []; events = EventSet.union3 rloc.events rold.events rmem.events; speculated = if do_deps then EventSet.union3 rloc.speculated rold.speculated rmem.speculated else rloc.speculated; po = po_union3 rloc rold rmem; partial_po = partial_po_union3 rloc rold rmem; intra_causality_data = EventRel.unions [EventRel.union3 rloc.intra_causality_data rold.intra_causality_data rmem.intra_causality_data; EventRel.cartesian output_rloc input_rmem;]; intra_causality_control = EventRel.union3 rloc.intra_causality_control rold.intra_causality_control rmem.intra_causality_control; intra_causality_order = EventRel.union3 rloc.intra_causality_order rold.intra_causality_order rmem.intra_causality_order; control= EventRel.union3 rloc.control rold.control rmem.control; data_ports= EventSet.union3 rloc.data_ports rold.data_ports rmem.data_ports; success_ports= EventSet.union3 rloc.success_ports rold.success_ports rmem.success_ports; input=None; data_input=None; output=Some (get_output rmem); ctrl_output = None ; sca = EventSetSet.union3 rloc.sca rold.sca rmem.sca; mem_accesses= EventSet.union3 rloc.mem_accesses rold.mem_accesses rmem.mem_accesses; aligned = rloc.aligned @ rold.aligned @ rmem.aligned ; } (**************) (* Add unless *) (**************) let linux_add_unless_ok loc a u rmem wmem retbool = let out_loc = maximals loc and in_rmem = minimals rmem and in_wmem = minimals wmem in { procs = []; events = EventSet.union5 loc.events a.events u.events rmem.events wmem.events; speculated = if do_deps then EventSet.union5 loc.speculated a.speculated u.speculated rmem.speculated wmem.speculated else loc.speculated; po = po_union5 loc a u rmem wmem; partial_po = partial_po_union5 loc a u rmem wmem; intra_causality_data = EventRel.unions [EventRel.union5 loc.intra_causality_data a.intra_causality_data u.intra_causality_data rmem.intra_causality_data wmem.intra_causality_data; EventRel.cartesian out_loc in_wmem; EventRel.cartesian out_loc in_rmem; EventRel.cartesian (maximals a) in_wmem; EventRel.cartesian (maximals rmem) in_wmem;]; intra_causality_control = EventRel.unions [EventRel.union5 loc.intra_causality_control a.intra_causality_control u.intra_causality_control rmem.intra_causality_control wmem.intra_causality_control; EventRel.cartesian (maximals u) in_wmem;]; intra_causality_order = EventRel.union5 loc.intra_causality_order a.intra_causality_order u.intra_causality_order rmem.intra_causality_order wmem.intra_causality_order; control = EventRel.union5 loc.control a.control u.control rmem.control wmem.control; data_ports = EventSet.union5 loc.data_ports a.data_ports u.data_ports rmem.data_ports wmem.data_ports; success_ports = EventSet.union5 loc.success_ports a.success_ports u.success_ports rmem.success_ports wmem.success_ports; input=None; data_input=None; output = Some (if retbool then EventSet.union (get_output rmem) (get_output u) else get_output rmem); ctrl_output = None ; sca = EventSetSet.union5 loc.sca a.sca u.sca rmem.sca wmem.sca; mem_accesses = EventSet.union5 loc.mem_accesses a.mem_accesses u.mem_accesses rmem.mem_accesses wmem.mem_accesses; aligned = loc.aligned @ a.aligned @ u.aligned @ rmem.aligned @ wmem.aligned ; } let linux_add_unless_no loc u rmem retbool = let out_loc = maximals loc and in_rmem = minimals rmem in { procs = []; events = EventSet.union3 loc.events u.events rmem.events; speculated = if do_deps then EventSet.union3 loc.speculated u.speculated rmem.speculated else loc.speculated; po = po_union3 loc u rmem; partial_po = partial_po_union3 loc u rmem; intra_causality_data = EventRel.unions [loc.intra_causality_data; u.intra_causality_data; rmem.intra_causality_data; EventRel.cartesian out_loc in_rmem;]; intra_causality_control = EventRel.union3 loc.intra_causality_control u.intra_causality_control rmem.intra_causality_control; intra_causality_order = EventRel.union3 loc.intra_causality_order u.intra_causality_order rmem.intra_causality_order; control = EventRel.union3 loc.control u.control rmem.control; data_ports = EventSet.union3 loc.data_ports u.data_ports rmem.data_ports; success_ports = EventSet.union3 loc.success_ports u.success_ports rmem.success_ports; input=None; data_input=None; output = Some (if retbool then EventSet.union (get_output rmem) (get_output u) else get_output rmem); ctrl_output = None ; sca = EventSetSet.union3 loc.sca u.sca rmem.sca ; mem_accesses = EventSet.union3 loc.mem_accesses u.mem_accesses rmem.mem_accesses; aligned = loc.aligned @ u.aligned @ rmem.aligned ; } let po_union6 = if do_deps then fun es1 es2 es3 es4 es5 es6 -> let r1,e1 = es1.po and r2,e2 = es2.po and r3,e3 = es3.po and r4,e4 = es4.po and r5,e5 = es5.po and r6,e6 = es6.po in let r = EventSet.union (EventSet.union3 r1 r2 r3) (EventSet.union3 r4 r5 r6) and e = EventRel.union (EventRel.union3 e1 e2 e3) (EventRel.union3 e4 e5 e6) in r,e else fun es _ _ _ _ _ -> es.po let po_unions = if do_deps then List.fold_left (fun (roots, edges) evt_st -> let r,e = evt_st.po in EventSet.union r roots,EventRel.union e edges) (EventSet.empty,EventRel.empty) else function | hd::_ -> hd.po | [] -> assert false (* RISCV Store conditional *) let get_switch v = Variant.get_switch A.arch v C.variant let riscv_sc success resa data addr wres wresult wmem = let dep_on_write = get_switch Variant.SwitchDepScWrite and dep_sc_result = get_switch Variant.SwitchDepScResult in let in_wmem = minimals wmem and out_wmem = maximals wmem and in_wres = minimals wres and in_wresult = minimals wresult and out_data = maximals data and out_resa = maximals resa in { procs = []; events = EventSet.union (EventSet.union3 resa.events data.events addr.events) (EventSet.union3 wres.events wresult.events wmem.events); speculated = if do_deps then EventSet.union (EventSet.union3 resa.speculated data.speculated addr.speculated) (EventSet.union3 wres.speculated wresult.speculated wmem.speculated) else resa.speculated; po = po_union6 resa data addr wres wresult wmem; partial_po = partial_po_union6 resa data addr wres wresult wmem; intra_causality_data = EventRel.unions [EventRel.union3 resa.intra_causality_data data.intra_causality_data addr.intra_causality_data; EventRel.union3 wres.intra_causality_data wresult.intra_causality_data wmem.intra_causality_data; EventRel.cartesian (get_output addr) (EventSet.union in_wmem (if (C.variant Variant.FullScDepend || success) && dep_sc_result then in_wresult else EventSet.empty)); EventRel.cartesian out_data (if C.variant Variant.Success || not (C.variant Variant.FullScDepend) then in_wmem else EventSet.union in_wresult in_wmem); ]; intra_causality_control = EventRel.union5 (EventRel.cartesian out_resa in_wres) (EventRel.cartesian (EventSet.union out_resa (if is_branching then get_ctrl_output_commits addr else get_ctrl_output addr)) in_wmem) (if dep_on_write then EventRel.cartesian out_wmem in_wresult else EventRel.empty) (EventRel.union3 resa.intra_causality_control data.intra_causality_control addr.intra_causality_control) (EventRel.union3 wres.intra_causality_control wresult.intra_causality_control wmem.control); intra_causality_order = EventRel.union6 resa.intra_causality_order data.intra_causality_order addr.intra_causality_order wres.intra_causality_order wresult.intra_causality_order wmem.intra_causality_order; control = EventRel.union (EventRel.union3 resa.control data.control addr.control) (EventRel.union3 wres.control wresult.control wmem.control); data_ports = EventSet.union (EventSet.union3 resa.data_ports data.data_ports addr.data_ports) (EventSet.union3 wres.data_ports wresult.data_ports wmem.data_ports); success_ports = EventSet.union (EventSet.union3 resa.success_ports data.success_ports addr.success_ports) (EventSet.union3 wres.success_ports wresult.success_ports wmem.success_ports); input=None; data_input=None; output = Some (EventSet.union (get_output wresult) (get_output wres)); ctrl_output = None ; sca = EventSetSet.union (EventSetSet.union3 resa.sca data.sca addr.sca) (EventSetSet.union3 wres.sca wresult.sca wmem.sca); mem_accesses = EventSet.union (EventSet.union3 resa.mem_accesses data.mem_accesses addr.mem_accesses) (EventSet.union3 wres.mem_accesses wresult.mem_accesses wmem.mem_accesses); aligned = resa.aligned @ data.aligned @ addr.aligned @ wres.aligned @ wresult.aligned @ wmem.aligned ;} (* AArch64 CAS, failure *) let aarch64_cas_no is_phy add_ctrl rn rs wrs rm br = let input_wrs = minimals wrs and input_rm = minimals rm and input_br = minimals br in { procs = [] ; events = EventSet.union5 rn.events rs.events wrs.events rm.events br.events; speculated = if do_deps then EventSet.union5 rn.speculated rs.speculated wrs.speculated rm.speculated br.speculated else rn.speculated; po = po_union5 rn rs wrs rm br; partial_po = partial_po_union5 rn rs wrs rm br; intra_causality_data = EventRel.union (EventRel.union5 rn.intra_causality_data rs.intra_causality_data wrs.intra_causality_data rm.intra_causality_data br.intra_causality_data) (EventRel.union4 (EventRel.cartesian (get_output rn) input_rm) (* D1 *) (EventRel.cartesian (get_output rm) input_wrs) (* Df1 *) (EventRel.cartesian (get_output rm) input_br) (EventRel.cartesian (get_output rs) input_br) ); intra_causality_control = (if is_branching && is_phy then EventRel.union (EventRel.cartesian (get_ctrl_output_commits rn) input_rm) else Misc.identity) ((if add_ctrl then EventRel.union (EventRel.cartesian (get_output br) input_wrs) else Misc.identity) (EventRel.union5 rn.intra_causality_control rs.intra_causality_control wrs.intra_causality_control rm.intra_causality_control br.intra_causality_control)) ; intra_causality_order = EventRel.union5 rn.intra_causality_order rs.intra_causality_order wrs.intra_causality_order rm.intra_causality_order br.intra_causality_order; control = EventRel.union5 rn.control rs.control rm.control wrs.control br.control; data_ports = EventSet.union5 rn.data_ports rs.data_ports wrs.data_ports rm.data_ports br.data_ports; success_ports = EventSet.union5 rn.success_ports rs.success_ports wrs.success_ports rm.success_ports br.success_ports; sca = EventSetSet.union5 rn.sca rs.sca wrs.sca rm.sca br.sca; mem_accesses = EventSet.union5 rn.mem_accesses rs.mem_accesses wrs.mem_accesses rm.mem_accesses br.mem_accesses; input=None; data_input=None; output = Some (maximals wrs); ctrl_output = None ; aligned = rn.aligned @ rs.aligned @ wrs.aligned @ rm.aligned @ br.aligned; } (* AArch64 CAS, success *) let aarch64_cas_ok is_phy prov_data rn rs rt wrs rm wm br = let input_wrs = minimals wrs and input_rm = minimals rm and input_wm = minimals wm and input_br = minimals br in { procs = [] ; events = EventSet.unions [rn.events; rs.events; rt.events; wrs.events; rm.events; br.events; wm.events]; speculated = if do_deps then EventSet.unions [rn.speculated; rs.speculated; rt.speculated; wrs.speculated; rm.speculated; br.speculated; wm.speculated] else rn.speculated; po = po_unions [rn; rs; rt; wrs; rm; br; wm]; partial_po = partial_po_unions [rn; rs; rt; wrs; rm; br; wm]; intra_causality_data = EventRel.union (EventRel.unions [rn.intra_causality_data; rs.intra_causality_data; rt.intra_causality_data; wrs.intra_causality_data; rm.intra_causality_data; br.intra_causality_data; wm.intra_causality_data]) (let output_rn = get_output rn and output_prov_data = match prov_data with | `DataFromRRs -> get_output rs | `DataFromRx -> get_output rm in EventRel.unions [(EventRel.cartesian output_rn input_rm); (* D1 *) (EventRel.cartesian output_rn input_wm); (* Ds2 *) (EventRel.cartesian (get_output rt) input_wm); (* Ds3 *) (EventRel.cartesian output_prov_data input_wrs); (EventRel.cartesian (get_output rs) input_br); (EventRel.cartesian (get_output rm) input_br);] ); intra_causality_control = EventRel.union (EventRel.unions [rn.intra_causality_control; rs.intra_causality_control; rt.intra_causality_control; wrs.intra_causality_control; rm.intra_causality_control; br.intra_causality_control; wm.intra_causality_control]) (let output_br = get_ctrl_output br in EventRel.union4 (if is_branching && is_phy then EventRel.cartesian (get_ctrl_output_commits rn) (EventSet.union input_rm input_wm) else EventRel.empty) (match prov_data with | `DataFromRRs -> EventRel.cartesian output_br input_wrs | `DataFromRx -> EventRel.empty) (EventRel.cartesian output_br input_wm) (* Cs1 *) (EventRel.cartesian output_br input_wm)); (* Cs2 *) intra_causality_order = EventRel.unions [rn.intra_causality_order; rs.intra_causality_order; rt.intra_causality_order; wrs.intra_causality_order; rm.intra_causality_order; br.intra_causality_order; wm.intra_causality_order]; control = (EventRel.unions [rn.control; rs.control; rt.control; wrs.control; rm.control; br.control; wm.control]); data_ports = (EventSet.unions [rn.data_ports; rs.data_ports; rt.data_ports; wrs.data_ports; rm.data_ports; br.data_ports; wm.data_ports]); success_ports = (EventSet.unions [rn.success_ports; rs.success_ports; rt.success_ports; wrs.success_ports; rm.success_ports; br.success_ports; wm.success_ports]); sca = (EventSetSet.unions [rn.sca; rs.sca; rt.sca; wrs.sca; rm.sca; br.sca; wm.sca]); mem_accesses = (EventSet.unions [rn.mem_accesses; rs.mem_accesses; rt.mem_accesses; wrs.mem_accesses; rm.mem_accesses; br.mem_accesses; wm.mem_accesses]); input=None; data_input=None; output = Some (maximals wrs); ctrl_output = None ; aligned = rn.aligned @ rs.aligned @ rt.aligned @ wrs.aligned @ rm.aligned @ br.aligned @ wm.aligned ; } (* Temporary morello variation of CAS *) let aarch64_cas_ok_morello rn rt rm wm = let input_rm = minimals rm and input_wm = minimals wm in { procs = [] ; events = EventSet.union4 rn.events rt.events rm.events wm.events ; speculated = if do_deps then EventSet.union4 rn.speculated rt.speculated rm.speculated wm.speculated else rn.speculated; po = po_union4 rn rt rm wm; partial_po = partial_po_union4 rn rt rm wm; intra_causality_data = EventRel.union (EventRel.union4 rn.intra_causality_data rt.intra_causality_data rm.intra_causality_data wm.intra_causality_data) (let output_rn = get_output rn in EventRel.union3 (EventRel.cartesian output_rn input_rm) (EventRel.cartesian output_rn input_wm) (EventRel.cartesian (get_output rt) input_wm)); intra_causality_control = EventRel.union (EventRel.union4 rn.intra_causality_control rt.intra_causality_control rm.intra_causality_control wm.intra_causality_control) (EventRel.cartesian (get_ctrl_output rm) input_wm); intra_causality_order = EventRel.union4 rn.intra_causality_order rt.intra_causality_order rm.intra_causality_order wm.intra_causality_order; control = (EventRel.union4 rn.control rt.control rm.control wm.control); data_ports = (EventSet.union4 rn.data_ports rt.data_ports rm.data_ports wm.data_ports); success_ports = (EventSet.union4 rn.success_ports rt.success_ports rm.success_ports wm.success_ports); sca = (EventSetSet.union4 rn.sca rt.sca rm.sca wm.sca); mem_accesses = (EventSet.union4 rn.mem_accesses rt.mem_accesses rm.mem_accesses wm.mem_accesses); input=None; data_input=None; output = None; ctrl_output = None ; aligned = rn.aligned @ rt.aligned @ rm.aligned @ wm.aligned ; } (* Store update composition, read data, read EA, write EA and write Mem *) (* Dijointness not checked..., useless *) let stu rD rEA wEA wM = assert (EventRel.is_empty rD.intra_causality_control && EventRel.is_empty rEA.intra_causality_control && EventRel.is_empty wEA.intra_causality_control && EventRel.is_empty wM.intra_causality_control) ; { procs = [] ; events = EventSet.union4 rD.events rEA.events wEA.events wM.events; speculated = if do_deps then EventSet.union4 rD.speculated rEA.speculated wEA.speculated wM.speculated else rD.speculated; po = po_union4 rD rEA wEA wM; partial_po = partial_po_union4 rD rEA wEA wM; intra_causality_data = begin let drD = rD.intra_causality_data and drEA = rEA.intra_causality_data and dwEA = wEA.intra_causality_data and dwM = wM.intra_causality_data in EventRel.unions [EventRel.unions [drD; drEA; dwEA; dwM;]; EventRel.cartesian (get_output rEA) (minimals wEA); EventRel.cartesian (EventSet.union (get_output rEA) (get_output rD)) (minimals wM);] end ; intra_causality_control = EventRel.empty; intra_causality_order = EventRel.empty; control = EventRel.union4 rD.control rEA.control wEA.control wM.control ; data_ports = EventSet.union4 rD.data_ports rEA.data_ports wEA.data_ports wM.data_ports ; success_ports = EventSet.union4 rD.success_ports rEA.success_ports wEA.success_ports wM.success_ports ; input=None; data_input=None; output = None; ctrl_output = None ; sca = EventSetSet.union4 rD.sca rEA.sca wEA.sca wM.sca; mem_accesses = EventSet.union4 rD.mem_accesses rEA.mem_accesses wEA.mem_accesses wM.mem_accesses ; aligned = rD.aligned @ rEA.aligned @ wEA.aligned @ wM.aligned ; } (*************************************************************) (* Add together event structures from different instructions *) (*************************************************************) let different_ins i1 i2 = match i1,i2 with | IdSome i1,IdSome i2 -> A.inst_instance_compare i1 i2 <> 0 | ((IdInit|IdSpurious),IdSome _) | (IdSome _,(IdInit|IdSpurious)) | ((IdInit|IdSpurious),(IdInit|IdSpurious)) -> true let disjoint_iiis es1 es2 = EventSet.for_all (fun e1 -> EventSet.for_all (fun e2 -> different_ins e1.iiid e2.iiid) es2.events) es1.events let check_both do_it es1 es2 = if not (EventSet.disjoint es1.events es2.events && disjoint_iiis es1 es2) then assert false else Some (do_it es1 es2) (* Parallel composition *) let (+|+) = check_both do_para_comp let empty_event_structure = empty (* Instruction control *) let cond_comp es1 es2 = let r = do_para_comp es1 es2 in let control = EventRel.cartesian es1.events es2.events in { r with control = EventRel.union control r.control; } (* Build from events - without any form of iico. *) let from_events events = let partial_po = if is_po_partial then EventTransRel.from_nodes events else EventTransRel.empty in { empty with events ; partial_po } end herd-herdtools7-1ca343e/herd/eventsMonad.ml000066400000000000000000002022411475314470400207020ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Authors: *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* Hadrien Renaud, University College London, UK. *) (****************************************************************************) (** A monad for event structures *) module type Config = sig val hexa : bool val debug : Debug_herd.t val variant : Variant.t -> bool end module Make (C:Config) (A:Arch_herd.S) (E:Event.S with module A = A and module Act.A = A) : (Monad.S with module A = A and module E = E and type evt_struct = E.event_structure) = struct open Printf module A = A module E = E module V = A.V module VC = Valconstraint.Make (struct let hexa = C.hexa let debug = C.debug let keep_failed_as_undetermined = C.variant Variant.ASL_AArch64 let old_solver = C.variant Variant.OldSolver end) (A) let dbg = C.debug.Debug_herd.mem let dbg_monad = C.debug.Debug_herd.monad let do_deps = C.variant Variant.Deps (* LM Use lists for polymorphism. It is assumed that list elts are pairwise distinct. *) module Evt = struct type 'a elt = ('a * VC.cnstrnts * E.event_structure) type 'a t = 'a elt list let empty = [] let singleton x = [x] let is_empty = function | [] -> true | _::_ -> false let as_singleton = function | [x] -> x | _ -> assert false let as_singleton_nospecul = fun (x,y) -> let x = as_singleton x in assert (y = None); x let add x s = x::s let map = List.map let fold f xs y0 = List.fold_left (fun x y -> f y x) y0 xs let foldfold f xs ys z0 = List.fold_left (fun z x -> List.fold_left (fun z y -> f x y z) z ys) z0 xs let union = (@) let elements (x:'a t) = x let rec check_same_value p x = match x with | [] -> true | elt::s -> p elt && check_same_value p s let wrap_check p x = match x with | [] -> assert false | elt::s -> assert(check_same_value (p elt) s); elt let rec combine_rec k xs ys = match xs,ys with | [],[] -> k | x::xs,y::ys -> combine_rec ((x,y)::k) xs ys | ([],_::_)|(_::_,[]) -> assert false (* By construction *) let combine xs ys = combine_rec [] xs ys end (* Monad type: + Argument is event identifier + Returned value is a pair, whose first element is concrete branch and second collects speculated branch. None means no speculation at all *) type eid = { id : int ; (* event identifier proper *) sub : int } (* identifier amongst one instruction instance *) let bump_eid { id; sub; } = { id=id+1; sub=sub+1; } type 'a t = eid -> eid * ('a Evt.t * 'a Evt.t option) let map_elt (f : 'a Evt.elt -> 'b Evt.elt) (m : 'a t) : 'b t = fun eid -> let eid', (evt, evt_spec) = m eid in (eid', (Evt.map f evt, Option.map (Evt.map f) evt_spec)) (* Code monad slight differs as regardes agument *) (* Threading by instruction instance identifier and event id proper *) type 'a code = (int * int) -> (int * int) * ('a Evt.t * 'a Evt.t option) let zeroT : 'a t = (fun eiid_next -> (eiid_next, (Evt.empty, None))) let zerocodeT : 'a code = (fun eiid_next -> (eiid_next, (Evt.empty, None))) let unitT (v : 'a) : 'a t = fun eiid_next -> eiid_next, (Evt.singleton (v, [], E.empty_event_structure), None) let warnT msg (v : 'a) : 'a t = fun eiid_next -> eiid_next, (Evt.singleton (v, [VC.Warn msg], E.empty_event_structure), None) let failT (e:exn) (v : 'a) : 'a t = fun eiid_next -> eiid_next, (Evt.singleton (v, [VC.Failed e], E.empty_event_structure), None) let ignore _ = unitT () let unitcodeT (v : 'a) : 'a code = fun eiid_next -> eiid_next, (Evt.singleton (v, [], E.empty_event_structure), None) let failcodeT (e:exn) (v : 'a) : 'a code = fun eiid_next -> eiid_next, (Evt.singleton (v, [VC.Failed e], E.empty_event_structure), None) let warncodeT (e : string) (v : 'a) : 'a code = fun eiid_next -> eiid_next, (Evt.singleton (v, [VC.Warn e], E.empty_event_structure), None) (* This very special combinator permits to get monad m's result, while postponing the usage of corresponding event structure. It proves convenient to express complex dependencies. Not compatible with speculation *) let delay_kont = fun tag (m:'a t) kont (eiid:eid) -> let eiid,(acts,specs) = m eiid in assert (specs=None) ; let eiid,acts = Evt.fold (fun (v,cls,es) (eiid,acts) -> if dbg_monad then begin eprintf "Delay %s output is %a\n" tag E.debug_output es end ; let delayed : 'a t = fun eiid -> eiid,(Evt.singleton (v,[],es),None) in let eiid,(acts2,specs) = kont v delayed eiid in assert (specs=None) ; let acts = Evt.fold (fun (v,cls2,es) acts -> Evt.add (v,cls@cls2,es) acts) acts2 acts in eiid,acts) acts (eiid,Evt.empty) in eiid,(acts,None) let delay (m:'a t) eiid = delay_kont "delay" m (fun v delayed -> unitT (v,delayed)) eiid let set_standard_input_output m eiid = let (eiid,(sact,sspec)) = m eiid in let set_std (v,cl,es) = let es = { es with E.input = None; data_input = None; output = None; ctrl_output = None; } in v,cl,es in let set_stds = Evt.map set_std in let sact = set_stds sact and sspec = Misc.map_opt set_stds sspec in eiid,(sact,sspec) let (=**=) = E.(=**=) let (=*$=) = E.(=*$=) let (=$$=) = E.(=$$=) let (=*$$=) = E.(=*$$=) let (+|+) = E.(+|+) let (=|=) = E.para_comp true (* Bind the result *) let data_comp comp_str s f = (fun eiid -> let (eiid,(sact,sspec)) = s eiid in assert(sspec = None); let eiid,(acts,specs) = Evt.fold (fun (v1, vcl1, es1) (eiid,(acts,specs)) -> let eiid,(b_acts,b_specs) = f v1 eiid in let acts = Evt.fold (fun (v2,vcl2,es2) acts -> match comp_str es1 es2 with | None -> acts | Some es -> Evt.add (v2,vcl2@vcl1,es) acts) b_acts acts in let specs = match b_specs with | None -> specs | Some b_specs -> Evt.fold (fun (v2,vcl2,es2) specs -> match comp_str (E.do_speculate es1) es2 with | None -> specs | Some es -> Evt.add (v2,vcl2@vcl2,es) specs) b_specs specs in eiid,(acts,specs)) sact (eiid,(Evt.empty,Evt.empty)) in let specs = if Evt.is_empty specs then None else Some specs in eiid,(acts,specs)) let (>>=) : 'a t -> ('a -> 'b t) -> ('b) t = fun s f -> data_comp (=*$=) s f let data_input_next s f = data_comp E.data_input_next s f let data_input_union s f = data_comp E.data_input_union s f let (>>==) : 'a t -> ('a -> 'b t) -> ('b) t = fun s f -> data_comp (=$$=) s f let data_output_union : 'a t -> ('a -> 'b t) -> ('b) t = fun s f -> data_comp (E.data_output_union) s f let asl_data s f = data_comp E.data_po_seq s f let (>>*=) : 'a t -> ('a -> 'b t) -> ('b) t = fun s f -> data_comp (=**=) s f let control_input_union s f = data_comp E.control_input_union s f let control_input_next s f = data_comp E.control_input_next s f let (>>*==) : 'a t -> ('a -> 'b t) -> ('b) t = fun s f -> data_comp (=*$$=) s f let bind_control_set_data_input_first s f = data_comp E.bind_control_set_data_input_first s f let bind_ctrl_avoid ma s f = fun eiid -> let eiid,(mact,spec) = ma eiid in assert(spec = None) ; let _,cl,es = Evt.as_singleton mact in assert (cl=[]) ; data_comp (E.bind_ctrl_avoid es.E.events) s f eiid let bind_ctrl_seq_data s f = data_comp E.bind_ctrl_sequence_data s f let asl_ctrl s f = data_comp E.bind_ctrl_sequence_data_po s f let bind_data_to_minimals s f = data_comp E.data_to_minimals s f let bind_data_to_output s f = data_comp E.data_to_output s f (* Triple composition *) let comp_comp comp_str m1 m2 m3 eiid = let eiid,(acts1,spec1) = m1 eiid in let eiid,(acts2,spec2) = m2 eiid in assert (spec1=None); assert (spec2=None); let eiid,acts = Evt.foldfold (fun (v1,cl1,es1) (v2,cl2,es2) (eiid,acts) -> let eiid,(acts3,spec3) = m3 v1 v2 eiid in assert (spec3=None) ; let acts = Evt.fold (fun (v3,cl3,es3) acts -> let es = comp_str es1 es2 es3 in Evt.add (v3,cl1@cl2@cl3,es) acts) acts3 acts in eiid,acts) acts1 acts2 (eiid,Evt.empty) in eiid,(acts,None) let bind_ctrldata_data m1 m2 m3 eiid = comp_comp E.bind_ctrldata_data m1 m2 m3 eiid let bind_ctrldata m1 m3 = bind_ctrldata_data m1 (unitT ()) (fun a () -> m3 a) let (>>**==) : 'a t -> ('a -> 'b t) -> ('b) t = fun s f -> data_comp E.bind_ctrldata_first_outputs s f let bind_ctrl_first_outputs s f = data_comp E.bind_ctrl_first_outputs s f let bind_order s f = data_comp E.bind_order s f (* Ad-hoc short-circuit *) let short p1 p2 m = fun eiid -> let eiid,(acts,specs) = m eiid in let acts = Evt.map (fun (v,cls,es) -> let data = let data = E.EventRel.filter (fun (e1,e2) -> p1 e1 && p2 e2) (E.EventRel.cartesian es.E.events es.E.events) in E.EventRel.union es.E.intra_causality_data data in v,cls,{ es with E.intra_causality_data=data; }) acts in eiid,(acts,specs) (* Ad-hoc upOne *) let upOneRW p m = fun eiid -> let eiid,(acts,specs) = m eiid in let acts = Evt.map (fun (v,cls,es) -> let data = es.E.intra_causality_data in let data = E.EventRel.fold (fun (e1,e0) k -> if p e1 && E.is_load e1 then E.EventRel.fold (fun (f0,e2) k -> if E.event_equal e0 f0 && p e2 && E.is_store e2 then E.EventRel.add (e1,e2) (E.EventRel.remove (e0,e2) k) else k) data k else k) data data in v,cls,{ es with E.intra_causality_data=data; }) acts in eiid,(acts,specs) (* Exchange combination *) let exch : 'a t -> 'a t -> ('a -> 'b t) -> ('a -> 'c t) -> ('b * 'c) t = fun rx ry wx wy -> fun eiid -> let eiid,rxact = rx eiid in let eiid,ryact = ry eiid in let (vrx,vclrx,esrx) = Evt.as_singleton_nospecul rxact and (vry,vclry,esry) = Evt.as_singleton_nospecul ryact in let eiid,wxact = wx vry eiid in let eiid,wyact = wy vrx eiid in let vwx,vclwx,eswx = Evt.as_singleton_nospecul wxact and vwy,vclwy,eswy = Evt.as_singleton_nospecul wyact in let es = E.exch esrx esry eswx eswy in eiid,(Evt.singleton((vwx,vwy),vclrx@vclry@vclwx@vclwy,es),None) (* Exchange combination *) (* NB: first boolean -> physical memory access *) let swp_or_amo : bool -> A.V.op_t option -> ('loc t) -> ('loc -> V.v t) -> V.v t -> ('loc -> V.v -> unit t) -> (V.v -> unit t) -> unit t = fun is_phy op rloc rmem rreg wmem wreg -> fun eiid -> let eiid,(locm,spec) = rloc eiid in assert (spec=None) ; let eiid,acts = Evt.fold (fun (loc,vlcloc,esloc) (eiid,acts) -> let eiid,expm = rreg eiid in let (v,vclexp,esexp) = Evt.as_singleton_nospecul expm in let eiid,rmemm = rmem loc eiid in let r = match op with None -> v | Some _ -> V.fresh_var () in let eiid,wmemm = wmem loc r eiid in let w,vclrmem,esrmem = Evt.as_singleton_nospecul rmemm and (),vclwmem,eswmem = Evt.as_singleton_nospecul wmemm in let vlop = match op with | None -> Misc.identity | Some op -> fun k -> VC.Assign (r,VC.Binop (op,w,v))::k in let eiid,wreg = wreg w eiid in let (),vclwreg,eswreg = Evt.as_singleton_nospecul wreg in let es = E.swp_or_amo is_phy op esloc esrmem esexp eswmem eswreg in let act = (),vlop (vlcloc@vclexp@vclrmem@vclwmem@vclwreg),es in eiid,Evt.add act acts) locm (eiid,Evt.empty) in eiid,(acts,None) let swp is_phy rloc rmem rreg wmem wreg = swp_or_amo is_phy None rloc rmem rreg wmem wreg let amo_strict is_phy op rloc rmem rreg wmem wreg = swp_or_amo is_phy (Some op) rloc rmem rreg wmem wreg (* linux exchange *) let linux_exch : 'loc t -> 'v t -> ('loc -> 'w t) -> ('loc -> 'v -> unit t) -> 'w t = fun rloc rexpr rmem wmem -> fun eiid -> let eiid,locm = rloc eiid in let eiid,expm = rexpr eiid in let (loc,vlcloc,esloc) = Evt.as_singleton_nospecul locm and (v,vclexp,esexp) = Evt.as_singleton_nospecul expm in let eiid,rmemm = rmem loc eiid in let eiid,wmemm = wmem loc v eiid in let w,vclrmem,esrmem = Evt.as_singleton_nospecul rmemm and (),vclwmem,eswmem = Evt.as_singleton_nospecul wmemm in let es = E.linux_exch esexp esloc esrmem eswmem in eiid, (Evt.singleton (w,vlcloc@vclexp@vclrmem@vclwmem,es),None) (* Amo, similar to exchange *) let amo : A.V.op_t -> 'loc t -> 'v t -> ('loc -> 'w t) -> ('loc -> 'v -> unit t) -> 'w t = fun op rloc rexpr rmem wmem -> fun eiid -> let eiid,locm = rloc eiid in let eiid,expm = rexpr eiid in let (loc,vlcloc,esloc) = Evt.as_singleton_nospecul locm and (v,vclexp,esexp) = Evt.as_singleton_nospecul expm in let eiid,rmemm = rmem loc eiid in let r = V.fresh_var () in let eiid,wmemm = wmem loc r eiid in let w,vclrmem,esrmem = Evt.as_singleton_nospecul rmemm and (),vclwmem,eswmem = Evt.as_singleton_nospecul wmemm in let vlop = VC.Assign (r,VC.Binop (op,w,v)) in let es = E.amo esexp esloc esrmem eswmem in eiid, (Evt.singleton (w,vlop::vlcloc@vclexp@vclrmem@vclwmem,es), None) (* Linux (successful) compexchange *) let linux_cmpexch_ok : 'loc t -> 'v t -> 'v t -> ('loc -> 'v t) -> ('loc -> 'v -> unit t) -> ('v -> 'v -> unit t) -> 'v t = fun rloc rold rnew rmem wmem req eiid -> let eiid,locm = rloc eiid in (* read location *) let eiid,oldm = rold eiid in (* read old value *) let eiid,newm = rnew eiid in (* read new value *) let (loc,vlcloc,esloc) = Evt.as_singleton_nospecul locm and (oldv,vlcold,esold) = Evt.as_singleton_nospecul oldm and (newv,vlcnew,esnew) = Evt.as_singleton_nospecul newm in let eiid,rmemm = rmem loc eiid in let eiid,wmemm = wmem loc newv eiid in let w,vclrmem,esrmem = Evt.as_singleton_nospecul rmemm and (),vclwmem,eswmem = Evt.as_singleton_nospecul wmemm in let es = E.linux_cmpexch_ok esloc esold esnew esrmem eswmem in let eiid,eqm = req oldv w eiid in let (),vcleq,eseq = Evt.as_singleton_nospecul eqm in assert (E.is_empty_event_structure eseq) ; eiid, (Evt.singleton (w,vcleq@vlcloc@vlcold@vlcnew@vclrmem@vclwmem,es), None) let linux_cmpexch_no : 'loc t -> 'v t -> ('loc -> 'v t) -> ('v -> 'v -> unit t) -> 'v t = fun rloc rold rmem rneq eiid -> let eiid,locm = rloc eiid in (* read location *) let eiid,oldm = rold eiid in (* read old value *) let (loc,vlcloc,esloc) = Evt.as_singleton_nospecul locm and (oldv,vlcold,esold) = Evt.as_singleton_nospecul oldm in let eiid,rmemm = rmem loc eiid in let w,vclrmem,esrmem = Evt.as_singleton_nospecul rmemm in let es = E.linux_cmpexch_no esloc esold esrmem in let eiid,eqm = rneq oldv w eiid in let (),vcleq,_ = Evt.as_singleton_nospecul eqm in eiid, (Evt.singleton (w,vcleq@vlcloc@vlcold@vclrmem,es), None) (**************) (* Add unless *) (**************) (* Success *) let linux_add_unless_ok rloc ra ru rmem wmem neq add ropt eiid = let eiid,locm = rloc eiid in (* read location *) let eiid,am = ra eiid in (* read added value *) let eiid,um = ru eiid in (* limit *) let vloc,clloc,esloc = Evt.as_singleton_nospecul locm and va,cla,esa = Evt.as_singleton_nospecul am and vu,clu,esu = Evt.as_singleton_nospecul um in let eiid,rmem = rmem vloc eiid in let vv,clrmem,esrmem = Evt.as_singleton_nospecul rmem in let eiid,addm = add vv va eiid in let vadd,cladd,esadd = Evt.as_singleton_nospecul addm in assert (E.is_empty_event_structure esadd) ; let eiid,wmem = wmem vloc vadd eiid in let _,clwmem,eswmem = Evt.as_singleton_nospecul wmem in let eiid,eqm = neq vv vu eiid in let (),cleq,eseq = Evt.as_singleton_nospecul eqm in assert (E.is_empty_event_structure eseq) ; let es = E.linux_add_unless_ok esloc esa esu esrmem eswmem (Misc.is_some ropt) in let r = match ropt with Some r -> r | None -> vv in eiid, (Evt.singleton (r,cleq@cladd@clwmem@clrmem@clloc@cla@clu,es), None) (* Failure *) let linux_add_unless_no rloc ru rmem eq ropt eiid = let eiid,locm = rloc eiid in (* read location *) let eiid,um = ru eiid in (* limit *) let vloc,clloc,esloc = Evt.as_singleton_nospecul locm and vu,clu,esu = Evt.as_singleton_nospecul um in let eiid,rmem = rmem vloc eiid in let vv,clrmem,esrmem = Evt.as_singleton_nospecul rmem in let eiid,eqm = eq vv vu eiid in let (),cleq,eseq = Evt.as_singleton_nospecul eqm in assert (E.is_empty_event_structure eseq) ; let es = E.linux_add_unless_no esloc esu esrmem (Misc.is_some ropt) in let r = match ropt with Some r -> r | None -> vv in eiid, (Evt.singleton (r,cleq@clrmem@clloc@clu,es), None) (* Store conditional, tricky dependencies *) let riscv_sc success read_res read_data read_addr cancel_res write_result write_mem eiid = let eiid,read_res = read_res eiid in let eiid,read_data = read_data eiid in let eiid,(read_addr,spec) = read_addr eiid in assert (spec=None) ; let resa,cl_resa,es_resa = Evt.as_singleton_nospecul read_res and data,cl_data,es_data = Evt.as_singleton_nospecul read_data in let eiid,acts = Evt.fold (fun (addr,cl_addr,es_addr) (eiid,acts) -> let eiid,cancel_res = cancel_res eiid in let eiid,write_result = write_result eiid in let eiid,write_mem = write_mem addr resa data eiid in let (),cl_wres,es_wres = Evt.as_singleton_nospecul cancel_res and (),cl_wresult,es_wresult = Evt.as_singleton_nospecul write_result and r,cl_wmem,es_wmem = Evt.as_singleton_nospecul write_mem in let es = E.riscv_sc success es_resa es_data es_addr es_wres es_wresult es_wmem in eiid, Evt.add (r,cl_resa@cl_data@cl_addr@cl_wres@cl_wresult@cl_wmem,es) acts) read_addr (eiid,Evt.empty) in eiid,(acts,None) (* AArch64 failed cas *) let do_aarch64_cas_no (is_physical:bool) (add_ctrl:bool) (read_rn:'loc t) (read_rs:'v t) (write_rs:'v-> unit t) (read_mem: 'loc -> 'v t) (branch: 'loc -> unit t) (rne: 'v -> 'v -> unit t) eiid = let eiid,read_rn = read_rn eiid in let eiid,read_rs = read_rs eiid in let cv,cl_cv,es_rs = Evt.as_singleton_nospecul read_rs in let acts_rn,spec = read_rn in assert (Misc.is_none spec) ; let eiid,acts = Evt.fold (fun (a,cl_a,es_rn) (eiid,acts) -> let eiid,read_mem = read_mem a eiid in let ov,cl_rm,es_rm = Evt.as_singleton_nospecul read_mem in let eiid,write_rs = write_rs ov eiid in let (),cl_wrs,es_wrs = Evt.as_singleton_nospecul write_rs in let eiid,branch = branch a eiid in let (),cl_br,es_br = Evt.as_singleton_nospecul branch in let eiid,nem = rne ov cv eiid in let (),cl_ne,eseq = Evt.as_singleton_nospecul nem in assert (E.is_empty_event_structure eseq) ; let es = E.aarch64_cas_no is_physical add_ctrl es_rn es_rs es_wrs es_rm es_br in let cls = cl_a@cl_cv@cl_rm@cl_wrs@cl_ne@cl_br in eiid,Evt.add ((),cls,es) acts) acts_rn (eiid,Evt.empty) in eiid,(acts, None) (* AArch64 failed cas that writes into memory nevertheless *) let do_aarch64_cas_no_with_writeback (is_physical:bool) (read_rn:'loc t) (read_rs:'v t) (write_rs:'v-> unit t) (read_mem: 'loc -> 'v t) (write_mem: 'loc -> 'v -> unit t) (branch: 'loc -> unit t) (rne: 'v -> 'v -> unit t) eiid = let eiid,read_rn = read_rn eiid in let eiid,read_rs = read_rs eiid in let cv,cl_cv,es_rs = Evt.as_singleton_nospecul read_rs in let acts_rn,spec = read_rn in assert (Misc.is_none spec) ; let eiid,acts = Evt.fold (fun (a,cl_a,es_rn) (eiid,acts) -> let eiid,read_mem = read_mem a eiid in let ov,cl_rm,es_rm = Evt.as_singleton_nospecul read_mem in let eiid,write_mem = write_mem a ov eiid in let (),cl_wm,es_wm= Evt.as_singleton_nospecul write_mem in let eiid,write_rs = write_rs ov eiid in let (),cl_wrs,es_wrs = Evt.as_singleton_nospecul write_rs in let eiid,branch = branch a eiid in let (),cl_br,es_br = Evt.as_singleton_nospecul branch in let eiid,nem = rne ov cv eiid in let (),cl_ne,eseq = Evt.as_singleton_nospecul nem in assert (E.is_empty_event_structure eseq) ; let es = E.aarch64_cas_ok is_physical `DataFromRx es_rn es_rs E.empty_event_structure es_wrs es_rm es_wm es_br in let cls = cl_a@cl_cv@cl_rm@cl_wm@cl_wrs@cl_br@cl_ne in eiid,Evt.add ((),cls,es) acts) acts_rn (eiid,Evt.empty) in eiid,(acts, None) (* AArch64 successful cas *) let do_aarch64_cas_ok (is_physical:bool) (prov_data: [`DataFromRRs | `DataFromRx]) (read_rn:'loc t) (read_rs:'v t) (read_rt: 'v t) (write_rs:'v-> unit t) (read_mem: 'loc -> 'v t) (write_mem: 'loc -> 'v -> unit t) (branch: 'loc -> unit t) (req: 'v -> 'v -> unit t) eiid = let eiid,read_rn = read_rn eiid in let eiid,read_rs = read_rs eiid in let eiid,read_rt = read_rt eiid in let cv,cl_cv,es_rs = Evt.as_singleton_nospecul read_rs and nv,cl_nv,es_rt = Evt.as_singleton_nospecul read_rt in let acts_rn,spec = read_rn in assert (spec=None) ; let eiid,acts = Evt.fold (fun (a,cl_a,es_rn) (eiid,acts) -> let eiid,read_mem = read_mem a eiid in let eiid,write_mem = write_mem a nv eiid in let ov,cl_rm,es_rm = Evt.as_singleton_nospecul read_mem and (),cl_wm,es_wm= Evt.as_singleton_nospecul write_mem in let eiid,write_rs = write_rs ov eiid in let (),cl_wrs,es_wrs = Evt.as_singleton_nospecul write_rs in let eiid,branch = branch a eiid in let (),cl_br,es_br = Evt.as_singleton_nospecul branch in let eiid,eqm = req ov cv eiid in let (),cl_eq,eseq = Evt.as_singleton_nospecul eqm in assert (E.is_empty_event_structure eseq) ; let es = E.aarch64_cas_ok is_physical prov_data es_rn es_rs es_rt es_wrs es_rm es_wm es_br in let cls = cl_a@cl_cv@cl_nv@cl_rm@cl_wm@cl_wrs@cl_br@cl_eq in eiid,Evt.add ((),cls,es) acts) acts_rn (eiid,Evt.empty) in eiid,(acts, None) (* Temporary morello variation of CAS *) let aarch64_cas_ok_morello (read_rn:'loc t) (read_rt: 'v t) (read_mem: 'v t) (write_mem: 'loc -> 'v -> unit t) eiid = let eiid,read_rn = read_rn eiid in let eiid,read_rt = read_rt eiid in let a,cl_a,es_rn = Evt.as_singleton_nospecul read_rn and nv,cl_nv,es_rt = Evt.as_singleton_nospecul read_rt in let eiid,read_mem = read_mem eiid in let eiid,write_mem = write_mem a nv eiid in let _,cl_rm,es_rm = Evt.as_singleton_nospecul read_mem and (),cl_wm,es_wm= Evt.as_singleton_nospecul write_mem in let es = E.aarch64_cas_ok_morello es_rn es_rt es_rm es_wm in let cls = cl_a@cl_nv@cl_rm@cl_wm in eiid,(Evt.singleton ((),cls,es), None) let has_no_spec (x,y) = assert(y=None); x (* Simple alternative *) let altT : 'a t -> 'a t -> 'a t = fun m1 m2 eiid -> let (eiid, act1) = m1 eiid in let act1 = has_no_spec act1 in let (eiid, act2) = m2 eiid in let act2 = has_no_spec act2 in let un = Evt.union act1 act2 in (eiid, (un,None)) let aarch64_or_riscv_store_conditional must_fail read_res read_data read_addr cancel_res write_result write_mem = let m_fail = riscv_sc false read_res read_data read_addr cancel_res (write_result V.one) (fun _a _resa _v -> unitT ()) in if must_fail then m_fail else altT m_fail (riscv_sc true read_res read_data read_addr cancel_res (write_result V.zero) write_mem) let aarch64_cas_ok (is_physical: bool) (read_rn: 'loc t) (read_rs: 'v t) (read_rt: 'v t) (write_rs: 'v -> unit t) (read_mem: 'loc -> 'v t) (write_mem: 'loc -> 'v -> unit t) (branch: 'loc -> unit t) (req: 'v -> 'v -> unit t) = let do_ prov_data = do_aarch64_cas_ok is_physical prov_data read_rn read_rs read_rt write_rs read_mem write_mem branch req in altT (do_ `DataFromRRs) (do_ `DataFromRx) let aarch64_cas_no (is_physical:bool) (read_rn:'loc t) (read_rs:'v t) (write_rs:'v-> unit t) (read_mem: 'loc -> 'v t) (branch: 'loc -> unit t) (rne: 'v -> 'v -> unit t) = let do_ add_ctrl = do_aarch64_cas_no is_physical add_ctrl read_rn read_rs write_rs read_mem branch rne in altT (do_ true) (do_ false) let aarch64_cas_no_with_writeback (is_physical: bool) (read_rn: 'loc t) (read_rs: 'v t) (write_rs: 'v -> unit t) (read_mem: 'loc -> 'v t) (write_mem: 'loc -> 'v -> unit t) (branch: 'loc -> unit t) (rne: 'v -> 'v -> unit t) = do_aarch64_cas_no_with_writeback is_physical read_rn read_rs write_rs read_mem write_mem branch rne (* RISCV store conditional may always succeed? *) let riscv_store_conditional = aarch64_or_riscv_store_conditional false let aarch64_store_conditional = aarch64_or_riscv_store_conditional (* stu combinator *) let stu : 'a t -> 'b t -> ('a -> unit t) -> (('a * 'b) -> unit t) -> unit t = fun rD rEA wEA wM -> fun eiid -> let eiid,rd = rD eiid in let eiid,rea = rEA eiid in let (vrd,vclrd,esrd) = Evt.as_singleton_nospecul rd and (vrea,vclrea,esrea) = Evt.as_singleton_nospecul rea in let eiid,wea = wEA vrea eiid in let eiid,wm = wM (vrd,vrea) eiid in let (_vwea,vclwea,eswea) = Evt.as_singleton_nospecul wea and (_vwm,vclwm,eswm) = Evt.as_singleton_nospecul wm in let es = E.stu esrd esrea eswea eswm in eiid,(Evt.singleton ((),vclrd@vclrea@vclwea@vclwm,es), None) let lift_combi_opt f c (v1,vcl1,es1) (v2,vcl2,es2) = match c es1 es2 with | None -> None | Some es -> Some (f v1 v2,vcl2@vcl1,es) let lift_combi f c elt1 elt2 acc = match lift_combi_opt f c elt1 elt2 with | None -> acc | Some s3 -> Evt.add s3 acc let fold2_ess f ess1 ess2 = Evt.fold (fun es1 k -> Evt.fold (fun es2 k -> f es1 es2 k) ess2 k) ess1 Evt.empty let fold3_ess f essa essb essc = let essbc = Evt.combine essb essc in Evt.fold (fun esa k -> List.fold_left (fun k (esb,esc) -> f esa esb esc k) k essbc) essa Evt.empty let lift_combis f c ess1 ess2 = fold2_ess (lift_combi f c) ess1 ess2 let do_speculate (v,vcl,es) = (v,vcl,E.do_speculate es) let do_speculates ess = Evt.map do_speculate ess (* Combine the results *) let combi f c s1 s2 = fun eiid -> let (eiid,(s1act,spec1)) = s1 eiid in let (eiid,(s2act,spec2)) = s2 eiid in let s3act = lift_combis f c s1act s2act in let spec3 = match spec1,spec2 with | None, None -> None | Some elt1, Some elt2 -> Some (lift_combis f c elt1 elt2) | None, Some elt2 -> let elt1 = do_speculates s1act in Some (lift_combis f c elt1 elt2) | Some elt1, None -> let elt2 = do_speculates s2act in Some (lift_combis f c elt1 elt2) in (eiid,(s3act,spec3)) let (>>|) : 'a t -> 'b t -> ('a * 'b) t = fun s1 s2 -> combi Misc.pair (fun es1 es2 -> es1 =|= es2) s1 s2 let para_atomic s1 s2 = combi Misc.pair E.para_atomic s1 s2 let para_input_right s1 s2 = combi Misc.pair E.para_input_right s1 s2 let (>>::) : 'a t -> 'a list t -> 'a list t = fun s1 s2 -> combi (Misc.cons) (fun es1 es2 -> es1 =|= es2) s1 s2 (* Parallel composition no result *) let (|||) : unit t -> unit t -> unit t = fun s1 s2 -> combi (fun _ _ -> ()) (=|=) s1 s2 (* Sequence memory events *) let seq_mem : 'a t -> 'b t -> ('a * 'b) t = fun s1 s2 -> combi Misc.pair E.seq_mem s1 s2 let seq_mem_list : 'a t -> 'a list t -> 'a list t = fun s1 s2 -> combi Misc.cons E.seq_mem s1 s2 (* Force monad value *) let forceT (v : 'a) : 'b t -> 'a t = let f (_, vcl, es) = (v, vcl, es) in map_elt f let (>>!) s v = forceT v s let discardT : 'a t -> unit t = fun s eiid -> forceT () s eiid (* Add a value *) let addT (v1: 'a) : 'b t -> ('a * 'b) t = let f (v2, vcl, es) = ((v1, v2), vcl, es) in map_elt f (* Assert a value *) let assertT (v: A.V.v) : 'a t -> 'a t = let f (r, cs, es) = (r, VC.Assign (v, VC.Atom V.one) :: cs, es) in map_elt f (* Choosing dependant upon flag, notice that, once determined v is either one or zero *) let choiceT = fun v l r eiid -> if V.is_var_determined v then begin match V.as_bool v with | Some b -> if b then l eiid else r eiid | None -> assert false end else let (eiid, (lact,lspec)) = l eiid in assert (lspec = None); let (eiid, (ract,rspec)) = r eiid in assert (rspec = None); let fl = (fun (r,cs,es) -> (r,(VC.Assign (v,VC.Atom V.v_true)) :: cs,es)) in let fr = (fun (r,cs,es) -> (r,(VC.Assign (v,VC.Atom V.v_false)) :: cs, es)) in let un = Evt.union (Evt.map fl lact) (Evt.map fr ract) in (eiid, (un, None)) (* Extract speculaive behaviout, base case is to speculate active branch *) let as_speculated (act,spec) = match spec with | Some spec -> spec | None -> do_speculates act (* Combine active branch and speculated one -> active *) let combi_acts ok no fcs = let acts,_ = ok and specs = as_speculated no in Evt.fold (fun (v,cl_act,es_act) acc -> let cl_act = fcs cl_act in Evt.fold (fun (_v_spec,cl_spec,es_spec) acc -> Evt.add (v,cl_act@cl_spec,Misc.as_some (es_act =|= es_spec)) acc) specs acc) acts Evt.empty (* Simple union of speculated structure(s) *) let combi_spec p1 p2 = let es1 = as_speculated p1 and es2 = as_speculated p2 in let specs = lift_combis (fun v _ -> v) (* Values are assume to be the same, unchecked *) (=|=) es1 es2 in Some specs let speculT : V.v -> 'a code -> 'a code -> 'a code = fun v l r eiid -> let eiid,pl = l eiid in let eiid,pr = r eiid in if V.is_var_determined v then begin if V.is_zero v then eiid,(combi_acts pr pl (fun cs -> cs),combi_spec pl pr) else eiid,(combi_acts pl pr (fun cs -> cs),combi_spec pr pl) end else let act = Evt.union (combi_acts pr pl (fun cs -> VC.Assign (v,VC.Atom V.zero)::cs)) (combi_acts pl pr (fun cs -> VC.Assign (v,VC.Atom V.one)::cs)) and spec = combi_spec pr pl in eiid,(act,spec) let condJumpT = if do_deps then speculT else choiceT let indirectJumpT v lbls g = assert (not do_deps) ; (* One *) let do_one (p,lbl) eiid = let eiid,(act,_) = g lbl eiid in let f (r,cs,es) = let cs = VC.Assign (v,VC.Atom (V.Val (Constant.Label (p,lbl))))::cs in r,cs,es in eiid,(Evt.map f act,None) in (* Rec *) let rec do_rec lbls eiid = match lbls with | [] -> assert false (* Caught earlier, in ArchSem module *) | [lbl] -> do_one lbl eiid | lbl::lbls -> let eiid,(act,_) = do_one lbl eiid in let eiid,(acts,_) = do_rec lbls eiid in eiid,(Evt.union act acts,None) in do_rec (Label.Full.Set.elements lbls) let speculPredT v pod l r = fun eiid -> let eiid,pod = pod eiid in let eiid,l = l eiid in let eiid,r = r eiid in let (),podcl,podact = Evt.as_singleton_nospecul pod and lv,lcl,lact = Evt.as_singleton_nospecul l and rv,rcl,ract = Evt.as_singleton_nospecul r in let lspec = E.do_speculate lact and rspec = E.do_speculate ract in let cl = podcl@lcl@rcl in let lact = Misc.as_some (podact =*$= Misc.as_some (lact =|= rspec)) and ract = Misc.as_some (podact =*$= Misc.as_some (ract =|= lspec)) and spec = Misc.as_some (E.do_speculate podact =*$= Misc.as_some (lspec =|= rspec)) in let act = Evt.union (Evt.singleton (rv, VC.Assign (v,VC.Atom V.zero)::cl,ract)) (Evt.singleton (lv, VC.Assign (v,VC.Atom V.one)::cl,lact)) and spec = Evt.singleton (rv,cl,spec) in eiid,(act,Some spec) let condPredT v pod m1 m2 = if do_deps then speculPredT v pod m1 m2 else pod >>= fun () -> choiceT v m1 m2 let discard_false sact = List.fold_right (fun (b,vcl,evt) k -> if b then ((),vcl,evt)::k else k) sact [] let discard_false_opt = function | None -> None | Some sact -> match discard_false sact with | [] -> None | sact -> Some sact let (|*|) : bool code -> unit code -> unit code = fun s1 s2 -> fun (poi,eiid) -> let ((_,eiid), (s1act,spec1)) = s1 (poi,eiid) in let ((_,eiid), (s2act,spec2)) = s2 (poi,eiid) in let s1lst = Evt.elements s1act in let s2lst = Evt.elements s2act in let s3act = List.fold_left (fun acc (va,vcla,evta) -> if va then List.fold_left (fun acc (_,vclb,evtb) -> match evta +|+ evtb with | Some evtc -> Evt.add ((), vcla@vclb, evtc) acc | None -> acc) acc s2lst else acc) Evt.empty s1lst in let spec3 = None in let pair = begin if Evt.is_empty s2act then (discard_false s1act,discard_false_opt spec1) else if Evt.is_empty s1act then (s2act,spec2) else (s3act,spec3) end in ((poi,eiid),pair) let cseq : 'a t -> ('a -> 'b t) -> 'b t = fun s f -> data_comp (+|+) s f let para_bind_output_right : 'a t -> ('a -> 'b t) -> 'b t = fun s f -> data_comp E.para_output_right s f let asl_seq : 'a t -> ('a -> 'b t) -> 'b t = fun s f -> data_comp E.para_po_seq_output_right s f type poi = int (************************************************) (* Combining instruction and continuation code. *) (* Notice that result is v2 *) (************************************************) (* ordinary combination, not much to say *) let other_combi ok (_,vcl1,es1) (v2,vcl2,es2) k = if ok v2 then let es = E.inst_code_comp es1 es2 in Evt.add (v2,vcl1@vcl2,es) k else k let other_combi_spec ok (_,vcl1,es1) (v2,vcl2,es2) (_,vcl3,es3) k = if ok v2 then let es = E.inst_code_comp_spec es1 es2 es3 in Evt.add (v2,vcl1@vcl2@vcl3,es) k else k (* Ordinary instr + code compostion. Notice: no causality from s to f v1 *) let comb_instr_code : ('b -> bool) -> (poi -> (poi * 'a) t) -> ('a -> 'b code) -> 'b code = fun ok s f (poi,eiid) -> let ({id=eiid;_},(acts1,spec1)) = s poi {id=eiid; sub=0;} in assert (spec1 = None) ; let poi,acts = Evt.fold (fun ((poi1,v1), vcl1, es1) ((po,eiid),acts) -> let (po2,eiid),(acts2,spec2) = f v1 (poi1,eiid) in assert (spec2 = None) ; let acts = Evt.fold (fun (v2,vcl2,es2) acts -> if ok v2 then let es = E.inst_code_comp es1 es2 in Evt.add (v2,vcl2@vcl1,es) acts else acts) acts2 acts in (max po2 po,eiid),acts) acts1 ((0,eiid),Evt.empty) in (poi,(acts,None)) (* Idem, speculation is possible and handled if present *) let not_speculated es = E.EventSet.is_empty es.E.speculated let comb_instr_code_deps : ('b -> bool) -> (poi -> (poi * 'a) t) -> ('a -> 'b code) -> 'b code = fun ok s f -> fun (poi,eiid) -> let ({id=eiid;_}, (sact,spec)) = s poi {id=eiid;sub=0} in (* We check that all semantics for "s" (instruction) 1. Yield the same value, 2. Have the same status w.r.t. speculation. So as to apply f (code continuation) only once (or twice) *) let ((poi,v1),_,es1) = Evt.wrap_check (fun (v1,_,es1) (v2,_,es2) -> v1 = v2 && not_speculated es1 = not_speculated es2) sact in if not_speculated es1 then let poi,(b_setact,bspec) = f v1 (poi,eiid) in let k = fold2_ess (other_combi ok) sact b_setact in let spec = match spec,bspec with | None, None -> None | None, Some spec2 -> let spec1 = do_speculates sact in Some (fold2_ess (other_combi ok) spec1 spec2) | Some spec1,None -> let spec2 = do_speculates b_setact in Some (fold2_ess (other_combi ok) spec1 spec2) | Some spec1,Some spec2 -> Some (fold2_ess (other_combi ok) spec1 spec2) in (poi,(k,spec)) else let poi,(b_setact,bspec) = f v1 (poi,eiid) in let poi,(c_setact,cspec) = f v1 poi in let k = fold3_ess (other_combi_spec ok) sact b_setact c_setact in let spec = match spec,bspec,cspec with | Some spec1,None,None -> let spec2 = do_speculates b_setact and spec3 = do_speculates c_setact in Some (fold3_ess (other_combi_spec ok) spec1 spec2 spec3) | Some spec1,Some spec2,Some spec3 -> Some (fold3_ess (other_combi_spec ok) spec1 spec2 spec3) | _ -> Warn.fatal "Inconsistent speculation in (<<<)" in poi,(k,spec) (* Actual instr + code combination depends upon deps mode *) let add_instr ok s f = if do_deps then comb_instr_code_deps ok s f else comb_instr_code ok s f let (>>>) s f = add_instr (fun _ -> true) s f (* For combining conditions and branches of an if, as above + instruction dependencies *) let (>>>>) s f = fun eiid -> let (eiid,(sact,spec)) = s eiid in assert(spec = None); let eiid,bfinal= Evt.fold (fun (v1, vcl1, es1) (eiid1,acc) -> let b_set = f v1 in let (eiid_b,(b_setact,bspec)) = b_set eiid1 in assert (bspec = None); Evt.fold (fun (v2,vcl2,es2) (eiid2,acc) -> let es = E.cond_comp es1 es2 in eiid2,Evt.add (v2,vcl2@vcl1,es) acc) b_setact (eiid_b,acc)) sact (eiid,Evt.empty) in eiid,(bfinal,None) (* Build event structure from event set *) let do_trivial es = E.from_events es (* Build event structure from action and instruction instance *) let (++) f g = fun eiid -> let eiid,x = f eiid in g x eiid and (--) f g = fun eiid -> let eiid,x = f eiid in eiid,g x let do_make_one_event iiid a eiid = bump_eid eiid, { E.eiid = eiid.id; E.subid=eiid.sub; E.iiid = iiid; E.action = a; } let make_one_event ii = do_make_one_event (E.IdSome ii) and make_one_init_event = do_make_one_event E.IdInit let do_make_one_event_structure a iiid = do_make_one_event iiid a -- fun evt -> do_trivial (E.EventSet.singleton evt) let make_one_event_structure a ii = do_make_one_event_structure a (E.IdSome ii) (* Add some fields to struture *) let add_data_ports st = { st with E.data_ports = st.E.events; } let add_success_ports st = { st with E.success_ports = st.E.events; } let as_data_port : 'a t -> 'a t = let f (a, cs, es) = (a, cs, add_data_ports es) in fun m -> map_elt f m let do_make_one_event_structure_data is_data = if is_data then fun a iiid -> do_make_one_event_structure a iiid -- add_data_ports else do_make_one_event_structure (* Add return value and equation to monad *) let make_one_monad v eqs st = fun eiid -> eiid,(Evt.singleton (v,eqs,st),None) (* A few monad constructors from action and instruction instance *) let mk_singleton_es a ii = make_one_event_structure a ii ++ make_one_monad () [] (* Some specific, exported basic monad building functions *) let mk_singleton_es_success a ii = make_one_event_structure a ii -- add_success_ports ++ make_one_monad () [] let mk_singleton_es_eq a eqs ii = make_one_event_structure a ii ++ make_one_monad () eqs let restrict cs = make_one_monad () cs E.empty_event_structure (******************************************************) (* Some basic event structures, read, write, fence... *) (******************************************************) (* Fresh variables are generated by reading *) let do_read_loc is_data mk_action loc iiid = fun eiid -> (* It is important to call V.fresh_var for every _complete_ call of read_loc *) let v = match iiid,loc with | E.IdSome {A.env={A.regs=env;_}; _},A.Location_reg (_,r) -> begin match A.look_reg r env with | Some v -> v | None -> V.fresh_var () end | _ -> V.fresh_var () in let m = do_make_one_event_structure_data is_data (mk_action loc v) iiid ++ make_one_monad v [] in m eiid let read_loc is_data mk_action loc ii = do_read_loc is_data mk_action loc (E.IdSome ii) (* Writing is as simple as emiting one event *) let do_write_loc mk_action loc iiid = do_make_one_event_structure (mk_action loc) iiid ++ make_one_monad () [] let write_loc mk_action loc ii = do_write_loc mk_action loc (E.IdSome ii) (* Fence events have no 'maximal' or output events, which makes them transparent to iicoo_data composition *) let mk_fence a ii = make_one_event_structure a ii -- (fun st -> { st with E.output = Some E.EventSet.empty;}) ++ make_one_monad () [] let fetch op arg mk_action ii = fun eiid -> let v = V.fresh_var () and vstored = V.fresh_var () in let m = let eqs = [VC.Assign (vstored,VC.Binop (op,v,arg))] and a = mk_action v vstored in make_one_event_structure a ii ++ make_one_monad v eqs in m eiid (**********************) (* Morello extensions *) (**********************) let add_atomic_tag_read m a f ii = fun eiid -> let (eiid,(sact,sspec)) = m eiid in assert(sspec = None); let (v,eqs,st) = Evt.as_singleton sact in let a_tag = V.fresh_var () in let eqs = VC.Assign (a_tag,VC.Unop (Op.CapaTagLoc,a))::eqs in let vs_tag = V.fresh_var () in let v_tag = V.fresh_var () in let eqs = eqs@[VC.Assign (v_tag,VC.Binop (Op.CapaSetTag,v,vs_tag))] in let eiid,es = bump_eid eiid, E.EventSet.add { E.eiid = eiid.id; E.subid=eiid.sub; E.iiid = E.IdSome ii; E.action = f (A.Location_global a_tag) vs_tag;} st.E.events in let e_full_action = if E.EventSet.is_empty st.E.events then f (A.Location_global a) v else (E.EventSet.max_elt st.E.events).E.action in let e_full = if E.EventSet.is_empty st.E.mem_accesses then { E.eiid=eiid.id; E.subid=eiid.sub; E.iiid = E.IdSome ii; E.action = e_full_action; } else E.EventSet.max_elt st.E.mem_accesses in let st = { st with E.events = es; E.sca = E.EventSetSet.singleton es; E.mem_accesses = E.EventSet.singleton e_full; E.aligned = [e_full,es]; } in bump_eid eiid,(Evt.singleton (v_tag,eqs,st),None) let add_atomic_tag_write m a v f ii = fun eiid -> let (eiid,(sact,sspec)) = m eiid in assert(sspec = None); let ((),eqs,st) = Evt.as_singleton sact in let a_tag = V.fresh_var () in let eqs = VC.Assign (a_tag,VC.Unop (Op.CapaTagLoc,a))::eqs in let eiid,es = bump_eid eiid, E.EventSet.add { E.eiid = eiid.id; E.subid=eiid.sub; E.iiid = E.IdSome ii; E.action = f (A.Location_global a_tag) v;} st.E.events in let e_full_action = if E.EventSet.is_empty st.E.events then f (A.Location_global a) v else (E.EventSet.max_elt st.E.events).E.action in let e_full = if E.EventSet.is_empty st.E.mem_accesses then { E.eiid=eiid.id; E.subid=eiid.sub; E.iiid = E.IdSome ii; E.action = e_full_action; } else E.EventSet.max_elt st.E.mem_accesses in let st = { st with E.events = es; E.sca = E.EventSetSet.singleton es; E.mem_accesses = E.EventSet.singleton e_full; E.aligned = [e_full,es]; } in bump_eid eiid,(Evt.singleton ((),eqs,st),None) (**************) (* Mixed size *) (**************) module Mixed(SZ:ByteSize.S) = struct let memtag = C.variant Variant.MemTag let morello = C.variant Variant.Morello let kvm = C.variant Variant.VMSA module AM = A.Mixed(SZ) module Scalar = V.Cst.Scalar let def_size v= match v with | V.Val (Constant.Instruction _) -> MachSize.Word (* TODO: arch dependennt *) | _ -> Scalar.machsize let extract_byte v = VC.Unop (Op.AndK AM.mask,v) let extract_step v = let d = extract_byte v and w = VC.Unop (Op.LogicalRightShift AM.nshift,v) in d,w (* Translate to list of bytes, least significant first *) let explode sz v = let rec do_rec k v = if k <= 1 then [v],[] else let d,w = extract_step v in let vw = V.fresh_var () in let ds,eqs = do_rec (k-1) vw in let vd = V.fresh_var () in vd::ds, VC.Assign (vw,w)::VC.Assign (vd,d)::eqs in do_rec (AM.nsz sz) v (* Translate from list of bytes least significant first *) let rec recompose ds = match ds with | [] -> assert false | [d] -> d,[] | d::ds -> let w,eqs = recompose ds in let vw = V.fresh_var () and x = V.fresh_var () in vw,VC.Assign (x,VC.Unop (Op.LeftShift AM.nshift,w))::VC.Assign (vw,VC.Binop (Op.Or,x,d))::eqs (* Bytes addresses, little endian *) let byte_eas sz a = let kmax = AM.nsz sz in let rec do_rec k = if k >= kmax then [],[] else let xa = V.fresh_var() in let xas,eqs = do_rec (k+1) in xa::xas,VC.Assign (xa,VC.Unop (Op.AddK (k*AM.byte_sz),a))::eqs in let xas,eqs = do_rec 1 in let xas = a::xas in let open Endian in match AM.endian with | Little -> xas,eqs | Big -> List.rev xas,eqs (* Build mixed size event structure *) let make_mixed es e = { E.empty_event_structure with E.events = es ; E.sca = E.EventSetSet.singleton es; E.mem_accesses = E.EventSet.singleton e; aligned = [e,es]; } let add_evt es e = E.EventSet.add e es let fold_pp m k xs = fun eiid -> List.fold_left (fun (eiid,k) x -> m k x eiid) (eiid,k) xs let read_mixed is_data sz mk_act a ii = fun eiid -> let eas,a_eqs = byte_eas sz a in let eavs = List.map (fun ea -> ea,V.fresh_var ()) eas in let vs = List.map snd eavs in let v,v_eqs = recompose vs in let eiid,es = fold_pp (fun es (ea,v) -> make_one_event ii (mk_act SZ.byte (A.Location_global ea) v) -- add_evt es) E.EventSet.empty eavs eiid in let eiid,e_full = make_one_event ii (mk_act sz (A.Location_global a) v) eiid in let st = make_mixed es e_full in let st = if is_data then { st with E.data_ports = es } else st in make_one_monad v (a_eqs@v_eqs) st eiid let fold_pp2 m k xs ys = fun eiid -> List.fold_left2 (fun (eiid,k) x y -> m k x y eiid) (eiid,k) xs ys let write_mixed sz mk_act a v ii = fun eiid -> let eas,a_eqs = byte_eas sz a and vs,v_eqs = explode sz v in let eiid,es = fold_pp2 (fun es ea v -> make_one_event ii (mk_act SZ.byte (A.Location_global ea) v) -- add_evt es) E.EventSet.empty eas vs eiid in let eiid,e_full = make_one_event ii (mk_act sz (A.Location_global a) v) eiid in let st = make_mixed es e_full in make_one_monad () (a_eqs@v_eqs) st eiid let is_tagloc a = let open Constant in match a with | V.Val (Symbolic (TagAddr _)) -> true | _ -> false let is_pteloc a = let open Constant in match a with | V.Val (Symbolic (System (PTE,_))) -> true | _ -> false let is_instrloc a = match a with | V.Val (Constant.Label _) -> true | _ -> false (* * Add init writes for tag addresses. * A symbolic location has its own tag address, hence * for a given x, tag(x) is initialised, except for arrays * that may span over several granules. * The task of initialising the appropriate tag addresses is * facilitated by array init being implemented as the explicit * initialisations of its elements. * For instance for int t[5], we have int-sized initial writes for * t+0, t+4, t+8, t+12, t+16, yielding the two tag addresses * tag(t) and t(t+16). Namely, with a granule size of 4 int's * the first four items have the same tag address tag(x). *) let add_inittags env = let glob,tag = List.fold_left (fun (glob,tag as p) (loc,v0) -> match loc with | A.Location_global a -> if is_tagloc a then begin if dbg then Printf.eprintf "Explicit initialisation of tag %s to value %s\n" (V.pp_v a) (V.pp_v v0) ; glob,a::tag end else a::glob,tag | A.Location_reg _ -> p) ([],[]) env in let tag_set = V.ValueSet.of_list tag in let glob_set = V.ValueSet.of_list glob in let glob_set = V.ValueSet.filter (fun a -> not (is_pteloc a || is_instrloc a)) glob_set in let s = V.ValueSet.map (fun a -> V.op1 Op.TagLoc a) glob_set in let env = V.ValueSet.fold (fun atag env -> if V.ValueSet.mem atag tag_set then env else begin if dbg then eprintf "Tag %s defaulting\n" (V.pp_v atag) ; (A.Location_global atag,V.Val (Constant.default_tag))::env end) s env in env let morello_init_tag s v eiid = assert morello ; let open Constant in bump_eid eiid, { E.eiid = eiid.id; E.subid=eiid.sub; E.iiid = E.IdInit; E.action = E.Act.mk_init_write (A.of_symbolic_data {default_symbolic_data with name=Misc.add_ctag s}) (def_size v) v; } let debug_env env = String.concat ", " (List.map (fun (loc,v) -> sprintf "%s -> %s" (A.pp_location loc) (V.pp_v v)) env) let val_of_pteval p = V.Val (Constant.PteVal p) let default_pteval s = val_of_pteval (V.Cst.PteVal.default s) and pteval_of_pte s = val_of_pteval (V.Cst.PteVal.of_pte s) let expand_pteval loc v = let open Constant in match v with | V.Val (Symbolic (Physical (s,_))) -> default_pteval s | V.Val (PteVal _) -> v | _ -> Warn.user_error "Cannot initialize %s with %s" (A.pp_location loc ) (V.pp C.hexa v) let pte_loc s = let open Constant in A.Location_global (V.Val (Symbolic (System (PTE,s)))) let pte2_loc s = let open Constant in A.Location_global (V.Val (Symbolic (System (PTE2,s)))) let phy_loc s o = let open Constant in A.Location_global (V.Val (Symbolic (Physical (s,o)))) let extract_virtual_pte env = let open Constant in List.fold_right (fun (loc,v as bd) (env,(virt,pte as maps)) -> match loc with | A.Location_global (V.Val (Symbolic (Virtual {name=s; tag=None; offset=o;_}))) -> (phy_loc s o,v)::env, (StringSet.add s virt,pte) | A.Location_global (V.Val (Symbolic (System (PTE,s)))) -> let v = expand_pteval loc v in (loc,v)::env,(virt,StringSet.add s pte) | A.Location_global (V.Val (Symbolic (TagAddr (VIR,s,o)))) -> let loc = A.Location_global (V.Val (Symbolic (TagAddr (PHY,s,o)))) in (loc,v)::env,maps | A.Location_global (V.Val (Symbolic (Physical _|Virtual _))) -> Warn.user_error "herd cannot handle initialisation of '%s'" (A.pp_location loc) | _ -> bd::env,maps) env ([],(StringSet.empty,StringSet.empty)) let add_initpte = let open Constant in fun env -> (* Collect virtual initialisations and explicit pte initialisations *) let env,(virt,pte) = extract_virtual_pte env in (* Add default initialisation of pte, when appropriate *) let env = StringSet.fold (fun s env -> if StringSet.mem s pte then env else (pte_loc s,default_pteval s)::env) virt env in let env = if C.variant Variant.PTE2 then List.fold_right (fun (loc,_ as bd) env -> match loc with | A.Location_global (V.Val (Symbolic (System (PTE,s)))) -> bd::(pte2_loc s,pteval_of_pte s)::env | _ -> bd::env) env [] else env in env let debug_add_initpte env = let r = add_initpte env in eprintf "Complete pte initialisation:\n[%s] -> [%s]\n" (debug_env env) (debug_env r) ; r let initwrites_non_mixed madd env size_env other_es = if dbg then Printf.eprintf "Initial env for init_writes: {%s}\n" (debug_env env) ; let env = if kvm then (if dbg then debug_add_initpte else add_initpte) env else env in fun eiid -> let eiid,es = List.fold_left (fun (eiid,es) (loc,v) -> let sz = match A.symbolic_data loc with | Some {Constant.name=s; _} when not (Misc.check_atag s) -> (* Notice that size does not depend upon offset. That is, all addresses with the same base share the same size *) A.look_size size_env s | _ -> def_size v in let eiid,ew = let v = V.map_scalar (V.Cst.Scalar.mask sz) v in make_one_init_event (E.Act.mk_init_write loc sz v) eiid in match A.symbolic_data loc with | Some {Constant.name=s; offset=0;_} -> let eiid,ews = if morello then let eiid,em = morello_init_tag s (V.op1 Op.CapaGetTag v) eiid in eiid,(em::[ew]) else eiid,[ew] in (eiid,ews@es) | _ -> (eiid,ew::es)) (eiid,[]) env in let es = E.EventSet.of_list (es @ other_es) in if dbg then begin eprintf "Init writes %a\n" E.debug_events es end ; madd (make_one_monad () [] (do_trivial es)) eiid let debug_env env = String.concat "; " (List.map (fun (loc,v) -> A.pp_location loc ^ " -> " ^ V.pp_v v) env) let initwrites_mixed env size_env other_es = if dbg then begin eprintf "Env is: [%s]\n" (debug_env env) end ; fun eiid -> try let eiid,es,sca = List.fold_left (fun (eiid,es,sca) (loc,v) -> let open Constant in match loc with | A.Location_global (V.Val (Symbolic (Virtual {name=s;offset=_;_})) as a) when not (Misc.check_atag s) -> (* Suffix encoding of tag addresses, sufficient for now *) let sz = A.look_size size_env s in let ds = AM.explode sz v and eas = AM.byte_eas sz a in let eiid,ews = List.fold_left2 (fun (eiid,ews) a d -> let eiid,ew = make_one_init_event (E.Act.mk_init_write (A.Location_global a) SZ.byte d) eiid in eiid,ew::ews) (eiid,[]) eas ds in let eiid,ews = if morello then let eiid,em = morello_init_tag s (V.op1 Op.CapaGetTag v) eiid in eiid,em::ews else eiid,ews in eiid,ews@es, E.EventSetSet.add (E.EventSet.of_list ews) sca | _ -> let eiid,ew = make_one_init_event (E.Act.mk_init_write loc (def_size v) v) eiid in eiid,ew::es, E.EventSetSet.add (E.EventSet.singleton ew) sca) (eiid,[],E.EventSetSet.empty) env in let es = E.EventSet.of_list (es @ other_es) in if dbg then begin eprintf "Init writes %a\n" E.debug_events es end ; let st = do_trivial es in let st = { st with E.sca; } in make_one_monad () [] st eiid with | V.Undetermined -> assert false let do_initwrites madd env = if dbg then Printf.eprintf "Env before additions: %s\n" (debug_env env) ; let env = if memtag then add_inittags env else env in (if A.is_mixed then initwrites_mixed else initwrites_non_mixed madd) env let t2code : 'a t -> 'a code = fun m -> fun (poi,eiid) -> let eiid,r = m {id=eiid;sub=0;} in ((poi,eiid.id),r) let initwrites madd env size_env = t2code (do_initwrites madd env size_env []) end (***************************************************) (* Operations, no events generated, only equations *) (***************************************************) let delay_op mk_c = let v = V.fresh_var () in make_one_monad v [VC.Assign (v, mk_c ())] E.empty_event_structure let any_op mk_v mk_c = try let v = mk_v () in make_one_monad v [] E.empty_event_structure with | V.Undetermined -> (* Not ready yet add equation *) delay_op mk_c | exn -> if C.debug.Debug_herd.exc then raise exn (* Delay failure *) else delay_op mk_c let op1 op v1 = any_op (fun () -> V.op1 op v1) (fun () -> VC.Unop (op,v1)) and op op v1 v2 = any_op (fun () -> V.op op v1 v2) (fun () -> VC.Binop (op,v1,v2)) and op3 op v1 v2 v3 = any_op (fun () -> V.op3 op v1 v2 v3) (fun () -> VC.Terop (op,v1,v2,v3)) let add = op Op.Add (* Add an inequality constraint *) let assign v1 v2 = make_one_monad () [(VC.Assign (v1,VC.Atom v2))] E.empty_event_structure let neqT : V.v -> V.v -> unit t = fun v1 v2 -> op Op.Eq v1 v2 >>= fun v -> assign v V.zero let eqT : V.v -> V.v -> unit t = assign let cutoffT msg ii v = forceT v (mk_singleton_es (E.Act.cutoff msg) ii) type evt_struct = E.event_structure type output = VC.cnstrnts * evt_struct let get_output et k = let (_,(es,_)) = et (0,0) in List.fold_left (fun k (_,vcl,evts) -> (vcl,evts)::k) k (Evt.elements es) let force_once (m : 'a t) : 'a t = let res = ref None in let new_m eiid = match !res with | None -> let eiid, v = m eiid in let _evts, evts_specul = v in let () = if Option.is_none evts_specul then () else Warn.warn_always "Speculated stored events. Results unknown." in let () = res := Some v in (eiid, v) | Some v -> (eiid, v) in new_m let debugT (s : string) (m : 'a t) : 'a t = fun eiid -> let eiid,(evts,specs) = m eiid in List.iter (fun (_,_,es) -> eprintf "%s%a" s E.debug_event_structure es) (Evt.elements evts) ; eiid,(evts,specs) end herd-herdtools7-1ca343e/herd/explicit.ml000066400000000000000000000040151475314470400202370ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris, France. *) (* *) (* Copyright 2020-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Explicit annotation for accesses, non-explicit accesses are more of less accesses added by, e.g. the virtual memory system. *) module type S = sig type explicit val exp_annot : explicit val nexp_annot : explicit val is_explicit_annot : explicit -> bool val is_not_explicit_annot : explicit -> bool val is_ifetch_annot : explicit -> bool val pp_explicit : explicit -> string val explicit_sets : (string * (explicit -> bool)) list end (* Default setting: all accesses are explicit *) module No = struct type explicit = unit let exp_annot = () let nexp_annot = () let is_explicit_annot _ = true let is_not_explicit_annot _ = false let is_ifetch_annot _ = false let pp_explicit _ = "" let explicit_sets = [] end (* Default setting, action level *) module NoAction = struct let is_explicit _ = true and is_not_explicit _ = false end herd-herdtools7-1ca343e/herd/explicit.mli000066400000000000000000000035071475314470400204150ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris, France. *) (* *) (* Copyright 2020-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Explicit annotation for accesses, non-explicit accesses are more of less accesses added by, e.g. the virtual memory system. *) module type S = sig type explicit val exp_annot : explicit val nexp_annot : explicit val is_explicit_annot : explicit -> bool val is_not_explicit_annot : explicit -> bool val is_ifetch_annot : explicit -> bool val pp_explicit : explicit -> string val explicit_sets : (string * (explicit -> bool)) list end (* Default setting: all accesses are explicit *) module No : S with type explicit=unit (* Default setting, action level *) module NoAction : sig val is_explicit :'act -> bool val is_not_explicit :'act -> bool end herd-herdtools7-1ca343e/herd/getModel.ml000066400000000000000000000037601475314470400201640ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) let check_arch_model a m = match m with | Model.Generic (_,(o,_,_)) -> begin match o.ModelOption.arch with | None -> m | Some b -> if a = b then m else Warn.user_error "Architecture mismatch between test and model (%s vs. %s)" (Archs.pp a) (Archs.pp b) end | m -> m let parse archcheck arch libfind variant model = let m = match model with | None -> Model.get_default_model variant arch | Some m -> m in let m = match m with | Model.File fname -> let module P = ParseModel.Make (struct include LexUtils.Default let libfind = libfind end) in let fname,ast = P.find_parse fname in Model.Generic (fname,ast) | _ -> m in if archcheck then check_arch_model arch m else m herd-herdtools7-1ca343e/herd/getModel.mli000066400000000000000000000027121475314470400203310ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Get usable model, _i.e._ from filename to cat model *) val parse : bool (* check architecture *) -> Archs.t -> (string -> string) (* libfind, to read default model *) -> (Variant.t -> bool) -> Model.t option (* Model specified, if any *) -> Model.t herd-herdtools7-1ca343e/herd/graph.ml000066400000000000000000000027121475314470400175210ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) type t = Free | Cluster | Columns let tags = ["free"; "cluster";"columns";] let parse tag = match Misc.lowercase tag with | "free" -> Some Free | "cluster" -> Some Cluster | "columns" -> Some Columns | _ -> None let pp = function | Free -> "free" | Cluster -> "cluster" | Columns -> "columns" herd-herdtools7-1ca343e/herd/graph.mli000066400000000000000000000024601475314470400176720ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Various graph layouts *) type t = Free | Cluster | Columns val tags : string list val parse : string -> t option val pp : t -> string herd-herdtools7-1ca343e/herd/handler.ml000066400000000000000000000031271475314470400200360ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Simple signal handler managment *) let handlers = ref [] let set_handlers () = let doit signal = Sys.set_signal signal (Sys.Signal_handle (fun _ -> List.iter (fun f -> f ()) !handlers ; exit 1)) in doit Sys.sigint ; doit Sys.sigterm ; doit Sys.sighup ; () let () = set_handlers () let push f = handlers := f :: !handlers let pop () = match !handlers with | [] -> () | _::rem -> handlers := rem herd-herdtools7-1ca343e/herd/handler.mli000066400000000000000000000024041475314470400202040ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Simple signal handler management *) val push : (unit -> unit) -> unit val pop : unit -> unit herd-herdtools7-1ca343e/herd/herd.ml000066400000000000000000000555731475314470400173570ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Entry point to Herd *) open Printf open Archs open Opts (* Command line arguments *) let args = ref [] let get_cmd_arg s = args := s :: !args (* Helpers *) open ArgUtils (* Option list *) let load_config s = LexConf_herd.lex (Opts.libfind !includes !debug.Debug_herd.files s) let pp_default_model a = sprintf "%s=%s" (Archs.pp a) (Model.pp (Model.get_default_model !Opts.variant a)) let gen_model_opt s = parse_tag s (fun tag -> match Model.parse tag with | None -> false | Some _ as m -> model := m ; true) Model.tags (sprintf " select model, defaults %s, %s, %s, %s, %s, %s, %s" (pp_default_model x86) (pp_default_model x86_64) (pp_default_model ppc) (pp_default_model arm) (pp_default_model aarch64) (pp_default_model riscv) (pp_default_model Archs.c)) let options = [ (* Basic *) ("-version", Arg.Unit (fun () -> printf "%s, Rev: %s\n" Version.version Version.rev ; exit 0), " show version number and exit") ; ("-libdir", Arg.Unit (fun () -> print_endline !Opts.libdir; exit 0), " show installation directory and exit"); ("-set-libdir", Arg.String (fun s -> Opts.libdir := s), " set installation directory to "); ("-v", Arg.Unit (fun _ -> incr verbose), " show various diagnostics, repeat to increase verbosity"); ("-q", Arg.Unit (fun _ -> verbose := -1; debug := Debug_herd.none), " do not show diagnostics"); ("-I", Arg.String (fun s -> includes := !includes @ [s]), " add to search path"); parse_bool "-exit" Opts.exit_if_failed "exit in case of failure"; parse_float_opt "-timeout" Opts.timeout "timeout (CPU time)"; ("-conf", Arg.String load_config, " read configuration file ") ; ("-bell", Arg.String (fun x -> Opts.bell := (Some x)), " read bell file ") ; ("-macros", Arg.String (fun x -> Opts.macros := (Some x)), " read macro (.def) file ") ; ("-o", Arg.String (fun s -> match s with | "-" -> outputdir := PrettyConf.StdoutOutput | _ -> outputdir := PrettyConf.Outputdir s), " generated files will go into , default: do not generate") ; ("-suffix", Arg.String (fun s -> suffix := s), " add at the end of the base of generated files") ; parse_bool "-dumpes" Opts.dumpes "dump event structures"; begin let module ParseView = ParseTag.Make(View) in ParseView.parse_opt "-view" PP.view "fork specified viewer to show output graphs" end ; ( "-gv", Arg.Unit (fun _ -> PP.view := Some View.GV), " alias for -view gv") ; ( "-evince", Arg.Unit (fun _ -> PP.view := Some View.Evince), " alias for -view evince") ; ( "-preview", Arg.Unit (fun _ -> PP.view := Some View.Preview), " alias for -view preview") ; ("-unroll", Arg.Int (fun x -> unroll := Some x), sprintf " branch unrolling upper limit, default ASL: %i, others: %i" (unroll_default `ASL) (unroll_default `Others)); parse_bool "-hexa" PP.hexa "print numbers in hexadecimal"; (* undocumented *) ("-switch", Arg.Unit (fun () -> Misc.switch := true), "switch something") ; ("-web", Arg.Unit (fun () -> load_config "web.cfg")," alias for -conf web.cfg"); ("-c11", Arg.Unit (fun () -> load_config "cpp11.cfg")," alias for -conf cpp11.cfg"); parse_tags "-debug" (fun tag -> match Debug_herd.parse !debug tag with | None -> false | Some t -> debug := t ; true) Debug_herd.tags "show debug messages for specific parts" ; parse_bool "-morefences" (ref false) "does nothing (deprecated)" ; (* Engine control *) gen_model_opt "-model"; gen_model_opt "-cat"; parse_tag "-through" (fun tag -> match Model.parse_through tag with | None -> false | Some t -> through := t ; true) Model.tags_through (sprintf "what to let through in addition to valid executions, default %s" (Model.pp_through !through)) ; parse_string_opt "-throughflag" throughflag "let through executions flagged with string, and only those" ; ("-skipcheck", Arg.String (fun tag -> skipchecks := StringSet.add tag !skipchecks), " do not apply check, cumulates") ; parse_stringset "-skipchecks" skipchecks "do not apply listed checks, cumulative" ; parse_bool "-strictskip" strictskip "retain outcomes allowed by ALL skipped checks" ; parse_stringset "-cycles" cycles " show failing checks as cycles, cumulates" ; (* Model control *) begin let module ParseVariant = ParseTag.MakeS(Opts.OptS) in ParseVariant.parse "-variant" variant "select an architecture variation" end ; begin let module ParseMachSize = ParseTag.Make(MachSize.Tag) in ParseMachSize.parse "-machsize" byte "set basic machine size" end ; begin let module ParseEndian = ParseTag.Make(Endian) in ParseEndian.parse_opt "-endian" endian "set endianness" end ; parse_bool "-archcheck" archcheck "check compatibility of test and cat model architectures" ; parse_tag "-optace" (fun tag -> match OptAce.parse tag with | None -> false | Some t -> optace := Some t ; true) OptAce.tags "optimize axiomatic candidate generation, default is iico"; "-initwrites", Arg.Bool (fun b -> initwrites := Some b), " represent init writes as write events, this option should not be used except for debugging model options"; parse_tag "-show" (fun tag -> match PrettyConf.parse_show tag with | None -> false | Some t -> show := t ; true) PrettyConf.tags_show (sprintf "executions shown in figure, default %s" (PrettyConf.pp_show !show)) ; "-showflag", Arg.String (fun flag -> show := PrettyConf.ShowFlag flag), " show executions flagged by string in figure" ; (* Discard some observations *) parse_tag "-speedcheck" (fun tag -> match Speed.parse tag with | None -> false | Some t -> speedcheck := t ; true) Speed.tags "aim at checking condition in place of listing final states" ; "-nshow", Arg.Int (fun n -> nshow := Some n), " collect at most pictures, default is to collect all (specified) pictures"; parse_bool "-badexecs" badexecs "give output for tests that have bad executions (see -badflag)" ; parse_string_opt "-badflag" badflag "executions with flag are bad" ; parse_bool "-checkfilter" check_filter "discard outcomes that negate filter proposition (if any)" ; (* undocumented *) "-showone", Arg.Bool (fun b -> if b then nshow := Some 1), " alias for -nshow 1"; parse_int_opt "-maxphantom" maxphantom "maximum phantom update (per variable)"; "-statelessrc11", Arg.Bool (fun b -> if b then statelessrc11 := true), " enable stateless RC11 model checking, use with -variant normw, SC check can be skipped"; "-dumpallfaults", Arg.Bool (fun b -> dumpallfaults := b), "Dump final states with all faults that that happenned regardless of the post-condition"; (************************) (* Control dot pictures *) (************************) (* General *) parse_tag "-graph" (fun tag -> match Graph.parse tag with | None -> false | Some t -> PP.graph := t ; true) Graph.tags (sprintf "select sort of graph, default %s" (Graph.pp !PP.graph)) ; parse_tag "-dotmode" (fun tag -> match PrettyConf.parse_dotmode tag with | None -> false | Some t -> PP.dotmode := t ; true) PrettyConf.tags_dotmode (sprintf "control text in dot figures, default %s" (PrettyConf.pp_dotmode !PP.dotmode)) ; parse_tag "-dotcom" (fun tag -> match PrettyConf.parse_dotcom tag with | None -> false | Some _ as t -> PP.dotcom := t ; true) PrettyConf.tags_dotcom "select command to translate dot, default depends on other modes" ; parse_tag "-showevents" (fun tag -> match PrettyConf.parse_showevents tag with | None -> false | Some t -> PP.showevents := t ; true) PrettyConf.tags_showevents (sprintf "select events shown in figures, default %s" (PrettyConf.pp_showevents !PP.showevents)) ; parse_bool "-mono" PP.mono "monochrome figures" ; parse_float "-scale" PP.scale "global scale factor for graphs" ; parse_float "-xscale" PP.xscale "global scale factor for graphs, x direction" ; parse_float "-yscale" PP.yscale "global scale factor for graphs, y direction" ; parse_float "-dsiy" PP.dsiy "vertical variation for events generated by the same instruction" ; parse_float "-siwidth" PP.siwidth "width occupied by events generated by the same instruction" ; parse_float "-ptscale" PP.ptscale "scale factor for points" ; parse_float "-boxscale" PP.ptscale "scale factor box width" ; parse_bool "-showthread" PP.showthread "show thread numbers in figures" ; "-shift", Arg.String (fun tag -> let fs = Misc.split_comma tag in let fs = List.map (fun f -> try float_of_string f with | _ -> raise (Arg.Bad (sprintf "bad argument for option -shift: '%s'" tag))) fs in PP.shift := Array.of_list fs), " add vertical space at thread start (column mode only)"; parse_bool "-edgemerge" PP.edgemerge "merge edges, cppmem style" ; parse_bool "-labelinit" PP.labelinit "show labels on the init node" ; (* Legend *) parse_bool "-showlegend" PP.showlegend "show legend in pictures" ; parse_bool "-showkind" showkind "show test kind in legends" ; parse_bool "-shortlegend" shortlegend "show test name only in legends"; (* Nodes *) parse_bool "-squished" PP.squished "limit information in graph nodes" ; parse_bool "-fixedsize" PP.fixedsize "fixedsize attribute for nodes in graph" ; parse_float "-extrachars" PP.extrachars "additional space for computing node width, can be negative" ; parse_bool "-showobserved" PP.showobserved "highlight observed memory reads in pictures" ; parse_bool "-brackets" PP.brackets "show brackets around locations in pictures" ; parse_bool "-texmacros" PP.texmacros "use latex commands in output"; parse_bool "-tikz" PP.tikz "generate dot files suitable for processing with TikZ"; (* Edge selection *) parse_bool "-showpo" PP.showpo "show po edges in pictures" ; parse_bool "-showinitrf" PP.showinitrf "show read-from edges from initial state in pictures" ; parse_bool "-showfinalrf" PP.showfinalrf "show read-from edges to final state in pictures" ; parse_pos "-initrfpos" PP.initdotpos "position of pseudo source event for initial rf" ; parse_pos "-finalrfpos" PP.initdotpos "position of pseudo target event for final rf" ; parse_bool "-oneinit" PP.oneinit "show a init writes pseudo-event, with all initial writes grouped" ; parse_pos_opt "-initpos" PP.initpos "position of the init writes pseudo-event" ; parse_bool "-showinitwrites" PP.showinitwrites "show init write events in pictures" ; parse_float "-threadposy" PP.threadposy "thread number position in the y direction" ; parse_stringsetfun "-doshow" PP.add_doshow "show those edges"; parse_stringsetfun "-unshow" PP.add_unshow "do not show those edges" ; parse_stringset "-symetric" PP.symetric "declare those edges as symetric" ; parse_stringset "-noid" PP.noid "like -symetric, additionally do not show identity edges" ; parse_string_opt "-classes" PP.classes "show classes of this equivalence (no not cumulate)" ; parse_stringset "-showraw" PP.showraw "do not perform transitivity removal on those edges" ; (* DOT contents control *) parse_tag "-splines" (fun tag -> match Splines.parse tag with | None -> false | Some Splines.No -> PP.splines := None; true | Some t -> PP.splines := Some t ; true) Splines.tags "specify splines graph attribute, default none" ; parse_float_opt "-margin" PP.margin "margin attribute of graphs"; parse_float_opt "-pad" PP.pad "pad attribute of graphs"; parse_string_opt "-sep" PP.sep "specify graph sep attribute" ; parse_string_opt "-fontname" PP.fontname "fontname attribute in graphs" ; parse_int_opt "-fontsize" PP.fontsize "fontsize attribute in graphs" ; parse_int "-edgefontsizedelta" PP.edgedelta "value to add to edge fontsize" ; parse_float_opt "-penwidth" PP.penwidth "penwidth attribute in graphs" ; parse_float_opt "-arrowsize" PP.arrowsize "arrowsize attribute in graphs" ; "-edgeattr", Arg.String (fun tag -> match Misc.split_comma tag with | [lbl;a;v;] -> PP.add_edgeattr lbl a v | _ -> raise (Arg.Bad (sprintf "bad argument for option -edgeattr: '%s'" tag))), " specify an attribute for edges labelled by label"; (* Select input *) CheckName.parse_names names ; CheckName.parse_excl excl ; (* Change input *) CheckName.parse_rename rename ; ( "-kinds", Arg.String (fun s -> kinds := !kinds @ [s]), " specify kind of tests (can be repeated)"); ( "-conds", Arg.String (fun s -> conds := !conds @ [s]), " specify conditions of tests (can be repeated)"); (* Undocumented *) parse_bool "-candidates" candidates "show complete candidate count in output" ; parse_tag "-restrict" (fun tag -> match Restrict.parse tag with | None -> false | Some t -> restrict := t ; true) Restrict.tags (sprintf "restrict outcomes, default %s" (Restrict.pp !restrict)); parse_bool "-outcomereads" outcomereads "include all memory reads in outcomes" ; parse_string_opt "-overlap" PP.overlap "specify graph overlap attribute" ; parse_bool "-relabel" PP.relabel "merge power/arm labels(e.g sync -> sync/dmb)" ; parse_bool "-withbox" PP.withbox "box together events generated by the same instruction" ; parse_bool "-labelbox" PP.labelbox "label instruction instruction boxes with instruction" ; parse_bool "-movelabel" PP.movelabel "apply various tricks to enhance edge label placement in pictures" ; ("-dotheader",Arg.String (fun s -> PP.dotheader := Some s), " insert the contents of at the beginning of generated dot files"); ] (* Parse command line *) let () = try Arg.parse options get_cmd_arg (sprintf "Usage %s [options] [test]*" prog) with | Misc.Fatal msg -> eprintf "%s: %s\n" prog msg ; exit 2 (* Read generic model, if any *) let libfind = Opts.libfind !includes !debug.Debug_herd.files module ParserConfig = struct let debug = !debug.Debug_herd.lexer let libfind = libfind end let model,model_opts = match !model with | Some (Model.File fname) -> let module P = ParseModel.Make(ParserConfig) in begin try let (fname,((b,_,_) as r)) = P.find_parse fname in Some (Model.Generic (fname,r)),b with | Misc.Fatal msg -> eprintf "%s: %s\n" prog msg ; exit 2 | Misc.Exit -> eprintf "Failure of generic model parsing\n" ; exit 2 end | Some _ as m -> m,ModelOption.compat | None -> None,ModelOption.default (* Check names, NB no select argument! *) module Verbose = struct let verbose = if !debug.Debug_herd.lexer then !verbose else 0 end module Check = CheckName.Make (struct include Verbose let rename = !rename let select = [] let names = !names let excl = !excl end) (* Read kinds/conds files *) module LR = LexRename.Make(Verbose) let kinds = LR.read_from_files !kinds ConstrGen.parse_kind let conds = LR.read_from_files !conds (fun s -> Some s) (* Configure parser/models/etc. *) let () = let module Config = struct let timeout = !timeout let candidates = !candidates let nshow = !nshow let restrict = !restrict let showkind = !showkind let shortlegend = !shortlegend let model = model let archcheck = !archcheck let through = !through let skipchecks = !skipchecks let strictskip = !strictskip let cycles = !cycles let outcomereads = !outcomereads let show = !show let badexecs = !badexecs let badflag = !badflag let throughflag = !throughflag let maxphantom = !maxphantom let statelessrc11 = !statelessrc11 let dumpallfaults = !dumpallfaults let check_name = Check.ok let check_rename = Check.rename_opt let check_kind = TblRename.find_value_opt kinds let check_cond = TblRename.find_value_opt conds let libfind = libfind let macros = !macros let model_enumco = model_opts.ModelOption.co let observed_finals_only = not model_enumco let initwrites = match !initwrites with | None -> model_opts.ModelOption.init | Some b -> b let check_filter = !check_filter let debug = !debug let debuglexer = debug.Debug_herd.lexer let verbose = !verbose let unroll = !unroll let speedcheck = !speedcheck let optace = match !optace with | Some b -> b | None -> match model with | Some (Model.Generic _|Model.File _)|None -> OptAce.Iico | Some (Model.CAV12 _) -> OptAce.False let variant = !variant let fault_handling = !Refs.fault_handling let mte_precision = !Refs.mte_precision let sve_vector_length = !Refs.sve_vector_length let sme_vector_length = !Refs.sme_vector_length let byte = !byte let endian = !endian let outputdir = !outputdir let suffix = !suffix let dumpes = !dumpes module PC = struct let debug = debug.Debug_herd.pretty let verbose = verbose let dotmode = !PP.dotmode let dotcom = !PP.dotcom let view = !PP.view let showevents = !PP.showevents let texmacros = !PP.texmacros let tikz = !PP.tikz let hexa = !PP.hexa let mono = !PP.mono let fontname = !PP.fontname let fontsize = !PP.fontsize let edgedelta = !PP.edgedelta let penwidth = !PP.penwidth let arrowsize = !PP.arrowsize let splines = !PP.splines let overlap = !PP.overlap let sep = !PP.sep let margin = !PP.margin let pad = !PP.pad let scale = !PP.scale let xscale = !PP.xscale let yscale = !PP.yscale let dsiy = !PP.dsiy let siwidth = !PP.siwidth let boxscale = !PP.boxscale let ptscale = !PP.ptscale let squished = !PP.squished let graph = !PP.graph let showpo = !PP.showpo let relabel = !PP.relabel let withbox = !PP.withbox let labelbox = !PP.labelbox let showthread = !PP.showthread let showlegend = !PP.showlegend let showfinalrf = !PP.showfinalrf let showinitrf = !PP.showinitrf let finaldotpos = !PP.finaldotpos let initdotpos = !PP.initdotpos let oneinit = !PP.oneinit let initpos = !PP.initpos let threadposy = !PP.threadposy let showinitwrites = !PP.showinitwrites let brackets = !PP.brackets let showobserved = !PP.showobserved let movelabel = !PP.movelabel let fixedsize = !PP.fixedsize let extrachars = !PP.extrachars let edgeattrs = PP.get_edgeattrs () let doshow = !PP.doshow let unshow = !PP.unshow let noid = !PP.noid let symetric = !PP.symetric let classes = !PP.classes let showraw = !PP.showraw let dotheader = match !PP.dotheader with | None -> None | Some f -> let fname = libfind f in try Misc.input_protect (fun chan -> let xs = MySys.read_by_line chan (fun x xs -> x::xs) [] in Some (String.concat "\n" (List.rev xs))) fname with Sys_error msg -> eprintf "Cannot read %s: %s\n" f msg ; exit 2 let shift = !PP.shift let edgemerge = !PP.edgemerge let labelinit = !PP.labelinit let variant = variant end end in let bi = match !Opts.bell with | None -> None | Some fname -> let module R = ReadBell.Make (struct let debug_lexer = Config.debug.Debug_herd.lexer let debug_model = Config.debug.Debug_herd.barrier let debug_files = Config.debug.Debug_herd.files let verbose = Config.verbose let libfind = libfind let compat = Config.variant Variant.BackCompat let prog = prog let variant = Misc.delay_parse Config.variant Variant.parse end) in let bi = R.read fname in Some (fname,bi) in let from_file f = let module T = ParseTest.Top (struct let bell_model_info = bi include Config end) in SymbValue.reset_gensym () ; T.from_file f in (* Just go *) let tests = !args in let check_exit = let b = !Opts.exit_if_failed in fun seen -> if b then exit 1 else seen in let check_pos0 s = String.length s > 5 && begin match s.[0],s.[1],s.[2],s.[3],s.[4] with | 'F','i','l','e',' ' -> true | _ -> false end in let dbg_exc = !Opts.debug.Debug_herd.exc in let _seen = (* If interval timer enabled and triggered, then stop test with not output at all *) Itimer.set_signal Config.timeout (fun _ -> raise Misc.Timeout) !debug.Debug_herd.timeout; Misc.fold_argv_or_stdin (fun name seen -> try from_file name seen with | Misc.Timeout -> seen | Misc.Exit as e -> if dbg_exc then raise e ; check_exit seen | Misc.Fatal msg as e -> if dbg_exc then raise e ; Warn.warn_always "%a: %s" Pos.pp_pos0 name msg ; check_exit seen | Misc.UserError msg as e -> if dbg_exc then raise e ; begin if check_pos0 msg then Warn.warn_always "%s (User error)" msg else Warn.warn_always "%a: %s (User error)" Pos.pp_pos0 name msg end ; check_exit seen | Asllib.Error.ASLException e as exc -> if dbg_exc then raise exc ; Warn.warn_always "%s" (Asllib.Error.error_to_string e); check_exit seen | e -> Printf.eprintf "\nFatal: %a Adios\n" Pos.pp_pos0 name ; raise e) tests StringMap.empty in exit 0 herd-herdtools7-1ca343e/herd/itimer.ml000066400000000000000000000037761475314470400177240ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2021-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Unix let dbg = false let name = ref "" let set_signal timeout f dbg = match timeout with | None -> () | Some _ -> let g = if dbg then fun s -> let n = !name in if n <> "" then Printf.eprintf "Timeout for %s\n%!" n ; f s else f in Sys.set_signal 26 (* SIGVTALARM *) (Sys.Signal_handle g) let start n timeout = match timeout with | None -> () | Some t -> name := n ; if dbg then Printf.eprintf "Start %s\n%!" n ; let it = {it_value=t; it_interval=0.0;} in ignore (setitimer ITIMER_VIRTUAL it) and stop timeout = match timeout with | None -> () | Some _ -> if dbg then Printf.eprintf "Stop %s\n%!" !name ; name := "" ; let it = {it_value=0.0; it_interval=0.0;} in ignore (setitimer ITIMER_VIRTUAL it) herd-herdtools7-1ca343e/herd/itimer.mli000066400000000000000000000035271475314470400200670ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2021-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Simple interface to interval timer in virtual processor time *) (** [set_signal timeout handle] set signal handle for timer. * Argument timeout is an option, if [None] do nothing * Argument debug is default false, if [true] print timeout debug *) val set_signal : float option -> (int -> unit) -> bool -> unit (** [start timeout] start interval for the given period. * Argument timeout is an option, if [None] do nothing, * otherwise the option specifies the timer period. *) val start : string -> float option -> unit (** [stop timeout] stop interval timer. * Argument timeout is an option, if [None] do nothing, * otherwise stop timer. *) val stop : float option -> unit herd-herdtools7-1ca343e/herd/lexConf_herd.mli000066400000000000000000000023341475314470400211710ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Read configuration files *) val lex : string -> unit herd-herdtools7-1ca343e/herd/lexConf_herd.mll000066400000000000000000000225331475314470400211770ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Read configuration files *) { open Printf open Opts open LexMisc exception LocError of string let error msg = raise (LocError msg) let lex_some ty lex arg = match arg with | "none" -> None | _ -> try Some (lex arg) with _ -> error (sprintf "%s parameter expected" ty) let lex_tag_fun key parse tags set tag = match parse tag with | Some x -> set x | None -> error (sprintf "bad tags for %s, allowed tag are %s" key (String.concat "," tags)) let lex_tag key parse tags v tag = lex_tag_fun key parse tags (fun x -> v := x) tag let lex_tag_opt key parse tags v tag = lex_tag_fun key parse tags (fun x -> v := Some x) tag let lex_bool_fun set arg = let x = try bool_of_string arg with _ -> error "bool parameter expected" in set x let lex_bool v arg = lex_bool_fun (fun b -> v := b) arg let lex_int_fun set arg = let x = try int_of_string arg with _ -> error "integer parameter expected" in set x let lex_int r arg = lex_int_fun (fun x -> r := x) arg let lex_int_opt r arg = r := lex_some "integer" int_of_string arg let lex_float_fun set arg = let x = try float_of_string arg with _ -> error "float parameter expected" in set x let lex_float r arg = lex_float_fun (fun x -> r := x) arg let lex_float_opt r arg = r := lex_some "float" float_of_string arg let lex_pos_fun set arg = match Misc.pos_of_string arg with | Some p -> set p | None -> error "pair of float parameter expected" let lex_pos r arg = lex_pos_fun (fun p -> r := p) arg let lex_pos_opt r arg = lex_pos_fun (fun p -> r := Some p) arg let lex_string_opt v arg = v := lex_some "string" (fun s -> s) arg let lex_stringsetfun f arg = let es = Misc.split_comma arg in f (StringSet.of_list es) let lex_stringset v arg = lex_stringsetfun (fun s -> v := StringSet.union s !v) arg open Lexing let dolex main fname = let dolex chan = let lexbuf = Lexing.from_channel chan in lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname=fname;}; try main lexbuf with LocError msg -> LexMisc.error msg lexbuf in try Misc.input_protect dolex fname with Error (msg,pos) -> eprintf "%a: %s\n" Pos.pp_pos pos msg ; exit 2 let handle_key main key arg = match key with | "conf" -> let module ML = MyLib.Make (struct let includes = !includes let env = Some "HERDLIB" let libdir = !Opts.libdir let debug = !debug.Debug_herd.files end) in dolex main (ML.find arg) | "verbose" -> lex_int verbose arg | "suffix" -> suffix := arg | "include" -> includes := !includes @ [arg] | "timeout" -> lex_float_opt timeout arg | "debug" -> begin match Debug_herd.parse !debug arg with | Some t -> debug := t | None -> error (sprintf "bad argument for key debug: '%s'" arg) end (* Change input *) | "names" -> names := !names @ [arg] | "excl" -> excl := !excl @ [arg] | "rename" -> rename := !rename @ [arg] | "kinds" -> kinds := !kinds @ [arg] | "conds" -> conds := !conds @ [arg] (* Behaviour control *) | "model"|"cat" -> lex_tag_opt key Model.parse Model.tags model arg | "bell" -> bell := Some arg | "macros" -> macros := Some arg | "variant" -> let module PV = ParseTag.MakeS(Opts.OptS) in PV.parse_tag_set "variant" variant arg | "machsize" -> lex_tag "machsize" MachSize.Tag.parse MachSize.Tag.tags byte arg | "endian" -> lex_tag_opt "endian" Endian.parse Endian.tags endian arg | "through" -> lex_tag "through" Model.parse_through Model.tags_through through arg | "skipchecks" -> lex_stringset skipchecks arg | "strictskip" -> lex_bool strictskip arg | "unroll" -> lex_int_opt unroll arg | "optace" -> lex_tag_opt "optace" OptAce.parse OptAce.tags optace arg | "archcheck" -> lex_bool archcheck arg | "initwrites" -> lex_bool_fun (fun b -> initwrites := Some b) arg | "speedcheck" -> lex_tag "speedcheck" Speed.parse Speed.tags speedcheck arg | "badexecs" -> lex_bool badexecs arg | "badflag" -> lex_string_opt badflag arg | "dumpallfaults" -> lex_bool dumpallfaults arg (* Control output *) | "show" -> lex_tag "show" PrettyConf.parse_show PrettyConf.tags_show show arg | "showflag" -> show := PrettyConf.ShowFlag arg | "nshow" -> lex_int_fun (fun x -> nshow := Some x) arg | "restrict" -> lex_tag "restrict" Restrict.parse Restrict.tags restrict arg | "showkind" -> lex_bool showkind arg | "shortlegend" -> lex_bool shortlegend arg | "texmacros" -> lex_bool PP.texmacros arg | "hexa" -> lex_bool PP.hexa arg | "outcomereads" -> lex_bool outcomereads arg | "dotmode" -> lex_tag "dotmode" PrettyConf.parse_dotmode PrettyConf.tags_dotmode PP.dotmode arg | "dotcom" -> lex_tag_opt "dotcom" PrettyConf.parse_dotcom PrettyConf.tags_dotmode PP.dotcom arg | "view" -> lex_tag_opt "view" View.parse View.tags PP.view arg | "showevents" -> lex_tag "showevents" PrettyConf.parse_showevents PrettyConf.tags_showevents PP.showevents arg | "graph" -> lex_tag "graph" Graph.parse Graph.tags PP.graph arg | "mono" -> lex_bool PP.mono arg | "fontname" -> lex_string_opt PP.fontname arg | "fontsize" -> lex_int_opt PP.fontsize arg | "edgefontsizedelta" -> lex_int PP.edgedelta arg | "penwidth" -> lex_float_opt PP.penwidth arg | "arrowsize" -> lex_float_opt PP.arrowsize arg | "splines" -> lex_tag_fun "splines" Splines.parse Splines.tags (fun x -> PP.splines := Some x) arg | "overlap" -> lex_string_opt PP.overlap arg | "sep" -> lex_string_opt PP.sep arg | "margin" -> lex_float_opt PP.margin arg | "pad" -> lex_float_opt PP.pad arg | "scale" -> lex_float PP.scale arg | "xscale" -> lex_float PP.xscale arg | "yscale" -> lex_float PP.yscale arg | "dsiy" -> lex_float PP.dsiy arg | "siwidth" -> lex_float PP.siwidth arg | "boxscale" -> lex_float PP.boxscale arg | "ptscale" -> lex_float PP.ptscale arg | "squished" -> lex_bool PP.squished arg | "showpo" -> lex_bool PP.showpo arg | "relabel" -> lex_bool PP.relabel arg | "withbox" -> lex_bool PP.withbox arg | "labelbox" -> lex_bool PP.labelbox arg | "showfinalrf" -> lex_bool PP.showfinalrf arg | "showinitrf" -> lex_bool PP.showinitrf arg | "finalrfpos" -> lex_pos PP.finaldotpos arg | "initrfpos" -> lex_pos PP.initdotpos arg | "oneinit" -> lex_bool PP.oneinit arg | "labelinit" -> lex_bool PP.labelinit arg | "initpos" -> lex_pos_opt PP.initpos arg | "threadposy" -> lex_float PP.threadposy arg | "showinitwrites" -> lex_bool PP.showinitwrites arg | "showthread" -> lex_bool PP.showthread arg | "showlegend" -> lex_bool PP.showlegend arg | "brackets" -> lex_bool PP.brackets arg | "showobserved" -> lex_bool PP.showobserved arg | "movelabel" -> lex_bool PP.movelabel arg | "fixedsize" -> lex_bool PP.fixedsize arg | "extrachars" -> lex_float PP.extrachars arg | "dotheader" -> PP.dotheader := Some arg | "doshow" -> lex_stringsetfun PP.add_doshow arg | "unshow" -> lex_stringsetfun PP.add_unshow arg | "noid" -> lex_stringset PP.noid arg | "symetric" -> lex_stringset PP.symetric arg | "classes" -> lex_string_opt PP.classes arg | "showraw" -> lex_stringset PP.showraw arg | "edgeattr" -> begin match Misc.split_comma arg with | [lbl;a;v;] -> PP.add_edgeattr lbl a v | _ -> error (sprintf "bad ->ument for key edgeattr: '%s'" arg) end | "shift" -> let fs = Misc.split_comma arg in let fs = List.map (fun f -> try float_of_string f with _ -> error "bad argument for key shift: '%s' arg") fs in PP.shift := Array.of_list fs | "edgemerge" -> lex_bool PP.edgemerge arg | _ -> error (sprintf "Unknown key '%s' in configuration file" key) } let blank = [' ''\t''\r'] let not_blank = [^' ''\t''\n''\r'] let arg = ((blank* '=' blank*|blank+) (not_blank [^'\n']* as arg) blank* ('\n'|eof)) rule main = parse | eof { () } | '#' [^'\n']* '\n' | blank* '\n' { incr_lineno lexbuf; main lexbuf } | "" { opt lexbuf ; incr_lineno lexbuf; main lexbuf } and opt = parse | (['a'-'z''A'-'Z']+ as key) arg { handle_key main key arg } | "" { error "Unknown key in configuration file" } { let lex fname = dolex main fname } herd-herdtools7-1ca343e/herd/libdir/000077500000000000000000000000001475314470400173315ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/libdir/C11-README.txt000066400000000000000000000003721475314470400213530ustar00rootroot00000000000000Files c11_*.cat are C11 models from Overhauling SC atomics in C11 and OpenCL. M. Batty, A. Donaldson, J. Wickerson. In Proc. 43rd ACM SIGPLAN-SIGACT Symposium on Principles of Programming Languages (POPL), 2016. Rewritten by Luc Maranget for herd7 herd-herdtools7-1ca343e/herd/libdir/LL.cat000066400000000000000000000003651475314470400203350ustar00rootroot00000000000000LL let chapo = fr | rf | co | (co;rf) | (fr;rf) let poi = WW(po-loc) | RW(po-loc) | WR(po-loc) irreflexive poi ; chapo (* Show things... *) let dmb.st=WW(dmb.st) let dsb.st=WW(dsb.st) show dmb, dsb, dmb.st, dsb.st show addr, data, ctrl, ctrlisb herd-herdtools7-1ca343e/herd/libdir/aarch32.cat000066400000000000000000000006011475314470400212420ustar00rootroot00000000000000(* * This file has not been written and is not maintained by ARM Ltd. * Authors: * Luke Geeson *) AArch32 catdep let TagCheck = emptyset let IC.IVAU = emptyset let IC.IALLUIS = emptyset let IC.IALLU = emptyset let DC.CVAU = emptyset let TLBInXS = emptyset let TLBIIS = emptyset let Q = emptyset let DMB.SY = DMB let DSB.SY = DSB include "aarch64.cat" herd-herdtools7-1ca343e/herd/libdir/aarch64-obsolete.cat000066400000000000000000000017021475314470400230640ustar00rootroot00000000000000"AArch64" include "cos.cat" (* Uniproc *) acyclic po-loc | rf | fr | co as uniproc (* Utilities *) let dd = addr | data let rdw = po-loc & (fre;rfe) let detour = po-loc & (coe ; rfe) let addrpo = addr;po let com = fr | co | rf empty rmw & (fre;coe) as atomic include "aarch64fences.cat" let ci0 = ctrlisb | detour let ii0 = dd | rfi | rdw let cc0 = dd | ctrl | addrpo let ic0 = 0 include "ppo.cat" let acq = (A * M) & po let rel = (M * L) & po let syf = dmb.sy & (M * M) | dsb.sy & (M * M) let stf = dmb.st & (W * W) | dsb.st & (W * W) let ldf = dmb.ld & (R * M) | dsb.ld & (R * M) let fence = syf | stf | ldf | acq | rel let hb = (R * M) & fence | rfe | ppo acyclic hb as thin_air let prop = com*; syf | stf | rfe?; rel let prop_al = (L * A) & (rf | po) | (A * L) & fr let xx = (W * W) & (X * X) & po irreflexive prop; rfe; (fence | ppo); fre as observation acyclic co | prop;hb* | xx | prop_al;hb* as propagation herd-herdtools7-1ca343e/herd/libdir/aarch64.cat000066400000000000000000000144421475314470400212570ustar00rootroot00000000000000(* * The Armv8 Application Level Memory Model. * * This is a machine-readable, executable and formal artefact, which aims to be * the latest stable version of the Armv8 memory model. * If you have comments on the content of this file, please send an email to * memory-model@arm.com * For a textual version of the model, see section B2.3 of the Armv8 ARM: * https://developer.arm.com/documentation/ddi0487/ * * Authors: * Will Deacon * Jade Alglave * Nikos Nikoleris * Artem Khyzha * * Copyright (C) 2016-present, Arm Ltd. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 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. * * Neither the name of ARM nor the names of its contributors may be * used to endorse or promote products derived from this software * without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT * HOLDER 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. *) catdep (* This option says that the cat file computes dependencies *) include "aarch64hwreqs.cat" (*** Coherence-after ***) let ca = fr | co (*** TLBI-after, DC-after, IC-after ***) include "enumerations.cat" with TLBI-after from (all-TLBI-Imp_TTD_R-enums local-hw-reqs) with DC-after from (all-DC-Exp_W-enums local-hw-reqs) with IC-after from (all-IC-Imp_Instr_R-enums local-hw-reqs) (*** Hazard-ordered-before ***) (** Explicitly-hazard-ordered-before **) let Exp-haz-ob = [Exp & R]; (po & same-loc); [Exp & R]; (ca & ext); [Exp & W] (** TLBI-ordered-before **) (* TTD-read-ordered-before *) let TTD-read-ordered-before = TLBI-after; [TLBI]; po; [dsb.full]; po; [~(Imp & M)] | TLBI-after; [TLBI]; po; [dsb.full]; po; [IFB]; po; [Imp & M] | (if "ETS2" || "ETS3" then TLBI-after; [TLBI]; po; [dsb.full]; po; [Imp & TTD & M] else 0) (* TLBI-ordered-before *) let TLBI-ob = TTD-read-ordered-before | tr-ib^-1; TTD-read-ordered-before & ext | po-va-loc; TTD-read-ordered-before & ext (** IC-ordered-before **) (* Instr-read-ordered-before *) let Instr-read-ordered-before = IC-after; [IC]; po; [dsb.full]; po; [~(Imp & M)] | (if "DIC" then ca else 0) (* IC-ordered-before *) let IC-ob = [Imp & Instr & R]; po; [Imp & Instr & R]; Instr-read-ordered-before (* Hazard-ordered-before *) let haz-ob = Exp-haz-ob | TLBI-ob | IC-ob (*** Hardware-required-ordered-before ***) let hw-reqs = local-hw-reqs | haz-ob (*** Observed-by ***) (** Explicitly-observed-by **) let Exp-obs = [Exp & M]; rf & ext; [Exp & M] | [Exp & M]; ca & ext; [Exp & M] (** Tag-observed-by **) let Tag-obs = [Exp & W]; rf & ext; [Imp & Tag & R] | [Imp & Tag & R]; ca & ext; [Exp & W] (** TTD-observed-by **) (* TLBUncacheable-predecessor *) let TLBuncacheable-pred = [range([TLBUncacheable & FAULT]; tr-ib^-1)]; (ca & ~intervening(W,ca)); [Exp & W] (* Hardware-update-predecessor *) let HU-pred = (ca & ~intervening(W,ca)); [HU] (* TLBI-coherence-after *) let TLBI-ca = [TLBI]; TLBI-after; [Imp & TTD & R]; ca; [W] (* TTD-observed-by *) let TTD-obs = [Imp & TTD]; rf | rf; [Imp & TTD] | TLBuncacheable-pred | HU-pred | [HU]; ca; [W] | [W]; ca; [HU] | TLBI-ca (** Instr-observed-by **) (* IC-coherence-after *) let IC-ca = (if not "DIC" && not "IDC" then [IC]; IC-after; [Imp & Instr & R]; ca; [W]; DC-after; [DC.CVAU] else 0) | (if not "DIC" && "IDC" then [IC]; IC-after; [Imp & Instr & R]; ca; [W] else 0) | (if "DIC" && "IDC" then [Imp & Instr & R]; ca; [W] else 0) (* Instr-observed-by *) let Instr-obs = rf; [Imp & Instr & R] | IC-after | [DC.CVAU]; DC-after; [W] | [W]; DC-after; [DC.CVAU] | IC-ca (** Observed-by **) let obs = Exp-obs; sca-class? | Tag-obs; sca-class? | TTD-obs | Instr-obs (*** Ordered-before ***) let rec ob = hw-reqs | obs | ob; ob (*** External visibility requirement ***) irreflexive ob as external (*** Internal visibility requirements ***) irreflexive [Exp & R]; ((po & same-loc) | rmw); [Exp & W]; rfi; [Exp & R] as coRW1-Exp irreflexive [Imp & Tag & R]; (po & same-loc); [Exp & Tag & W]; rfi; [Imp & Tag & R] as coRW1-MTE irreflexive [Exp & W]; (po & same-loc); [Exp & W]; (ca & int); [Exp & W] as coWW-Exp irreflexive [Exp & W]; (po & same-loc); [Exp & R]; (ca & int); [Exp & W] as coWR-Exp irreflexive [Exp & Tag & W]; (po & same-loc); [Imp & Tag & R]; (ca & int) as coWR-MTE (*** Atomic: LDXR/STXR, AMO and HU constraint to forbid intervening writes. ***) empty (rmw & (fr; co)) \ (([Exp]; rmw; [Exp]) & (fri ; [Exp & W]; coi)) as atomic (*** Break Before Make ***) let BBM = ([TTDV]; ca; [TTDINV]; co; [TTDV]) flag ~empty (TTD-update-needsBBM & ~BBM) as requires-BBM (*** Additional synchronisation requirements for CMODX ***) let CMODX-conflicts = same-loc & ( (Imp & Instr & R & Within-CMODX-List) * W | (Imp & Instr & R) * (Within-CMODX-List & W) | W * (Within-CMODX-List & Imp & Instr & R) | (Within-CMODX-List & W) * (Imp & Instr & R) ) let CMODX-ordering = [Imp & Instr & R]; ob; [W] | [W]; ob; [Imp & Instr & R] let CMODX-unordered-conflicts = CMODX-conflicts \ (CMODX-ordering | CMODX-ordering^-1) flag ~empty CMODX-unordered-conflicts as violates-CMODX-requirements herd-herdtools7-1ca343e/herd/libdir/aarch64bbm.cat000066400000000000000000000074261475314470400217440ustar00rootroot00000000000000(* * The Armv8 Application Level Memory Model. * * This is a machine-readable, executable and formal artefact, which aims to be * the latest stable version of the Armv8 memory model. * If you have comments on the content of this file, please send an email to * jade.alglave@arm.com * For a textual version of the model, see section B2.3 of the Armv8 ARM: * https://developer.arm.com/documentation/ddi0487/ * * Authors: * Nikos Nikoleris * * Copyright (C) 2016-present, Arm Ltd. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 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. * * Neither the name of ARM nor the names of its contributors may be * used to endorse or promote products derived from this software * without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT * HOLDER 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. *) (* * Include aarch64memattrs.cat to define relations on Memory Attributes. *) include "aarch64memattrs.cat" (* Can we move this to stdlib? *) (* Coherence-after *) let ca = fr | co let PTE-MT-update = [PTENormal]; ca; [PTEDevice] | [PTEDevice]; ca; [PTENormal] let PTE-SH-update = [PTENon-shareable]; ca; [PTEInner-shareable | PTEOuter-shareable] | [PTEInner-shareable]; ca; [PTEOuter-shareable | PTENon-shareable] | [PTEOuter-shareable]; ca; [PTENon-shareable | PTEInner-shareable] let PTE-ICH-update = [PTEInner-non-cacheable]; ca; [PTEInner-write-through | PTEInner-write-back] | [PTEInner-write-through]; ca; [PTEInner-write-back | PTEInner-non-cacheable] | [PTEInner-write-back]; ca; [PTEInner-non-cacheable | PTEInner-write-through] let PTE-OCH-update = [PTEOuter-non-cacheable]; ca; [PTEOuter-write-through | PTEOuter-write-back] | [PTEOuter-write-through]; ca; [PTEOuter-write-back | PTEOuter-non-cacheable] | [PTEOuter-write-back]; ca; [PTEOuter-non-cacheable | PTEOuter-write-through] let PTE-DT-update = [PTEDevice-GRE]; ca; [PTEDevice-nGRE | PTEDevice-nGnRE | PTEDevice-nGnRnE] | [PTEDevice-nGRE]; ca; [PTEDevice-GRE | PTEDevice-nGnRE | PTEDevice-nGnRnE] | [PTEDevice-nGnRE]; ca; [PTEDevice-GRE | PTEDevice-nGRE | PTEDevice-nGnRnE] | [PTEDevice-nGnRnE]; ca; [PTEDevice-GRE | PTEDevice-nGRE | PTEDevice-nGnRE] let PTE-OA-update = ([PTE]; ca; [PTE & oa-changes(PTE, ca^-1)]) let PTE-OA-update-writable = PTE-OA-update & ([PTE]; ca; [PTE & at-least-one-writable(PTE, ca^-1)]) let PTE-update-needsBBM = ([PTEV]; ca \ (ca; [PTEV]; ca); [PTEV]) & (PTE-MT-update | PTE-SH-update | PTE-ICH-update | PTE-OCH-update | PTE-DT-update | PTE-OA-update) let TTDV = PTEV let TTDINV = PTEINV let TTD-update-needsBBM = PTE-update-needsBBM herd-herdtools7-1ca343e/herd/libdir/aarch64deps.cat000066400000000000000000000070701475314470400221320ustar00rootroot00000000000000(* * The Armv8 Application Level Memory Model. * * This is a machine-readable, executable and formal artefact, which aims to be * the latest stable version of the Armv8 memory model. * If you have comments on the content of this file, please send an email to * memory-model@arm.com * For a textual version of the model, see section B2.3 of the Armv8 ARM: * https://developer.arm.com/docs/ddi0487/ * * Authors: * Jade Alglave * Artem Khyzha * * Copyright (C) 2016-present, Arm Ltd. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 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. * * Neither the name of ARM nor the names of its contributors may be * used to endorse or promote products derived from this software * without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT * HOLDER 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. *) catdep (* This option tells that the cat file computes dependencies *) include "aarch64util.cat" (* Local write or MMU Fault successor *) let lwfs = [Exp & M | Imp & Tag & R]; (po & same-loc); [Exp & W] | [Exp & M]; (po & same-loc); [MMU & FAULT] | [Imp & TTD & R]; (po & same-loc); [Exp & W | HU] (* Local read successor *) let lrs = [W]; ((po & same-loc) & ~(intervening(W,(po & same-loc)))); [R] (* Dependency through registers and memory *) let rec dtrm = [~range(lxsx)]; rf-reg | lrs | iico_data | dtrm; dtrm (** Data, Address and Control dependencies *) let ADDR = Rreg \ DATA let basic-dep = [Exp & R | Rreg]; dtrm? let data = [Exp & R]; (basic-dep; [DATA]; iico_data+; [Exp & W]) & ~same-instance let addr = [Exp & R]; (basic-dep; [ADDR]; iico_data+; [Exp & M | Imp & Tag & R | Imp & TTD & R | HU | TLBI | DC.CVAU | IC.IVAU]) & ~same-instance let ctrl = [Exp & R]; basic-dep; [BCC]; po (** Pick dependencies *) let rec pick-dtrm = dtrm | iico_ctrl | pick-dtrm; pick-dtrm let pick-basic-dep = [Exp & R | Rreg]; pick-dtrm? let pick-addr-dep = [Exp & R]; (pick-basic-dep; [ADDR]; iico_data+; [Exp & M | Imp & Tag & R | Imp & TTD & R | HU | TLBI | DC.CVAU | IC.IVAU]) & ~same-instance let pick-data-dep = [Exp & R]; (pick-basic-dep; [DATA]; (iico_data|iico_ctrl)+; [Exp & W]) & ~same-instance let pick-ctrl-dep = [Exp & R]; pick-basic-dep; [BCC]; po let pick-dep = ( pick-basic-dep | pick-addr-dep | pick-data-dep | pick-ctrl-dep ) & ~same-instance include "aarch64show.cat" herd-herdtools7-1ca343e/herd/libdir/aarch64fences.cat000066400000000000000000000043021475314470400224350ustar00rootroot00000000000000AArch64Fences (* Protection against running tests of other architecture *) let DMB.ISH = try DMB.ISH with emptyset let DMB.ISHLD = try DMB.ISHLD with emptyset let DMB.ISHST = try DMB.ISHST with emptyset let DSB.ISH = try DSB.ISH with emptyset let DSB.ISHLD = try DSB.ISHLD with emptyset let DSB.ISHST = try DSB.ISHST with emptyset let DMB.SY = try DMB.SY with emptyset let DMB.ST = try DMB.ST with emptyset let DMB.LD = try DMB.LD with emptyset let DSB.SY = try DSB.SY with emptyset let DSB.ST = try DSB.ST with emptyset let DSB.LD = try DSB.LD with emptyset let DMB.OSH = try DMB.OSH with emptyset let DSB.OSH = try DSB.OSH with emptyset let DMB.OSHLD = try DMB.OSHLD with emptyset let DSB.OSHLD = try DSB.OSH with emptyset let DMB.OSHST = try DMB.OSHST with emptyset let DSB.OSHST = try DSB.OSHST with emptyset let ISB = try ISB with emptyset let A = try A & (Exp & M) with emptyset and L = try L & (Exp & M | FAULT) with emptyset and Q = try Q & (Exp & M) with emptyset and NoRet = try NoRet with emptyset (* Fences, for showing *) let dmb.ish = fencerel(DMB.ISH) let dmb.ishld = fencerel(DMB.ISHLD) let dmb.ishst = fencerel(DMB.ISHST) let dmb.fullsy = fencerel(DMB.SY) let dmb.fullst = fencerel(DMB.ST) let dmb.fullld = fencerel(DMB.LD) let dmb.sy = dmb.fullsy | dmb.ish let dmb.st = dmb.fullst | dmb.ishst let dmb.ld = dmb.fullld | dmb.ishld let dsb.sy = fencerel(DSB.SY) let dsb.st = fencerel(DSB.ST) let dsb.ld = fencerel(DSB.LD) let isb = fencerel(ISB) show dmb.sy,dmb.st,dmb.ld,dsb.sy,sb.st,dsb.ld,dmb,dsb (* * As a restriction of the model, all observers are limited to the same * inner-shareable domain. Consequently, the ISH, OSH and SY barrier * options are all equivalent to each other. *) let dsb.full = DSB.ISH | DSB.OSH | DSB.SY let dsb.ld = DSB.ISHLD | DSB.OSHLD | DSB.LD let dsb.st = DSB.ISHST | DSB.OSHST | DSB.ST let dmb.full = DMB.ISH | DMB.OSH | DMB.SY | dsb.full let dmb.ld = DMB.ISHLD | DMB.OSHLD | DMB.LD | dsb.ld let dmb.st = DMB.ISHST | DMB.OSHST | DMB.ST | dsb.st (* Flag any use of shareability options, due to the restrictions above. *) flag ~empty (dmb.full | dmb.ld | dmb.st) \ (DMB.SY | DMB.LD | DMB.ST | DSB.SY | DSB.LD | DSB.ST) as Assuming-common-inner-shareable-domain herd-herdtools7-1ca343e/herd/libdir/aarch64hwreqs.cat000066400000000000000000000140301475314470400225020ustar00rootroot00000000000000(* * The Armv8 Application Level Memory Model. * * This is a machine-readable, executable and formal artefact, which aims to be * the latest stable version of the Armv8 memory model. * If you have comments on the content of this file, please send an email to * memory-model@arm.com * For a textual version of the model, see section B2.3 of the Armv8 ARM: * https://developer.arm.com/documentation/ddi0487/ * * Authors: * Will Deacon * Jade Alglave * Nikos Nikoleris * Artem Khyzha * * Copyright (C) 2016-present, Arm Ltd. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 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. * * Neither the name of ARM nor the names of its contributors may be * used to endorse or promote products derived from this software * without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT * HOLDER 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. *) (* * Include aarch64deps.cat to define dependencies. *) include "aarch64deps.cat" (* Tag-Check-before *) (* Note: in asynchronous fault handling mode, instruction semantics for checked memory accesses does not feature the iico_ctrl edge to Exp & M *) let tc-before = [Imp & Tag & R]; iico_data; [B]; iico_ctrl; [Exp & M | TagCheck & FAULT] (* Tag-Check-intrinsically-before *) let tc-ib = tc-before; [~(Exp & R)] (* Fetch-intrinsically-before *) let f-ib = [Imp & Instr & R]; iico_data; [B]; (iico_ctrl | iico_ctrl; iico_data) (* DSB-ordered-before *) let DSB-ob = [M | DC.CVAU | IC]; po; [dsb.full]; po; [~(Imp & TTD & M | Imp & Instr & R)] | (if "ETS2" || "ETS3" then [M | DC.CVAU | IC]; po; [dsb.full]; po; [Imp & TTD & M] else 0) | [(Exp & R) \ NoRet | Imp & Tag & R]; po; [dsb.ld]; po; [~(Imp & TTD & M | Imp & Instr & R)] | (if "ETS2" || "ETS3" then [(Exp & R) \ NoRet]; po; [dsb.ld]; po; [Imp & TTD & M] else 0) | [Exp & W]; po; [dsb.st]; po; [~(Imp & TTD & M | Imp & Instr & R)] | (if "ETS2" || "ETS3" then [Exp & W]; po; [dsb.st]; po; [Imp & TTD & M] else 0) (* IFB-ordered-before *) let EXC-ENTRY-IFB = EXC-ENTRY let EXC-RET-IFB = if not "ExS" || "EOS" then EXC-RET else {} let IFB = ISB | EXC-ENTRY-IFB | EXC-RET-IFB let IFB-ob = [Exp & R]; ctrl; [IFB]; po | [Exp & R]; pick-ctrl-dep; [IFB]; po | [Exp & R]; addr; [Exp & M]; po; [IFB]; po | [Exp & R]; pick-addr-dep; [Exp & M]; po; [IFB]; po | [Exp & R]; pick-addr-dep; (tc-ib | tr-ib); [IFB]; po | DSB-ob; [IFB]; po | [Imp & TTD & R]; tr-ib; [IFB]; po | [Imp & Tag & R]; tc-ib; [IFB]; po | [Imp & TTD & R]; tr-ib; [Exp & M]; po; [IFB]; po | [Imp & Tag & R]; tc-before; [Exp & M]; po; [IFB]; po (* Dependency-ordered-before *) let dob = addr | data | ctrl; [Exp & W | HU | TLBI | DC.CVAU | IC] | addr; [Exp & M]; po; [Exp & W | HU] | addr; [Exp & M]; lrs; [Exp & R | Imp & Tag & R] | data; [Exp & M]; lrs; [Exp & R | Imp & Tag & R] | [Imp & TTD & R]; tr-ib; [Exp & M]; po; [Exp & W] | [Imp & Tag & R]; tc-before; [Exp & M]; po; [Exp & W] (* Fetch-ordered-before *) let f-ob = [Imp & Instr & R]; po; [~(Imp & Instr & R)] (* Pick-ordered-before *) let pob = pick-addr-dep; [Exp & W | HU | TLBI | DC.CVAU | IC] | pick-data-dep | pick-ctrl-dep; [Exp & W | HU | TLBI | DC.CVAU | IC] | pick-addr-dep; [Exp & M]; po; [Exp & W | HU] (* Atomic-ordered-before *) let aob = [Exp & M]; rmw; [Exp & M] | [Exp & M]; rmw; lrs; [A | Q] | [Imp & TTD & R]; rmw; [HU] (* Barrier-ordered-before *) let bob = [Exp & M | Imp & Tag & R]; po; [dmb.full]; po; [Exp & M | Imp & Tag & R | MMU & FAULT] | [Exp & M]; po; [dmb.full]; po; [DC.CVAU] | [DC.CVAU]; po; [dmb.full]; po; [Exp & M] | [DC.CVAU]; po; [dmb.full]; po; [DC.CVAU] | [Exp & (R \ NoRet) | Imp & Tag & R]; po; [dmb.ld]; po; [Exp & M | Imp & Tag & R | MMU & FAULT] | [Exp & W]; po; [dmb.st]; po; [Exp & W | MMU & FAULT] | [range([A];amo;[L])]; po; [Exp & M | Imp & Tag & R | MMU & FAULT] | [L]; po; [A] | [A | Q]; po; [Exp & M | Imp & Tag & R | MMU & FAULT] | [A | Q]; iico_order; [Exp & M | Imp & Tag & R | MMU & FAULT] | [Exp & M | Imp & Tag & R]; po; [L] | [Exp & M | Imp & Tag & R]; iico_order; [L] let po-scl-ob = [Exp & M]; (po & scl); [DC.CVAU] | [DC.CVAU]; (po & scl); [Exp & M] | [DC.CVAU]; (po & scl); [DC.CVAU] let TLBUncacheable = MMU & (Translation | AccessFlag) (* ETS-ordered-before *) let ets-ob = (if "ETS2" then [Exp & M]; po; [TLBUncacheable & FAULT]; tr-ib^-1; [Imp & TTD & R] else 0) | (if "ETS3" then [Exp & M]; po; [MMU & FAULT]; tr-ib^-1; [Imp & TTD & R] else 0) | (if "ETS3" then [Exp & M]; po; [TagCheck & EXC-ENTRY]; tc-ib^-1; [Imp & Tag & R] else 0) (* Locally-ordered-before *) let rec lob = tc-ib | tr-ib | f-ib | ets-ob | f-ob | po-scl-ob | DSB-ob | IFB-ob | lwfs | lwfs; sca-class | dob | pob | aob | bob | lob; lob let pick-lob = pick-dep; lob; [Exp & W] let rec local-hw-reqs = lob | pick-lob | local-hw-reqs; local-hw-reqs herd-herdtools7-1ca343e/herd/libdir/aarch64loc.cat000066400000000000000000000014741475314470400217560ustar00rootroot00000000000000(* Translation-intrinsically-before *) let tr-ib = [Imp & TTD & R]; iico_data; [B]; iico_ctrl; [Exp & M | MMU & FAULT] (* Notions of Same Location - PA, VA, and including Fault Effects *) let TTD-same-oa = same-oa(TTD*TTD) let same-loc = [M]; loc; [M] | [MMU & Translation & FAULT]; same-low-order-bits | same-low-order-bits; [MMU & Translation & FAULT] | (tr-ib^-1; TTD-same-oa; tr-ib) & same-low-order-bits let po-loc = po & same-loc (* Same-cache-line relation *) (* NOTE : currently assumes all locations are on different cache lines *) (* also extends to IC without a location specified *) let scl = loc | (M | DC.CVAU | IC) * (IC.IALLU | IC.IALLUIS) | (IC.IALLU | IC.IALLUIS) * (M | DC.CVAU | IC) let va-loc = (tr-ib; same-low-order-bits; tr-ib^-1) & loc let po-va-loc = po & va-loc herd-herdtools7-1ca343e/herd/libdir/aarch64memattrs.cat000066400000000000000000000152211475314470400230300ustar00rootroot00000000000000(* * The Armv8 Application Level Memory Model. * * This is a machine-readable, executable and formal artefact, which aims to be * the latest stable version of the Armv8 memory model. * If you have comments on the content of this file, please send an email to * memory-model@arm.com * For a textual version of the model, see section B2.3 of the Armv8 ARM: * https://developer.arm.com/documentation/ddi0487/ * * Authors: * Nikos Nikoleris * * Copyright (C) 2016-present, Arm Ltd. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 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. * * Neither the name of ARM nor the names of its contributors may be * used to endorse or promote products derived from this software * without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT * HOLDER 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. *) (*** Device Memory ***) (* Device Memory Types *) let PTEDevice-GRE = try PTEDevice-GRE with emptyset let PTEDevice-nGRE = try PTEDevice-nGRE with emptyset let PTEDevice-nGnRE = try PTEDevice-nGnRE with emptyset let PTEDevice-nGnRnE = try PTEDevice-nGnRnE with emptyset (* A PTE can only have one of the above Device memory types *) let DeviceMemoryType-conflict = (PTEDevice-GRE & PTEDevice-nGRE) | (PTEDevice-GRE & PTEDevice-nGnRE) | (PTEDevice-GRE & PTEDevice-nGnRnE) | (PTEDevice-nGRE & PTEDevice-nGnRE) | (PTEDevice-nGRE & PTEDevice-nGnRnE) | (PTEDevice-nGnRE & PTEDevice-nGnRnE) assert empty DeviceMemoryType-conflict as Invalid-Device-Memory-Type let PTEDevice = try PTEDevice with emptyset let PTEDevice = PTEDevice | PTEDevice-GRE | PTEDevice-nGRE | PTEDevice-nGnRE | PTEDevice-nGnRnE (*** Normal Memory ***) let PTENon-shareable = try PTENon-shareable with emptyset let PTEInner-shareable = try PTEInner-shareable with emptyset let PTEOuter-shareable = try PTEOuter-shareable with emptyset (* Memory cannot have more than one Shareability Attribute *) let Shareability-conflict = (PTENon-shareable & PTEInner-shareable) | (PTEInner-shareable & PTEOuter-shareable) | (PTENon-shareable & PTEOuter-shareable) assert empty Shareability-conflict as Invalid-Shareability let PTEInner-write-back = try PTEInner-write-back with emptyset let PTEInner-write-through = try PTEInner-write-through with emptyset let PTEInner-non-cacheable = try PTEInner-non-cacheable with emptyset (* Memory cannot have more than one Inner Cacheability Attribute *) let InnerCacheability-conflict = (PTEInner-write-back & PTEInner-write-through) | (PTEInner-write-through & PTEInner-non-cacheable) | (PTEInner-non-cacheable & PTEInner-write-back) assert empty InnerCacheability-conflict as Invalid-Inner-Cacheability let PTEOuter-write-back = try PTEOuter-write-back with emptyset let PTEOuter-write-through = try PTEOuter-write-through with emptyset let PTEOuter-non-cacheable = try PTEOuter-non-cacheable with emptyset (* Memory cannot have more than one Outer Cacheability Attribute *) let OuterCacheability-conflict = (PTEOuter-write-back & PTEOuter-write-through) | (PTEOuter-write-through & PTEOuter-non-cacheable) | (PTEOuter-non-cacheable & PTEOuter-write-back) assert empty OuterCacheability-conflict as Invalid-Outer-Cacheability let PTENormal = try PTENormal with emptyset let PTETaggedNormal = try PTETaggedNormal with emptyset (*** Common attributes ***) let PTEXS = try PTEXS with emptyset (*** Sanity checks ***) (* Memory cannot be of type Normal and Device at the same time *) let MemoryType-conflict = PTENormal & PTEDevice assert empty MemoryType-conflict as Invalid-Memory-Type (* No other memory attribute is allowed *) let PTEMemAttr = try PTEMemAttr with emptyset let PTEAll-Valid-Mem-Attr = PTENormal | PTETaggedNormal | PTENon-shareable | PTEInner-shareable | PTEOuter-shareable | PTEInner-write-back | PTEInner-write-through | PTEInner-non-cacheable | PTEOuter-write-back | PTEOuter-write-through | PTEOuter-non-cacheable | PTEDevice | PTEDevice-GRE | PTEDevice-nGRE | PTEDevice-nGnRE | PTEDevice-nGnRnE | PTEXS let Invalid-Memory-Attr = PTEMemAttr \ (PTEAll-Valid-Mem-Attr) assert empty Invalid-Memory-Attr as Invalid-Memory-Attribute (* Default Shareability *) let PTEInner-shareable = PTEInner-shareable | (PTE \ (PTEDevice | PTENon-shareable | PTEOuter-shareable)) (* Default Inner Cacheability *) let PTEInner-write-back = PTEInner-write-back | (PTE \ (PTEDevice | PTEInner-write-through | PTEInner-non-cacheable)) (* Default Outer Cacheability *) let PTEOuter-write-back = PTEOuter-write-back | (PTE \ (PTEDevice | PTEOuter-write-through | PTEOuter-non-cacheable)) let ISH-WB = PTEInner-shareable & PTEInner-write-back & PTEOuter-write-back (* Default Memory Type *) let PTETaggedNormal = PTETaggedNormal | (if "memtag" then ISH-WB else 0) let PTENormal = PTENormal | PTENon-shareable | PTEInner-shareable | PTEOuter-shareable | PTEInner-write-back | PTEInner-write-through | PTEInner-non-cacheable | PTEOuter-write-back | PTEOuter-write-through | PTEOuter-non-cacheable let PTENormal = if "memtag" then PTENormal \ ISH-WB else PTENormal herd-herdtools7-1ca343e/herd/libdir/aarch64show.cat000066400000000000000000000005241475314470400221540ustar00rootroot00000000000000(* Show dependencies *) show data,addr let ctrlisb = try ctrl;[ISB];po with 0 show ctrlisb show isb \ ctrlisb as isb show ctrl \ ctrlisb as ctrl (* Show same-tag-loc without id edges *) show same-tag-loc\id as same-tag-loc (* Communication relations *) let rf-mem = rf \ rf-reg show rf-reg show rf-mem as rf unshow fr,co show co|fr as ca herd-herdtools7-1ca343e/herd/libdir/aarch64util.cat000066400000000000000000000116071475314470400221550ustar00rootroot00000000000000(* * The Armv8 Application Level Memory Model. * * This is a machine-readable, executable and formal artefact, which aims to be * the latest stable version of the Armv8 memory model. * If you have comments on the content of this file, please send an email to * memory-model@arm.com * For a textual version of the model, see section B2.3 of the Armv8 ARM: * https://developer.arm.com/documentation/ddi0487/ * * Authors: * Will Deacon * Jade Alglave * Nikos Nikoleris * Artem Khyzha * * Copyright (C) 2016-present, Arm Ltd. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 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. * * Neither the name of ARM nor the names of its contributors may be * used to endorse or promote products derived from this software * without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT * HOLDER 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. *) (* * Include default definitions for sets that are undefined without * -variant vmsa *) let PTE = if "vmsa" then PTE else emptyset let PTEV = if "vmsa" then PTEV else emptyset let PTEINV = if "vmsa" then PTEINV else emptyset let inv-domain = if "vmsa" then inv-domain else 0 let AF = if "vmsa" then AF else emptyset let DB = if "vmsa" then DB else emptyset let MMU = if "vmsa" then MMU else emptyset let Translation = if "vmsa" then Translation else emptyset let AccessFlag = if "vmsa" then AccessFlag else emptyset (* * Include default definitions for sets that might be undefined without * -variant ifetch *) let Instr = if "ifetch" then Instr else emptyset let Within-CMODX-List = if "ifetch" then Restricted-CMODX else emptyset (* * Include the cos.cat file shipped with herd. * This builds the co relation as a total order over writes to the same * location and then consequently defines the fr relation using co and * rf. *) let AFtoDB = same-instance & ((AF\DB) * (DB\AF)) let co0=co0 | AFtoDB include "cos.cat" (* * A shorthand for cache maintenance effects used by -variant ifetch *) let IC = IC.IALLUIS | IC.IALLU | IC.IVAU (* Renaming default herd names *) let Imp = NExp let SPONTANEOUS = SPURIOUS let inv-scope = inv-domain let TTD = PTE let Tag = T (* HW TTD Updates permitted only for the AF or DB *) let HU = Imp & TTD & W assert empty HU \ (AF | DB) (* * Include aarch64fences.cat to define barriers. *) include "aarch64fences.cat" (* * Include aarch64bbm.cat to define relations on Break-Before-Make semantics. *) include "aarch64bbm.cat" (* Show relations in generated diagrams *) include "aarch64show.cat" (* Helper functions *) procedure included(r1, r2) = empty r1 \ r2 end procedure equal(r1, r2) = call included(r1, r2) call included(r2, r1) end (* Intervening Effect *) let intervening(S,r) = r; [S]; r (* Properties of single-copy atomic accesses *) let sca-class = [M & Exp]; sm; [M & Exp] (* Flag any occurrence of writes to two different locations that might be on * the same cache line. *) flag ~empty ((W & Instr)*(W & Instr) \ loc) as Assuming-no-two-modified-instructions-are-on-the-same-cache-line (* Flag the runs of herd7 with unsupported combinations of variants *) flag ~empty (if "vmsa" && "memtag" then _ else 0) as combining-vmsa-and-memtag-is-not-supported flag ~empty (if "vmsa" && "ifetch" then _ else 0) as combining-vmsa-and-ifetch-is-not-supported flag ~empty (if "memtag" && "ifetch" then _ else 0) as combining-memtag-and-ifetch-is-not-supported (* Flag the runs of herd7 with work-in-progress features *) flag ~empty (if "sve" then _ else 0) as Scalable-Vector-Extensions-is-work-in-progress flag ~empty (if "sme" then _ else 0) as Scalable-Matrix-Extensions-is-work-in-progress include "aarch64loc.cat" herd-herdtools7-1ca343e/herd/libdir/all.cfg000066400000000000000000000004061475314470400205620ustar00rootroot00000000000000graph cluster squished true showevents all movelabel true fontsize 8 xscale 2.0 yscale 1.5 arrowsize 0.8 splines spline pad 0.1 doshow data doshow addr doshow dd edgeattr dd,color,indigo edgeattr hb,color,indigo edgeattr co,color,blue withbox true labelbox true herd-herdtools7-1ca343e/herd/libdir/apoil.cfg000066400000000000000000000002411475314470400211130ustar00rootroot00000000000000#Main graph mode graph free #Show memory events only showevents memory #Minimal information in nodes squished true #Do not show a legend at all showlegend false herd-herdtools7-1ca343e/herd/libdir/arm-alt.cat000066400000000000000000000013631475314470400213620ustar00rootroot00000000000000ARM (* Alternative model for ARM, ie with MR(po-loc) omitted from ppo *) include "cos.cat" (* Uniproc *) acyclic po-loc | rf | fr | co as uniproc (* Atomic *) empty rmw & (fre;coe) as atomic (* Utilities *) let dd = addr | data let rdw = po-loc & (fre;rfe) let detour = po-loc & (coe ; rfe) let addrpo = addr;po (*******) (* ppo *) (*******) include "armfences.cat" (* Initial value *) let ci0 = ctrlisb | detour let ii0 = dd | rfi | rdw let cc0 = dd | ctrl | addrpo | (M*W) & po-loc let ic0 = 0 include "ppo.cat" (**********) (* fences *) (**********) (* ARM *) let WW = W * W let dmb.st=dmb.st & WW let dsb.st=dsb.st & WW (* Common, all arm barriers are strong *) let strong = dmb|dsb|dmb.st|dsb.st let light = 0 include "ppc-checks.cat" herd-herdtools7-1ca343e/herd/libdir/arm-models/000077500000000000000000000000001475314470400213715ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/libdir/arm-models/mixed/000077500000000000000000000000001475314470400224775ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/libdir/arm-models/mixed/armv8-common.cat000066400000000000000000000050331475314470400255140ustar00rootroot00000000000000(* * The ARMv8 Application Level Memory Model. * * See section B2.3 of the ARMv8 ARM: * https://developer.arm.com/docs/ddi0487/latest/arm-architecture-reference-manual-armv8-for-armv8-a-architecture-profile * * Author: Will Deacon * Author: Jade Alglave * * Copyright (C) 2016-2019, ARM Ltd. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 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. * * Neither the name of ARM nor the names of its contributors may be * used to endorse or promote products derived from this software * without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT * HOLDER 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. *) include "aarch64hwreqs.cat" (*** Internal visibility requirements ***) irreflexive [Exp & R]; (po-loc | rmw); [Exp & W]; rfi; [Exp & R] as coRW1-Exp irreflexive [Imp & Tag & R]; po-loc; [Exp & Tag & W]; rfi; [Imp & Tag & R] as coRW1-MTE irreflexive [Exp & W]; po-loc; [Exp & W]; (ca & int); [Exp & W] as coWW-Exp irreflexive [Exp & W]; po-loc; [Exp & R]; (ca & int); [Exp & W] as coWR-Exp irreflexive [Exp & Tag & W]; po-loc; [Imp & Tag & R]; (ca & int) as coWR-MTE (*** Atomic: LDXR/STXR, AMO and HU constraint to forbid intervening writes. ***) empty (rmw & (fr; co)) \ (([Exp]; rmw; [Exp]) & (fri ; [Exp & W]; coi)) as atomic let IM0 = ((IW * (M\IW)) | loc & ((W\FW) * FW)) herd-herdtools7-1ca343e/herd/libdir/arm-models/mixed/ec.cat000066400000000000000000000057671475314470400235760ustar00rootroot00000000000000(* * The ARMv8 Application Level Memory Model. * * See section B2.3 of the ARMv8 ARM: * https://developer.arm.com/docs/ddi0487/latest/arm-architecture-reference-manual-armv8-for-armv8-a-architecture-profile * * Author: Jade Alglave * * Copyright (C) 2018-2020, ARM Ltd. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 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. * * Neither the name of ARM nor the names of its contributors may be * used to endorse or promote products derived from this software * without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT * HOLDER 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. *) "Armv8 External completion requirement, with mixed-size" catdep include "armv8-common.cat" include "sca.cat" let preorder-cb = IM0 | local-hw-reqs | scaob let preorder-cb-lift = lift(MC,preorder-cb) with cb from linearisations(MC,preorder-cb-lift) ~empty cb let dcb = delift(cb) let dcbl = dcb & same-loc let rf-fwd = (W*(Exp&R)) & lrs & dcbl^-1 & ~(intervening(W,dcbl); [Exp & R]; po-loc) (* exclude the cases of load hazards *) let rf-nfwd = (W*(Exp&R)) & dcbl & ~(dcbl; [W]; lrs) (* exclude Write Effects outdated by the local predecessor, see rf-fwd *) & ~intervening(W,dcbl) (* exclude Write Effects that are not the most recent in Completed-before *) & ~(intervening(W,dcbl); [Exp & R]; po-loc) (* exclude the cases of load hazards *) let rf-cb = rf-fwd | rf-nfwd let co-cb = dcbl & (W*W) call equal(rf, rf-cb) as rfeq call equal(co, co-cb) as cbeq flag ~empty (if "vmsa" then _ else 0) as external-completion-requirement-does-not-support-variant-vmsa flag ~empty (if "ifetch" then _ else 0) as external-completion-requirement-does-not-support-variant-ifetch flag ~empty (if "memtag" then _ else 0) as external-completion-requirement-does-not-support-variant-memtagherd-herdtools7-1ca343e/herd/libdir/arm-models/mixed/egc.cat000066400000000000000000000053721475314470400237350ustar00rootroot00000000000000(* * The ARMv8 Application Level Memory Model. * * See section B2.3 of the ARMv8 ARM: * https://developer.arm.com/docs/ddi0487/latest/arm-architecture-reference-manual-armv8-for-armv8-a-architecture-profile * * Author: Jade Alglave * * Copyright (C) 2018-2020, ARM Ltd. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 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. * * Neither the name of ARM nor the names of its contributors may be * used to endorse or promote products derived from this software * without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT * HOLDER 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. *) "Armv8 External global completion requirement, with mixed-size" catdep include "armv8-common.cat" include "sca.cat" let gc-req = (W * _) | (R * _) & ((range(rfe) * _) | (rfi^-1; local-hw-reqs)) let preorder-gcb = IM0 | local-hw-reqs & gc-req | scaob let preorder-gcb-lift = lift(MC,preorder-gcb) with gcb from linearisations(MC, preorder-gcb-lift) ~empty gcb let dgcb = delift(gcb) let dgcbl = dgcb & same-loc let rf-gcb = (W * (Exp & R)) & dgcbl & ~intervening(W,dgcbl) & ~(intervening(W,dgcbl);[Exp & R]; po-loc) let co-gcb = (W * W) & dgcbl call equal(rf, rf-gcb) call equal(co, co-gcb) flag ~empty (if "vmsa" then _ else 0) as external-global-completion-requirement-does-not-support-variant-vmsa flag ~empty (if "ifetch" then _ else 0) as external-global-completion-requirement-does-not-support-variant-ifetch flag ~empty (if "memtag" then _ else 0) as external-global-completion-requirement-does-not-support-variant-memtagherd-herdtools7-1ca343e/herd/libdir/arm-models/mixed/ev.cat000066400000000000000000000040301475314470400235770ustar00rootroot00000000000000(* * The ARMv8 Application Level Memory Model. * * See section B2.3 of the ARMv8 ARM: * https://developer.arm.com/docs/ddi0487/latest/arm-architecture-reference-manual-armv8-for-armv8-a-architecture-profile * * Author: Jade Alglave * * Copyright (C) 2018-2020, ARM Ltd. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 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. * * Neither the name of ARM nor the names of its contributors may be * used to endorse or promote products derived from this software * without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT * HOLDER 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. *) "Armv8 External Visibility requirement, with mixed size" include "armv8-common.cat" (* Ordered-before *) let rec ob = obs; si | lob | ob; ob (* External visibility requirement *) irreflexive ob as external herd-herdtools7-1ca343e/herd/libdir/arm-models/mixed/sca.cat000066400000000000000000000040721475314470400237410ustar00rootroot00000000000000(* * The ARMv8 Application Level Memory Model. * * See section B2.3 of the ARMv8 ARM: * https://developer.arm.com/docs/ddi0487/latest/arm-architecture-reference-manual-armv8-for-armv8-a-architecture-profile * * Author: Jade Alglave * * Copyright (C) 2018-2020, ARM Ltd. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 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. * * Neither the name of ARM nor the names of its contributors may be * used to endorse or promote products derived from this software * without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT * HOLDER 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. *) "Armv8 Single-copy-atomic-ordered-before" let ER = range(rfe) let IR = range(rfi) let rfisw = rfi^-1;si;rfi let erln = (si & (W*W) | si & (ER * ER) | si & (R*R) & rfisw)+ let MC = classes(erln) let scaob = si & (ER*IR) herd-herdtools7-1ca343e/herd/libdir/arm-models/non-mixed/000077500000000000000000000000001475314470400232675ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/libdir/arm-models/non-mixed/armv8-common.cat000066400000000000000000000050331475314470400263040ustar00rootroot00000000000000(* * The ARMv8 Application Level Memory Model. * * See section B2.3 of the ARMv8 ARM: * https://developer.arm.com/docs/ddi0487/latest/arm-architecture-reference-manual-armv8-for-armv8-a-architecture-profile * * Author: Will Deacon * Author: Jade Alglave * * Copyright (C) 2016-2020, ARM Ltd. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 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. * * Neither the name of ARM nor the names of its contributors may be * used to endorse or promote products derived from this software * without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT * HOLDER 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. *) include "aarch64hwreqs.cat" (*** Internal visibility requirements ***) irreflexive [Exp & R]; (po-loc | rmw); [Exp & W]; rfi; [Exp & R] as coRW1-Exp irreflexive [Imp & Tag & R]; po-loc; [Exp & Tag & W]; rfi; [Imp & Tag & R] as coRW1-MTE irreflexive [Exp & W]; po-loc; [Exp & W]; (ca & int); [Exp & W] as coWW-Exp irreflexive [Exp & W]; po-loc; [Exp & R]; (ca & int); [Exp & W] as coWR-Exp irreflexive [Exp & Tag & W]; po-loc; [Imp & Tag & R]; (ca & int) as coWR-MTE (*** Atomic: LDXR/STXR, AMO and HU constraint to forbid intervening writes. ***) empty (rmw & (fr; co)) \ (([Exp]; rmw; [Exp]) & (fri ; [Exp & W]; coi)) as atomic let IM0 = ((IW * (M\IW)) | loc & ((W\FW) * FW)) herd-herdtools7-1ca343e/herd/libdir/arm-models/non-mixed/ec.cat000066400000000000000000000055151475314470400243550ustar00rootroot00000000000000(* * The ARMv8 Application Level Memory Model. * * See section B2.3 of the ARMv8 ARM: * https://developer.arm.com/docs/ddi0487/latest/arm-architecture-reference-manual-armv8-for-armv8-a-architecture-profile * * Author: Will Deacon * Author: Jade Alglave * * Copyright (C) 2016-2020, ARM Ltd. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 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. * * Neither the name of ARM nor the names of its contributors may be * used to endorse or promote products derived from this software * without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT * HOLDER 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. *) "Armv8 External completion requirement, not mixed-size" catdep include "armv8-common.cat" let preorder-cb = IM0 | local-hw-reqs with cb from linearisations(M,preorder-cb) ~empty cb let cbl = cb & same-loc let rf-fwd = (W*(Exp&R)) & lrs & cbl^-1 & ~(intervening(W,cbl); [Exp & R]; po-loc) (* exclude the cases of load hazards *) let rf-nfwd = (W*(Exp&R)) & cbl & ~(cbl; [W]; lrs) (* exclude Write Effects outdated by the local predecessor, see rf-fwd *) & ~intervening(W,cbl) (* exclude Write Effects that are not the most recent in Completed-before *) & ~(intervening(W,cbl); [Exp & R]; po-loc) (* exclude the cases of load hazards *) let rf-cb = rf-fwd | rf-nfwd let co-cb = cbl & (W*W) call equal(rf, rf-cb) as rfeq call equal(co, co-cb) as cbeq flag ~empty (if "vmsa" then _ else 0) as external-completion-requirement-does-not-support-variant-vmsa flag ~empty (if "ifetch" then _ else 0) as external-completion-requirement-does-not-support-variant-ifetch herd-herdtools7-1ca343e/herd/libdir/arm-models/non-mixed/egc.cat000066400000000000000000000053501475314470400245210ustar00rootroot00000000000000(* * The ARMv8 Application Level Memory Model. * * See section B2.3 of the ARMv8 ARM: * https://developer.arm.com/docs/ddi0487/latest/arm-architecture-reference-manual-armv8-for-armv8-a-architecture-profile * * Author: Will Deacon * Author: Jade Alglave * * Copyright (C) 2016-2020, ARM Ltd. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 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. * * Neither the name of ARM nor the names of its contributors may be * used to endorse or promote products derived from this software * without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT * HOLDER 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. *) "Armv8 External global completion requirement, not mixed-size" catdep include "armv8-common.cat" let gc-req = (W * _) | (R * _) & ((range(rfe) * _) | (rfi^-1; local-hw-reqs)) let preorder-gcb = IM0 | local-hw-reqs & gc-req let preorder-gcb-lift = lift(M,preorder-gcb) with gcb from linearisations(M, preorder-gcb) ~empty gcb let gcbl = gcb & same-loc let rf-gcb = (W * (Exp & R)) & gcbl & ~intervening(W,gcbl) & ~(intervening(W,gcbl);[Exp & R]; po-loc) let co-gcb = (W * W) & gcbl call equal(rf, rf-gcb) call equal(co, co-gcb) flag ~empty (if "vmsa" then _ else 0) as external-global-completion-requirement-does-not-support-variant-vmsa flag ~empty (if "ifetch" then _ else 0) as external-global-completion-requirement-does-not-support-variant-ifetch flag ~empty (if "memtag" then _ else 0) as external-global-completion-requirement-does-not-support-variant-memtag herd-herdtools7-1ca343e/herd/libdir/arm-models/non-mixed/ev.cat000066400000000000000000000041001475314470400243650ustar00rootroot00000000000000(* * The ARMv8 Application Level Memory Model. * * See section B2.3 of the ARMv8 ARM: * https://developer.arm.com/docs/ddi0487/latest/arm-architecture-reference-manual-armv8-for-armv8-a-architecture-profile * * Author: Will Deacon * Author: Jade Alglave * * Copyright (C) 2016-2020, ARM Ltd. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 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. * * Neither the name of ARM nor the names of its contributors may be * used to endorse or promote products derived from this software * without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT * HOLDER 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. *) "Armv8 External Visibility requirement, not mixed size" include "armv8-common.cat" (* Ordered-before *) let rec ob = obs | lob | ob; ob (* External visibility requirement *) irreflexive ob as external herd-herdtools7-1ca343e/herd/libdir/arm-models/proofs/000077500000000000000000000000001475314470400227015ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/libdir/arm-models/proofs/mixed_v8_equivalences.v000066400000000000000000007235361475314470400273770ustar00rootroot00000000000000(* * The Armv8 Application Level Memory Model. * * This is a machine-readable, executable and formal artefact, which aims to be * an equivalence proof between the three formulations of the * latest stable version of the Armv8 memory model. * If you have comments on the content of this file, please send an email to * memory-model@arm.com, referring to version number: * 814a6fc1610ec1a24f2cbd178e171966375626ac * For a textual version of the model, see section B2.3 of the Armv8 ARM: * https://developer.arm.com/docs/ddi0487/latest/arm-architecture-reference-manual-armv8-for-armv8-a-architecture-profile * * Author: Jade Alglave * * Copyright (C) 2016-2021, Arm Ltd. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 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. * * Neither the name of ARM nor the names of its contributors may be * used to endorse or promote products derived from this software * without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT * HOLDER 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. *) Require Import ZArith. Require Import Ensembles. Require Import Classical_Prop. Hypothesis excluded_middle : forall A, A \/ ~A. Set Implicit Arguments. Ltac decide_equality := decide equality; auto with equality arith. (* Some facts about natural numbers *) Lemma nat_eq_or_not_eq : forall (n1 n2 : nat), n1 = n2 \/ n1 <> n2. Proof. intros n1 n2. rewrite <- eq_nat_is_eq. destruct (eq_nat_decide n1 n2); auto. Qed. Lemma nat_neq_implies_lt : forall (n1 n2 : nat), n1 <> n2 -> (n1 < n2 \/ n2 < n1). Proof. intros n1 n2 Hneq. generalize (nat_total_order n1 n2). intro Htot. apply Htot. auto. Qed. (** * Events **) (** ** Events: Definitions *) Definition Acquire := Set. Definition Release := Set. Definition RMW := Set. Definition Read := Set. Hypothesis read_eq_or_not_eq : forall (r1 r2 : Read), r1 = r2 \/ r1 <> r2. Definition Write := Set. Hypothesis write_eq_or_not_eq : forall (w1 w2 : Write), w1 = w2 \/ w1 <> w2. Definition Fence := Set. Hypothesis fence_eq_or_not_eq : forall (f1 f2 : Fence), f1 = f2 \/ f1 <> f2. Inductive Effect := | read : Read -> Effect | write : Write -> Effect | fence : Fence -> Effect. Lemma eff_eq_or_not_eq : forall (eff1 eff2 : Effect), eff1 = eff2 \/ eff1 <> eff2. Proof. intros eff1 eff2; case_eq eff1. (*eff1 is a read*) intros r1 Hr1; case_eq eff2; intros r2 Hr2. (*eff2 is a read*) generalize (read_eq_or_not_eq r1 r2); intros [Heq12 | Hneq12]. rewrite Heq12; auto. right; intro Heq; inversion Heq; apply Hneq12; auto. (*eff2 is a write*) right; intro Heq; inversion Heq. (*eff2 is a fence*) right; intro Heq; inversion Heq. (*eff1 is a write*) intros w1 Hr1; case_eq eff2; intros w2 Hr2. (*eff2 is a read*) right; intro Heq; inversion Heq. (*eff2 is a write*) generalize (write_eq_or_not_eq w1 w2); intros [Heq12 | Hneq12]. rewrite Heq12; auto. right; intro Heq; inversion Heq; apply Hneq12; auto. (*eff2 is a fence*) right; intro Heq; inversion Heq. (*eff1 is a fence*) intros f1 Hf1; case_eq eff2; intros f2 Hf2. (*eff2 is a read*) right; intro Heq; inversion Heq. (*eff2 is a write*) right; intro Heq; inversion Heq. (*eff2 is a fence*) generalize (fence_eq_or_not_eq f1 f2); intros [Heq12 | Hneq12]. rewrite Heq12; auto. right; intro Heq; inversion Heq; apply Hneq12; auto. Qed. Definition Id := nat. Definition Location := nat. Definition Value := nat. Record Event := mkev { id : Id; (* Unique identifier, consistent with program order for a given thread *) tid : Id; (* Thread identifier *) effect : Effect; (* Effect type (read, write, etc) *) loc : Location; (* Location accessed by the effect *) val : Value (* Value read or written by the effect *) }. Definition is_write e : Prop := match effect e with | write _ => True | _ => False end. Definition is_read e : Prop := match effect e with | read _ => True | _ => False end. Hypothesis event_id_uniq : forall e1 e2, e1 <> e2 -> id e1 <> id e2. (** ** Events: Lemmas *) Lemma event_eq_or_not_eq : forall (e1 e2 : Event), e1 = e2 \/ e1 <> e2. Proof. intros [id1 tid1 eff1 l1 v1] [id2 tid2 eff2 l2 v2]. generalize (nat_eq_or_not_eq id1 id2); intro Horid. generalize (nat_eq_or_not_eq tid1 tid2); intro Hortid. generalize (nat_eq_or_not_eq l1 l2); intro Horloc. generalize (nat_eq_or_not_eq v1 v2); intro Horval. generalize (eff_eq_or_not_eq eff1 eff2); intro Horeff. inversion Horid as [Heqid | Hneqid]; clear Horid. inversion Hortid as [Heqtid | Hneqtid]; clear Hortid. inversion Horloc as [Heqloc | Hneqloc]; clear Horloc. inversion Horval as [Heqval | Hneqval]; clear Horval. inversion Horeff as [Heqeff | Hneqeff]; clear Horeff. left. rewrite Heqid; rewrite Heqtid; rewrite Heqeff; rewrite Heqloc; rewrite Heqval; auto. right. intro Heq; injection Heq as _ _ Heff _ _; apply Hneqeff; auto. right. intro Heq; injection Heq as _ _ _ _ Hval; apply Hneqval; auto. right. intro Heq; injection Heq as _ _ _ Hloc _; apply Hneqloc; auto. right. intro Heq; injection Heq as _ Htid _ _ _; apply Hneqtid; auto. right. intro Heq; injection Heq as Hid _ _ _ _; apply Hneqid; auto. Qed. (** * Sets and relations ****) (** ** Sets and relations: Definitions *) Definition set := Ensemble. Definition Rln (A:Type) := A -> A -> Prop. Definition dom (A:Type) (r:Rln A) : set A := fun x => exists y, r x y. Definition ran (A:Type) (r:Rln A) : set A := fun y => exists x, r x y. Inductive transitive_closure (r : Rln Event) (e1 e2 : Event) : Prop := | _base : r e1 e2 -> transitive_closure r e1 e2 | _trans : forall e, r e1 e -> transitive_closure r e e2 -> transitive_closure r e1 e2. Definition irreflexive (r : Rln Event) : Prop := ~(exists x, r x x). Definition acyclic (r : Rln Event) : Prop := irreflexive (transitive_closure r). Definition rel_incl (A:Type) (r1 r2 : Rln A) : Prop := forall x y, r1 x y -> r2 x y. Definition rel_equal (r1 r2 : Rln Event) : Prop := rel_incl r1 r2 /\ rel_incl r2 r1. Definition rel_seq (r1 r2 : Rln Event) : Rln Event := fun e1 e2 => exists e, r1 e1 e /\ r2 e e2. Definition rel_union (r1 r2 : Rln Event) : Rln Event := fun e1 e2 => r1 e1 e2 \/ r2 e1 e2. Definition maybe r : Rln Event := fun e1 e2 => e1 = e2 \/ r e1 e2. Definition transitive (A:Type) (r:Rln A) : Prop := (forall x1 x2 x3, (r x1 x2) -> (r x2 x3) -> (r x1 x3)). Axiom Extensionality_Rlns : forall R1 R2:Rln Event, rel_incl R1 R2 /\ rel_incl R2 R1 -> R1 = R2. Definition Class (A:Type) := set A. Definition class_of (A:Type) (r : Rln A) e := fun e' => r e e'. Definition classes (A:Type) (r:Rln A) : set (Class A) := fun c => exists x, c = class_of r x. Definition lift (A:Type) (C:set (Class A)) (r:Rln A) : Rln (Class A) := fun c1 => fun c2 => C c1 /\ C c2 /\ exists e1, exists e2, c1 e1 /\ c2 e2 /\ r e1 e2. Definition delift (A:Type) (C : set (Class A)) (rC : Rln (Class A)) : Rln A := fun e1 => fun e2 => forall c1 c2, C c1 -> C c2 -> c1 e1 -> c2 e2 -> rC c1 c2. (** ** Sets and relations: Lemmas *) Lemma tc_trans r e1 e2 e3 : transitive_closure r e1 e2 -> transitive_closure r e2 e3 -> transitive_closure r e1 e3. Proof. intros H12 H23; induction H12. apply _trans with e2; auto. apply _trans with e; auto. Qed. Lemma seq_tc_reorg (r1 r2 : Rln Event) x y : rel_seq r1 (rel_seq r2 r1) x y -> rel_seq (transitive_closure (rel_seq r1 r2)) r1 x y. Proof. intros [e1 [Hx1 [e2 [H12 H2y]]]]; exists e2; split; auto; apply _base; exists e1; split; auto. Qed. Lemma tc_seq_inv (r1 r2: Rln Event) x z : transitive_closure (rel_seq (maybe r1) r2) x z -> exists y1, exists y2, (maybe r1) x y1 /\ transitive_closure (rel_seq r2 (maybe r1)) y1 y2 /\ (maybe r2) y2 z. Proof. intro Hxz; induction Hxz. Focus 2. destruct H as [y1 [H1y1 Hy1e]]; destruct IHHxz as [e' [y2 [Hee' [He'y2 Hy22]]]]. exists y1; exists y2; split; auto; split; auto. apply _trans with e'; auto; exists e; split; auto. destruct H as [y1 [H1y1 Hy12]]; exists y1; exists e2; split; auto; split; [apply _base; exists e2; split; auto; left|left]; auto. Qed. Lemma tc_seq_left (r1 r2 : Rln Event) x y z : transitive r1 -> r1 x y -> transitive_closure (rel_seq r1 r2) y z -> transitive_closure (rel_seq r1 r2) x z. Proof. intros Htr1 Hxy Hyz; induction Hyz. Focus 2. apply _trans with e; auto. destruct H as [e' [H1' H'e]]; exists e'; split; auto; apply Htr1 with e1; auto. apply _base; destruct H as [e' [H1' H'2]]; exists e'; split; auto; apply Htr1 with e1; auto. Qed. Lemma tc_seq_right (r1 r2 : Rln Event) x y z : transitive r2 -> transitive_closure (rel_seq r1 r2) x y -> r2 y z -> transitive_closure (rel_seq r1 r2) x z. Proof. intros Htr2 Hxy Hyz; induction Hxy. Focus 2. apply _trans with e; auto. apply _base; destruct H as [x [H1x Hx2]]; exists x; split; auto; apply Htr2 with e2; auto. Qed. Lemma seq_tc_reorg2 (r1 r2 : Rln Event) x y z : transitive r1 -> rel_seq r1 (rel_seq r2 r1) x y -> rel_seq (transitive_closure (rel_seq r1 r2)) r1 y z -> rel_seq (transitive_closure (rel_seq r1 r2)) r1 x z. Proof. intros Htr1 [e1 [Hx1 [e2 [H12 H2y]]]]; intros [e3 [Hy3 H3z]]; exists e3; split; auto; apply tc_trans with e2; auto. apply _base; exists e1; auto. apply tc_seq_left with y; auto. Qed. Lemma tc_seq_incl (r r1 r2 : Rln Event) x y : rel_incl r1 r2 -> rel_seq (transitive_closure r1) r x y -> rel_seq (transitive_closure r2) r x y. Proof. intros Hincl [e [Hxe Hey]]; exists e; split; auto; clear Hey; induction Hxe. apply _base; apply Hincl; auto. apply _trans with e; auto. Qed. Lemma tc_seq_reorg (r1 r2 : Rln Event) x y z : transitive r1 -> transitive_closure (rel_seq r1 (rel_seq r2 r1)) x y -> r1 y z -> transitive_closure (rel_seq r1 (rel_seq r2 r1)) x z. Proof. intros Htr1 Hxy Hyz; induction Hxy. destruct H as [e [H1e He2]]; apply _base; exists e; split; auto. destruct He2 as [e' [Hee' He'2]]; exists e'; split; auto; apply Htr1 with e2; auto. apply _trans with e; auto. Qed. Lemma r_in_evts_implies_tc_in_evts (E : set Event) (r : Rln Event) : Included _ (Union _ (dom r) (ran r)) E -> Included _ (Union _ (dom (transitive_closure r)) (ran (transitive_closure r))) E. Proof. intros Hincl _x [x Hdom | y Hran]. inversion Hdom as [y Htc]; induction Htc. apply Hincl; left; exists e2; auto. apply Hincl; left; exists e; auto. inversion Hran as [x Htc]; induction Htc. apply Hincl; right; exists e1; auto. apply IHHtc; auto. Qed. Lemma tc_incl r1 r2 : rel_incl r1 r2 -> rel_incl (transitive_closure r1) (transitive_closure r2). Proof. intros Hincl x y Hxy; induction Hxy. apply _base; apply Hincl; auto. apply _trans with e; auto. Qed. Lemma seq_tc_seq r1 r2 e1 e2 x y : transitive r2 -> transitive_closure (rel_seq r1 r2) e1 e2 -> maybe (rel_seq r1 r2) e2 x -> r2 x y -> transitive_closure (rel_seq r1 r2) e1 y. Proof. intros Htr2 H12 H2x Hxy. inversion H2x as [Heq2x | Hs2x]; clear H2x. rewrite Heq2x in H12; apply tc_seq_right with x; auto. apply tc_trans with e2; auto; apply _base; destruct Hs2x as [e [H2e Hex]]; exists e; split; auto; apply Htr2 with x; auto. Qed. (** * Linear and linear strict orders ****) (** ** Orders: Definitions *) Definition partial_order (A:Type) (r:Rln A) (xs:set A) : Prop := Included _(Union _ (dom r) (ran r)) xs /\ (* If an event is in the relation, then it's also in the set *) transitive r /\ (* Transitivity *) (forall x, ~(r x x)). (* Irreflexivity *) Ltac destruct_part H := destruct H as [Hinc [Htrans Hirr]]. Definition linear_strict_order (A : Type) (r : Rln A) (xs : set A) : Prop := partial_order r xs /\ (forall x1 x2, (x1 <> x2) -> (xs x1) -> (xs x2) -> (r x1 x2) \/ (r x2 x1)). (* Total *) Ltac destruct_lin H := destruct H as [Hpart Htot]. Parameter linearisations : Rln Event -> set Event -> set (Rln Event). Parameter clinearisations : Rln (Class Event) -> set (Class Event) -> set (Rln (Class Event)). Hypothesis order_ext : forall E r, partial_order r E -> (exists lin_ext, (linearisations r E) lin_ext). Hypothesis lin_ext_prop : forall E r lin_ext, (linearisations r E) lin_ext <-> rel_incl r lin_ext /\ linear_strict_order lin_ext E. Hypothesis corder_ext : forall E r, partial_order r E -> (exists lin_ext, (clinearisations r E) lin_ext). Hypothesis clin_ext_prop : forall E r lin_ext, (clinearisations r E) lin_ext <-> rel_incl r lin_ext /\ linear_strict_order lin_ext E. (** ** Orders: Lemmas *) Lemma lin_of_big_is_lin_of_little : forall (s : set Event) (r1 r2 : Rln Event) (l : Rln Event), rel_incl r1 r2 -> (linearisations r2 s) l -> (linearisations r1 s) l. Proof. intros s r1 r2 l. intros Hincl_r1r2 Hlin. rewrite lin_ext_prop in Hlin. rewrite lin_ext_prop. destruct Hlin as [Hincl_r2l Hlin]. split. unfold rel_incl. intros e1 e2. intro Hinr1. generalize (Hincl_r1r2 e1 e2 Hinr1). apply Hincl_r2l. apply Hlin. Qed. Lemma clin_of_big_is_clin_of_little : forall (s : set (Class Event)) (r1 r2 : Rln (Class Event)) (l : Rln (Class Event)), rel_incl r1 r2 -> (clinearisations r2 s) l -> (clinearisations r1 s) l. Proof. intros s r1 r2 l. intros Hincl_r1r2 Hlin. rewrite clin_ext_prop in Hlin. rewrite clin_ext_prop. destruct Hlin as [Hincl_r2l Hlin]. split. unfold rel_incl. intros e1 e2. intro Hinr1. generalize (Hincl_r1r2 e1 e2 Hinr1). apply Hincl_r2l. apply Hlin. Qed. (** * Built-in herd relations ****) (** ** Herd: Definitions*) Definition internal (E : set Event) (e1 e2 : Event) : Prop := tid e1 = tid e2 /\ E e1 /\ E e2. Definition external (E : set Event) (e1 e2 : Event) : Prop := ~(internal E e1 e2). Definition po (E : set Event) (e1 e2 : Event) : Prop := internal E e1 e2 /\ lt (id e1) (id e2). Definition po_loc (E : set Event) (e1 e2 : Event) : Prop := po E e1 e2 /\ loc e1 = loc e2. Definition rf (E : set Event) (e1 e2 : Event) : Prop := is_write e1 /\ is_read e2 /\ loc e1 = loc e2 /\ val e1 = val e2 /\ E e1 /\ E e2. Ltac destruct_rf H := destruct H as [Hisw [Hisr [Hloceq [Hvaleq [Hinw Hinr]]]]]. Definition pre_co (E : set Event) (e1 e2 : Event) : Prop := is_write e1 /\ is_write e2 /\ loc e1 = loc e2 /\ E e1 /\ E e2. Definition fr (E : set Event) (co : set Event -> Rln Event) (e1 e2 : Event) : Prop := exists w, is_write w /\ rf E w e1 /\ co E w e2. Definition rf_well_formed (E : set Event) : Prop := partial_order (rf E) E /\ forall (r : Event), is_read r -> (exists w, rf E w r) /\ (forall w1 w2, rf E w1 r -> rf E w2 r -> w1 = w2). Ltac destruct_rf_wf H := destruct H as [Hpart_rf Hex_uni]. Definition is_write_same_loc (l : Location) (e : Event) : Prop := is_write e /\ loc e = l. Definition co_well_formed (E : set Event) (co : set Event -> Rln Event) : Prop := (rel_incl (co E) (pre_co E)) /\ (forall (l : Location), linear_strict_order (co E) (Intersection _ E (is_write_same_loc l))). Definition rfi (E : set Event) (e1 e2 : Event) : Prop := rf E e1 e2 /\ internal E e1 e2. Definition coi (E : set Event) (co : set Event -> Rln Event) (e1 e2 : Event) : Prop := co E e1 e2 /\ internal E e1 e2. Definition fri (E : set Event) (co : set Event -> Rln Event) (e1 e2 : Event) : Prop := fr E co e1 e2 /\ internal E e1 e2. Definition rfe (E : set Event) (e1 e2 : Event) : Prop := rf E e1 e2 /\ external E e1 e2. Definition coe (E : set Event) (co : set Event -> Rln Event) (e1 e2 : Event) : Prop := co E e1 e2 /\ external E e1 e2. Definition fre (E : set Event) (co : set Event -> Rln Event) (e1 e2 : Event) : Prop := fr E co e1 e2 /\ external E e1 e2. Definition corf E (co : set Event -> Rln Event) (e1 e2 : Event) := exists e, co E e1 e /\ rf E e e2. Definition corfe E (co : set Event -> Rln Event) (e1 e2 : Event) := exists e, co E e1 e /\ rfe E e e2. Definition coirf E (co : set Event -> Rln Event) (e1 e2 : Event) := exists e, coi E co e1 e /\ rf E e e2. Definition coerf E (co : set Event -> Rln Event) (e1 e2 : Event) := exists e, coe E co e1 e /\ rf E e e2. Definition coerfe E (co : set Event -> Rln Event) (e1 e2 : Event) := exists e, coe E co e1 e /\ rfe E e e2. Definition frrf E (co : set Event -> Rln Event) (e1 e2 : Event) := exists e, fr E co e1 e /\ rf E e e2. Definition frrfe E (co : set Event -> Rln Event) (e1 e2 : Event) := exists e, fr E co e1 e /\ rfe E e e2. Definition frrfi E (co : set Event -> Rln Event) (e1 e2 : Event) := exists e, fr E co e1 e /\ rfi E e e2. Definition frerf E (co : set Event -> Rln Event) (e1 e2 : Event) := exists e, fre E co e1 e /\ rf E e e2. Definition complus E (co : set Event -> Rln Event) e1 e2 := rf E e1 e2 \/ co E e1 e2 \/ fr E co e1 e2 \/ rel_seq (co E) (rf E) e1 e2 \/ rel_seq (fr E co) (rf E) e1 e2. Definition ER E := ran (rfe E). Definition IR E := ran(rfi E). Definition M E := fun e => E e /\ (is_write e \/ is_read e). Definition si_well_formed (E:set Event) (si:Rln Event) := (forall x, dom si x -> M E x) /\ (forall x, ran si x -> M E x) /\ (forall x, si x x) /\ (forall x y, si x y -> si y x) /\ (forall x y z, si x y -> si y z -> si x z) /\ (forall x y, si x y -> is_write x -> is_write y) /\ (forall x y, si x y -> is_read x -> is_read y). Ltac destruct_siwf H := destruct H as [Hdom [Hran [Hrefl [Hsym [Htrans [Hw Hr]]]]]]. Definition scaob E si e1 e2 := si E e1 e2 /\ ER E e1 /\ IR E e2. Definition rfisw E si := fun r1 => fun r2 => exists w1, exists w2, rfi E w1 r1 /\ rfi E w2 r2 /\ si E w1 w2. Definition erln E si := fun e1 => fun e2 => M E e1 /\ M E e2 /\ si E e1 e2 /\ ((is_write e1 /\ is_write e2) \/ (ER E e1 /\ ER E e2) \/ (rfisw E si e1 e2)). Definition MemC E si := classes (erln E si). (** ** Herd: Lemmas *) Lemma int_or_ext (E : set Event) : forall (e1 e2 : Event), E e1 -> E e2 -> internal E e1 e2 \/ external E e1 e2. Proof. intros e1 e2 Hin1 Hin2. unfold external. unfold internal. generalize (nat_eq_or_not_eq (tid e1) (tid e2)). intro Hor. inversion Hor as [Heq|Hdiff]; clear Hor. left; auto. right. unfold not. intros [Heq [? ?]]. unfold not in Hdiff. apply Hdiff. apply Heq. Qed. Lemma int_ext_contrad E e1 e2 : internal E e1 e2 -> external E e1 e2 -> False. Proof. intros Hint Hext; apply Hext; auto. Qed. Lemma internal_trans E x y z : internal E x y -> internal E y z -> internal E x z. Proof. intros [Heqxy [? ?]] [Heqyz [? ?]]; split; [|split]; auto. rewrite Heqxy; auto. Qed. Lemma internal_implies_po_or_po_minus_1 E x y : internal E x y -> x <> y -> po E x y \/ po E y x. Proof. intros Hint Hdiff. assert (id x <> id y) as Hneq. apply event_id_uniq; auto. generalize (nat_neq_implies_lt Hneq); intros [Hxy | Hyx]; [left | right]; split; auto. destruct Hint as [Heq [? ?]]; split; [rewrite Heq|]; auto. Qed. Lemma dom_po_in_evts (E : set Event) (e1 e2 : Event) : po E e1 e2 -> E e1. Proof. intros [[? [? ?]] ?]; auto. Qed. Lemma ran_po_in_evts (E : set Event) (e1 e2 : Event) : po E e1 e2 -> E e2. Proof. intros [[? [? ?]] ?]; auto. Qed. Lemma dom_rf_in_evts (E : set Event) (e1 e2 : Event) : rf E e1 e2 -> E e1. Proof. intros [_ [_ [_ [_ [He1_in_E _]]]]]. auto. Qed. Lemma ran_rf_in_evts (E : set Event) (e1 e2:Event) : rf E e1 e2 -> E e2. Proof. intros [_ [_ [_ [_ [_ He2_in_E]]]]]. auto. Qed. Lemma dom_rf_is_write (E : set Event) (e1 e2:Event) : rf E e1 e2 -> is_write e1. Proof. intros [? ?]; auto. Qed. Lemma ran_rf_is_read (E : set Event) (e1 e2:Event) : rf E e1 e2 -> is_read e2. Proof. intros [? [Hr ?]]. auto. Qed. Lemma rf_implies_same_loc (E : set Event) (e1 e2 : Event) : rf E e1 e2 -> loc e1 = loc e2. Proof. intros [? [? [? ?]]]; auto. Qed. Lemma rf_implies_same_val (E : set Event) (e1 e2 : Event) : rf E e1 e2 -> val e1 = val e2. Proof. intros [? [? [? [? ?]]]]; auto. Qed. Lemma dom_co_in_evts (E : set Event) (co : set Event -> Rln Event) (e1 e2 : Event) : co_well_formed E co -> co E e1 e2 -> E e1. Proof. intros [Hincl ?] Hco. destruct (Hincl e1 e2) as [? [? [? [? ?]]]]; auto. Qed. Lemma ran_co_in_evts (E : set Event) (co : set Event -> Rln Event) (e1 e2 : Event) : co_well_formed E co -> co E e1 e2 -> E e2. Proof. intros [Hincl ?] Hco. destruct (Hincl e1 e2) as [? [? [? [? ?]]]]; auto. Qed. Lemma dom_co_is_write (E : set Event) (co : set Event -> Rln Event) (e1 e2 : Event) : co_well_formed E co -> co E e1 e2 -> is_write e1. Proof. intros [Hincl ?] Hco; auto. generalize (Hincl e1 e2 Hco); intros [? [? ?]]; auto. Qed. Lemma ran_co_is_write (E : set Event) (co : set Event -> Rln Event) (e1 e2:Event) : co_well_formed E co -> co E e1 e2 -> is_write e2. Proof. intros [Hincl ?] Hco; auto. generalize (Hincl e1 e2 Hco); intros [? [? ?]]. auto. Qed. Lemma co_implies_same_loc (E : set Event) (co : set Event -> Rln Event) (e1 e2 : Event) : co_well_formed E co -> co E e1 e2 -> loc e1 = loc e2. Proof. intros [Hincl ?] Hco; auto. generalize (Hincl e1 e2 Hco);intros [? [? [? ?]]]; auto. Qed. Lemma dom_fr_in_evts (E : set Event) (co : set Event -> Rln Event) (e1 e2 : Event) : fr E co e1 e2 -> E e1. Proof. intros [? [? [Hrf ?]]]. destruct Hrf as [_ [_ [_ [_ [_ He1_in_E]]]]]. auto. Qed. Lemma ran_fr_in_evts (E : set Event) (co : set Event -> Rln Event) (e1 e2:Event) : co_well_formed E co -> fr E co e1 e2 -> E e2. Proof. intros [Hincl ?] [w [Hw [Hrf Hco]]]; auto. generalize (Hincl w e2 Hco); intros [? [? [? [? ?]]]]; auto. Qed. Lemma dom_fr_is_read (E : set Event) (co : set Event -> Rln Event) (e1 e2:Event) : fr E co e1 e2 -> is_read e1. Proof. intros [x [? [Hrf ?]]]; apply ran_rf_is_read with E x; auto. Qed. Lemma ran_fr_is_write (E : set Event) (co : set Event -> Rln Event) (e1 e2:Event) : co_well_formed E co -> fr E co e1 e2 -> is_write e2. Proof. intros Hcowf [x [? [? Hco]]]; apply ran_co_is_write with E co x; auto. Qed. Lemma fr_implies_same_loc (E : set Event) (co : set Event -> Rln Event) (e1 e2 : Event) : co_well_formed E co -> fr E co e1 e2 -> loc e1 = loc e2. Proof. intros [Hincl ?] [w [Hw [Hrf Hco]]]. generalize (Hincl w e2 Hco); intros [? [? [Hloc ?]]]. destruct_rf Hrf; rewrite <- Hloceq; auto. Qed. Lemma read_write_contrad (e : Event) : is_read e -> is_write e -> False. Proof. intros Hr Hw; unfold is_read in Hr; unfold is_write in Hw; case_eq (effect e). intros r Her; rewrite Her in Hw; auto. intros w Hew; rewrite Hew in Hr; auto. intros f Hef; rewrite Hef in Hr; auto. Qed. Lemma fr_implies_diff (E : set Event) (co : set Event -> Rln Event) (e1 e2 : Event) : co_well_formed E co -> fr E co e1 e2 -> e1 <> e2. Proof. intros [Hincl ?] [w [Hw [Hrf Hco]]]. destruct_rf Hrf. generalize (Hincl w e2 Hco); intros [? [Hwe2 [? ?]]]. intro Heq; rewrite Heq in Hisr. apply read_write_contrad with e2; auto. Qed. Lemma rf_fr_is_co E co e1 e2 e3 : rf_well_formed E -> rf E e1 e2 -> fr E co e2 e3 -> co E e1 e3. Proof. intros [? Hr] Hrf12 [w [Hw [Hrfw2 Hco]]]. generalize (ran_rf_is_read Hrf12); intro Hr2; generalize (Hr e2 Hr2); intros [? Huni]; generalize (Huni e1 w Hrf12 Hrfw2); intro Heq; rewrite <- Heq in Hco; auto. Qed. Lemma co_trans E co e1 e2 e3 : co_well_formed E co -> co E e1 e2 -> co E e2 e3 -> co E e1 e3. Proof. intros Hcowf H12 H23; generalize (co_implies_same_loc e1 e2 Hcowf H12); intro Hl12; generalize (co_implies_same_loc e2 e3 Hcowf H23); intro Hl23. destruct Hcowf as [Hincl Hlin]; generalize (Hlin (loc e1)); clear Hlin; intro Hlin; destruct_lin Hlin; destruct_part Hpart; apply Htrans with e2; auto. Qed. Lemma fr_co_is_fr E co e1 e2 e3 : co_well_formed E co -> fr E co e1 e2 -> co E e2 e3 -> fr E co e1 e3. Proof. intros Hcowf [w [Hw [Hrf Hco]]]; exists w; split; auto; split; auto; apply co_trans with e2; auto. Qed. Lemma rfe_in_rf E x y : rfe E x y -> rf E x y. Proof. intros [? ?]; auto. Qed. Lemma corfe_in_corf E co x y : corfe E co x y -> corf E co x y. Proof. intros [e [Hco [? ?]]]; exists e; split; auto. Qed. Lemma frrfe_in_frrf E co x y : frrfe E co x y -> frrf E co x y. Proof. intros [e [Hfr [? ?]]]; exists e; split; auto. Qed. Lemma rf_complus_in_complus E co e1 e2 e3 : rf_well_formed E -> co_well_formed E co -> rf E e1 e2 -> complus E co e2 e3 -> complus E co e1 e3. Proof. intros Hrfwf [Hincl ?] Hrf12 [Hrf23 | [Hco23 | [Hfr23 | [Hcorf23 | Hfrrf23]]]]. assert False as Ht. destruct Hrf12 as [? [Hr2 ?]]; destruct Hrf23 as [Hw2 ?]; apply (read_write_contrad e2 Hr2 Hw2). inversion Ht. assert False as Ht. generalize (Hincl e2 e3 Hco23); intro Hpco23. destruct Hrf12 as [? [Hr2 ?]]; destruct Hpco23 as [Hw2 ?]; apply (read_write_contrad e2 Hr2 Hw2). inversion Ht. right; left; apply rf_fr_is_co with e2; auto. assert False as Ht. destruct Hrf12 as [? [Hr2 ?]]; destruct Hcorf23 as [e [Hco Hrf]]; generalize (Hincl e2 e Hco); intro Hpco. destruct Hpco as [Hw2 ?]; apply (read_write_contrad e2 Hr2 Hw2). inversion Ht. right; right; right; left; destruct Hfrrf23 as [e [Hfr Hrf]]; exists e; split; auto; apply rf_fr_is_co with e2; auto. Qed. Lemma co_complus_in_complus E co e1 e2 e3 : co_well_formed E co -> co E e1 e2 -> complus E co e2 e3 -> complus E co e1 e3. Proof. intros Hcowf Hco12 [Hrf23 | [Hco23 | [Hfr23 | [Hcorf23 | Hfrrf23]]]]. right; right; right; left; exists e2; auto. right; left; apply co_trans with e2; auto. assert False as Ht. generalize (ran_co_is_write e1 e2 Hcowf Hco12); intro Hw2; generalize (dom_fr_is_read Hfr23); intro Hr2. apply (read_write_contrad e2 Hr2 Hw2). inversion Ht. right; right; right; left; destruct Hcorf23 as [e [Hcoe2e Hrfee3]]; exists e; split; auto; apply co_trans with e2; auto. assert False as Ht. destruct Hfrrf23 as [e [Hfr Hrf]]. generalize (ran_co_is_write e1 e2 Hcowf Hco12); intro Hw2; generalize (dom_fr_is_read Hfr); intro Hr2. apply (read_write_contrad e2 Hr2 Hw2). inversion Ht. Qed. Lemma fr_complus_in_complus E co e1 e2 e3 : co_well_formed E co -> fr E co e1 e2 -> complus E co e2 e3 -> complus E co e1 e3. Proof. intros Hcowf Hfr12 [Hrf23 | [Hco23 | [Hfr23 | [Hcorf23 | Hfrrf23]]]]. right; right; right; right; exists e2; auto. right; right; left; apply fr_co_is_fr with e2; auto. assert False as Ht. generalize (ran_fr_is_write Hcowf Hfr12); intro Hw2; generalize (dom_fr_is_read Hfr23); intro Hr2; apply (read_write_contrad e2 Hr2 Hw2); auto. inversion Ht. destruct Hcorf23 as [e [Hco Hrf]]; right; right; right; right; exists e; split; auto; apply fr_co_is_fr with e2; auto. assert False as Ht. destruct Hfrrf23 as [e [Hfr Hrf]]. generalize (ran_fr_is_write Hcowf Hfr12); intro Hw2; generalize (dom_fr_is_read Hfr); intro Hr2; apply (read_write_contrad e2 Hr2 Hw2); auto. inversion Ht. Qed. Lemma mcomplus_trans E co : rf_well_formed E -> co_well_formed E co -> transitive (maybe (complus E co)). Proof. intros Hrfwf Hcowf x y z Hxy Hyz. inversion Hxy as [Heqxy | Hmcpxy]; clear Hxy; inversion Hyz as [Heqyz | Hmcpyz]; clear Hyz. left; rewrite Heqxy; auto. right; rewrite Heqxy; auto. right; rewrite <- Heqyz; auto. right; inversion Hmcpxy as [Hrf | [Hco | [Hfr | [[e [Hco Hrf]] | [e [Hfr Hrf]]]]]]; clear Hmcpxy. apply rf_complus_in_complus with y; auto. apply co_complus_in_complus with y; auto. apply fr_complus_in_complus with y; auto. apply co_complus_in_complus with e; auto; apply rf_complus_in_complus with y; auto. apply fr_complus_in_complus with e; auto; apply rf_complus_in_complus with y; auto. Qed. Lemma complus_irr E co x : rf_well_formed E -> co_well_formed E co -> complus E co x x -> False. Proof. intros Hrfwf Hcowf; generalize Hcowf; intros [? Hlin]; intros [Hrf | [Hco | [Hfr | [Hcorf | Hfrrf]]]]. apply (read_write_contrad x); [apply ran_rf_is_read with E x | apply dom_rf_is_write with E x]; auto. generalize (Hlin (loc x)); clear Hlin; intro Hlin; destruct_lin Hlin; destruct_part Hpart; generalize Hco; apply Hirr; auto. destruct Hfr as [w [Hw [Hrf Hco]]]; apply (read_write_contrad x); [apply ran_rf_is_read with E w | apply ran_co_is_write with E co w]; auto. destruct Hcorf as [e [Hco Hrf]]; apply (read_write_contrad x); [apply ran_rf_is_read with E e | apply dom_co_is_write with E co e]; auto. destruct Hfrrf as [w [[w' [Hw' [Hrf' Hco]]] Hrf]]. generalize (ran_rf_is_read Hrf'); intro Hrx; destruct_rf_wf Hrfwf; generalize (Hex_uni x Hrx); intros [_ Huni]; generalize (Huni w' w Hrf' Hrf); intro Heq; rewrite Heq in Hco; generalize (Hlin (loc w')); clear Hlin; intro Hlin; destruct_lin Hlin; destruct_part Hpart; generalize Hco; apply Hirr; auto. Qed. Lemma rfe_fri_is_coe E co x z y : rf_well_formed E -> co_well_formed E co -> rfe E x z -> fri E co z y -> coe E co x y. Proof. intros Hrfwf Hcowf [Hrfxz Hextxz] [Hfrzy [Heqzy [? ?]]]; split. apply rf_fr_is_co with z; auto. intros [Heqtidxy [? ?]]; apply Hextxz. split; [rewrite Heqzy|split]; auto. Qed. Lemma fri_coi_is_fri E co x y z : co_well_formed E co -> fri E co x y -> coi E co y z -> fri E co x z. Proof. intros Hcowf [Hfrxy Hintxy] [Hcoyz Hintyz]; split; auto. apply fr_co_is_fr with y; auto. apply internal_trans with y; auto. Qed. (** * ARMv8 axiomatic relations ****) (** ** ARMv8: Definitions *) Definition internal_visibility (E : set Event) (co : set Event -> Rln Event) : Prop := acyclic (fun e1 e2 => rf E e1 e2 \/ co E e1 e2 \/ fr E co e1 e2 \/ po_loc E e1 e2). Definition obs (E : set Event) (co : set Event -> Rln Event) (e1 e2 : Event) : Prop := rfe E e1 e2 \/ co E e1 e2 \/ fr E co e1 e2. Definition obsplus E co := transitive_closure (obs E co). Inductive ob (E : set Event) (co : set Event -> Rln Event) (si lob : Rln Event) (e1 e2 : Event) : Prop := | _obs : rel_seq (obs E co) si e1 e2 -> ob E co si lob e1 e2 | _lob : lob e1 e2 -> ob E co si lob e1 e2 | _ob : forall e, ob E co si lob e1 e -> ob E co si lob e e2 -> ob E co si lob e1 e2. Definition external_visibility (E : set Event) (co : set Event -> Rln Event) (si lob : set Event -> Rln Event) : Prop := irreflexive (ob E co (si E) (lob E)). (** Well-formed lob: a relation lob over a set of events E is well-formed when: - lob is irreflexive - lob is transitive - lob starts with a read or write memory event - lob is included in po - lob; erln is included in lob - lob; scaob is included in lob - scaob; lob is included in lob*) Definition lob_well_formed (E:set Event) (si lob : set Event -> Rln Event) := irreflexive (lob E) /\ transitive (lob E) /\ (forall e1 e2, lob E e1 e2 -> is_write e1 \/ is_read e1) /\ rel_incl (lob E) (po E) /\ rel_incl (rel_seq (lob E) (erln E si)) (lob E) /\ rel_incl (rel_seq (lob E) (scaob E si)) (lob E) /\ rel_incl (rel_seq (scaob E si) (lob E)) (lob E). Ltac destruct_lob_wf H := destruct H as [Hirr_lob [Htrans_lob [Hdom_lob [Hincl_po [Hlob_erln [Hlob_scaob Hscaob_lob]]]]]]. (** ** ARMv8: Lemmas *) Lemma obs_in_mop (E : set Event) (co : set Event -> Rln Event) (e1 e2 : Event) : obs E co e1 e2 -> maybe (obsplus E co) e1 e2. Proof. right; left; auto. Qed. Lemma obsplus_dec E co e1 e2 : rf_well_formed E -> co_well_formed E co -> transitive_closure (obs E co) e1 e2 -> rfe E e1 e2 \/ co E e1 e2 \/ fr E co e1 e2 \/ corfe E co e1 e2 \/ frrfe E co e1 e2. Proof. intros Hrfwf Hcowf H12; generalize Hcowf; intros [Hincl Hcolin]; induction H12 as [e1 e2 Hb | e1 e2 e H1e He2]. inversion Hb as [Hrfe | [Hco | Hfr]]; auto. inversion H1e as [Hrfe1e | [Hco1e | Hfr1e]]; inversion IHHe2 as [Hrfee2 | [Hcoe2 | [Hfre2 | [Hcorfee2 | Hfrrfee2]]]]. destruct Hrfe1e as [[? [Hre ?]] ?]; destruct Hrfee2 as [[Hwe ?] ?]; generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. generalize (Hincl e e2 Hcoe2); intro Hpcoe2; destruct Hrfe1e as [[? [Hre ?]] ?]; destruct Hpcoe2 as [Hwe ?]; generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. destruct Hrfe1e as [? ?]; right; left; apply rf_fr_is_co with e; auto. destruct Hrfe1e as [[? [Hre ?]] ?]; destruct Hcorfee2 as [w [Hcoew Hrfe]]; generalize (Hincl e w Hcoew); intro Hpcoew; destruct Hpcoew as [Hwe ?]; generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. destruct Hrfe1e as [? ?]; destruct Hfrrfee2 as [w [Hfrew Hrfw2]]; right; right; right; left; exists w; split; auto; apply rf_fr_is_co with e; auto. right; right; right; left; exists e; split; auto. right; left; apply co_trans with e; auto. generalize (Hincl e1 e Hco1e); intro Hpco1e; destruct Hpco1e as [? [Hwe ?]]; destruct Hfre2 as [? [? [[? [Hre ?]] ?]]]; generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. destruct Hcorfee2 as [w [Hcoew Hrfw2]]; right; right; right; left; exists w; split; auto; apply co_trans with e; auto. destruct Hfrrfee2 as [w [Hfrew Hrfw2]]; generalize (dom_fr_is_read Hfrew); intro Hre; generalize (ran_co_is_write e1 e Hcowf Hco1e); intro Hwe; generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. right; right; right; right; exists e; split; auto. right; right; left; apply fr_co_is_fr with e; auto. destruct Hfr1e as [? [? [? Hco]]]; generalize (Hincl x e Hco); intros [? [Hwe ?]]; destruct Hfre2 as [? [? [[? [Hre ?]] ?]]]; generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. destruct Hcorfee2 as [w [Hcoew Hrfewe2]]; right; right; right; right; exists w; split; auto; apply fr_co_is_fr with e; auto. destruct Hfrrfee2 as [w [Hfrew Hrfewe2]]; generalize (dom_fr_is_read Hfrew); intro Hre; generalize (ran_fr_is_write Hcowf Hfr1e); intro Hwe; generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. Qed. Lemma op_trans E co e1 e2 e3 : (obsplus E co) e1 e2 -> (obsplus E co) e2 e3 -> (obsplus E co) e1 e3. Proof. intros H12 H23; apply tc_trans with e2; auto. Qed. Lemma mop_trans E co e1 e2 e3 : maybe (obsplus E co) e1 e2 -> maybe (obsplus E co) e2 e3 -> maybe (obsplus E co) e1 e3. Proof. intros [Heq12 | Htc12]. rewrite Heq12; auto. intros [Heq23 | Htc23]. rewrite <- Heq23; right; auto. right; apply op_trans with e2; auto. Qed. Lemma obsplus_in_scpv E co x y : rf_well_formed E -> co_well_formed E co -> obsplus E co x y -> transitive_closure (fun e1 e2 : Event => rf E e1 e2 \/ co E e1 e2 \/ fr E co e1 e2 \/ po_loc E e1 e2) x y. Proof. intros Hrfwf Hcowf Hxy; generalize (obsplus_dec Hrfwf Hcowf Hxy); intros [[Hrf ?] | [Hco | [Hfr | [[z [Hco [Hrf ?]]] | [z [Hfr [Hrf ?]]]]]]]. apply _base; left; auto. apply _base; right; left; auto. apply _base; right; right; left; auto. apply _trans with z; [right |]; left; auto. apply _trans with z; [right; right |]; left; auto. Qed. Lemma posRW_is_fri E co x y : rf_well_formed E -> co_well_formed E co -> internal_visibility E co -> is_read x -> is_write y -> po E x y -> loc x = loc y -> fri E co x y. Proof. intros Hrfwf [? Hlin] Hintv Hrx Hwy Hpoxy Hlocxy; split. destruct_rf_wf Hrfwf; generalize (Hex_uni x Hrx); clear Hex_uni; intros [[w Hrf] Huni]; exists w; split; [apply dom_rf_is_write with E x | split]; auto. generalize (Hlin (loc x)); clear Hlin; intro Hlin; destruct_lin Hlin. assert (Intersection Event E (is_write_same_loc (loc x)) w) as Hw. split; [apply dom_rf_in_evts with x| split; [apply dom_rf_is_write with E x|apply rf_implies_same_loc with E]]; auto. assert (Intersection Event E (is_write_same_loc (loc x)) y) as Hy. split; [apply ran_po_in_evts with x | split]; auto. assert (w <> y) as Hdiff. intro Heq; rewrite Heq in Hrf; apply Hintv; exists x; apply _trans with y; [right; right; right; split| apply _base]; auto. generalize (Htot w y Hdiff Hw Hy); intros [? | Hcoyw]; auto. assert False as Ht. apply Hintv; exists x; apply _trans with y; [right; right; right; split| apply _trans with w; [|apply _base]]; auto. inversion Ht. destruct Hpoxy as [? ?]; auto. Qed. Lemma posWW_is_coi E co w w' : co_well_formed E co -> internal_visibility E co -> is_write w -> is_write w' -> po E w w' -> loc w = loc w' -> co E w w'. Proof. intros [? Hlin] Hintv Hisw Hisw' Hpoww' Hlocww'. destruct (Hlin (loc w)) as [Hpart Htot]. assert (w <> w') as Hd. intro Heq; rewrite Heq in Hpoww'. destruct Hpoww' as [? Hlt]; generalize Hlt; apply lt_irrefl. assert (Intersection Event E (is_write_same_loc (loc w)) w) as Hw. split; auto; [apply dom_po_in_evts with w'|split]; auto. assert (Intersection Event E (is_write_same_loc (loc w)) w') as Hw'. split; auto; [apply ran_po_in_evts with w|split]; auto. generalize (Htot w w' Hd Hw Hw'); intros [|Hw'w]; auto. assert False as Ht. apply Hintv; exists w; apply _trans with w'; [right; right; right; split|apply _base]; auto. inversion Ht. Qed. Lemma rfi_implies_po E co w r : internal_visibility E co -> rfi E w r -> po E w r. Proof. intros Hintv [Hrf Hint]. assert (w <> r) as Hdiff. intro Heq; rewrite Heq in Hrf; assert False as Ht. apply read_write_contrad with r; [apply ran_rf_is_read with E r | apply dom_rf_is_write with E r]; auto. inversion Ht. generalize (internal_implies_po_or_po_minus_1 Hint Hdiff); intros [|Hporw]; auto. assert False as Ht. apply Hintv; exists w; auto; apply _trans with r; [left | apply _base; right; right; right; split]; auto. rewrite rf_implies_same_loc with E w r; auto. inversion Ht. Qed. (** * Definitions and lemmas relative to total order based models in general ****) Definition order_to_co (E : set Event) (o : Rln Event) (e1 e2 : Event) : Prop := E e1 /\ E e2 /\ is_write e1 /\ is_write e2 /\ loc e1 = loc e2 /\ o e1 e2. Lemma co_in_order E co o x y : rel_equal (co E) (order_to_co E o) -> co E x y -> o x y. Proof. intros Hcoeq Hco; destruct Hcoeq as [Hcoincl ?]; generalize (Hcoincl x y Hco); intros [? [? [? [? [? ?]]]]]; auto. Qed. Lemma co_order_incl (E : set Event) (co : set Event -> Rln Event) (r o : Rln Event) : co_well_formed E co -> linearisations r E o -> rel_incl (co E) r -> rel_incl (co E) (order_to_co E o). Proof. intros Hcowf Hlin Hcor; generalize (lin_ext_prop E r o); intros [Himpl _]; generalize (Himpl Hlin); clear Himpl; intros [Hincl Hlso]; intros x y Hxy. split. apply dom_co_in_evts with co y; auto. split. apply ran_co_in_evts with co x; auto. split; [apply dom_co_is_write with E co y | split; [apply ran_co_is_write with E co x| split; [apply co_implies_same_loc with E co|apply Hincl; apply Hcor]]]; auto. Qed. Lemma co_corder_incl (E : set Event) (co : set Event -> Rln Event) (C : set (Class Event)) (r : Rln Event) (o : Rln (Class Event)) : co_well_formed E co -> clinearisations (lift C r) C o -> rel_incl (co E) (delift C o) -> rel_incl (co E) (order_to_co E (delift C o)). Proof. intros Hcowf Hlin Hcor; generalize (clin_ext_prop C (lift C r) o); intros [Himpl _]; generalize (Himpl Hlin); clear Himpl; intros [Hincl Hlso]; intros x y Hxy. split. apply dom_co_in_evts with co y; auto. split. apply ran_co_in_evts with co x; auto. split; [apply dom_co_is_write with E co y | split; [apply ran_co_is_write with E co x | split; [apply co_implies_same_loc with E co |]]]; auto. Qed. Lemma fr_implies_order_or_order_minus_1 (E : set Event) (co : set Event -> Rln Event) (r o : Rln Event) (e1 e2 : Event) : co_well_formed E co -> linearisations r E o -> fr E co e1 e2 -> o e1 e2 \/ o e2 e1. Proof. intros Hcowf Hlin H12. generalize (lin_ext_prop E r o); intros [Himpl ?]; generalize (Himpl Hlin); intros [Hincl Hlso]; destruct_lin Hlso. apply Htot; auto. apply fr_implies_diff with E co; auto. apply dom_fr_in_evts with co e2; auto. apply ran_fr_in_evts with co e1; auto. Qed. Definition equiv_rel (A:Type) (eqr:Rln A) := (forall x, eqr x x) /\ (forall x y, eqr x y -> eqr y x) /\ (forall x y z, eqr x y -> eqr y z -> eqr x z). Ltac destruct_eqrln H := destruct H as [Hrefl [Hsym Htrans]]. Lemma class_of_in_classes (A:Type) (eqr:Rln A) C x : equiv_rel eqr -> C = classes eqr -> C (class_of eqr x). Proof. intros Heqr HeqC; rewrite HeqC; exists x; auto. Qed. Lemma class_of_refl (A:Type) (eqr:Rln A) x : equiv_rel eqr -> class_of eqr x x. Proof. intros Heqr; destruct_eqrln Heqr; apply Hrefl. Qed. Lemma ran_of_rfe_si_is_read E si x y z : si_well_formed E (si E) -> rfe E x y -> si E y z -> is_read z. Proof. intros Hsiwf [Hrf ?] Hsi. destruct_siwf Hsiwf; apply Hr with y; auto. apply ran_rf_is_read with E x; auto. Qed. Lemma read_is_ER_or_IR E x : rf_well_formed E -> is_read x -> ER E x \/ IR E x. Proof. intros Hrfwf Hr; destruct_rf_wf Hrfwf; generalize (Hex_uni x Hr); intros [[w Hrf] ?]. assert (E w) as HEw. apply dom_rf_in_evts with x; auto. assert (E x) as HEx. apply ran_rf_in_evts with w; auto. generalize (int_or_ext E w x HEw HEx); intros [Hint | Hext]; [right | left]; exists w; split; auto. Qed. Lemma equiv_elts_have_equal_classes (A:Type) (eqr:Rln A) x y : equiv_rel eqr -> eqr x y -> class_of eqr x = class_of eqr y. Proof. intros Hequivr Hxy; unfold class_of; destruct_eqrln Hequivr; apply Extensionality_Ensembles; split; intros e He; unfold In in * |- *. apply Htrans with x; apply Hsym; auto. apply Htrans with y; auto. Qed. Lemma obsp_si_in_order E co si r eqr C o x y : erln E si = eqr -> equiv_rel eqr -> C = classes eqr -> si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> clinearisations (lift C r) C o -> rel_incl (rfe E) (delift C o) -> rel_incl (co E) (delift C o) -> rel_incl (fr E co) (delift C o) -> rel_incl (scaob E si) r -> rel_seq (obsplus E co) (si E) x y -> o (class_of eqr x) (class_of eqr y). Proof. intros Heqr Hequivr HC Hsiwf Hrfwf Hcowf Hlin Hrfeincl Hcoincl Hfrincl Hscaobincl [e [Hxe Hey]]; generalize (clin_ext_prop C (lift C r) o); intros [Himpl _]; generalize (Himpl Hlin); clear Himpl; intros [Hincl Hlso]; destruct_lin Hlso; destruct_part Hpart; generalize (class_of_in_classes x Hequivr HC); intro Hinx; generalize (class_of_in_classes e Hequivr HC); intro Hine; generalize (class_of_in_classes y Hequivr HC); intro Hiny; generalize (class_of_refl x Hequivr); intro Hreflx; generalize (class_of_refl e Hequivr); intro Hrefle; generalize (class_of_refl y Hequivr); intro Hrefly; generalize (obsplus_dec Hrfwf Hcowf Hxe); intros [Hrfe | [Hco | [Hfr | [Hcorfe | Hfrrfe]]]]. (*x -rfe-> e -si- y*) generalize (Hrfeincl x e Hrfe); intro Hdrfe; generalize (Hdrfe (class_of eqr x) (class_of eqr e) Hinx Hine Hreflx Hrefle); intros Hoxe. assert (ER E e) as HERe. exists x; auto. assert (ER E y \/ IR E y) as Hory. apply read_is_ER_or_IR; auto; apply ran_of_rfe_si_is_read with E si x e; auto. inversion Hory as [HERy | HIRy]; clear Hory. assert (class_of eqr e = class_of eqr y) as Hceqey. clear Htrans; destruct_siwf Hsiwf. apply equiv_elts_have_equal_classes; auto; rewrite <- Heqr; auto; split; auto; [apply Hdom; exists y | split; [apply Hran; exists e|]]; auto. rewrite <- Hceqey; auto. apply Htrans with (class_of eqr e); auto; apply Hincl; auto; split; auto; split; auto; exists e; exists y; split; auto; split; auto; apply Hscaobincl; split; auto. (*x -co-> e -si- y*) generalize (Hcoincl x e Hco); intro Hdco; generalize (Hdco (class_of eqr x) (class_of eqr e) Hinx Hine Hreflx Hrefle); intros Hoxe. assert (is_write e /\ is_write y) as Hww. generalize (ran_co_is_write x e Hcowf Hco); intro Hwe. split; [| clear Htrans; destruct_siwf Hsiwf; apply Hw with e]; auto. assert (class_of eqr e = class_of eqr y) as Hceqey. clear Htrans; destruct_siwf Hsiwf. apply equiv_elts_have_equal_classes; auto; rewrite <- Heqr; auto; split; auto; [apply Hdom; exists y | split; [apply Hran; exists e|]]; auto. rewrite <- Hceqey; auto. (*x -fr-> e -si- y*) generalize (Hfrincl x e Hfr); intro Hdfr; generalize (Hdfr (class_of eqr x) (class_of eqr e) Hinx Hine Hreflx Hrefle); intros Hoxe. assert (is_write e /\ is_write y) as Hww. generalize (ran_fr_is_write Hcowf Hfr); intro Hwe. split; [| clear Htrans; destruct_siwf Hsiwf; apply Hw with e]; auto. assert (class_of eqr e = class_of eqr y) as Hceqey. clear Htrans; destruct_siwf Hsiwf. apply equiv_elts_have_equal_classes; auto; rewrite <- Heqr; auto; split; auto; [apply Hdom; exists y | split; [apply Hran; exists e|]]; auto. rewrite <- Hceqey; auto. (*x -co;rfe-> e -si- y*) destruct Hcorfe as [x' [Hco Hrfe]]; generalize (class_of_in_classes x' Hequivr HC); intro Hinx'; generalize (class_of_refl x' Hequivr); intro Hreflx'; apply Htrans with (class_of eqr x'). generalize (Hcoincl x x' Hco); intro Hdco; generalize (Hdco (class_of eqr x) (class_of eqr x') Hinx Hinx' Hreflx Hreflx'); intros Hoxx'; auto. generalize (Hrfeincl x' e Hrfe); intro Hdrfe; generalize (Hdrfe (class_of eqr x') (class_of eqr e) Hinx' Hine Hreflx' Hrefle); intros Hox'e. assert (ER E e) as HERe. exists x'; auto. assert (ER E y \/ IR E y) as Hory. apply read_is_ER_or_IR; auto; apply ran_of_rfe_si_is_read with E si x' e; auto. inversion Hory as [HERy | HIRy]; clear Hory. assert (class_of eqr e = class_of eqr y) as Hceqey. clear Htrans; destruct_siwf Hsiwf. apply equiv_elts_have_equal_classes; auto; rewrite <- Heqr; auto; split; auto; [apply Hdom; exists y | split; [apply Hran; exists e|]]; auto. rewrite <- Hceqey; auto. apply Htrans with (class_of eqr e); auto; apply Hincl; auto; split; auto; split; auto; exists e; exists y; split; auto; split; auto; apply Hscaobincl; split; auto. (*x -fr;rfe-> e -si- y*) destruct Hfrrfe as [x' [Hfr Hrfe]]; generalize (class_of_in_classes x' Hequivr HC); intro Hinx'; generalize (class_of_refl x' Hequivr); intro Hreflx'; apply Htrans with (class_of eqr x'). generalize (Hfrincl x x' Hfr); intro Hdfr; generalize (Hdfr (class_of eqr x) (class_of eqr x') Hinx Hinx' Hreflx Hreflx'); intros Hoxx'; auto. generalize (Hrfeincl x' e Hrfe); intro Hdrfe; generalize (Hdrfe (class_of eqr x') (class_of eqr e) Hinx' Hine Hreflx' Hrefle); intros Hox'e. assert (ER E e) as HERe. exists x'; auto. assert (ER E y \/ IR E y) as Hory. apply read_is_ER_or_IR; auto; apply ran_of_rfe_si_is_read with E si x' e; auto. inversion Hory as [HERy | HIRy]; clear Hory. assert (class_of eqr e = class_of eqr y) as Hceqey. clear Htrans; destruct_siwf Hsiwf. apply equiv_elts_have_equal_classes; auto; rewrite <- Heqr; auto; split; auto; [apply Hdom; exists y | split; [apply Hran; exists e|]]; auto. rewrite <- Hceqey; auto. apply Htrans with (class_of eqr e); auto; apply Hincl; auto; split; auto; split; auto; exists e; exists y; split; auto; split; auto; apply Hscaobincl; split; auto. Qed. Lemma tc_obsp_si_in_order E co si r eqr C o x y : erln E si = eqr -> equiv_rel eqr -> C = classes eqr -> si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> clinearisations (lift C r) C o -> rel_incl (rfe E) (delift C o) -> rel_incl (co E) (delift C o) -> rel_incl (fr E co) (delift C o) -> rel_incl (scaob E si) r -> transitive_closure (rel_seq (obsplus E co) (si E)) x y -> o (class_of eqr x) (class_of eqr y). Proof. intros Heqr Hequivr HC Hsiwf Hrfwf Hcowf Hlin Hrfeincl Hcoincl Hfrincl Hscaobincl Htc; auto. induction Htc as [x e Hb | x y e Hb]; generalize (obsp_si_in_order Heqr Hequivr HC Hsiwf Hrfwf Hcowf Hlin Hrfeincl Hcoincl Hfrincl Hscaobincl Hb); auto; intros Hoxe; generalize (clin_ext_prop C (lift C r) o); intros [Himpl _]; generalize (Himpl Hlin); clear Himpl; intros [Hincl Hlso]; destruct_lin Hlso; destruct_part Hpart; apply Htrans with (class_of eqr e); auto; rewrite <- Heqr; auto. Qed. Lemma mop_in_order E co si r eqr C o x y : erln E si = eqr -> equiv_rel eqr -> C = classes eqr -> si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> clinearisations (lift C r) C o -> rel_incl (rfe E) (delift C o) -> rel_incl (co E) (delift C o) -> rel_incl (fr E co) (delift C o) -> rel_incl (scaob E si) r -> maybe (transitive_closure (rel_seq (obsplus E co) (si E))) x y -> x = y \/ o (class_of eqr x) (class_of eqr y). Proof. intros Heqr Hequivr HC Hsiwf Hrfwf Hcowf Hlin Hrfeincl Hcoincl Hfrincl Hscaobincl [Heq | Htc]; auto. right; apply tc_obsp_si_in_order with E co si r C; auto. Qed. Definition mobs_r_mobs E co si r := rel_seq (maybe (transitive_closure (rel_seq (obsplus E co) (si E)))) (rel_seq r (maybe (transitive_closure (rel_seq (obsplus E co) (si E))))). Definition tc_mobs_r_mobs E co si r := transitive_closure (mobs_r_mobs E co si r). Lemma r_to_lift (A:Type) (C:set (Class A)) (r:Rln A) eqr e1 e2 : equiv_rel eqr -> C (class_of eqr e1) -> C (class_of eqr e2) -> r e1 e2 -> lift C r (class_of eqr e1) (class_of eqr e2). Proof. intros Hequivr H1 H2 H12. generalize (class_of_refl e1 Hequivr); intro Hre1; generalize (class_of_refl e2 Hequivr); intro Hre2. split; auto; split; auto; exists e1; exists e2; split; auto. Qed. Lemma mobs_r_mobs_in_order E co si r eqr C o e1 e2 : erln E si = eqr -> equiv_rel eqr -> C = classes eqr -> si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> clinearisations (lift C r) C o -> rel_incl (rfe E) (delift C o) -> rel_incl (co E) (delift C o) -> rel_incl (fr E co) (delift C o) -> rel_incl (scaob E si) r -> (mobs_r_mobs E co si r) e1 e2 -> o (class_of eqr e1) (class_of eqr e2). Proof. intros Heqr Hequivr HC Hsiwf Hrfwf Hcowf Hlin Hrfincl Hcoincl Hfrincl Hscaobincl [e [H1e [e' [Hee' He'2]]]]; generalize (class_of_in_classes e Hequivr HC); intros HCe; generalize (class_of_in_classes e' Hequivr HC); intros HCe'; generalize (clin_ext_prop C (lift C r) o); intros [Himpl _]; generalize (Himpl Hlin); intros [Hincl Hlso]; destruct_lin Hlso; destruct_part Hpart; generalize (mop_in_order Heqr Hequivr HC Hsiwf Hrfwf Hcowf Hlin Hrfincl Hcoincl Hfrincl Hscaobincl H1e); generalize (mop_in_order Heqr Hequivr HC Hsiwf Hrfwf Hcowf Hlin Hrfincl Hcoincl Hfrincl Hscaobincl He'2); intros [Heqe'2 | Hgcbe'2]; intros [Heqe1 | Hgcbe1]. rewrite Heqe1; rewrite <- Heqe'2; auto; apply Hincl; apply r_to_lift; auto. apply Htrans with (class_of eqr e); auto; rewrite <- Heqe'2; auto; apply Hincl; apply r_to_lift; auto. apply Htrans with (class_of eqr e'); auto; rewrite Heqe1; auto; apply Hincl; apply r_to_lift; auto. apply Htrans with (class_of eqr e); auto; apply Htrans with (class_of eqr e'); auto; apply Hincl; apply r_to_lift; auto. Qed. Lemma tc_mobs_r_mobs_in_order E co si r eqr C o x y : erln E si = eqr -> equiv_rel eqr -> C = classes eqr -> si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> clinearisations (lift C r) C o -> rel_incl (rfe E) (delift C o) -> rel_incl (co E) (delift C o) -> rel_incl (fr E co) (delift C o) -> rel_incl (scaob E si) r -> tc_mobs_r_mobs E co si r x y -> o (class_of eqr x) (class_of eqr y). Proof. intros Heqr Hequivr HC Hsiwf Hrfwf Hcowf Hlin Hrfincl Hcoincl Hfrincl Hscaobincl Hxy. induction Hxy. apply mobs_r_mobs_in_order with E co si r C; auto. generalize (clin_ext_prop C (lift C r) o); intros [Himpl _]; generalize (Himpl Hlin); clear Himpl; intros [Hincl Hlso]; destruct_lin Hlso; destruct_part Hpart; apply Htrans with (class_of eqr e); auto. apply mobs_r_mobs_in_order with E co si r C; auto. Qed. Lemma tc_mobs_r_mobs_irr E co si r eqr C o x : erln E si = eqr -> equiv_rel eqr -> C = classes eqr -> si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> clinearisations (lift C r) C o -> rel_incl (rfe E) (delift C o) -> rel_incl (co E) (delift C o) -> rel_incl (fr E co) (delift C o) -> rel_incl (scaob E si) r -> ~(tc_mobs_r_mobs E co si r x x). Proof. intros Heqr Hequivr HC Hsiwf Hrfwf Hcowf Hlin Hrfeincl Hcoincl Hfrincl Hscaobincl Hxx; generalize (clin_ext_prop C (lift C r) o); intros [Himpl _]; generalize (Himpl Hlin); clear Himpl; intros [Hincl Hlso]; destruct_lin Hlso; destruct_part Hpart. apply Hirr with (class_of eqr x); apply tc_mobs_r_mobs_in_order with E co si r C; auto. Qed. (** * External Global Completion *) (** ** External Global Completion: Definitions *) Definition intervening_write (r : Rln Event) (e1 e2 : Event) : Prop := exists w, is_write w /\ r e1 w /\ r w e2. Definition gcb_rf (E : set Event) (gcb : Rln Event) (e1 e2 : Event) : Prop := E e1 /\ E e2 /\ is_write e1 /\ is_read e2 /\ loc e1 = loc e2 /\ val e1 = val e2 /\ gcb e1 e2 /\ ~intervening_write (fun e1 e2 => gcb e1 e2 /\ loc e1 = loc e2) e1 e2. Definition gcb_rf_wf (E:set Event) (gcb : Rln Event) : Prop := forall r, is_read r -> exists w, gcb_rf E gcb w r. Definition gcb_co (E : set Event) (gcb : Rln Event) (e1 e2 : Event) : Prop := order_to_co E gcb e1 e2. Definition does_not_locally_reads_from E r1 := ~(exists w1, rfi E w1 r1). Definition locally_reads_from_a_lob_write (E : set Event) (lob : set Event -> Rln Event) r1 e2 := exists w1, rfi E w1 r1 /\ lob E w1 e2. Definition read_requirements (E : set Event) (lob : set Event -> Rln Event) r1 e2 := does_not_locally_reads_from E r1 \/ locally_reads_from_a_lob_write E lob r1 e2. Definition lob' (E : set Event) (lob : set Event -> Rln Event) (e1 e2 : Event) := lob E e1 e2 /\ (is_read e1 /\ ~(read_requirements E lob e1 e2)). Definition preorder_gcb (E : set Event) (si lob : set Event -> Rln Event) (e1 e2 : Event) : Prop := (lob E e1 e2 /\ (is_write e1 \/ (is_read e1 /\ read_requirements E lob e1 e2))) \/ (scaob E si e1 e2). Definition preorder_gcb_lift E si lob C := lift C (preorder_gcb E si lob). Definition dgcb_loc E C gcb := fun e1 => fun e2 => E e1 /\ E e2 /\ delift C gcb e1 e2 /\ loc e1 = loc e2. Definition external_global_completion (E : set Event) (co si lob: set Event -> Rln Event) (gcb : Rln (Class Event)): Prop := (clinearisations (preorder_gcb_lift E si lob (MemC E si)) (MemC E si)) gcb /\ rel_equal (rf E) (gcb_rf E (dgcb_loc E (MemC E si) gcb)) /\ rel_equal (co E) (gcb_co E (dgcb_loc E (MemC E si) gcb)). (** ** External Global Completion: Auxiliary definitions, for convenience in the proofs below *) Definition big_rel E co si lob := tc_mobs_r_mobs E co si (preorder_gcb E si lob). (** ** External Global Completion: Lemmas that do _not_ need the existence of a External Global Completion order *) Lemma lob'_irr E si lob x : lob_well_formed E si lob -> ~(lob' E lob x x). Proof. intros Hlobwf [Hxx ?]; destruct_lob_wf Hlobwf. apply Hirr_lob; exists x; auto. Qed. Lemma lob_implies_pgcb_or_lob' (E : set Event) (si lob : set Event -> Rln Event) (e1 e2 : Event) : lob_well_formed E si lob -> lob E e1 e2 -> preorder_gcb E si lob e1 e2 \/ lob' E lob e1 e2. Proof. intros Hlobwf H12; destruct_lob_wf Hlobwf; generalize (Hdom_lob e1 e2 H12); intros [Hw1 | Hr1]. left; left; split; auto. generalize (excluded_middle (read_requirements E lob e1 e2)); intros [Hrr | Hnrr]; [left; left | right]; split; auto. Qed. Lemma pgcb_in_big_rel E co si lob e1 e2 : preorder_gcb E si lob e1 e2 -> big_rel E co si lob e1 e2. Proof. intros Hpgcb; apply _base; exists e1; split; [left; auto | exists e2; split; [|left]; auto]. Qed. Lemma lob'_in_lob'_seq_big_rel E co si lob e1 e2 : lob' E lob e1 e2 -> rel_seq (lob' E lob) (maybe (big_rel E co si lob)) e1 e2. Proof. intros H12; exists e2; split; auto; left; auto. Qed. Lemma front_seq (r1 r2 : Rln Event) e1 e2 e3 : transitive r1 -> r1 e1 e2 -> transitive_closure (rel_seq r1 (rel_seq r2 r1)) e2 e3 -> transitive_closure (rel_seq r1 (rel_seq r2 r1)) e1 e3. Proof. intros Htr1 H12 H23; induction H23 as [e e2 [e' [Hee' He'2]] | e e2 e' He2]. apply _base; exists e'; split; auto. generalize Hee'; generalize H12; apply Htr1. apply _trans with e'; auto. destruct He2 as [e0 [He0 H0']]; exists e0; split; auto. generalize He0; generalize H12; apply Htr1. Qed. Lemma maybe_tc_trans r : transitive (maybe (transitive_closure r)). Proof. intros e1 e2 e3 Hor12 Hor23. inversion Hor12 as [Heq12 | H12]; clear Hor12. rewrite Heq12; auto. inversion Hor23 as [Heq23 | H23]; clear Hor23. rewrite <- Heq23; right; auto. right; apply tc_trans with e2; auto. Qed. Lemma mop_br_in_br E co si lob e1 e2 e3 : maybe (transitive_closure (rel_seq (obsplus E co) (si E))) e1 e2 -> big_rel E co si lob e2 e3 -> big_rel E co si lob e1 e3. Proof. unfold big_rel; unfold tc_mobs_r_mobs; unfold mobs_r_mobs. apply front_seq; apply maybe_tc_trans. Qed. Lemma ER_lob'_contrad E lob e1 e2 : rf_well_formed E -> ER E e1 -> lob' E lob e1 e2 -> False. Proof. intros Hrfwf [w1 [Hrfw1e1 Hext]] [Hlob [Hr1 Hnrr]]; apply Hnrr; left; intros [w [Hrfw1 Hint]]. destruct Hrfwf as [? Hr]; generalize (Hr e1 Hr1); intros [? Huni]; generalize (Huni w1 w Hrfw1e1 Hrfw1); intro Heq; rewrite Heq in Hext; apply int_ext_contrad with E w e1; auto. Qed. Lemma W_lob'_contrad E lob e1 e2 : is_write e1 -> lob' E lob e1 e2 -> False. Proof. intros Hw1 [Hlob [Hr1 Hnrr]]; apply read_write_contrad with e1; auto. Qed. Lemma tc_dec r e1 e3 : transitive_closure r e1 e3 -> exists e2, maybe (transitive_closure r) e1 e2 /\ r e2 e3. Proof. intros H13; induction H13. exists e1; split; auto; left; auto. destruct IHtransitive_closure as [e' [Hee' He'2]]; exists e'; split; auto. inversion Hee' as [Heq | Htc]. rewrite Heq in H; right; apply _base; auto. right; apply _trans with e; auto. Qed. Lemma obsp_si_lob' E co si lob e1 e2 e3 : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> rel_seq (obsplus E co) (si E) e1 e2 -> lob' E lob e2 e3 -> rel_seq (rel_seq (maybe (rel_union (co E) (fr E co))) (rfe E)) (rel_seq (scaob E si) (lob' E lob)) e1 e3. Proof. intros Hsiwf Hrfwf Hcowf [e [H1e He2]] H23. generalize (obsplus_dec Hrfwf Hcowf H1e); clear H1e; intros [Hrfe1e | [Hco1e | [Hfr1e | [Hcorfe1e | Hfrrfe1e]]]]. assert (ER E e) as HERe. exists e1; auto. assert (is_read e2) as Hr2. destruct_siwf Hsiwf; apply Hr with e; auto; apply ran_rf_is_read with E e1; destruct Hrfe1e; auto. exists e; split; [exists e1; split; [left|] |]; auto; exists e2; split; auto; split; auto; split; auto. generalize (read_is_ER_or_IR e2 Hrfwf Hr2); intros [HER2 | HIR2]; auto. generalize (ER_lob'_contrad Hrfwf HER2 H23); intro Ht; inversion Ht. assert (is_write e2) as Hw2. destruct_siwf Hsiwf; apply Hw with e; auto; apply ran_co_is_write with E co e1; auto. generalize (W_lob'_contrad Hw2 H23); intro Ht; inversion Ht. assert (is_write e2) as Hw2. destruct_siwf Hsiwf; apply Hw with e; auto; apply ran_fr_is_write with E co e1; auto. generalize (W_lob'_contrad Hw2 H23); intro Ht; inversion Ht. destruct Hcorfe1e as [x [? Hrfe]]. assert (ER E e) as HERe. exists x; auto. assert (is_read e2) as Hr2. destruct_siwf Hsiwf; apply Hr with e; auto; apply ran_rf_is_read with E x; destruct Hrfe; auto. exists e; split; [exists x; split; [right; left|] |]; auto; exists e2; split; auto; split; auto; split; auto. generalize (read_is_ER_or_IR e2 Hrfwf Hr2); intros [HER2 | HIR2]; auto. generalize (ER_lob'_contrad Hrfwf HER2 H23); auto; intro Ht; inversion Ht. destruct Hfrrfe1e as [x [? Hrfe]]. assert (ER E e) as HERe. exists x; auto. assert (is_read e2) as Hr2. destruct_siwf Hsiwf; apply Hr with e; auto; apply ran_rf_is_read with E x; destruct Hrfe; auto. exists e; split; [exists x; split; [right; right|] |]; auto; exists e2; split; auto; split; auto; split; auto. generalize (read_is_ER_or_IR e2 Hrfwf Hr2); intros [HER2 | HIR2]; auto. generalize (ER_lob'_contrad Hrfwf HER2 H23); auto; intro Ht; inversion Ht. Qed. Lemma pre_mop_lob'_in_lob'_or_br E co si lob e1 e2 e3 : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> maybe (transitive_closure (rel_seq (obsplus E co) (si E))) e1 e2 -> lob' E lob e2 e3 -> lob' E lob e1 e3 \/ rel_seq (maybe (transitive_closure (rel_seq (obsplus E co) (si E)))) (rel_seq (rel_seq (maybe (rel_union (co E) (fr E co))) (rfe E)) (rel_seq (scaob E si) (lob' E lob))) e1 e3. Proof. intros Hsiwf Hrfwf Hcowf [Heq12 | H12] H23; [rewrite Heq12|]; auto. generalize (tc_dec H12); intros [e [H1e He2]]; right; exists e; split; auto. apply obsp_si_lob' with e2; auto. Qed. Lemma mscaob_lob'_is_lob_or_lob' E si lob e1 e2 : lob_well_formed E si lob -> rel_seq (maybe (scaob E si)) (lob' E lob) e1 e2 -> lob E e1 e2 \/ lob' E lob e1 e2. Proof. intros Hlobwf [e [Hm Hlob']]; inversion Hm as [Heq | Hsi]. rewrite <- Heq in Hlob'; right; auto. destruct_lob_wf Hlobwf; destruct Hlob' as [Hlob ?]. left; apply Hscaob_lob; exists e; auto. Qed. Lemma scaob_lob'_is_pgcb_or_lob' E si lob e1 e2 : rf_well_formed E -> lob_well_formed E si lob -> rel_seq (scaob E si) (lob' E lob) e1 e2 -> preorder_gcb E si lob e1 e2. Proof. intros Hrfwf Hlobwf [e [Hsi Hlob']]; unfold preorder_gcb; left; split; auto. destruct_lob_wf Hlobwf; destruct Hlob' as [Hlob ?]. apply Hscaob_lob; exists e; auto. right; destruct Hsi as [Hsi [[w1 [Hrf Hext]] HIR]]. assert (is_read e1) as Hr1. apply ran_rf_is_read with E w1; auto. split; auto. left; intros [w2 [Hrf2 Hint]]. destruct_rf_wf Hrfwf; generalize (Hex_uni e1 Hr1); intros [? Huni]. generalize (Huni w1 w2 Hrf Hrf2); intro Heq. rewrite <- Heq in Hint; apply (int_ext_contrad Hint Hext). Qed. Lemma mscaob_lob'_is_pgcb_or_lob' E si lob e1 e2 : rf_well_formed E -> lob_well_formed E si lob -> rel_seq (maybe (scaob E si)) (lob' E lob) e1 e2 -> preorder_gcb E si lob e1 e2 \/ lob' E lob e1 e2. Proof. intros Hrfwf Hlobwf [e [Hm Hlob']]; inversion Hm as [Heq | Hsi]. rewrite <- Heq in Hlob'; right; auto. left; apply scaob_lob'_is_pgcb_or_lob'; auto; exists e; auto. Qed. Lemma mop_lob'_in_lob'_or_br E co si lob e1 e2 e3 : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> maybe (transitive_closure (rel_seq (obsplus E co) (si E))) e1 e2 -> lob' E lob e2 e3 -> lob' E lob e1 e3 \/ big_rel E co si lob e1 e3. Proof. intros Hsiwf Hrfwf Hcowf Hlobwf H12 H23; generalize (pre_mop_lob'_in_lob'_or_br si Hsiwf Hrfwf Hcowf H12 H23); intros [Hlob' | Hseq]; [left |]; auto. destruct Hseq as [a [H1a [b [Hab Hb3]]]]. generalize (scaob_lob'_is_pgcb_or_lob' Hrfwf Hlobwf Hb3); intros Hpgcb. right; unfold big_rel. unfold tc_mobs_r_mobs. unfold mobs_r_mobs. apply _base; exists b; split. inversion H1a as [Heq1a | Hs1a]. rewrite Heq1a; right; apply _base; exists b; split; auto. destruct Hab as [x [[Heqax | Hax] Hxb]]. rewrite Heqax; apply _base; left; auto. apply _trans with x; auto. inversion Hax as [Hco | Hfr]; right; [left | right]; auto. apply _base; left; auto. destruct_siwf Hsiwf; apply Hrefl; auto. right; apply tc_trans with a; auto. apply _base; exists b; split. destruct Hab as [x [[Heqax | Hax] Hxb]]. rewrite Heqax; apply _base; left; auto. apply _trans with x; auto. inversion Hax as [Hco | Hfr]; right; [left | right]; auto. apply _base; left; auto. destruct_siwf Hsiwf; apply Hrefl; auto. exists e3; split; [|left]; auto. Qed. Lemma br_trans E co si lob e1 e2 e3 : big_rel E co si lob e1 e2 -> big_rel E co si lob e2 e3 -> big_rel E co si lob e1 e3. Proof. intros H12 H23. apply tc_trans with e2; auto. Qed. Lemma br_mop_in_br E co si lob e1 e2 e3 : big_rel E co si lob e1 e2 -> maybe (transitive_closure (rel_seq (obsplus E co) (si E))) e2 e3 -> big_rel E co si lob e1 e3. Proof. intros Hbr12 Hmop23; induction Hbr12 as [e1 e2 Hb | e1 e2 e H1e]. destruct Hb as [e [He1e [e'[Hee' He'2]]]]; apply _base; exists e; split; auto; exists e'; split; auto. generalize Hmop23; generalize He'2; apply maybe_tc_trans. apply br_trans with e; auto; apply _base; auto. Qed. Lemma lob'_seq_lob'_in_pgcb_or_lob' E si lob e1 e2 e3: lob_well_formed E si lob -> lob' E lob e1 e2 -> lob' E lob e2 e3 -> (preorder_gcb E si lob) e1 e3 \/ lob' E lob e1 e3. Proof. intros Hlobwf [Hlob12 [Hw1 Hrr1]] [Hlob23 [Hw2 Hrr2]]; destruct_lob_wf Hlobwf. assert (lob E e1 e3) as H13. apply (Htrans_lob e1 e2 e3 Hlob12 Hlob23). generalize (excluded_middle (read_requirements E lob e1 e3)); intros [Hrr | Hnrr]. left; left; split; auto. right; split; auto. Qed. Lemma pgcb_lob'_in_pgcb_or_lob' E si lob e1 e2 e3 : lob_well_formed E si lob -> (preorder_gcb E si lob) e1 e2 -> lob' E lob e2 e3 -> rel_seq (maybe (scaob E si)) (preorder_gcb E si lob) e1 e3 \/ rel_seq (maybe (scaob E si)) (lob' E lob) e1 e3. Proof. intros Hlobwf Hpgcb H23; generalize Hlobwf; intro Hlobwf'; destruct_lob_wf Hlobwf'. inversion Hpgcb as [Hpgcb12 | Hsirr]. left; exists e1; split; [left | left]; auto; destruct Hpgcb12 as [H12 Hor12]; destruct H23 as [H23 [Hr2 Hnrr]]. assert (lob E e1 e3) as Hlob13. apply (Htrans_lob e1 e2 e3 H12 H23). destruct Hor12 as [Hw1|[Hr1 Hrr]]; split; auto. right; split; auto. inversion Hrr as [Hext | Hint]; [left | right]; auto. destruct Hint as [w1 [Hrfi Hlob]]; exists w1; split; auto. apply (Htrans_lob w1 e2 e3 Hlob H23). right; exists e2; split; auto; right; auto. Qed. Lemma br_lob'_in_br_or_lob' E co si lob e1 e2 e3 : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> big_rel E co si lob e1 e2 -> lob' E lob e2 e3 -> big_rel E co si lob e1 e3 \/ lob' E lob e1 e3. Proof. intros Hsiwf Hrfwf Hcowf Hlobwf H12 H23; induction H12 as [e1 e2 [e [H1e [e' [Hee' He'2]]]] | e1 e2 e H1e He2]. generalize (mop_lob'_in_lob'_or_br Hsiwf Hrfwf Hcowf Hlobwf He'2 H23); clear He'2 H23; intros [He'3 | He'3]. (*e',e3 in lob'*) generalize (pgcb_lob'_in_pgcb_or_lob' Hlobwf Hee' He'3); intros [Hpgcbe3 | Hlob'e3]. destruct Hpgcbe3 as [e0 [Hee0 H03]]; inversion Hee0 as [Heqee0 | Hsee0]; clear Hee0; left. rewrite Heqee0 in H1e; apply _base; exists e0; split; auto; exists e3; split; auto; left; auto. apply tc_trans with e0; apply _base. exists e; split; auto; exists e0; split; [|left]; auto; right; auto. exists e0; split; [left|exists e3; split; [|left]]; auto. generalize (mscaob_lob'_is_pgcb_or_lob' Hrfwf Hlobwf Hlob'e3); intros [Hpgcb | Hlob']. left; apply _base; exists e; split; auto; exists e3; split; auto; left; auto. generalize (mop_lob'_in_lob'_or_br Hsiwf Hrfwf Hcowf Hlobwf H1e Hlob'); intros [? |?]; auto. (*e',e3 in br*) left; apply _trans with e'; auto; exists e; split; auto; exists e'; split; [|left]; auto. (*inductive case*) generalize (IHHe2 H23); intros [Hbre3 | Hlob'e3]. left; apply br_trans with e; auto; apply _base; auto. clear IHHe2 H23 He2 e2. destruct H1e as [x [H1x [y [Hxy Hye]]]]. generalize (mop_lob'_in_lob'_or_br Hsiwf Hrfwf Hcowf Hlobwf Hye Hlob'e3); clear Hye Hlob'e3 e; intros [Hy3 | Hy3]. (*y,e3 in lob'*) generalize (pgcb_lob'_in_pgcb_or_lob' Hlobwf Hxy Hy3); intros [Hpgcbx3 | Hlob'x3]. destruct Hpgcbx3 as [e0 [Hee0 H03]]; inversion Hee0 as [Heqee0 | Hsee0]; clear Hee0; left. rewrite Heqee0 in H1x; apply _base; exists e0; split; auto; exists e3; split; auto; left; auto. apply tc_trans with e0; apply _base. exists x; split; auto; exists e0; split; [|left]; auto; right; auto. exists e0; split; [left|exists e3; split; [|left]]; auto. generalize (mscaob_lob'_is_pgcb_or_lob' Hrfwf Hlobwf Hlob'x3); intros [Hpgcb | Hlob']. left; apply _base; exists x; split; auto; exists e3; split; auto; left; auto. generalize (mop_lob'_in_lob'_or_br Hsiwf Hrfwf Hcowf Hlobwf H1x Hlob'); intros [? |?]; auto. (*y,e3 in br*) left; apply _trans with y; auto; exists x; split; auto; exists y; split; [|left]; auto. Qed. Lemma pgcb_mbr_in_br E co si lob e1 e2 e3 : (preorder_gcb E si lob) e1 e2 -> maybe (big_rel E co si lob) e2 e3 -> big_rel E co si lob e1 e3. Proof. intros H12 [Heq23 | H23]. rewrite <- Heq23; apply _base; exists e1; split; [left | exists e2; split; [ | left]]; auto. induction H23. apply br_trans with e0; apply _base; auto. exists e1; split; [left | exists e0; split; [|left]]; auto. apply br_trans with e; auto; apply br_trans with e0; apply _base; auto. exists e1; split; [left | exists e0; split; [|left]]; auto. Qed. Lemma gcb_path_ob_dec (E : set Event) (co si lob : set Event -> Rln Event) (e1 e2 : Event) : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> ob E co (si E) (lob E) e1 e2 -> transitive_closure (rel_seq (obsplus E co) (si E)) e1 e2 \/ big_rel E co si lob e1 e2 \/ rel_seq (lob' E lob) (maybe (big_rel E co si lob)) e1 e2 \/ rel_seq (lob' E lob) (maybe (transitive_closure (rel_seq (obsplus E co) (si E)))) e1 e2. Proof. intros Hsiwf Hrfwf Hcowf Hlobwf H12. induction H12 as [e1 e3 [e2 [Hobs Hsi]] | e1 e2 Hlob |]; auto. (*e1,e2 in obs*) left; apply _base; exists e2; split; auto; apply _base; auto. (*e1,e2 in lob*) generalize (lob_implies_pgcb_or_lob' e1 e2 Hlobwf Hlob); intros [Hpgcb | Hlob']; right; [left; apply pgcb_in_big_rel | right; left; apply lob'_in_lob'_seq_big_rel]; auto. (*inductive case*) clear H12_ H12_0; inversion IHob1 as [Hmop1e | [Hbr1e | [Hlob'1e | Hlob'1e]]]; clear IHob1. (*e1,e in obs+*) inversion IHob2 as [Hmop2 | [Hbre2 | Hlob'e2]]; clear IHob2. (*e,e2 in obs+*) left; apply tc_trans with e; auto. (*e,e2 in br*) right; left; apply mop_br_in_br with e; auto; right; auto. (*e,e2 in lob';mbr U lob';mop*) assert (maybe (transitive_closure (rel_seq (obsplus E co) (si E))) e1 e) as Hmmop1e. right; auto. inversion Hlob'e2 as [Hee2 | Hee2]; clear Hlob'e2; destruct Hee2 as [e' [Hlob'ee' Hbre'2]]; generalize (mop_lob'_in_lob'_or_br Hsiwf Hrfwf Hcowf Hlobwf Hmmop1e Hlob'ee'); intros [Hlob'1' | Hbr1']; right. right; left; exists e'; split; auto. left; inversion Hbre'2 as [Heq | Hbr]; [rewrite <- Heq | apply br_trans with e']; auto. right; right; exists e'; split; auto. left; inversion Hbre'2 as [Heq | Hbr]; [rewrite <- Heq | apply br_mop_in_br with e'; auto; right; apply _base; auto]; auto. (*e1,e in br*) inversion IHob2 as [Hmop2 | [Hbre2 | Hlob'e2]]; clear IHob2. (*e,e2 in op*) right; left; apply br_mop_in_br with e; auto; right; auto. (*e,e2 in br*) right; left; apply br_trans with e; auto. (*e,e2 in lob';mbr U lob';mop*) inversion Hlob'e2 as [Hee2 | Hee2]; clear Hlob'e2; destruct Hee2 as [e' [Hee' He'2]]; generalize (br_lob'_in_br_or_lob' Hsiwf Hrfwf Hcowf Hlobwf Hbr1e Hee'); clear Hbr1e Hee' e; intros [Hbr1' | Hlob1']; right. left; inversion He'2 as [Heqe'2 | Hbre'2]; clear He'2; [rewrite Heqe'2 in Hbr1'|apply br_trans with e']; auto. right; left; exists e'; auto. left; apply br_mop_in_br with e'; auto. right; right; exists e'; split; auto. (*e1,e in lob';mbr*) destruct Hlob'1e as [e' [H1e' He'e]]; inversion IHob2 as [Hmop2 | [Hbre2 | Hlob'e2]]; clear IHob2. (*e,e2 in op*) inversion He'e as [Heqe'e | Hbre'e]; clear He'e; right; right; [right; rewrite Heqe'e in H1e'; exists e; split | left; exists e'; split; auto; right; apply br_mop_in_br with e]; auto; right; auto. (*e,e2 in br*) right; right; left; exists e'; split; auto; inversion He'e as [Heqe'e | Hbre'e]; clear He'e; auto; right; [rewrite Heqe'e | apply br_trans with e]; auto. (*e,e2 in lob;mbr U lob;mop*) inversion Hlob'e2 as [He2 | He2]; clear Hlob'e2; destruct He2 as [e'' [Hee'' He''2]]; inversion He'e as [Heqe'e | Hbre'e]; clear He'e. rewrite Heqe'e in H1e'; generalize (lob'_seq_lob'_in_pgcb_or_lob' Hlobwf H1e' Hee''); clear e Heqe'e H1e' Hee''; intros [Hpgcb1'' | Hlob'1'']; right; [left; apply pgcb_mbr_in_br with e''; auto | right; left; exists e''; auto]. generalize (br_lob'_in_br_or_lob' Hsiwf Hrfwf Hcowf Hlobwf Hbre'e Hee''); clear Hbre'e Hee'' e; intros [Hbre'e'' | Hlobe'e'']. right; right; left; exists e'; split; auto. inversion He''2 as [Heq''2 | Hbre''2]; clear He''2. rewrite Heq''2 in Hbre'e''; right; auto. right; apply br_trans with e''; auto. generalize (lob'_seq_lob'_in_pgcb_or_lob' Hlobwf H1e' Hlobe'e''); clear e' H1e' Hlobe'e''; intros [Hmpgcb1'' | Hlob'1'']. right; left; apply pgcb_mbr_in_br with e''; auto. right; right; left; exists e''; split; auto. (*e,e2 in lob;mop*) rewrite Heqe'e in H1e'; generalize (lob'_seq_lob'_in_pgcb_or_lob' Hlobwf H1e' Hee''); clear e Heqe'e H1e' Hee''; intros [Hpgcb1'' | Hlob'1'']; right; [left; apply _base; exists e1; split; [left | exists e''; split]; auto | right; right; exists e''; split; auto]. generalize (br_lob'_in_br_or_lob' Hsiwf Hrfwf Hcowf Hlobwf Hbre'e Hee''); clear Hbre'e Hee'' e; intros [Hbre'e'' | Hlob'e'e'']. right; right; left; exists e'; split; auto; right; apply br_mop_in_br with e''; auto. generalize (lob'_seq_lob'_in_pgcb_or_lob' Hlobwf H1e' Hlob'e'e''); intros [Hpgcb | Hlob]; clear H1e' Hlob'e'e''. right; left; apply _base; exists e1; split; [left|exists e'']; auto. right; right; right; exists e''; split; auto. (*e,1e in lob';mop*) inversion IHob2 as [Hmop2 | [Hbre2 | Hlob'e2]]; clear IHob2; destruct Hlob'1e as [e' [H1' H'e]]. (*e,e2 in obs+*) right; right; right; exists e'; split; auto. inversion H'e as [Heq'e | Hop'e]; clear H'e; [rewrite Heq'e; right|right; generalize Hmop2; generalize Hop'e; apply tc_trans]; auto. (*e,e2 in br*) right; right; left; exists e'; split; auto. right; apply mop_br_in_br with e; auto. (*e,e2 in lob';mbr U lob';mop*) inversion Hlob'e2 as [He2 | He2]; destruct He2 as [e'' [He'' H''2]]; generalize (mop_lob'_in_lob'_or_br Hsiwf Hrfwf Hcowf Hlobwf H'e He''); clear H'e He''; intros [Hlob | Hbr]. (*e',e'' in lob'*) generalize (lob'_seq_lob'_in_pgcb_or_lob' Hlobwf H1' Hlob); clear H1' Hlob; intros [Hpgcb | Hlob]; right. (*e1,e'' in pgcb*) left; apply pgcb_mbr_in_br with e''; auto. (*e1,e'' in lob'*) right; left; exists e''; auto. (*e',e'' in br*) right; right; left; exists e'; split; auto; inversion H''2 as [Heq | Hbr''2]; clear H''2; [rewrite Heq in Hbr; right | right; apply br_trans with e'']; auto. (*e',e'' in lob*) generalize (lob'_seq_lob'_in_pgcb_or_lob' Hlobwf H1' Hlob); clear H1' Hlob; intros [Hpgcb | Hlob]; right. (*e1,e'' in pgcb*) left; apply _base; exists e1; split; [left |]; auto; exists e''; split; auto. (*e1,e'' in lob'*) right; right; exists e''; auto. (*e',e'' in br*) right; right; left; exists e'; split; auto; right; apply br_mop_in_br with e''; auto. Qed. (** * External Global Completion -> External Visibility lemmas *) Lemma rf_in_dgcb E si gcb : rel_equal (rf E) (gcb_rf E (dgcb_loc E (MemC E si) gcb)) -> rel_incl (rf E) (delift (MemC E si) gcb). Proof. intros Hrfeq x y Hrf; destruct Hrfeq as [Hrfincl ?]; generalize (Hrfincl x y Hrf); intros [? [? [? [? [? [? [Hxy ?]]]]]]]; auto; destruct Hxy as [? [? [? ?]]]; auto. Qed. Lemma co_in_dgcb E co si gcb : rel_equal (co E) (gcb_co E (dgcb_loc E (MemC E si) gcb)) -> rel_incl (co E) (delift (MemC E si) gcb). Proof. intros Hcoeq x y Hco; destruct Hcoeq as [Hcoincl ?]; generalize (Hcoincl x y Hco); intros [? [? [? [? [? [? [? [? ?]]]]]]]]; auto. Qed. Lemma erln_is_equiv E si : si_well_formed E (si E) -> rf_well_formed E -> equiv_rel (erln E si). Proof. intros Hsiwf Hrfwf; destruct_siwf Hsiwf; unfold erln; split; [|split]. intro x; generalize (Hrefl x); intro Hsix. assert (M E x) as HMx. apply Hdom; exists x; auto. split; auto; split; auto; split; auto. destruct HMx as [HEx [Hwx | Hrx]]; [left | right]; auto. destruct_rf_wf Hrfwf; generalize (Hex_uni x Hrx); intros [[wx Hrf] Huni]; generalize (dom_rf_in_evts Hrf); intro HEwx. generalize (int_or_ext E wx x HEwx HEx); intros [Hintx | Hextx]. right; exists wx; exists wx; split; auto; split; auto; split; auto. left; split; auto; exists wx; split; auto. intros x y [HMx [HMy [Hsi [[Hwx Hwy] | [[HERx HERy] | [wx [wy [Hrfix [Hrfiy Hsixy]]]] ]]]]]; split; auto; split; auto; split; auto; right; right; exists wy; exists wx; split; auto. intros x y z [HMx [HMy [Hsixy Horxy]]] [HMy' [HMz [Hsiyz Horyz]]]; split; auto; split; auto; split; auto. apply Htrans with y; auto. inversion Horxy as [[Hwx Hwy] | [[HERx HERy] | [wx [wy [Hrfix [Hrfiy ?]]]]]]; clear Horxy; inversion Horyz as [[Hwy' Hwz] | [[HERy' HERz] | [wy' [wz [Hrfiy' [Hrfiz ?]]]]]]; clear Horyz. left; split; auto. destruct HERy' as [wy [Hrf ?]]; generalize (ran_rf_is_read Hrf); intro Hry; generalize (read_write_contrad y Hry Hwy); intro Ht; inversion Ht. destruct Hrfiy' as [Hrf ?]; generalize (ran_rf_is_read Hrf); intro Hry; generalize (read_write_contrad y Hry Hwy); intro Ht; inversion Ht. destruct HERy as [wy [Hrf ?]]; generalize (ran_rf_is_read Hrf); intro Hry; generalize (read_write_contrad y Hry Hwy'); intro Ht; inversion Ht. right; left; split; auto. destruct HERy as [wy [Hrf Hext]]; destruct Hrfiy' as [Hrf' Hint]; generalize (ran_rf_is_read Hrf); intro Hry. destruct_rf_wf Hrfwf; generalize (Hex_uni y Hry); intros [? Huni]; generalize (Huni wy wy' Hrf Hrf'); intro Heq; rewrite <- Heq in Hint; generalize (int_ext_contrad Hint Hext); intro Ht; inversion Ht. destruct Hrfiy as [Hrf ?]; generalize (ran_rf_is_read Hrf); intro Hry; generalize (read_write_contrad y Hry Hwy'); intro Ht; inversion Ht. destruct HERy' as [wy' [Hrf' Hext]]; destruct Hrfiy as [Hrf Hint]; generalize (ran_rf_is_read Hrf); intro Hry. destruct_rf_wf Hrfwf; generalize (Hex_uni y Hry); intros [? Huni]; generalize (Huni wy wy' Hrf Hrf'); intro Heq; rewrite Heq in Hint; generalize (int_ext_contrad Hint Hext); intro Ht; inversion Ht. right; right; exists wx; exists wz; split; auto; split; auto. destruct Hrfiy as [Hrf Hint]; destruct Hrfiy' as [Hrf' Hint']; generalize (ran_rf_is_read Hrf); intro Hry; destruct_rf_wf Hrfwf; generalize (Hex_uni y Hry); intros [? Huni]; generalize (Huni wy wy' Hrf Hrf'); intro Heq; apply Htrans with wy; auto; rewrite Heq; auto. Qed. Lemma delift_trans E si gcb : si_well_formed E (si E) -> rf_well_formed E -> partial_order gcb (MemC E si) -> transitive (delift (MemC E si) gcb). Proof. unfold delift; intros Hsiwf Hrfwf Hpart x y z Hxy Hyz; intros Cx Cz HinCx HinCz HCx HCz; assert (MemC E si = classes (erln E si)) as HeqMemC. auto. generalize (erln_is_equiv si Hsiwf Hrfwf); intro Herln; generalize (class_of_in_classes y Herln HeqMemC); intro HCy; generalize (class_of_refl y Herln); intro Hyy; destruct_part Hpart; apply Htrans with (class_of (erln E si) y); [apply Hxy | apply Hyz]; auto. Qed. Lemma delift_irr E si gcb : si_well_formed E (si E) -> rf_well_formed E -> partial_order gcb (MemC E si) -> forall x : Event, ~ delift (MemC E si) gcb x x. Proof. unfold delift; intros Hsiwf Hrfwf Hpart x Hx; assert (MemC E si = classes (erln E si)) as HeqMemC. auto. generalize (erln_is_equiv si Hsiwf Hrfwf); intro Herln; generalize (class_of_in_classes x Herln HeqMemC); intro HCx; generalize (class_of_refl x Herln); intro Hxx; destruct_part Hpart; apply Hirr with (class_of (erln E si) x); apply Hx; auto. Qed. Lemma in_class_implies_class_of (A:Type) (eqr:Rln A) (Cx:Class A) (x:A) : equiv_rel eqr -> classes eqr Cx -> Cx x -> Cx = class_of eqr x. Proof. unfold classes; unfold class_of; intros Heqr [x' HeqCx] Hx; destruct_eqrln Heqr; apply Extensionality_Ensembles; split; intros e He; unfold In in *|-*. rewrite HeqCx in Hx; rewrite HeqCx in He; apply Htrans with x'; auto. rewrite HeqCx in Hx; rewrite HeqCx; apply Htrans with x; auto. Qed. Lemma not_si_implies_diff_class E si x y : si_well_formed E (si E) -> rf_well_formed E -> ~(si E x y) -> class_of (erln E si) x <> class_of (erln E si) y. Proof. intros Hsiwf Hrfwf Hnsi; intro Heq; apply Hnsi. assert ((class_of (erln E si) x) y) as Hxy. rewrite Heq; apply class_of_refl; apply erln_is_equiv; auto. destruct Hxy as [? [? [? ?]]]; auto. Qed. Lemma fr_implies_not_si E co si x y : co_well_formed E co -> si_well_formed E (si E) -> fr E co x y -> ~(si E x y). Proof. intros Hcowf Hsiwf Hfr; destruct_siwf Hsiwf. generalize (excluded_middle (si E x y)); intros [Hsi |?]; auto. generalize (dom_fr_is_read Hfr); intro Hrx; generalize (ran_fr_is_write Hcowf Hfr); intro Hwy. generalize (Hsym x y Hsi); intro Hsiyx; generalize (Hw y x Hsiyx Hwy); intro Hwx; generalize (read_write_contrad x Hrx Hwx); intro Ht; inversion Ht. Qed. Lemma fr_in_dgcb E co si lob gcb : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> clinearisations (preorder_gcb_lift E si lob (MemC E si)) (MemC E si) gcb -> rel_equal (rf E) (gcb_rf E (dgcb_loc E (MemC E si) gcb)) -> rel_equal (co E) (gcb_co E (dgcb_loc E (MemC E si) gcb)) -> rel_incl (fr E co) (delift (MemC E si) gcb). Proof. intros Hsiwf Hcowf Hrfwf Hlin Hrfeq Hcoeq x y Hfr. unfold delift; intros Cx Cy HinCx HinCy Hx Hy. generalize (erln_is_equiv si Hsiwf Hrfwf); intro Heqr; unfold MemC in HinCx; generalize (in_class_implies_class_of x Heqr HinCx Hx); intro Heqx1. unfold MemC in HinCy; generalize (in_class_implies_class_of y Heqr HinCy Hy); intro Heqy1. generalize (clin_ext_prop (MemC E si) (preorder_gcb_lift E si lob (MemC E si)) gcb); intros [Himpl ?]; generalize (Himpl Hlin); intros [Hincl Hlso]; destruct_lin Hlso. assert (Cx <> Cy) as Hdiff. rewrite Heqx1; rewrite Heqy1. apply not_si_implies_diff_class; auto; apply fr_implies_not_si with co; auto. generalize (Htot Cx Cy Hdiff HinCx HinCy); intros [? | Hyx]; auto. generalize Hfr; intros [w [Hw [Hrf Hco]]]; generalize (rf_in_dgcb Hrfeq Hrf); intro Hgcbwx; generalize (co_in_dgcb co Hcoeq w y Hco); intro Hgcbwy. destruct Hrfeq as [Hinrf ?]; generalize (Hinrf w x Hrf); intros [? [? [? Hnointerv]]]. assert (loc w = loc y) as Hlocwy. apply co_implies_same_loc with E co; auto. assert (loc x = loc y) as Hlocxy. apply fr_implies_same_loc with E co; auto. assert False as Ht. apply Hnointerv; exists y; split; [|split; split]; auto. apply ran_co_is_write with E co w; auto. split; auto. split; auto. apply ran_co_in_evts with co w; auto. split; auto. apply ran_co_in_evts with co w; auto. split; auto. split; auto. unfold delift; intros cy cx Hincy Hincx Hcy Hcx; unfold MemC in Hincx; generalize (in_class_implies_class_of x Heqr Hincx Hcx); intro Heqx2; unfold MemC in Hincy; generalize (in_class_implies_class_of y Heqr Hincy Hcy); intro Heqy2. rewrite Heqx2; rewrite Heqy2; rewrite <- Heqx1; rewrite <- Heqy1; auto. inversion Ht. Qed. Lemma scaob_in_pgcb E si lob : rel_incl (scaob E si) (preorder_gcb E si lob). Proof. intros e1 e2 H12; right; auto. Qed. Lemma big_rel_irr E co si lob gcb x : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> clinearisations (preorder_gcb_lift E si lob (MemC E si)) (MemC E si) gcb -> rel_equal (rf E) (gcb_rf E (dgcb_loc E (MemC E si) gcb)) -> rel_equal (co E) (gcb_co E (dgcb_loc E (MemC E si) gcb)) -> ~(big_rel E co si lob x x). Proof. intros Hsiwf Hrfwf Hcowf Hlin Hrfeq Hcoeq; apply tc_mobs_r_mobs_irr with (erln E si) (MemC E si) gcb; auto. apply erln_is_equiv; auto. intros e1 e2 H12. apply rf_in_dgcb; destruct H12; auto. apply co_in_dgcb; auto. apply fr_in_dgcb with lob; auto. apply scaob_in_pgcb; auto. Qed. Lemma obsp_si_ac E co si lob gcb x : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> clinearisations (preorder_gcb_lift E si lob (MemC E si)) (MemC E si) gcb -> rel_equal (rf E) (gcb_rf E (dgcb_loc E (MemC E si) gcb)) -> rel_equal (co E) (gcb_co E (dgcb_loc E (MemC E si) gcb)) -> ~transitive_closure (rel_seq (obsplus E co) (si E)) x x. Proof. intros Hsiwf Hrfwf Hcowf Hlin Hrfeq Hcoeq Hx. assert (erln E si = erln E si) as Heqt. auto. assert ((MemC E si) = classes (erln E si)) as HeqC. unfold MemC; auto. generalize (erln_is_equiv si Hsiwf Hrfwf); intro Hequivr. assert (rel_incl (rfe E) (delift (MemC E si) gcb)) as Hrfeincl. intros e1 e2 [Hrf ?]; apply (rf_in_dgcb Hrfeq); auto. generalize (co_in_dgcb co Hcoeq); intro Hcoincl. generalize (fr_in_dgcb Hsiwf Hcowf Hrfwf Hlin Hrfeq Hcoeq); intro Hfrincl. assert (rel_incl (scaob E si) (preorder_gcb E si lob)) as Hscaobincl. apply scaob_in_pgcb; auto. generalize (tc_obsp_si_in_order Heqt Hequivr HeqC Hsiwf Hrfwf Hcowf Hlin Hrfeincl Hcoincl Hfrincl Hscaobincl Hx); generalize (clin_ext_prop (MemC E si) (preorder_gcb_lift E si lob (MemC E si)) gcb); intros [Himpl _]; generalize (Himpl Hlin); clear Himpl; intros [Hincl Hlso]; destruct_lin Hlso; destruct_part Hpart; apply Hirr. Qed. (** ** External global completion implies External Visibility *) Lemma external_global_completion_implies_external_visibility (E : set Event) (co si lob : set Event -> Rln Event) : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> internal_visibility E co -> (exists gcb, external_global_completion E co si lob gcb) -> external_visibility E co si lob. (** We show here that: - given a well-formed execution (E, lob, rf, co) - if the [internal_visibility] axiom holds over E, - and there exists an [external_global_completion] External Global Completion order gcb, - then the [external_visibility] axiom holds over E *) Proof. intros Hsiwf Hrfwf Hcowf Hlobwf Hscpv [gcb [Hlin [Hrfeq Hcoeq]]] [x Hx]. (** Reason by contradiction: suppose that the [external_visibility] axiom does not hold over E, viz, there exists x s.t. (x,x) in ob.*) generalize (gcb_path_ob_dec Hsiwf Hrfwf Hcowf Hlobwf Hx); clear Hx; intros [Hmop | [Hbr | [Hlbr | Hlop]]]. (** Now observe (c.f. [gcb_path_ob_dec]) that (x,x) in ob means either: - (x,x) obsplus - (x,x) in big_rel - (x,x) in lob';big_rel? - (x,x) in lob';obs *) (** *** Case 1: (x,x) obsplus*) apply (obsp_si_ac Hsiwf Hrfwf Hcowf Hlin Hrfeq Hcoeq Hmop). (** This is a contradiction of the [internal_visibility] axiom. *) (** *** Case 2: (x,x) in big_rel *) apply (big_rel_irr Hsiwf Hrfwf Hcowf Hlin Hrfeq Hcoeq Hbr); auto. (** This is impossible as big_rel is irreflexive (c.f. [big_rel_irr]). *) (** *** Case 3: (x,x) in lob';big_rel? We reason by case disjunction: - 3a. (x,x) in lob' - 3b. (x,x) in lob';big_rel *) destruct Hlbr as [y [Hxy Hyx]]. inversion Hyx as [Heqyx | Hbryx]; clear Hyx. (** **** Case 3a: (x,x) in lob' *) rewrite Heqyx in Hxy; apply (lob'_irr Hlobwf Hxy). (** This is impossible as lob' is irreflexive (c.f. [lob'_irr]). *) (** **** Case 3b: (x,x) in lob';big_rel In this case by definition there exists y s.t. (x,y) in lob' and (y,x) in big_rel. *) generalize (br_lob'_in_br_or_lob' Hsiwf Hrfwf Hcowf Hlobwf Hbryx Hxy); clear Hbryx Hxy; intros [Hbr | Hlob']. (** Using [br_lob'_in_br_or_lob'] we can reason by case disjunction: - 3bi. (x,x) in big_rel - 3bii. (x,x) in lob'*) (** Case 3bi: (x,x) in big_rel *) apply (big_rel_irr Hsiwf Hrfwf Hcowf Hlin Hrfeq Hcoeq Hbr); auto. (** This is impossible because big_rel is irreflexive (c.f. [big_rel_irr]). *) (** Case 3bii: (x,x) in lob' *) apply (lob'_irr Hlobwf Hlob'). (** This is impossible because lob' is irreflexive (c.f. [lob'_irr]). *) (** *** Case 4: (x,x) in lob';obs* *) destruct Hlop as [y [Hxy Hyx]]. (** By definition this means that there exists y s.t. (x,y) in lob' and (y,x) in obs*. *) generalize (mop_lob'_in_lob'_or_br Hsiwf Hrfwf Hcowf Hlobwf Hyx Hxy); intros [Hlob' | Hbr]. (** Therefore (y,y) in obs*;(lob'|br). *) (** case where (y,y) in obs*;lob'.*) (** Now observe that (c.f. [mop_lob'_in_lob']) this entails (y,y) in lob'. *) apply (lob'_irr Hlobwf Hlob'). (** case where (y,y) in br*) apply (big_rel_irr Hsiwf Hrfwf Hcowf Hlin Hrfeq Hcoeq Hbr); auto. (** This is impossible since lob' is irreflexive (c.f. [lob'_irr]). *) Qed. (** * External Visibility -> External Global Completion lemmas *) (** We show here that: - given a well-formed execution (E, lob, rf, co) - if the internal visibility axiom holds - if the external visibility axiom holds - then there exists a External Global Completion external global completion order gcb.*) (** To do so we need to exhibit an order gcb that satisfies the requirements given in [external_global_completion]. Observe that (c.f. [pre_egc_partial_order]) the relation [pre_egc] is a partial order. Using the order extension principle (c.f. [order_ext]) we can extend pre_egc to a total order that we call gcb. Using [external_global_completion_gcb] we then show that gcb satisfies the [external_global_completion] requirement.*) Definition pre_egc E co si lob := transitive_closure (rel_union (rel_seq (rf E) (erln E si)) (rel_union (rel_seq (co E) (erln E si)) (rel_union (rel_seq (fr E co) (erln E si)) (preorder_gcb E si lob)))). Definition big_rel2 E co si lob := transitive_closure (rel_seq (maybe (transitive_closure (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si))))) (rel_seq (rel_seq (erln E si) (rel_seq (preorder_gcb E si lob) (erln E si))) (maybe (transitive_closure (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si))))))). Lemma transitive_maybe_tc r : transitive (maybe (transitive_closure r)). Proof. intros e1 e2 e3 [Heq12 | H12] [Heq23 | H23]. left; rewrite Heq12; auto. right; rewrite Heq12; auto. right; rewrite <- Heq23; auto. right; apply tc_trans with e2; auto. Qed. Lemma rfi_erln_is_erln_rfi E si w1 e1 e2 : si_well_formed E (si E) -> rf_well_formed E -> rfi E w1 e1 -> erln E si e1 e2 -> (exists w2, erln E si w1 w2 /\ rfi E w2 e2). Proof. intros Hsiwf Hrfwf Hrfiwe1 [HM1 [HM2 [Hsi12 Hor12]]]. inversion Hor12 as [[Hw1 Hw2] | [[HER1 HER2] | Hrfisw12]]; clear Hor12. destruct Hrfiwe1 as [Hrf ?]; generalize (ran_rf_is_read Hrf); intro Hr1; generalize (read_write_contrad e1 Hr1 Hw1); intro Ht; inversion Ht. destruct Hrfiwe1 as [Hrf Hint]; destruct HER1 as [w' [Hrf' Hext]]; generalize (ran_rf_is_read Hrf); intro Hr1; destruct_rf_wf Hrfwf; generalize (Hex_uni e1 Hr1); intros [? Huni]; generalize (Huni w1 w' Hrf Hrf'); intro Heq; rewrite <- Heq in Hext; generalize (int_ext_contrad Hint Hext); intro Ht; inversion Ht. destruct Hrfisw12 as [w' [w2 [Hrfi1 [Hrfi2 Hsiw12]]]]; exists w2; split; auto. destruct Hrfiwe1 as [Hrf ?]; destruct Hrfi1 as [Hrf' ?]; generalize (ran_rf_is_read Hrf); intro Hr1; destruct_rf_wf Hrfwf; generalize (Hex_uni e1 Hr1); intros [? Huni]; generalize (Huni w1 w' Hrf Hrf'); intro Heq; rewrite <- Heq in Hsiw12; split; [| split; [|split]]; auto. split; [apply dom_rf_in_evts with e1 | left; apply dom_rf_is_write with E e1]; auto. destruct Hrfi2; split; [apply dom_rf_in_evts with e2 | left; apply dom_rf_is_write with E e2]; auto. destruct Hrfi2; left; split; [apply dom_rf_is_write with E e1 | apply dom_rf_is_write with E e2]; auto. Qed. Lemma rfi_obs_in_obsp E co si w r e : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> rfi E w r -> obs E co r e -> obsplus E co w e. Proof. intros Hsiwf Hcowf Hrfwf Hwr Hre. inversion Hre as [Hrfe | [Hco | Hfr]]; clear Hre. assert (is_read r) as Hr. apply ran_rf_is_read with E w; destruct Hwr; auto. assert (is_write r) as Hw. apply dom_rf_is_write with E e; destruct Hrfe; auto. generalize (read_write_contrad r Hr Hw); intro Ht; inversion Ht. assert (is_read r) as Hr. apply ran_rf_is_read with E w; destruct Hwr; auto. assert (is_write r) as Hw. apply dom_co_is_write with E co e; auto. generalize (read_write_contrad r Hr Hw); intro Ht; inversion Ht. left; right; left; apply rf_fr_is_co with r; auto; destruct Hwr; auto. Qed. Lemma rfi_obsp_in_obsp E co si w r e : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> rfi E w r -> obsplus E co r e -> obsplus E co w e. Proof. intros Hsiwf Hcowf Hrfwf Hwr Hre. induction Hre as [r e Hre|]. apply rfi_obs_in_obsp with si r; auto. apply tc_trans with e; auto; apply rfi_obs_in_obsp with si e1; auto. Qed. Lemma rfi_erln_obsp_in_erln_obsp E (co si : set Event -> Rln Event) e1 e e0 e2 : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> rfi E e1 e0 -> erln E si e0 e -> obsplus E co e e2 -> rel_seq (erln E si) (obsplus E co) e1 e2. Proof. intros Hsiwf Hcowf Hrfwf H10 H0e He2. generalize (rfi_erln_is_erln_rfi Hsiwf Hrfwf H10 H0e); clear H10 H0e; intros [we [H0we Hrfi]]; exists we; split; auto; apply rfi_obsp_in_obsp with si e; auto. Qed. Lemma rf_erln_obsp_erln_in_tc E (co si : set Event -> Rln Event) e1 e e0 e2 : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> rf E e1 e0 -> erln E si e0 e -> (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si))) e e2 -> transitive_closure (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si))) e1 e2. Proof. intros Hsiwf Hcowf Hrfwf H10 H0e He2; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl [? Htrans]]. assert (E e1) as HE1. apply dom_rf_in_evts with e0; auto. assert (E e0) as HE0. apply ran_rf_in_evts with e1; auto. generalize (int_or_ext E e1 e0 HE1 HE0); intros [Hint | Hext]. assert (rfi E e1 e0) as Hrfi. split; auto. destruct He2 as [x [Hex [y [Hxy Hy2]]]]. assert (erln E si e0 x) as He0x. apply Htrans with e; auto. generalize (rfi_erln_obsp_in_erln_obsp Hsiwf Hcowf Hrfwf Hrfi He0x Hxy); intros [r1 [H0r1 Hr1y]]. apply _base; exists r1; split; auto; exists y; auto. apply tc_trans with e; apply _base; auto. exists e1; split; auto; exists e0; split; auto; left; left; auto; split; auto. Qed. Lemma rf_tc_erln_obsp_erln_in_tc E (co si : set Event -> Rln Event) e1 e e0 e2 : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> rf E e1 e0 -> erln E si e0 e -> transitive_closure (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si))) e e2 -> transitive_closure (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si))) e1 e2. Proof. intros Hsiwf Hcowf Hrfwf H10 H0e He2; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl [? Htrans]]; induction He2. apply rf_erln_obsp_erln_in_tc with e2 e0; auto. generalize (rf_erln_obsp_erln_in_tc Hsiwf Hcowf Hrfwf H10 H0e H0); intros H1e; apply tc_trans with e; auto. Qed. Lemma tc_dec2 r e1 e3 : transitive_closure r e1 e3 -> exists e2, r e1 e2 /\ maybe (transitive_closure r) e2 e3. Proof. intros H13; induction H13. exists e2; split; auto; left; auto. exists e; split; auto; right; auto. Qed. Lemma rfi_pgcb_is_pgcb E si lob e1 e2 e3 : rf_well_formed E -> rfi E e1 e2 -> preorder_gcb E si lob e2 e3 -> preorder_gcb E si lob e1 e3. Proof. intros Hrfwf [Hrf12 Hint12]; generalize (ran_rf_is_read Hrf12); intros Hr2 [[Hlob23 Hreqs] | Hscaob]. inversion Hreqs as [Hw2 | [_ Hrr23]]; [generalize (read_write_contrad e2 Hr2 Hw2); intro Ht; inversion Ht | inversion Hrr23 as [Hext | Hint]; clear Hrr23]. assert False as Ht. apply Hext; exists e1; split; auto. inversion Ht. destruct Hint as [w' [[Hrf' ?] Hlob]]; destruct_rf_wf Hrfwf; generalize (Hex_uni e2 Hr2); intros [? Huni]; generalize (Huni e1 w' Hrf12 Hrf'); intro Heq. rewrite Heq; left; split; auto; left; apply dom_rf_is_write with E e2; auto. destruct Hscaob as [? [[w2 [Hrf2 Hext2]] He3]]. destruct_rf_wf Hrfwf; generalize (Hex_uni e2 Hr2); intros [Hex Huni]; generalize (Huni e1 w2 Hrf12 Hrf2); intro Heq12; rewrite Heq12 in Hint12; generalize (int_ext_contrad Hint12 Hext2); intro Ht; inversion Ht. Qed. Lemma rf_base_br2_in_br2 E co si lob e1 e0 e x e2 : si_well_formed E (si E) -> rf_well_formed E -> rf E e1 e0 -> erln E si e0 e -> rel_seq (rel_seq (erln E si) (rel_seq (preorder_gcb E si lob) (erln E si))) (maybe (transitive_closure (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si))))) e x -> maybe (transitive_closure (rel_seq (maybe (transitive_closure (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si))))) (rel_seq (rel_seq (erln E si) (rel_seq (preorder_gcb E si lob) (erln E si))) (maybe (transitive_closure (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si)))))))) x e2 -> big_rel2 E co si lob e1 e2. Proof. intros Hsiwf Hrfwf H1e0 He0e Hex Hx2; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl [Hsym Htrans]]; assert (E e1) as HE1. apply dom_rf_in_evts with e0; auto. assert (E e0) as HE0. apply ran_rf_in_evts with e1; auto. generalize (int_or_ext E e1 e0 HE1 HE0); intros [Hint | Hext]. assert (rfi E e1 e0) as Hrfi. split; auto. generalize (rfi_erln_is_erln_rfi Hsiwf Hrfwf Hrfi He0e); clear Hrfi He0e; intros [w [H1w Hwe]]. destruct Hex as [e' [Hee' He'x]]. destruct Hee' as [a [Hea [b [Hab Hbe']]]]. generalize (rfi_erln_is_erln_rfi Hsiwf Hrfwf Hwe Hea); clear Hwe Hea; intros [wa [Herlnwa Hrfia]]. assert (erln E si e1 wa) as Herlne1wa. apply Htrans with w; auto. clear H1w Herlnwa. generalize (rfi_pgcb_is_pgcb Hrfwf Hrfia Hab); clear Hrfia Hab; intro Hpgcbwab. inversion Hx2 as [Heqx2 | Htcx2]; clear Hx2. rewrite Heqx2 in He'x; apply _base; exists e1; split; [left|]; auto. exists e'; split; auto; exists wa; split; auto; exists b; split; auto. apply _trans with x; auto. exists e1; split; [left|]; auto. exists e'; split; auto; exists wa; split; auto; exists b; split; auto. assert (rfe E e1 e0) as Hrfe. split; auto. inversion Hx2 as [Heqx2 | Htcx2]; clear Hx2. rewrite Heqx2 in Hex; clear Heqx2; apply _base; exists e; split; auto; right; apply _base; exists e1; split; auto; exists e0; split; auto; left; left; auto. apply _trans with x; auto; exists e; split; auto; right; apply _base; exists e1; split; auto; exists e0; split; auto; left; left; auto. Qed. Lemma rf_br2_in_br2 E (co si lob : set Event -> Rln Event) e1 e e0 e2 : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> rf E e1 e0 -> erln E si e0 e -> big_rel2 E co si lob e e2 -> (big_rel2 E co si lob) e1 e2. Proof. intros Hsiwf Hcowf Hrfwf H1e0 He0e He2; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl [Hsym Htrans]]; generalize (tc_dec2 He2); clear He2; intros [x [[y [Hey Hex]] He2]]. inversion Hey as [Heqey | Htcey]; clear Hey. rewrite <- Heqey in Hex; clear Heqey. apply rf_base_br2_in_br2 with e0 e x; auto. inversion He2 as [Heqxe2 | Htcxe2]; clear He2. rewrite Heqxe2 in Hex; clear Heqxe2. apply _base; exists y; split; auto; right; apply rf_tc_erln_obsp_erln_in_tc with e e0; auto. apply tc_trans with x; auto. apply _base; exists y; split; auto; right; apply rf_tc_erln_obsp_erln_in_tc with e e0; auto. Qed. Lemma co_br2_in_br2 E (co si lob : set Event -> Rln Event) e1 e e0 e2 : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> co E e1 e0 -> erln E si e0 e -> big_rel2 E co si lob e e2 -> big_rel2 E co si lob e1 e2. Proof. intros Hsiwf Hrfwf Hcowf H1e0 He0e He2; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl ?]. apply tc_seq_left with e; auto. apply transitive_maybe_tc. right; apply _base; exists e1; split; auto; exists e0; split; auto; left; right; left; auto. Qed. Lemma fr_br2_in_br2 E (co si lob : set Event -> Rln Event) e1 e e0 e2 : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> fr E co e1 e0 -> erln E si e0 e -> big_rel2 E co si lob e e2 -> big_rel2 E co si lob e1 e2. Proof. intros Hsiwf Hrfwf Hcowf H1e0 He0e He2; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl ?]. apply tc_seq_left with e; auto. apply transitive_maybe_tc. right; apply _base; exists e1; split; auto; exists e0; split; auto; left; right; right; auto. Qed. Definition nrel E co si lob := maybe (transitive_closure (rel_union (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si))) (rel_seq (erln E si)(rel_seq (preorder_gcb E si lob) (erln E si))))). Lemma rfi_erln_base_nrel_in_nrel_irr E co si lob e1 e2 e3 e4 : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> rfi E e1 e2 -> erln E si e2 e3 -> rel_union (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si))) (rel_seq (erln E si) (rel_seq (preorder_gcb E si lob) (erln E si))) e3 e4 -> (transitive_closure (rel_union (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si))) (rel_seq (erln E si) (rel_seq (preorder_gcb E si lob) (erln E si))))) e1 e4. Proof. intros Hsiwf Hcowf Hrfwf Hrfi Herln [Heoe | Hpgcbe]. destruct Hrfi as [Hrf ?]; generalize (rf_erln_obsp_erln_in_tc Hsiwf Hcowf Hrfwf Hrf Herln Heoe); intro H14. apply tc_incl with (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si))); auto. intros x y Hxy; left; auto. destruct Hpgcbe as [x [H3x [y [Hxy Hy4]]]]. generalize (erln_is_equiv si Hsiwf Hrfwf); intros [? [? Htrans]]. assert (erln E si e2 x) as H2x. apply Htrans with e3; auto. clear Herln H3x. generalize (rfi_erln_is_erln_rfi Hsiwf Hrfwf Hrfi H2x); clear Hrfi H2x; intros [wx [Hrfi Hwxx]]. apply _base; right; exists wx; split; auto; exists y; split; auto. apply rfi_pgcb_is_pgcb with x; auto. Qed. Lemma rfi_erln_base_nrel_in_nrel E co si lob e1 e2 e3 e4 : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> rfi E e1 e2 -> erln E si e2 e3 -> rel_union (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si))) (rel_seq (erln E si) (rel_seq (preorder_gcb E si lob) (erln E si))) e3 e4 -> nrel E co si lob e1 e4. Proof. intros Hsiwf Hcowf Hrfwf Hrfi Herln [Heoe | Hpgcbe]. destruct Hrfi as [Hrf ?]; generalize (rf_erln_obsp_erln_in_tc Hsiwf Hcowf Hrfwf Hrf Herln Heoe); intro H14. right; apply tc_incl with (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si))); auto. intros x y Hxy; left; auto. destruct Hpgcbe as [x [H3x [y [Hxy Hy4]]]]. generalize (erln_is_equiv si Hsiwf Hrfwf); intros [? [? Htrans]]. assert (erln E si e2 x) as H2x. apply Htrans with e3; auto. clear Herln H3x. generalize (rfi_erln_is_erln_rfi Hsiwf Hrfwf Hrfi H2x); clear Hrfi H2x; intros [wx [Hrfi Hwxx]]. right; apply _base; right; exists wx; split; auto; exists y; split; auto. apply rfi_pgcb_is_pgcb with x; auto. Qed. Lemma rf_erln_nrel_in_nrel_irr E co si lob e1 e2 e3 e4 : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> rf E e1 e2 -> erln E si e2 e3 -> nrel E co si lob e3 e4 -> (transitive_closure (rel_union (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si))) (rel_seq (erln E si) (rel_seq (preorder_gcb E si lob) (erln E si))))) e1 e4 \/ (rel_seq (rfi E) (erln E si)) e1 e4. Proof. intros Hsiwf Hcowf Hrfwf H12 H23 H34. assert (E e1) as HE1. apply dom_rf_in_evts with e2; auto. assert (E e2) as HE2. apply ran_rf_in_evts with e1; auto. generalize (int_or_ext E e1 e2 HE1 HE2); intros [Hint | Hext]. (*rfi*) assert (rfi E e1 e2) as Hrfi12. split; auto. clear H12 Hint. inversion H34 as [Heq | Htc]; clear H34. right; rewrite <- Heq; exists e2; split; auto. generalize (tc_dec2 Htc); clear Htc; intros [e [He3e Hee4]]. inversion Hee4 as [Heqee4 | Htcee4]; clear Hee4. rewrite Heqee4 in He3e; clear Heqee4; left. apply rfi_erln_base_nrel_in_nrel_irr with e2 e3; auto. left; generalize (rfi_erln_base_nrel_in_nrel_irr Hsiwf Hcowf Hrfwf Hrfi12 H23 He3e); clear Hrfi12 H23 He3e; intro H1e. apply tc_trans with e; auto. (*rfe*) assert (rfe E e1 e2) as Hrfe12. split; auto. clear H12 Hext. generalize (erln_is_equiv si Hsiwf Hrfwf); intros [? ?]; auto. left; inversion H34 as [Heq34 | Htc34]; clear H34. rewrite Heq34 in H23; clear Heq34. apply _base; left; exists e1; split; auto. exists e2; split; auto; left; left; auto. apply tc_trans with e3; auto. apply _base; left; exists e1; split; auto; exists e2; split; auto; left; left; auto. Qed. Lemma rf_erln_nrel_in_nrel E co si lob e1 e2 e3 e4 : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> rf E e1 e2 -> erln E si e2 e3 -> nrel E co si lob e3 e4 -> nrel E co si lob e1 e4 \/ (rel_seq (rfi E) (erln E si)) e1 e4. Proof. intros Hsiwf Hcowf Hrfwf H12 H23 H34. assert (E e1) as HE1. apply dom_rf_in_evts with e2; auto. assert (E e2) as HE2. apply ran_rf_in_evts with e1; auto. generalize (int_or_ext E e1 e2 HE1 HE2); intros [Hint | Hext]. (*rfi*) assert (rfi E e1 e2) as Hrfi12. split; auto. clear H12 Hint. inversion H34 as [Heq | Htc]; clear H34. right; rewrite <- Heq; exists e2; split; auto. generalize (tc_dec2 Htc); clear Htc; intros [e [He3e Hee4]]. inversion Hee4 as [Heqee4 | Htcee4]; clear Hee4. rewrite Heqee4 in He3e; clear Heqee4; left. apply rfi_erln_base_nrel_in_nrel with e2 e3; auto. left; right; generalize (rfi_erln_base_nrel_in_nrel Hsiwf Hcowf Hrfwf Hrfi12 H23 He3e); clear Hrfi12 H23 He3e; intro H1e. inversion H1e as [Heq1e | Htc1e]; clear H1e. rewrite Heq1e; auto. apply tc_trans with e; auto. (*rfe*) assert (rfe E e1 e2) as Hrfe12. split; auto. clear H12 Hext. generalize (erln_is_equiv si Hsiwf Hrfwf); intros [? ?]; auto. left; inversion H34 as [Heq34 | Htc34]; clear H34. rewrite Heq34 in H23; clear Heq34. right; apply _base; left; exists e1; split; auto. exists e2; split; auto; left; left; auto. right; apply tc_trans with e3; auto. apply _base; left; exists e1; split; auto; exists e2; split; auto; left; left; auto. Qed. Lemma co_erln_seq_nrel_in_nrel E (co: set Event -> Rln Event) si lob e1 e' e a : si_well_formed E (si E) -> rf_well_formed E -> co E e1 e' -> erln E si e' e -> nrel E co si lob e a -> nrel E co si lob e1 a. Proof. intros Hsiwf Hrfwf H1e' He'e Hor; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl ?]; inversion Hor as [Hea | Hea]; clear Hor; right. rewrite <- Hea; clear Hea; apply _base; left; exists e1; split; auto; exists e'; split; auto; left; right; left; auto. apply _trans with e; auto; left; exists e1; split; auto; exists e'; split; auto; left; right; left; auto. Qed. Lemma fr_erln_seq_nrel_in_nrel E co si lob e1 e' e a : si_well_formed E (si E) -> rf_well_formed E -> fr E co e1 e' -> erln E si e' e -> nrel E co si lob e a -> nrel E co si lob e1 a. Proof. intros Hsiwf Hrfwf H1e' He'e Hor; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl ?]; inversion Hor as [Hea | Hea]; clear Hor; right. rewrite <- Hea; clear Hea; apply _base; left; exists e1; split; auto; exists e'; split; auto; left; right; right; auto. apply _trans with e; auto; left; exists e1; split; auto; exists e'; split; auto; left; right; right; auto. Qed. Lemma pgcb_seq_nrel_in_nrel E co si lob e1 e a : si_well_formed E (si E) -> rf_well_formed E -> (preorder_gcb E si lob) e1 e -> nrel E co si lob e a -> nrel E co si lob e1 a. Proof. intros Hsiwf Hrfwf H1e Hor; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl ?]; inversion Hor as [Hea | Hea]; clear Hor; right. apply _base; right; exists e1; split; auto; exists a; split; auto; rewrite <- Hea; auto. apply _trans with e; auto; right; exists e1; split; auto; exists e; split; auto. Qed. Lemma pre_egc_dec (E : set Event) (co si lob : set Event -> Rln Event) (e1 e2 : Event) : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> pre_egc E co si lob e1 e2 -> (rel_seq (nrel E co si lob) (rel_seq (rfi E) (erln E si))) e1 e2 \/ transitive_closure (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si))) e1 e2 \/ (big_rel2 E co si lob) e1 e2. Proof. intros Hsiwf Hrfwf Hcowf H12; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl [Hsym Htrans]]. induction H12 as [e1 e2 H12 | e1 e2 e H1e He2]. inversion H12 as [[e' [Hrf1e' Hsie'2]] | [[e' [Hco1e' Hsie'2]] | [[e' [Hfr1e' Hsie'2]] | Hpgcb12]]]; clear H12. assert (E e1) as HE1. apply dom_rf_in_evts with e'; auto. assert (E e') as HE'. apply ran_rf_in_evts with e1; auto. generalize (int_or_ext E e1 e' HE1 HE'); intros [Hint | Hext]. left; exists e1; split; auto; [left|exists e'; split]; auto; split; auto. right; left; apply _base; exists e1; split; auto; exists e'; split; auto; left; auto; left; auto; split; auto. right; left; apply _base; exists e1; split; auto; exists e'; split; auto; left; auto; right; left; auto. right; left; apply _base; exists e1; split; auto; exists e'; split; auto; left; auto; right; right; auto. right; right; apply _base; exists e1; split; auto; [left | exists e2; split; auto]; auto; [exists e1; split; auto; exists e2; split; auto | left; auto]. inversion H1e as [[e' [Hrf1e' Hsie'e]] | [[e' [Hco1e' Hsie'e]] | [[e' [Hfr1e' Hsie'e]] | Hpgcb1e]]]; clear H1e; inversion IHHe2 as [Hnrfie2 | [Hcompluse2 | Hbre2]]; clear IHHe2. destruct Hnrfie2 as [e'' [Hnrel Hrfie]]. generalize (rf_erln_nrel_in_nrel Hsiwf Hcowf Hrfwf Hrf1e' Hsie'e Hnrel); intros He1e''. inversion He1e'' as [Hnrel1e'' | Hrfiee1e'']; clear He1e''. left; exists e''; split; auto. assert (is_write e'') as Hwe''. destruct Hrfie as [r [[He''r ?] ?]]; apply dom_rf_is_write with E r; auto. assert (is_read e'') as Hre''. destruct Hrfiee1e'' as [x [[He1x ?] Hxe'']]; destruct Hxe'' as [? [? [Hsi ?]]]. clear Hrefl Hsym Htrans; destruct_siwf Hsiwf; apply Hr with x; auto; apply ran_rf_is_read with E e1; auto. generalize (read_write_contrad e'' Hre'' Hwe''); intro Ht; inversion Ht. right; left; apply rf_tc_erln_obsp_erln_in_tc with e e'; auto. right; right; apply rf_br2_in_br2 with e e'; auto. destruct Hnrfie2 as [a [Hea Ha2]]; left; exists a; split; auto. apply co_erln_seq_nrel_in_nrel with e' e; auto. right; left; apply tc_trans with e; auto; apply _base; exists e1; split; auto; exists e'; split; auto. left; auto. right; left; auto. right; right; apply co_br2_in_br2 with e e'; auto. destruct Hnrfie2 as [a [Hea Ha2]]; left; exists a; split; auto. apply fr_erln_seq_nrel_in_nrel with e' e; auto. right; left; apply tc_trans with e; auto; apply _base; exists e1; split; auto; exists e'; split; auto. left; right; right; auto. right; right; apply fr_br2_in_br2 with e e'; auto. destruct Hnrfie2 as [a [Hea Ha2]]; left; exists a; split; auto. apply pgcb_seq_nrel_in_nrel with e; auto. right; right; apply _base; exists e1; split; auto; [left | exists e; split; [| right]]; auto. exists e1; split; auto; exists e; split; auto. right; right; apply _trans with e; auto. exists e1; split; auto; [left |]; auto; exists e; split; [|left]; auto. exists e1; split; auto; exists e; split; auto. Qed. Definition obs_extra E co := rel_union (rfe E) (rel_union (co E) (rel_union (fr E co) (rel_union (corfe E co) (frrfe E co)))). Lemma seq_tc_reorg3 r0 r1 r2 r3 e1 e2 e3 : transitive r0 -> rel_incl (rel_seq (rel_seq r0 r2) (rel_seq r0 r3)) (rel_seq (maybe (transitive_closure (rel_seq r0 (rel_seq r1 r0)))) (rel_seq r0 r3)) -> rel_seq r0 (rel_seq (rel_union r1 r2) r0) e1 e2 -> (rel_seq r0 r3) e2 e3 -> rel_seq (maybe (transitive_closure (rel_seq r0 (rel_seq r1 r0)))) (rel_seq r0 r3) e1 e3. Proof. intros Htr0 Hincl [x [H1x [y [Hxy Hy2]]]] H23. inversion Hxy as [Hr1xy | Hr2xy]; clear Hxy. exists e2; split; auto; right; apply _base; exists x; split; auto; exists y; split; auto. apply Hincl; exists y; split; auto. exists x; split; auto. destruct H23 as [e [H2e He3]]; exists e; split; auto; apply Htr0 with e2; auto. Qed. Lemma complus_obs_extra_rln E co : complus E co = rel_union (obs_extra E co) (rel_union (rfi E) (rel_union (rel_seq (co E) (rfi E)) (rel_seq (fr E co) (rfi E)))). Proof. apply Extensionality_Rlns; split; intros e1 e2 H12. inversion H12 as [Hrf | [Hco | [Hfr | [Hcorf | Hfrrf]]]]; clear H12. generalize (dom_rf_in_evts Hrf); intro HEe1; generalize (ran_rf_in_evts Hrf); intro HEe2; generalize (int_or_ext E e1 e2 HEe1 HEe2); intros [Hint | Hext]; [right; left; split; auto | left; left; split; auto]. left; right; left; auto. left; right; right; left; auto. destruct Hcorf as [e [Hco Hrf]]; generalize (dom_rf_in_evts Hrf); intro HEe; generalize (ran_rf_in_evts Hrf); intro HEe2; generalize (int_or_ext E e e2 HEe HEe2); intros [Hint | Hext]. right; right; left; exists e; split; auto; split; auto. left; right; right; right; left; exists e; split; auto; split; auto. destruct Hfrrf as [e [Hco Hrf]]; generalize (dom_rf_in_evts Hrf); intro HEe; generalize (ran_rf_in_evts Hrf); intro HEe2; generalize (int_or_ext E e e2 HEe HEe2); intros [Hint | Hext]. right; right; right; exists e; split; auto; split; auto. left; right; right; right; right; exists e; split; auto; split; auto. inversion H12 as [Hpc | [[Hrf ?] | [[e [Hco [Hrf ?]]] | [e [Hfr [Hrf ?]]]]]]; clear H12. inversion Hpc as [[Hrf ?] | [Hco | [Hfr | [[e [Hco [Hrf ?]]] | [e [Hfr [Hrf ?]]]]]]]. left; auto. right; left; auto. right; right; left; auto. right; right; right; left; exists e; split; auto. right; right; right; right; exists e; split; auto. left; auto. right; right; right; left; exists e; split; auto. right; right; right; right; exists e; split; auto. Qed. Lemma complus_seq_pgcb E co si lob e1 e2 e3 : si_well_formed E (si E) -> rf_well_formed E -> (rel_seq (erln E si) (rel_seq (complus E co) (erln E si))) e1 e2 -> (rel_seq (erln E si) (preorder_gcb E si lob)) e2 e3 -> rel_seq (maybe (transitive_closure (rel_seq (erln E si) (rel_seq (obs_extra E co) (erln E si))))) (rel_seq (erln E si) (preorder_gcb E si lob)) e1 e3. Proof. intros Hsiwf Hrfwf H12 [e'2 [H22' H2'3]]; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl [? Htrans]]. assert (complus E co = rel_union (obs_extra E co) (rel_union (rfi E) (rel_union (rel_seq (co E) (rfi E)) (rel_seq (fr E co) (rfi E)))) ) as Heq. apply complus_obs_extra_rln; auto. rewrite Heq in H12. apply seq_tc_reorg3 with (rel_union (rfi E) (rel_union (rel_seq (co E) (rfi E)) (rel_seq (fr E co) (rfi E)))) e2; auto. Focus 2. exists e'2; split; auto. intros x z [y [[a [Hxa Hay]] [e' [Hye' He'z]]]]; inversion Hay as [Hrfi | [[e [Hco Hrfi]] | [e [Hfr Hrfi]]]]; generalize (rfi_erln_is_erln_rfi Hsiwf Hrfwf Hrfi Hye'); intros [w' [Hae' Hrfi']]. exists x; split; [left | exists w'; split; [apply Htrans with a|]]; auto; apply rfi_pgcb_is_pgcb with e'; auto. exists e; split; [right; apply _base; exists a; split; auto; exists e; split; auto; right; left | exists w'; split; auto; apply rfi_pgcb_is_pgcb with e']; auto. exists e; split; [right; apply _base; exists a; split; auto; exists e; split; auto; right; right; left | exists w'; split; auto; apply rfi_pgcb_is_pgcb with e']; auto. Qed. Lemma rf_obs_extra_is_obs_extra E co e1 e2 e3 : co_well_formed E co -> rf_well_formed E -> rf E e1 e2 -> obs_extra E co e2 e3 -> obs_extra E co e1 e3. Proof. intros Hcowf Hrfwf H12 [Hrfe | [Hco | [Hfr | [Hcorfe | Hfrrfe]]]]. destruct Hrfe as [Hrf23 ?]; generalize (ran_rf_is_read H12); intro Hr2; generalize (dom_rf_is_write Hrf23); intro Hw2; generalize (read_write_contrad e2 Hr2 Hw2); intro Ht; inversion Ht. generalize (ran_rf_is_read H12); intro Hr2; generalize (dom_co_is_write e2 e3 Hcowf Hco); intro Hw2; generalize (read_write_contrad e2 Hr2 Hw2); intro Ht; inversion Ht. right; left; apply rf_fr_is_co with e2; auto. destruct Hcorfe as [e [Hco Hrfe]]; generalize (ran_rf_is_read H12); intro Hr2; generalize (dom_co_is_write e2 e Hcowf Hco); intro Hw2; generalize (read_write_contrad e2 Hr2 Hw2); intro Ht; inversion Ht. destruct Hfrrfe as [e [Hfr Hrfe]]; right; right; right; left; exists e; split; auto; apply rf_fr_is_co with e2; auto. Qed. Lemma seq_incl r0 r1 r2 x y : rel_incl r1 r2 -> rel_seq r0 (rel_seq r1 r0) x y -> rel_seq r0 (rel_seq r2 r0) x y. Proof. intros Hincl [e1 [Hx1 [e2 [H12 H2y]]]]. exists e1; split; auto; exists e2; split; auto. Qed. Lemma seq_tc_reorg4 r0 r1 r2 x y z : transitive r0 -> rel_incl (rel_seq (rel_seq r2 r0) (rel_seq r0 r1)) (rel_seq r0 r1) -> rel_seq r0 (rel_seq (rel_union r1 r2) r0) x y -> rel_seq r0 (rel_seq r1 r0) y z -> transitive_closure (rel_seq r0 (rel_seq r1 r0)) x z. Proof. intros Htr0 Hincl [e1 [Hx1 [e2 [H12 H2y]]]] Hyz; inversion H12 as [Hr112 | Hr212]; clear H12. apply _trans with y; [| apply _base]; auto. exists e1; split; auto; exists e2; split; auto. assert ((rel_seq r2 r0) e1 y) as H1y. exists e2; split; auto. clear Hr212 H2y e2. assert ((rel_seq (rel_seq r0 r1) r0) y z) as Hyz'. destruct Hyz as [a [Hya [b [Hab Hz]]]]. exists b; split; auto; exists a; split; auto. clear Hyz. destruct Hyz' as [e [Hye Hez]]. assert ((rel_seq r0 r1) e1 e) as He1e. apply Hincl; exists y; split; auto. clear H1y Hye y. destruct He1e as [e2 [H12 H2e]]. apply _base; exists e2; split. apply Htr0 with e1; auto. exists e; split; auto. Qed. Lemma seq_tc_reorg5 r0 r1 r2 x y z : transitive r0 -> rel_incl (rel_seq (rel_seq r0 (rel_seq r2 r0)) (rel_seq r0 (rel_seq r1 r0))) (transitive_closure (rel_seq r0 (rel_seq r1 r0))) -> rel_seq r0 (rel_seq (rel_union r1 r2) r0) x y -> rel_seq r0 (rel_seq r1 r0) y z -> transitive_closure (rel_seq r0 (rel_seq r1 r0)) x z. Proof. intros Htr0 Hincl [e1 [Hx1 [e2 [H12 H2y]]]] Hyz. inversion H12 as [Hr112 | Hr212]; clear H12. apply _trans with y; [| apply _base]; auto. exists e1; split; auto; exists e2; split; auto. assert ((rel_seq r0 (rel_seq r2 r0)) x y) as Hxy. exists e1; split; auto; exists e2; auto. clear Hx1 Hr212 H2y. assert ((rel_seq (rel_seq r0 (rel_seq r2 r0)) (rel_seq r0 (rel_seq r1 r0))) x z) as Hxz. exists y; split; auto. clear Hxy Hyz. apply Hincl; auto. Qed. Lemma rfi_erln_obs_extra_erln_red E co si e2 e3 e5 e6 : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> rfi E e2 e3 -> erln E si e3 e5 -> rel_seq (obs_extra E co) (erln E si) e5 e6 -> (rel_seq (erln E si) (rel_seq (obs_extra E co) (erln E si))) e2 e6. Proof. intros Hsiwf Hcowf Hrfwf Hrfi H35 H56. generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl [? Htrans]]. generalize (rfi_erln_is_erln_rfi Hsiwf Hrfwf Hrfi H35); clear Hrfi H35; intros [w5 [H25 Hrfi]]. exists w5; split; auto; clear H25. destruct H56 as [e [H5e He6]]; exists e; split; auto; clear He6. apply rf_obs_extra_is_obs_extra with e5; auto; destruct Hrfi; auto. Qed. Lemma obs_extra_red E co si : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> rel_incl (rel_seq (rel_seq (erln E si) (rel_seq (rel_union (rfi E) (rel_union (rel_seq (co E) (rfi E)) (rel_seq (fr E co) (rfi E)))) (erln E si))) (rel_seq (erln E si) (rel_seq (obs_extra E co) (erln E si)))) ((transitive_closure (rel_seq (erln E si) (rel_seq (obs_extra E co) (erln E si))))). Proof. intros Hsiwf Hcowf Hrfwf e1 e6 [e4 [[e2 [H12 [e3 [H23 H34]]]] [e5 [H45 H56]]]]; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl [? Htrans]]. assert (erln E si e3 e5) as H35. apply Htrans with e4; auto. clear H34 H45 e4. inversion H23 as [Hrfi | [Hcorfi | Hfrrfi]]; clear H23. generalize (rfi_erln_obs_extra_erln_red Hsiwf Hcowf Hrfwf Hrfi H35 H56); intro H26. apply tc_seq_left with e2; auto; apply _base; auto. destruct Hcorfi as [e [H2e Hrfi]]; apply tc_trans with e; [|clear H12 H2e]. apply _base; exists e2; split; auto; exists e; split; auto; right; left; auto. apply _base; apply rfi_erln_obs_extra_erln_red with e3 e5; auto. destruct Hfrrfi as [e [H2e Hrfi]]; apply tc_trans with e; [|clear H12 H2e]. apply _base; exists e2; split; auto; exists e; split; auto; right; right; left; auto. apply _base; apply rfi_erln_obs_extra_erln_red with e3 e5; auto. Qed. Lemma complus_erln_obs_extra_erln E co si e1 e2 e3 : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> (rel_seq (erln E si) (rel_seq (complus E co) (erln E si))) e1 e2 -> rel_seq (erln E si) (rel_seq (obs_extra E co) (erln E si)) e2 e3 -> transitive_closure (rel_seq (erln E si) (rel_seq (obs_extra E co) (erln E si))) e1 e3. Proof. intros Hsiwf Hcowf Hrfwf H12 H23; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl [? Htrans]]. apply seq_tc_reorg5 with (rel_union (rfi E) (rel_union (rel_seq (co E) (rfi E)) (rel_seq (fr E co) (rfi E)))) e2; auto. Focus 2. rewrite <- complus_obs_extra_rln; auto. apply obs_extra_red; auto. Qed. Lemma erln_complus_erln_obs_extra_erln E co si e1 e2 e3 : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> rel_seq (erln E si) (rel_seq (complus E co) (erln E si)) e1 e2 -> rel_seq (erln E si) (rel_seq (obs_extra E co) (erln E si)) e2 e3 -> transitive_closure (rel_seq (erln E si) (rel_seq (obs_extra E co) (erln E si))) e1 e3. Proof. intros Hsiwf Hcowf Hrfwf H12 H23. generalize (complus_erln_obs_extra_erln Hsiwf Hcowf Hrfwf H12 H23); intro H13; auto. Qed. Lemma erln_complus_erln_tc_obs_extra_si E co si e1 e2 e3 : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> rel_seq (erln E si) (rel_seq (complus E co) (erln E si)) e1 e2 -> transitive_closure (rel_seq (erln E si) (rel_seq (obs_extra E co) (erln E si))) e2 e3 -> transitive_closure (rel_seq (erln E si) (rel_seq (obs_extra E co) (erln E si))) e1 e3. Proof. intros Hsiwf Hcowf Hrfwf H12 H23; induction H23; generalize (erln_complus_erln_obs_extra_erln Hsiwf Hcowf Hrfwf H12 H); intro H1e; auto. apply tc_trans with e; auto. Qed. Lemma tc_erln_complus_erln_obs_extra_si E co si e1 e2 e3 : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> transitive_closure (rel_seq (erln E si) (rel_seq (complus E co) (erln E si))) e1 e2 -> rel_seq (erln E si) (rel_seq (obs_extra E co) (erln E si)) e2 e3 -> transitive_closure (rel_seq (erln E si) (rel_seq (obs_extra E co) (erln E si))) e1 e3. Proof. intros Hsiwf Hcowf Hrfwf H12 H23; induction H12. Focus 2. apply erln_complus_erln_tc_obs_extra_si with e; auto. apply erln_complus_erln_tc_obs_extra_si with e2; auto; apply _base; auto. Qed. Lemma obs_extra_in_complus E co x y : (obs_extra E co) x y -> (complus E co) x y. Proof. intros Hobs_extraxy; auto. inversion Hobs_extraxy as [Hrf | [Hco | [Hfr | [Hcorf | Hfrrf]]]]; clear Hobs_extraxy. left; apply rfe_in_rf; auto. right; left; auto. right; right; auto. right; right; right; left; apply corfe_in_corf; auto. right; right; right; right; apply frrfe_in_frrf; auto. Qed. Lemma tc_erln_complus_erln_tc_obs_extra_si E co si e1 e2 e3 : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> transitive_closure (rel_seq (erln E si) (rel_seq (complus E co) (erln E si))) e1 e2 -> transitive_closure (rel_seq (erln E si) (rel_seq (obs_extra E co) (erln E si))) e2 e3 -> transitive_closure (rel_seq (erln E si) (rel_seq (obs_extra E co) (erln E si))) e1 e3. Proof. intros Hsiwf Hcowf Hrfwf H12 H23; induction H23. Focus 2. apply IHtransitive_closure. generalize (tc_erln_complus_erln_obs_extra_si Hsiwf Hcowf Hrfwf H12 H); apply tc_incl; intros x z [y [Hxz [a [Hza Hay]]]]; exists y; split; auto; exists a; split; auto; apply obs_extra_in_complus; auto. apply tc_erln_complus_erln_obs_extra_si with e0; auto. Qed. Lemma mcomplus_seq_obs_extra E co si lob e1 e2 e3 : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> maybe (transitive_closure (rel_seq (erln E si) (rel_seq (complus E co) (erln E si)))) e1 e2 -> (rel_seq (erln E si) (preorder_gcb E si lob)) e2 e3 -> rel_seq (maybe (transitive_closure (rel_seq (erln E si) (rel_seq (obs_extra E co) (erln E si))))) (rel_seq (erln E si) (preorder_gcb E si lob)) e1 e3. Proof. intros Hsiwf Hcowf Hrfwf H12 H23; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl ?]; inversion H12 as [Heq12 | Htc12]; clear H12. rewrite Heq12; exists e2; split; [left|]; auto. induction Htc12 as [e1 e2 H12|]. generalize (complus_seq_pgcb Hsiwf Hrfwf H12 H23); intros [e0 [H10 H03]]; exists e0; split; auto. generalize (IHHtc12 H23); intros [e0 [[Heqee0 | Hee0] He0e3]]. rewrite <- Heqee0 in He0e3; generalize (complus_seq_pgcb Hsiwf Hrfwf H0 He0e3); intros [e' [H1' H'3]]. exists e'; split; auto. exists e0; split; auto; right; apply erln_complus_erln_tc_obs_extra_si with e; auto. Qed. Lemma mcomplus_seq_obs_extra_incl E co si lob : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> rel_incl (rel_seq (maybe (transitive_closure (rel_seq (erln E si) (rel_seq (complus E co) (erln E si))))) (rel_seq (erln E si) (preorder_gcb E si lob))) (rel_seq (maybe (transitive_closure (rel_seq (erln E si) (rel_seq (obs_extra E co) (erln E si))))) (rel_seq (erln E si) (preorder_gcb E si lob))). Proof. intros Hsiwf Hcowf Hrfwf e1 e3 [e2 [H12 H23]]; apply mcomplus_seq_obs_extra with e2; auto. Qed. Lemma erln_scaob_is_scaob E si e1 e2 e3 : si_well_formed E (si E) -> rf_well_formed E -> erln E si e1 e2 -> scaob E si e2 e3 -> scaob E si e1 e3. Proof. intros Hsiwf Hrfwf [? [? [Hsi12 H12]]] [H23 [HE2 HI3]]; destruct_siwf Hsiwf; split; auto. apply Htrans with e2; auto. assert (is_read e2) as Hr2. destruct HE2 as [w2 [Hrf ?]]; apply ran_rf_is_read with E w2; auto. inversion H12 as [[Hw1 Hw2] | [[HER1 HER2] | Hrfisw]]. assert False as Ht. apply read_write_contrad with e2; auto. inversion Ht. split; auto. destruct HE2 as [w2 [Hrf2 Hext2]]. destruct Hrfisw as [? [w2' [? [[Hrf2' Hint2] ?]]]]. destruct_rf_wf Hrfwf; generalize (Hex_uni e2 Hr2); intros [? Huni]; generalize (Huni w2 w2' Hrf2 Hrf2'); intro Heq; rewrite <- Heq in Hint2. generalize (int_ext_contrad Hint2 Hext2); intro Ht; inversion Ht. Qed. Lemma erln_pgcb_in_dec E (co si lob : set Event -> Rln Event) e1 e2 : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> rel_seq (erln E si) (preorder_gcb E si lob) e1 e2 -> rel_union (scaob E si) (rel_seq (rel_union (erln E si) (scaob E si)) (ob E co (si E) (lob E))) e1 e2. Proof. intros Hsiwf Hrfwf Hcowf H12. destruct H12 as [e [H1e He3]]; generalize H1e; intros [? [? [Hsi1e ?]]]; generalize Hsiwf; intro Hsiwf'; destruct_siwf Hsiwf'; inversion He3 as [[Hlob ?] | Hscaob]; clear He3. right; exists e; split; auto; [left | apply _lob]; auto. left; apply erln_scaob_is_scaob with e; auto. Qed. Lemma ob_erln_in_ob E (co si lob : set Event -> Rln Event) x y z : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> ob E co (si E) (lob E) x y -> erln E si y z -> ob E co (si E) (lob E) x z. Proof. intros Hsiwf Hrfwf Hcowf Hlobwf Hxy Hyz; destruct_siwf Hsiwf. induction Hxy as [e1 e3 [e2 [H12 H23]] | |]. apply _obs; exists e2; split; auto; apply Htrans with e3; destruct Hyz as [? [? [Hsi ?]]]; auto. destruct_lob_wf Hlobwf; apply _lob; apply Hlob_erln; exists e2; split; auto. apply _ob with e; auto. Qed. Lemma ob_scaob_in_ob E (co si lob : set Event -> Rln Event) x y z : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> ob E co (si E) (lob E) x y -> (scaob E si) y z -> ob E co (si E) (lob E) x z. Proof. intros Hsiwf Hrfwf Hcowf Hlobwf Hxy Hyz; destruct_siwf Hsiwf. induction Hxy as [e1 e3 [e2 [H12 H23]] | |]. apply _obs; exists e2; split; auto; apply Htrans with e3; destruct Hyz as [Hsi ?]; auto. destruct_lob_wf Hlobwf; apply _lob; apply Hlob_scaob; exists e2; split; auto. apply _ob with e; auto. Qed. Lemma ob_erln_union_scaob_in_ob E (co si lob : set Event -> Rln Event) x y z : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> ob E co (si E) (lob E) x y -> rel_union (erln E si) (scaob E si) y z -> ob E co (si E) (lob E) x z. Proof. intros Hsiwf Hrfwf Hcowf Hlobwf Hxy [Hyz | Hyz]; [apply ob_erln_in_ob with y | apply ob_scaob_in_ob with y]; auto. Qed. Lemma obs_extra_in_ob E (co si lob : set Event -> Rln Event) e1 e2 : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> (obs_extra E co) e1 e2 -> ob E co (si E) (lob E) e1 e2. Proof. intros Hsiwf Hrfwf Hcowf; destruct_siwf Hsiwf; intros [Hrfe | [Hco | [Hfr | [[e [Hco Hrfe]] | [e [Hfr Hrfe]]]]]]. apply _obs; exists e2; split; auto; left; auto. apply _obs; exists e2; split; auto; right; left; auto. apply _obs; exists e2; split; auto; right; right; auto. apply _ob with e; auto; apply _obs. exists e; split; auto; right; left; auto. exists e2; split; auto; left; auto. apply _ob with e; auto; apply _obs. exists e; split; auto; right; right; auto. exists e2; split; auto; left; auto. Qed. Lemma erln_obs_extra_erln_in_dec E (co si lob : set Event -> Rln Event) e1 e4 : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> rel_seq (erln E si) (rel_seq (obs_extra E co) (erln E si)) e1 e4 -> rel_union (scaob E si) (rel_seq (rel_union (erln E si) (scaob E si)) (ob E co (si E) (lob E))) e1 e4. Proof. intros Hsifwf Hrfwf Hcowf Hlobwf [e2 [H12 [e3 [H23 H34]]]]. right; exists e2; split; [left |]; auto. destruct H12 as [? [? [Hsi ?]]]; auto. apply ob_erln_in_ob with e3; auto; apply obs_extra_in_ob; auto. Qed. Lemma scaob_erln_is_scaob E si e1 e2 e3 : si_well_formed E (si E) -> rf_well_formed E -> scaob E si e1 e2 -> erln E si e2 e3 -> scaob E si e1 e3. Proof. intros Hsiwf Hrfwf [Hsi12 [HER1 HIR2]] [? [? [Hsi23 H23]]]; destruct_siwf Hsiwf; split. apply Htrans with e2; auto. assert (is_read e2) as Hr2. destruct HIR2 as [w2 [Hrf2 Hint2]]; apply ran_rf_is_read with E w2; auto. split; auto. inversion H23 as [[Hw2 Hw3] | [[HER2 HER3] | Hrfisw]]. generalize (read_write_contrad e2 Hr2 Hw2); intro Ht; inversion Ht. destruct HIR2 as [w2 [Hrf2 Hint2]]; destruct HER2 as [w2' [Hrf2' Hext2]]; destruct_rf_wf Hrfwf; generalize (Hex_uni e2 Hr2); intros [? Huni]; generalize (Huni w2 w2' Hrf2 Hrf2'); intro Heq; rewrite <- Heq in Hext2; generalize (int_ext_contrad Hint2 Hext2); intro Ht; inversion Ht. destruct Hrfisw as [? [w3 [? [Hrfi3 ?]]]]; exists w3; auto. Qed. Lemma scaob_scaob_contrad E si e1 e2 e3 : rf_well_formed E -> scaob E si e1 e2 -> scaob E si e2 e3 -> False. Proof. intros Hrfwf [? [? [w2 [Hrf2 Hint]]]] [? [[w2' [Hrf2' Hext]] ?]]; assert (is_read e2) as Hr2. apply ran_rf_is_read with E w2; auto. destruct_rf_wf Hrfwf; generalize (Hex_uni e2 Hr2); intros [? Huni]; generalize (Huni w2 w2' Hrf2 Hrf2'); intro Heq; rewrite <- Heq in Hext; generalize (int_ext_contrad Hint Hext); intro Ht; inversion Ht. Qed. Lemma dec_trans E (co si lob : set Event -> Rln Event) e1 e2 e3 : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> rel_union (scaob E si) (rel_seq (rel_union (erln E si) (scaob E si)) (ob E co (si E) (lob E))) e1 e2 -> rel_union (scaob E si) (rel_seq (rel_union (erln E si) (scaob E si)) (ob E co (si E) (lob E))) e2 e3 -> rel_union (scaob E si) (rel_seq (rel_union (erln E si) (scaob E si)) (ob E co (si E) (lob E))) e1 e3. Proof. intros Hsiwf Hrfwf Hcowf Hlobwf [Hsi12 | Hs12] [Hsi23 | Hs23]. destruct Hsi12 as [? [? [w2 [Hrf2 Hint]]]]; destruct Hsi23 as [? [[w2' [Hrf2' Hext]] ?]]; assert (is_read e2) as Hr2. apply ran_rf_is_read with E w2; auto. destruct_rf_wf Hrfwf; generalize (Hex_uni e2 Hr2); intros [? Huni]; generalize (Huni w2 w2' Hrf2 Hrf2'); intro Heq; rewrite <- Heq in Hext; generalize (int_ext_contrad Hint Hext); intro Ht; inversion Ht. destruct Hs23 as [e [[H2e | H2e] He3]]. generalize (scaob_erln_is_scaob Hsiwf Hrfwf Hsi12 H2e); intro H1e; right; exists e; split; auto; right; auto. generalize (scaob_scaob_contrad Hrfwf Hsi12 H2e); intro Ht; inversion Ht. destruct Hs12 as [e [H1e He2]]; generalize (ob_scaob_in_ob Hsiwf Hrfwf Hcowf Hlobwf He2 Hsi23); clear He2 Hsi23; intro He3; right; exists e; split; auto. destruct Hs12 as [e [H1e He2]]; destruct Hs23 as [e' [H2e' He'3]]; generalize (ob_erln_union_scaob_in_ob Hsiwf Hrfwf Hcowf Hlobwf He2 H2e'); clear He2 H2e'; intro Hee'; right; exists e; split; auto; apply _ob with e'; auto. Qed. Lemma dec_is_trans E (co si lob : set Event -> Rln Event) : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> transitive (rel_union (scaob E si) (rel_seq (rel_union (erln E si) (scaob E si)) (ob E co (si E) (lob E)))). Proof. intros Hsiwf Hrfwf Hcowf Hlobwf e1 e2 e3 H12 H23; apply dec_trans with e2; auto. Qed. Lemma trans_equals_tc r : transitive r -> r = transitive_closure r. Proof. intro Htr; apply Extensionality_Rlns; split; intros e1 e2 H12. apply _base; auto. induction H12; auto. apply Htr with e; auto. Qed. Lemma pgcb_mobs_extra_seq_dec E (co si lob : set Event -> Rln Event) e1 e3 : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> rel_seq (rel_seq (erln E si) (preorder_gcb E si lob)) (maybe (transitive_closure (rel_seq (erln E si) (rel_seq (obs_extra E co) (erln E si))))) e1 e3 -> rel_union (scaob E si) (rel_seq (rel_union (erln E si) (scaob E si)) (ob E co (si E) (lob E))) e1 e3. Proof. intros Hsiwf Hrfwf Hcowf Hlobwf [e2 [H12 H23]]; inversion H23 as [Heq23 | Htc23]; clear H23. rewrite Heq23 in H12; clear Heq23; apply erln_pgcb_in_dec; auto. generalize (dec_is_trans Hsiwf Hrfwf Hcowf Hlobwf); intro Hdt; rewrite (trans_equals_tc Hdt). induction Htc23 as [x y Hxy |]. Focus 2. generalize (erln_pgcb_in_dec Hsiwf Hrfwf Hcowf H12); intro H10. generalize (erln_obs_extra_erln_in_dec Hsiwf Hrfwf Hcowf Hlobwf H); intro H0e. assert (rel_incl (rel_seq (erln E si) (rel_seq (obs_extra E co) (erln E si))) (rel_union (scaob E si) (rel_seq (rel_union (erln E si) (scaob E si)) (ob E co (si E) (lob E))))) as Hincl. intros a b Hab; apply erln_obs_extra_erln_in_dec; auto. generalize (tc_incl Hincl Htc23); intros He2. apply tc_trans with e0; auto. apply _base; auto. apply tc_trans with e; auto; apply _base; auto. apply tc_trans with x; auto; apply _base. apply erln_pgcb_in_dec; auto. apply erln_obs_extra_erln_in_dec; auto. Qed. Lemma tc_pgcb_mobs_extra_dec E (co si lob aob : set Event -> Rln Event) x y : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> internal_visibility E co -> transitive_closure (rel_seq (rel_seq (erln E si) (preorder_gcb E si lob)) (maybe (transitive_closure (rel_seq (erln E si) (rel_seq (obs_extra E co) (erln E si)))))) x y -> rel_union (scaob E si) (rel_seq (rel_union (erln E si) (scaob E si)) (ob E co (si E) (lob E))) x y. Proof. intros Hsiwf Hrfwf Hcowf Hlobwf Hint_vis Hxy. generalize (dec_is_trans Hsiwf Hrfwf Hcowf Hlobwf); intro Hdt; rewrite (trans_equals_tc Hdt). generalize Hxy; apply tc_incl. intros a b Hab; apply pgcb_mobs_extra_seq_dec; auto. Qed. Lemma mcomplus_seq_obs_extra_seq_pgcb E co si lob e' e2 e'' e3 : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> maybe (transitive_closure (rel_seq (erln E si) (rel_seq (complus E co) (erln E si)))) e' e2 -> transitive_closure (rel_seq (erln E si) (rel_seq (obs_extra E co) (erln E si))) e2 e'' -> (rel_seq (erln E si)(preorder_gcb E si lob)) e'' e3 -> rel_seq (maybe (transitive_closure (rel_seq (erln E si) (rel_seq (obs_extra E co) (erln E si))))) (rel_seq (erln E si)(preorder_gcb E si lob)) e' e3. Proof. intros Hsiwf Hrfwf Hcowf H'2 H2'' H''3. apply mcomplus_seq_obs_extra_incl; auto. inversion H'2 as [Heq'2 | Htc'2]; clear H'2. rewrite Heq'2; exists e''; split; auto. right; generalize H2''; apply tc_incl; intros x y [e [Hxe [e0 [Hee0 He0y]]]]; exists e; split; auto; exists e0; split; auto. apply obs_extra_in_complus; auto. generalize (tc_erln_complus_erln_tc_obs_extra_si Hsiwf Hcowf Hrfwf Htc'2 H2''); intro He'e''; exists e''; split; auto. right; generalize He'e''; apply tc_incl; intros x y [e [Hxe [e0 [Hee0 He0y]]]]; exists e; split; auto; exists e0; split; auto. apply obs_extra_in_complus; auto. Qed. Lemma complus_seq_tc E (co si lob aob : set Event -> Rln Event) x y z : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> internal_visibility E co -> external_visibility E co si lob -> (maybe (transitive_closure (rel_seq (erln E si) (rel_seq (complus E co) (erln E si))))) x y -> transitive_closure (rel_seq (maybe (transitive_closure (rel_seq (erln E si) (rel_seq (obs_extra E co) (erln E si))))) (rel_seq (erln E si) (preorder_gcb E si lob))) y z -> transitive_closure (rel_seq (maybe (transitive_closure (rel_seq (erln E si) (rel_seq (obs_extra E co) (erln E si))))) (rel_seq (erln E si) (preorder_gcb E si lob))) x z. Proof. intros Hsiwf Hrfwf Hcowf Hlobwf Hintv Hextv Hxy Hyz. induction Hyz. Focus 2. apply _trans with e; auto. destruct H as [e' [H1' H'e]]; inversion H1' as [Heq1' | Hobs_extra1']; clear H1'. rewrite Heq1' in Hxy; apply mcomplus_seq_obs_extra with e'; auto. apply mcomplus_seq_obs_extra_seq_pgcb with e1 e'; auto. destruct H as [e' [H1' H'e]]; inversion H1' as [Heq1' | Hobs_extra1']; clear H1'. apply _base; rewrite Heq1' in Hxy; apply mcomplus_seq_obs_extra with e'; auto. apply _base; apply mcomplus_seq_obs_extra_seq_pgcb with e1 e'; auto. Qed. (** ** The relation pre_egc is a partial order over events viz, - it is defined over events - it is transitive - it is irreflexive *) Lemma ran_si_in_evts E si x y : si_well_formed E (si E) -> si E x y -> E y. Proof. intros Hsiwf Hxy; destruct_siwf Hsiwf. assert (ran (si E) y) as Hrany. exists x; auto. generalize (Hran y Hrany); intros [? ?]; auto. Qed. Lemma pre_egc_in_evts (E : set Event) (co si lob : set Event -> Rln Event) : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> Included Event (Union Event (dom (pre_egc E co si lob)) (ran (pre_egc E co si lob))) E. Proof. (** The relation pre_egc is defined over events and transitive: since pre_egc is defined as the transitive closure of a union of relations over events, it is trivially defined over events and trivially transitive. *) intros Hsiwf Hrfwf Hcowf Hlobwf; apply r_in_evts_implies_tc_in_evts; intros _x [x Hdom | y Hran]. destruct Hdom as [e Hxe]; inversion Hxe as [[y [Hrf ?]] | [[y [Hco ?]] | [[y [Hfr ?]] | [[Hlob ?] | Hscaob]]]]. apply dom_rf_in_evts with y; auto. apply dom_co_in_evts with co y; auto. apply dom_fr_in_evts with co y; auto. destruct_lob_wf Hlobwf; apply dom_po_in_evts with e; auto. destruct Hscaob as [? [[wx [Hrfx ?]] ?]]; apply ran_rf_in_evts with wx; auto. destruct Hran as [e Hey]; inversion Hey as [[x [? Hsi]] | [[x [? Hsi]] | [[x [? Hsi]] | [[Hlob ?] | Hscaob]]]]. destruct Hsi as [? [? [? ?]]]; apply ran_si_in_evts with si x; auto. destruct Hsi as [? [? [? ?]]]; apply ran_si_in_evts with si x; auto. destruct Hsi as [? [? [? ?]]]; apply ran_si_in_evts with si x; auto. destruct_lob_wf Hlobwf; apply ran_po_in_evts with e; auto. destruct Hscaob as [? [? [wy [Hrfy ?]]]]; apply ran_rf_in_evts with wy; auto. Qed. Lemma tc_seq_split r1 r2 x y : transitive r1 -> transitive_closure (rel_seq r1 (rel_seq r2 r1)) x y -> exists e, r1 x e /\ transitive_closure (rel_seq r2 r1) e y. Proof. intros Htr1 Hxy; induction Hxy; [|clear Hxy]. destruct H as [e [Hxe Hey]]; exists e; split; auto; apply _base; auto. destruct H as [a [H1a Hae]]; destruct IHHxy as [b [Heb Hb2]]; exists a; split; auto. apply _trans with b; auto. destruct Hae as [c [Hac Hce]]; exists c; split; auto; apply Htr1 with e; auto. Qed. Lemma lrflobw_erln_is_lrflobw E si lob e1 e2 e3 : si_well_formed E (si E) -> lob_well_formed E si lob -> rf_well_formed E -> locally_reads_from_a_lob_write E lob e1 e2 -> erln E si e2 e3 -> locally_reads_from_a_lob_write E lob e1 e3. Proof. intros Hsiwf Hlobwf Hrfwf [w1 [Hrfi1 Hlob2]] H23; destruct_lob_wf Hlobwf; exists w1; split; auto; apply Hlob_erln; exists e2; auto. Qed. Lemma pc_erln_dec (E : set Event) (si lob : set Event -> Rln Event) (e1 e3 : Event) : si_well_formed E (si E) -> lob_well_formed E si lob -> rf_well_formed E -> rel_seq (preorder_gcb E si lob) (erln E si) e1 e3 -> (preorder_gcb E si lob) e1 e3. Proof. intros Hsiwf Hlobwf Hrfwf [e2 [[Hlob12 | Hscaob12] H23]]; generalize Hlobwf; intros Hlobwf'; destruct_lob_wf Hlobwf'. destruct Hlob12 as [Hlob [Hw1 | [Hr1 Hrr12]]]. left; split; auto. apply Hlob_erln; exists e2; split; auto. left; split; auto. apply Hlob_erln; exists e2; split; auto. right; split; auto; inversion Hrr12 as [He | Hi]; clear Hrr12. left; auto. right; auto. apply lrflobw_erln_is_lrflobw with si e2; auto. right; auto. apply scaob_erln_is_scaob with e2; auto. Qed. Lemma nrel_irr_dec E co si lob x z : si_well_formed E (si E) -> lob_well_formed E si lob -> rf_well_formed E -> transitive_closure (rel_union (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si))) (rel_seq (erln E si) (rel_seq (preorder_gcb E si lob) (erln E si)))) x z -> rel_seq (erln E si) (transitive_closure (rel_union (rel_seq (obsplus E co) (erln E si)) (preorder_gcb E si lob))) x z. Proof. intros Hsiwf Hlobwf Hrfwf Hxz; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl [Hsym Htrans]]; induction Hxz as [x z Hxz |]. inversion Hxz as [[y [Ho Hy]] | [y [Hpc Hy]]]; clear Hxz; exists y; split; auto; apply _base; [left | right; apply pc_erln_dec]; auto. inversion H as [[x [Hx Ho]] | [x [Hx Hpc]]]; clear H Hxz; destruct IHHxz as [y [Hy Htc]]; exists x; split; auto; apply _trans with y; auto. destruct Ho as [z [Ho Hz]]; left; exists z; split; auto; apply Htrans with z; auto; apply Htrans with e; auto. destruct Hpc as [z [Hpc Hz]]. assert (rel_seq (preorder_gcb E si lob) (erln E si) x y) as Hobs_extra. exists z; split; auto; apply Htrans with z; auto; apply Htrans with e; auto. right; apply pc_erln_dec; auto. Qed. Lemma tc_eoe_is_e_seq_tc_oe E co si x z : si_well_formed E (si E) -> rf_well_formed E -> transitive_closure (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si))) x z -> exists y, erln E si x y /\ transitive_closure (rel_seq (obsplus E co) (erln E si)) y z. Proof. intros Hsiwf Hrfwf Hxz; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl [Hsym Htrans]]; induction Hxz. destruct H as [y [H1y Hy2]]; exists y; split; auto; apply _base; auto. clear Hxz; destruct H as [a [H1a Hae]]; destruct IHHxz as [b [Heb Hb2]]; exists a; split; auto; apply _trans with b; auto. destruct Hae as [x [Hax Hxe]]; exists x; split; auto; apply Htrans with e; auto. Qed. Lemma oe_mtc_eoe_in_tc E co si a b e2 r: si_well_formed E (si E) -> rf_well_formed E -> rel_seq (obsplus E co) (erln E si) a b -> maybe (transitive_closure (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si)))) b e2 -> transitive_closure (rel_union (rel_seq (obsplus E co) (erln E si)) r) a e2. Proof. intros Hsiwf Hrfwf Hab [Heq | Htcb2]; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl [Hsym Htrans]]. rewrite Heq in Hab; apply _base; left; auto. generalize (tc_eoe_is_e_seq_tc_oe Hsiwf Hrfwf Htcb2); clear Htcb2; intros [y [Hby Hy2]]. apply _trans with y; auto. left; destruct Hab as [x [Hax Hxb]]; exists x; split; auto; apply Htrans with b; auto. apply tc_incl with (rel_seq (obsplus E co) (erln E si)); auto. intros c d Hcd; left; auto. Qed. Lemma mtc_eoe_e_is_mtc_eoe E co si b x e : si_well_formed E (si E) -> rf_well_formed E -> maybe (transitive_closure (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si)))) b x -> erln E si x e -> maybe (transitive_closure (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si)))) b e \/ erln E si b e. Proof. intros Hsiwf Hrfwf; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl [Hsym Htrans]]; intros [Heqbx | Hbx] Hxe. rewrite Heqbx; clear Heqbx; right; auto. induction Hbx. left; destruct H as [a [H1a [b [Hab Hb2]]]]; right; apply _base; exists a; split; auto; exists b; split; auto; apply Htrans with e2; auto. clear Hbx; generalize (IHHbx Hxe); clear Hxe IHHbx; intros [[Heq0e | Htc] | Herln]. rewrite Heq0e in H; clear Heq0e; left; right; apply _base; auto. left; right; apply _trans with e0; auto. left; right; apply _base; destruct H as [a [H1a [b [Hab Hb0]]]]; exists a; split; auto; exists b; split; auto; apply Htrans with e0; auto. Qed. Lemma br2_base_dec (E : set Event) (co si lob : set Event -> Rln Event) (e1 e2 : Event) : si_well_formed E (si E) -> lob_well_formed E si lob -> rf_well_formed E -> co_well_formed E co -> rel_seq (maybe (transitive_closure (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si))))) (rel_seq (rel_seq (erln E si) (rel_seq (preorder_gcb E si lob) (erln E si))) (maybe (transitive_closure (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si)))))) e1 e2 -> rel_seq (erln E si) (transitive_closure (rel_union (rel_seq (obsplus E co) (erln E si)) (preorder_gcb E si lob))) e1 e2. Proof. intros Hsiwf Hlobwf Hrfwf Hcowf H12; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl [Hsym Htrans]]. destruct H12 as [x [H1x [y [Hxy Hy2]]]]; inversion H1x as [Heq1x | Htc1x]; clear H1x; inversion Hy2 as [Heqy2 | Htcy2]; clear Hy2. rewrite Heq1x; rewrite <- Heqy2; clear Heq1x Heqy2; destruct Hxy as [z [Hxz Hzy]]; exists z; split; auto; apply _base; right; apply (pc_erln_dec Hsiwf Hlobwf Hrfwf Hzy). rewrite Heq1x; clear Heq1x; destruct Hxy as [z [Hxz Hzy]]; exists z; split; auto; clear Hxz. generalize (tc_dec2 Htcy2); clear Htcy2; intros [e [[d [Hyd Hde]] He2]]. assert (rel_seq (preorder_gcb E si lob) (erln E si) z d) as Hzd. destruct Hzy as [z' [Hzz' Hz'y]]; exists z'; split; auto; apply Htrans with y; auto. apply _trans with d; [right; apply pc_erln_dec|apply oe_mtc_eoe_in_tc with e]; auto. rewrite Heqy2 in Hxy; clear Heqy2; destruct Hxy as [z [Hxz Hz2]]; generalize (tc_dec2 Htc1x); clear Htc1x; intros [b [[a [H1a Hab]] Hbx]]; exists a; split; auto; apply tc_trans with z; auto. generalize (mtc_eoe_e_is_mtc_eoe Hsiwf Hrfwf Hbx Hxz); intros [Hmbz | Heqbz]. apply oe_mtc_eoe_in_tc with b; auto. apply _base; left; destruct Hab as [e [Hae Heb]]; exists e; split; auto; apply Htrans with b; auto. apply _base; right; apply pc_erln_dec; auto. destruct Hxy as [z [Hxz Hz2]]; generalize (tc_dec2 Htc1x); clear Htc1x; intros [b [[a [H1a Hab]] Hbx]]; generalize (tc_dec2 Htcy2); clear Htcy2; intros [e [[d [Hyd Hde]] He2]]. exists a; split; auto; clear H1a; generalize (mtc_eoe_e_is_mtc_eoe Hsiwf Hrfwf Hbx Hxz); clear Hbx Hxz; intros [Hmbz | Heqbz]. generalize (oe_mtc_eoe_in_tc (preorder_gcb E si lob) Hsiwf Hrfwf Hab Hmbz); clear Hab Hmbz; intro Haz; apply tc_trans with z; auto; clear Haz. apply _trans with d; auto; [right; apply pc_erln_dec|]; auto. destruct Hz2 as [f [Hzf Hfy]]; exists f; split; auto; apply Htrans with y; auto. apply oe_mtc_eoe_in_tc with e; auto. apply tc_trans with z; auto. apply _base; destruct Hab as [x' [Hax' Hx'b]]; left; exists x'; split; auto; apply Htrans with b; auto. apply _trans with d; auto; [right; apply pc_erln_dec|]; auto. destruct Hz2 as [f [Hzf Hfy]]; exists f; split; auto; apply Htrans with y; auto. apply oe_mtc_eoe_in_tc with e; auto. Qed. Lemma tcu_e_is_tcu E co si lob a e b : si_well_formed E (si E) -> lob_well_formed E si lob -> rf_well_formed E -> transitive_closure (rel_union (rel_seq (obsplus E co) (erln E si)) (preorder_gcb E si lob)) a e -> erln E si e b -> transitive_closure (rel_union (rel_seq (obsplus E co) (erln E si)) (preorder_gcb E si lob)) a b. Proof. intros Hsiwf Hlobwf Hrfwf Hae Heb; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl [Hsym Htrans]]. induction Hae. inversion H as [Ho | Hpc]; clear H. destruct Ho as [a [H1a Ha2]]; apply _base; left; exists a; split; auto. apply Htrans with e2; auto. apply _base; right; apply pc_erln_dec; auto; exists e2; split; auto. apply _trans with e; auto. Qed. Lemma br2_dec (E : set Event) (co si lob : set Event -> Rln Event) (e1 e2 : Event) : si_well_formed E (si E) -> lob_well_formed E si lob -> rf_well_formed E -> co_well_formed E co -> (big_rel2 E co si lob) e1 e2 -> rel_seq (erln E si) (transitive_closure (rel_union (rel_seq (obsplus E co) (erln E si)) (preorder_gcb E si lob))) e1 e2. Proof. intros Hsiwf Hlobwf Hrfwf Hcowf H12; induction H12. apply br2_base_dec; auto. generalize (br2_base_dec Hsiwf Hlobwf Hrfwf Hcowf H); clear H H12; intros [a [H1a Hae]]; exists a; split; auto; clear H1a; destruct IHtransitive_closure as [b [Heb Hb2]]; apply tc_trans with b; auto; clear Hb2. apply tcu_e_is_tcu with e; auto. Qed. Lemma op_si_in_ob (E : set Event) (co si lob : set Event -> Rln Event) x y z : si_well_formed E (si E) -> (obsplus E co) x y -> si E y z -> ob E co (si E) (lob E) x z. Proof. intros Hsiwf Hxy Hyz; induction Hxy. Focus 2. destruct_siwf Hsiwf; apply _ob with e; auto; apply _obs; exists e; split; auto. apply _obs; exists e2; split; auto. Qed. Lemma op_e_in_ob (E : set Event) (co si lob : set Event -> Rln Event) x y : si_well_formed E (si E) -> rel_seq (obsplus E co) (erln E si) x y -> ob E co (si E) (lob E) x y. Proof. intros Hsiwf [e [Hxe [? [? [Hsi ?]]]]]; apply op_si_in_ob with e; auto. Qed. Lemma pc_in_dec (E : set Event) (co si lob : set Event -> Rln Event) (x y : Event) : preorder_gcb E si lob x y -> rel_seq (maybe (scaob E si)) (ob E co (si E) (lob E)) x y \/ rel_seq (scaob E si) (maybe (lob' E lob)) x y. Proof. intros [[Hlob ?] | Hsi]; [left; exists x; split | right]; auto. left; auto. apply _lob; auto. exists y; split; [|left]; auto. Qed. Lemma pc_in_dec2 (E : set Event) (co si lob : set Event -> Rln Event) (x y : Event) : preorder_gcb E si lob x y -> ob E co (si E) (lob E) x y \/ rel_seq (scaob E si) (maybe (lob' E lob)) x y. Proof. intros [[Hlob ?] | Hsi]; [left | right]; auto. apply _lob; auto. exists y; split; [|left]; auto. Qed. Lemma nrr_implies_IR E lob e1 e2 : ~read_requirements E lob e1 e2 -> IR E e1. Proof. unfold read_requirements; intros Hnrr; generalize (not_or_and (does_not_locally_reads_from E e1) (locally_reads_from_a_lob_write E lob e1 e2) Hnrr); clear Hnrr; unfold does_not_locally_reads_from; intros [H1 H2]. generalize (NNPP (IR E e1) H1); auto. Qed. Lemma tc_e_in_ob_or_scaob (E : set Event) (co si lob : set Event -> Rln Event) (x y z : Event) : si_well_formed E (si E) -> lob_well_formed E si lob -> rf_well_formed E -> transitive_closure (rel_union (rel_seq (obsplus E co) (erln E si)) (preorder_gcb E si lob)) x y -> erln E si y z -> rel_seq (maybe (scaob E si)) (ob E co (si E) (lob E)) x z \/ rel_seq (scaob E si) (maybe (lob' E lob)) x z. Proof. intros Hsiwf Hlobwf Hrfwf Hxy Hyz; generalize (tcu_e_is_tcu Hsiwf Hlobwf Hrfwf Hxy Hyz); clear Hxy Hyz; intros Hxz. induction Hxz; [| clear Hxz]. inversion H as [Hobs | Hpc]; clear H; [left; exists e1; split; auto; [left | apply op_e_in_ob]; auto | apply pc_in_dec]; auto. inversion H as [Hobs1e | Hpc1e]; clear H; inversion IHHxz as [Hobe2 | Hsie2]; clear IHHxz. destruct Hobe2 as [b [[Heqeb | [Hsieb ?]] Hb2]]. rewrite Heqeb in Hobs1e; clear Heqeb; left; exists e1; split; auto; [left|apply _ob with b; auto; apply op_e_in_ob]; auto. destruct Hobs1e as [a [H1a [? [? [Hae ?]]]]]; left; exists e1; split; auto; [left|apply _ob with b; auto; apply op_si_in_ob with a; auto; destruct_siwf Hsiwf; apply Htrans with e]; auto. destruct Hsie2 as [b [[Hsi ?] [Heq | [Hlob ?]]]]; destruct Hobs1e as [a [H1a [? [? [Hae ?]]]]]. rewrite Heq in Hsi; clear Heq; left; exists e1; split; auto; [left | apply op_si_in_ob with a; auto; destruct_siwf Hsiwf; apply Htrans with e]; auto. left; exists e1; split; auto; [left | apply _ob with b; auto; [apply op_si_in_ob with a; auto; destruct_siwf Hsiwf; apply Htrans with e | apply _lob]]; auto. inversion Hpc1e as [[Hlob1e ?] | Hscaob]; clear Hpc1e; [left; exists e1; split; auto; [left |]|]; auto. destruct Hobe2 as [b [[Heqeb | Hscaobeb] Hb2]]; apply _ob with b; auto. rewrite Heqeb in Hlob1e; clear Heqeb; apply _lob; auto. destruct_lob_wf Hlobwf; apply _lob; apply Hlob_scaob; exists e; split; auto. destruct Hobe2 as [b [[Heqeb | Hscaobeb] Hb2]]. rewrite Heqeb in Hscaob; clear Heqeb; left; exists b; split; auto; right; auto. generalize (scaob_scaob_contrad Hrfwf Hscaob Hscaobeb); intro Ht; inversion Ht. inversion Hpc1e as [[Hlob1e ?] | Hscaob1e]; clear Hpc1e; destruct Hsie2 as [b [Hscaob [Heq | Hlob']]]. rewrite Heq in Hscaob; clear Heq; left; exists e1; split; [left| apply _lob; destruct_lob_wf Hlobwf; apply Hlob_scaob; exists e; auto]; auto. left; exists e1; split; destruct Hlob' as [Hlob ?]; [left| apply _ob with b; apply _lob; auto; destruct_lob_wf Hlobwf; apply Hlob_scaob; exists e; auto]; auto. generalize (scaob_scaob_contrad Hrfwf Hscaob1e Hscaob); intro Ht; inversion Ht. generalize (scaob_scaob_contrad Hrfwf Hscaob1e Hscaob); intro Ht; inversion Ht. Qed. Lemma ob_scaob E co si lob x y z : si_well_formed E (si E) -> lob_well_formed E si lob -> rf_well_formed E -> ob E co (si E) (lob E) x y -> scaob E si y z -> ob E co (si E) (lob E) x z. Proof. intros Hsiwf Hlobwf Hrfwf Hxy Hyz; induction Hxy. destruct H as [a [Hxa Hay]]; destruct Hyz as [? [? [Hsi ?]]]; apply _obs; exists a; split; auto; destruct_siwf Hsiwf; apply Htrans with e2; auto. destruct_lob_wf Hlobwf; apply _lob; apply Hlob_scaob; exists e2; auto. apply _ob with e; auto. Qed. Lemma scaob_irr E si x : rf_well_formed E -> scaob E si x x -> False. Proof. intros Hrfwf [Hsi [[wx [Hrfx HEx]] [wx' [Hrfx' HIx]]]]. assert (is_read x) as Hrx. apply ran_rf_is_read with E wx; auto. destruct_rf_wf Hrfwf; generalize (Hex_uni x Hrx); intros [? Huni]; generalize (Huni wx wx' Hrfx Hrfx'); intro Heq; rewrite <- Heq in HIx; apply int_ext_contrad with E wx x; auto. Qed. Lemma e_tc_union_irr (E : set Event) (co si lob : set Event -> Rln Event) (x : Event) : si_well_formed E (si E) -> lob_well_formed E si lob -> rf_well_formed E -> external_visibility E co si lob -> rel_seq (erln E si) (transitive_closure (rel_union (rel_seq (obsplus E co) (erln E si)) (preorder_gcb E si lob))) x x -> False. Proof. intros Hsiwf Hlobwf Hrfwf Hev [y [Hxy Hyx]]. generalize (tc_e_in_ob_or_scaob Hsiwf Hlobwf Hrfwf Hyx Hxy); clear Hxy Hyx x; intros [[x [[Heq | Hsi] Hob]] | [x [Hscaob [Heq | Hlob']]]]. rewrite Heq in Hob; clear Heq; apply Hev; exists x; auto. apply Hev; exists x; apply ob_scaob with y; auto. rewrite Heq in Hscaob; clear Heq. apply scaob_irr with E si y; auto. destruct Hlob' as [Hlob ?]; apply Hev; exists x; apply _lob; destruct_lob_wf Hlobwf; apply Hlob_scaob; exists y; auto. Qed. (** ** The relation pre_egc is irreflexive: *) Lemma pre_egc_irr (E : set Event) (co si lob aob : set Event -> Rln Event) : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> internal_visibility E co -> external_visibility E co si lob -> (forall x : Event, ~ pre_egc E co si lob x x). Proof. (** Reason by contradiction and suppose that there exists x s.t. (x,x) in pre_egc.*) intros Hsiwf Hrfwf Hcowf Hlobwf Hint_vis Hext_vis x Hx. generalize (pre_egc_dec Hsiwf Hrfwf Hcowf Hx); clear Hx; intros [Hx|Hx]. (** Observe (c.f. [pre_egc_dec]) that this entails: - either (x,x) in complus - or (x,x) in big_rel2. We then reason by case disjunction. *) (** ** Case 1: (x,x) in nrel;rfi;erln *) destruct Hx as [y [Hxy [z [[Hyz Hint] Hzx]]]]. generalize (rf_erln_nrel_in_nrel_irr Hsiwf Hcowf Hrfwf Hyz Hzx Hxy); clear Hyz Hzx Hxy Hint x z; intros [Hnrel | Hrfie]. generalize (nrel_irr_dec Hsiwf Hlobwf Hrfwf Hnrel); clear Hnrel. apply e_tc_union_irr; auto. destruct Hrfie as [x [[Hrf ?] Herln]]; apply read_write_contrad with y; auto. destruct_siwf Hsiwf; apply Hr with x; auto. destruct Herln as [? [? [Hsi ?]]]; auto. apply ran_rf_is_read with E y; auto. apply dom_rf_is_write with E x; auto. (** This is impossible as complus must be (c.f. [complus_irr]) irreflexive under the [internal_visibility] requirement.*) (** ** Case 2: (x,x) in (e;obs+;e)+ or big_rel2 *) inversion Hx as [Heoe | Hbr2]; clear Hx. generalize (tc_eoe_is_e_seq_tc_oe Hsiwf Hrfwf Heoe); intros [y [Hxy Hyx]]; apply e_tc_union_irr with E co si lob x; auto; exists y; split; auto; apply tc_incl with (rel_seq (obsplus E co) (erln E si)); auto; intros e1 e2 H12; left; auto. apply e_tc_union_irr with E co si lob x; auto; apply br2_dec; auto. Qed. Lemma pre_egc_partial_order (E : set Event) (co si lob aob : set Event -> Rln Event) : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> internal_visibility E co -> external_visibility E co si lob -> partial_order (pre_egc E co si lob) E. Proof. intros Hsiwf Hrfwf Hcowf Hlobwf Hint_vis Hext_vis; split; [|split]. apply pre_egc_in_evts; auto. intros e1 e2 e3 H12 H23; apply tc_trans with e2; auto. apply pre_egc_irr; auto. Qed. Lemma rel_incl_lift (A:Type) (C:set (Class A)) (r1 r2 : Rln A) : rel_incl r1 r2 -> rel_incl (lift C r1) (lift C r2). Proof. unfold lift; intros Hincl C1 C2 [HC1 [HC2 [x [y [Hx1 [Hy2 Hrxy]]]]]]; split; auto; split; auto; exists x; exists y; split; auto. Qed. (** ** A linear extension of the relation pre_egc satisfies the [external_global_completion] requirement viz, - gcb is a linear extension of the preorder_gcb relation - the read-froms extracted from gcb [gcb_rf] are the same as the axiomatic ones [rf] - the coherence extracted from gcb [gcb_co] are the same as the axiomatic ones [co] *) Lemma read_reqs_erln_is_read_reqs E si lob x y z : lob_well_formed E si lob -> read_requirements E lob x y -> erln E si y z -> read_requirements E lob x z. Proof. intros Hlobwf [Hext | [wx [Hrfi Hlob]]] Hyz; [left | right]; auto. exists wx; split; auto. destruct_lob_wf Hlobwf; apply Hlob_erln; exists y; auto. Qed. Lemma lob'_erln_is_lob' E si lob x y z : si_well_formed E (si E) -> rf_well_formed E -> lob_well_formed E si lob -> lob' E lob x y -> erln E si y z -> lob' E lob x z. Proof. intros Hsiwf Hrfwf Hlobwf [Hxy [? Hrr]] Hyz; generalize Hlobwf; intros Hlobwf'; destruct_lob_wf Hlobwf'; split; [|split]; auto. apply Hlob_erln; exists y; auto. generalize (erln_is_equiv si Hsiwf Hrfwf); intros [? [Hsym ?]]; generalize (Hsym y z Hyz); intro Hzy; intro Hreqs. generalize (read_reqs_erln_is_read_reqs Hlobwf Hreqs Hzy); intro Hc; apply Hrr; auto. Qed. Lemma pre_egc_erln_is_pre_egc E co si lob x y z : si_well_formed E (si E) -> rf_well_formed E -> lob_well_formed E si lob -> pre_egc E co si lob x y -> erln E si y z -> pre_egc E co si lob x z. Proof. intros Hsiwf Hrfwf Hlobwf Hxy Hyz; induction Hxy as [x y Hb | x e3 y Htc]. Focus 2. apply _trans with y; auto; unfold pre_egc in IHHxy; generalize (IHHxy Hyz); intro Ht; auto. assert (si E y z) as Hsi. destruct Hyz as [? [? [? ?]]]; auto. generalize (erln_is_equiv si Hsiwf Hrfwf); intros [? [? Htrans]]; inversion Hb as [Hrfsi | [Hcosi | [Hfrsi | Hpc]]]. destruct Hrfsi as [e [Hxe Hey]]; apply _base; left; exists e; split; auto. apply Htrans with y; auto. destruct Hcosi as [e [Hxe Hey]]; apply _base; right; left; exists e; split; auto; apply Htrans with y; auto. destruct Hfrsi as [e [Hxe Hey]]; apply _base; right; right; left; exists e; split; auto; apply Htrans with y; auto. generalize Hlobwf; intro Hlobwf'; destruct_lob_wf Hlobwf'; inversion Hpc as [[Hlob Hreqs] | Hscaob]; clear Hpc; apply _base; right; right; right. left; split. apply Hlob_erln; exists y; split; auto. inversion Hreqs as [Hwx | [Hrx Hrr]]; [left | right; split]; auto. apply read_reqs_erln_is_read_reqs with si y; auto. right; apply scaob_erln_is_scaob with y; auto. Qed. Lemma udr_lift E co si lob : Included (Class Event) (Union (Class Event) (dom (lift (MemC E si) (pre_egc E co si lob))) (ran (lift (MemC E si) (pre_egc E co si lob)))) (MemC E si). Proof. unfold lift; intros ? [Cx [Cy [? ?]] | Cy [Cx [? [? ?]]]]; auto. Qed. Lemma trans_lift E co si lob : si_well_formed E (si E) -> rf_well_formed E -> lob_well_formed E si lob -> partial_order (pre_egc E co si lob) E -> transitive (lift (MemC E si) (pre_egc E co si lob)). Proof. intros Hsiwf Hrfwf Hlobwf Hpart; destruct_part Hpart. unfold lift; intros Cx Cy Cz [HCx [HCy [x [y [Hx [Hy Hxy]]]]]] [? [HCz [y' [z [Hy' [Hz Hy'z]]]]]]; split; auto; split; auto; exists x; exists z; split; auto; split; auto. apply Htrans with y'; auto. unfold MemC in HCy; unfold classes in HCy; unfold class_of in HCy; destruct HCy as [y0 HCy]; rewrite HCy in Hy; rewrite HCy in Hy'. assert (erln E si y y') as Hyy'. generalize (erln_is_equiv si Hsiwf Hrfwf); intro Hequiv; clear Htrans; destruct_eqrln Hequiv; apply Htrans with y0; auto. apply pre_egc_erln_is_pre_egc with y; auto. Qed. Lemma irr_lift E co si lob Cx : si_well_formed E (si E) -> rf_well_formed E -> lob_well_formed E si lob -> partial_order (pre_egc E co si lob) E -> ~ lift (MemC E si) (pre_egc E co si lob) Cx Cx. Proof. intros Hsiwf Hrfwf Hlobwf Hpart; destruct_part Hpart. unfold lift; intros [HCx [? [e1 [e2 [H1 [H2 H12]]]]]]. unfold MemC in HCx; unfold classes in HCx; unfold class_of in HCx; destruct HCx as [x0 HCx]; rewrite HCx in H1; rewrite HCx in H2. assert (erln E si e2 e1) as Hyy'. generalize (erln_is_equiv si Hsiwf Hrfwf); intro Hequiv; clear Htrans; destruct_eqrln Hequiv; apply Htrans with x0; auto. apply Hirr with e1; apply pre_egc_erln_is_pre_egc with e2; auto. Qed. Lemma lift_partial_order E co si lob : si_well_formed E (si E) -> rf_well_formed E -> lob_well_formed E si lob -> partial_order (pre_egc E co si lob) E -> partial_order (lift (MemC E si) (pre_egc E co si lob)) (MemC E si). Proof. intros Hsiwf Hrfwf Hlobwf Hpart; split; [|split]. apply udr_lift; auto. apply trans_lift; auto. intros Cx; apply irr_lift; auto. Qed. (** *** The gcb relation is a linear extension of the preorder_gcb relation *) Lemma gcb_is_lin (E : set Event) (co si lob : set Event -> Rln Event) (gcb : Rln (Class Event)) : clinearisations (lift (MemC E si) (pre_egc E co si lob)) (MemC E si) gcb -> clinearisations (preorder_gcb_lift E si lob (MemC E si)) (MemC E si) gcb. Proof. (** By definition gcb is a linearisation of the relation pre_egc. Observe that preorder_gcb is included in pre_egc. Note that for all relation r2 included in another relation r1, a linearisation of the bigger relation r1 is a linearisation of the smaller relation r2. Therefore a linearisation of the bigger relation pre_egc is also a linearisation of the smaller relation preorder_gcb. *) intros Hlin; apply clin_of_big_is_clin_of_little with (lift (MemC E si) (pre_egc E co si lob)); auto. apply rel_incl_lift; auto. intros x y Hxy; apply _base; right; right; right; auto. Qed. Lemma co_in_pre_egc E co si lob : si_well_formed E (si E) -> rf_well_formed E -> rel_incl (co E) (pre_egc E co si lob). Proof. intros Hsiwf Hrfwf x y Hxy; apply _base; right; left; auto. generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl ?]. exists y; split; auto. Qed. Lemma MemC_in_evts E si Cx x : si_well_formed E (si E) -> rf_well_formed E -> MemC E si Cx -> Cx x -> E x. Proof. unfold MemC; unfold classes; unfold class_of; unfold erln; intros Hsiwf Hrfwf [e HCx] Hx; rewrite HCx in Hx; destruct Hx as [? [[? ?] ?]]; auto. Qed. Lemma co_gcb_incl (E : set Event) (co si lob : set Event -> Rln Event) gcb : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> clinearisations (lift (MemC E si) (pre_egc E co si lob)) (MemC E si) gcb -> rel_incl (co E) (gcb_co E (dgcb_loc E (MemC E si) gcb)). Proof. intros Hsiwf Hcowf Hrfwf Hlin; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl ?]. intros x y Hxy; split; [| split; [|split; [|split; [|split]]]]. apply dom_co_in_evts with co y; auto. apply ran_co_in_evts with co x; auto. apply dom_co_is_write with E co y; auto. apply ran_co_is_write with E co x; auto. apply co_implies_same_loc with E co; auto. split. apply dom_co_in_evts with co y; auto. split. apply ran_co_in_evts with co x; auto. split. generalize (co_in_pre_egc co si lob Hsiwf); intro Hcoincl. generalize (clin_ext_prop (MemC E si) (lift (MemC E si) (pre_egc E co si lob)) gcb); intros [Himpl _]; generalize (Himpl Hlin); clear Himpl; intros [Hincl Hlso]. intros Cx Cy HCx HCy Hinx Hiny; apply Hincl; unfold lift; split; auto; split; auto; exists x; exists y; split; auto; split; auto; apply _base; right; left; exists y; split; auto. apply co_implies_same_loc with E co; auto. Qed. Lemma gcb_co_incl (E : set Event) (co si lob : set Event -> Rln Event) gcb : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> clinearisations (lift (MemC E si) (pre_egc E co si lob)) (MemC E si) gcb -> rel_incl (gcb_co E (dgcb_loc E (MemC E si) gcb)) (co E). Proof. intros Hsiwf Hcowf Hrfwf Hlin x y Hxy. generalize Hcowf; intros [Hincl Hlin_co]; destruct_lin (Hlin_co (loc x)); generalize (clin_ext_prop (MemC E si) (lift (MemC E si) (pre_egc E co si lob)) gcb); intros [Hd1 H2]; generalize (Hd1 Hlin); intros [? Hlin_gcb]; destruct Hlin_gcb as [Hpart_gcb ?]. assert (delift (MemC E si) gcb x y) as Hdxy. destruct Hxy as [? [? [? [? [? [? [? [Hdxy ?]]]]]]]]; auto. assert (x <> y) as Hdiff. intro Heq; rewrite <- Heq in Hdxy. assert False as Ht. apply (delift_irr Hsiwf Hrfwf Hpart_gcb Hdxy). inversion Ht. assert (Intersection Event E (is_write_same_loc (loc x)) x) as Hx. split; [|split]; destruct Hxy as [? [? [? ?]]]; auto. assert (Intersection Event E (is_write_same_loc (loc x)) y) as Hy. split; [|split]; destruct Hxy as [? [? [? [? [? ?]]]]]; auto. generalize (Htot x y Hdiff Hx Hy); intros [|Hco_yx]; auto. generalize (co_gcb_incl Hsiwf Hcowf Hrfwf Hlin y x Hco_yx); intro Hgcb_yx. assert (delift (MemC E si) gcb x x) as Hxx. apply delift_trans with y; auto. destruct Hgcb_yx as [? [? [? [? [? [? [? [Hdyx ?]]]]]]]]; auto. assert False as Ht. apply (delift_irr Hsiwf Hrfwf Hpart_gcb Hxx). inversion Ht. Qed. Lemma gcb_coeq (E : set Event) (co si lob : set Event -> Rln Event) gcb : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> clinearisations (lift (MemC E si) (pre_egc E co si lob)) (MemC E si) gcb -> rel_equal (co E) (gcb_co E (dgcb_loc E (MemC E si) gcb)). Proof. intros Hsiwf Hcowf Hrfwf Hlin; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl ?]; split. apply co_gcb_incl with lob; auto. intros x y Hxy; generalize Hcowf; intros [Hincl Hlin_co]; destruct_lin (Hlin_co (loc x)); generalize (clin_ext_prop (MemC E si) (lift (MemC E si) (pre_egc E co si lob)) gcb); intros [Hd1 H2]; generalize (Hd1 Hlin); intros [? Hlin_gcb]; destruct Hlin_gcb as [Hpart_gcb ?]. assert (delift (MemC E si) gcb x y) as Hdxy. destruct Hxy as [? [? [? [? [? [? [? [Hdxy ?]]]]]]]]; auto. assert (x <> y) as Hdiff. intro Heq; rewrite <- Heq in Hdxy. assert False as Ht. apply (delift_irr Hsiwf Hrfwf Hpart_gcb Hdxy). inversion Ht. assert (Intersection Event E (is_write_same_loc (loc x)) x) as Hx. split; [|split]; destruct Hxy as [? [? [? ?]]]; auto. assert (Intersection Event E (is_write_same_loc (loc x)) y) as Hy. split; [|split]; destruct Hxy as [? [? [? [? [? ?]]]]]; auto. generalize (Htot x y Hdiff Hx Hy); intros [|Hco_yx]; auto. generalize (co_gcb_incl Hsiwf Hcowf Hrfwf Hlin y x Hco_yx); intro Hgcb_yx. assert (delift (MemC E si) gcb x x) as Hxx. apply delift_trans with y; auto. destruct Hgcb_yx as [? [? [? [? [? [? [? [Hdyx ?]]]]]]]]; auto. assert False as Ht. apply (delift_irr Hsiwf Hrfwf Hpart_gcb Hxx). inversion Ht. Qed. Lemma gcb_rf_incl (E : set Event) (co si lob : set Event -> Rln Event) gcb : si_well_formed E (si E) -> rf_well_formed E -> clinearisations (lift (MemC E si) (pre_egc E co si lob)) (MemC E si) gcb -> rel_incl (gcb_rf E (dgcb_loc E (MemC E si) gcb)) (rf E). Proof. intros Hswif Hrfwf Hlin; generalize (clin_ext_prop (MemC E si) (lift (MemC E si) (pre_egc E co si lob)) gcb); intros [Himpl _]; generalize (Himpl Hlin); clear Himpl; intros [Hincl Hlso]; intros x y Hxy. destruct_lin Hlso; destruct Hxy as [HEx [HEy [Hwx [Hry [Hloc [Hval [Hgcb Hnointerv]]]]]]]; split; auto; split; auto; split; auto; split; auto; split; auto. Qed. Lemma gcb_rf_is_wf (E : set Event) (co si lob : set Event -> Rln Event) gcb : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> internal_visibility E co -> external_visibility E co si lob -> clinearisations (lift (MemC E si) (pre_egc E co si lob)) (MemC E si) gcb -> gcb_rf_wf E (dgcb_loc E (MemC E si) gcb). Proof. intros Hsiwf Hrfwf Hcowf Hlobwf Hint_vis Hext_vis Hlin r Hr. generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl ?]. generalize Hrfwf; intro Hrfwf'; destruct_rf_wf Hrfwf'; generalize (Hex_uni r Hr); intros [[w Hrf] Huni]; generalize (clin_ext_prop (MemC E si) (lift (MemC E si) (pre_egc E co si lob)) gcb); intros [Himpl _]; generalize (Himpl Hlin); clear Himpl; intros [Hincl Hlso]; exists w; split; [apply dom_rf_in_evts with r | split; [apply ran_rf_in_evts with w| split; [apply dom_rf_is_write with E r | split; [apply ran_rf_is_read with E w | split; [apply rf_implies_same_loc with E | split; [apply rf_implies_same_val with E | split]]]]]]; auto. unfold dgcb_loc; unfold delift; split; auto. apply dom_rf_in_evts with r; auto. split. apply ran_rf_in_evts with w; auto. split. intros Cw Cr HCw HCr Hinw Hinr; apply Hincl; unfold lift; split; auto; split; auto; exists w; exists r; split; auto; split; auto; apply _base; left; exists r; split; auto. apply rf_implies_same_loc with E; auto. intros [w' [Hw' [[Hgcbww' Hlocww'] [Hgcbw'r Hlocw'r]]]]. generalize (gcb_co_incl Hsiwf Hcowf Hrfwf Hlin); intro Hcoincl. assert (E w) as HEw. apply dom_rf_in_evts with r; auto. assert (E w') as HEw'. destruct Hgcbww' as [? [HEw' ?]]; auto. assert (is_write w) as Hw. apply dom_rf_is_write with E r; auto. assert (co E w w') as Hcoww'. apply Hcoincl; split; auto. assert (fr E co r w') as Hfrrw'. exists w; split; auto; split; auto. assert (dgcb_loc E (MemC E si) gcb r w') as Hgcbrw'. unfold dgcb_loc; unfold delift; split; auto. apply dom_fr_in_evts with co w'; auto. split; auto. split; auto. intros Cr Cw' HCr HCw' Hinr Hinw'; apply Hincl; unfold lift; split; auto; split; auto; exists r; exists w'; split; auto; split; auto; apply _base; right; right; left; exists w'; split; auto. destruct_lin Hlso. assert ((delift (MemC E si) gcb) r r) as Hrr. destruct Hgcbw'r as [? [? [? ?]]]; destruct Hgcbrw' as [? [? [? ?]]]; apply delift_trans with w'; auto. apply (delift_irr Hsiwf Hrfwf Hpart Hrr). Qed. Lemma rf_gcb_incl (E : set Event) (co si lob : set Event -> Rln Event) gcb : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> internal_visibility E co -> external_visibility E co si lob -> clinearisations (lift (MemC E si) (pre_egc E co si lob)) (MemC E si) gcb -> rel_incl (rf E) (gcb_rf E (dgcb_loc E (MemC E si) gcb)). Proof. intros Hsiwf Hrfwf Hcowf Hlobwf Hint_vis Hext_vis Hlin; intros x y Hxy. assert (is_read y) as Hry. apply ran_rf_is_read with E x; auto. generalize (gcb_rf_is_wf Hsiwf Hrfwf Hcowf Hlobwf Hint_vis Hext_vis Hlin y Hry); intros [w Hgcbrfwy]; generalize (gcb_rf_incl Hsiwf Hrfwf Hlin Hgcbrfwy); intro Hrfwy; destruct_rf_wf Hrfwf; generalize (Hex_uni y Hry); intros [Hex Huni]; clear Hex_uni; generalize (Huni x w Hxy Hrfwy); intro Heq; rewrite Heq; auto. Qed. Lemma gcb_rfeq (E : set Event) (co si lob : set Event -> Rln Event) gcb : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> internal_visibility E co -> external_visibility E co si lob -> clinearisations (lift (MemC E si) (pre_egc E co si lob)) (MemC E si) gcb -> rel_equal (rf E) (gcb_rf E (dgcb_loc E (MemC E si) gcb)). Proof. intros Hsiwf Hrfwf Hcowf Hlobwf Hint_vis Hext_vis Hlin; generalize (clin_ext_prop (MemC E si) (lift (MemC E si) (pre_egc E co si lob)) gcb); intros [Himpl _]; generalize (Himpl Hlin); clear Himpl; intros [Hincl Hlso]; split. apply rf_gcb_incl with co lob; auto. apply gcb_rf_incl with co lob; auto. Qed. Lemma external_global_completion_gcb (E : set Event) (co si lob : set Event -> Rln Event) gcb : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> internal_visibility E co -> external_visibility E co si lob -> clinearisations (lift (MemC E si) (pre_egc E co si lob)) (MemC E si) gcb -> external_global_completion E co si lob gcb. Proof. intros Hsiwf Hrfwf Hcowf Hlobwf Hint_vis Hext_vis Hlin; split; [|split]; auto. apply gcb_is_lin with co; auto. apply gcb_rfeq with co lob; auto. apply gcb_coeq with lob; auto. Qed. (** ** All in all *) Lemma external_visibility_implies_external_global_completion (E : set Event) (co si lob aob : set Event -> Rln Event) : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> internal_visibility E co -> (external_visibility E co si lob -> exists gcb, external_global_completion E co si lob gcb). Proof. intros Hsiwf Hrfwf Hcowf Hlobwf Hint_vis Hext_vis. generalize (pre_egc_partial_order lob Hsiwf Hrfwf Hcowf Hlobwf Hint_vis Hext_vis); intro Hpart. generalize (lift_partial_order Hsiwf Hrfwf Hlobwf Hpart); clear Hpart; intro Hpart. generalize (corder_ext Hpart); intros [gcb Hgcb]; exists gcb. apply external_global_completion_gcb; auto. Qed. (** * External Visibility <-> External Global Completion *) Theorem external_visibility_gcb_equivalence (E : set Event) (co si lob : set Event -> Rln Event) : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> internal_visibility E co -> ((external_visibility E co si lob) <-> (exists gcb, external_global_completion E co si lob gcb)). Proof. intros Hsiwf Hrfwf Hcowf Hlob_wf Hint_vis. split. apply external_visibility_implies_external_global_completion; auto. apply external_global_completion_implies_external_visibility; auto. Qed. (** * Global Completion *) (** ** Global Completion: Definitions *) Definition fwd (E : set Event) (cb : Rln Event) (w r : Event) := po E w r /\ cb r w /\ ~intervening_write (fun e1 e2 => po E e1 e2 /\ loc e1 = loc e2) w r. Definition nfwd (E : set Event) (cb : Rln Event) (w r : Event) := cb w r /\ ~intervening_write (fun e1 e2 => cb e1 e2 /\ loc e1 = loc e2) w r. Definition cb_rf (E : set Event) (cb : Rln Event) (e1 e2 : Event) : Prop := is_write e1 /\ is_read e2 /\ loc e1 = loc e2 /\ val e1 = val e2 /\ ((fwd E cb e1 e2) \/ (nfwd E cb e1 e2)). Definition cb_co (E : set Event) (cb : Rln Event) (e1 e2 : Event) : Prop := order_to_co E cb e1 e2. Definition preorder_cb E si lob := (rel_union (lob E) (scaob E si)). Definition preorder_cb_lift E si lob C := lift C (preorder_cb E si lob). Definition global_completion (E : set Event) (co si lob : set Event -> Rln Event) (cb : Rln (Class Event)): Prop := (clinearisations (preorder_cb_lift E si lob (MemC E si)) (MemC E si)) cb /\ rel_equal (rf E) (cb_rf E (dgcb_loc E (MemC E si) cb)) /\ rel_equal (co E) (cb_co E (dgcb_loc E (MemC E si) cb)). Definition big_rel3 (E : set Event) (co si lob : set Event -> Rln Event) := tc_mobs_r_mobs E co si (preorder_cb E si lob). (** ** Global Completion: Lemmas that do _not_ need the existence of a External Global Completion order *) Lemma rfe_in_cb E si cb : rel_equal (rf E) (cb_rf E (dgcb_loc E (MemC E si) cb)) -> rel_incl (rfe E) (delift (MemC E si) cb). Proof. intros Hrfeq x y [Hrf Hext]; destruct Hrfeq as [Hrfincl ?]; generalize (Hrfincl x y Hrf); intros [? [? [? [? Hor]]]]. inversion Hor as [[Hpo ?]| Hnfwd]; clear Hor. assert (internal E x y) as Hint. destruct Hpo; auto. assert False as Ht. apply int_ext_contrad with E x y; auto. inversion Ht; auto. destruct Hnfwd as [[? [? [Hxy ?]]] ?]; auto. Qed. Lemma co_in_cb E co si cb : rel_equal (co E) (cb_co E (dgcb_loc E (MemC E si) cb)) -> rel_incl (co E) (delift (MemC E si) cb). Proof. intros Hcoeq x y Hco; destruct Hcoeq as [Hcoincl ?]; generalize (Hcoincl x y Hco); intros [? [? [? [? [? [? [? [? ?]]]]]]]]; auto. Qed. Lemma fr_in_cb E co si lob cb : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> (clinearisations (preorder_cb_lift E si lob (MemC E si)) (MemC E si)) cb -> rel_equal (rf E) (cb_rf E (dgcb_loc E (MemC E si) cb)) -> rel_equal (co E) (cb_co E (dgcb_loc E (MemC E si) cb)) -> rel_incl (fr E co) (delift (MemC E si) cb). Proof. intros Hsiwf Hcowf Hrfwf Hlin Hrfeq Hcoeq x y Hfr. unfold delift; intros Cx Cy HinCx HinCy Hx Hy. generalize (erln_is_equiv si Hsiwf Hrfwf); intro Heqr; unfold MemC in HinCx; generalize (in_class_implies_class_of x Heqr HinCx Hx); intro Heqx1. unfold MemC in HinCy; generalize (in_class_implies_class_of y Heqr HinCy Hy); intro Heqy1. generalize (clin_ext_prop (MemC E si) (preorder_cb_lift E si lob (MemC E si)) cb); intros [Himpl ?]; generalize (Himpl Hlin); intros [Hincl Hlso]; destruct_lin Hlso. assert (Cx <> Cy) as Hdiff. rewrite Heqx1; rewrite Heqy1. apply not_si_implies_diff_class; auto; apply fr_implies_not_si with co; auto. generalize (Htot Cx Cy Hdiff HinCx HinCy); intros [? | Hyx]; auto. generalize Hfr; intros [w [Hw [Hrf Hco]]]; generalize (co_in_dgcb co Hcoeq w y Hco); intro Hgcbwy. generalize Hrfeq; intros Hrfeq'; destruct Hrfeq as [Hinrf ?]; generalize (Hinrf w x Hrf); intros [? [? [? [? [Hfwd | Hnfwd]]]]]. Focus 2. destruct Hnfwd as [Hcbwx Hnointerv]. assert (loc w = loc y) as Hlocwy. apply co_implies_same_loc with E co; auto. assert (loc x = loc y) as Hlocxy. apply fr_implies_same_loc with E co; auto. assert False as Ht. apply Hnointerv; exists y; split; [|split; split]; auto. apply ran_co_is_write with E co w; auto. split; auto. apply dom_co_in_evts with co y; auto. split; auto. apply ran_co_in_evts with co w; auto. split; auto. apply ran_co_in_evts with co w; auto. split; auto. apply ran_rf_in_evts with w; auto. split; auto. unfold delift; intros cy cx Hincy Hincx Hcy Hcx; unfold MemC in Hincx; generalize (in_class_implies_class_of x Heqr Hincx Hcx); intro Heqx2; unfold MemC in Hincy; generalize (in_class_implies_class_of y Heqr Hincy Hcy); intro Heqy2. rewrite Heqx2; rewrite Heqy2; rewrite <- Heqx1; rewrite <- Heqy1; auto. inversion Ht. destruct Hfwd as [? [[? [? [Hcbxw ?]]] ?]]. assert (MemC E si (class_of (erln E si) w)) as HinCw. apply class_of_in_classes; auto. assert (class_of (erln E si) w w) as Hisw. unfold class_of; destruct Heqr as [Hrefl ?]; auto. unfold delift in Hcbxw; unfold delift in Hgcbwy. generalize (Hcbxw Cx (class_of (erln E si) w) HinCx HinCw Hx Hisw); intro Hxw. generalize (Hgcbwy (class_of (erln E si) w) Cy HinCw HinCy Hisw Hy); intro Hwy. destruct_part Hpart; apply (Htrans Cx (class_of (erln E si) w) Cy Hxw Hwy). Qed. Lemma cb_path_ob_dec (E : set Event) (co si lob : set Event -> Rln Event) (cb : Rln Event) (e1 e2 : Event) : rel_equal (rf E) (cb_rf E cb) -> rel_equal (co E) (cb_co E cb) -> ob E co (si E) (lob E) e1 e2 -> transitive_closure (rel_seq (obsplus E co) (si E)) e1 e2 \/ big_rel3 E co si lob e1 e2. Proof. intros Hrfeq Hcoeq H12. induction H12 as [e1 e2 [e [Hobs Hsi]] | e1 e2 Hlob |]; auto. left; apply _base; exists e; split; auto; apply _base; auto. right; apply _base; exists e1; split; [left|exists e2; split; [|left]]; auto; left; auto. inversion IHob1 as [Hob1 | Hbr1]; clear IHob1; inversion IHob2 as [Hob2 | Hbr2]; clear IHob2. left; apply tc_trans with e; auto. right; apply tc_seq_left with e; auto; [intros x y z Hxy Hyz; apply maybe_tc_trans with y | right]; auto. right; apply tc_seq_reorg with e; auto; [intros x y z Hxy Hyz; apply maybe_tc_trans with y |right]; auto. right; apply tc_trans with e; auto. Qed. (** ** Global Completion -> External Visibility lemmas *) Lemma big_rel3_irr E co si lob cb x : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> clinearisations (preorder_cb_lift E si lob (MemC E si)) (MemC E si) cb -> rel_equal (rf E) (cb_rf E (dgcb_loc E (MemC E si) cb)) -> rel_equal (co E) (cb_co E (dgcb_loc E (MemC E si) cb)) -> ~(big_rel3 E co si lob x x). Proof. intros Hsiwf Hrfwf Hcowf Hlin Hrfeq Hcoeq; generalize (erln_is_equiv si Hsiwf Hrfwf); intro Herln; apply tc_mobs_r_mobs_irr with (erln E si) (MemC E si) cb; auto; intros e1 e2 H12. apply rfe_in_cb; auto. apply co_in_cb with co; auto. apply fr_in_cb with co lob; auto. unfold preorder_cb. right; auto. Qed. Lemma obsp_si_ac2 E co si lob cb x : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> clinearisations (preorder_cb_lift E si lob (MemC E si)) (MemC E si) cb -> rel_equal (rf E) (cb_rf E (dgcb_loc E (MemC E si) cb)) -> rel_equal (co E) (cb_co E (dgcb_loc E (MemC E si) cb)) -> ~transitive_closure (rel_seq (obsplus E co) (si E)) x x. Proof. intros Hsiwf Hrfwf Hcowf Hlin Hrfeq Hcoeq Hx. assert (erln E si = erln E si) as Heqt. auto. assert ((MemC E si) = classes (erln E si)) as HeqC. unfold MemC; auto. generalize (erln_is_equiv si Hsiwf Hrfwf); intro Hequivr. assert (rel_incl (rfe E) (delift (MemC E si) cb)) as Hrfeincl. intros e1 e2 Hrfe; apply (rfe_in_cb Hrfeq); auto. generalize (co_in_cb co Hcoeq); intro Hcoincl. generalize (fr_in_cb Hsiwf Hcowf Hrfwf Hlin Hrfeq Hcoeq); intro Hfrincl. assert (rel_incl (scaob E si) (preorder_cb E si lob)) as Hscaobincl. intros e1 e2 H12; right; auto. generalize (tc_obsp_si_in_order Heqt Hequivr HeqC Hsiwf Hrfwf Hcowf Hlin Hrfeincl Hcoincl Hfrincl Hscaobincl Hx); generalize (clin_ext_prop (MemC E si) (preorder_cb_lift E si lob (MemC E si)) cb); intros [Himpl _]; generalize (Himpl Hlin); clear Himpl; intros [Hincl Hlso]; destruct_lin Hlso; destruct_part Hpart; apply Hirr. Qed. Lemma global_completion_implies_external_visibility (E : set Event) (co si lob : set Event -> Rln Event) : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> internal_visibility E co -> (exists cb : Rln (Class Event), global_completion E co si lob cb) -> external_visibility E co si lob. Proof. intros Hsiwf Hrfwf Hcowf Hintv [cb [Hlin [Hrfeq Hcoeq]]] [x Hx]. generalize (cb_path_ob_dec si lob Hrfeq Hcoeq Hx); intros [Hobs | Hbr3]. apply (obsp_si_ac2 Hsiwf Hrfwf Hcowf Hlin Hrfeq Hcoeq Hobs). apply (big_rel3_irr Hsiwf Hrfwf Hcowf Hlin Hrfeq Hcoeq Hbr3); auto. Qed. (** ** External Visibility -> Global Completion lemmas *) Definition pre_gc (E : set Event) (co si lob : set Event -> Rln Event) := transitive_closure (rel_union (rel_seq (rfe E) (erln E si)) (rel_union (rel_seq (co E) (erln E si)) (rel_union (rel_seq (fr E co) (erln E si)) (preorder_cb E si lob)))). Definition big_rel4 E co si lob := transitive_closure (rel_seq (maybe (transitive_closure (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si))))) (rel_seq (rel_seq (erln E si) (rel_seq (preorder_cb E si lob) (erln E si))) (maybe (transitive_closure (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si))))))). Lemma rfe_base_br4_in_br4 E co si lob e1 e0 e x e2 : si_well_formed E (si E) -> rf_well_formed E -> rfe E e1 e0 -> erln E si e0 e -> rel_seq (rel_seq (erln E si) (rel_seq (preorder_cb E si lob) (erln E si))) (maybe (transitive_closure (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si))))) e x -> maybe (transitive_closure (rel_seq (maybe (transitive_closure (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si))))) (rel_seq (rel_seq (erln E si) (rel_seq (preorder_cb E si lob) (erln E si))) (maybe (transitive_closure (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si)))))))) x e2 -> big_rel4 E co si lob e1 e2. Proof. intros Hsiwf Hrfwf H1e0 He0e Hex Hx2; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl [Hsym Htrans]]; inversion Hx2 as [Heqx2 | Htcx2]; clear Hx2. rewrite Heqx2 in Hex; clear Heqx2; apply _base; exists e; split; auto; right; apply _base; exists e1; split; auto; exists e0; split; auto; left; left; auto. apply _trans with x; auto; exists e; split; auto; right; apply _base; exists e1; split; auto; exists e0; split; auto; left; left; auto. Qed. Lemma rf_br4_in_br4 E co si lob e1 e e0 e2 : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> rfe E e1 e0 -> erln E si e0 e -> big_rel4 E co si lob e e2 -> big_rel4 E co si lob e1 e2. Proof. intros Hsiwf Hcowf Hrfwf H1e0 He0e He2; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl [Hsym Htrans]]; generalize (tc_dec2 He2); clear He2; intros [x [[y [Hey Hex]] He2]]. inversion Hey as [Heqey | Htcey]; clear Hey. rewrite <- Heqey in Hex; clear Heqey. apply rfe_base_br4_in_br4 with e0 e x; auto. inversion He2 as [Heqxe2 | Htcxe2]; clear He2. rewrite Heqxe2 in Hex; clear Heqxe2. apply _base; exists y; split; auto; right; apply rf_tc_erln_obsp_erln_in_tc with e e0; auto; destruct H1e0; auto. apply tc_trans with x; auto. apply _base; exists y; split; auto; right; apply rf_tc_erln_obsp_erln_in_tc with e e0; auto; destruct H1e0; auto. Qed. Lemma co_br4_in_br4 E (co si lob : set Event -> Rln Event) e1 e e0 e2 : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> co E e1 e0 -> erln E si e0 e -> big_rel4 E co si lob e e2 -> big_rel4 E co si lob e1 e2. Proof. intros Hsiwf Hrfwf Hcowf H1e0 He0e He2; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl ?]. apply tc_seq_left with e; auto. apply transitive_maybe_tc. right; apply _base; exists e1; split; auto; exists e0; split; auto; left; right; left; auto. Qed. Lemma fr_br4_in_br4 E (co si lob : set Event -> Rln Event) e1 e e0 e2 : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> fr E co e1 e0 -> erln E si e0 e -> big_rel4 E co si lob e e2 -> big_rel4 E co si lob e1 e2. Proof. intros Hsiwf Hrfwf Hcowf H1e0 He0e He2; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl ?]. apply tc_seq_left with e; auto. apply transitive_maybe_tc. right; apply _base; exists e1; split; auto; exists e0; split; auto; left; right; right; auto. Qed. Lemma preorder_cb_br4_in_br4 E (co si lob : set Event -> Rln Event) e1 e e2 : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> preorder_cb E si lob e1 e -> big_rel4 E co si lob e e2 -> big_rel4 E co si lob e1 e2. Proof. intros Hsiwf Hrfwf Hcowf H1e He2; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl ?]; induction He2 as [e e2 He2 | e e2 e' Hee']. apply _trans with e; [exists e1; split; [left | exists e; split; [|left]]|apply _base]; auto. exists e1; split; auto; exists e; split; auto. apply tc_trans with e'; auto. apply _trans with e; [exists e1; split; [left | exists e; split; [|left]]|apply _base]; auto. exists e1; split; auto; exists e; split; auto. Qed. Lemma obs_extra_obsp_eq E co : rf_well_formed E -> co_well_formed E co -> obs_extra E co = obsplus E co. Proof. intros Hrfwf Hcowf; apply Extensionality_Rlns; split; intros e1 e2 H12. inversion H12 as [Hrfe | [Hco | [Hfr | [Hcorfe | Hfrrfe]]]]. apply _base; left; auto. apply _base; right; left; auto. apply _base; right; right; auto. destruct Hcorfe as [e [Hco Hrfe]]; apply _trans with e; [right; left | apply _base; left]; auto. destruct Hfrrfe as [e [Hco Hrfe]]; apply _trans with e; [right; right | apply _base; left]; auto. induction H12. inversion H as [Hrfe | [Hco | Hfr]]. left; auto. right; left; auto. right; right; left; auto. inversion H as [Hrfe1e | [Hco1e | Hfr1e]]. (*e1,e in rfe*) inversion IHtransitive_closure as [Hrfee2 | [Hcoe2 | [Hfre2 | [Hcorfee2 | Hfrrfee2]]]]. destruct Hrfe1e as [Hrfe1e ?]; destruct Hrfee2 as [Hrfee2 ?]; generalize (ran_rf_is_read Hrfe1e); intro Hre; generalize (dom_rf_is_write Hrfee2); intro Hwe; generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. destruct Hrfe1e as [Hrfe1e ?]; generalize (ran_rf_is_read Hrfe1e); intro Hre; generalize (dom_co_is_write e e2 Hcowf Hcoe2); intro Hwe; generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. destruct Hrfe1e as [Hrfe1e ?]; right; left; apply rf_fr_is_co with e; auto. destruct Hrfe1e as [Hrfe1e ?]; destruct Hcorfee2 as [e' [Hco ?]]; generalize (ran_rf_is_read Hrfe1e); intro Hre; generalize (dom_co_is_write e e' Hcowf Hco); intro Hwe; generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. destruct Hrfe1e as [Hrfe1e ?]; destruct Hfrrfee2 as [e' [Hfr ?]]; generalize (rf_fr_is_co Hrfwf Hrfe1e Hfr); intro Hco; right; right; right; left; exists e'; split; auto. (*e1,e2 in co*) inversion IHtransitive_closure as [Hrfee2 | [Hcoe2 | [Hfre2 | [Hcorfee2 | Hfrrfee2]]]]. right; right; right; left; exists e; split; auto. right; left; apply co_trans with e; auto. generalize (ran_co_is_write e1 e Hcowf Hco1e); intro Hwe; generalize (dom_fr_is_read Hfre2); intro Hre; generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. destruct Hcorfee2 as [e'[Hco ?]]; generalize (co_trans e1 e e' Hcowf Hco1e Hco); intro Hco1e'; right; right; right; left; exists e'; split; auto. destruct Hfrrfee2 as [e' [Hfr ?]]; generalize (ran_co_is_write e1 e Hcowf Hco1e); intro Hwe; generalize (dom_fr_is_read Hfr); intro Hre. generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. (*e1,e2 in fr*) inversion IHtransitive_closure as [Hrfee2 | [Hcoe2 | [Hfre2 | [Hcorfee2 | Hfrrfee2]]]]. right; right; right; right; exists e; split; auto. right; right; left; apply fr_co_is_fr with e; auto. generalize (ran_fr_is_write Hcowf Hfr1e); intro Hwe; generalize (dom_fr_is_read Hfre2); intro Hre; generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. destruct Hcorfee2 as [e' [Hco Hrfe]]; generalize (fr_co_is_fr e' Hcowf Hfr1e Hco); intro Hfr1e'; right; right; right; right; exists e'; split; auto. destruct Hfrrfee2 as [e' [Hfr Hrfe]]; generalize (ran_fr_is_write Hcowf Hfr1e); intro Hwe; generalize (dom_fr_is_read Hfr); intro Hre; generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. Qed. Lemma pre_gc_dec (E : set Event) (co si lob : set Event -> Rln Event) (e1 e2 : Event) : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> pre_gc E co si lob e1 e2 -> transitive_closure (rel_seq (erln E si) (rel_seq (obs_extra E co) (erln E si))) e1 e2 \/ (big_rel4 E co si lob) e1 e2. Proof. intros Hsiwf Hrfwf Hcowf H12; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl ?]; induction H12 as [e1 e2 H12 | e1 e2 b H1b Hb2]. inversion H12 as [[a [Hrfe Hsi]] | [[a [Hco Hsi]] | [[a [Hfr Hsi]] | Hlob]]]; clear H12. left; apply _base; exists e1; split; auto; exists a; split; auto; left; auto. left; apply _base; exists e1; split; auto; exists a; split; auto; right; left; auto. left; apply _base; exists e1; split; auto; exists a; split; auto; right; right; left; auto. right; apply _base; exists e1; split; [left | exists e2; split; [| left]]; auto. exists e1; split; auto. exists e2; split; auto. inversion H1b as [[a [Hrfe Hsi]] | [[a [Hco Hsi]] | [[a [Hfr Hsi]] | Hlob]]]; clear H1b; inversion IHHb2 as [Hcpb2 | Hbr4b2]; clear IHHb2. left; apply _trans with b; auto; exists e1; split; auto; exists a; split; auto; left; auto. right; apply rf_br4_in_br4 with b a; auto. left; apply _trans with b; auto; exists e1; split; auto; exists a; split; auto; right; left; auto. right; apply co_br4_in_br4 with b a; auto. left; apply _trans with b; auto; exists e1; split; auto; exists a; split; auto; right; right; left; auto. right; apply fr_br4_in_br4 with b a; auto. right; apply _base; exists e1; split; [left |exists b; split; [|right]]; auto. exists e1; split; auto; exists b; split; auto. rewrite <- obs_extra_obsp_eq; auto. right; apply preorder_cb_br4_in_br4 with b; auto. Qed. Lemma mobs_extra_trans E (co si lob : set Event -> Rln Event) : rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> internal_visibility E co -> external_visibility E co si lob -> transitive (maybe (obs_extra E co)). Proof. intros Hrfwf Hcowf Hlobwf Hintv Hextv x y z Hxy Hyz; inversion Hxy as [Heqxy | Hpcxy]; clear Hxy; inversion Hyz as [Heqyz | Hpcyz]; clear Hyz. left; rewrite Heqxy; auto. right; rewrite Heqxy; auto. right; rewrite <- Heqyz; auto. right; inversion Hpcxy as [Hrfexy | [Hcoxy | [Hfrxy | [Hcorfexy | Hfrrfexy]]]]; clear Hpcxy; inversion Hpcyz as [Hrfeyz | [Hcoyz | [Hfryz | [Hcorfeyz | Hfrrfeyz]]]]; clear Hpcyz. assert False as Ht. apply (read_write_contrad y); [apply ran_rf_is_read with E x; destruct Hrfexy | apply dom_rf_is_write with E z; destruct Hrfeyz]; auto. inversion Ht. assert False as Ht. apply (read_write_contrad y); [apply ran_rf_is_read with E x; destruct Hrfexy | apply dom_co_is_write with E co z]; auto. inversion Ht. destruct Hrfexy as [? ?]; right; left; apply rf_fr_is_co with y; auto. assert False as Ht. apply (read_write_contrad y); [apply ran_rf_is_read with E x; destruct Hrfexy | destruct Hcorfeyz as [e [Hye Hez]]; apply dom_co_is_write with E co e]; auto. inversion Ht. destruct Hrfexy as [? ?]; destruct Hfrrfeyz as [e [Hfr Hrfe]]; right; right; right; left; exists e; split; auto; apply rf_fr_is_co with y; auto. right; right; right; left; exists y; split; auto. right; left; apply co_trans with y; auto. assert False as Ht. generalize (ran_co_is_write x y Hcowf Hcoxy); intro Hwy; generalize (dom_fr_is_read Hfryz); intro Hry; apply (read_write_contrad y Hry Hwy). inversion Ht. right; right; right; left; destruct Hcorfeyz as [e [Hco Hrfe]]; exists e; split; auto; apply co_trans with y; auto. destruct Hfrrfeyz as [e [Hfr Hrfe]]; assert False as Ht. generalize (ran_co_is_write x y Hcowf Hcoxy); intro Hwy; generalize (dom_fr_is_read Hfr); intro Hry; apply (read_write_contrad y Hry Hwy). inversion Ht. right; right; right; right; exists y; split; auto. right; right; left; apply fr_co_is_fr with y; auto. assert False as Ht. generalize (ran_fr_is_write Hcowf Hfrxy); intro Hwy; generalize (dom_fr_is_read Hfryz); intro Hry; apply (read_write_contrad y Hry Hwy). inversion Ht. destruct Hcorfeyz as [e [Hco Hrfe]]; right; right; right; right; exists e; split; auto; apply fr_co_is_fr with y; auto. destruct Hfrrfeyz as [e [Hfr Hrfe]]; assert False as Ht. generalize (ran_fr_is_write Hcowf Hfrxy); intro Hwy; generalize (dom_fr_is_read Hfr); intro Hry; apply (read_write_contrad y Hry Hwy). inversion Ht. assert False as Ht. apply (read_write_contrad y); [destruct Hcorfexy as [e [Hxe [Hey ?]]]; apply ran_rf_is_read with E e | apply dom_rf_is_write with E z; destruct Hrfeyz]; auto. inversion Ht. assert False as Ht. apply (read_write_contrad y); [destruct Hcorfexy as [e [Hxe [Hey ?]]]; apply ran_rf_is_read with E e | apply dom_co_is_write with E co z]; auto. inversion Ht. destruct Hcorfexy as [e [Hco Hrfe]]; destruct Hrfe as [? ?]; right; left; apply co_trans with e; auto; apply rf_fr_is_co with y; auto. assert False as Ht. apply (read_write_contrad y); [destruct Hcorfexy as [e [Hxe [Hey ?]]]; apply ran_rf_is_read with E e | destruct Hcorfeyz as [e [Hye Hez]]; apply dom_co_is_write with E co e]; auto. inversion Ht. destruct Hcorfexy as [e [Hco [Hrfe ?]]]; destruct Hfrrfeyz as [e' [Hfr Hrfe']]; right; right; right; left; exists e'; split; auto; apply co_trans with e; auto; apply rf_fr_is_co with y; auto. destruct Hfrrfexy as [e [Hfr [Hrf ?]]]; destruct Hrfeyz as [Hrf' ?]; assert False as Ht. generalize (dom_rf_is_write Hrf'); intro Hwy; generalize (ran_rf_is_read Hrf); intro Hry; apply (read_write_contrad y Hry Hwy). inversion Ht. destruct Hfrrfexy as [e [Hfr [Hrf ?]]]; assert False as Ht. generalize (ran_rf_is_read Hrf); intro Hry; generalize (dom_co_is_write y z Hcowf Hcoyz); intro Hwy; apply (read_write_contrad y Hry Hwy). inversion Ht. destruct Hfrrfexy as [e [Hfr [Hrf ?]]]; right; right; left; apply fr_co_is_fr with e; auto; apply rf_fr_is_co with y; auto. destruct Hfrrfexy as [e [Hfr [Hrf ?]]]; destruct Hcorfeyz as [e' [Hco [Hrf' ?]]]; assert False as Ht. generalize (ran_rf_is_read Hrf); intro Hry; generalize (dom_co_is_write y e' Hcowf Hco); intro Hwy; apply (read_write_contrad y Hry Hwy). inversion Ht. destruct Hfrrfexy as [e [Hfr [Hrf ?]]]; destruct Hfrrfeyz as [e' [Hfr' Hrfe]]; right; right; right; right; exists e'; split; auto; apply fr_co_is_fr with e; auto; apply rf_fr_is_co with y; auto. Qed. Lemma preorder_cb_seq_mobs_extra_dec E co si lob x y : rf_well_formed E -> co_well_formed E co -> (rel_seq (preorder_cb E si lob) (maybe (obs_extra E co))) x y -> rel_seq (maybe (scaob E si)) (transitive_closure (rel_union (rel_seq (obsplus E co) (maybe (scaob E si))) (lob E))) x y \/ scaob E si x y. Proof. intros Hrfwf Hcowf [e [Hpre [Heq | Hobs_extra]]]. rewrite Heq in Hpre; clear Heq. inversion Hpre as [Hlob | Hscaob]; clear Hpre. left; exists x; split; [left| apply _base; right]; auto. right; auto. inversion Hpre as [Hlob | Hscaob]; clear Hpre. left; exists x; split; [left|apply _trans with e; [right|apply _base; left]]; auto. exists y; split; [|left]; auto. rewrite <- obs_extra_obsp_eq; auto. left; exists e; split. right; auto. apply _base; left. exists y; split; [|left]; auto. rewrite <- obs_extra_obsp_eq; auto. Qed. Lemma tc_u_scaob_is_tc E co si lob x y z : lob_well_formed E si lob -> rf_well_formed E -> transitive_closure (rel_union (rel_seq (obsplus E co) (maybe (scaob E si))) (lob E)) x y -> (maybe (scaob E si)) y z -> transitive_closure (rel_union (rel_seq (obsplus E co) (maybe (scaob E si))) (lob E)) x z. Proof. intros Hlobwf Hrfwf Hxy [Heq | Hyz]; [rewrite Heq in Hxy|]; auto. induction Hxy. inversion H as [[e [Hobsp [Heqe2 | Hscaobe2]]] | Hlob]; clear H. rewrite Heqe2 in Hobsp; clear Heqe2; apply _base; left; exists e2; split; auto; right; auto. generalize (scaob_scaob_contrad Hrfwf Hscaobe2 Hyz); intro Ht; inversion Ht. apply _base; right; destruct_lob_wf Hlobwf; apply Hlob_scaob; auto; exists e2; split; auto. clear Hxy; apply _trans with e; auto. Qed. Lemma tc_preorder_cb_seq_mobs_extra_dec E co si lob x y : lob_well_formed E si lob -> rf_well_formed E -> co_well_formed E co -> transitive_closure (rel_seq (preorder_cb E si lob) (maybe (obs_extra E co))) x y -> rel_seq (maybe (scaob E si)) (transitive_closure (rel_union (rel_seq (obsplus E co) (maybe (scaob E si))) (lob E))) x y \/ scaob E si x y. Proof. intros Hlobwf Hrfwf Hcowf Hxy; induction Hxy. apply preorder_cb_seq_mobs_extra_dec; auto. clear Hxy; generalize (preorder_cb_seq_mobs_extra_dec Hrfwf Hcowf H); clear H; intros [Hseq1e | Hscaob1e]; inversion IHHxy as [Hseqe2 | Hscaobe2]; clear IHHxy. left; destruct Hseq1e as [a [H1a Hae]]; exists a; split; auto; clear H1a. destruct Hseqe2 as [b [Heb Hb2]]; apply tc_trans with b; auto. apply tc_u_scaob_is_tc with e; auto. left; destruct Hseq1e as [a [H1a Hae]]; exists a; split; auto; clear H1a. apply tc_u_scaob_is_tc with e; auto; right; auto. left; destruct Hseqe2 as [b [[Heqeb | Heb] Hb2]]; exists b; split; auto. right; rewrite Heqeb in Hscaob1e; auto. generalize (scaob_scaob_contrad Hrfwf Hscaob1e Heb); intro Ht; inversion Ht. generalize (scaob_scaob_contrad Hrfwf Hscaob1e Hscaobe2); intro Ht; inversion Ht. Qed. Lemma obsp_in_ob E co si lob e1 e2 : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> obsplus E co e1 e2 -> ob E co (si E) (lob E) e1 e2. Proof. intros Hsiwf Hrfwf Hcowf Hobsp; destruct_siwf Hsiwf. generalize (obsplus_dec Hrfwf Hcowf Hobsp); clear Hobsp; intros [Hrfe | [Hco | [Hfr | [[e [Hco Hrfe]] | [e [Hfr Hrfe]]]]]]. apply _obs; exists e2; split; auto; left; auto. apply _obs; exists e2; split; auto; right; left; auto. apply _obs; exists e2; split; auto; right; right; auto. apply _ob with e; apply _obs; [exists e | exists e2]; split; auto. right; left; auto. left; auto. apply _ob with e; apply _obs; [exists e | exists e2]; split; auto. right; right; auto. left; auto. Qed. Lemma obsp_scaob_in_ob E co si lob e1 e2 e3 : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> obsplus E co e1 e2 -> scaob E si e2 e3 -> ob E co (si E) (lob E) e1 e3. Proof. intros Hsiwf Hrfwf Hcowf Hobsp [Hsi ?]; destruct_siwf Hsiwf. generalize (obsplus_dec Hrfwf Hcowf Hobsp); clear Hobsp; intros [Hrfe | [Hco | [Hfr | [[e [Hco Hrfe]] | [e [Hfr Hrfe]]]]]]. apply _obs; exists e2; split; auto; left; auto. apply _obs; exists e2; split; auto; right; left; auto. apply _obs; exists e2; split; auto; right; right; auto. apply _ob with e; apply _obs; [exists e|exists e2]; split; auto. right; left; auto. left; auto. apply _ob with e; apply _obs; [exists e | exists e2]; split; auto. right; right; auto. left; auto. Qed. Lemma u_in_ob E co si lob e1 e2 : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> rel_union (rel_seq (obsplus E co) (maybe (scaob E si))) (lob E) e1 e2 -> ob E co (si E) (lob E) e1 e2. Proof. intros Hsiwf Hrfwf Hcowf [[e [Hobsp [Heq | Hscaob]]] |Hlob]. rewrite Heq in Hobsp; clear Heq. apply obsp_in_ob; auto. apply obsp_scaob_in_ob with e; auto. apply _lob; auto. Qed. Lemma tc_in_ob E co si lob x y : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> transitive_closure (rel_union (rel_seq (obsplus E co) (maybe (scaob E si))) (lob E)) x y -> ob E co (si E) (lob E) x y. Proof. intros Hsiwf Hrfwf Hcowf Hxy; induction Hxy. apply u_in_ob; auto. clear Hxy; apply _ob with e; auto; apply u_in_ob; auto. Qed. Lemma tc_preorder_cb_seq_mobs_extra_irr E co si lob x: si_well_formed E (si E) -> lob_well_formed E si lob -> rf_well_formed E -> co_well_formed E co -> external_visibility E co si lob -> transitive_closure (rel_seq (preorder_cb E si lob) (maybe (obs_extra E co))) x x -> False. Proof. intros Hsiwf Hlobwf Hrfwf Hcowf Hext_vis Hx; generalize (tc_preorder_cb_seq_mobs_extra_dec Hlobwf Hrfwf Hcowf Hx); clear Hx. intros [[y [Hxy Htc]] | Hscaob]. generalize (tc_u_scaob_is_tc Hlobwf Hrfwf Htc Hxy); clear Htc Hxy x; intro Hy; apply Hext_vis; exists y. apply tc_in_ob; auto. apply scaob_irr with E si x; auto. Qed. Lemma preorder_cb_erln_dec (E : set Event) (si lob : set Event -> Rln Event) (e1 e3 : Event) : si_well_formed E (si E) -> lob_well_formed E si lob -> rf_well_formed E -> rel_seq (preorder_cb E si lob) (erln E si) e1 e3 -> (preorder_cb E si lob) e1 e3. Proof. intros Hsiwf Hlobwf Hrfwf [e2 [[Hlob12 | Hscaob12] H23]]; generalize Hlobwf; intros Hlobwf'; destruct_lob_wf Hlobwf'. left; auto. apply Hlob_erln; exists e2; split; auto. right; auto. apply scaob_erln_is_scaob with e2; auto. Qed. Lemma tcu_e_is_tcu2 E co si lob a e b : si_well_formed E (si E) -> lob_well_formed E si lob -> rf_well_formed E -> transitive_closure (rel_union (rel_seq (obsplus E co) (erln E si)) (preorder_cb E si lob)) a e -> erln E si e b -> transitive_closure (rel_union (rel_seq (obsplus E co) (erln E si)) (preorder_cb E si lob)) a b. Proof. intros Hsiwf Hlobwf Hrfwf Hae Heb; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl [Hsym Htrans]]. induction Hae. inversion H as [Ho | Hpc]; clear H. destruct Ho as [a [H1a Ha2]]; apply _base; left; exists a; split; auto. apply Htrans with e2; auto. apply _base; right; apply preorder_cb_erln_dec; auto; exists e2; split; auto. apply _trans with e; auto. Qed. Lemma preorder_cb_in_dec (E : set Event) (co si lob : set Event -> Rln Event) (x y : Event) : preorder_cb E si lob x y -> rel_seq (maybe (scaob E si)) (ob E co (si E) (lob E)) x y \/ (scaob E si) x y. Proof. intros [Hlob | Hsi]; [left; exists x; split | ]; auto. left; auto. apply _lob; auto. Qed. Lemma tc_e_in_ob_or_scaob2 (E : set Event) (co si lob : set Event -> Rln Event) (x y z : Event) : si_well_formed E (si E) -> lob_well_formed E si lob -> rf_well_formed E -> transitive_closure (rel_union (rel_seq (obsplus E co) (erln E si)) (preorder_cb E si lob)) x y -> erln E si y z -> rel_seq (maybe (scaob E si)) (ob E co (si E) (lob E)) x z \/ (scaob E si) x z. Proof. intros Hsiwf Hlobwf Hrfwf Hxy Hyz; generalize (tcu_e_is_tcu2 Hsiwf Hlobwf Hrfwf Hxy Hyz); clear Hxy Hyz; intros Hxz. induction Hxz; [| clear Hxz]. inversion H as [Hobs | Hpc]; clear H; [left; exists e1; split; auto; [left | apply op_e_in_ob]; auto | apply preorder_cb_in_dec]; auto. inversion H as [Hobs1e | Hpc1e]; clear H; inversion IHHxz as [Hobe2 | Hsie2]; clear IHHxz. destruct Hobe2 as [b [[Heqeb | [Hsieb ?]] Hb2]]. rewrite Heqeb in Hobs1e; clear Heqeb; left; exists e1; split; auto; [left|apply _ob with b; auto; apply op_e_in_ob]; auto. destruct Hobs1e as [a [H1a [? [? [Hae ?]]]]]; left; exists e1; split; auto; [left|apply _ob with b; auto; apply op_si_in_ob with a; auto; destruct_siwf Hsiwf; apply Htrans with e]; auto. destruct Hsie2 as [Hsi ?]; destruct Hobs1e as [a [H1a [? [? [Hae ?]]]]]. left; exists e1; split; auto; [left | apply op_si_in_ob with a; auto; destruct_siwf Hsiwf; apply Htrans with e]; auto. inversion Hpc1e as [Hlob1e | Hsi1e]; clear Hpc1e; [left; exists e1; split; auto; [left |]|]; auto. destruct Hobe2 as [b [[Heqeb | Hscaobeb] Hb2]]; apply _ob with b; auto. rewrite Heqeb in Hlob1e; clear Heqeb; apply _lob; auto. destruct_lob_wf Hlobwf; apply _lob; apply Hlob_scaob; exists e; split; auto. destruct Hobe2 as [b [[Heqeb | Hscaobeb] Hb2]]. rewrite Heqeb in Hsi1e; clear Heqeb; left; exists b; split; auto; right; auto. generalize (scaob_scaob_contrad Hrfwf Hsi1e Hscaobeb); intro Ht; inversion Ht. inversion Hpc1e as [Hlob1e | Hsi1e]; clear Hpc1e. left; exists e1; split; [left|apply _lob; destruct_lob_wf Hlobwf; apply Hlob_scaob; exists e]; auto. generalize (scaob_scaob_contrad Hrfwf Hsi1e Hsie2); intro Ht; inversion Ht. Qed. Lemma e_tc_union_irr2 (E : set Event) (co si lob : set Event -> Rln Event) (x : Event) : si_well_formed E (si E) -> lob_well_formed E si lob -> rf_well_formed E -> external_visibility E co si lob -> rel_seq (erln E si) (transitive_closure (rel_union (rel_seq (obsplus E co) (erln E si)) (preorder_cb E si lob))) x x -> False. Proof. intros Hsiwf Hlobwf Hrfwf Hev [y [Hxy Hyx]]. generalize (tc_e_in_ob_or_scaob2 Hsiwf Hlobwf Hrfwf Hyx Hxy); clear Hxy Hyx x; intros [[x [[Heq | Hsi] Hob]] | Hscaob]. rewrite Heq in Hob; clear Heq; apply Hev; exists x; auto. apply Hev; exists x; apply ob_scaob with y; auto. apply scaob_irr with E si y; auto. Qed. Lemma br4_base_dec (E : set Event) (co si lob : set Event -> Rln Event) (e1 e2 : Event) : si_well_formed E (si E) -> lob_well_formed E si lob -> rf_well_formed E -> co_well_formed E co -> rel_seq (maybe (transitive_closure (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si))))) (rel_seq (rel_seq (erln E si) (rel_seq (preorder_cb E si lob) (erln E si))) (maybe (transitive_closure (rel_seq (erln E si) (rel_seq (obsplus E co) (erln E si)))))) e1 e2 -> rel_seq (erln E si) (transitive_closure (rel_union (rel_seq (obsplus E co) (erln E si)) (preorder_cb E si lob))) e1 e2. Proof. intros Hsiwf Hlobwf Hrfwf Hcowf H12; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl [Hsym Htrans]]. destruct H12 as [x [H1x [y [Hxy Hy2]]]]; inversion H1x as [Heq1x | Htc1x]; clear H1x; inversion Hy2 as [Heqy2 | Htcy2]; clear Hy2. rewrite Heq1x; rewrite <- Heqy2; clear Heq1x Heqy2; destruct Hxy as [z [Hxz Hzy]]; exists z; split; auto; apply _base; right; apply (preorder_cb_erln_dec Hsiwf Hlobwf Hrfwf Hzy). rewrite Heq1x; clear Heq1x; destruct Hxy as [z [Hxz Hzy]]; exists z; split; auto; clear Hxz. generalize (tc_dec2 Htcy2); clear Htcy2; intros [e [[d [Hyd Hde]] He2]]. assert (rel_seq (preorder_cb E si lob) (erln E si) z d) as Hzd. destruct Hzy as [z' [Hzz' Hz'y]]; exists z'; split; auto; apply Htrans with y; auto. apply _trans with d; [right; apply preorder_cb_erln_dec|apply oe_mtc_eoe_in_tc with e]; auto. rewrite Heqy2 in Hxy; clear Heqy2; destruct Hxy as [z [Hxz Hz2]]; generalize (tc_dec2 Htc1x); clear Htc1x; intros [b [[a [H1a Hab]] Hbx]]; exists a; split; auto; apply tc_trans with z; auto. generalize (mtc_eoe_e_is_mtc_eoe Hsiwf Hrfwf Hbx Hxz); intros [Hmbz | Heqbz]. apply oe_mtc_eoe_in_tc with b; auto. apply _base; left; destruct Hab as [e [Hae Heb]]; exists e; split; auto; apply Htrans with b; auto. apply _base; right; apply preorder_cb_erln_dec; auto. destruct Hxy as [z [Hxz Hz2]]; generalize (tc_dec2 Htc1x); clear Htc1x; intros [b [[a [H1a Hab]] Hbx]]; generalize (tc_dec2 Htcy2); clear Htcy2; intros [e [[d [Hyd Hde]] He2]]. exists a; split; auto; clear H1a; generalize (mtc_eoe_e_is_mtc_eoe Hsiwf Hrfwf Hbx Hxz); clear Hbx Hxz; intros [Hmbz | Heqbz]. generalize (oe_mtc_eoe_in_tc (preorder_cb E si lob) Hsiwf Hrfwf Hab Hmbz); clear Hab Hmbz; intro Haz; apply tc_trans with z; auto; clear Haz. apply _trans with d; auto; [right; apply preorder_cb_erln_dec|]; auto. destruct Hz2 as [f [Hzf Hfy]]; exists f; split; auto; apply Htrans with y; auto. apply oe_mtc_eoe_in_tc with e; auto. apply tc_trans with z; auto. apply _base; destruct Hab as [x' [Hax' Hx'b]]; left; exists x'; split; auto; apply Htrans with b; auto. apply _trans with d; auto; [right; apply preorder_cb_erln_dec|]; auto. destruct Hz2 as [f [Hzf Hfy]]; exists f; split; auto; apply Htrans with y; auto. apply oe_mtc_eoe_in_tc with e; auto. Qed. Lemma br4_dec (E : set Event) (co si lob : set Event -> Rln Event) (e1 e2 : Event) : si_well_formed E (si E) -> lob_well_formed E si lob -> rf_well_formed E -> co_well_formed E co -> (big_rel4 E co si lob) e1 e2 -> rel_seq (erln E si) (transitive_closure (rel_union (rel_seq (obsplus E co) (erln E si)) (preorder_cb E si lob))) e1 e2. Proof. intros Hsiwf Hlobwf Hrfwf Hcowf H12; induction H12. apply br4_base_dec; auto. generalize (br4_base_dec Hsiwf Hlobwf Hrfwf Hcowf H); clear H H12; intros [a [H1a Hae]]; exists a; split; auto; clear H1a; destruct IHtransitive_closure as [b [Heb Hb2]]; apply tc_trans with b; auto; clear Hb2. apply tcu_e_is_tcu2 with e; auto. Qed. Lemma pre_gc_irr (E : set Event) (co si lob : set Event -> Rln Event) : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> internal_visibility E co -> external_visibility E co si lob -> (forall x : Event, ~ pre_gc E co si lob x x). Proof. intros Hsiwf Hrfwf Hcowf Hlobwf Hint_vis Hext_vis x Hx. generalize (pre_gc_dec Hsiwf Hrfwf Hcowf Hx); clear Hx; intros [Heoe|Hx]. rewrite obs_extra_obsp_eq in Heoe; auto. generalize (tc_eoe_is_e_seq_tc_oe Hsiwf Hrfwf Heoe); intros [y [Hxy Hyx]]; apply e_tc_union_irr2 with E co si lob x; auto; exists y; split; auto; apply tc_incl with (rel_seq (obsplus E co) (erln E si)); auto; intros e1 e2 H12; left; auto. apply e_tc_union_irr2 with E co si lob x; auto; apply br4_dec; auto. Qed. Lemma pre_gc_in_evts (E : set Event) (co si lob : set Event -> Rln Event) : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> Included Event (Union Event (dom (pre_gc E co si lob)) (ran (pre_gc E co si lob))) E. Proof. intros Hsiwf Hrfwf Hcowf Hlobwf; apply r_in_evts_implies_tc_in_evts; intros _x [x Hdom | y Hran]. destruct Hdom as [e' Hxe']; inversion Hxe' as [[y [[Hrf ?] Hsi]] | [[y [Hco Hsi]]| [[y [Hfr Hsi]] | [Hlob | [Hsi ?]]]]]; clear Hxe'. apply dom_rf_in_evts with y; auto. apply dom_co_in_evts with co y; auto. apply dom_fr_in_evts with co y; auto. destruct_lob_wf Hlobwf; apply dom_po_in_evts with e'; auto. assert (dom (si E) x) as Hdx. exists e'; auto. destruct_siwf Hsiwf; generalize (Hdom x Hdx); intros [? ?]; auto. destruct Hran as [e' Hxe']; inversion Hxe' as [[x [[Hrf ?] [? [? [Hsi ?]]]]] | [[x [Hco [? [? [Hsi ?]]]]]| [[x [Hfr [? [? [Hsi ?]]]]] | [Hlob | [Hsi ?]]]]]; clear Hxe'. assert (ran (si E) y) as Hry. exists x; auto. destruct_siwf Hsiwf; generalize (Hran y Hry); intros [? ?]; auto. assert (ran (si E) y) as Hry. exists x; auto. destruct_siwf Hsiwf; generalize (Hran y Hry); intros [? ?]; auto. assert (ran (si E) y) as Hry. exists x; auto. destruct_siwf Hsiwf; generalize (Hran y Hry); intros [? ?]; auto. destruct_lob_wf Hlobwf; apply ran_po_in_evts with e'; auto. assert (ran (si E) y) as Hry. exists e'; auto. destruct_siwf Hsiwf; generalize (Hran y Hry); intros [? ?]; auto. Qed. Lemma pre_gc_partial_order (E : set Event) (co si lob : set Event -> Rln Event) : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> internal_visibility E co -> external_visibility E co si lob -> partial_order (pre_gc E co si lob) E. Proof. intros Hsiwf Hrfwf Hcowf Hlobwf Hint_vis Hext_vis; split; [|split]. apply pre_gc_in_evts; auto. intros e1 e2 e3 H12 H23; apply tc_trans with e2; auto. apply pre_gc_irr; auto. Qed. Lemma cb_is_lin (E : set Event) (co si lob : set Event -> Rln Event) (cb : Rln (Class Event)) : clinearisations (lift (MemC E si) (pre_gc E co si lob)) (MemC E si) cb -> clinearisations (preorder_cb_lift E si lob (MemC E si)) (MemC E si) cb. Proof. intros Hlin; apply clin_of_big_is_clin_of_little with (lift (MemC E si) (pre_gc E co si lob)); auto. apply rel_incl_lift; auto. intros x y Hxy; apply _base; right; right; right; auto. Qed. Lemma co_in_pre_gc E co si lob : si_well_formed E (si E) -> rf_well_formed E -> rel_incl (co E) (pre_gc E co si lob). Proof. intros Hsiwf Hrfwf x y Hxy; apply _base; right; left; auto. generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl ?]. exists y; split; auto. Qed. Lemma co_cb_incl (E : set Event) (co si lob : set Event -> Rln Event) cb : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> clinearisations (lift (MemC E si) (pre_gc E co si lob)) (MemC E si) cb -> rel_incl (co E) (cb_co E (dgcb_loc E (MemC E si) cb)). Proof. intros Hsiwf Hcowf Hrfwf Hlin; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl ?]. intros x y Hxy; split; [| split; [|split; [|split; [|split]]]]. apply dom_co_in_evts with co y; auto. apply ran_co_in_evts with co x; auto. apply dom_co_is_write with E co y; auto. apply ran_co_is_write with E co x; auto. apply co_implies_same_loc with E co; auto. split. apply dom_co_in_evts with co y; auto. split. apply ran_co_in_evts with co x; auto. split. generalize (co_in_pre_gc co si lob Hsiwf); intro Hcoincl. generalize (clin_ext_prop (MemC E si) (lift (MemC E si) (pre_gc E co si lob)) cb); intros [Himpl _]; generalize (Himpl Hlin); clear Himpl; intros [Hincl Hlso]. intros Cx Cy HCx HCy Hinx Hiny; apply Hincl; unfold lift; split; auto; split; auto; exists x; exists y; split; auto; split; auto; apply _base; right; left; auto; exists y; split; auto. apply co_implies_same_loc with E co; auto. Qed. Lemma cb_co_incl (E : set Event) (co si lob : set Event -> Rln Event) cb : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> clinearisations (lift (MemC E si) (pre_gc E co si lob)) (MemC E si) cb -> rel_incl (gcb_co E (dgcb_loc E (MemC E si) cb)) (co E). Proof. intros Hsiwf Hcowf Hrfwf Hlin x y Hxy. generalize Hcowf; intros [Hincl Hlin_co]; destruct_lin (Hlin_co (loc x)); generalize (clin_ext_prop (MemC E si) (lift (MemC E si) (pre_gc E co si lob)) cb); intros [Hd1 H2]; generalize (Hd1 Hlin); intros [? Hlin_cb]; destruct Hlin_cb as [Hpart_cb ?]. assert (delift (MemC E si) cb x y) as Hdxy. destruct Hxy as [? [? [? [? [? [? [? [Hdxy ?]]]]]]]]; auto. assert (x <> y) as Hdiff. intro Heq; rewrite <- Heq in Hdxy. assert False as Ht. apply (delift_irr Hsiwf Hrfwf Hpart_cb Hdxy). inversion Ht. assert (Intersection Event E (is_write_same_loc (loc x)) x) as Hx. split; [|split]; destruct Hxy as [? [? [? ?]]]; auto. assert (Intersection Event E (is_write_same_loc (loc x)) y) as Hy. split; [|split]; destruct Hxy as [? [? [? [? [? ?]]]]]; auto. generalize (Htot x y Hdiff Hx Hy); intros [|Hco_yx]; auto. generalize (co_cb_incl Hsiwf Hcowf Hrfwf Hlin y x Hco_yx); intro Hcb_yx. assert (delift (MemC E si) cb x x) as Hxx. apply delift_trans with y; auto. destruct Hcb_yx as [? [? [? [? [? [? [? [Hdyx ?]]]]]]]]; auto. assert False as Ht. apply (delift_irr Hsiwf Hrfwf Hpart_cb Hxx). inversion Ht. Qed. Lemma cb_coeq (E : set Event) (co si lob : set Event -> Rln Event) cb : si_well_formed E (si E) -> co_well_formed E co -> rf_well_formed E -> clinearisations (lift (MemC E si) (pre_gc E co si lob)) (MemC E si) cb -> rel_equal (co E) (cb_co E (dgcb_loc E (MemC E si) cb)). Proof. intros Hsiwf Hcowf Hrfwf Hlin; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl ?]; split. apply co_cb_incl with lob; auto. apply cb_co_incl with lob; auto. Qed. Lemma cb_rf_incl (E : set Event) (co si lob : set Event -> Rln Event) (cb : Rln (Class Event)) : clinearisations (lift (MemC E si) (pre_gc E co si lob)) (MemC E si) cb -> rel_incl (cb_rf E (dgcb_loc E (MemC E si) cb)) (rf E). Proof. intros Hlin; generalize (clin_ext_prop (MemC E si) (lift (MemC E si) (pre_gc E co si lob)) cb); intros [Himpl _]; generalize (Himpl Hlin); clear Himpl; intros [Hincl Hlso]; intros x y Hxy. destruct_lin Hlso; destruct_part Hpart; destruct Hxy as [Hwx [Hry [Hloc [Hval [Hfwd | Hnfwd]]]]]. destruct Hfwd as [Hpo [Hcbyx Hnointerv]]. split; auto; split; auto; split; auto; split; auto; split; auto. apply dom_po_in_evts with y; auto. apply ran_po_in_evts with x; auto. destruct Hnfwd as [Hcb Hnoniterv]. split; auto; split; auto; split; auto; split; auto; split; auto; destruct Hcb as [? [? ?]]; auto. Qed. Definition cb_rf_wf (E : set Event) (si : set Event -> Rln Event) (cb : Rln (Class Event)) := forall r : Event, is_read r -> exists w : Event, cb_rf E (dgcb_loc E (MemC E si) cb) w r. Lemma rf_implies_diff_classes E si w r : si_well_formed E (si E) -> rf_well_formed E -> rf E w r -> class_of (erln E si) w <> class_of (erln E si) r. Proof. intros Hsiwf Hrfwf Hwr; generalize (erln_is_equiv si Hsiwf Hrfwf); intro Heqr. generalize (dom_rf_is_write Hwr); intro Hw. generalize (ran_rf_is_read Hwr); intro Hr. generalize (class_of_refl w Heqr); intros HCw Heq; rewrite Heq in HCw; clear Heq. destruct HCw as [? [? [? Hor]]]; inversion Hor as [[Hiswr ?] | [[? [x [Hrfw ?]]] | [w1 [w2 [? [[Hrf ?] ?]]]]]]; clear Hor. apply read_write_contrad with r; auto. apply read_write_contrad with w; auto. apply ran_rf_is_read with E x; auto. apply read_write_contrad with w; auto. apply ran_rf_is_read with E w2; auto. Qed. Lemma cb_rf_is_wf (E : set Event) (co si lob : set Event -> Rln Event) (cb : Rln (Class Event)) : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> internal_visibility E co -> external_visibility E co si lob -> clinearisations (lift (MemC E si) (pre_gc E co si lob)) (MemC E si) cb -> cb_rf_wf E si cb. Proof. intros Hsiwf Hrfwf Hcowf Hlobwf Hint_vis Hext_vis Hlin r Hr; generalize (erln_is_equiv si Hsiwf Hrfwf); intros [Hrefl ?]; unfold gcb_rf. generalize Hrfwf; intro Hrfwf'; destruct_rf_wf Hrfwf'; generalize (Hex_uni r Hr); intros [[w Hrf] Huni]; generalize (clin_ext_prop (MemC E si) (lift (MemC E si) (pre_gc E co si lob)) cb); intros [Himpl _]; generalize (Himpl Hlin); clear Himpl; intros [Hincl Hlso]; exists w; split; [apply dom_rf_is_write with E r | split; [apply ran_rf_is_read with E w | split; [apply rf_implies_same_loc with E | split; [apply rf_implies_same_val with E | ]]]]; auto. assert (E w) as HEw. apply dom_rf_in_evts with r; auto. assert (E r) as HEr. apply ran_rf_in_evts with w; auto. generalize (int_or_ext E w r HEw HEr); intros [Hint | Hext]. Focus 2. assert (dgcb_loc E (MemC E si) cb w r) as Hcbwr. split; auto; split; auto; split; auto. unfold delift; intros Cw Cr HinCw HinCr HCw HCr; apply Hincl; unfold lift; split; auto; split; auto; exists w; exists r; split; auto; split; auto; left; left; exists r; split; auto; split; auto. apply rf_implies_same_loc with E; auto. right; split; auto. intros [w' [Hw' [[Hcbww' Hlocww'] [Hcbw'r Hlocw'r]]]]. assert (E w') as HEw'. destruct Hcbw'r; auto. generalize (cb_co_incl Hsiwf Hcowf Hrfwf Hlin); intro Hcoincl. assert (is_write w) as Hw. apply dom_rf_is_write with E r; auto. assert (co E w w') as Hcoww'. apply Hcoincl; split; auto; split; auto. assert (fr E co r w') as Hfrrw'. exists w; split; auto. assert (dgcb_loc E (MemC E si) cb r w') as Hcbrw'. split; auto; split; auto; split; auto. unfold delift; intros Cr Cw' HinCr HinCw' HCr HCw'. apply Hincl; unfold lift; split; auto; split; auto. exists r; exists w'; split; auto; split; auto; left; right; right; left; auto; exists w'; split; auto. destruct_lin Hlso; destruct_part Hpart. apply Hirr with (class_of (erln E si) w'); apply Htrans with (class_of (erln E si) r). destruct Hcbw'r as [? [? [Hd ?]]]; apply Hd. apply class_of_in_classes; auto; apply erln_is_equiv; auto. apply class_of_in_classes; auto; apply erln_is_equiv; auto. apply class_of_refl; auto; apply erln_is_equiv; auto. apply class_of_refl; auto; apply erln_is_equiv; auto. destruct Hcbrw' as [? [? [Hd ?]]]; apply Hd. apply class_of_in_classes; auto; apply erln_is_equiv; auto. apply class_of_in_classes; auto; apply erln_is_equiv; auto. apply class_of_refl; auto; apply erln_is_equiv; auto. apply class_of_refl; auto; apply erln_is_equiv; auto. assert (cb (class_of (erln E si) w) (class_of (erln E si) r) \/ cb (class_of (erln E si) r) (class_of (erln E si) w)) as Hor. destruct_lin Hlso; apply Htot; auto. apply rf_implies_diff_classes; auto. apply class_of_in_classes; auto; apply erln_is_equiv; auto. apply class_of_in_classes; auto; apply erln_is_equiv; auto. inversion Hor as [Hcbwr | Hcbrw]; clear Hor; [right|left]; split; auto. split; auto; split; auto; split; auto. unfold delift; intros Cw Cr HinCw HinCr HCw HCr. destruct HinCr as [cr HinCr]; assert (Cr = class_of (erln E si) r) as HeqCr. rewrite HinCr; apply equiv_elts_have_equal_classes; auto. apply erln_is_equiv; auto. rewrite HinCr in HCr; unfold class_of in HCr; auto. destruct HinCw as [cw HinCw]; assert (Cw = class_of (erln E si) w) as HeqCw. rewrite HinCw; apply equiv_elts_have_equal_classes; auto. apply erln_is_equiv; auto. rewrite HinCw in HCw; unfold class_of in HCw; auto. rewrite HeqCr; rewrite HeqCw; auto. apply rf_implies_same_loc with E; auto. intros [w' [Hw' [[Hcbww' Hlocww'] [Hcbw'r Hlocw'r]]]]. assert (E w') as HEw'. destruct Hcbw'r; auto. generalize (cb_co_incl Hsiwf Hcowf Hrfwf Hlin); intro Hcoincl. assert (is_write w) as Hw. apply dom_rf_is_write with E r; auto. assert (co E w w') as Hcoww'. apply Hcoincl; split; auto; split; auto. assert (fr E co r w') as Hfrrw'. exists w; split; auto. assert (dgcb_loc E (MemC E si) cb r w') as Hcbrw'. split; auto; split; auto; split; auto. unfold delift; intros Cr Cw' HinCr HinCw' HCr HCw'. apply Hincl; unfold lift; split; auto; split; auto. exists r; exists w'; split; auto; split; auto; left; right; right; left; auto; exists w'; split; auto. destruct_lin Hlso; destruct_part Hpart. apply Hirr with (class_of (erln E si) w'); apply Htrans with (class_of (erln E si) r). destruct Hcbw'r as [? [? [Hd ?]]]; apply Hd. apply class_of_in_classes; auto; apply erln_is_equiv; auto. apply class_of_in_classes; auto; apply erln_is_equiv; auto. apply class_of_refl; auto; apply erln_is_equiv; auto. apply class_of_refl; auto; apply erln_is_equiv; auto. destruct Hcbrw' as [? [? [Hd ?]]]; apply Hd. apply class_of_in_classes; auto; apply erln_is_equiv; auto. apply class_of_in_classes; auto; apply erln_is_equiv; auto. apply class_of_refl; auto; apply erln_is_equiv; auto. apply class_of_refl; auto; apply erln_is_equiv; auto. apply rfi_implies_po with co; auto; split; auto. split; auto. split; auto; split; auto; split; auto. unfold delift; intros Cr Cw HinCr HinCw HCr HCw. destruct HinCr as [cr HinCr]; assert (Cr = class_of (erln E si) r) as HeqCr. rewrite HinCr; apply equiv_elts_have_equal_classes; auto. apply erln_is_equiv; auto. rewrite HinCr in HCr; unfold class_of in HCr; auto. destruct HinCw as [cw HinCw]; assert (Cw = class_of (erln E si) w) as HeqCw. rewrite HinCw; apply equiv_elts_have_equal_classes; auto. apply erln_is_equiv; auto. rewrite HinCw in HCw; unfold class_of in HCw; auto. rewrite HeqCr; rewrite HeqCw; auto. generalize (rf_implies_same_loc Hrf); auto. intros [w' [Hw' [[Hpoww' Hlocww'] [Hpow'r Hlocw'r]]]]. assert (is_write w) as Hw. apply dom_rf_is_write with E r; auto. assert (co E w w') as Hcoww'. apply posWW_is_coi; auto. assert (fr E co r w') as Hfrrw'. exists w; split; auto. apply Hint_vis; exists w'; apply _trans with r; auto; [right; right; right; split|apply _base]; auto. Qed. Lemma rf_cb_incl (E : set Event) (co si lob : set Event -> Rln Event) (cb : Rln (Class Event)) : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> internal_visibility E co -> external_visibility E co si lob -> clinearisations (lift (MemC E si) (pre_gc E co si lob)) (MemC E si) cb -> rel_incl (rf E) (cb_rf E (dgcb_loc E (MemC E si) cb)). Proof. intros Hsiwf Hrfwf Hcowf Hlobwf Hint_vis Hext_vis Hlin; intros x y Hxy. assert (is_read y) as Hry. apply ran_rf_is_read with E x; auto. generalize (cb_rf_is_wf Hsiwf Hrfwf Hcowf Hlobwf Hint_vis Hext_vis Hlin y Hry); intros [w Hcbrfwy]; generalize (cb_rf_incl Hlin Hcbrfwy); intro Hrfwy; destruct_rf_wf Hrfwf; generalize (Hex_uni y Hry); intros [Hex Huni]; clear Hex_uni; generalize (Huni x w Hxy Hrfwy); intro Heq; rewrite Heq; auto. Qed. Lemma cb_rfeq (E : set Event) (co si lob : set Event -> Rln Event) (cb : Rln (Class Event)) : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> internal_visibility E co -> external_visibility E co si lob -> clinearisations (lift (MemC E si) (pre_gc E co si lob)) (MemC E si) cb -> rel_equal (rf E) (cb_rf E (dgcb_loc E (MemC E si) cb)). Proof. intros Hsiwf Hrfwf Hcowf Hlobwf Hint_vis Hext_vis Hlin; generalize (clin_ext_prop (MemC E si) (lift (MemC E si) (pre_gc E co si lob)) cb); intros [Himpl _]; generalize (Himpl Hlin); clear Himpl; intros [Hincl Hlso]; split. apply rf_cb_incl with co lob; auto. apply cb_rf_incl with co lob; auto. Qed. Lemma global_completion_cb (E : set Event) (co si lob : set Event -> Rln Event) (cb : Rln (Class Event)) : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> internal_visibility E co -> external_visibility E co si lob -> clinearisations (lift (MemC E si) (pre_gc E co si lob)) (MemC E si) cb -> global_completion E co si lob cb. Proof. intros Hsiwf Hrfwf Hcowf Hlobwf Hint_vis Hext_vis Hlin; split; [|split]; auto. apply cb_is_lin with co; auto. apply cb_rfeq with co lob; auto. apply cb_coeq with lob; auto. Qed. Lemma udr_lift2 E co si lob : Included (Class Event) (Union (Class Event) (dom (lift (MemC E si) (pre_gc E co si lob))) (ran (lift (MemC E si) (pre_gc E co si lob)))) (MemC E si). Proof. unfold lift; intros ? [Cx [Cy [? ?]] | Cy [Cx [? [? ?]]]]; auto. Qed. Lemma pre_gc_erln_is_pre_gc E co si lob x y z : si_well_formed E (si E) -> rf_well_formed E -> lob_well_formed E si lob -> pre_gc E co si lob x y -> erln E si y z -> pre_gc E co si lob x z. Proof. intros Hsiwf Hrfwf Hlobwf Hxy Hyz; induction Hxy as [x y Hb | x e3 y Htc]. Focus 2. apply _trans with y; auto; unfold pre_gc in IHHxy; generalize (IHHxy Hyz); intro Ht; auto. assert (si E y z) as Hsi. destruct Hyz as [? [? [? ?]]]; auto. generalize (erln_is_equiv si Hsiwf Hrfwf); intros [? [? Htrans]]; inversion Hb as [Hrfsi | [Hcosi | [Hfrsi | Hpc]]]. destruct Hrfsi as [e [Hxe Hey]]; apply _base; left; exists e; split; auto. apply Htrans with y; auto. destruct Hcosi as [e [Hxe Hey]]; apply _base; right; left; exists e; split; auto; apply Htrans with y; auto. destruct Hfrsi as [e [Hxe Hey]]; apply _base; right; right; left; exists e; split; auto; apply Htrans with y; auto. generalize Hlobwf; intro Hlobwf'; destruct_lob_wf Hlobwf'; inversion Hpc as [Hlob | Hscaob]; clear Hpc; apply _base; right; right; right. left. apply Hlob_erln; exists y; split; auto. right; apply scaob_erln_is_scaob with y; auto. Qed. Lemma trans_lift2 E co si lob : si_well_formed E (si E) -> rf_well_formed E -> lob_well_formed E si lob -> partial_order (pre_gc E co si lob) E -> transitive (lift (MemC E si) (pre_gc E co si lob)). Proof. intros Hsiwf Hrfwf Hlobwf Hpart; destruct_part Hpart. unfold lift; intros Cx Cy Cz [HCx [HCy [x [y [Hx [Hy Hxy]]]]]] [? [HCz [y' [z [Hy' [Hz Hy'z]]]]]]; split; auto; split; auto; exists x; exists z; split; auto; split; auto. apply Htrans with y'; auto. unfold MemC in HCy; unfold classes in HCy; unfold class_of in HCy; destruct HCy as [y0 HCy]; rewrite HCy in Hy; rewrite HCy in Hy'. assert (erln E si y y') as Hyy'. generalize (erln_is_equiv si Hsiwf Hrfwf); intro Hequiv; clear Htrans; destruct_eqrln Hequiv; apply Htrans with y0; auto. apply pre_gc_erln_is_pre_gc with y; auto. Qed. Lemma irr_lift2 E co si lob Cx : si_well_formed E (si E) -> rf_well_formed E -> lob_well_formed E si lob -> partial_order (pre_gc E co si lob) E -> ~ lift (MemC E si) (pre_gc E co si lob) Cx Cx. Proof. intros Hsiwf Hrfwf Hlobwf Hpart; destruct_part Hpart. unfold lift; intros [HCx [? [e1 [e2 [H1 [H2 H12]]]]]]. unfold MemC in HCx; unfold classes in HCx; unfold class_of in HCx; destruct HCx as [x0 HCx]; rewrite HCx in H1; rewrite HCx in H2. assert (erln E si e2 e1) as Hyy'. generalize (erln_is_equiv si Hsiwf Hrfwf); intro Hequiv; clear Htrans; destruct_eqrln Hequiv; apply Htrans with x0; auto. apply Hirr with e1; apply pre_gc_erln_is_pre_gc with e2; auto. Qed. Lemma lift_partial_order2 E co si lob : si_well_formed E (si E) -> rf_well_formed E -> lob_well_formed E si lob -> partial_order (pre_gc E co si lob) E -> partial_order (lift (MemC E si) (pre_gc E co si lob)) (MemC E si). Proof. intros Hsiwf Hrfwf Hlobwf Hpart; split; [|split]. apply udr_lift2; auto. apply trans_lift2; auto. intros Cx; apply irr_lift2; auto. Qed. Lemma external_visibility_implies_global_completion (E : set Event) (co si lob : set Event -> Rln Event) : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> internal_visibility E co -> external_visibility E co si lob -> (exists cb, global_completion E co si lob cb). Proof. intros Hsiwf Hrfwf Hcowf Hlobwf Hintv Hextv. generalize (pre_gc_partial_order Hsiwf Hrfwf Hcowf Hlobwf Hintv Hextv); intro Hpart; generalize (lift_partial_order2 Hsiwf Hrfwf Hlobwf Hpart); clear Hpart; intro Hpart. generalize (corder_ext Hpart); intros [cb Hcb]; exists cb. apply global_completion_cb; auto. Qed. (** ** External Visibility <-> Global Completion **) Theorem external_visibility_cb_equivalence (E : set Event) (co si lob : set Event -> Rln Event) : si_well_formed E (si E) -> rf_well_formed E -> co_well_formed E co -> lob_well_formed E si lob -> internal_visibility E co -> (external_visibility E co si lob <-> (exists cb, global_completion E co si lob cb)). Proof. intros Hsiwf Hrfwf Hcowf Hlobwf Hint_vis. split. apply external_visibility_implies_global_completion; auto. apply global_completion_implies_external_visibility; auto. Qed. herd-herdtools7-1ca343e/herd/libdir/arm-models/proofs/non_mixed_v8_equivalences.v000066400000000000000000003724541475314470400302500ustar00rootroot00000000000000(* * The Armv8 Application Level Memory Model. * * This is a machine-readable, executable and formal artefact, which aims to be * an equivalence proof between the three formulations of the * latest stable version of the Armv8 memory model. * If you have comments on the content of this file, please send an email to * memory-model@arm.com, referring to version number: * 814a6fc1610ec1a24f2cbd178e171966375626ac * For a textual version of the model, see section B2.3 of the Armv8 ARM: * https://developer.arm.com/docs/ddi0487/latest/arm-architecture-reference-manual-armv8-for-armv8-a-architecture-profile * * Author: Jade Alglave * * Copyright (C) 2016-2021, Arm Ltd. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 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. * * Neither the name of ARM nor the names of its contributors may be * used to endorse or promote products derived from this software * without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT * HOLDER 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. *) Require Import ZArith. Require Import Ensembles. Hypothesis excluded_middle : forall A, A \/ ~A. Set Implicit Arguments. Ltac decide_equality := decide equality; auto with equality arith. (* Some facts about natural numbers *) Lemma nat_eq_or_not_eq : forall (n1 n2 : nat), n1 = n2 \/ n1 <> n2. Proof. intros n1 n2. rewrite <- eq_nat_is_eq. destruct (eq_nat_decide n1 n2); auto. Qed. Lemma nat_neq_implies_lt : forall (n1 n2 : nat), n1 <> n2 -> (n1 < n2 \/ n2 < n1). Proof. intros n1 n2 Hneq. generalize (nat_total_order n1 n2). intro Htot. apply Htot. auto. Qed. (** * Events **) (** ** Events: Definitions *) Definition Acquire := Set. Definition Release := Set. Definition RMW := Set. Definition Read := Set. Hypothesis read_eq_or_not_eq : forall (r1 r2 : Read), r1 = r2 \/ r1 <> r2. Definition Write := Set. Hypothesis write_eq_or_not_eq : forall (w1 w2 : Write), w1 = w2 \/ w1 <> w2. Definition Fence := Set. Hypothesis fence_eq_or_not_eq : forall (f1 f2 : Fence), f1 = f2 \/ f1 <> f2. Inductive Effect := | read : Read -> Effect | write : Write -> Effect | fence : Fence -> Effect. Lemma eff_eq_or_not_eq : forall (eff1 eff2 : Effect), eff1 = eff2 \/ eff1 <> eff2. Proof. intros eff1 eff2; case_eq eff1. (*eff1 is a read*) intros r1 Hr1; case_eq eff2; intros r2 Hr2. (*eff2 is a read*) generalize (read_eq_or_not_eq r1 r2); intros [Heq12 | Hneq12]. rewrite Heq12; auto. right; intro Heq; inversion Heq; apply Hneq12; auto. (*eff2 is a write*) right; intro Heq; inversion Heq. (*eff2 is a fence*) right; intro Heq; inversion Heq. (*eff1 is a write*) intros w1 Hr1; case_eq eff2; intros w2 Hr2. (*eff2 is a read*) right; intro Heq; inversion Heq. (*eff2 is a write*) generalize (write_eq_or_not_eq w1 w2); intros [Heq12 | Hneq12]. rewrite Heq12; auto. right; intro Heq; inversion Heq; apply Hneq12; auto. (*eff2 is a fence*) right; intro Heq; inversion Heq. (*eff1 is a fence*) intros f1 Hf1; case_eq eff2; intros f2 Hf2. (*eff2 is a read*) right; intro Heq; inversion Heq. (*eff2 is a write*) right; intro Heq; inversion Heq. (*eff2 is a fence*) generalize (fence_eq_or_not_eq f1 f2); intros [Heq12 | Hneq12]. rewrite Heq12; auto. right; intro Heq; inversion Heq; apply Hneq12; auto. Qed. Definition Id := nat. Definition Location := nat. Definition Value := nat. Record Event := mkev { id : Id; (* Unique identifier, consistent with program order for a given thread *) tid : Id; (* Thread identifier *) effect : Effect; (* Effect type (read, write, etc) *) loc : Location; (* Location accessed by the effect *) val : Value (* Value read or written by the effect *) }. Definition is_write e : Prop := match effect e with | write _ => True | _ => False end. Definition is_read e : Prop := match effect e with | read _ => True | _ => False end. Hypothesis event_id_uniq : forall e1 e2, e1 <> e2 -> id e1 <> id e2. (** ** Events: Lemmas *) Lemma event_eq_or_not_eq : forall (e1 e2 : Event), e1 = e2 \/ e1 <> e2. Proof. intros [id1 tid1 eff1 l1 v1] [id2 tid2 eff2 l2 v2]. generalize (nat_eq_or_not_eq id1 id2); intro Horid. generalize (nat_eq_or_not_eq tid1 tid2); intro Hortid. generalize (nat_eq_or_not_eq l1 l2); intro Horloc. generalize (nat_eq_or_not_eq v1 v2); intro Horval. generalize (eff_eq_or_not_eq eff1 eff2); intro Horeff. inversion Horid as [Heqid | Hneqid]; clear Horid. inversion Hortid as [Heqtid | Hneqtid]; clear Hortid. inversion Horloc as [Heqloc | Hneqloc]; clear Horloc. inversion Horval as [Heqval | Hneqval]; clear Horval. inversion Horeff as [Heqeff | Hneqeff]; clear Horeff. left. rewrite Heqid; rewrite Heqtid; rewrite Heqeff; rewrite Heqloc; rewrite Heqval; auto. right. intro Heq; injection Heq as _ _ Heff _ _; apply Hneqeff; auto. right. intro Heq; injection Heq as _ _ _ _ Hval; apply Hneqval; auto. right. intro Heq; injection Heq as _ _ _ Hloc _; apply Hneqloc; auto. right. intro Heq; injection Heq as _ Htid _ _ _; apply Hneqtid; auto. right. intro Heq; injection Heq as Hid _ _ _ _; apply Hneqid; auto. Qed. (** * Sets and relations ****) (** ** Sets and relations: Definitions *) Definition set := Ensemble. Definition Rln (A:Type) := A -> A -> Prop. Definition dom (A:Type) (r:Rln A) : set A := fun x => exists y, r x y. Definition ran (A:Type) (r:Rln A) : set A := fun y => exists x, r x y. Inductive transitive_closure (r : Rln Event) (e1 e2 : Event) : Prop := | _base : r e1 e2 -> transitive_closure r e1 e2 | _trans : forall e, r e1 e -> transitive_closure r e e2 -> transitive_closure r e1 e2. Definition irreflexive (r : Rln Event) : Prop := ~(exists x, r x x). Definition acyclic (r : Rln Event) : Prop := irreflexive (transitive_closure r). Definition rel_incl (A:Type) (r1 r2 : Rln A) : Prop := forall x y, r1 x y -> r2 x y. Definition rel_equal (r1 r2 : Rln Event) : Prop := rel_incl r1 r2 /\ rel_incl r2 r1. Definition rel_seq (r1 r2 : Rln Event) : Rln Event := fun e1 e2 => exists e, r1 e1 e /\ r2 e e2. Definition rel_union (r1 r2 : Rln Event) : Rln Event := fun e1 e2 => r1 e1 e2 \/ r2 e1 e2. Definition maybe r : Rln Event := fun e1 e2 => e1 = e2 \/ r e1 e2. Definition transitive (A:Type) (r:Rln A) : Prop := (forall x1 x2 x3, (r x1 x2) -> (r x2 x3) -> (r x1 x3)). Axiom Extensionality_Rlns : forall R1 R2:Rln Event, rel_incl R1 R2 /\ rel_incl R2 R1 -> R1 = R2. (** ** Sets and relations: Lemmas *) Lemma tc_trans r e1 e2 e3 : transitive_closure r e1 e2 -> transitive_closure r e2 e3 -> transitive_closure r e1 e3. Proof. intros H12 H23; induction H12. apply _trans with e2; auto. apply _trans with e; auto. Qed. Lemma seq_tc_reorg (r1 r2 : Rln Event) x y : rel_seq r1 (rel_seq r2 r1) x y -> rel_seq (transitive_closure (rel_seq r1 r2)) r1 x y. Proof. intros [e1 [Hx1 [e2 [H12 H2y]]]]; exists e2; split; auto; apply _base; exists e1; split; auto. Qed. Lemma tc_seq_inv (r1 r2: Rln Event) x z : transitive_closure (rel_seq (maybe r1) r2) x z -> exists y1, exists y2, (maybe r1) x y1 /\ transitive_closure (rel_seq r2 (maybe r1)) y1 y2 /\ (maybe r2) y2 z. Proof. intro Hxz; induction Hxz. Focus 2. destruct H as [y1 [H1y1 Hy1e]]; destruct IHHxz as [e' [y2 [Hee' [He'y2 Hy22]]]]. exists y1; exists y2; split; auto; split; auto. apply _trans with e'; auto; exists e; split; auto. destruct H as [y1 [H1y1 Hy12]]; exists y1; exists e2; split; auto; split; [apply _base; exists e2; split; auto; left|left]; auto. Qed. Lemma tc_seq_left (r1 r2 : Rln Event) x y z : transitive r1 -> r1 x y -> transitive_closure (rel_seq r1 r2) y z -> transitive_closure (rel_seq r1 r2) x z. Proof. intros Htr1 Hxy Hyz; induction Hyz. Focus 2. apply _trans with e; auto. destruct H as [e' [H1' H'e]]; exists e'; split; auto; apply Htr1 with e1; auto. apply _base; destruct H as [e' [H1' H'2]]; exists e'; split; auto; apply Htr1 with e1; auto. Qed. Lemma tc_seq_right (r1 r2 : Rln Event) x y z : transitive r2 -> transitive_closure (rel_seq r1 r2) x y -> r2 y z -> transitive_closure (rel_seq r1 r2) x z. Proof. intros Htr2 Hxy Hyz; induction Hxy. Focus 2. apply _trans with e; auto. apply _base; destruct H as [x [H1x Hx2]]; exists x; split; auto; apply Htr2 with e2; auto. Qed. Lemma seq_tc_reorg2 (r1 r2 : Rln Event) x y z : transitive r1 -> rel_seq r1 (rel_seq r2 r1) x y -> rel_seq (transitive_closure (rel_seq r1 r2)) r1 y z -> rel_seq (transitive_closure (rel_seq r1 r2)) r1 x z. Proof. intros Htr1 [e1 [Hx1 [e2 [H12 H2y]]]]; intros [e3 [Hy3 H3z]]; exists e3; split; auto; apply tc_trans with e2; auto. apply _base; exists e1; auto. apply tc_seq_left with y; auto. Qed. Lemma tc_seq_incl (r r1 r2 : Rln Event) x y : rel_incl r1 r2 -> rel_seq (transitive_closure r1) r x y -> rel_seq (transitive_closure r2) r x y. Proof. intros Hincl [e [Hxe Hey]]; exists e; split; auto; clear Hey; induction Hxe. apply _base; apply Hincl; auto. apply _trans with e; auto. Qed. Lemma tc_seq_reorg (r1 r2 : Rln Event) x y z : transitive r1 -> transitive_closure (rel_seq r1 (rel_seq r2 r1)) x y -> r1 y z -> transitive_closure (rel_seq r1 (rel_seq r2 r1)) x z. Proof. intros Htr1 Hxy Hyz; induction Hxy. destruct H as [e [H1e He2]]; apply _base; exists e; split; auto. destruct He2 as [e' [Hee' He'2]]; exists e'; split; auto; apply Htr1 with e2; auto. apply _trans with e; auto. Qed. Lemma r_in_evts_implies_tc_in_evts (E : set Event) (r : Rln Event) : Included _ (Union _ (dom r) (ran r)) E -> Included _ (Union _ (dom (transitive_closure r)) (ran (transitive_closure r))) E. Proof. intros Hincl _x [x Hdom | y Hran]. inversion Hdom as [y Htc]; induction Htc. apply Hincl; left; exists e2; auto. apply Hincl; left; exists e; auto. inversion Hran as [x Htc]; induction Htc. apply Hincl; right; exists e1; auto. apply IHHtc; auto. Qed. Lemma tc_incl r1 r2 : rel_incl r1 r2 -> rel_incl (transitive_closure r1) (transitive_closure r2). Proof. intros Hincl x y Hxy; induction Hxy. apply _base; apply Hincl; auto. apply _trans with e; auto. Qed. Lemma seq_tc_seq r1 r2 e1 e2 x y : transitive r2 -> transitive_closure (rel_seq r1 r2) e1 e2 -> maybe (rel_seq r1 r2) e2 x -> r2 x y -> transitive_closure (rel_seq r1 r2) e1 y. Proof. intros Htr2 H12 H2x Hxy. inversion H2x as [Heq2x | Hs2x]; clear H2x. rewrite Heq2x in H12; apply tc_seq_right with x; auto. apply tc_trans with e2; auto; apply _base; destruct Hs2x as [e [H2e Hex]]; exists e; split; auto; apply Htr2 with x; auto. Qed. (** * Linear and linear strict orders ****) (** ** Orders: Definitions *) Definition partial_order (A:Type) (r:Rln A) (xs:set A) : Prop := Included _(Union _ (dom r) (ran r)) xs /\ (* If an event is in the relation, then it's also in the set *) transitive r /\ (* Transitivity *) (forall x, ~(r x x)). (* Irreflexivity *) Ltac destruct_part H := destruct H as [Hinc [Htrans Hirr]]. Definition linear_strict_order (A : Type) (r : Rln A) (xs : set A) : Prop := partial_order r xs /\ (forall x1 x2, (x1 <> x2) -> (xs x1) -> (xs x2) -> (r x1 x2) \/ (r x2 x1)). (* Total *) Ltac destruct_lin H := destruct H as [Hpart Htot]. Parameter linearisations : Rln Event -> set Event -> set (Rln Event). Hypothesis order_ext : forall E r, partial_order r E -> (exists lin_ext, (linearisations r E) lin_ext). Hypothesis lin_ext_prop : forall E r lin_ext, (linearisations r E) lin_ext <-> rel_incl r lin_ext /\ linear_strict_order lin_ext E. (** ** Orders: Lemmas *) Lemma lin_of_big_is_lin_of_little : forall (s : set Event) (r1 r2 : Rln Event) (l : Rln Event), rel_incl r1 r2 -> (linearisations r2 s) l -> (linearisations r1 s) l. Proof. intros s r1 r2 l. intros Hincl_r1r2 Hlin. rewrite lin_ext_prop in Hlin. rewrite lin_ext_prop. destruct Hlin as [Hincl_r2l Hlin]. split. unfold rel_incl. intros e1 e2. intro Hinr1. generalize (Hincl_r1r2 e1 e2 Hinr1). apply Hincl_r2l. apply Hlin. Qed. (** * Built-in herd relations ****) (** ** Herd: Definitions*) Definition internal (E : set Event) (e1 e2 : Event) : Prop := tid e1 = tid e2 /\ E e1 /\ E e2. Definition external (E : set Event) (e1 e2 : Event) : Prop := ~(internal E e1 e2). Definition po (E : set Event) (e1 e2 : Event) : Prop := internal E e1 e2 /\ lt (id e1) (id e2). Definition po_loc (E : set Event) (e1 e2 : Event) : Prop := po E e1 e2 /\ loc e1 = loc e2. Definition rf (E : set Event) (e1 e2 : Event) : Prop := is_write e1 /\ is_read e2 /\ loc e1 = loc e2 /\ val e1 = val e2 /\ E e1 /\ E e2. Ltac destruct_rf H := destruct H as [Hisw [Hisr [Hloceq [Hvaleq [Hinw Hinr]]]]]. Definition pre_co (E : set Event) (e1 e2 : Event) : Prop := is_write e1 /\ is_write e2 /\ loc e1 = loc e2 /\ E e1 /\ E e2. Definition fr (E : set Event) (co : set Event -> Rln Event) (e1 e2 : Event) : Prop := exists w, is_write w /\ rf E w e1 /\ co E w e2. Definition rf_well_formed (E : set Event) : Prop := partial_order (rf E) E /\ forall (r : Event), is_read r -> (exists w, rf E w r) /\ (forall w1 w2, rf E w1 r -> rf E w2 r -> w1 = w2). Ltac destruct_rf_wf H := destruct H as [Hpart_rf Hex_uni]. Definition is_write_same_loc (l : Location) (e : Event) : Prop := is_write e /\ loc e = l. Definition co_well_formed (E : set Event) (co : set Event -> Rln Event) : Prop := (rel_incl (co E) (pre_co E)) /\ forall (l : Location), linear_strict_order (co E) (Intersection _ E (is_write_same_loc l)). Definition rfi (E : set Event) (e1 e2 : Event) : Prop := rf E e1 e2 /\ internal E e1 e2. Definition coi (E : set Event) (co : set Event -> Rln Event) (e1 e2 : Event) : Prop := co E e1 e2 /\ internal E e1 e2. Definition fri (E : set Event) (co : set Event -> Rln Event) (e1 e2 : Event) : Prop := fr E co e1 e2 /\ internal E e1 e2. Definition rfe (E : set Event) (e1 e2 : Event) : Prop := rf E e1 e2 /\ external E e1 e2. Definition coe (E : set Event) (co : set Event -> Rln Event) (e1 e2 : Event) : Prop := co E e1 e2 /\ external E e1 e2. Definition fre (E : set Event) (co : set Event -> Rln Event) (e1 e2 : Event) : Prop := fr E co e1 e2 /\ external E e1 e2. Definition corf E (co : set Event -> Rln Event) (e1 e2 : Event) := exists e, co E e1 e /\ rf E e e2. Definition corfe E (co : set Event -> Rln Event) (e1 e2 : Event) := exists e, co E e1 e /\ rfe E e e2. Definition coirf E (co : set Event -> Rln Event) (e1 e2 : Event) := exists e, coi E co e1 e /\ rf E e e2. Definition coerf E (co : set Event -> Rln Event) (e1 e2 : Event) := exists e, coe E co e1 e /\ rf E e e2. Definition coerfe E (co : set Event -> Rln Event) (e1 e2 : Event) := exists e, coe E co e1 e /\ rfe E e e2. Definition frrf E (co : set Event -> Rln Event) (e1 e2 : Event) := exists e, fr E co e1 e /\ rf E e e2. Definition frrfe E (co : set Event -> Rln Event) (e1 e2 : Event) := exists e, fr E co e1 e /\ rfe E e e2. Definition frrfi E (co : set Event -> Rln Event) (e1 e2 : Event) := exists e, fr E co e1 e /\ rfi E e e2. Definition frerf E (co : set Event -> Rln Event) (e1 e2 : Event) := exists e, fre E co e1 e /\ rf E e e2. Definition complus E co e1 e2 := rf E e1 e2 \/ co E e1 e2 \/ fr E co e1 e2 \/ rel_seq (co E) (rf E) e1 e2 \/ rel_seq (fr E co) (rf E) e1 e2. (** ** Herd: Lemmas *) Lemma int_or_ext (E : set Event) : forall (e1 e2 : Event), E e1 -> E e2 -> internal E e1 e2 \/ external E e1 e2. Proof. intros e1 e2 Hin1 Hin2. unfold external. unfold internal. generalize (nat_eq_or_not_eq (tid e1) (tid e2)). intro Hor. inversion Hor as [Heq|Hdiff]; clear Hor. left; auto. right. unfold not. intros [Heq [? ?]]. unfold not in Hdiff. apply Hdiff. apply Heq. Qed. Lemma int_ext_contrad E e1 e2 : internal E e1 e2 -> external E e1 e2 -> False. Proof. intros Hint Hext; apply Hext; auto. Qed. Lemma internal_trans E x y z : internal E x y -> internal E y z -> internal E x z. Proof. intros [Heqxy [? ?]] [Heqyz [? ?]]; split; [|split]; auto. rewrite Heqxy; auto. Qed. Lemma internal_implies_po_or_po_minus_1 E x y : internal E x y -> x <> y -> po E x y \/ po E y x. Proof. intros Hint Hdiff. assert (id x <> id y) as Hneq. apply event_id_uniq; auto. generalize (nat_neq_implies_lt Hneq); intros [Hxy | Hyx]; [left | right]; split; auto. destruct Hint as [Heq [? ?]]; split; [rewrite Heq|]; auto. Qed. Lemma dom_po_in_evts (E : set Event) (e1 e2 : Event) : po E e1 e2 -> E e1. Proof. intros [[? [? ?]] ?]; auto. Qed. Lemma ran_po_in_evts (E : set Event) (e1 e2 : Event) : po E e1 e2 -> E e2. Proof. intros [[? [? ?]] ?]; auto. Qed. Lemma dom_rf_in_evts (E : set Event) (e1 e2 : Event) : rf E e1 e2 -> E e1. Proof. intros [_ [_ [_ [_ [He1_in_E _]]]]]. auto. Qed. Lemma ran_rf_in_evts (E : set Event) (e1 e2:Event) : rf E e1 e2 -> E e2. Proof. intros [_ [_ [_ [_ [_ He2_in_E]]]]]. auto. Qed. Lemma dom_rf_is_write (E : set Event) (e1 e2:Event) : rf E e1 e2 -> is_write e1. Proof. intros [? ?]; auto. Qed. Lemma ran_rf_is_read (E : set Event) (e1 e2:Event) : rf E e1 e2 -> is_read e2. Proof. intros [? [Hr ?]]. auto. Qed. Lemma rf_implies_same_loc (E : set Event) (e1 e2 : Event) : rf E e1 e2 -> loc e1 = loc e2. Proof. intros [? [? [? ?]]]; auto. Qed. Lemma rf_implies_same_val (E : set Event) (e1 e2 : Event) : rf E e1 e2 -> val e1 = val e2. Proof. intros [? [? [? [? ?]]]]; auto. Qed. Lemma dom_co_in_evts (E : set Event) (co : set Event -> Rln Event) (e1 e2 : Event) : co_well_formed E co -> co E e1 e2 -> E e1. Proof. intros [Hincl ?] Hco. destruct (Hincl e1 e2) as [? [? [? [? ?]]]]; auto. Qed. Lemma ran_co_in_evts (E : set Event) (co : set Event -> Rln Event) (e1 e2 : Event) : co_well_formed E co -> co E e1 e2 -> E e2. Proof. intros [Hincl ?] Hco. destruct (Hincl e1 e2) as [? [? [? [? ?]]]]; auto. Qed. Lemma dom_co_is_write (E : set Event) (co : set Event -> Rln Event) (e1 e2 : Event) : co_well_formed E co -> co E e1 e2 -> is_write e1. Proof. intros [Hincl ?] Hco; auto. generalize (Hincl e1 e2 Hco); intros [? [? ?]]; auto. Qed. Lemma ran_co_is_write (E : set Event) (co : set Event -> Rln Event) (e1 e2:Event) : co_well_formed E co -> co E e1 e2 -> is_write e2. Proof. intros [Hincl ?] Hco; auto. generalize (Hincl e1 e2 Hco); intros [? [? ?]]. auto. Qed. Lemma co_implies_same_loc (E : set Event) (co : set Event -> Rln Event) (e1 e2 : Event) : co_well_formed E co -> co E e1 e2 -> loc e1 = loc e2. Proof. intros [Hincl ?] Hco; auto. generalize (Hincl e1 e2 Hco);intros [? [? [? ?]]]; auto. Qed. Lemma dom_fr_in_evts (E : set Event) (co : set Event -> Rln Event) (e1 e2 : Event) : fr E co e1 e2 -> E e1. Proof. intros [? [? [Hrf ?]]]. destruct Hrf as [_ [_ [_ [_ [_ He1_in_E]]]]]. auto. Qed. Lemma ran_fr_in_evts (E : set Event) (co : set Event -> Rln Event) (e1 e2:Event) : co_well_formed E co -> fr E co e1 e2 -> E e2. Proof. intros [Hincl ?] [w [Hw [Hrf Hco]]]; auto. generalize (Hincl w e2 Hco); intros [? [? [? [? ?]]]]; auto. Qed. Lemma dom_fr_is_read (E : set Event) (co : set Event -> Rln Event) (e1 e2:Event) : fr E co e1 e2 -> is_read e1. Proof. intros [x [? [Hrf ?]]]; apply ran_rf_is_read with E x; auto. Qed. Lemma ran_fr_is_write (E : set Event) (co : set Event -> Rln Event) (e1 e2:Event) : co_well_formed E co -> fr E co e1 e2 -> is_write e2. Proof. intros Hcowf [x [? [? Hco]]]; apply ran_co_is_write with E co x; auto. Qed. Lemma fr_implies_same_loc (E : set Event) (co : set Event -> Rln Event) (e1 e2 : Event) : co_well_formed E co -> fr E co e1 e2 -> loc e1 = loc e2. Proof. intros [Hincl ?] [w [Hw [Hrf Hco]]]. generalize (Hincl w e2 Hco); intros [? [? [Hloc ?]]]. destruct_rf Hrf; rewrite <- Hloceq; auto. Qed. Lemma read_write_contrad (e : Event) : is_read e -> is_write e -> False. Proof. intros Hr Hw; unfold is_read in Hr; unfold is_write in Hw; case_eq (effect e). intros r Her; rewrite Her in Hw; auto. intros w Hew; rewrite Hew in Hr; auto. intros f Hef; rewrite Hef in Hr; auto. Qed. Lemma fr_implies_diff (E : set Event) (co : set Event -> Rln Event) (gcb : Rln Event) (e1 e2 : Event) : co_well_formed E co -> fr E co e1 e2 -> e1 <> e2. Proof. intros [Hincl ?] [w [Hw [Hrf Hco]]]. destruct_rf Hrf. generalize (Hincl w e2 Hco); intros [? [Hwe2 [? ?]]]. intro Heq; rewrite Heq in Hisr. apply read_write_contrad with e2; auto. Qed. Lemma rf_fr_is_co E co e1 e2 e3 : rf_well_formed E -> rf E e1 e2 -> fr E co e2 e3 -> co E e1 e3. Proof. intros [? Hr] Hrf12 [w [Hw [Hrfw2 Hco]]]. generalize (ran_rf_is_read Hrf12); intro Hr2; generalize (Hr e2 Hr2); intros [? Huni]; generalize (Huni e1 w Hrf12 Hrfw2); intro Heq; rewrite <- Heq in Hco; auto. Qed. Lemma co_trans E co e1 e2 e3 : co_well_formed E co -> co E e1 e2 -> co E e2 e3 -> co E e1 e3. Proof. intros Hcowf H12 H23; generalize (co_implies_same_loc e1 e2 Hcowf H12); intro Hl12; generalize (co_implies_same_loc e2 e3 Hcowf H23); intro Hl23. destruct Hcowf as [Hincl Hlin]; generalize (Hlin (loc e1)); clear Hlin; intro Hlin; destruct_lin Hlin; destruct_part Hpart; apply Htrans with e2; auto. Qed. Lemma fr_co_is_fr E co e1 e2 e3 : co_well_formed E co -> fr E co e1 e2 -> co E e2 e3 -> fr E co e1 e3. Proof. intros Hcowf [w [Hw [Hrf Hco]]]; exists w; split; auto; split; auto; apply co_trans with e2; auto. Qed. Lemma rfe_in_rf E x y : rfe E x y -> rf E x y. Proof. intros [? ?]; auto. Qed. Lemma corfe_in_corf E co x y : corfe E co x y -> corf E co x y. Proof. intros [e [Hco [? ?]]]; exists e; split; auto. Qed. Lemma frrfe_in_frrf E co x y : frrfe E co x y -> frrf E co x y. Proof. intros [e [Hfr [? ?]]]; exists e; split; auto. Qed. Lemma rf_complus_in_complus E co e1 e2 e3 : rf_well_formed E -> co_well_formed E co -> rf E e1 e2 -> complus E co e2 e3 -> complus E co e1 e3. Proof. intros Hrfwf [Hincl ?] Hrf12 [Hrf23 | [Hco23 | [Hfr23 | [Hcorf23 | Hfrrf23]]]]. assert False as Ht. destruct Hrf12 as [? [Hr2 ?]]; destruct Hrf23 as [Hw2 ?]; apply (read_write_contrad e2 Hr2 Hw2). inversion Ht. assert False as Ht. generalize (Hincl e2 e3 Hco23); intro Hpco23. destruct Hrf12 as [? [Hr2 ?]]; destruct Hpco23 as [Hw2 ?]; apply (read_write_contrad e2 Hr2 Hw2). inversion Ht. right; left; apply rf_fr_is_co with e2; auto. assert False as Ht. destruct Hrf12 as [? [Hr2 ?]]; destruct Hcorf23 as [e [Hco Hrf]]; generalize (Hincl e2 e Hco); intro Hpco. destruct Hpco as [Hw2 ?]; apply (read_write_contrad e2 Hr2 Hw2). inversion Ht. right; right; right; left; destruct Hfrrf23 as [e [Hfr Hrf]]; exists e; split; auto; apply rf_fr_is_co with e2; auto. Qed. Lemma co_complus_in_complus E co e1 e2 e3 : co_well_formed E co -> co E e1 e2 -> complus E co e2 e3 -> complus E co e1 e3. Proof. intros Hcowf Hco12 [Hrf23 | [Hco23 | [Hfr23 | [Hcorf23 | Hfrrf23]]]]. right; right; right; left; exists e2; auto. right; left; apply co_trans with e2; auto. assert False as Ht. generalize (ran_co_is_write e1 e2 Hcowf Hco12); intro Hw2; generalize (dom_fr_is_read Hfr23); intro Hr2. apply (read_write_contrad e2 Hr2 Hw2). inversion Ht. right; right; right; left; destruct Hcorf23 as [e [Hcoe2e Hrfee3]]; exists e; split; auto; apply co_trans with e2; auto. assert False as Ht. destruct Hfrrf23 as [e [Hfr Hrf]]. generalize (ran_co_is_write e1 e2 Hcowf Hco12); intro Hw2; generalize (dom_fr_is_read Hfr); intro Hr2. apply (read_write_contrad e2 Hr2 Hw2). inversion Ht. Qed. Lemma fr_complus_in_complus E co e1 e2 e3 : co_well_formed E co -> fr E co e1 e2 -> complus E co e2 e3 -> complus E co e1 e3. Proof. intros Hcowf Hfr12 [Hrf23 | [Hco23 | [Hfr23 | [Hcorf23 | Hfrrf23]]]]. right; right; right; right; exists e2; auto. right; right; left; apply fr_co_is_fr with e2; auto. assert False as Ht. generalize (ran_fr_is_write Hcowf Hfr12); intro Hw2; generalize (dom_fr_is_read Hfr23); intro Hr2; apply (read_write_contrad e2 Hr2 Hw2); auto. inversion Ht. destruct Hcorf23 as [e [Hco Hrf]]; right; right; right; right; exists e; split; auto; apply fr_co_is_fr with e2; auto. assert False as Ht. destruct Hfrrf23 as [e [Hfr Hrf]]. generalize (ran_fr_is_write Hcowf Hfr12); intro Hw2; generalize (dom_fr_is_read Hfr); intro Hr2; apply (read_write_contrad e2 Hr2 Hw2); auto. inversion Ht. Qed. Lemma mcomplus_trans E co : rf_well_formed E -> co_well_formed E co -> transitive (maybe (complus E co)). Proof. intros Hrfwf Hcowf x y z Hxy Hyz. inversion Hxy as [Heqxy | Hmcpxy]; clear Hxy; inversion Hyz as [Heqyz | Hmcpyz]; clear Hyz. left; rewrite Heqxy; auto. right; rewrite Heqxy; auto. right; rewrite <- Heqyz; auto. right; inversion Hmcpxy as [Hrf | [Hco | [Hfr | [[e [Hco Hrf]] | [e [Hfr Hrf]]]]]]; clear Hmcpxy. apply rf_complus_in_complus with y; auto. apply co_complus_in_complus with y; auto. apply fr_complus_in_complus with y; auto. apply co_complus_in_complus with e; auto; apply rf_complus_in_complus with y; auto. apply fr_complus_in_complus with e; auto; apply rf_complus_in_complus with y; auto. Qed. Lemma complus_irr E co x : rf_well_formed E -> co_well_formed E co -> complus E co x x -> False. Proof. intros Hrfwf Hcowf; generalize Hcowf; intros [? Hlin]; intros [Hrf | [Hco | [Hfr | [Hcorf | Hfrrf]]]]. apply (read_write_contrad x); [apply ran_rf_is_read with E x | apply dom_rf_is_write with E x]; auto. generalize (Hlin (loc x)); clear Hlin; intro Hlin; destruct_lin Hlin; destruct_part Hpart; generalize Hco; apply Hirr; auto. destruct Hfr as [w [Hw [Hrf Hco]]]; apply (read_write_contrad x); [apply ran_rf_is_read with E w | apply ran_co_is_write with E co w]; auto. destruct Hcorf as [e [Hco Hrf]]; apply (read_write_contrad x); [apply ran_rf_is_read with E e | apply dom_co_is_write with E co e]; auto. destruct Hfrrf as [w [[w' [Hw' [Hrf' Hco]]] Hrf]]. generalize (ran_rf_is_read Hrf'); intro Hrx; destruct_rf_wf Hrfwf; generalize (Hex_uni x Hrx); intros [_ Huni]; generalize (Huni w' w Hrf' Hrf); intro Heq; rewrite Heq in Hco; generalize (Hlin (loc w')); clear Hlin; intro Hlin; destruct_lin Hlin; destruct_part Hpart; generalize Hco; apply Hirr; auto. Qed. Lemma rfe_fri_is_coe E co x z y : rf_well_formed E -> co_well_formed E co -> rfe E x z -> fri E co z y -> coe E co x y. Proof. intros Hrfwf Hcowf [Hrfxz Hextxz] [Hfrzy [Heqzy [? ?]]]; split. apply rf_fr_is_co with z; auto. intros [Heqtidxy [? ?]]; apply Hextxz. split; [rewrite Heqzy|split]; auto. Qed. Lemma fri_coi_is_fri E co x y z : co_well_formed E co -> fri E co x y -> coi E co y z -> fri E co x z. Proof. intros Hcowf [Hfrxy Hintxy] [Hcoyz Hintyz]; split; auto. apply fr_co_is_fr with y; auto. apply internal_trans with y; auto. Qed. (** * ARMv8 axiomatic relations ****) (** ** ARMv8: Definitions *) Definition internal_visibility (E : set Event) (co : set Event -> Rln Event) : Prop := acyclic (fun e1 e2 => rf E e1 e2 \/ co E e1 e2 \/ fr E co e1 e2 \/ po_loc E e1 e2). Definition obs (E : set Event) (co : set Event -> Rln Event) (e1 e2 : Event) : Prop := rfe E e1 e2 \/ co E e1 e2 \/ fr E co e1 e2. Definition obsplus E co := transitive_closure (obs E co). Inductive ob (E : set Event) (co : set Event -> Rln Event) (lob : Rln Event) (e1 e2 : Event) : Prop := | _obs : obs E co e1 e2 -> ob E co lob e1 e2 | _lob : lob e1 e2 -> ob E co lob e1 e2 | _ob : forall e, ob E co lob e1 e -> ob E co lob e e2 -> ob E co lob e1 e2. Definition external_visibility (E : set Event) (co : set Event -> Rln Event) (lob : set Event -> Rln Event) : Prop := irreflexive (ob E co (lob E)). (** Well-formed lob: a relation lob over a set of events E is well-formed when: - lob is irreflexive - lob is transitive - lob starts with a write and ends with a read or write memory event - lob is included in po *) Definition lob_well_formed (E:set Event) (lob : set Event -> Rln Event) := irreflexive (lob E) /\ transitive (lob E) /\ (forall e1 e2, lob E e1 e2 -> is_write e1 \/ is_read e1) /\ rel_incl (lob E) (po E). Ltac destruct_lob_wf H := destruct H as [Hirr_lob [Htrans_lob [Hdom_lob Hincl_po]]]. (** ** ARMv8: Lemmas *) Lemma obs_in_mop (E : set Event) (co : set Event -> Rln Event) (e1 e2 : Event) : obs E co e1 e2 -> maybe (obsplus E co) e1 e2. Proof. right; left; auto. Qed. Lemma obsplus_dec E co e1 e2 : rf_well_formed E -> co_well_formed E co -> transitive_closure (obs E co) e1 e2 -> rfe E e1 e2 \/ co E e1 e2 \/ fr E co e1 e2 \/ corfe E co e1 e2 \/ frrfe E co e1 e2. Proof. intros Hrfwf Hcowf H12; generalize Hcowf; intros [Hincl Hcolin]; induction H12 as [e1 e2 Hb | e1 e2 e H1e He2]. inversion Hb as [Hrfe | [Hco | Hfr]]; auto. inversion H1e as [Hrfe1e | [Hco1e | Hfr1e]]; inversion IHHe2 as [Hrfee2 | [Hcoe2 | [Hfre2 | [Hcorfee2 | Hfrrfee2]]]]. destruct Hrfe1e as [[? [Hre ?]] ?]; destruct Hrfee2 as [[Hwe ?] ?]; generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. generalize (Hincl e e2 Hcoe2); intro Hpcoe2; destruct Hrfe1e as [[? [Hre ?]] ?]; destruct Hpcoe2 as [Hwe ?]; generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. destruct Hrfe1e as [? ?]; right; left; apply rf_fr_is_co with e; auto. destruct Hrfe1e as [[? [Hre ?]] ?]; destruct Hcorfee2 as [w [Hcoew Hrfe]]; generalize (Hincl e w Hcoew); intro Hpcoew; destruct Hpcoew as [Hwe ?]; generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. destruct Hrfe1e as [? ?]; destruct Hfrrfee2 as [w [Hfrew Hrfw2]]; right; right; right; left; exists w; split; auto; apply rf_fr_is_co with e; auto. right; right; right; left; exists e; split; auto. right; left; apply co_trans with e; auto. generalize (Hincl e1 e Hco1e); intro Hpco1e; destruct Hpco1e as [? [Hwe ?]]; destruct Hfre2 as [? [? [[? [Hre ?]] ?]]]; generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. destruct Hcorfee2 as [w [Hcoew Hrfw2]]; right; right; right; left; exists w; split; auto; apply co_trans with e; auto. destruct Hfrrfee2 as [w [Hfrew Hrfw2]]; generalize (dom_fr_is_read Hfrew); intro Hre; generalize (ran_co_is_write e1 e Hcowf Hco1e); intro Hwe; generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. right; right; right; right; exists e; split; auto. right; right; left; apply fr_co_is_fr with e; auto. destruct Hfr1e as [? [? [? Hco]]]; generalize (Hincl x e Hco); intros [? [Hwe ?]]; destruct Hfre2 as [? [? [[? [Hre ?]] ?]]]; generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. destruct Hcorfee2 as [w [Hcoew Hrfewe2]]; right; right; right; right; exists w; split; auto; apply fr_co_is_fr with e; auto. destruct Hfrrfee2 as [w [Hfrew Hrfewe2]]; generalize (dom_fr_is_read Hfrew); intro Hre; generalize (ran_fr_is_write Hcowf Hfr1e); intro Hwe; generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. Qed. Lemma op_trans E co e1 e2 e3 : (obsplus E co) e1 e2 -> (obsplus E co) e2 e3 -> (obsplus E co) e1 e3. Proof. intros H12 H23; apply tc_trans with e2; auto. Qed. Lemma mop_trans E co e1 e2 e3 : maybe (obsplus E co) e1 e2 -> maybe (obsplus E co) e2 e3 -> maybe (obsplus E co) e1 e3. Proof. intros [Heq12 | Htc12]. rewrite Heq12; auto. intros [Heq23 | Htc23]. rewrite <- Heq23; right; auto. right; apply op_trans with e2; auto. Qed. Lemma obsplus_in_scpv E co x y : rf_well_formed E -> co_well_formed E co -> obsplus E co x y -> transitive_closure (fun e1 e2 : Event => rf E e1 e2 \/ co E e1 e2 \/ fr E co e1 e2 \/ po_loc E e1 e2) x y. Proof. intros Hrfwf Hcowf Hxy; generalize (obsplus_dec Hrfwf Hcowf Hxy); intros [[Hrf ?] | [Hco | [Hfr | [[z [Hco [Hrf ?]]] | [z [Hfr [Hrf ?]]]]]]]. apply _base; left; auto. apply _base; right; left; auto. apply _base; right; right; left; auto. apply _trans with z; [right |]; left; auto. apply _trans with z; [right; right |]; left; auto. Qed. Lemma posRW_is_fri E co x y : rf_well_formed E -> co_well_formed E co -> internal_visibility E co -> is_read x -> is_write y -> po E x y -> loc x = loc y -> fri E co x y. Proof. intros Hrfwf Hcowf Hintv Hrx Hwy Hpoxy Hlocxy; generalize Hcowf; intros [Hincl Hlin]; split. destruct_rf_wf Hrfwf; generalize (Hex_uni x Hrx); clear Hex_uni; intros [[w Hrf] Huni]; exists w; split; [apply dom_rf_is_write with E x | split]; auto. generalize (Hlin (loc x)); clear Hlin; intro Hlin; destruct_lin Hlin. assert (Intersection Event E (is_write_same_loc (loc x)) w) as Hw. split; [apply dom_rf_in_evts with x| split; [apply dom_rf_is_write with E x|apply rf_implies_same_loc with E]]; auto. assert (Intersection Event E (is_write_same_loc (loc x)) y) as Hy. split; [apply ran_po_in_evts with x | split]; auto. assert (w <> y) as Hdiff. intro Heq; rewrite Heq in Hrf; apply Hintv; exists x; apply _trans with y; [right; right; right; split| apply _base]; auto. generalize (Htot w y Hdiff Hw Hy); intros [? | Hcoyw]; auto. assert False as Ht. apply Hintv; exists x; apply _trans with y; [right; right; right; split| apply _trans with w; [|apply _base]]; auto. inversion Ht. destruct Hpoxy as [? ?]; auto. Qed. Lemma posWW_is_coi E co w w' : co_well_formed E co -> internal_visibility E co -> is_write w -> is_write w' -> po E w w' -> loc w = loc w' -> co E w w'. Proof. intros Hcowf Hintv Hisw Hisw' Hpoww' Hlocww'; generalize Hcowf; intros [Hincl Hlin]. destruct (Hlin (loc w)) as [Hpart Htot]. assert (w <> w') as Hd. intro Heq; rewrite Heq in Hpoww'. destruct Hpoww' as [? Hlt]; generalize Hlt; apply lt_irrefl. assert (Intersection Event E (is_write_same_loc (loc w)) w) as Hw. split; auto; [apply dom_po_in_evts with w'|split]; auto. assert (Intersection Event E (is_write_same_loc (loc w)) w') as Hw'. split; auto; [apply ran_po_in_evts with w|split]; auto. generalize (Htot w w' Hd Hw Hw'); intros [|Hw'w]; auto. assert False as Ht. apply Hintv; exists w; apply _trans with w'; [right; right; right; split|apply _base]; auto. inversion Ht. Qed. Lemma rfi_implies_po E co w r : internal_visibility E co -> rfi E w r -> po E w r. Proof. intros Hintv [Hrf Hint]. assert (w <> r) as Hdiff. intro Heq; rewrite Heq in Hrf; assert False as Ht. apply read_write_contrad with r; [apply ran_rf_is_read with E r | apply dom_rf_is_write with E r]; auto. inversion Ht. generalize (internal_implies_po_or_po_minus_1 Hint Hdiff); intros [|Hporw]; auto. assert False as Ht. apply Hintv; exists w; auto; apply _trans with r; [left | apply _base; right; right; right; split]; auto. rewrite rf_implies_same_loc with E w r; auto. inversion Ht. Qed. (** * Definitions and lemmas relative to total order based models in general ****) Definition order_to_co (E : set Event) (o : Rln Event) (e1 e2 : Event) : Prop := is_write e1 /\ is_write e2 /\ loc e1 = loc e2 /\ o e1 e2. Lemma co_in_order E co o x y : rel_equal (co E) (order_to_co E o) -> co E x y -> o x y. Proof. intros Hcoeq Hco; destruct Hcoeq as [Hcoincl ?]; generalize (Hcoincl x y Hco); intros [? [? [? ?]]]; auto. Qed. Lemma co_order_incl (E : set Event) (co : set Event -> Rln Event) (r o : Rln Event) : co_well_formed E co -> linearisations r E o -> rel_incl (co E) r -> rel_incl (co E) (order_to_co E o). Proof. intros Hcowf Hlin Hcor; generalize (lin_ext_prop E r o); intros [Himpl _]; generalize (Himpl Hlin); clear Himpl; intros [Hincl Hlso]; intros x y Hxy. split; [apply dom_co_is_write with E co y | split; [apply ran_co_is_write with E co x | split; [apply co_implies_same_loc with E co |apply Hincl; apply Hcor]]]; auto. Qed. (* Lemma order_co_incl (E : set Event) (r o : Rln Event) : linearisations r E o -> rel_incl (order_to_co E o) (co E). Proof. intros Hlin; generalize (lin_ext_prop E r o); intros [Himpl _]; generalize (Himpl Hlin); clear Himpl; intros [Hincl Hlso]; intros x y Hxy. destruct_lin Hlso; destruct_part Hpart; destruct Hxy as [Hwx [Hwy [Hloc Hgcb]]]; split; auto; split; auto; split; auto; split; auto; apply Hinc; auto; [left; exists y | right; exists x]; auto. Qed. Lemma order_coeq (E : set Event) (r o : Rln Event) : linearisations r E o -> rel_incl (co E) r -> rel_equal (co E) (order_to_co E o). Proof. intros Hlin Hcor; split. apply co_order_incl with r; auto. apply order_co_incl with r; auto. Qed. *) Lemma fr_implies_order_or_order_minus_1 (E : set Event) (co : set Event -> Rln Event) (r o : Rln Event) (e1 e2 : Event) : co_well_formed E co -> linearisations r E o -> fr E co e1 e2 -> o e1 e2 \/ o e2 e1. Proof. intros Hcowf Hlin H12. generalize (lin_ext_prop E r o); intros [Himpl ?]; generalize (Himpl Hlin); intros [Hincl Hlso]; destruct_lin Hlso. apply Htot; auto. apply fr_implies_diff with E co; auto. apply dom_fr_in_evts with co e2; auto. apply ran_fr_in_evts with co e1; auto. Qed. Lemma mop_in_order E co r o x y : rf_well_formed E -> co_well_formed E co -> linearisations r E o -> rel_incl (rfe E) o -> rel_incl (co E) o -> rel_incl (fr E co) o -> maybe (obsplus E co) x y -> x = y \/ o x y. Proof. intros Hrfwf Hcowf Hlin Hrfeincl Hcoincl Hfrincl [? | Hxy]; auto; right. generalize (obsplus_dec Hrfwf Hcowf Hxy); clear Hxy; generalize (lin_ext_prop E r o); intros [Himpl _]; generalize (Himpl Hlin); clear Himpl; intros [Hincl Hlso]; destruct_lin Hlso; destruct_part Hpart; intros [Hrfe | [Hco | [Hfr | [[z [Hco Hrfe]] | [z [Hfr Hrfe]]]]]]. apply Hrfeincl; auto. apply Hcoincl; auto. apply Hfrincl; auto. apply Htrans with z; [apply Hcoincl | apply Hrfeincl]; auto. apply Htrans with z; [apply Hfrincl | apply Hrfeincl]; auto. Qed. Definition mobs_r_mobs E co r := rel_seq (maybe (obsplus E co)) (rel_seq r (maybe (obsplus E co))). Definition tc_mobs_r_mobs E co r := transitive_closure (mobs_r_mobs E co r). Lemma mobs_r_mobs_in_order E co r o e1 e2 : rf_well_formed E -> co_well_formed E co -> linearisations r E o -> rel_incl (rfe E) o -> rel_incl (co E) o -> rel_incl (fr E co) o -> (mobs_r_mobs E co r) e1 e2 -> o e1 e2. Proof. intros Hrfwf Hcowf Hlin Hrfincl Hcoincl Hfrincl [e [H1e [e' [Hee' He'2]]]]. generalize (lin_ext_prop E r o); intros [Himpl _]; generalize (Himpl Hlin); intros [Hincl Hlso]; generalize (Hincl e e' Hee'); intro Hgcbee'; destruct_lin Hlso; destruct_part Hpart; generalize (mop_in_order Hrfwf Hcowf Hlin Hrfincl Hcoincl Hfrincl H1e); generalize (mop_in_order Hrfwf Hcowf Hlin Hrfincl Hcoincl Hfrincl He'2); intros [Heqe'2 | Hgcbe'2]; intros [Heqe'1 | Hgcbe'1]. rewrite Heqe'1; rewrite <- Heqe'2; auto. rewrite <- Heqe'2; apply Htrans with e; auto. rewrite Heqe'1; apply Htrans with e'; auto. apply Htrans with e; auto; apply Htrans with e'; auto. Qed. Lemma tc_mobs_r_mobs_in_order E co r o x y : rf_well_formed E -> co_well_formed E co -> linearisations r E o -> rel_incl (rfe E) o -> rel_incl (co E) o -> rel_incl (fr E co) o -> tc_mobs_r_mobs E co r x y -> o x y. Proof. intros Hrfwf Hcowf Hlin Hrfincl Hcoincl Hfrincl Hxy. induction Hxy. apply mobs_r_mobs_in_order with E co r; auto. generalize (lin_ext_prop E r o); intros [Himpl _]; generalize (Himpl Hlin); clear Himpl; intros [Hincl Hlso]; destruct_lin Hlso; destruct_part Hpart; apply Htrans with e; auto. apply mobs_r_mobs_in_order with E co r; auto. Qed. Lemma tc_mobs_r_mobs_irr E co r o x : rf_well_formed E -> co_well_formed E co -> linearisations r E o -> rel_incl (rfe E) o -> rel_incl (co E) o -> rel_incl (fr E co) o -> ~(tc_mobs_r_mobs E co r x x). Proof. intros Hrfwf Hcowf Hlin Hrfeincl Hcoincl Hfrincl Hxx; generalize (lin_ext_prop E r o); intros [Himpl _]; generalize (Himpl Hlin); clear Himpl; intros [Hincl Hlso]; destruct_lin Hlso; destruct_part Hpart; apply Hirr with x; apply tc_mobs_r_mobs_in_order with E co r; auto. Qed. (** * External Global Completion *) (** ** External Global Completion: Definitions *) Definition intervening_write (r : Rln Event) (e1 e2 : Event) : Prop := exists w, is_write w /\ r e1 w /\ r w e2. Definition gcb_rf (E : set Event) (gcb : Rln Event) (e1 e2 : Event) : Prop := is_write e1 /\ is_read e2 /\ loc e1 = loc e2 /\ val e1 = val e2 /\ gcb e1 e2 /\ ~intervening_write (fun e1 e2 => gcb e1 e2 /\ loc e1 = loc e2) e1 e2. Definition gcb_rf_wf (E:set Event) (gcb : Rln Event) : Prop := forall r, is_read r -> exists w, gcb_rf E gcb w r. Definition gcb_co (E : set Event) (gcb : Rln Event) (e1 e2 : Event) : Prop := order_to_co E gcb e1 e2. Definition does_not_locally_reads_from E r1 := ~(exists w1, rfi E w1 r1). Definition locally_reads_from_a_lob_write (E : set Event) (lob : set Event -> Rln Event) r1 e2 := exists w1, rfi E w1 r1 /\ lob E w1 e2. Definition read_requirements (E : set Event) (lob : set Event -> Rln Event) r1 e2 := does_not_locally_reads_from E r1 \/ locally_reads_from_a_lob_write E lob r1 e2. Definition preorder_gcb (E : set Event) (lob : set Event -> Rln Event) (e1 e2 : Event) : Prop := lob E e1 e2 /\ (is_write e1 \/ (is_read e1 /\ read_requirements E lob e1 e2)). Definition external_global_completion (E : set Event) (co lob : set Event -> Rln Event) (gcb : Rln Event): Prop := (linearisations (preorder_gcb E lob) E) gcb /\ rel_equal (rf E) (gcb_rf E gcb) /\ rel_equal (co E) (gcb_co E gcb). (** ** External Global Completion: Auxiliary definitions, for convenience in the proofs below *) Definition lob' (E : set Event) (lob : set Event -> Rln Event) (e1 e2 : Event) := lob E e1 e2 /\ (is_read e1 /\ ~(read_requirements E lob e1 e2)). Definition big_rel E co lob := tc_mobs_r_mobs E co (preorder_gcb E lob). (** ** External Global Completion: Lemmas that do _not_ need the existence of a External Global Completion order *) Lemma lob'_irr E lob x : lob_well_formed E lob -> ~(lob' E lob x x). Proof. intros Hlobwf [Hxx ?]; destruct_lob_wf Hlobwf. apply Hirr_lob; exists x; auto. Qed. Lemma lob_implies_pgcb_or_lob' (E : set Event) (lob : set Event -> Rln Event) (e1 e2 : Event) : lob_well_formed E lob -> lob E e1 e2 -> preorder_gcb E lob e1 e2 \/ lob' E lob e1 e2. Proof. intros Hlobwf H12; destruct_lob_wf Hlobwf; generalize (Hdom_lob e1 e2 H12); intros [Hw1 | Hr1]. left; split; auto. generalize (excluded_middle (read_requirements E lob e1 e2)); intros [Hrr | Hnrr]; [left | right]; split; auto. Qed. Lemma pgcb_in_big_rel E co lob e1 e2 : preorder_gcb E lob e1 e2 -> big_rel E co lob e1 e2. Proof. intros Hpc; apply _base; exists e1; split; [left; auto | exists e2; split; [|left]; auto]. Qed. Lemma lob'_in_lob'_seq_big_rel E co lob e1 e2 : lob' E lob e1 e2 -> rel_seq (lob' E lob) (maybe (big_rel E co lob)) e1 e2. Proof. intros H12; exists e2; split; auto; left; auto. Qed. Lemma mop_br_in_br E co lob e1 e2 e3 : maybe (obsplus E co) e1 e2 -> big_rel E co lob e2 e3 -> big_rel E co lob e1 e3. Proof. intros H12 H23. induction H23 as [e2 e3 [e [Hmop Hr]] | e2 e3 e' [e [H2e Hee']]]; [apply _base; exists e; split; auto; apply mop_trans with e2; auto | apply _trans with e'; auto; exists e; split; auto; apply mop_trans with e2; auto]. Qed. Lemma rfe_lob'_contrad E lob e1 e2 e3 : rf_well_formed E -> rfe E e1 e2 -> lob' E lob e2 e3 -> False. Proof. intros Hrfwf [Hrf12 Hext] [Hlob [Hr2 Hnrr]]; apply Hnrr; left; intros [w [Hrfw2 Hint]]. destruct Hrfwf as [? Hr]; generalize (Hr e2 Hr2); intros [? Huni]; generalize (Huni e1 w Hrf12 Hrfw2); intro Heq; rewrite Heq in Hext; apply int_ext_contrad with E w e2; auto. Qed. Lemma co_lob'_contrad E (co : set Event -> Rln Event) lob e1 e2 e3 : co_well_formed E co -> co E e1 e2 -> lob' E lob e2 e3 -> False. Proof. intros Hcowf Hco [? [Hr2 ?]]. generalize (ran_co_is_write e1 e2 Hcowf Hco); intro Hw2. apply read_write_contrad with e2; auto. Qed. Lemma fr_lob'_contrad E co lob e1 e2 e3 : co_well_formed E co -> fr E co e1 e2 -> lob' E lob e2 e3 -> False. Proof. intros Hcowf Hfr [? [Hr2 ?]]; generalize (ran_fr_is_write Hcowf Hfr); intro Hw2. apply read_write_contrad with e2; auto. Qed. Lemma mop_lob'_in_lob' E co lob e1 e2 e3 : rf_well_formed E -> co_well_formed E co -> maybe (obsplus E co) e1 e2 -> lob' E lob e2 e3 -> lob' E lob e1 e3. Proof. intros Hrfwf Hcowf [Heq12 | H12] H23; [rewrite Heq12|]; auto. generalize (obsplus_dec Hrfwf Hcowf H12); clear H12; intros [Hrfe12 | [Hco12 | [Hfr12 | [Hcorfe12 | Hfrrfe12]]]]. generalize (rfe_lob'_contrad Hrfwf Hrfe12 H23); auto; intro Ht; inversion Ht. generalize (co_lob'_contrad e1 Hcowf Hco12 H23); auto; intro Ht; inversion Ht. generalize (fr_lob'_contrad Hcowf Hfr12 H23); auto; intro Ht; inversion Ht. destruct Hcorfe12 as [x [? Hrfe]]; generalize (rfe_lob'_contrad Hrfwf Hrfe H23); auto; intro Ht; inversion Ht. destruct Hfrrfe12 as [x [? Hrfe]]; generalize (rfe_lob'_contrad Hrfwf Hrfe H23); auto; intro Ht; inversion Ht. Qed. Lemma br_trans E co lob e1 e2 e3 : big_rel E co lob e1 e2 -> big_rel E co lob e2 e3 -> big_rel E co lob e1 e3. Proof. intros H12 H23. apply tc_trans with e2; auto. Qed. Lemma br_mop_in_br E co lob e1 e2 e3 : big_rel E co lob e1 e2 -> maybe (obsplus E co) e2 e3 -> big_rel E co lob e1 e3. Proof. intros Hbr12 Hmop23; induction Hbr12 as [e1 e2 Hb | e1 e2 e H1e]. destruct Hb as [e [He1e [e'[Hee' He'2]]]]; apply _base; exists e; split; auto; exists e'; split; auto; apply mop_trans with e2; auto. apply br_trans with e; auto; apply _base; auto. Qed. Lemma pgcb_lob'_in_pgcb_or_lob' E lob e1 e2 e3 : lob_well_formed E lob -> (preorder_gcb E lob) e1 e2 -> lob' E lob e2 e3 -> preorder_gcb E lob e1 e3 \/ lob' E lob e1 e3. Proof. intros Hlobwf Hpc12 H23; destruct_lob_wf Hlobwf. left; destruct Hpc12 as [H12 Hor12]; destruct H23 as [H23 [Hr2 Hnrr]]. assert (lob E e1 e3) as Hlob13. apply (Htrans_lob e1 e2 e3 H12 H23). destruct Hor12 as [Hw1|[Hr1 Hrr]]; split; auto. right; split; auto. inversion Hrr as [Hext | Hint]; [left | right]; auto. destruct Hint as [w1 [Hrfi Hlob]]; exists w1; split; auto. apply (Htrans_lob w1 e2 e3 Hlob H23). Qed. Lemma br_lob'_in_br_or_lob' E co lob e1 e2 e3 : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> big_rel E co lob e1 e2 -> lob' E lob e2 e3 -> big_rel E co lob e1 e3 \/ lob' E lob e1 e3. Proof. intros Hrfwf Hcowf Hlobwf H12 H23; induction H12 as [e1 e2 [e [H1e [e' [Hee' He'2]]]] | e1 e2 e H1e He2]. generalize (mop_lob'_in_lob' Hrfwf Hcowf He'2 H23); clear He'2 H23; intro He'3. generalize (pgcb_lob'_in_pgcb_or_lob' Hlobwf Hee' He'3); intros [Hobs_extra3 | Hlob'e3]. left; apply _base; exists e; split; auto; exists e3; split; [|left]; auto. right; apply mop_lob'_in_lob' with co e; auto. generalize (IHHe2 H23); intros [Hbre3 | Hlob'e3]. left; apply br_trans with e; auto; apply _base; auto. clear IHHe2 H23 He2 e2. destruct H1e as [x [H1x [y [Hxy Hye]]]]. generalize (mop_lob'_in_lob' Hrfwf Hcowf Hye Hlob'e3); clear Hye Hlob'e3 e; intro Hy3. generalize (pgcb_lob'_in_pgcb_or_lob' Hlobwf Hxy Hy3); clear Hxy Hy3 y; intro Hx3. inversion Hx3 as [Hpcx3 | Hlob'x3]; clear Hx3. left; apply _base; exists x; split; auto; exists e3; split; auto; left; auto. right; apply mop_lob'_in_lob' with co x; auto. Qed. Lemma lob'_seq_lob'_in_pgcb_or_lob' E lob e1 e2 e3: lob_well_formed E lob -> lob' E lob e1 e2 -> lob' E lob e2 e3 -> (preorder_gcb E lob) e1 e3 \/ lob' E lob e1 e3. Proof. intros Hlobwf [Hlob12 [Hw1 Hrr1]] [Hlob23 [Hw2 Hrr2]]; destruct_lob_wf Hlobwf. assert (lob E e1 e3) as H13. apply (Htrans_lob e1 e2 e3 Hlob12 Hlob23). generalize (excluded_middle (read_requirements E lob e1 e3)); intros [Hrr | Hnrr]. left; split; auto. right; split; auto. Qed. Lemma pgcb_mbr_in_br E co lob e1 e2 e3 : (preorder_gcb E lob) e1 e2 -> maybe (big_rel E co lob) e2 e3 -> big_rel E co lob e1 e3. Proof. intros H12 [Heq23 | H23]. rewrite <- Heq23; apply _base; exists e1; split; [left | exists e2; split; [ | left]]; auto. induction H23. apply br_trans with e0; apply _base; auto. exists e1; split; [left | exists e0; split; [|left]]; auto. apply br_trans with e; auto; apply br_trans with e0; apply _base; auto. exists e1; split; [left | exists e0; split; [|left]]; auto. Qed. Lemma gcb_path_ob_dec (E : set Event) (co lob : set Event -> Rln Event) (gcb : Rln Event) (e1 e2 : Event) : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> ob E co (lob E) e1 e2 -> obsplus E co e1 e2 \/ big_rel E co lob e1 e2 \/ rel_seq (lob' E lob) (maybe (big_rel E co lob)) e1 e2 \/ rel_seq (lob' E lob) (maybe (obsplus E co)) e1 e2. Proof. intros Hrfwf Hcowf Hlobwf H12. induction H12 as [e1 e2 Hobs | e1 e2 Hlob |]; auto. (*e1,e2 in obs*) left; apply _base; auto. (*e1,e2 in lob*) generalize (lob_implies_pgcb_or_lob' e1 e2 Hlobwf Hlob); intros [Hpc | Hlob']; right; [left; apply pgcb_in_big_rel | right; left; apply lob'_in_lob'_seq_big_rel]; auto. (*inductive case*) clear H12_ H12_0; inversion IHob1 as [Hmop1e | [Hbr1e | [Hlob'1e | Hlob'1e]]]; clear IHob1. (*e1,e in obs+*) inversion IHob2 as [Hmop2 | [Hbre2 | Hlob'e2]]; clear IHob2. (*e,e2 in obs+*) left; apply op_trans with e; auto. (*e,e2 in br*) right; left; apply mop_br_in_br with e; auto; right; auto. (*e,e2 in lob';mbr U lob';mop*) inversion Hlob'e2 as [Hee2 | Hee2]; clear Hlob'e2; destruct Hee2 as [e' [Hlob'ee' Hbre'2]]; right; right; [left | right]; exists e'; split; auto; apply mop_lob'_in_lob' with co e; auto; right; auto. (*e1,e in br*) inversion IHob2 as [Hmop2 | [Hbre2 | Hlob'e2]]; clear IHob2. (*e,e2 in op*) right; left; apply br_mop_in_br with e; auto; right; auto. (*e,e2 in br*) right; left; apply br_trans with e; auto. (*e,e2 in lob';mbr U lob';mop*) inversion Hlob'e2 as [Hee2 | Hee2]; clear Hlob'e2; destruct Hee2 as [e' [Hee' He'2]]; generalize (br_lob'_in_br_or_lob' Hrfwf Hcowf Hlobwf Hbr1e Hee'); clear Hbr1e Hee' e; intros [Hbr1' | Hlob1']; right. left; inversion He'2 as [Heqe'2 | Hbre'2]; clear He'2; [rewrite Heqe'2 in Hbr1'|apply br_trans with e']; auto. right; left; exists e'; auto. left; apply br_mop_in_br with e'; auto. right; right; exists e'; split; auto. (*e1,e in lob';mbr*) destruct Hlob'1e as [e' [H1e' He'e]]; inversion IHob2 as [Hmop2 | [Hbre2 | Hlob'e2]]; clear IHob2. (*e,e2 in op*) inversion He'e as [Heqe'e | Hbre'e]; clear He'e; right; right; [right; rewrite Heqe'e in H1e'; exists e; split | left; exists e'; split; auto; right; apply br_mop_in_br with e]; auto; right; auto. (*e,e2 in br*) right; right; left; exists e'; split; auto; inversion He'e as [Heqe'e | Hbre'e]; clear He'e; auto; right; [rewrite Heqe'e | apply br_trans with e]; auto. (*e,e2 in lob;mbr U lob;mop*) inversion Hlob'e2 as [He2 | He2]; clear Hlob'e2; destruct He2 as [e'' [Hee'' He''2]]; inversion He'e as [Heqe'e | Hbre'e]; clear He'e. rewrite Heqe'e in H1e'; generalize (lob'_seq_lob'_in_pgcb_or_lob' Hlobwf H1e' Hee''); clear e Heqe'e H1e' Hee''; intros [Hpc1'' | Hlob'1'']; right; [left; apply pgcb_mbr_in_br with e''; auto | right; left; exists e''; auto]. generalize (br_lob'_in_br_or_lob' Hrfwf Hcowf Hlobwf Hbre'e Hee''); clear Hbre'e Hee'' e; intros [Hbre'e'' | Hlobe'e'']. right; right; left; exists e'; split; auto. inversion He''2 as [Heq''2 | Hbre''2]; clear He''2. rewrite Heq''2 in Hbre'e''; right; auto. right; apply br_trans with e''; auto. generalize (lob'_seq_lob'_in_pgcb_or_lob' Hlobwf H1e' Hlobe'e''); clear e' H1e' Hlobe'e''; intros [Hmpc1'' | Hlob'1'']. right; left; apply pgcb_mbr_in_br with e''; auto. right; right; left; exists e''; split; auto. (*e,e2 in lob;mop*) rewrite Heqe'e in H1e'; generalize (lob'_seq_lob'_in_pgcb_or_lob' Hlobwf H1e' Hee''); clear e Heqe'e H1e' Hee''; intros [Hpc1'' | Hlob'1'']; right; [left; apply _base; exists e1; split; [left | exists e''; split]; auto | right; right; exists e''; split; auto]. generalize (br_lob'_in_br_or_lob' Hrfwf Hcowf Hlobwf Hbre'e Hee''); clear Hbre'e Hee'' e; intros [Hbre'e'' | Hlob'e'e'']. right; right; left; exists e'; split; auto; right; apply br_mop_in_br with e''; auto. generalize (lob'_seq_lob'_in_pgcb_or_lob' Hlobwf H1e' Hlob'e'e''); intros [Hpc | Hlob]; clear H1e' Hlob'e'e''. right; left; apply _base; exists e1; split; [left|exists e'']; auto. right; right; right; exists e''; split; auto. (*e,1e in lob';mop*) inversion IHob2 as [Hmop2 | [Hbre2 | Hlob'e2]]; clear IHob2; destruct Hlob'1e as [e' [H1' H'e]]. (*e,e2 in obs+*) right; right; right; exists e'; split; auto. inversion H'e as [Heq'e | Hop'e]; clear H'e; [rewrite Heq'e; right|right; apply op_trans with e]; auto. (*e,e2 in br*) right; right; left; exists e'; split; auto. right; apply mop_br_in_br with e; auto. (*e,e2 in lob';mbr U lob';mop*) inversion Hlob'e2 as [He2 | He2]; destruct He2 as [e'' [He'' H''2]]; generalize (mop_lob'_in_lob' Hrfwf Hcowf H'e He''); clear H'e He''; intros Hlob; generalize (lob'_seq_lob'_in_pgcb_or_lob' Hlobwf H1' Hlob); clear H1' Hlob; intros [Hpc | Hlob]; right. left; apply pgcb_mbr_in_br with e''; auto. right; left; exists e''; auto. left; apply _base; exists e1; split; [left | exists e''; split]; auto. right; right; exists e''; split; auto. Qed. (** * External Global Completion -> External Visibility lemmas *) Lemma fr_implies_gcb_or_gcb_minus_1 (E : set Event) (co lob : set Event -> Rln Event) (gcb : Rln Event) (e1 e2 : Event) : co_well_formed E co -> linearisations (preorder_gcb E lob) E gcb -> fr E co e1 e2 -> gcb e1 e2 \/ gcb e2 e1. Proof. intros Hcowf Hlin H12. apply fr_implies_order_or_order_minus_1 with E co (preorder_gcb E lob); auto. Qed. Lemma rf_in_gcb E gcb x y : rel_equal (rf E) (gcb_rf E gcb) -> rf E x y -> gcb x y. Proof. intros Hrfeq Hrf; destruct Hrfeq as [Hrfincl ?]; generalize (Hrfincl x y Hrf); intros [? [? [? [? [? ?]]]]]; auto. Qed. Lemma rfe_in_gcb E gcb x y : rel_equal (rf E) (gcb_rf E gcb) -> rfe E x y -> gcb x y. Proof. intros Hrfeq [Hrf ?]; apply rf_in_gcb with E; auto. Qed. Lemma co_in_gcb E co gcb x y : rel_equal (co E) (gcb_co E gcb) -> co E x y -> gcb x y. Proof. apply co_in_order; auto. Qed. Lemma fr_in_gcb E co lob gcb x y : co_well_formed E co -> linearisations (preorder_gcb E lob) E gcb -> rel_equal (rf E) (gcb_rf E gcb) -> rel_equal (co E) (gcb_co E gcb) -> fr E co x y -> gcb x y. Proof. intros Hcowf Hlin Hrfeq Hcoeq Hfr. generalize (fr_implies_gcb_or_gcb_minus_1 Hcowf Hlin (*Hrfeq Hcoeq*) Hfr); intros [? | Hgcbyx]; auto; generalize Hfr; intros [w [Hw [Hrf Hco]]]; generalize (rf_in_gcb Hrfeq Hrf); intro Hgcbwx; generalize (co_in_gcb co w y Hcoeq Hco); intro Hgcbwy. destruct Hrfeq as [Hincl ?]; generalize (Hincl w x Hrf); intros [? [? [? Hnointerv]]]. assert False as Ht. apply Hnointerv; exists y; split; [|split; split]; auto. apply ran_co_is_write with E co w; auto. apply co_implies_same_loc with E co; auto. generalize (fr_implies_same_loc Hcowf Hfr); auto. inversion Ht. Qed. Lemma big_rel_irr E co lob gcb x : rf_well_formed E -> co_well_formed E co -> linearisations (preorder_gcb E lob) E gcb -> rel_equal (rf E) (gcb_rf E gcb) -> rel_equal (co E) (gcb_co E gcb) -> ~(big_rel E co lob x x). Proof. intros Hrfwf Hcowf Hlin Hrfeq Hcoeq; apply tc_mobs_r_mobs_irr with gcb; auto; intros e1 e2 H12. apply rfe_in_gcb with E; auto. apply co_in_gcb with E co; auto. apply fr_in_gcb with E co lob; auto. Qed. (** ** External global completion implies External Visibility *) Lemma external_global_completion_implies_external_visibility (E : set Event) (co lob : set Event -> Rln Event) : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> internal_visibility E co -> (exists gcb, external_global_completion E co lob gcb) -> external_visibility E co lob. (** We show here that: - given a well-formed execution (E, lob, rf, co) - if the [internal_visibility] axiom holds over E, - and there exists an [external_global_completion] External Global Completion order gcb, - then the [external_visibility] axiom holds over E *) Proof. intros Hrfwf Hcowf Hlobwf Hscpv [gcb [Hlin [Hrfeq Hcoeq]]] [x Hx]. (** Reason by contradiction: suppose that the [external_visibility] axiom does not hold over E, viz, there exists x s.t. (x,x) in ob.*) generalize (gcb_path_ob_dec gcb Hrfwf Hcowf Hlobwf Hx); clear Hx; intros [Hmop | [Hbr | [Hlbr | Hlop]]]. (** Now observe (c.f. [gcb_path_ob_dec]) that (x,x) in ob means either: - (x,x) obsplus - (x,x) in big_rel - (x,x) in lob';big_rel? - (x,x) in lob';obs *) (** *** Case 1: (x,x) obsplus*) apply Hscpv; exists x; apply obsplus_in_scpv; auto. (** This is a contradiction of the [internal_visibility] axiom. *) (** *** Case 2: (x,x) in big_rel *) apply (big_rel_irr Hrfwf Hcowf Hlin Hrfeq Hcoeq Hbr); auto. (** This is impossible as big_rel is irreflexive (c.f. [big_rel_irr]). *) (** *** Case 3: (x,x) in lob';big_rel? We reason by case disjunction: - 3a. (x,x) in lob' - 3b. (x,x) in lob';big_rel *) destruct Hlbr as [y [Hxy Hyx]]. inversion Hyx as [Heqyx | Hbryx]; clear Hyx. (** **** Case 3a: (x,x) in lob' *) rewrite Heqyx in Hxy; apply (lob'_irr Hlobwf Hxy). (** This is impossible as lob' is irreflexive (c.f. [lob'_irr]). *) (** **** Case 3b: (x,x) in lob';big_rel In this case by definition there exists y s.t. (x,y) in lob' and (y,x) in big_rel. *) generalize (br_lob'_in_br_or_lob' Hrfwf Hcowf Hlobwf Hbryx Hxy); clear Hbryx Hxy; intros [Hbr | Hlob']. (** Using [br_lob'_in_br_or_lob'] we can reason by case disjunction: - 3bi. (x,x) in big_rel - 3bii. (x,x) in lob'*) (** Case 3bi: (x,x) in big_rel *) apply (big_rel_irr Hrfwf Hcowf Hlin Hrfeq Hcoeq Hbr); auto. (** This is impossible because big_rel is irreflexive (c.f. [big_rel_irr]). *) (** Case 3bii: (x,x) in lob' *) apply (lob'_irr Hlobwf Hlob'). (** This is impossible because lob' is irreflexive (c.f. [lob'_irr]). *) (** *** Case 4: (x,x) in lob';obs* *) destruct Hlop as [y [Hxy Hyx]]. (** By definition this means that there exists y s.t. (x,y) in lob' and (y,x) in obs*. *) generalize (mop_lob'_in_lob' Hrfwf Hcowf Hyx Hxy); intro Hlob'. (** Therefore (y,y) in obs*;lob'. Now observe that (c.f. [mop_lob'_in_lob']) this entails (y,y) in lob'. *) apply (lob'_irr Hlobwf Hlob'). (** This is impossible since lob' is irreflexive (c.f. [lob'_irr]). *) Qed. (** * External Visibility -> External Global Completion lemmas *) (** We show here that: - given a well-formed execution (E, lob, rf, co) - if the internal visibility axiom holds - if the external visibility axiom holds - then there exists a External Global Completion external global completion order gcb.*) (** To do so we need to exhibit an order gcb that satisfies the requirements given in [external_global_completion]. Observe that (c.f. [pre_egc_partial_order]) the relation [pre_egc] is a partial order. Using the order extension principle (c.f. [order_ext]) we can extend pre_egc to a total order that we call gcb. Using [external_global_completion_gcb] we then show that gcb satisfies the [external_global_completion] requirement.*) Definition pre_egc E co lob := transitive_closure (rel_union (rf E) (rel_union (co E) (rel_union (fr E co) (preorder_gcb E lob)))). Definition big_rel2 E co lob := transitive_closure (rel_seq (maybe (obsplus E co)) (rel_seq (preorder_gcb E lob) (maybe (obsplus E co)))). Lemma rfi_pgcb_is_pgcb E lob e1 e2 e3 : rf_well_formed E -> rfi E e1 e2 -> preorder_gcb E lob e2 e3 -> preorder_gcb E lob e1 e3. Proof. intros Hrfwf [Hrf12 Hint12]; generalize (ran_rf_is_read Hrf12); intros Hr2 [Hlob23 [Hw2 | [_ Hrr23]]]; [generalize (read_write_contrad e2 Hr2 Hw2); intro Ht; inversion Ht | inversion Hrr23 as [Hext | Hint]; clear Hrr23]. assert False as Ht. apply Hext; exists e1; split; auto. inversion Ht. destruct Hint as [w' [[Hrf' ?] Hlob]]; destruct_rf_wf Hrfwf; generalize (Hex_uni e2 Hr2); intros [? Huni]; generalize (Huni e1 w' Hrf12 Hrf'); intro Heq. rewrite Heq; split; auto; left; apply dom_rf_is_write with E e2; auto. Qed. Lemma rfi_seq_obs_in_obs E co lob x y z : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> rfi E x y -> obs E co y z -> obs E co x z. Proof. intros Hrfwf Hcowf Hlobwf Hrfi Hobs. destruct Hrfi as [Hrfxy ?]; inversion Hobs as [Hrfe | [Hco | Hfr]]; clear Hobs. destruct Hrfe as [Hrfyz ?]; generalize (dom_rf_is_write Hrfyz); intro Hwy; generalize (ran_rf_is_read Hrfxy); intro Hry; generalize (read_write_contrad y Hry Hwy); intro Ht; inversion Ht. generalize (dom_co_is_write y z Hcowf Hco); intro Hwy; generalize (ran_rf_is_read Hrfxy); intro Hry; generalize (read_write_contrad y Hry Hwy); intro Ht; inversion Ht. generalize (rf_fr_is_co Hrfwf Hrfxy Hfr); intro Hco; right; left; auto. Qed. Lemma rfi_seq_obsplus_in_obsplus E co lob x y z : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> rfi E x y -> obsplus E co y z -> obsplus E co x z. Proof. intros Hrfwf Hcowf Hlobwf Hrfi Hobsp. induction Hobsp. apply _base; apply rfi_seq_obs_in_obs with lob e1; auto. apply _trans with e; auto. apply rfi_seq_obs_in_obs with lob e1; auto. Qed. Lemma rfe_seq_obsplus_in_obsplus E co lob x y z : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> rfe E x y -> obsplus E co y z -> obsplus E co x z. Proof. intros Hrfwf Hcowf Hlobwf Hrfi Hobsp. apply _trans with y; auto; left; auto. Qed. Lemma rf_seq_obsplus_in_obsplus E co lob x y z : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> rf E x y -> obsplus E co y z -> obsplus E co x z. Proof. intros Hrfwf Hcowf Hlobwf Hrfi Hobsp. assert (E x) as HEx. apply dom_rf_in_evts with y; auto. assert (E y) as HEy. apply ran_rf_in_evts with x; auto. generalize (int_or_ext E x y HEx HEy); intros [Hint | Hext]. apply rfi_seq_obsplus_in_obsplus with lob y; auto; split; auto. apply rfe_seq_obsplus_in_obsplus with lob y; auto; split; auto. Qed. Lemma rfi_base_br2_in_br2 E co lob e1 e2 e3 : co_well_formed E co -> rf_well_formed E -> lob_well_formed E lob -> rfi E e1 e2 -> rel_seq (maybe (obsplus E co)) (rel_seq (preorder_gcb E lob) (maybe (obsplus E co))) e2 e3 -> rel_seq (maybe (obsplus E co)) (rel_seq (preorder_gcb E lob) (maybe (obsplus E co))) e1 e3. Proof. intros Hcowf Hrfwf Hlobwf Hrfi12 H23. destruct H23 as [x [H2x [y [Hxy Hy3]]]]. inversion H2x as [Heq2x | Hobsp2x]; clear H2x. rewrite Heq2x in *; clear Heq2x. exists e1; split; [left|]; auto; exists y; split; auto. apply rfi_pgcb_is_pgcb with x; auto; split; auto. exists x; split; [right|exists y; split]; auto. apply rfi_seq_obsplus_in_obsplus with lob e2; auto; split; auto. Qed. Lemma rfe_base_br2_in_br2 E co lob e1 e2 e3 : co_well_formed E co -> rf_well_formed E -> lob_well_formed E lob -> rfe E e1 e2 -> rel_seq (maybe (obsplus E co)) (rel_seq (preorder_gcb E lob) (maybe (obsplus E co))) e2 e3 -> rel_seq (maybe (obsplus E co)) (rel_seq (preorder_gcb E lob) (maybe (obsplus E co))) e1 e3. Proof. intros Hcowf Hrfwf Hlobwf Hrfe12 H23. destruct H23 as [x [H2x [y [Hxy Hy3]]]]. inversion H2x as [Heq2x | Hobsp2x]; clear H2x. rewrite Heq2x in *; clear Heq2x. exists x; split; [right; apply _base; left|exists y; split]; auto. exists x; split; [right; apply _trans with e2|exists y; split]; auto; left; auto. Qed. Lemma rf_br2_in_br2 E co lob e1 e2 e3 : co_well_formed E co -> rf_well_formed E -> lob_well_formed E lob -> rf E e1 e2 -> big_rel2 E co lob e2 e3 -> big_rel2 E co lob e1 e3. Proof. intros Hcowf Hrfwf Hlobwf Hrf12 Hbr23. assert (E e1) as HE1. apply dom_rf_in_evts with e2; auto. assert (E e2) as HE2. apply ran_rf_in_evts with e1; auto. generalize (int_or_ext E e1 e2 HE1 HE2); intros [Hint12 | Hext12]. induction Hbr23 as [e2 e3 H23|]. apply _base; apply rfi_base_br2_in_br2 with e2; auto; split; auto. apply _trans with e; auto. apply rfi_base_br2_in_br2 with e0; auto; split; auto. induction Hbr23 as [e2 e3 H23|]. apply _base; apply rfe_base_br2_in_br2 with e2; auto; split; auto. apply _trans with e; auto. apply rfe_base_br2_in_br2 with e0; auto; split; auto. Qed. Lemma co_seq_obsplus_in_obsplus E co lob x y z : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> co E x y -> obsplus E co y z -> obsplus E co x z. Proof. intros Hrfwf Hcowf Hlobwf Hrfi Hobsp. apply _trans with y; auto; right; left; auto. Qed. Lemma co_br2_in_br2 E co lob e1 e2 e3 : co_well_formed E co -> co E e1 e2 -> big_rel2 E co lob e2 e3 -> big_rel2 E co lob e1 e3. Proof. intros Hcowf H12 H23; induction H23 as [e2 e3 H23|]. destruct H23 as [x [H2x Hx3]]; apply _base; exists x; split; auto; right; inversion H2x as [Heq2x | Ho2x]; clear H2x. rewrite Heq2x in *; clear Heq2x; apply _base; right; left; auto. apply _trans with e2; auto; right; left; auto. apply _trans with e; auto. destruct H as [x [H0x Hxe]]; exists x; split; auto. right; inversion H0x as [Heq0x | Ho0x]; clear H0x. rewrite Heq0x in *; clear Heq0x; apply _base; right; left; auto. apply _trans with e0; auto; right; left; auto. Qed. Lemma fr_seq_obsplus_in_obsplus E co lob x y z : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> fr E co x y -> obsplus E co y z -> obsplus E co x z. Proof. intros Hrfwf Hcowf Hlobwf Hrfi Hobsp. apply _trans with y; auto; right; right; auto. Qed. Lemma fr_br2_in_br2 E co lob e1 e e2 : co_well_formed E co -> fr E co e1 e -> big_rel2 E co lob e e2 -> big_rel2 E co lob e1 e2. Proof. intros Hcowf H12 H23; induction H23 as [e2 e3 H23|]. destruct H23 as [x [H2x Hx3]]; apply _base; exists x; split; auto; right; inversion H2x as [Heq2x | Ho2x]; clear H2x. rewrite Heq2x in *; clear Heq2x; apply _base; right; right; auto. apply _trans with e2; auto; right; right; auto. apply _trans with e; auto. destruct H as [x [H0x Hxe]]; exists x; split; auto. right; inversion H0x as [Heq0x | Ho0x]; clear H0x. rewrite Heq0x in *; clear Heq0x; apply _base; right; right; auto. apply _trans with e0; auto; right; right; auto. Qed. Definition nrel E co lob := maybe (transitive_closure (rel_union (obsplus E co) (preorder_gcb E lob))). Lemma rf_seq_obsplus_u_pgcb_in_tc_obsplus_u_pgcb E co lob e1 e2 e3 : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> rf E e1 e2 -> rel_union (obsplus E co) (preorder_gcb E lob) e2 e3 -> transitive_closure (rel_union (obsplus E co) (preorder_gcb E lob)) e1 e3. Proof. intros Hrfwf Hcowf Hlobwf H12 H23. inversion H23 as [Hop23 | Hpgcb23]; clear H23. apply _base; left; apply rf_seq_obsplus_in_obsplus with lob e2; auto. assert (E e1) as HE1. apply dom_rf_in_evts with e2; auto. assert (E e2) as HE2. apply ran_rf_in_evts with e1; auto. generalize (int_or_ext E e1 e2 HE1 HE2); intros [Hint | Hext]. apply _base; right; apply rfi_pgcb_is_pgcb with e2; auto; split; auto. apply _trans with e2; [left; apply _base; left; split|apply _base; right]; auto. Qed. Lemma rf_seq_nrel_seq_rfi_in_nrel_seq_rfi E co lob e1 e2 e3 : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> rf E e1 e2 -> rel_seq (nrel E co lob) (rfi E) e2 e3 -> rel_seq (nrel E co lob) (rfi E) e1 e3. Proof. intros Hrfwf Hcowf Hlobwf H12 [x [H2x Hx3]]. inversion H2x as [Heq2x | Hn2x]; clear H2x. rewrite Heq2x in H12; clear Heq2x. assert (is_write x) as Hwx. apply dom_rf_is_write with E e3; destruct Hx3; auto. assert (is_read x) as Hrx. apply ran_rf_is_read with E e1; auto. generalize (read_write_contrad x Hrx Hwx); intro Ht; inversion Ht. exists x; split; auto; clear Hx3; right. induction Hn2x as [e2 x H2x|]. apply rf_seq_obsplus_u_pgcb_in_tc_obsplus_u_pgcb with e2; auto. apply tc_trans with e; auto; apply rf_seq_obsplus_u_pgcb_in_tc_obsplus_u_pgcb with e0; auto. Qed. Lemma co_seq_obsplus_u_pgcb_in_tc_obsplus_u_pgcb E co lob e1 e2 e3 : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> co E e1 e2 -> rel_union (obsplus E co) (preorder_gcb E lob) e2 e3 -> transitive_closure (rel_union (obsplus E co) (preorder_gcb E lob)) e1 e3. Proof. intros Hrfwf Hcowf Hlobwf H12 H23. inversion H23 as [Hop23 | Hpgcb23]; clear H23. apply _base; left; apply _trans with e2; auto; right; left; auto. apply _trans with e2; [|apply _base; right]; auto; left; apply _base; right; left; auto. Qed. Lemma co_seq_nrel_seq_rfi_in_nrel_seq_rfi E co lob e1 e2 e3 : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> co E e1 e2 -> rel_seq (nrel E co lob) (rfi E) e2 e3 -> rel_seq (nrel E co lob) (rfi E) e1 e3. Proof. intros Hrfwf Hcowf Hlobwf H12 [x [H2x Hx3]]. inversion H2x as [Heq2x | Hn2x]; clear H2x. rewrite Heq2x in H12; clear Heq2x. exists x; split; auto; right; apply _base; left; apply _base; right; left; auto. exists x; split; auto; right. induction Hn2x. apply co_seq_obsplus_u_pgcb_in_tc_obsplus_u_pgcb with e0; auto. apply tc_trans with e; auto; apply co_seq_obsplus_u_pgcb_in_tc_obsplus_u_pgcb with e0; auto. Qed. Lemma fr_seq_obsplus_u_pgcb_in_tc_obsplus_u_pgcb E co lob e1 e2 e3 : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> fr E co e1 e2 -> rel_union (obsplus E co) (preorder_gcb E lob) e2 e3 -> transitive_closure (rel_union (obsplus E co) (preorder_gcb E lob)) e1 e3. Proof. intros Hrfwf Hcowf Hlobwf H12 H23. inversion H23 as [Hop23 | Hpgcb23]; clear H23. apply _base; left; apply _trans with e2; auto; right; right; auto. apply _trans with e2; [|apply _base; right]; auto; left; apply _base; right; right; auto. Qed. Lemma fr_seq_nrel_seq_rfi_in_nrel_seq_rfi E co lob e1 e2 e3 : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> fr E co e1 e2 -> rel_seq (nrel E co lob) (rfi E) e2 e3 -> rel_seq (nrel E co lob) (rfi E) e1 e3. Proof. intros Hrfwf Hcowf Hlobwf H12 [x [H2x Hx3]]. inversion H2x as [Heq2x | Hn2x]; clear H2x. rewrite Heq2x in H12; clear Heq2x. exists x; split; auto; right; apply _base; left; apply _base; right; right; auto. exists x; split; auto; right. induction Hn2x. apply fr_seq_obsplus_u_pgcb_in_tc_obsplus_u_pgcb with e0; auto. apply tc_trans with e; auto; apply fr_seq_obsplus_u_pgcb_in_tc_obsplus_u_pgcb with e0; auto. Qed. Lemma pgcb_seq_nrel_seq_rfi_in_nrel_seq_rfi E co lob e1 e2 e3 : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> preorder_gcb E lob e1 e2 -> rel_seq (nrel E co lob) (rfi E) e2 e3 -> rel_seq (nrel E co lob) (rfi E) e1 e3. Proof. intros Hrfwf Hcowf Hlobwf H12 [x [H2x Hx3]]. exists x; split; auto. inversion H2x as [Heq2x | Hu2x]; clear H2x. rewrite Heq2x in H12; clear Heq2x. right; apply _base; right; auto. right; apply _trans with e2; auto; right; auto. Qed. Lemma pre_egc_dec (E : set Event) (co lob : set Event -> Rln Event) (e1 e2 : Event) : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> pre_egc E co lob e1 e2 -> rel_seq (nrel E co lob) (rfi E) e1 e2 \/ (obsplus E co) e1 e2 \/ (big_rel2 E co lob) e1 e2. Proof. intros Hrfwf Hcowf Hlobwf H12; induction H12 as [e1 e2 H12 | e1 e2 e H1e He2]. inversion H12 as [Hrf12 | [Hco12 | [Hfr12 | Hpc12]]]. assert (E e1) as HE1. apply dom_rf_in_evts with e2; auto. assert (E e2) as HE2. apply ran_rf_in_evts with e1; auto. generalize (int_or_ext E e1 e2 HE1 HE2); intros [Hint | Hext]. left; exists e1; split; [left|split]; auto. right; left; apply _base; left; split; auto. right; left; apply _base; right; left; auto. right; left; apply _base; right; right; auto. right; right; left; exists e1; split; [left|exists e2; split]; auto; left; auto. inversion H1e as [Hrf1e | [Hco1e | [Hfr1e | Hpc1e]]]; clear H1e; inversion IHHe2 as [Hnrfie2 | [Hobspluse2 | Hbre2]]; clear IHHe2. left; apply rf_seq_nrel_seq_rfi_in_nrel_seq_rfi with e; auto. right; left; apply rf_seq_obsplus_in_obsplus with lob e; auto. right; right; apply rf_br2_in_br2 with e; auto. left; apply co_seq_nrel_seq_rfi_in_nrel_seq_rfi with e; auto. right; left; apply co_seq_obsplus_in_obsplus with lob e; auto. right; right; apply co_br2_in_br2 with e; auto. left; apply fr_seq_nrel_seq_rfi_in_nrel_seq_rfi with e; auto. right; left; apply fr_seq_obsplus_in_obsplus with lob e; auto. right; right; apply fr_br2_in_br2 with e; auto. left; apply pgcb_seq_nrel_seq_rfi_in_nrel_seq_rfi with e; auto. right; right; apply _base; exists e1; split; [left|exists e;split; [|right]]; auto. right; right; apply _trans with e; auto; exists e1; split; auto; [left |]; auto; exists e; split; [|left]; auto. Qed. Definition obs_extra E co := rel_union (rfe E) (rel_union (co E) (rel_union (fr E co) (rel_union (corfe E co) (frrfe E co)))). Lemma mcomplus_seq_pgcb E co lob e1 e2 e3 : rf_well_formed E -> maybe (complus E co) e1 e2 -> preorder_gcb E lob e2 e3 -> rel_seq (maybe (obs_extra E co)) (preorder_gcb E lob) e1 e3. Proof. intros Hrfwf H12 H23; inversion H12 as [Heq12 | Hcomplus12]; clear H12. rewrite Heq12; exists e2; split; [left|]; auto. inversion Hcomplus12 as [Hrf | [Hco | [Hfr | [Hcorf | Hfrrf]]]]; clear Hcomplus12. generalize (dom_rf_in_evts Hrf); intro HE1; generalize (ran_rf_in_evts Hrf); intro HE2; generalize (int_or_ext E e1 e2 HE1 HE2); intros [Hint | Hext]. exists e1; split; [left|]; auto; apply rfi_pgcb_is_pgcb with e2; auto; split; auto. exists e2; split; auto; right; left; split; auto. exists e2; split; auto; right; right; left; auto. exists e2; split; auto; right; right; right; left; auto. destruct Hcorf as [w [Hco Hrf]]. generalize (dom_rf_in_evts Hrf); intro HEw; generalize (ran_rf_in_evts Hrf); intro HE2; generalize (int_or_ext E w e2 HEw HE2); intros [Hint | Hext]. exists w; split; [right; right; left|]; auto; apply rfi_pgcb_is_pgcb with e2; auto; split; auto. exists e2; split; auto; right; right; right; right; left; auto; exists w; split; auto; split; auto. destruct Hfrrf as [w [Hfr Hrf]]. generalize (dom_rf_in_evts Hrf); intro HEw; generalize (ran_rf_in_evts Hrf); intro HE2; generalize (int_or_ext E w e2 HEw HE2); intros [Hint | Hext]. exists w; split; [right; right; right; left|]; auto; apply rfi_pgcb_is_pgcb with e2; auto; split; auto. exists e2; split; auto; right; right; right; right; right; auto; exists w; split; auto; split; auto. Qed. Lemma mcomplus_seq_pgcb_incl E co lob : rf_well_formed E -> rel_incl (rel_seq (maybe (complus E co)) (preorder_gcb E lob)) (rel_seq (maybe (obs_extra E co)) (preorder_gcb E lob)). Proof. intros Hrfwf e1 e3 [e2 [H12 H23]]; apply mcomplus_seq_pgcb with e2; auto. Qed. (*Lemma br2_dec (E : set Event) (co lob : set Event -> Rln Event) (e1 e2 : Event) : rf_well_formed E -> co_well_formed E co -> (big_rel2 E co lob) e1 e2 -> rel_seq (transitive_closure (rel_seq (maybe (obs_extra E co)) (preorder_gcb E lob))) (maybe (complus E co)) e1 e2. Proof. intros Hrfwf Hcowf H12. assert (rel_seq (transitive_closure (rel_seq (maybe (complus E co)) (preorder_gcb E lob))) (maybe (complus E co)) e1 e2) as H12'. induction H12 as [e1 e2 H12 | e1 e2 e H1e _]. apply seq_tc_reorg; auto. apply seq_tc_reorg2 with e; auto; apply mcomplus_trans; auto. apply tc_seq_incl with (rel_seq (maybe (complus E co)) (preorder_gcb E lob)); auto. apply mcomplus_seq_pgcb_incl; auto. Qed.*) Lemma br2_base_dec (E : set Event) (co lob : set Event -> Rln Event) (e1 e2 : Event) : lob_well_formed E lob -> rf_well_formed E -> co_well_formed E co -> rel_seq (maybe (obsplus E co)) (rel_seq (preorder_gcb E lob) (maybe (obsplus E co))) e1 e2 -> (transitive_closure (rel_union (obsplus E co) (preorder_gcb E lob))) e1 e2. Proof. intros Hlobwf Hrfwf Hcowf H12. destruct H12 as [x [H1x [y [Hxy Hy2]]]]; inversion H1x as [Heq1x | Htc1x]; clear H1x; inversion Hy2 as [Heqy2 | Htcy2]; clear Hy2. apply _base; rewrite Heq1x; rewrite <- Heqy2; right; auto. rewrite <- Heq1x in Hxy; apply _trans with y; [right|apply _base; left]; auto. rewrite Heqy2 in Hxy; apply _trans with x; [left|apply _base; right]; auto. apply _trans with x; [left|apply _trans with y; [right|apply _base; left]]; auto. Qed. Lemma br2_dec (E : set Event) (co lob : set Event -> Rln Event) (e1 e2 : Event) : lob_well_formed E lob -> rf_well_formed E -> co_well_formed E co -> (big_rel2 E co lob) e1 e2 -> (transitive_closure (rel_union (obsplus E co) (preorder_gcb E lob))) e1 e2. Proof. intros Hlobwf Hrfwf Hcowf H12; induction H12. apply br2_base_dec; auto. generalize (br2_base_dec Hlobwf Hrfwf Hcowf H); clear H H12; intros H1e; apply tc_trans with e; auto. Qed. Lemma pgcb_in_lob (E : set Event) (lob : set Event -> Rln Event) : rel_incl (preorder_gcb E lob) (lob E). Proof. intros x y [? ?]; auto. Qed. Lemma mobs_extra_trans E (co lob : set Event -> Rln Event) (*x y z*) : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> internal_visibility E co -> external_visibility E co lob -> transitive (maybe (obs_extra E co)). Proof. intros Hrfwf Hcowf Hlobwf Hintv Hextv x y z Hxy Hyz; inversion Hxy as [Heqxy | Hpcxy]; clear Hxy; inversion Hyz as [Heqyz | Hpcyz]; clear Hyz. left; rewrite Heqxy; auto. right; rewrite Heqxy; auto. right; rewrite <- Heqyz; auto. right; inversion Hpcxy as [Hrfexy | [Hcoxy | [Hfrxy | [Hcorfexy | Hfrrfexy]]]]; clear Hpcxy; inversion Hpcyz as [Hrfeyz | [Hcoyz | [Hfryz | [Hcorfeyz | Hfrrfeyz]]]]; clear Hpcyz. assert False as Ht. apply (read_write_contrad y); [apply ran_rf_is_read with E x; destruct Hrfexy | apply dom_rf_is_write with E z; destruct Hrfeyz]; auto. inversion Ht. assert False as Ht. apply (read_write_contrad y); [apply ran_rf_is_read with E x; destruct Hrfexy | apply dom_co_is_write with E co z]; auto. inversion Ht. destruct Hrfexy as [? ?]; right; left; apply rf_fr_is_co with y; auto. assert False as Ht. apply (read_write_contrad y); [apply ran_rf_is_read with E x; destruct Hrfexy | destruct Hcorfeyz as [e [Hye Hez]]; apply dom_co_is_write with E co e]; auto. inversion Ht. destruct Hrfexy as [? ?]; destruct Hfrrfeyz as [e [Hfr Hrfe]]; right; right; right; left; exists e; split; auto; apply rf_fr_is_co with y; auto. right; right; right; left; exists y; split; auto. right; left; apply co_trans with y; auto. assert False as Ht. generalize (ran_co_is_write x y Hcowf Hcoxy); intro Hwy; generalize (dom_fr_is_read Hfryz); intro Hry; apply (read_write_contrad y Hry Hwy). inversion Ht. right; right; right; left; destruct Hcorfeyz as [e [Hco Hrfe]]; exists e; split; auto; apply co_trans with y; auto. destruct Hfrrfeyz as [e [Hfr Hrfe]]; assert False as Ht. generalize (ran_co_is_write x y Hcowf Hcoxy); intro Hwy; generalize (dom_fr_is_read Hfr); intro Hry; apply (read_write_contrad y Hry Hwy). inversion Ht. right; right; right; right; exists y; split; auto. right; right; left; apply fr_co_is_fr with y; auto. assert False as Ht. generalize (ran_fr_is_write Hcowf Hfrxy); intro Hwy; generalize (dom_fr_is_read Hfryz); intro Hry; apply (read_write_contrad y Hry Hwy). inversion Ht. destruct Hcorfeyz as [e [Hco Hrfe]]; right; right; right; right; exists e; split; auto; apply fr_co_is_fr with y; auto. destruct Hfrrfeyz as [e [Hfr Hrfe]]; assert False as Ht. generalize (ran_fr_is_write Hcowf Hfrxy); intro Hwy; generalize (dom_fr_is_read Hfr); intro Hry; apply (read_write_contrad y Hry Hwy). inversion Ht. assert False as Ht. apply (read_write_contrad y); [destruct Hcorfexy as [e [Hxe [Hey ?]]]; apply ran_rf_is_read with E e | apply dom_rf_is_write with E z; destruct Hrfeyz]; auto. inversion Ht. assert False as Ht. apply (read_write_contrad y); [destruct Hcorfexy as [e [Hxe [Hey ?]]]; apply ran_rf_is_read with E e | apply dom_co_is_write with E co z]; auto. inversion Ht. destruct Hcorfexy as [e [Hco Hrfe]]; destruct Hrfe as [? ?]; right; left; apply co_trans with e; auto; apply rf_fr_is_co with y; auto. assert False as Ht. apply (read_write_contrad y); [destruct Hcorfexy as [e [Hxe [Hey ?]]]; apply ran_rf_is_read with E e | destruct Hcorfeyz as [e [Hye Hez]]; apply dom_co_is_write with E co e]; auto. inversion Ht. destruct Hcorfexy as [e [Hco [Hrfe ?]]]; destruct Hfrrfeyz as [e' [Hfr Hrfe']]; right; right; right; left; exists e'; split; auto; apply co_trans with e; auto; apply rf_fr_is_co with y; auto. destruct Hfrrfexy as [e [Hfr [Hrf ?]]]; destruct Hrfeyz as [Hrf' ?]; assert False as Ht. generalize (dom_rf_is_write Hrf'); intro Hwy; generalize (ran_rf_is_read Hrf); intro Hry; apply (read_write_contrad y Hry Hwy). inversion Ht. destruct Hfrrfexy as [e [Hfr [Hrf ?]]]; assert False as Ht. generalize (ran_rf_is_read Hrf); intro Hry; generalize (dom_co_is_write y z Hcowf Hcoyz); intro Hwy; apply (read_write_contrad y Hry Hwy). inversion Ht. destruct Hfrrfexy as [e [Hfr [Hrf ?]]]; right; right; left; apply fr_co_is_fr with e; auto; apply rf_fr_is_co with y; auto. destruct Hfrrfexy as [e [Hfr [Hrf ?]]]; destruct Hcorfeyz as [e' [Hco [Hrf' ?]]]; assert False as Ht. generalize (ran_rf_is_read Hrf); intro Hry; generalize (dom_co_is_write y e' Hcowf Hco); intro Hwy; apply (read_write_contrad y Hry Hwy). inversion Ht. destruct Hfrrfexy as [e [Hfr [Hrf ?]]]; destruct Hfrrfeyz as [e' [Hfr' Hrfe]]; right; right; right; right; exists e'; split; auto; apply fr_co_is_fr with e; auto; apply rf_fr_is_co with y; auto. Qed. Lemma obs_extra_in_complus E co x y : (obs_extra E co) x y -> (complus E co) x y. Proof. intros Hobs_extraxy; auto. inversion Hobs_extraxy as [Hrf | [Hco | [Hfr | [Hcorf | Hfrrf]]]]; clear Hobs_extraxy. left; apply rfe_in_rf; auto. right; left; auto. right; right; auto. right; right; right; left; apply corfe_in_corf; auto. right; right; right; right; apply frrfe_in_frrf; auto. Qed. Lemma mobs_extra_in_mcomplus E co x y : maybe (obs_extra E co) x y -> maybe (complus E co) x y. Proof. intros [Heqxy | Hobs_extraxy]; [left | right]; auto. apply obs_extra_in_complus; auto. Qed. Lemma complus_seq_obs_extra_is_complus E co x y z : rf_well_formed E -> co_well_formed E co -> maybe (complus E co) x y -> maybe (obs_extra E co) y z -> maybe (complus E co) x z. Proof. intros Hrfwf Hcowf Hxy Hyz. apply mcomplus_trans with y; auto. apply mobs_extra_in_mcomplus; auto. Qed. Lemma mcomplus_seq_obs_extra_seq_pgcb E co lob e' e2 e'' e3 : rf_well_formed E -> co_well_formed E co -> maybe (complus E co) e' e2 -> obs_extra E co e2 e'' -> preorder_gcb E lob e'' e3 -> rel_seq (maybe (obs_extra E co)) (preorder_gcb E lob) e' e3. Proof. intros Hrfwf Hcowf H'2 H2'' H''3. apply mcomplus_seq_pgcb_incl; auto. exists e''; split; auto; apply complus_seq_obs_extra_is_complus with e2; auto; right; auto. Qed. Lemma complus_seq_tc E (co lob : set Event -> Rln Event) x y z : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> internal_visibility E co -> external_visibility E co lob -> maybe (complus E co) x y -> transitive_closure (rel_seq (maybe (obs_extra E co)) (preorder_gcb E lob)) y z -> transitive_closure (rel_seq (maybe (obs_extra E co)) (preorder_gcb E lob)) x z. Proof. intros Hrfwf Hcowf Hlobwf Hintv Hextv Hxy Hyz. induction Hyz. Focus 2. apply _trans with e; auto. destruct H as [e' [H1' H'e]]; inversion H1' as [Heq1' | Hobs_extra1']; clear H1'. rewrite Heq1' in Hxy; apply mcomplus_seq_pgcb with e'; auto. apply mcomplus_seq_obs_extra_seq_pgcb with e1 e'; auto. destruct H as [e' [H1' H'e]]; inversion H1' as [Heq1' | Hobs_extra1']; clear H1'. apply _base; rewrite Heq1' in Hxy; apply mcomplus_seq_pgcb with e'; auto. apply _base; apply mcomplus_seq_obs_extra_seq_pgcb with e1 e'; auto. Qed. (** ** The relation pre_egc is a partial order over events viz, - it is defined over events - it is transitive - it is irreflexive *) Lemma pre_egc_in_evts (E : set Event) (co lob : set Event -> Rln Event) : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> Included Event (Union Event (dom (pre_egc E co lob)) (ran (pre_egc E co lob))) E. Proof. (** The relation pre_egc is defined over events and transitive: since pre_egc is defined as the transitive closure of a union of relations over events, it is trivially defined over events and trivially transitive. *) intros Hrfwf Hcowf Hlobwf; apply r_in_evts_implies_tc_in_evts; intros _x [x Hdom | y Hran]. destruct Hdom as [y Hxy]; inversion Hxy as [Hrf | [Hco | [Hfr | [Hlob ?]]]]. apply dom_rf_in_evts with y; auto. apply dom_co_in_evts with co y; auto. apply dom_fr_in_evts with co y; auto. destruct_lob_wf Hlobwf; apply dom_po_in_evts with y; auto. destruct Hran as [x Hxy]; inversion Hxy as [Hrf | [Hco | [Hfr | [Hlob ?]]]]. apply ran_rf_in_evts with x; auto. apply ran_co_in_evts with co x; auto. apply ran_fr_in_evts with co x; auto. destruct_lob_wf Hlobwf; apply ran_po_in_evts with x; auto. Qed. Lemma obs_extra_obsp_eq E co : rf_well_formed E -> co_well_formed E co -> obs_extra E co = obsplus E co. Proof. intros Hrfwf Hcowf; apply Extensionality_Rlns; split; intros e1 e2 H12. inversion H12 as [Hrfe | [Hco | [Hfr | [Hcorfe | Hfrrfe]]]]. apply _base; left; auto. unfold obsplus. unfold obs. apply _base; right; left; auto. apply _base; right; right; auto. destruct Hcorfe as [e [Hco Hrfe]]; apply _trans with e; [right; left | apply _base; left]; auto. destruct Hfrrfe as [e [Hco Hrfe]]; apply _trans with e; [right; right | apply _base; left]; auto. induction H12. inversion H as [Hrfe | [Hco | Hfr]]. left; auto. right; left; auto. right; right; left; auto. inversion H as [Hrfe1e | [Hco1e | Hfr1e]]. (*e1,e in rfe*) inversion IHtransitive_closure as [Hrfee2 | [Hcoe2 | [Hfre2 | [Hcorfee2 | Hfrrfee2]]]]. destruct Hrfe1e as [Hrfe1e ?]; destruct Hrfee2 as [Hrfee2 ?]; generalize (ran_rf_is_read Hrfe1e); intro Hre; generalize (dom_rf_is_write Hrfee2); intro Hwe; generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. destruct Hrfe1e as [Hrfe1e ?]; generalize (ran_rf_is_read Hrfe1e); intro Hre; generalize (dom_co_is_write e e2 Hcowf Hcoe2); intro Hwe; generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. destruct Hrfe1e as [Hrfe1e ?]; right; left; apply rf_fr_is_co with e; auto. destruct Hrfe1e as [Hrfe1e ?]; destruct Hcorfee2 as [e' [Hco ?]]; generalize (ran_rf_is_read Hrfe1e); intro Hre; generalize (dom_co_is_write e e' Hcowf Hco); intro Hwe; generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. destruct Hrfe1e as [Hrfe1e ?]; destruct Hfrrfee2 as [e' [Hfr ?]]; generalize (rf_fr_is_co Hrfwf Hrfe1e Hfr); intro Hco; right; right; right; left; exists e'; split; auto. (*e1,e2 in co*) inversion IHtransitive_closure as [Hrfee2 | [Hcoe2 | [Hfre2 | [Hcorfee2 | Hfrrfee2]]]]. right; right; right; left; exists e; split; auto. right; left; apply co_trans with e; auto. generalize (ran_co_is_write e1 e Hcowf Hco1e); intro Hwe; generalize (dom_fr_is_read Hfre2); intro Hre; generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. destruct Hcorfee2 as [e'[Hco ?]]; generalize (co_trans e1 e e' Hcowf Hco1e Hco); intro Hco1e'; right; right; right; left; exists e'; split; auto. destruct Hfrrfee2 as [e' [Hfr ?]]; generalize (ran_co_is_write e1 e Hcowf Hco1e); intro Hwe; generalize (dom_fr_is_read Hfr); intro Hre. generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. (*e1,e2 in fr*) inversion IHtransitive_closure as [Hrfee2 | [Hcoe2 | [Hfre2 | [Hcorfee2 | Hfrrfee2]]]]. right; right; right; right; exists e; split; auto. right; right; left; apply fr_co_is_fr with e; auto. generalize (ran_fr_is_write Hcowf Hfr1e); intro Hwe; generalize (dom_fr_is_read Hfre2); intro Hre; generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. destruct Hcorfee2 as [e' [Hco Hrfe]]; generalize (fr_co_is_fr e' Hcowf Hfr1e Hco); intro Hfr1e'; right; right; right; right; exists e'; split; auto. destruct Hfrrfee2 as [e' [Hfr Hrfe]]; generalize (ran_fr_is_write Hcowf Hfr1e); intro Hwe; generalize (dom_fr_is_read Hfr); intro Hre; generalize (read_write_contrad e Hre Hwe); intro Ht; inversion Ht. Qed. Lemma obsp_pgcb_in_ob (E : set Event) (co lob : set Event -> Rln Event) (x y : Event) : lob_well_formed E lob -> rf_well_formed E -> (rel_union (obsplus E co) (preorder_gcb E lob)) x y -> ob E co (lob E) x y. Proof. intros Hlobwf Hrfwf Hxy. inversion Hxy as [Hobsp | Hpgcb]; clear Hxy. induction Hobsp. apply _obs; auto. apply _ob with e; auto; apply _obs; auto. apply _lob; destruct Hpgcb as [Hlob ?]; auto. Qed. Lemma tc_obsp_pgcb_in_ob (E : set Event) (co lob : set Event -> Rln Event) (x y : Event) : lob_well_formed E lob -> rf_well_formed E -> transitive_closure (rel_union (obsplus E co) (preorder_gcb E lob)) x y -> ob E co (lob E) x y. Proof. intros Hlobwf Hrfwf Hxy; induction Hxy. apply obsp_pgcb_in_ob; auto. apply _ob with e; auto; apply obsp_pgcb_in_ob; auto. Qed. Lemma tc_union_irr (E : set Event) (co lob : set Event -> Rln Event) (x : Event) : lob_well_formed E lob -> rf_well_formed E -> external_visibility E co lob -> (transitive_closure (rel_union (obsplus E co) (preorder_gcb E lob))) x x -> False. Proof. intros Hlobwf Hrfwf Hev Hx; apply Hev; exists x. apply tc_obsp_pgcb_in_ob; auto. Qed. Lemma tc_dec2 r e1 e3 : transitive_closure r e1 e3 -> exists e2, r e1 e2 /\ maybe (transitive_closure r) e2 e3. Proof. intros H13; induction H13. exists e2; split; auto; left; auto. exists e; split; auto; right; auto. Qed. Lemma rfi_seq_union_in_nrel E co lob x y z : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> rfi E x y -> rel_union (obsplus E co) (preorder_gcb E lob) y z -> transitive_closure (rel_union (obsplus E co) (preorder_gcb E lob)) x z. Proof. intros Hrfwf Hcowf Hlobwf Hrfi [Hobsp | Hpgcb]. apply _base; left. apply rfi_seq_obsplus_in_obsplus with lob y; auto. apply _base; right; apply rfi_pgcb_is_pgcb with y; auto. Qed. Lemma rfi_seq_nrel_in_tc_obsp_pgcb E co lob x y z : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> rfi E x y -> nrel E co lob y z -> rfi E x z \/ transitive_closure (rel_union (obsplus E co) (preorder_gcb E lob)) x z. Proof. intros Hrfwf Hcowf Hlobwf Hxy [Heqyz | Htcyz]. rewrite Heqyz in Hxy; left; auto. induction Htcyz as [y z Hyz|]. right; apply rfi_seq_union_in_nrel with y; auto. right; apply tc_trans with e; auto; apply rfi_seq_union_in_nrel with e1; auto. Qed. Lemma rfi_irr E x : rfi E x x -> False. Proof. intros [Hrf Hint]; generalize (dom_rf_is_write Hrf); intro Hwx; generalize (ran_rf_is_read Hrf); intro Hrx. apply read_write_contrad with x; auto. Qed. (** ** The relation pre_egc is irreflexive: *) Lemma pre_egc_irr (E : set Event) (co lob : set Event -> Rln Event) : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> internal_visibility E co -> external_visibility E co lob -> (forall x : Event, ~ pre_egc E co lob x x). Proof. (** Reason by contradiction and suppose that there exists x s.t. (x,x) in pre_egc.*) intros Hrfwf Hcowf Hlobwf Hint_vis Hext_vis x Hx. generalize (pre_egc_dec Hrfwf Hcowf Hlobwf Hx); clear Hx; intros [Hx|[Hx|Hx]]. destruct Hx as [y [Hnrel Hrfi]]. generalize (rfi_seq_nrel_in_tc_obsp_pgcb Hrfwf Hcowf Hlobwf Hrfi Hnrel); intros [Hrfiy | Hnrely]. apply rfi_irr with E y; auto. apply tc_union_irr with E co lob y; auto. apply Hint_vis; exists x; apply obsplus_in_scpv; auto. generalize (br2_dec Hlobwf Hrfwf Hcowf Hx); clear Hx; apply tc_union_irr; auto. Qed. Lemma pre_egc_partial_order (E : set Event) (co lob : set Event -> Rln Event) : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> internal_visibility E co -> external_visibility E co lob -> partial_order (pre_egc E co lob) E. Proof. intros Hrfwf Hcowf Hlobwf Hint_vis Hext_vis; split; [|split]. apply pre_egc_in_evts; auto. intros e1 e2 e3 H12 H23; apply tc_trans with e2; auto. apply pre_egc_irr; auto. Qed. (** ** A linear extension of the relation pre_egc satisfies the [external_global_completion] requirement viz, - gcb is a linear extension of the preorder_gcb relation - the read-froms extracted from gcb [gcb_rf] are the same as the axiomatic ones [rf] - the coherence extracted from gcb [gcb_co] are the same as the axiomatic ones [co] *) (** *** The gcb relation is a linear extension of the preorder_gcb relation *) Lemma gcb_is_lin (E : set Event) (co lob : set Event -> Rln Event) (gcb : Rln Event) : linearisations (pre_egc E co lob) E gcb -> linearisations (preorder_gcb E lob) E gcb. Proof. (** By definition gcb is a linearisation of the relation pre_egc. Observe that preorder_gcb is included in pre_egc. Note that for all relation r2 included in another relation r1, a linearisation of the bigger relation r1 is a linearisation of the smaller relation r2. Therefore a linearisation of the bigger relation pre_egc is also a linearisation of the smaller relation preorder_gcb. *) intros Hlin; apply lin_of_big_is_lin_of_little with (pre_egc E co lob); auto. intros x y Hxy; apply _base; right; right; right; auto. Qed. Lemma co_in_pre_egc E co lob : rel_incl (co E) (pre_egc E co lob). Proof. intros x y Hxy; apply _base; right; left; auto. Qed. Lemma co_gcb_incl (E : set Event) (co lob : set Event -> Rln Event) (gcb : Rln Event) : co_well_formed E co -> linearisations (pre_egc E co lob) E gcb -> rel_incl (co E) (gcb_co E gcb). Proof. intros Hcowf Hlin x y Hxy. split. apply dom_co_is_write with E co y; auto. split. apply ran_co_is_write with E co x; auto. split. apply co_implies_same_loc with E co; auto. assert (pre_egc E co lob x y) as Hin. apply co_in_pre_egc; auto. generalize (lin_ext_prop E (pre_egc E co lob) gcb); intros [Hd1 Hd2]. generalize (Hd1 Hlin); intros [Hincl ?]; apply Hincl; auto. Qed. Lemma gcb_co_incl (E : set Event) (co lob : set Event -> Rln Event) (gcb : Rln Event) : co_well_formed E co -> linearisations (pre_egc E co lob) E gcb -> rel_incl (gcb_co E gcb) (co E). Proof. intros Hcowf Hlin x y Hxy; generalize Hcowf; intros [Hincl Hlin_co]. generalize (Hlin_co (loc x)); clear Hlin_co; intro Hlin_co; destruct_lin Hlin_co. destruct Hxy as [Hwx [Hwy [Heqloc Hgcbxy]]]. generalize (lin_ext_prop E (pre_egc E co lob) gcb); intros [Hd1 Hd2]. generalize (Hd1 Hlin); intros [? Hlin_gcb]; destruct Hlin_gcb as [Hpart_gcb ?]; destruct_part Hpart_gcb. assert (x <> y) as Hdiff. intro Heq; rewrite Heq in Hgcbxy; destruct Heq. apply Hirr with x; auto. assert (Intersection Event E (is_write_same_loc (loc x)) x) as Hx. split. apply Hinc; left; exists y; auto. split; auto. assert (Intersection Event E (is_write_same_loc (loc x)) y) as Hy. split. apply Hinc; right; exists x; auto. split; auto. generalize (Htot x y Hdiff Hx Hy); intros [?|Hyx]; auto. assert (gcb y x) as Hgcbyx. generalize (co_gcb_incl Hcowf Hlin y x Hyx); intros [? [? [? ?]]]; auto. assert False as Ht. apply Hirr with x; apply Htrans with y; auto. inversion Ht. Qed. Lemma gcb_coeq (E : set Event) (co lob : set Event -> Rln Event) (gcb : Rln Event) : co_well_formed E co -> linearisations (pre_egc E co lob) E gcb -> rel_equal (co E) (gcb_co E gcb). Proof. intros Hcowf Hlin; split. apply co_gcb_incl with lob; auto. apply gcb_co_incl with lob; auto. Qed. Lemma gcb_rf_incl (E : set Event) (co lob : set Event -> Rln Event) (gcb : Rln Event) : linearisations (pre_egc E co lob) E gcb -> rel_incl (gcb_rf E gcb) (rf E). Proof. intros Hlin; generalize (lin_ext_prop E (pre_egc E co lob) gcb); intros [Himpl _]; generalize (Himpl Hlin); clear Himpl; intros [Hincl Hlso]; intros x y Hxy. destruct_lin Hlso; destruct_part Hpart; destruct Hxy as [Hwx [Hry [Hloc [Hval [Hgcb Hnointerv]]]]]; split; auto; split; auto; split; auto; split; auto; split; auto; apply Hinc; auto; [left; exists y | right; exists x]; auto. Qed. Lemma gcb_rf_is_wf (E : set Event) (co lob : set Event -> Rln Event) (gcb : Rln Event) : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> internal_visibility E co -> external_visibility E co lob -> linearisations (pre_egc E co lob) E gcb -> gcb_rf_wf E gcb. Proof. intros Hrfwf Hcowf Hlobwf Hint_vis Hext_vis Hlin r Hr. generalize Hrfwf; intro Hrfwf'; destruct_rf_wf Hrfwf'; generalize (Hex_uni r Hr); intros [[w Hrf] Huni]; generalize (lin_ext_prop E (pre_egc E co lob) gcb); intros [Himpl _]; generalize (Himpl Hlin); clear Himpl; intros [Hincl Hlso]; exists w; split; [apply dom_rf_is_write with E r | split; [apply ran_rf_is_read with E w | split; [apply rf_implies_same_loc with E | split; [apply rf_implies_same_val with E | split]]]]; auto. apply Hincl; left; left; auto. intros [w' [Hw' [[Hgcbww' Hlocww'] [Hgcbw'r Hlocw'r]]]]. generalize (gcb_co_incl Hcowf Hlin); intro Hcoincl. assert (is_write w) as Hw. apply dom_rf_is_write with E r; auto. assert (co E w w') as Hcoww'. apply Hcoincl; split; auto. assert (fr E co r w') as Hfrrw'. exists w; split; auto. assert (gcb r w') as Hgcbrw'. apply Hincl; left; right; right; left; auto. destruct_lin Hlso; destruct_part Hpart. generalize (Htrans w' r w' Hgcbw'r Hgcbrw'); intro Hcy; apply Hirr with w'; auto. Qed. Lemma rf_gcb_incl (E : set Event) (co lob : set Event -> Rln Event) (gcb : Rln Event) : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> internal_visibility E co -> external_visibility E co lob -> linearisations (pre_egc E co lob) E gcb -> rel_incl (rf E) (gcb_rf E gcb). Proof. intros Hrfwf Hcowf Hlobwf Hint_vis Hext_vis Hlin; intros x y Hxy. assert (is_read y) as Hry. apply ran_rf_is_read with E x; auto. generalize (gcb_rf_is_wf Hrfwf Hcowf Hlobwf Hint_vis Hext_vis Hlin y Hry); intros [w Hgcbrfwy]; generalize (gcb_rf_incl Hlin Hgcbrfwy); intro Hrfwy; destruct_rf_wf Hrfwf; generalize (Hex_uni y Hry); intros [Hex Huni]; clear Hex_uni; generalize (Huni x w Hxy Hrfwy); intro Heq; rewrite Heq; auto. Qed. Lemma gcb_rfeq (E : set Event) (co lob : set Event -> Rln Event) (gcb : Rln Event) : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> internal_visibility E co -> external_visibility E co lob -> linearisations (pre_egc E co lob) E gcb -> rel_equal (rf E) (gcb_rf E gcb). Proof. intros Hrfwf Hcowf Hlobwf Hint_vis Hext_vis Hlin; generalize (lin_ext_prop E (pre_egc E co lob) gcb); intros [Himpl _]; generalize (Himpl Hlin); clear Himpl; intros [Hincl Hlso]; split. apply rf_gcb_incl with co lob; auto. apply gcb_rf_incl with co lob; auto. Qed. Lemma external_global_completion_gcb (E : set Event) (co lob : set Event -> Rln Event) (gcb : Rln Event) : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> internal_visibility E co -> external_visibility E co lob -> linearisations (pre_egc E co lob) E gcb -> external_global_completion E co lob gcb. Proof. intros Hrfwf Hcowf Hlobwf Hint_vis Hext_vis Hlin; split; [|split]; auto. apply gcb_is_lin with co; auto. apply gcb_rfeq with co lob; auto. apply gcb_coeq with lob; auto. Qed. (** ** All in all *) Lemma external_visibility_implies_external_global_completion (E : set Event) (co lob : set Event -> Rln Event) : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> internal_visibility E co -> (external_visibility E co lob -> exists gcb : Rln Event, external_global_completion E co lob gcb). Proof. intros Hrfwf Hcowf Hlobwf Hint_vis Hext_vis. generalize (pre_egc_partial_order Hrfwf Hcowf Hlobwf Hint_vis Hext_vis); intro Hpart; generalize (order_ext Hpart); intros [gcb Hgcb]; exists gcb. apply external_global_completion_gcb; auto. Qed. (** * External Visibility <-> External Global Completion *) Theorem external_visibility_gcb_equivalence (E : set Event) (co lob : set Event -> Rln Event) : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> internal_visibility E co -> (external_visibility E co lob <-> (exists gcb, external_global_completion E co lob gcb)). Proof. intros Hrfwf Hcowf Hlob_wf Hint_vis. split. apply external_visibility_implies_external_global_completion; auto. apply external_global_completion_implies_external_visibility; auto. Qed. (** * External Completion *) (** ** External Completion: Definitions *) Definition fwd (E : set Event) (cb : Rln Event) (w r : Event) := po E w r /\ cb r w /\ ~intervening_write (fun e1 e2 => po E e1 e2 /\ loc e1 = loc e2) w r. Definition nfwd (E : set Event) (cb : Rln Event) (w r : Event) := cb w r /\ ~intervening_write (fun e1 e2 => cb e1 e2 /\ loc e1 = loc e2) w r. Definition cb_rf (E : set Event) (cb : Rln Event) (e1 e2 : Event) : Prop := is_write e1 /\ is_read e2 /\ loc e1 = loc e2 /\ val e1 = val e2 /\ ((fwd E cb e1 e2) \/ (nfwd E cb e1 e2)). Definition cb_co (E : set Event) (cb : Rln Event) (e1 e2 : Event) : Prop := order_to_co E cb e1 e2. Definition external_completion (E : set Event) (co lob : set Event -> Rln Event) (cb : Rln Event): Prop := (linearisations (lob E) E) cb /\ rel_equal (rf E) (cb_rf E cb) /\ rel_equal (co E) (cb_co E cb). Definition big_rel3 (E : set Event) (co lob : set Event -> Rln Event) := tc_mobs_r_mobs E co (lob E). (** ** External Completion: Lemmas that do _not_ need the existence of a External Global Completion order *) Lemma rfe_in_cb E cb x y : rel_equal (rf E) (cb_rf E cb) -> rfe E x y -> cb x y. Proof. intros Hrfeq [Hrf Hext]; destruct Hrfeq as [Hrfincl ?]; generalize (Hrfincl x y Hrf); intros [? [? [? [? [Hfwd | Hnfwd]]]]]; auto. assert False as Ht. apply int_ext_contrad with E x y; auto. destruct Hfwd as [[? ?] ?]; auto. inversion Ht. destruct Hnfwd as [? ?]; auto. Qed. Lemma co_in_cb E co cb x y : rel_equal (co E) (cb_co E cb) -> co E x y -> cb x y. Proof. apply co_in_order; auto. Qed. Lemma fr_implies_cb_or_cb_minus_1 (E : set Event) (co lob : set Event -> Rln Event) (cb : Rln Event) (e1 e2 : Event) : co_well_formed E co -> linearisations (lob E) E cb -> fr E co e1 e2 -> cb e1 e2 \/ cb e2 e1. Proof. intros Hlin H12. apply fr_implies_order_or_order_minus_1 with (lob E); auto. Qed. Lemma fr_in_cb E co lob cb x y : co_well_formed E co -> linearisations (lob E) E cb -> rel_equal (rf E) (cb_rf E cb) -> rel_equal (co E) (cb_co E cb) -> fr E co x y -> cb x y. Proof. intros Hcowf Hlin Hrfeq Hcoeq Hfr. generalize (fr_implies_cb_or_cb_minus_1 lob Hcowf Hlin Hfr); intros [? | Hgcbyx]; auto; generalize Hfr; intros [w [Hw [Hrf Hco]]]. destruct Hrfeq as [Hinclrf ?]; generalize (Hinclrf w x Hrf); intros [? [? [? [? [Hfwd | Hnfwd]]]]]. destruct Hfwd as [? [Hcbxw ?]]. assert False as Ht. generalize (lin_ext_prop E (lob E) cb); intros [Himpl ?]; generalize (Himpl Hlin); intros [Hincl Hlso]; destruct_lin Hlso; destruct_part Hpart; apply (Hirr x). apply Htrans with w; auto; apply Htrans with y; auto. destruct Hcoeq as [Hcoincl ?]; apply Hcoincl; auto. inversion Ht. destruct Hnfwd as [Hcbwx Hnointerv]; (*here: observe the different structure from fr_in_gcb, need to refactor*) generalize (co_in_cb co w y Hcoeq Hco); intro Hcbwy. assert False as Ht. apply Hnointerv; exists y; split; [|split; split]; auto. apply ran_co_is_write with E co w; auto. apply co_implies_same_loc with E co; auto. generalize (fr_implies_same_loc Hcowf Hfr); auto. inversion Ht. Qed. Lemma cb_path_ob_dec (E : set Event) (co lob : set Event -> Rln Event) (cb : Rln Event) (e1 e2 : Event) : rel_equal (rf E) (cb_rf E cb) -> rel_equal (co E) (cb_co E cb) -> ob E co (lob E) e1 e2 -> obsplus E co e1 e2 \/ big_rel3 E co lob e1 e2. Proof. intros Hrfeq Hcoeq H12. induction H12 as [e1 e2 Hobs | e1 e2 Hlob |]; auto. left; apply _base; auto. right; apply _base; exists e1; split; [left|exists e2; split; [|left]]; auto. inversion IHob1 as [Hob1 | Hbr1]; clear IHob1; inversion IHob2 as [Hob2 | Hbr2]; clear IHob2. left; apply tc_trans with e; auto. right; apply tc_seq_left with e; auto; [intros x y z Hxy Hyz; apply mop_trans with y | right]; auto. right; apply tc_seq_reorg with e; auto; [intros x y z Hxy Hyz; apply mop_trans with y |right]; auto. right; apply tc_trans with e; auto. Qed. (** ** External Completion -> External Visibility lemmas *) Lemma big_rel3_irr E co lob cb x : rf_well_formed E -> co_well_formed E co -> linearisations (lob E) E cb -> rel_equal (rf E) (cb_rf E cb) -> rel_equal (co E) (cb_co E cb) -> ~(big_rel3 E co lob x x). Proof. intros Hrfwf Hcowf Hlin Hrfeq Hcoeq; apply tc_mobs_r_mobs_irr with cb; auto; intros e1 e2 H12. apply rfe_in_cb with E; auto. apply co_in_cb with E co; auto. apply fr_in_cb with E co lob; auto. Qed. Lemma external_completion_implies_external_visibility (E : set Event) (co lob : set Event -> Rln Event) : rf_well_formed E -> co_well_formed E co -> internal_visibility E co -> (exists cb : Rln Event, external_completion E co lob cb) -> external_visibility E co lob. Proof. intros Hrfwf Hcowf Hintv [cb [Hlin [Hrf Hco]]] [x Hx]. generalize (cb_path_ob_dec lob Hrf Hco Hx); intros [Hobs | Hbr3]. apply Hintv; exists x; apply obsplus_in_scpv; auto. apply (big_rel3_irr Hrfwf Hcowf Hlin Hrf Hco Hbr3); auto. Qed. (** ** External Visibility -> External Completion lemmas *) Definition pre_ec (E : set Event) (co lob : set Event -> Rln Event) := transitive_closure (rel_union (rfe E) (rel_union (co E) (rel_union (fr E co) (lob E)))). Definition big_rel4 E co lob := transitive_closure (rel_seq (maybe (obs_extra E co)) (rel_seq (lob E) (maybe (obs_extra E co)))). Lemma rfe_obs_extra_in_obs_extra E co e1 e e2 : co_well_formed E co -> rf_well_formed E -> rfe E e1 e -> obs_extra E co e e2 -> obs_extra E co e1 e2. Proof. intros Hcowf Hrfwf H1e [Hrfe | [Hco | [Hfr | [Hcorfe | Hfrrfe]]]]. assert False as Ht. apply read_write_contrad with e; [apply ran_rf_is_read with E e1; destruct H1e | apply dom_rf_is_write with E e2; destruct Hrfe]; auto. inversion Ht. assert False as Ht. apply read_write_contrad with e; [apply ran_rf_is_read with E e1; destruct H1e | apply dom_co_is_write with E co e2]; auto. inversion Ht. right; left; apply rf_fr_is_co with e; destruct H1e; auto. assert False as Ht. apply read_write_contrad with e; [apply ran_rf_is_read with E e1; destruct H1e | destruct Hcorfe as [e' [? ?]]; apply dom_co_is_write with E co e']; auto. inversion Ht. destruct Hfrrfe as [e' [Hfr Hrfe]]; right; right; right; left; exists e'; split; auto; apply rf_fr_is_co with e; destruct H1e; auto. Qed. Lemma rfe_br4_in_br4 E co lob e1 e e2 : co_well_formed E co -> rf_well_formed E -> rfe E e1 e -> big_rel4 E co lob e e2 -> big_rel4 E co lob e1 e2. Proof. intros Hcowf Hrfwf H1e He2; induction He2 as [e e2 He2 | e e2 e' Hee']. destruct He2 as [x [Hex [y [Hxy Hy2]]]]. inversion Hex as [Heqex | Hcomplusex]; clear Hex. rewrite Heqex in H1e; clear Heqex; apply _base; exists x; split; auto; [right; left|exists y; split]; auto. apply _base; exists x; split; auto; [right; apply rfe_obs_extra_in_obs_extra with e | exists y; split]; auto. apply _trans with e'; auto. destruct Hee' as [x [Hex [y [Hxy Hye']]]]. inversion Hex as [Heqex | Hcomplusex]; clear Hex. rewrite Heqex in H1e; clear Heqex; exists x; split; auto; [right; left|exists y; split]; auto. exists x; split; auto; [right; apply rfe_obs_extra_in_obs_extra with e|exists y; split]; auto. Qed. Lemma co_obs_extra_in_obs_extra E co e1 e e2 : co_well_formed E co -> co E e1 e -> obs_extra E co e e2 -> obs_extra E co e1 e2. Proof. intros Hrfwf H1e [Hrfe | [Hco | [Hfr | [Hcorfe | Hfrrfe]]]]. right; right; right; left; exists e; split; auto. right; left; apply co_trans with e; auto. assert False as Ht. apply read_write_contrad with e; [apply dom_fr_is_read with E co e2 | apply ran_co_is_write with E co e1]; auto. inversion Ht. destruct Hcorfe as [e' [Hco Hrfe]]; right; right; right; left; exists e'; split; auto; apply co_trans with e; auto. destruct Hfrrfe as [e'[Hfr Hrfe]]; assert False as Ht. apply read_write_contrad with e; [apply dom_fr_is_read with E co e' | apply ran_co_is_write with E co e1]; auto. inversion Ht. Qed. Lemma co_br4_in_br4 E co lob e1 e e2 : co_well_formed E co -> co E e1 e -> big_rel4 E co lob e e2 -> big_rel4 E co lob e1 e2. Proof. intros Hcowf H1e He2; induction He2 as [e e2 He2 | e e2 e' Hee']. destruct He2 as [e' [Hee' He'2]]; inversion Hee' as [Heqee' | Hcomplusee']; clear Hee'; apply _base; exists e'; split; auto; right; [rewrite Heqee' in H1e; right; left | apply co_obs_extra_in_obs_extra with e]; auto. apply _trans with e'; auto; destruct Hee' as [e'' [Hee'' He''e']]; exists e''; split; auto; inversion Hee'' as [Heqee'' | Hcomplusee'']; clear Hee''; right; [rewrite <- Heqee''; right; left | apply co_obs_extra_in_obs_extra with e]; auto. Qed. Lemma fr_obs_extra_in_obs_extra E co e1 e e2 : rf_well_formed E -> co_well_formed E co -> fr E co e1 e -> obs_extra E co e e2 -> obs_extra E co e1 e2. Proof. intros Hrfwf Hcowf H1e [Hrfe | [Hco | [Hfr | [Hcorfe | Hfrrfe]]]]. right; right; right; right; exists e; split; auto. right; right; left; apply fr_co_is_fr with e; auto. assert False as Ht. apply read_write_contrad with e; [apply dom_fr_is_read with E co e2 | apply ran_fr_is_write with E co e1]; auto. inversion Ht. destruct Hcorfe as [e' [Hco Hrfe]]; right; right; right; right; exists e'; split; auto; apply fr_co_is_fr with e; auto. destruct Hfrrfe as [e' [Hfr Hrfe]]; assert False as Ht. apply read_write_contrad with e; [apply dom_fr_is_read with E co e' | apply ran_fr_is_write with E co e1]; auto. inversion Ht. Qed. Lemma fr_br4_in_br4 E co lob e1 e e2 : rf_well_formed E -> co_well_formed E co -> fr E co e1 e -> big_rel4 E co lob e e2 -> big_rel4 E co lob e1 e2. Proof. intros Hrfwf Hcowf H1e He2; induction He2 as [e e2 He2 | e e2 e' Hee']. destruct He2 as [e' [Hee' He'2]]; inversion Hee' as [Heqee' | Hcomplusee']; clear Hee'; apply _base; exists e'; split; auto; right; [rewrite Heqee' in H1e; right; right; left | apply fr_obs_extra_in_obs_extra with e]; auto. apply _trans with e'; auto; destruct Hee' as [e'' [Hee'' He''e']]; exists e''; split; auto; inversion Hee'' as [Heqee'' | Hcomplusee'']; clear Hee''; right; [rewrite <- Heqee''; right; right; left | apply fr_obs_extra_in_obs_extra with e]; auto. Qed. Lemma lob_br4_in_br4 E (co lob : set Event -> Rln Event) e1 e e2 : rf_well_formed E -> co_well_formed E co -> lob E e1 e -> big_rel4 E co lob e e2 -> big_rel4 E co lob e1 e2. Proof. intros Hrfwf Hcowf H1e He2; induction He2 as [e e2 He2 | e e2 e' Hee']. apply _trans with e; [exists e1; split; [left | exists e; split; [|left]]|apply _base]; auto. apply tc_trans with e'; auto. apply _trans with e; [exists e1; split; [left | exists e; split; [|left]]|apply _base]; auto. Qed. Lemma pre_ec_dec (E : set Event) (co lob : set Event -> Rln Event) (e1 e2 : Event) : rf_well_formed E -> co_well_formed E co -> pre_ec E co lob e1 e2 -> (obs_extra E co) e1 e2 \/ (big_rel4 E co lob) e1 e2. Proof. intros Hrfwf Hcowf H12; induction H12 as [e1 e2 H12 | e1 e2 e H1e He2]. inversion H12 as [Hrf | [Hco | [Hfr | Hlob]]]. left; left; auto. left; right; left; auto. left; right; right; left; auto. right; apply _base; exists e1; split; [left | exists e2; split; [| left]]; auto. inversion H1e as [Hrfe | [Hco | [Hfr | Hlob]]]; clear H1e; inversion IHHe2 as [Hcpe2 | Hbr4e2]; clear IHHe2. left; apply rfe_obs_extra_in_obs_extra with e; auto. right; apply rfe_br4_in_br4 with e; auto. left; apply co_obs_extra_in_obs_extra with e; auto. right; apply co_br4_in_br4 with e; auto. left; apply fr_obs_extra_in_obs_extra with e; auto. right; apply fr_br4_in_br4 with e; auto. right; apply _base; exists e1; split; [left |exists e; split; [|right]]; auto. right; apply lob_br4_in_br4 with e; auto. Qed. Lemma obsplus_in_ob E co lob : rel_incl (obsplus E co) (ob E co (lob E)). Proof. intros x y Hxy; induction Hxy. apply _obs; auto. apply _ob with e; auto; apply _obs; auto. Qed. Lemma tc_ob_in_ob E co lob x y : transitive_closure (ob E co (lob E)) x y -> ob E co (lob E) x y. Proof. intros Hxy; induction Hxy; auto. apply _ob with e; auto. Qed. Lemma pre_ec_irr (E : set Event) (co lob : set Event -> Rln Event) : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> internal_visibility E co -> external_visibility E co lob -> (forall x : Event, ~ pre_ec E co lob x x). Proof. intros Hrfwf Hcowf Hlobwf Hint_vis Hext_vis x Hx. generalize (pre_ec_dec Hrfwf Hcowf Hx); clear Hx; intros [Hx|Hx]. apply complus_irr with E co x; auto. apply obs_extra_in_complus; auto. generalize (tc_seq_inv Hx); intros [e1 [e2 [Hx1 [H12 H2x]]]]. assert (transitive_closure (rel_seq (lob E) (maybe (obs_extra E co))) e1 e2) as H12'. apply tc_incl with (rel_seq (rel_seq (lob E) (maybe (obs_extra E co))) (maybe (obs_extra E co))); auto. intros a d [c [[b [Hab Hbc]] Hcd]]; exists b; split; auto. generalize Hbc Hcd; apply mobs_extra_trans with lob; auto. clear H12. generalize (mobs_extra_trans Hrfwf Hcowf Hlobwf Hint_vis Hext_vis); intro Htr. generalize (seq_tc_seq e1 Htr H12' H2x Hx1); intro H11; clear Hx Hx1 H2x H12' x. rewrite obs_extra_obsp_eq in H11; auto. assert (transitive_closure (ob E co (lob E)) e1 e1) as Htc11. apply tc_incl with (rel_seq (lob E) (maybe (obsplus E co))); auto. intros x y [z [Hxy Hyz]]; inversion Hyz as [Heqyz | Hoyz]; clear Hyz. rewrite <- Heqyz; apply _lob; auto. apply _ob with z; [apply _lob|]; auto. apply obsplus_in_ob; auto. apply Hext_vis; exists e1; auto. apply tc_ob_in_ob; auto. Qed. Lemma pre_ec_in_evts (E : set Event) (co lob : set Event -> Rln Event) : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> Included Event (Union Event (dom (pre_ec E co lob)) (ran (pre_ec E co lob))) E. Proof. intros Hrfwf Hcowf Hlobwf; apply r_in_evts_implies_tc_in_evts; intros _x [x Hdom | y Hran]. destruct Hdom as [y Hxy]; inversion Hxy as [[Hrf ?] | [Hco | [Hfr | Hlob]]]. apply dom_rf_in_evts with y; auto. apply dom_co_in_evts with co y; auto. apply dom_fr_in_evts with co y; auto. destruct_lob_wf Hlobwf; apply dom_po_in_evts with y; auto. destruct Hran as [x Hxy]; inversion Hxy as [[Hrf ?] | [Hco | [Hfr | Hlob]]]. apply ran_rf_in_evts with x; auto. apply ran_co_in_evts with co x; auto. apply ran_fr_in_evts with co x; auto. destruct_lob_wf Hlobwf; apply ran_po_in_evts with x; auto. Qed. Lemma pre_ec_partial_order (E : set Event) (co lob : set Event -> Rln Event) : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> internal_visibility E co -> external_visibility E co lob -> partial_order (pre_ec E co lob) E. Proof. intros Hrfwf Hcowf Hlobwf Hint_vis Hext_vis; split; [|split]. apply pre_ec_in_evts; auto. intros e1 e2 e3 H12 H23; apply tc_trans with e2; auto. apply pre_ec_irr; auto. Qed. Lemma cb_is_lin (E : set Event) (co lob : set Event -> Rln Event) (cb : Rln Event) : linearisations (pre_ec E co lob) E cb -> linearisations (lob E) E cb. Proof. intros Hlin; apply lin_of_big_is_lin_of_little with (pre_ec E co lob); auto. intros x y Hxy; apply _base; right; right; right; auto. Qed. (*exactly the same as gcb_is_lin*) Lemma co_in_pre_ec (E : set Event) (co lob : set Event -> Rln Event) : rel_incl (co E) (pre_ec E co lob). Proof. intros x y Hxy; apply _base; right; left; auto. Qed. Lemma co_cb_incl (E : set Event) (co lob : set Event -> Rln Event) (cb : Rln Event) : co_well_formed E co -> linearisations (pre_ec E co lob) E cb -> rel_incl (co E) (cb_co E cb). Proof. intros Hcowf Hlin x y Hxy. split. apply dom_co_is_write with E co y; auto. split. apply ran_co_is_write with E co x; auto. split. apply co_implies_same_loc with E co; auto. assert (pre_ec E co lob x y) as Hin. apply co_in_pre_ec; auto. generalize (lin_ext_prop E (pre_ec E co lob) cb); intros [Hd1 Hd2]. generalize (Hd1 Hlin); intros [Hincl ?]; apply Hincl; auto. Qed. Lemma cb_co_incl (E : set Event) (co lob : set Event -> Rln Event) (cb : Rln Event) : co_well_formed E co -> linearisations (pre_ec E co lob) E cb -> rel_incl (cb_co E cb) (co E). Proof. intros Hcowf Hlin x y Hxy; generalize Hcowf; intros [Hincl Hlin_co]. generalize (Hlin_co (loc x)); clear Hlin_co; intro Hlin_co; destruct_lin Hlin_co. destruct Hxy as [Hwx [Hwy [Heqloc Hcbxy]]]. generalize (lin_ext_prop E (pre_ec E co lob) cb); intros [Hd1 Hd2]. generalize (Hd1 Hlin); intros [? Hlin_cb]; destruct Hlin_cb as [Hpart_cb ?]; destruct_part Hpart_cb. assert (x <> y) as Hdiff. intro Heq; rewrite Heq in Hcbxy; destruct Heq. apply Hirr with x; auto. assert (Intersection Event E (is_write_same_loc (loc x)) x) as Hx. split. apply Hinc; left; exists y; auto. split; auto. assert (Intersection Event E (is_write_same_loc (loc x)) y) as Hy. split. apply Hinc; right; exists x; auto. split; auto. generalize (Htot x y Hdiff Hx Hy); intros [?|Hyx]; auto. assert (cb y x) as Hcbyx. generalize (co_cb_incl Hcowf Hlin y x Hyx); intros [? [? [? ?]]]; auto. assert False as Ht. apply Hirr with x; apply Htrans with y; auto. inversion Ht. Qed. Lemma cb_coeq (E : set Event) (co lob : set Event -> Rln Event) (cb : Rln Event) : co_well_formed E co -> linearisations (pre_ec E co lob) E cb -> rel_equal (co E) (cb_co E cb). Proof. intros Hcowf Hlin; split. apply co_cb_incl with lob; auto. apply cb_co_incl with lob; auto. Qed. Lemma cb_rf_incl (E : set Event) (co lob : set Event -> Rln Event) (cb : Rln Event) : linearisations (pre_ec E co lob) E cb -> rel_incl (cb_rf E cb) (rf E). Proof. intros Hlin; generalize (lin_ext_prop E (pre_ec E co lob) cb); intros [Himpl _]; generalize (Himpl Hlin); clear Himpl; intros [Hincl Hlso]; intros x y Hxy. destruct_lin Hlso; destruct_part Hpart; destruct Hxy as [Hwx [Hry [Hloc [Hval [Hfwd | Hnfwd]]]]]. destruct Hfwd as [Hpo [Hcbyx Hnointerv]]. split; auto; split; auto; split; auto; split; auto; split; auto. apply dom_po_in_evts with y; auto. apply ran_po_in_evts with x; auto. destruct Hnfwd as [Hcb Hnoniterv]. split; auto; split; auto; split; auto; split; auto; split; auto; apply Hinc; auto; [left; exists y | right; exists x]; auto. Qed. (*almost the same as cb_rf_incl*) Definition cb_rf_wf (E : set Event) (gcb : Rln Event) := forall r : Event, is_read r -> exists w : Event, cb_rf E gcb w r. Lemma cb_rf_is_wf (E : set Event) (co lob : set Event -> Rln Event) (cb : Rln Event) : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> internal_visibility E co -> external_visibility E co lob -> linearisations (pre_ec E co lob) E cb -> cb_rf_wf E cb. Proof. intros Hrfwf Hcowf Hlobwf Hint_vis Hext_vis Hlin r Hr. unfold gcb_rf. generalize Hrfwf; intro Hrfwf'; destruct_rf_wf Hrfwf'; generalize (Hex_uni r Hr); intros [[w Hrf] Huni]; generalize (lin_ext_prop E (pre_ec E co lob) cb); intros [Himpl _]; generalize (Himpl Hlin); clear Himpl; intros [Hincl Hlso]; exists w; split; [apply dom_rf_is_write with E r | split; [apply ran_rf_is_read with E w | split; [apply rf_implies_same_loc with E | split; [apply rf_implies_same_val with E | ]]]]; auto. assert (E w) as HEw. apply dom_rf_in_evts with r; auto. assert (E r) as HEr. apply ran_rf_in_evts with w; auto. generalize (int_or_ext E w r HEw HEr); intros [Hint | Hext]. Focus 2. assert (cb w r) as Hcbwr. apply Hincl; left; left; split; auto. right; split; auto. (*this should be a lemma*) intros [w' [Hw' [[Hcbww' Hlocww'] [Hcbw'r Hlocw'r]]]]. generalize (cb_co_incl Hcowf Hlin); intro Hcoincl. assert (is_write w) as Hw. apply dom_rf_is_write with E r; auto. assert (co E w w') as Hcoww'. apply Hcoincl; split; auto. assert (fr E co r w') as Hfrrw'. exists w; split; auto. assert (cb r w') as Hcbrw'. apply Hincl; left; right; right; left; auto. destruct_lin Hlso; destruct_part Hpart. generalize (Htrans w' r w' Hcbw'r Hcbrw'); intro Hcy; apply Hirr with w'; auto. (*up to here*) assert (cb w r \/ cb r w) as Hor. destruct_lin Hlso; apply Htot; auto. intro Heq; rewrite Heq in Hrf; apply read_write_contrad with r; [apply ran_rf_is_read with E r | apply dom_rf_is_write with E r]; auto. inversion Hor as [Hcbwr | Hcbrw]; clear Hor; [right|left]; split; auto. (*this should be a lemma*) intros [w' [Hw' [[Hcbww' Hlocww'] [Hcbw'r Hlocw'r]]]]. generalize (cb_co_incl Hcowf Hlin); intro Hcoincl. assert (is_write w) as Hw. apply dom_rf_is_write with E r; auto. assert (co E w w') as Hcoww'. apply Hcoincl; split; auto. assert (fr E co r w') as Hfrrw'. exists w; split; auto. assert (cb r w') as Hcbrw'. apply Hincl; left; right; right; left; auto. destruct_lin Hlso; destruct_part Hpart. generalize (Htrans w' r w' Hcbw'r Hcbrw'); intro Hcy; apply Hirr with w'; auto. (*up to here*) apply rfi_implies_po with co; auto; split; auto. split; auto. intros [w' [Hw' [[Hpoww' Hlocww'] [Hpow'r Hlocw'r]]]]. assert (is_write w) as Hw. apply dom_rf_is_write with E r; auto. assert (co E w w') as Hcoww'. apply posWW_is_coi; auto. assert (fr E co r w') as Hfrrw'. exists w; split; auto. apply Hint_vis; exists w'; apply _trans with r; auto; [right; right; right; split|apply _base]; auto. Qed. Lemma rf_cb_incl (E : set Event) (co lob : set Event -> Rln Event) (cb : Rln Event) : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> internal_visibility E co -> external_visibility E co lob -> linearisations (pre_ec E co lob) E cb -> rel_incl (rf E) (cb_rf E cb). Proof. intros Hrfwf Hcowf Hlobwf Hint_vis Hext_vis Hlin; intros x y Hxy. assert (is_read y) as Hry. apply ran_rf_is_read with E x; auto. generalize (cb_rf_is_wf Hrfwf Hcowf Hlobwf Hint_vis Hext_vis Hlin y Hry); intros [w Hcbrfwy]; generalize (cb_rf_incl Hlin Hcbrfwy); intro Hrfwy; destruct_rf_wf Hrfwf; generalize (Hex_uni y Hry); intros [Hex Huni]; clear Hex_uni; generalize (Huni x w Hxy Hrfwy); intro Heq; rewrite Heq; auto. Qed. Lemma cb_rfeq (E : set Event) (co lob : set Event -> Rln Event) (cb : Rln Event) : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> internal_visibility E co -> external_visibility E co lob -> linearisations (pre_ec E co lob) E cb -> rel_equal (rf E) (cb_rf E cb). Proof. intros Hrfwf Hcowf Hlobwf Hint_vis Hext_vis Hlin; generalize (lin_ext_prop E (pre_ec E co lob) cb); intros [Himpl _]; generalize (Himpl Hlin); clear Himpl; intros [Hincl Hlso]; split. apply rf_cb_incl with co lob; auto. apply cb_rf_incl with co lob; auto. Qed. Lemma external_completion_cb (E : set Event) (co lob : set Event -> Rln Event) (cb : Rln Event) : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> internal_visibility E co -> external_visibility E co lob -> linearisations (pre_ec E co lob) E cb -> external_completion E co lob cb. Proof. intros Hrfwf Hcowf Hlobwf Hint_vis Hext_vis Hlin; split; [|split]; auto. apply cb_is_lin with co; auto. apply cb_rfeq with co lob; auto. apply cb_coeq with lob; auto. Qed. Lemma external_visibility_implies_external_completion (E : set Event) (co lob : set Event -> Rln Event) : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> internal_visibility E co -> external_visibility E co lob -> (exists cb, external_completion E co lob cb). Proof. intros Hrfwf Hcowf Hlobwf Hintv Hextv. generalize (pre_ec_partial_order Hrfwf Hcowf Hlobwf Hintv Hextv); intro Hpart; generalize (order_ext Hpart); intros [cb Hcb]; exists cb. apply external_completion_cb; auto. Qed. (** ** External Visibility <-> External Completion equivalence **) Theorem external_visibility_cb_equivalence (E : set Event) (co lob : set Event -> Rln Event) : rf_well_formed E -> co_well_formed E co -> lob_well_formed E lob -> internal_visibility E co -> (external_visibility E co lob <-> (exists cb, external_completion E co lob cb)). Proof. intros Hrfwf Hcowf Hlobwf Hint_vis. split. apply external_visibility_implies_external_completion; auto. apply external_completion_implies_external_visibility; auto. Qed. herd-herdtools7-1ca343e/herd/libdir/arm.cat000066400000000000000000000013571475314470400206070ustar00rootroot00000000000000ARM (* Model for ARM, ie with po-loc omitted from ppo *) include "cos.cat" (* Uniproc *) acyclic po-loc | rf | fr | co as uniproc (* Atomic *) empty rmw & (fre;coe) as atomic (* Utilities *) let dd = addr | data let rdw = po-loc & (fre;rfe) let detour = po-loc & (coe ; rfe) let addrpo = addr;po (*******) (* ppo *) (*******) include "armfences.cat" (* Initial value *) let ci0 = ctrlisb | detour let ii0 = dd | rfi | rdw let cc0 = dd | ctrl | addrpo (* po-loc deleted *) let ic0 = 0 include "ppo.cat" (**********) (* fences *) (**********) (* ARM *) let WW = W * W let dmb.st=dmb.st & WW let dsb.st=dsb.st & WW (* Common, all arm barriers are strong *) let strong = dmb|dsb|dmb.st|dsb.st|dmb.ish let light = 0 include "ppc-checks.cat" herd-herdtools7-1ca343e/herd/libdir/armfences.cat000066400000000000000000000006651475314470400217740ustar00rootroot00000000000000ARMFences (* Fences *) let dmb.st = try fencerel(DMB.ST) with 0 let dsb.st = try fencerel(DSB.ST) with 0 let dmb = try fencerel(DMB) with 0 let dmb.ish = try fencerel(DMB.ISH) with 0 let dsb = try fencerel(DSB) with 0 let isb = try fencerel(ISB) with 0 show dmb.st,dsb.st,dmb,dsb,dmb.ish (* Dependencies *) show data,addr let ctrlisb = try ctrlcfence(ctrl,ISB) with 0 show ctrlisb show isb \ ctrlisb as isb show ctrl \ ctrlisb as ctrl herd-herdtools7-1ca343e/herd/libdir/armllh.cat000066400000000000000000000014161475314470400213030ustar00rootroot00000000000000"Relaxed ARM llh model" include "filters.cat" (* co with load-load hazards *) include "cosllh.cat" (* Uniproc *) let poi = WW(po-loc) | RW(po-loc) | WR(po-loc) let complus = fr|rf|co|(co;rf)|(fr;rf) irreflexive poi;complus as uniproc (* Utilities *) let dd = addr | data let rdw = po-loc & (fre;rfe) let detour = po-loc & (coe ; rfe) let addrpo = addr;po (*******) (* ppo *) (*******) include "armfences.cat" (* Initial value *) let ci0 = ctrlisb | detour let ii0 = dd | rfi | rdw let cc0 = dd | ctrl | addrpo (* po-loc removed *) let ic0 = 0 include "ppo.cat" (**********) (* fences *) (**********) (* ARM *) let dmb.st=WW(dmb.st) let dsb.st=WW(dsb.st) (* Common, all arm barriers are strong *) let strong = dmb|dsb|dmb.st|dsb.st let light = 0 include "ppc-checks.cat" herd-herdtools7-1ca343e/herd/libdir/asl-pseudo-arch.cat000066400000000000000000000005001475314470400230040ustar00rootroot00000000000000(* Pseudo-architecture to test ASL dependencies *) (* Principle: this peudo-architecture is made to be able to discirminate asl-dependencies in very short litmus tests (in constrast to the full shared aarch64 pseudocode included in an AArch64 litmus test). *) acyclic iico_data | iico_ctrl | rf-reg | rf herd-herdtools7-1ca343e/herd/libdir/asl-pseudocode/000077500000000000000000000000001475314470400222405ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/libdir/asl-pseudocode/Makefile000066400000000000000000000025611475314470400237040ustar00rootroot00000000000000.PHONY: default default: a64 PYTHON := python3 BUNDLER_JOBS := BUNDLER_ARGS := -vv $(BUNDLER_JOBS) BUNDLER := bundler.py BUNDLER_CMD := $(PYTHON) $(BUNDLER) $(BUNDLER_ARGS) BASE_URL := https://developer.arm.com/-/media/developer/products/architecture/armv9-a-architecture/2023-09/ ISA_A64_NAME := ISA_A64_xml_A_profile-2023-09 ISA_A32_NAME := ISA_AArch32_xml_A_profile-2023-09 REGS_NAME := SysReg_xml_A_profile-2023-09 TARGETS := $(ISA_A64_NAME) $(ISA_A32_NAME) $(REGS_NAME) TARGETS_TAR_GZ := $(addsuffix .tar.gz,$(TARGETS)) TARGETS_LOG := $(addsuffix .log,$(TARGETS)) # .SECONDARY does not support wildcards .SECONDARY: $(TARGETS_TAR_GZ) $(TARGETS) $(TARGETS_TAR_GZ): @ echo "Downloading ISA from developer.arm.com ..." curl $(BASE_URL)/$@ --silent --output $@ $(TARGETS): %: | %.tar.gz @ echo "Unpacking xml archive ..." @ tar -zxf $*.tar.gz $* $(TARGETS_LOG): %.log: | % @ echo "Copying proprietary notice ..." @ cp $*/xhtml/notice.html . @ echo "Extracting ASL pseudocode from xml files ..." @ $(BUNDLER_CMD) -o $(@D) --log-file $@ $* @ echo "You can find extraction log at $@" .PHONY: a64 a32 regs a64: $(ISA_A64_NAME).log a32: $(ISA_A32_NAME).log regs: $(REGS_NAME).log .PHONY: all all: a64 a32 regs .PHONY: clean-tmp clean-tmp: @ rm -fr $(TARGETS) $(TARGETS_TAR_GZ) .PHONY: clean clean: clean-tmp rm -fr aarch64 shared_pseudocode.asl other-instrs $(TARGETS_LOG) herd-herdtools7-1ca343e/herd/libdir/asl-pseudocode/bundler.py000066400000000000000000000360161475314470400242530ustar00rootroot00000000000000"""Process ISA XML files into raw asl files. Working assumptions: - for any xml file, the o_path as built by `o_path_of_tree` uniquely identifies the pseudocode in the xml file. - no other program concurrently modifies our output files """ import argparse from concurrent.futures import ThreadPoolExecutor, as_completed from datetime import datetime import itertools import logging from pathlib import Path import re from typing import List, Optional, Iterable import textwrap from xml.etree.ElementTree import Element, parse # In this whole module, path names used as input (resp. output) are prefixed with `i_` (resp. `o_`). _logger = logging.getLogger("bundler0") _last_run_start = datetime.now() MESSAGE_ON_TOP = """ // Copyright (c) 2010-2022 Arm Limited or its affiliates. All rights reserved. // This document is Non-Confidential. This document may only be used and // distributed in accordance with the terms of the agreement entered into by // Arm and the party that Arm delivered this document to. // More information can be found in notice.html or // https://developer.arm.com/documentation/ddi0602/latest/Proprietary-Notice // This document was automatically extracted from the XML files distributed at // https://developer.arm.com/downloads/-/exploration-tools // by a script authored by Hadrien Renaud and // available at bundler.py or // https://github.com/herd/herdtools7/blob/master/herd/libdir/asl-pseudocode/bundler.py """ DEFAULT_INSTR_DIR = Path("other-instrs") SEPARATOR_LINE = ( "// =============================================================================" ) RE_IDENTIFIER_WITH_SLICES = re.compile( r"(?P[a-zA-Z_]\w*)<(?P\d|(\d+:\d+))>" ) def o_path_of_tree(root: Element, o_dir: Path) -> Path: """Constructs and checks the writing file corresponding to this tree.""" root_type = root.get("type") if root_type == "instruction": ps_name = root.find("ps_section").find("ps").get("name") file_name = Path(ps_name + ".opn") if not ps_name.startswith("aarch"): _logger.debug("Moving file %s to %s", ps_name, DEFAULT_INSTR_DIR) file_name = DEFAULT_INSTR_DIR / file_name o_path = o_dir / file_name o_path.parent.mkdir(parents=True, exist_ok=True) else: if root_type != "pseudocode": _logger.warning("Unknown root type %s", root_type) o_path = o_dir / (root.get("id").lower() + ".asl") if ( o_path.exists() and datetime.fromtimestamp(o_path.stat().st_mtime) < _last_run_start ): # We consider that if it has been modified after `_last_run_start`, # then it is this program that edited it, and so we are overriding our # own results. The underlying assumption is that 2 different xml files # that have the same o_path have the same pseudocode. _logger.warning("Overriding %s", o_path) return o_path def header_of_tree(root: Element, o_path: Path) -> str: """Find a nice title for the written file.""" root_type = root.get("type") titles = [root.get("title")] post_header = [] if root_type == "instruction": if o_path.exists(): with o_path.open(mode="r") as f: for line in f.readlines(): if line.startswith("// =="): break if line.startswith("// "): titles.append(line[2:].strip()) titles = sorted(frozenset(titles)) post_header.append("// Execute") post_header.append("// =======") post_header.append("") return "\n".join( ( *(f"// {i:^74}" for i in titles), SEPARATOR_LINE, "", MESSAGE_ON_TOP, *post_header, "", ) ) def asl_for_instruction_fields(regdiagram, instr_id) -> [str]: """Reads the xml for an instruction and constructs the ASL from it's tabular representation of the instruction binary encoding""" result = {} for box in regdiagram.findall("./box"): name = box.get("name") if name is None: continue hibit = box.get("hibit") width = box.get("width") pos = hibit if width is None else f"{hibit} : ({hibit} - {width} + 1)" name = name.strip() if name.isidentifier(): # Normal case if name not in result: result[name] = pos continue # Otherwise we fall back to the slicing case, with an implicit slice _logger.debug ("Instruction %s: Adding implicit slice to field %s", instr_id, name) if width is None: name = name + "<0>" else: name = f"{name}<{width}:0>" regex_match = RE_IDENTIFIER_WITH_SLICES.fullmatch(name) if regex_match is None: _logger.warning("Instruction %s: Ignoring uncompatible field name '%s'", instr_id, name) continue name = regex_match.group("id") prevs = result.get(name, []) if isinstance(prevs, str): _logger.debug("Instruction %s: adding implicit slice to field %s", instr_id, name) prevs = [(("0", "0"), prevs)] raw_slices = regex_match.group("slices") if ":" in raw_slices: hi, lo = raw_slices.split(":") slices = (hi, lo) else: slices = (raw_slices, raw_slices) _logger.debug("Adding for field '%s' slices %s for position %s", name, slices, pos) prevs.append((slices, pos)) result[name] = prevs for name, pos in result.items(): if isinstance(pos, str): continue pos.sort(reverse=True) result[name] = ", ".join((pos for (_slices, pos) in pos)) _logger.debug("Constructed for attr '%s' positions: %s.", name, result[name]) return [f"let {name} = instruction[{pos}];" for (name, pos) in result.items()] def read_text_in_node(root, path, warn=True) -> str: """Reads all the text at that path""" nodes = root.findall(path) if len(nodes) == 0: if warn: _logger.warning("Could not find node at %s", path) return "" if len(nodes) >= 2 and warn: _logger.warning("Too many nodes matching path %s", path) return "".join(nodes[0].itertext()).strip() def read_text_in_nodes(root, path) -> [str]: """Reads all the texts in the nodes matching that path.""" return ["".join(n.itertext()) for n in root.findall(path)] def read_execute(root) -> str: """Read 'Execute' section of the xml tree of an instruction.""" return read_text_in_node(root, ".//ps_section/ps/pstext[@section='Execute']") def make_body(from_bin: str, decode: str, post_decode: str, execute: str) -> str: """Build the body of an ASL function.""" if len(post_decode) == 0: post_decode = ("// No post decode",) else: post_decode = ( "// beginning of post decode section", post_decode, "// end of post decode section", ) return "\n".join( ( "// beginning of binary unpacking", *from_bin, "// end of binary unpacking", "", "// beginning of decode section", decode, "// end of decode section", "", *post_decode, "", "// beginning of execute section", execute, "// end of execute section", ) ) def make_function(name: str, body: str) -> Iterable[str]: """Build an ASL function from a body as an ASL statement and a name. The function takes an argument 'instruction' which is of type 'bits(32)'. It does not return anything. """ return "\n".join( ( f"func {name} (instruction: bits(32))", "begin", textwrap.indent(body, " "), "end", "", ) ) def read_one_encoding( instr_id: str, iclass: Element, post_decode: str, execute: str, add_encoding_id=True, ) -> str: """Construct an ASL function from one encoding class of an instruction.""" from_bin = asl_for_instruction_fields(iclass.find("./regdiagram"), instr_id) decode = read_text_in_node(iclass, "./ps_section") body = make_body(from_bin, decode, post_decode, execute) encoding_id = "_" + iclass.get("id") if add_encoding_id else "" fname = "instr_" + instr_id + encoding_id return make_function(fname, body) def one_instruction_to_string(i_path: Path) -> str: """Process one instruction, write the decode and write it to output directory""" _logger.info("Processing %s", i_path) root = parse(i_path).getroot() if root.tag != "instructionsection": _logger.error("Cannot interpret file %s -- Skipping.", i_path) return "" root_type = root.get("type") if root_type == "pseudocode": _logger.info("Skipping shared pseudocode at %s", i_path) return "" if root_type == "alias": _logger.info("Skipping alias at %s.", i_path) return "" if root_type != "instruction": _logger.warning("Unknown xml type at %s -- Skipping", i_path) return "" execute = read_execute(root) post_decode = read_text_in_node( root, ".//ps_section/ps/pstext[@section='Postdecode']", warn=False ) instr_id = i_path.stem instruction_name = root.get( "title", default="Instruction without a name (could not parse it from the xml)" ) iclasses = root.findall("./classes/iclass") add_encoding_id = len(iclasses) > 1 return "\n".join( ( SEPARATOR_LINE, f"// {instruction_name}", SEPARATOR_LINE, "", *( read_one_encoding( instr_id, iclass, post_decode, execute, add_encoding_id ) for iclass in iclasses ), "", "", ) ) def process_one_file(i_file: Path, o_dir: Path): """Process one file and write it to output directory.""" _logger.info("Processing %s", i_file) root = parse(i_file).getroot() if root.tag != "instructionsection": _logger.error("Cannot interpret file %s -- Skipping.", i_file) return if root.get("type") == "alias": _logger.info("Skipping alias at %s.", i_file) return o_path = o_path_of_tree(root, o_dir) _logger.info("Writing to %s", o_path) header = header_of_tree(root, o_path) with o_path.open("w") as f: f.write(header) for ps in root.findall("./ps_section/ps"): sect_type = ps.get("secttype") if sect_type not in ("Library", "Operation"): continue _logger.debug("Writing section %s", ps.get("name")) f.writelines(ps.find("pstext").itertext()) f.write("\n\n") _logger.debug("Processed %s", i_file) def get_all_paths(paths: Iterable[Path]) -> List[Path]: """Expand all "*.xml" paths inside this list.""" i_files = [] # type: List[Path] for f in paths: f = f.expanduser() if f.is_dir(): _logger.info("Extending directory %s", f) i_files.extend(f.glob("*.xml")) elif f.exists(): i_files.append(f) else: _logger.warning("Ignoring %s", f) return i_files def mkdirp(o_dir: Path): """Creates directory o_dir if it does not exists.""" if not o_dir.exists(): _logger.info("Output dir does not exist. Creating it.") _logger.debug("mkdir %s", o_dir) o_dir.mkdir(exist_ok=True, parents=True) elif not o_dir.is_dir(): _logger.error("Output option is not a directory. Might break later.") def configure_logger(quiet, verbose, log_file): """Configure the logging infrastructure in function of 3 parameters.""" if quiet: log_level = logging.CRITICAL else: log_level = { 0: logging.ERROR, 1: logging.WARNING, 2: logging.INFO, 3: logging.DEBUG, }.get(verbose, logging.DEBUG) if log_file is None: logging.basicConfig(level=log_level) else: logging.basicConfig(filename=log_file, filemode="w", level=log_level) def get_args() -> (List[Path], Path, Optional[int]): """Process arguments.""" parser = argparse.ArgumentParser( description="Process ISA XML files into raw asl files." ) parser.add_argument( "-o", "--output", action="store", type=Path, default=Path.cwd() / "asl-pseudocode", help="The directory where all pseudocode should be written to.", ) parser.add_argument( "paths", metavar="PATH", type=Path, nargs="+", help="The different paths to parse. If this is a directory, this will (non-recursively) " "parse all files inside the directory that have the '.xml' extension.", ) logger_group = parser.add_mutually_exclusive_group() logger_group.add_argument( "-v", "--verbose", action="count", default=0, help="Logger level. Can be repeated.", ) logger_group.add_argument( "-q", "--quiet", action="store_true", help="Only report critical errors." ) parser.add_argument( "--log-file", action="store", help="Where to write parsing logs. Default to stderr.", ) parser.add_argument( "-j", "--jobs", action="store", type=int, help="Parallelization on parsing and writing jobs. Default to python's ThreadPoolExecutor" "default, which should be `min(32, cpu_count)`", ) parser.add_argument( "-m", "--make-functions", action="store_true", help="Make function and not opns.", ) args = parser.parse_args() configure_logger(args.quiet, args.verbose, args.log_file) i_files = get_all_paths(args.paths) o_dir = args.output.absolute() mkdirp(o_dir) jobs = args.jobs if jobs is None: _logger.info("Starting process with default number of parallel workers.") else: _logger.info("Starting process with %d workers.", jobs) make_functions = args.make_functions return i_files, o_dir, jobs, make_functions def main(): """Main entry point.""" (i_files, o_dir, jobs, make_functions) = get_args() with ThreadPoolExecutor(max_workers=jobs) as executor: if make_functions: future_strings = ( executor.submit(one_instruction_to_string, i_file) for i_file in i_files ) o_file = o_dir / "instructions.asl" with open(o_file, "w", encoding="utf8") as f: f.write(MESSAGE_ON_TOP) for future_string in as_completed(future_strings): f.write(future_string.result()) else: executor.map( process_one_file, i_files, itertools.repeat(o_dir, len(i_files)) ) if __name__ == "__main__": _last_run_start = datetime.now() main() herd-herdtools7-1ca343e/herd/libdir/asl-pseudocode/implementations.asl000066400000000000000000000333041475314470400261540ustar00rootroot00000000000000/* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause */ /* implementations.asl ------------------- This file is a list of implementations for use in herd of functions left non- -implemented in the ARM Reference Manual. We copy the explanations from it. The ARM Reference Manual is available here: https://developer.arm.com/documentation/ddi0602/2023-09/ The first two type declarations have been extracted from the ARM Reference manual with a regex search. We suppose that they are enough for our experiments. The rest of the file are hand-written implementations: they are mostly the smallest AST that would type-check, but sometimes also call some logic relative to herd primitives. */ // ============================================================================= /* Got with the following command line in the ARM Reference Manual XML Download folder: rg '.*(FEAT_\w+).*' --replace ' $1,' --no-line-number --no-filename | sort | uniq */ type Feature of enumeration { FEAT_AA32EL0, FEAT_AA32EL1, FEAT_AA32EL2, FEAT_AA32EL3, FEAT_AA32HPD, FEAT_AA64EL1, FEAT_AA64EL3, FEAT_ABLE, FEAT_AES, FEAT_AFP, FEAT_AIE, FEAT_ASID2, FEAT_ASMv8p2, FEAT_ATS1A, FEAT_BBM, FEAT_BF16, FEAT_BRBE, FEAT_BRBEv1p1, FEAT_BTI, FEAT_BWE, FEAT_BWE2, FEAT_CHK, FEAT_CLRBHB, FEAT_CMOW, FEAT_CNTSC, FEAT_CONSTPACFIELD, FEAT_CPA, FEAT_CPA2, FEAT_CRC32, FEAT_CSSC, FEAT_D128, FEAT_DGH, FEAT_DIT, FEAT_DPB, FEAT_DPB2, FEAT_Debugv8p2, FEAT_Debugv8p4, FEAT_Debugv8p8, FEAT_Debugv8p9, FEAT_DoPD, FEAT_DotProd, FEAT_DoubleFault, FEAT_DoubleFault2, FEAT_DoubleLock, FEAT_E0PD, FEAT_E2H0, FEAT_EBEP, FEAT_EBF16, FEAT_ECV, FEAT_EDHSR, FEAT_EPAC, FEAT_ExS, FEAT_F32MM, FEAT_F64MM, FEAT_FAMINMAX, FEAT_FCMA, FEAT_FGT, FEAT_FGT2, FEAT_FHM, FEAT_FP16, FEAT_FP8, FEAT_FP8DOT2, FEAT_FP8DOT4, FEAT_FP8FMA, FEAT_FPAC, FEAT_FPACCOMBINE, FEAT_FPMR, FEAT_FRINTTS, FEAT_FlagM, FEAT_FlagM2, FEAT_GCS, FEAT_GTG, FEAT_HAFDBS, FEAT_HAFT, FEAT_HBC, FEAT_HCX, FEAT_HDBSS, FEAT_HF_hints, FEAT_HPDS, FEAT_HPMN0, FEAT_I8MM, FEAT_IESB, FEAT_ITE, FEAT_JSCVT, FEAT_LOR, FEAT_LPA, FEAT_LPA2, FEAT_LRCPC, FEAT_LRCPC2, FEAT_LRCPC3, FEAT_LS64, FEAT_LS64_ACCDATA, FEAT_LS64_V, FEAT_LSE, FEAT_LSE128, FEAT_LSE2, FEAT_LSMAOC, FEAT_LUT, FEAT_LVA, FEAT_LVA3, FEAT_MEC, FEAT_MOPS, FEAT_MPAM, FEAT_MPAMv0p1, FEAT_MPAMv1p1, FEAT_MTE, FEAT_MTE2, FEAT_MTE4, FEAT_MTE_ASYM_FAULT, FEAT_MTE_ASYNC, FEAT_MTE_CANONICAL_TAGS, FEAT_MTE_PERM, FEAT_MTE_STORE_ONLY, FEAT_NMI, FEAT_NV, FEAT_NV2, FEAT_PACIMP, FEAT_PACQARMA3, FEAT_PACQARMA5, FEAT_PAN, FEAT_PAN2, FEAT_PAN3, FEAT_PAuth, FEAT_PAuth2, FEAT_PAuth_LR, FEAT_PCSRv8p9, FEAT_PFAR, FEAT_PMULL, FEAT_PMUv3, FEAT_PMUv3_EDGE, FEAT_PMUv3_ICNTR, FEAT_PMUv3_SME, FEAT_PMUv3_SS, FEAT_PMUv3_TH, FEAT_PMUv3_TH2, FEAT_PMUv3p1, FEAT_PMUv3p5, FEAT_PMUv3p7, FEAT_PMUv3p9, FEAT_PRFMSLC, FEAT_RAS, FEAT_RASv2, FEAT_RDM, FEAT_RME, FEAT_RME_GPC2, FEAT_RPRES, FEAT_RPRFM, FEAT_S1PIE, FEAT_S1POE, FEAT_S2FWB, FEAT_S2PIE, FEAT_S2POE, FEAT_SB, FEAT_SCTLR2, FEAT_SEBEP, FEAT_SEL2, FEAT_SHA1, FEAT_SHA256, FEAT_SHA3, FEAT_SHA512, FEAT_SM3, FEAT_SM4, FEAT_SME, FEAT_SME2, FEAT_SME2p1, FEAT_SME_F16F16, FEAT_SME_F64F64, FEAT_SME_F8F16, FEAT_SME_F8F32, FEAT_SME_FA64, FEAT_SME_I16I64, FEAT_SME_LUTv2, FEAT_SPE, FEAT_SPECRES, FEAT_SPECRES2, FEAT_SPE_DPFZS, FEAT_SPE_FDS, FEAT_SPEv1p1, FEAT_SPEv1p2, FEAT_SPEv1p4, FEAT_SSBS, FEAT_SSVE_FP8DOT2, FEAT_SSVE_FP8DOT4, FEAT_SSVE_FP8FMA, FEAT_STEP2, FEAT_SVE, FEAT_SVE2, FEAT_SVE2p1, FEAT_SVE_AES, FEAT_SVE_B16B16, FEAT_SVE_BitPerm, FEAT_SVE_PMULL128, FEAT_SVE_SHA3, FEAT_SVE_SM4, FEAT_SYSINSTR128, FEAT_SYSREG128, FEAT_TCR2, FEAT_THE, FEAT_TIDCP1, FEAT_TLBIOS, FEAT_TLBIRANGE, FEAT_TLBIW, FEAT_TME, FEAT_TRBE, FEAT_TRBE_EXT, FEAT_TRF, FEAT_TTCNP, FEAT_TTL, FEAT_TTST, FEAT_TWED, FEAT_UAO, FEAT_VHE, FEAT_VMID16, FEAT_WFxT, FEAT_XNX, FEAT_XS, }; // ============================================================================= /* Got with the following command line in the ARM Reference Manual XML Download folder: rg '.*SCTLR2?_EL[x012](\[\])?\.(\w+).*' --replace '$2' -I -N | sort | uniq | nl | sed 's/\([[:digit:]]*\)\t\([[:alnum:]]*\)/[\1] \2,/' */ type SCTLRType of bits(64) { [1] A, [2] ATA, [3] C, [4] CMOW, [5] CPTA, [6] CPTM, [7] EASE, [8] EE, [9] EMEC, [10] EPAN, [11] EnALS, [12] EnAS0, [13] EnASR, [14] EnDA, [15] EnDB, [16] EnFPM, [17] EnIA, [18] EnIB, [19] EnPACM, [20] EnPACM0, [21] I, [22] IESB, [23] ITD, [24] M, [25] MSCEn, [26] NMEA, [27] SED, [28] SPAN, [29] TCF, [30] TCSO, [31] TCSO0, [32] TIDCP, [33] TME, [34] TME0, [35] TMT, [36] TMT0, [37] TWEDEL, [38] TWEDEn, [39] UMA, [40] WXN, [41] nTLSMD, [42] read, }; // ============================================================================= // MarkExclusiveGlobal() // ===================== // Record the physical address region of size bytes starting at paddress in // the global Exclusives monitor for processorid. func MarkExclusiveGlobal (paddress : FullAddress, processorid : integer, size : integer) begin return; end; // ============================================================================= // MarkExclusiveLocal() // ==================== // Record the physical address region of size bytes starting at paddress in // the local Exclusives monitor for processorid. func MarkExclusiveLocal (paddress : FullAddress, processorid : integer, size : integer) begin return; end; // ============================================================================= // AArch64.MarkExclusiveVA() // ========================= // Optionally record an exclusive access to the virtual address region of size bytes // starting at address for processorid. var RESADDR : bits(64); func AArch64_MarkExclusiveVA (address : bits(64), processorid : integer, size : integer) begin RESADDR = address; end; // ============================================================================= // AArch64.IsExclusiveVA() // ======================= // An optional IMPLEMENTATION DEFINED test for an exclusive access to a virtual // address region of size bytes starting at address. // // It is permitted (but not required) for this function to return FALSE and // cause a store exclusive to fail if the virtual address region is not // totally included within the region recorded by MarkExclusiveVA(). // // It is always safe to return TRUE which will check the physical address only. var SuccessVA : boolean ; func AArch64_IsExclusiveVA (address : bits(64), processorid : integer, size : integer) => boolean begin // Try both possibilties: write or not write SuccessVA = SomeBoolean(); // Read RESADDR localy because we want a read event in all cases. let reserved = RESADDR; // If write succeeds then effective address and reservation coincide. if SuccessVA then CheckProp(address == reserved); end; return SuccessVA; end; // ============================================================================= // ExclusiveMonitorsStatus() // ========================= // Returns '0' to indicate success if the last memory write by this PE was to // the same physical address region endorsed by ExclusiveMonitorsPass(). // Returns '1' to indicate failure if address translation resulted in a different // physical address. func ExclusiveMonitorsStatus() => bit begin return if SuccessVA then '0' else '1'; end; // ============================================================================= // IsExclusiveLocal() // ================== // Return TRUE if the local Exclusives monitor for processorid includes all of // the physical address region of size bytes starting at paddress. func IsExclusiveLocal (paddress : FullAddres, processorid : integer, size : integer) => boolean begin return TRUE; end; // ============================================================================= // IsExclusiveGlobal() // =================== // Return TRUE if the global Exclusives monitor for processorid includes all of // the physical address region of size bytes starting at paddress. func IsExclusiveGlobal (paddress : FullAddres, processorid : integer, size : integer) => boolean begin return TRUE; end; // ============================================================================= // ClearExclusiveLocal() // ===================== // Clear the local Exclusives monitor for the specified processorid. func ClearExclusiveLocal(processorid : integer) begin return; end; // ============================================================================= func ConstrainUnpredictableBool(which:Unpredictable) => boolean begin return ARBITRARY: boolean; end; // ============================================================================= // ============================================================================= func IsFeatureImplemented(f : Feature) => boolean begin return FALSE; end; // ============================================================================= func PhysMemWrite{N}( desc:AddressDescriptor, accdesc:AccessDescriptor, value:bits(8*N) ) => PhysMemRetStatus begin write_memory_gen {N*8}(desc.vaddress, value,accdesc); return PhysMemRetStatus { statuscode = Fault_None, extflag = '0', merrorstate = ErrorState_CE, // ?? store64bstatus = Zeros{64} }; end; // ============================================================================= func PhysMemRead{N}( desc:AddressDescriptor, accdesc:AccessDescriptor ) => (PhysMemRetStatus, bits(8*N)) begin let value = read_memory_gen {N*8}(desc.vaddress,accdesc); let ret_status = PhysMemRetStatus { statuscode = Fault_None, extflag = '0', merrorstate = ErrorState_CE, // ?? store64bstatus = Zeros{64} }; return (ret_status, value); end; // ============================================================================= func HaveAArch32() => boolean begin return FALSE; end; // ============================================================================= func HaveAArch64() => boolean begin return TRUE; end; // ============================================================================= // HaveEL() // ======== // Return TRUE if Exception level 'el' is supported func HaveEL(el: bits(2)) => boolean begin if el IN {EL1,EL0} then return TRUE; // EL1 and EL0 must exist else return FALSE; // boolean IMPLEMENTATION_DEFINED; end; end; // ============================================================================= // ClearExclusiveByAddress() // ========================= // Clear the global Exclusives monitors for all PEs EXCEPT processorid if they // record any part of the physical address region of size bytes starting at paddress. // It is IMPLEMENTATION DEFINED whether the global Exclusives monitor for processorid // is also cleared if it records any part of the address region. func ClearExclusiveByAddress(paddress : FullAddress, processorid : integer, size : integer) begin pass; end; // ============================================================================= getter _R (n : integer) => bits(64) begin return read_register(n); end; setter _R (n : integer) = value : bits(64) begin write_register(n, value); end; // ============================================================================= getter SCTLR_EL1() => SCTLRType begin return Zeros{64}; end; // ============================================================================= // InstructionSynchronizationBarrier() // =================================== func InstructionSynchronizationBarrier() begin primitive_isb(); end; // ============================================================================= // DataMemoryBarrier() // =================== // We use our own integer codings of enumerations // to guard against enumeration type change func MBReqDomainToInteger(domain : MBReqDomain) => integer begin case domain of when MBReqDomain_Nonshareable => return 0; when MBReqDomain_InnerShareable => return 1; when MBReqDomain_OuterShareable => return 2; when MBReqDomain_FullSystem => return 3; end; end; func MBReqTypesToInteger(types : MBReqTypes) => integer begin case types of when MBReqTypes_Reads => return 0; when MBReqTypes_Writes => return 1; when MBReqTypes_All => return 2; end; end; func DataMemoryBarrier(domain : MBReqDomain, types : MBReqTypes) begin primitive_dmb(MBReqDomainToInteger(domain),MBReqTypesToInteger(types)); end; // DataSynchronizationBarrier() // ============================ func DataSynchronizationBarrier (domain : MBReqDomain, types : MBReqTypes, nXS : boolean) begin primitive_dsb(MBReqDomainToInteger(domain),MBReqTypesToInteger(types)); end; // ============================================================================= // Hint_Branch() // ============= // Report the hint passed to BranchTo() and BranchToAddr(), for consideration when processing // the next instruction. func Hint_Branch(hint : BranchType) begin return; end; herd-herdtools7-1ca343e/herd/libdir/asl-pseudocode/implementations0.asl000066400000000000000000000026231475314470400262340ustar00rootroot00000000000000/* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause */ /* implementations0.asl ------------------- This file contains two ASL0 implementations which cannot be found in the ARM Reference Manual, but are required for use in herd. In particular, they interface with herd primitives. They cannot be implemented in ASL1, as ASL1 now forbids getters/setters without any arguments. The ARM Reference Manual is available here: https://developer.arm.com/documentation/ddi0602/2023-09/ */ // ============================================================================= bits(64) _PC return read_pc(); _PC = bits(64) value write_pc(value); return; // ============================================================================= // Wrapper to the V1 function PhysMemRetStatus PhysMemWrite(AddressDescriptor desc, integer size, AccessDescriptor accdesc, bits(8*size) value) return PhysMemWrite{size}(desc,accdesc,value); // ============================================================================= // Wrapper to the V1 function (PhysMemRetStatus, bits(8*size)) PhysMemRead(AddressDescriptor desc, integer size, AccessDescriptor accdesc) (ret_status,value) = PhysMemRead{size}(desc,accdesc); return (ret_status,value); herd-herdtools7-1ca343e/herd/libdir/asl-pseudocode/patches.asl000066400000000000000000000211611475314470400243710ustar00rootroot00000000000000/* * SPDX-FileCopyrightText: Copyright 2022-2023 Arm Limited and/or its affiliates * SPDX-License-Identifier: BSD-3-Clause */ /* patches.asl ----------- This file is a list of re-implementations of ASL functions from the ARM Reference Manual. They are completely re-written or simply edited by hand. When re-written completely, this is often time the minimal code that type-checks. The code is also translated from ASLv0 to ASLv1 by hand. The ARM Reference Manual is available here: https://developer.arm.com/documentation/ddi0602/2023-09/ */ // ============================================================================= // GenMPAMatEL() // ============= // Returns MPAMinfo for the specified EL. // May be called if MPAM is not implemented (but in an version that supports // MPAM), MPAM is disabled, or in AArch32. In AArch32, convert the mode to // EL if can and use that to drive MPAM information generation. If mode // cannot be converted, MPAM is not implemented, or MPAM is disabled return // default MPAM information for the current security state. // From https://developer.arm.com/documentation/ddi0602/2023-09/Shared-Pseudocode/shared-functions-mpam?lang=en#impl-shared.GenMPAMatEL.2 // The whole logic is too complex for our simple use, so we return the base value of the return type. // MPAMinfo GenMPAMatEL(AccessType acctype, bits(2) el) func GenMPAMatEL(acctype: AccessType, el:bits(2)) => MPAMinfo begin var x : MPAMinfo; return x; end; // ============================================================================= // IsAligned() // =========== // From https://developer.arm.com/documentation/ddi0602/2023-09/Shared-Pseudocode/shared-functions-common?lang=en#impl-shared.IsAligned.2 // We disable alignment checks. func IsAligned{N}(x : bits(N), y:integer) => boolean begin return TRUE; end; func IsAligned(x:integer, y:integer) => boolean begin return TRUE; end; // ============================================================================= // BigEndian() // =========== // From https://developer.arm.com/documentation/ddi0602/2023-09/Shared-Pseudocode/shared-functions-memory?lang=en#impl-shared.BigEndian.1 // We only use small-endian func BigEndian(acctype: AccessType) => boolean begin return FALSE; end; // ============================================================================= // IsFault() // ========= // Return TRUE if a fault is associated with an address descriptor // From https://developer.arm.com/documentation/ddi0602/2023-09/Shared-Pseudocode/shared-functions-aborts?lang=en#impl-shared.IsFault.1 // No fault is ever constructed with the associated address descriptors. func IsFault(addrdesc: AddressDescriptor) => boolean begin return FALSE; end; // ============================================================================= // AArch64.TranslateAddress() // ========================== // Main entry point for translating an address // From https://developer.arm.com/documentation/ddi0602/2023-09/Shared-Pseudocode/aarch64-translation-vmsa-translation?lang=en#AArch64.TranslateAddress.4 // We disable address translation func AArch64_TranslateAddress(address:bits(64), accdesc:AccessDescriptor, aligned:boolean, size:integer) => AddressDescriptor begin var full_addr : FullAddress; return CreateAddressDescriptor(address, full_addr, NormalNCMemAttr()); end; // ============================================================================= // ELStateUsingAArch32K() // ====================== // Returns (known, aarch32): // 'known' is FALSE for EL0 if the current Exception level is not EL0 and EL1 is // using AArch64, since it cannot determine the state of EL0; TRUE otherwise. // 'aarch32' is TRUE if the specified Exception level is using AArch32; FALSE otherwise. // From https://developer.arm.com/documentation/ddi0602/2023-09/Shared-Pseudocode/shared-functions-system?lang=en#impl-shared.ELStateUsingAArch32K.2 // We are always on AArch64 func ELStateUsingAArch32K(el:bits(2), secure:boolean) => (boolean, boolean) begin return (TRUE, FALSE); end; // ============================================================================= // ProcState // ========= // Armv8 processor state bits. // There is no significance to the field order. // From https://developer.arm.com/documentation/ddi0602/2023-09/Shared-Pseudocode/shared-functions-system?lang=en#ProcState // Rewritten from record to bitfields type ProcState of bits(64) { [3] N, // Negative condition flag [2] Z, // Zero condition flag [1] C, // Carry condition flag [0] V, // Overflow condition flag [4] D, // Debug mask bit [AArch64 only] [5] A, // SError interrupt mask bit [6] I, // IRQ mask bit [7] F, // FIQ mask bit [8] EXLOCK, // Lock exception return state [9] PAN, // Privileged Access Never Bit [v8.1] [10] UAO, // User Access Override [v8.2] [11] DIT, // Data Independent Timing [v8.4] [12] TCO, // Tag Check Override [v8.5, AArch64 only] [13] PM, // PMU exception Mask [14] PPEND, // synchronous PMU exception to be_observed [16:15] BTYPE, // Branch Type [v8.5] [17] ZA, // Accumulation array enabled [SME] [18] SM, // Streaming SVE mode enabled [SME] [19] ALLINT, // Interrupt mask bit [20] SS, // Software step bit [21] IL, // Illegal Execution state bit [23:22] EL, // Exception level [24] nRW, // Execution state: 0=AArch64, 1=AArch32 [25] SP, // Stack pointer select: 0=SP0, 1=SPx [AArch64 only] [26] Q, // Cumulative saturation flag [AArch32 only] [30:27] GE, // Greater than or Equal flags [AArch32 only] [31] SSBS, // Speculative Store Bypass Safe [39:32] IT, // If-then bits, RES0 in CPSR [AArch32 only] [40] J, // J bit, RES0 [AArch32 only, RES0 in SPSR and CPSR] [41] T, // T32 bit, RES0 in CPSR [AArch32 only] [42] E, // Endianness bit [AArch32 only] [47:42] M // Mode field [AArch32 only] }; // ============================================================================= // From https://developer.arm.com/documentation/ddi0602/2023-09/Shared-Pseudocode/shared-functions-system?lang=en#PSTATE // Not really modified var PSTATE : ProcState; // ============================================================================= // GenerateAddress() // ================= // Generate and address by adding a pointer with an offset and returning the result. // If FEAT_CPA2 is implemented, the pointer arithmetic is checked. // From https://developer.arm.com/documentation/ddi0602/2023-09/Shared-Pseudocode/shared-functions-system?lang=en#impl-shared.GenerateAddress.3 // We don't want the checked pointer arithmetic. // LUC simplify because failure of slice operatin on symbolic address. func GenerateAddress(base:bits(64), offset:bits(64), accdesc:AccessDescriptor) => bits(64) begin return base + offset; end; // ============================================================================= // AArch64.BranchAddr() // ==================== // Return the virtual address with tag bits removed. // This is typically used when the address will be stored to the program counter. // From https://developer.arm.com/documentation/ddi0602/2023-09/Shared-Pseudocode/shared-functions-memory?lang=en // We don't do that here, we want to keep the address "as is". func AArch64_BranchAddr (vaddress:bits(64), el:bits(2)) => bits(64) begin return vaddress; end; // ============================================================================= // BranchNotTaken() // ================ // Called when a branch is not taken. // Patched to add PC self assignment // From https://developer.arm.com/documentation/ddi0602/2023-09/Shared-Pseudocode/shared-trace-tracebranch?lang=en // We add the increment to _PC func BranchNotTaken(branchtype:BranchType, branch_conditional:boolean) begin _PC() = _PC()+4; let branchtaken = FALSE; if IsFeatureImplemented(FEAT_SPE) then SPEBranch{64} (ARBITRARY:bits(64), branchtype, branch_conditional, branchtaken); end; return; end; // ============================================================================= // UsingAArch32() // ============== // Return TRUE if the current Exception level is using AArch32, FALSE if using AArch64. // Let us return FALSE, called by BranchTo(...) for checking tgt address size. func UsingAArch32() => boolean begin return FALSE; end; herd-herdtools7-1ca343e/herd/libdir/asl-pseudocode/pstate-exp.asl000066400000000000000000000031401475314470400250310ustar00rootroot00000000000000// Experimental implementation of PSTATE as two independant variables. var _PSTATE : ProcState; var _NZCV : ProcState; func isNZCV(n:integer) => boolean begin return 0 <= n && n < 4 ; end; getter PSTATE() => ProcState begin return _PSTATE; end; setter PSTATE() = v : ProcState begin _PSTATE = v; end; getter PSTATE(n:integer) => bits(1) begin if isNZCV(n) then return _NZCV[n]; else return _PSTATE[n]; end; end; setter PSTATE(n:integer) = v : bits(1) begin if isNZCV(n) then _NZCV[n] = v; else _PSTATE[n] = v; end; end; getter PSTATE(n:integer,m:integer) => bits(2) begin if isNZCV(n) && isNZCV(m) then return _NZCV[n,m]; else return _PSTATE[n,m]; end; end; setter PSTATE(n:integer,m:integer) = v : bits(2) begin if isNZCV(n) && isNZCV(m) then _NZCV[n,m] = v; else _PSTATE[n,m] = v; end; end; getter PSTATE(n:integer,m:integer,o:integer) => bits(3) begin if isNZCV(n) && isNZCV(m) && isNZCV(o) then return _NZCV[n,m,o]; else return _PSTATE[n,m,o]; end; end; setter PSTATE(n:integer,m:integer,o:integer) = v : bits(3) begin if isNZCV(n) && isNZCV(m) && isNZCV(o) then _NZCV[n,m,o] = v; else _PSTATE[n,m,o] = v; end; end; getter PSTATE(n:integer,m:integer,o:integer,p:integer) => bits(4) begin if isNZCV(n) && isNZCV(m) && isNZCV(o) && isNZCV(p) then return _NZCV[n,m,o,p]; else return _PSTATE[n,m,o,p]; end; end; setter PSTATE(n:integer,m:integer,o:integer,p:integer) = v : bits(4) begin if isNZCV(n) && isNZCV(m) && isNZCV(o) && isNZCV(p) then _NZCV[n,m,o,p] = v; else _PSTATE[n,m,o,p] = v; end; end; herd-herdtools7-1ca343e/herd/libdir/asl.cat000066400000000000000000000056231475314470400206070ustar00rootroot00000000000000(* This is a ________ _______ __ _________ _________ |_ ___ \.|_ __ \ / \ |_ ___ | _ _ | | | \. \ | |__) | / /\ \ | |_ \_|_/ | | \_| | | | | | __ / / ____ \ | _| | | _| |___.' /_| | \ \_ _/ / \ \_ _| |_ _| |_ |________.'|____| |___|____| |____|_____| |_____| model for ^~^ , ('Y') ) / \/ ASL __QQ (\|||/) (_)_"> / Please do consider this as a work in progress. *) ASL (* Renamings *) let NASLLocal = ~ASLLocal let ASLDATA = DATA let asl_iico_ctrl = iico_ctrl let asl_iico_data = iico_data let asl_rf_reg = rf-reg let asl_rf = rf (* Warning, partial_po is _implicitely_ transitive *) let asl_po = as_transitive (partial_po) (* Working relations *) let aarch64 = NASLLocal * NASLLocal let asl_fr_reg = asl_po & ([Rreg];loc;[Wreg]) (* loc extended to registers *) let asl_fr = asl_po & ([R] ; loc ; [W]) let asl_data = asl_iico_data | asl_rf_reg let asl_deps = asl_data (* | asl_iico_ctrl *) let asl_deps_restricted = id | (asl_deps ; ([ASLLocal] ; asl_deps)+) let aarch64_iico_data = ( asl_deps_restricted ; asl_data+ ) & aarch64 let aarch64_iico_ctrl = ([B]; asl_iico_ctrl; asl_data*)+ & aarch64 let aarch64_iico_order = ( asl_fr | asl_fr_reg ) & aarch64 let aarch64_intrinsic = aarch64_iico_ctrl | aarch64_iico_data | aarch64_iico_order (* Event sets *) let restrict-finals s = (* Asumming that non-final writes are read internally *) let non-final = domain(rf-reg) in s \ non-final let AArch64 = NASLLocal let AArch64Finals = restrict-finals(AArch64&Wreg) (* DATA and NDATA *) let to_data = (asl_deps_restricted ; [DATA] ; asl_iico_data ; [W | Wreg]) & aarch64 let AArch64_DATA = NASLLocal & domain (to_data) show [AArch64_DATA] as AArch64_DATA show [DATA] as debug_data (* TODO *) (* B = write to PC *) (* BCC = range(aarch64_iico_ctrl) & B *) (* Pred = BranchTo(VBAR something) ??? *) (* F = call to (data memory ?) barrier *) (* Tests *) acyclic (aarch64_intrinsic | asl_po) as asl_determinism (***********) (* Display *) (***********) (* Keep significant branching effects only. * Significant branching effect are the ones * that stand on a control path from AArch64 * relevant accesses. *) let AArch64NoB = AArch64 \ B let reaching = domain ([B]; aarch64_iico_ctrl; [AArch64NoB]) let reachable = range ([AArch64NoB]; aarch64_iico_data; aarch64_iico_ctrl?; [B]) let AArch64B = reaching & reachable let AArch64 = AArch64NoB | AArch64B show AArch64,AArch64Finals,AArch64_DATA show aarch64_iico_ctrl as aarch64_iico_ctrl show aarch64_iico_data, aarch64_iico_order (* Branching events to PC writes are of the branch conditional kind *) let AArch64_BCC = domain ([B]; aarch64_iico_ctrl; [WPC]) show AArch64_BCC herd-herdtools7-1ca343e/herd/libdir/atom-arm.cat000066400000000000000000000015731475314470400215450ustar00rootroot00000000000000"Experimental model, with atomics and ARM ppo" include "cos.cat" (* Uniproc *) acyclic po-loc | rf | fr | co (* Atomic *) empty rmw & (fre;coe) as atomic (* Utilities *) let dd = addr | data let rdw = po-loc & (fre;rfe) let detour = po-loc & (coe ; rfe) let addrpo = addr;po let aa = po & (A * A) (*******) (* ppo *) (*******) include "armfences.cat" show isb,ctrlisb let WW = W * W let RM = R * M let RR = R * R let WR = W * R (* Initial value *) let ci0 = ctrlisb | detour | aa & RR | aa & WR let ii0 = dd | rfi | rdw let cc0 = dd |ctrl | addrpo | aa (* po-loc deleted *) let ic0 = 0 (* Fixpoint from i -> c in instructions and transitivity *) include "ppo.cat" (**********) (* fences *) (**********) (* ARM *) let dmb.st=dmb.st & WW let dsb.st=dsb.st & WW (* Common, all arm barriers are strong *) let strong = dmb|dsb|dmb.st|dsb.st let light = 0 include "ppc-checks.cat" herd-herdtools7-1ca343e/herd/libdir/atom.cat000066400000000000000000000016541475314470400207700ustar00rootroot00000000000000"Experimental model, with atomics" include "cos.cat" (* Uniproc *) acyclic po-loc | rf | fr | co (* Atomic *) empty rmw & (fre;coe) as atomic (* Utilities *) let dd = addr | data let rdw = po-loc & (fre;rfe) let detour = po-loc & (coe ; rfe) let addrpo = addr;po let aa = po & (A * A) (*******) (* ppo *) (*******) include "ppcfences.cat" show isync,ctrlisync show lwsync as lwsync show eieio as eieio show sync let WW = W * W let RM = R * M let RR = R * R let WR = W * R (* Initial value *) let ci0 = ctrlisync | detour | aa & RR | aa & WR let ii0 = dd | rfi | rdw let cc0 = dd | po-loc | ctrl | addrpo | aa let ic0 = 0 (* Fixpoint from i -> c in instructions and transitivity *) include "ppo.cat" (**********) (* fences *) (**********) (* Power *) let lwsync = lwsync & RM | lwsync & WW let eieio = eieio & WW (* Common, all arm barriers are strong *) let strong = sync let light = lwsync|eieio include "ppc-checks.cat" herd-herdtools7-1ca343e/herd/libdir/bpf.cat000066400000000000000000000041461475314470400205760ustar00rootroot00000000000000BPF "BPF Memory model based on LKMM" (*************) (* Utilities *) (*************) (* Single event atomic ops are marked with both R and W. * These events are marked with SC if the op returns a value. *) let RMW = [R & W] & [SC] (* Atomic ops with separate R and W events are related by the amo relation. * both of these R and W events are marked with SC if the op returns a value. *) let SRMW = (SC * SC) & amo (* Both single and double event atomics when marked with SC act as full * barriers: * 1. Single event RMW with SC: * [M] -> RMWsc-> [M] * * 2. Double event RMW with SC: * [M] -> Rsc -> Wsc -> [M] *) let po_amo_fetch = ([M];po;RMW) | (RMW;po;[M]) | ([M];po;[domain(SRMW)]) | ([range(SRMW)];po;[M]) show po_amo_fetch as atomicfetch (* Release Consistency processor consistent (RCpc) *) let load_acquire = ([AQ];po;[M]) let store_release = ([M];po;[RL]) let rcpc = load_acquire | store_release (****************) (* Dependencies *) (****************) let addr_dep = [R];addr;[M] let data_dep = [R];data;[W] let ctrl_dep = [R];ctrl;[W] show addr_dep as addr show data_dep as data show ctrl_dep as ctrl (**********************) (* ppo and prop rules *) (**********************) (* Compute coherence relation *) include "cos-opt.cat" let com = co | rf | fr let ppo = (* Explicit synchronization *) po_amo_fetch | rcpc (* Syntactic Dependencies *) | addr_dep | data_dep | ctrl_dep (* Pipeline Dependencies *) | [M];(addr|data);[W];rfi;[R] | [M];addr;[M];po;[W] (* Overlapping-address ordering *) | (coi | fri) (* Propagation ordering from SC and release operations *) let A-cumul = rfe? ; (po_amo_fetch | store_release) let amo-sequence = (rf ; ([R & W] | amo))* let prop = (coe | fre)? ; (A-cumul ; amo-sequence)* ; rfe? (**********) (* Axioms *) (**********) (* Sc per location *) acyclic com | po-loc as Coherence (* No-Thin-Air and Observation *) let hb = ppo | rfe | ((prop \ id) & int) acyclic hb as Happens-before (* Propagation *) let pb = prop ; po_amo_fetch ; hb* acyclic pb as Propagation (* Atomicity *) empty rmw & (fre;coe) as Atomic (* Atomic fetch as a fence *) acyclic po_amo_fetch | com herd-herdtools7-1ca343e/herd/libdir/c11.bell000066400000000000000000000006241475314470400205570ustar00rootroot00000000000000"C11 Bell annotation" enum memorder = 'rlx || 'acq || 'rel || 'con || 'acq_rel || 'sc instructions R[{'rlx,'acq,'con,'sc}] instructions W[{'rlx,'rel,'sc}] instructions F[{'acq,'rel,'acq_rel,'sc}] let ACQ= tag2set('acq) let SC = tag2set('sc) let REL = tag2set('rel) let RLX = tag2set('rlx) let ACQ_REL = tag2set('acq_rel) let CON = tag2set('con) let A = M & (ACQ|SC|REL|RLX|ACQ_REL|CON) let NA = M \ A herd-herdtools7-1ca343e/herd/libdir/c11.def000066400000000000000000000014061475314470400203760ustar00rootroot00000000000000// Some RMW operations atomic_load(X) atomic_load_explicit(X,memory_order_seq_cst) atomic_store(X,V) { atomic_store_explicit(X,V,memory_order_seq_cst); } atomic_exchange(X,V) atomic_exchange_explicit(X,V,memory_order_seq_cst) atomic_fetch_add(X,V) atomic_fetch_add_explicit(X,V,memory_order_seq_cst) atomic_fetch_sub(X,V) atomic_fetch_sub_explicit(X,V,memory_order_seq_cst) atomic_fetch_or(X,V) atomic_fetch_or_explicit(X,V,memory_order_seq_cst) atomic_fetch_xor(X,V) atomic_fetch_xor_explicit(X,V,memory_order_seq_cst) atomic_fetch_and(X,V) atomic_fetch_and_explicit(X,V,memory_order_seq_cst) // RCU rcu_read_lock() { __fence{rcu-lock}; } rcu_read_unlock() { __fence{rcu-unlock};} synchronize_rcu() { __fence{sync-rcu}; } synchronize_rcu_expedited() { __fence{sync-rcu}; } herd-herdtools7-1ca343e/herd/libdir/c11_base.cat000066400000000000000000000050741475314470400214060ustar00rootroot00000000000000"C++11" (* All c11_*.cat files are C11 models Overhauling SC atomics in C11 and OpenCL. M. Batty, A. Donaldson, J. Wickerson. In Proc. 43rd ACM SIGPLAN-SIGACT Symposium on Principles of Programming Languages (POPL), 2016. Rewritten by Luc Maranget for herd7 *) include "c11_cos.cat" include "c11_los.cat" let asw = IW * (M \ IW) let sb = po let mo = co let cacq = ACQ | (SC & (R | F)) | ACQ_REL | (F & CON) let crel = REL | (SC & (W | F)) | ACQ_REL let ccon = R & CON let fr = rf^-1 ; mo let dd = (data | addr)+ let fsb = sb & (F * _) let sbf = sb & (_ * F) (* release_acquire_fenced_synchronizes_with, hypothetical_release_sequence_set, release_sequence_set *) (* OLD: let rs = [crel] ; fsb? ; [A & W] ; (((mo ; [rmw]) | coi) & ~(coe ; [!rmw] ; mo))? *) let rs_prime = int | (_ * (R & W)) let rs = mo & rs_prime \ ((mo \ rs_prime) ; mo) (* OLD: let swra = ext (rs ; rf ; [A] ; sbf? ; [cacq]) *) let swra = ext & (toid(crel) ; fsb? ; toid(A & W) ; rs? ; rf ; toid(R & A) ; sbf? ; toid(cacq)) let swul = ext & (toid(UL) ; lo ; toid(LK)) let pp_asw = asw \ (asw ; sb) let sw = pp_asw | swul | swra (* with_consume_cad_set, dependency_ordered_before *) let cad = ((rf & sb) | dd)+ let dob = (ext & (toid(W & crel) ; fsb? ; toid(A & W) ; rs?; rf; toid(ccon))); cad? (* happens_before, inter_thread_happens_before, consistent_hb *) let ithbr = sw | dob | (sw ; sb) let ithb = (ithbr | (sb ; ithbr))+ let hb = sb | ithb acyclic hb as Hb show (hb \ (IW * _)) & ext as hb (* coherent_memory_use *) let hbl = hb & loc irreflexive ((rf^-1)? ; mo ; rf? ; hb) as Coh (* visible_side_effect_set *) let vis = (hbl & (W * R)) \ (hbl; toid(W) ; hbl) (* consistent_atomic_rf *) irreflexive (rf ; hb) as Rf (* consistent_non_atomic_rf *) empty ((rf ; [R\A]) \ vis) as NaRf empty [FW\A];hbl;[W] as NaRf (* implicit read of Na final writes.. *) irreflexive (rf | (mo ; mo ; rf^-1) | (mo ; rf)) as Rmw (* locks_only_consistent_lo *) irreflexive (lo ; hb) as Lo1 (* locks_only_consistent_locks *) irreflexive (toid(LS) ; lo^-1 ; toid(LS) ; ~(lo ; toid(UL) ; lo)) as Lo2 (* data_races *) let Mutex = UL|LS let cnf = (((W * _) | (_ * W)) & loc) \ ((Mutex * _) | (_ * Mutex)) let dr = ext & (cnf \ hb \ (hb^-1) \ (A * A)) (* unsequenced_races *) let ur = int & ((W * M) | (M * W)) & loc & ~id & ~(sb+) & ~((sb+)^-1) (* locks_only_good_mutex_use, locks_only_bad_mutexes *) let bl = (toid(LS); (sb & lo); toid(LK)) & ~(lo; toid(UL); lo) let losbwoul = (sb & lo & ~(lo; toid(UL); lo)) let lu = toid(UL) & ~(toid(UL) ; losbwoul^-1 ; toid(LS) ; losbwoul ; toid(UL)) herd-herdtools7-1ca343e/herd/libdir/c11_cos.cat000066400000000000000000000005711475314470400212550ustar00rootroot00000000000000"Generate co's (mo's) for c11, ie on atomic writes only ??" include "cross.cat" let invrf = rf^-1 let mobase = co0 with mo from generate_orders(W&(A|IW),mobase) (* From now, mo is a coherence order *) let moi = mo & int let moe = mo & ext let co = mo and coe = moe and coi = coi (* Compute fr *) let fr = (invrf ; mo) \ id let fri = fr & int let fre = fr & ext show mo,fr herd-herdtools7-1ca343e/herd/libdir/c11_los.cat000066400000000000000000000007061475314470400212660ustar00rootroot00000000000000"C++11, generate lock-order" (* Direct generation, replaced by optimised generation *) (* with lo from generate_orders(LS|UL,po) *) (* Non-nested critical section *) let crit = let Mutex = LS|UL in let poMutex = po-loc & (Mutex * Mutex) in (po-loc & (LS * UL)) \ (poMutex;poMutex) with loLL from generate_orders(LS,po) (* Locks are ordered, place unlock in-between *) let loLU = loLL?;crit and loUL = crit^-1;loLL let lo = (loLL|loLU|loUL)+ herd-herdtools7-1ca343e/herd/libdir/c11_orig.cat000066400000000000000000000010151475314470400214230ustar00rootroot00000000000000"C++11" include "c11_base.cat" with S from linearisations(SC,hb) let Simm = S \ (mo ; S) irreflexive (S ; hb) as S1 irreflexive (S ; fsb? ; mo ; sbf?) as S2 irreflexive (S ; rf^-1; toid(SC) ; mo) as S3 let r4 = rf^-1 ; hbl ; toid(W) irreflexive (Simm ; r4) as S4 irreflexive (S ; fsb ; fr) as S5 irreflexive (S ; fr ; sbf) as S6 irreflexive (S ; fsb ; fr ; sbf) as S7 undefined_unless empty dr as Dr undefined_unless empty ur as unsequencedRace undefined_unless empty bl as badLock undefined_unless empty lu as badUnlock herd-herdtools7-1ca343e/herd/libdir/c11_partialSC.cat000066400000000000000000000006631475314470400223550ustar00rootroot00000000000000C "C++11" include "c11_base.cat" let r1 = hb let r2 = fsb? ; mo ; sbf? let r3 = rf^-1; toid(SC) ; mo let r4 = rf^-1 ; hbl ; toid(W) let r5 = fsb ; fr let r6 = fr ; sbf let r7 = fsb ; fr ; sbf let scp = r1|r2|r3|r4|r5|r6|r7 acyclic (((SC * SC) & scp) \ id) as Spartial show scp undefined_unless empty dr as Dr undefined_unless empty ur as unsequencedRace undefined_unless empty bl as badLock undefined_unless empty lu as badUnlock herd-herdtools7-1ca343e/herd/libdir/c11_simp.cat000066400000000000000000000004241475314470400214360ustar00rootroot00000000000000"C++11" include "c11_base.cat" let scp = ((SC * SC) & (fsb?; (mo | fr | hb); sbf?)) \ id acyclic scp as Ssimp show scp undefined_unless empty dr as Dr undefined_unless empty ur as unsequencedRace undefined_unless empty bl as badLock undefined_unless empty lu as badUnlock herd-herdtools7-1ca343e/herd/libdir/catdefinitions.tex000066400000000000000000000442641475314470400230700ustar00rootroot00000000000000\newcommand{\notthecase}[1]{it is not the case that #1} \newcommand{\Variant}[1]{#1 is implemented} \newcommand{\NotVariant}[1]{it is not the case that #1 is implemented} \newcommand{\flag}[1]{By construction, #1} \newcommand{\assert}[1]{By construction, #1} % % % \newcommand{\anyevent}[1]{#1 is any event} \newcommand{\anyrel}[2]{#1 and #2 are any events} \newcommand{\transitive}[3]{there exists a chain of #1 from #2 to #3} \newcommand{\intervening}[4]{there exists a #1 in #2 between #3 and #4} \newcommand{\includedname}{included in} \newcommand{\included}[2]{#1 is included in #2} \newcommand{\includedemph}[2]{#1 is \emph{included in} #2} \newcommand{\sameloc}[2]{#1 and #2 are to the Same Location} \newcommand{\sca}[2]{#1 belongs to the same single-copy-atomic class as #2} \newcommand{\po}[2]{#1 appears in program order before #2} \newcommand{\coemph}[2]{#1 is \emph{Coherence-write-before} #2} \newcommand{\fr}[2]{#1 Reads-before #2} \newcommand{\rf}[2]{#2 Reads-from-memory #1} \newcommand{\rfi}[2]{#2 Reads-from-internal #1} \newcommand{\rfreg}[2]{#2 Reads-from-register #1} \newcommand{\rmw}[2]{#1 and #2 form a successful Read-Modify-Write pair} \newcommand{\DATA}[2]{#1 affects the data value written by #2} \newcommand{\ADDR}[2]{#1 affects the address of the Location accessed by #2} \newcommand{\sameinstance}[2]{#1 and #2 are generated by the same instruction} \newcommand{\sm}[2]{\sameinstance{#1}{#2}} \newcommand{\si}[2]{\sameinstance{#1}{#2}} \newcommand{\sameEffect}[2]{#1 and #2 are the same Effect} \newcommand{\ext}[2]{#1 and #2 are from different Processing Elements} % \newcommand{\ME}{Memory Effect} \newcommand{\MWE}{Memory Write Effect} \newcommand{\MRE}{Memory Read Effect} \newcommand{\M}[1]{#1 is a \ME{}} \newcommand{\W}[1]{#1 is a \MWE{}} \newcommand{\R}[1]{#1 is a \MRE{}} \renewcommand{\_}{any Effect} \newcommand{\B}[1]{#1 is a Branching Effect} \newcommand{\BCC}[1]{#1 is a Conditional Branching Effect} \newcommand{\FAULT}[1]{#1 is a Fault Effect} \newcommand{\NoRet}[1]{#1 is generated by an instruction whose destination register is WZR or XZR} \newcommand{\RWE}{Register Write Effect} \newcommand{\RRE}{Register Read Effect} \newcommand{\RRWEs}{Register Read and Write Effects} \newcommand{\Wreg}[1]{#1 is a \RWE{}} \newcommand{\Rreg}[1]{#1 is a \RRE{}} \newcommand{\RREof}[1]{the \RRE{} of #1} \newcommand{\RWEof}[1]{the \RWE{} of #1} % \newcommand{\memloc}[1]{the Memory Location #1} \newcommand{\tagloc}[1]{the Tag Location #1} \newcommand{\reg}[1]{the Register #1} % % \newcommand{\Exp}[1]{#1 is an Explicit Effect} \newcommand{\ExpMREof}[1]{the Explicit \MRE{} of #1} \newcommand{\ExpMWEof}[1]{the Explicit \MWE{} of #1} \newcommand{\ExpM}[1]{#1 is an Explicit \ME{}} % \newcommand{\ExpW}[1]{#1 is an Explicit \MWE{}} \newcommand{\ExpR}[1]{#1 is an Explicit \MRE{}} \newcommand{\NExp}[1]{#1 is an Implicit Effect} \newcommand{\Imp}[1]{\NExp{#1}} \newcommand{\ImpM}[1]{#1 is an Implicit Memory Effect} \newcommand{\ImpW}[1]{#1 is an Implicit Memory Write Effect} \newcommand{\ImpR}[1]{#1 is an Implicit Memory Read Effect} \newcommand{\Tag}[1]{#1 is a Tag Effect} \newcommand{\TagCheck}[1]{#1 is a TagCheck Effect} \newcommand{\ExpTagMRE}{Explicit Tag \MRE{}} \newcommand{\ExpTagMWE}{Explicit Tag \MWE{}} \newcommand{\ImpTagMRE}{Implicit Tag \MRE{}} \newcommand{\ImpTagMWE}{Implicit Tag \MWE{}} \newcommand{\ImpTagMREof}[1]{the \ImpTagMRE{} of #1} \newcommand{\ImpTagMWEof}[1]{the \ImpTagMWE{} of #1} \newcommand{\ImpTagM}[1]{#1 is an Implicit Tag Memory Effect} \newcommand{\ImpTagW}[1]{#1 is an \ImpTagMWE{}} \newcommand{\ImpTagR}[1]{#1 is an \ImpTagMRE{}} \newcommand{\ImpTTDM}[1]{#1 is an Implicit TTD Memory Effect} \newcommand{\ImpTTDW}[1]{#1 is an Implicit TTD Memory Write Effect} \newcommand{\HU}[1]{#1 is a Hardware Update Effect} \newcommand{\ImpTTDR}[1]{#1 is an Implicit TTD Memory Read Effect} \newcommand{\ImpInstrM}[1]{#1 is an Implicit Instruction Memory Effect} \newcommand{\ImpInstrW}[1]{#1 is an Implicit Instruction Memory Write Effect} \newcommand{\ImpInstrR}[1]{#1 is an Implicit Instruction Memory Read Effect} \newcommand{\ISB}[1]{#1 is an ISB Effect} \newcommand{\EXCENTRY}[1]{#1 is an Exception Entry Effect} \newcommand{\EXCRET}[1]{#1 is an Exception Return Effect} \newcommand{\EXCENTRYIFB}[1]{#1 is an Exception Entry Instruction Fetch Barrier Effect} \newcommand{\EXCRETIFB}[1]{#1 is an Exception Return Instruction Fetch Barrier Effect} \newcommand{\IFB}[1]{#1 is an Instruction Fetch Barrier Effect} \newcommand{\A}[1]{#1 is an Explicit \ME{} generated by an instruction with Acquire semantics} \newcommand{\Q}[1]{#1 is an Explicit \ME{} generated by an instruction with AcquirePC semantics} \newcommand{\REL}[1]{#1 is an Explicit \ME{} or a Fault Effect and generated by an instruction with Release semantics} \newcommand{\rangeAamoL}[1]{#1 is an Explicit \MWE{} and is generated by an atomic instruction with both Acquire and Release semantics} \newcommand{\DMBFULL}[1]{#1 is a DMB FULL Effect} \newcommand{\DMBSY}[1]{#1 is a DMB SY Effect} \newcommand{\DMBST}[1]{#1 is a DMB ST Effect} \newcommand{\DMBLD}[1]{#1 is a DMB LD Effect} \newcommand{\DSBFULL}[1]{#1 is a DSB FULL Effect} \newcommand{\DSBSY}[1]{#1 is a DSB SY Effect} \newcommand{\DSBST}[1]{#1 is a DSB ST Effect} \newcommand{\DSBLD}[1]{#1 is a DSB LD Effect} \newcommand{\TLBI}[1]{#1 is a TLBI Effect} \newcommand{\CTLBI}[1]{#1 is a Completed TLBI Effect} \newcommand{\invscope}[2]{#1 is in the Invalidation Scope of #2} \newcommand{\invscopeemph}[2]{#1 is \emph{in the Invalidation Scope of} #2} \newcommand{\DCCVAU}[1]{#1 is a DC CVAU Effect} \newcommand{\IC}[1]{#1 is an IC Effect} \newcommand{\ICIVAU}[1]{#1 is an IC IVAU Effect} \newcommand{\Fault}[1]{#1 is a Fault Effect} \newcommand{\TagCheckFAULT}[1]{#1 is a TagCheck Fault Effect} \newcommand{\TagCheckEXCENTRY}[1]{#1 is a TagCheck Fault Effect that generates a synchronous exception} \newcommand{\MMU}[1]{#1 is an MMU Effect} \newcommand{\MMUFAULT}[1]{#1 is an MMU Fault Effect} \newcommand{\TLBUncacheableFAULT}[1]{#1 is a TLBUncacheable Fault Effect} % \newcommand{\amo}{an atomic operation} \newcommand{\lxsx}{a successful Load-Exclusive/Store-Exclusive pair} % \newcommand{\iicodataname}{Intrinsic Data Dependency} \newcommand{\iicodata}[2]{there is an \iicodataname{} from #1 to #2} \newcommand{\iicodataemph}[2]{there is an \emph{\iicodataname{}} from #1 to #2} \newcommand{\iicoordername}{Intrinsic Order Dependency} \newcommand{\iicoorder}[2]{there is an \iicoordername{} from #1 to #2} \newcommand{\iicoorderemph}[2]{there is an \emph{\iicoordername{}} from #1 to #2} \newcommand{\iicoctrlname}{Intrinsic Control Dependency} \newcommand{\iicoctrl}[2]{there is an \iicoctrlname{} from #1 to #2} \newcommand{\iicoctrlemph}[2]{there is an \emph{\iicoctrlname{}} from #1 to #2} \newcommand{\dtrmname}{Dependency through registers and memory} \newcommand{\dtrm}[2]{there is a \dtrmname{} from #1 to #2} \newcommand{\dtrmemph}[2]{there is a \emph{\dtrmname{}} from #1 to #2} \newcommand{\basicdepname}{Basic dependency} \newcommand{\basicdep}[2]{there is a \basicdepname{} from #1 to #2} \newcommand{\basicdepemph}[2]{there is a \emph{\basicdepname{}} from #1 to #2} \newcommand{\dataname}{Data dependency} \newcommand{\data}[2]{there is a \dataname{} from #1 to #2} \newcommand{\dataemph}[2]{there is a \emph{\dataname{}} from #1 to #2} \newcommand{\addrname}{Address dependency} \newcommand{\addr}[2]{there is an \addrname{} from #1 to #2} \newcommand{\addremph}[2]{there is an \emph{\addrname{}} from #1 to #2} \newcommand{\ctrlname}{Control dependency} \newcommand{\ctrl}[2]{there is a \ctrlname{} from #1 to #2} \newcommand{\ctrlemph}[2]{there is a \emph{\ctrlname{}} from #1 to #2} \newcommand{\pickdtrmname}{Pick dependency through registers and memory} \newcommand{\pickdtrm}[2]{there is a \pickdtrmname{} from #1 to #2} \newcommand{\pickdtrmemph}[2]{there is a \emph{\pickdtrmname{}} from #1 to #2} \newcommand{\pickbasicdepname}{Pick Basic dependency} \newcommand{\pickbasicdep}[2]{there is a \pickbasicdepname{} from #1 to #2} \newcommand{\pickbasicdepemph}[2]{there is a \emph{\pickbasicdepname{}} from #1 to #2} \newcommand{\pickdatadepname}{Pick Data dependency} \newcommand{\pickdatadep}[2]{there is a \pickdatadepname{} from #1 to #2} \newcommand{\pickdatadepemph}[2]{there is a \emph{\pickdatadepname{}} from #1 to #2} \newcommand{\pickaddrdepname}{Pick Address dependency} \newcommand{\pickaddrdep}[2]{there is a \pickaddrdepname{} from #1 to #2} \newcommand{\pickaddrdepemph}[2]{there is a \emph{\pickaddrdepname{}} from #1 to #2} \newcommand{\pickctrldepname}{Pick Control dependency} \newcommand{\pickctrldep}[2]{there is a \pickctrldepname{} from #1 to #2} \newcommand{\pickctrldepemph}[2]{there is a \emph{\pickctrldepname{}} from #1 to #2} \newcommand{\pickdepname}{Pick dependency} \newcommand{\pickdep}[2]{there is a \pickdepname{} from #1 to #2} \newcommand{\pickdepemph}[2]{there is a \emph{\pickdepname{}} from #1 to #2} % \newcommand{\tcibname}{Tag-check-intrinsically-before} \newcommand{\tcib}[2]{#1 is Tag-check-intrinsically-before #2} \newcommand{\tcibemph}[2]{#1 is \emph{Tag-check-intrinsically-before} #2} \newcommand{\tribname}{Translation-intrinsically-before} \newcommand{\trib}[2]{#1 is Translation-intrinsically-before #2} \newcommand{\tribemph}[2]{#1 is \emph{Translation-intrinsically-before} #2} \newcommand{\fibname}{Fetch-intrinsically-before} \newcommand{\fib}[2]{#1 is Fetch-intrinsically-before #2} \newcommand{\fibemph}[2]{#1 is \emph{Fetch-intrinsically-before} #2} \newcommand{\sameoa}[2]{#1 and #2 have the Same Output Address} \newcommand{\sameloworderbits}[2]{#1 and #2 have the Same Low Order Bits} \newcommand{\valoc}[2]{#1 and #2 are to the Same Virtual Address} \newcommand{\lrsname}{a Local read successor of} \newcommand{\lrs}[2]{#2 is a Local read successor of #1} \newcommand{\lwfsname}{a Local write or MMU Fault successor of} \newcommand{\lwfs}[2]{#2 is a Local write or MMU Fault successor of #1} % \edef\povaloc#1#2{\po{#1}{#2} and \valoc{#1}{#2}} \newcommand{\povaloc}[2]{\po{#1}{#2} and \valoc{#1}{#2}} \newcommand{\samereg}[2]{#1 and #2 are to the Same Register} \newcommand{\sameval}[2]{#2 takes its data from #1} \newcommand{\scl}[2]{#1 and #2 are to the Same Cache Line} \newcommand{\dobname}{Dependency-ordered-before} \newcommand{\dob}[2]{#1 is \dobname{} #2} \newcommand{\dobemph}[2]{#1 is \emph{\dobname{}} #2} \newcommand{\pobname}{Pick-ordered-before} \newcommand{\pob}[2]{#1 is \pobname{} #2} \newcommand{\pobemph}[2]{#1 is \emph{\pobname{}} #2} \newcommand{\aobname}{Atomic-ordered-before} \newcommand{\aob}[2]{#1 is \aobname{} #2} \newcommand{\aobemph}[2]{#1 is \emph{\aobname{}} #2} \newcommand{\bobname}{Barrier-ordered-before} \newcommand{\bob}[2]{#1 is \bobname{} #2} \newcommand{\bobemph}[2]{#1 is \emph{\bobname{}} #2} \newcommand{\DSBobname}{DSB-ordered-before} \newcommand{\DSBob}[2]{#1 is DSB-ordered-before #2} \newcommand{\DSBobemph}[2]{#1 is \emph{DSB-ordered-before} #2} \newcommand{\IFBobname}{Instruction-fetch-barrier-ordered-before} \newcommand{\IFBob}[2]{#1 is Instruction-fetch-barrier-ordered-before #2} \newcommand{\IFBobemph}[2]{#1 is \emph{Instruction-fetch-barrier-ordered-before} #2} \newcommand{\TLBIbname}{TLBI-before} \newcommand{\TLBIb}[2]{#1 is \TLBIaname{} #2} \newcommand{\TLBIbemph}[2]{#1 is \emph{\TLBIaname{}} #2} \newcommand{\TLBIaname}{TLBI-after} \newcommand{\TLBIa}[2]{#1 is \TLBIbname{} #2} \newcommand{\TLBIaemph}[2]{#1 is \emph{\TLBIbname{}} #2} \newcommand{\DCbname}{DC-before} \newcommand{\DCb}[2]{#1 is \DCaname{} #2} \newcommand{\DCbemph}[2]{#1 is \emph{\DCaname{}} #2} \newcommand{\DCaname}{DC-after} \newcommand{\DCa}[2]{#1 is \DCbname{} #2} \newcommand{\DCaemph}[2]{#1 is \emph{\DCbname{}} #2} \newcommand{\ICbname}{IC-before} \newcommand{\ICb}[2]{#1 is \ICaname{} #2} \newcommand{\ICbemph}[2]{#1 is \emph{\ICaname{}} #2} \newcommand{\ICaname}{IC-after} \newcommand{\ICa}[2]{#1 is \ICbname{} #2} \newcommand{\ICaemph}[2]{#1 is \emph{\ICbname{}} #2} \newcommand{\TLBIcbname}{TLBI-coherence-before} \newcommand{\TLBIcb}[2]{#1 is \TLBIcaname{} #2} \newcommand{\TLBIcbemph}[2]{#1 is \emph{\TLBIcaname{}} #2} \newcommand{\TLBIcaname}{TLBI-coherence-after} \newcommand{\TLBIca}[2]{#1 is \TLBIcbname{} #2} \newcommand{\TLBIcaemph}[2]{#1 is \emph{\TLBIcbname{}} #2} \newcommand{\ICcbname}{IC-coherence-before} \newcommand{\ICcb}[2]{#1 is \ICcaname{} #2} \newcommand{\ICcbemph}[2]{#1 is \emph{\ICcaname{}} #2} \newcommand{\ICcaname}{IC-coherence-after} \newcommand{\ICca}[2]{#1 is \ICcbname{} #2} \newcommand{\ICcaemph}[2]{#1 is \emph{\ICcbname{}} #2} \newcommand{\TLBIaftername}{\TLBIaname} \newcommand{\TLBIafter}[2]{\TLBIa{#1}{#2}} \newcommand{\ICaftername}{\ICaname} \newcommand{\ICafter}[2]{\ICa{#1}{#2}} \newcommand{\DCafter}[2]{\DCa{#1}{#2}} \newcommand{\cbname}{Coherence-before} \newcommand{\cb}[2]{#1 is \caname{} #2} \newcommand{\cbemph}[2]{#1 is \emph{\caname{}} #2} \newcommand{\caname}{Coherence-after} \newcommand{\ca}[2]{#1 is \cbname{} #2} \newcommand{\caemph}[2]{#1 is \emph{\cbname{}} #2} \newcommand{\lobname}{Locally-ordered-before} \newcommand{\lob}[2]{#1 is Locally-ordered-before #2} \newcommand{\lobemph}[2]{#1 is \emph{Locally-ordered-before} #2} \newcommand{\picklobname}{Pick-locally-ordered-before} \newcommand{\picklob}[2]{#1 is Pick-locally-ordered-before #2} \newcommand{\picklobemph}[2]{#1 is \emph{Pick-locally-ordered-before} #2} \newcommand{\localhwreqsname}{Locally-hardware-required-ordered-before} \newcommand{\localhwreqs}[2]{#1 is Locally-hardware-required-ordered-before #2} \newcommand{\localhwreqsemph}[2]{#1 is \emph{Locally-hardware-required-ordered-before} #2} \newcommand{\hazobname}{Hazard-ordered-before} \newcommand{\hazob}[2]{#1 is Hazard-ordered-before #2} \newcommand{\hazobemph}[2]{#1 is \emph{Hazard-ordered-before} #2} \newcommand{\Exphazobname}{Explicitly-hazard-ordered-before} \newcommand{\Exphazob}[2]{#1 is Explicitly-hazard-ordered-before #2} \newcommand{\Exphazobemph}[2]{#1 is \emph{Explicitly-hazard-ordered-before} #2} \newcommand{\TTDreadobname}{TTD-read-ordered-before} \newcommand{\TTDreadob}[2]{#1 is TTD-read-ordered-before #2} \newcommand{\TTDreadobemph}[2]{#1 is \emph{TTD-read-ordered-before} #2} \newcommand{\TLBIobname}{TLBI-ordered-before} \newcommand{\TLBIob}[2]{#1 is TLBI-ordered-before #2} \newcommand{\TLBIobemph}[2]{#1 is \emph{TLBI-ordered-before} #2} \newcommand{\Instrreadobname}{Instruction-read-ordered-before} \newcommand{\Instrreadob}[2]{#1 is Instruction-read-ordered-before #2} \newcommand{\Instrreadobemph}[2]{#1 is \emph{Instruction-read-ordered-before} #2} \newcommand{\ICobname}{IC-ordered-before} \newcommand{\ICob}[2]{#1 is IC-ordered-before #2} \newcommand{\ICobemph}[2]{#1 is \emph{IC-ordered-before} #2} \newcommand{\hwreqsname}{Hardware-required-ordered-before} \newcommand{\hwreqs}[2]{#1 is Hardware-required-ordered-before #2} \newcommand{\hwreqsemph}[2]{#1 is \emph{Hardware-required-ordered-before} #2} \newcommand{\obsname}{Observed-by} \newcommand{\obs}[2]{#1 is Observed-by #2} \newcommand{\obsemph}[2]{#1 is \emph{Observed-by} #2} \newcommand{\Expobsname}{Explicitly-Observed-by} \newcommand{\Expobs}[2]{#1 is Explicitly-Observed-by #2} \newcommand{\Expobsemph}[2]{#1 is \emph{Explicitly-Observed-by} #2} \newcommand{\Tagobsname}{Tag-Observed-by} \newcommand{\Tagobs}[2]{#1 is \Tagobsname{} #2} \newcommand{\Tagobsemph}[2]{#1 is \emph{\Tagobsname{}} #2} \newcommand{\TTDobsname}{TTD-Observed-by} \newcommand{\TTDobs}[2]{#1 is \TTDobsname{} #2} \newcommand{\TTDobsemph}[2]{#1 is \emph{\TTDobsname{}} #2} \newcommand{\Instrobsname}{Instruction-Observed-by} \newcommand{\Instrobs}[2]{#1 is \Instrobsname{} #2} \newcommand{\Instrobsemph}[2]{#1 is \emph{\Instrobsname{}} #2} \newcommand{\obname}{Ordered-before} \newcommand{\ob}[2]{#1 is Ordered-before #2} \newcommand{\obemph}[2]{#1 is \emph{Ordered-before} #2} \newcommand{\TLBuncacheablepredname}{a TLBUncacheable-Write-Predecessor of} \newcommand{\TLBuncacheablepred}[2]{#1 is a TLBUncacheable-Write-Predecessor of #2} \newcommand{\TLBuncacheablepredemph}[2]{#1 is \emph{a TLBUncacheable-Write-Predecessor of} #2} \newcommand{\TLBuncacheablesuccname}{a TLBUncacheable-Write-Successor of} \newcommand{\TLBuncacheablesucc}[2]{#1 is a TLBUncacheable-Write-Successor of #2} \newcommand{\TLBuncacheablesuccemph}[2]{#1 is \emph{a TLBUncacheable-Write-Successor of} #2} \newcommand{\HUpredname}{a Hardware-Update-Predecessor of} \newcommand{\HUpred}[2]{#1 is a Hardware-Update-Predecessor of #2} \newcommand{\HUpredemph}[2]{#1 is \emph{a Hardware-Update-Predecessor of} #2} \newcommand{\HUsuccname}{a Hardware-Update-Successor of} \newcommand{\HUsucc}[2]{#1 is a Hardware-Update-Successor of #2} \newcommand{\HUsuccemph}[2]{#1 is \emph{a Hardware-Update-Successor of} #2} % \newcommand{\byamo}[1]{#1 is generated by \amo\xspace} \newcommand{\rangelxsx}[1]{#1 is generated by a Store-Exclusive instruction as part of \lxsx} \newcommand{\rangetribminus}[3]{\ImpTTDR{#1} and \trib{#1}{an Effect #2 such that #3}} % \newcommand{\pofetchobname}{Fetch-ordered-before} \newcommand{\pofetchob}[2]{#1 is Fetch-ordered-before #2} \newcommand{\pofetchobemph}[2]{#1 is \emph{Fetch-ordered-before} #2} \newcommand{\posclobname}{Same-Cache-Line-ordered-before} \newcommand{\posclob}[2]{#1 is Same-Cache-Line-ordered-before #2} \newcommand{\posclobemph}[2]{#1 is \emph{Same-Cache-Line-ordered-before} #2} \newcommand{\etsobname}{ETS-ordered-before} \newcommand{\etsob}[2]{#1 is ETS-ordered-before #2} \newcommand{\etsobemph}[2]{#1 is \emph{ETS-ordered-before} #2} \newcommand{\fobname}{Fetch-ordered-before} \newcommand{\fob}[2]{#1 is Fetch-ordered-before #2} \newcommand{\fobemph}[2]{#1 is \emph{Fetch-ordered-before} #2} \newcommand{\irobname}{Implicit-Read-ordered-before} \newcommand{\irob}[2]{#1 is Implicit-Read-ordered-before #2} \newcommand{\irobemph}[2]{#1 is \emph{Implicit-Read-ordered-before} #2} \newcommand{\iobname}{Intrinsically-ordered-before} \newcommand{\iob}[2]{#1 is Intrinsically-ordered-before #2} \newcommand{\iobemph}[2]{#1 is \emph{Intrinsically-ordered-before} #2} \newcommand{\tcbeforename}{Tag-check-before} \newcommand{\tcbefore}[2]{#1 is Tag-check-before #2} \newcommand{\tcbeforeemph}[2]{#1 is \emph{Tag-check-before} #2} \newcommand{\invdomain}[2]{\invscope{#1}{#2}} \newcommand{\ImpTTD}[1]{\ImpTTDM{#1}} \newcommand{\TTDreadorderedbefore}[2]{\TTDreadob{#1}{#2}} \newcommand{\TTDreadorderedbeforeemph}[2]{\TTDreadobemph{#1}{#2}} \newcommand{\nointerv}[4]{there is no #1 in #2 between #3 and #4} \renewcommand{\int}[2]{#1 and #2 are from the same Processing Element} herd-herdtools7-1ca343e/herd/libdir/choices.cat000066400000000000000000000012721475314470400214410ustar00rootroot00000000000000let choices rf = let r2ws r = rf;[r] in (* returns the subrelation of rf such that the second component of the pair is exactly r *) let rec zyva rs = match rs with || {} -> { 0 } || r ++ rs -> let wrs = r2ws r in (* subrelation of rf { w -> x | x = r } *) let rels = zyva rs in (* recursion *) let rec mapwrs wrs = match wrs with # for all w -> r || {} -> {} || wr ++ wrs -> let rec maprels rels = match rels with # for all relations || { } -> {} || rel ++ rels -> (wr ++ rel) ++ maprels rels end in maprels rels | mapwrs wrs end in mapwrs wrs end in zyva (range rf) herd-herdtools7-1ca343e/herd/libdir/compat.cat000066400000000000000000000000451475314470400213040ustar00rootroot00000000000000Compatibility include "filters.cat" herd-herdtools7-1ca343e/herd/libdir/cos-no-opt.cat000066400000000000000000000004311475314470400220160ustar00rootroot00000000000000"Generate co's" include "cross.cat" let invrf = rf^-1 let cobase = co0 with co from generate_cos(cobase) (* From now, co is a coherence order *) let coi = co & int let coe = co \ coi (* Compute fr *) let fr = (invrf ; co) \ id let fri = fr & int let fre = fr \ fri show co,fr herd-herdtools7-1ca343e/herd/libdir/cos-ok-opt.cat000066400000000000000000000015561475314470400220240ustar00rootroot00000000000000"Generate co's" (* generates possible co's, optimized version *) (* co observations in test *) let invrf = rf^-1 (* Relation pco is computed by herd7 code let obsco = let po-loc = [Exp];po-loc;[Exp] in let ww = po-loc & (W * W) and rw = rf ; (po-loc & (R * W)) and wr = ((po-loc & (W * R)) ; invrf) \ id and rr = (rf ; (po-loc & (R * R)) ; invrf) \ id in (ww|rw|wr|rr) let pco = obsco|co0 *) (* The following applies to C only, where RMW is both R and W *) let rmwco = let _RMW = R & W in rf & (W * _RMW) (* co observation by atomicity *) let cobase = rmwco|pco (* Catch uniproc violations early *) acyclic cobase as ConsCo include "cross.cat" with co from generate_cos(cobase) (* From now, co is a coherence order *) let coi = co & int let coe = co \ coi (* Compute fr *) let fr = (invrf ; co) \ id let fri = fr & int let fre = fr \ fri show co,fr herd-herdtools7-1ca343e/herd/libdir/cos-opt.cat000066400000000000000000000014131475314470400214050ustar00rootroot00000000000000"Generate co's" (* generates possible co's, optimized version *) (* co observations in test *) let invrf = rf^-1 let obsco = let ww = po-loc & (W * W) and rw = rf ; (po-loc & (R * W)) and wr = ((po-loc & (W * R)) ; invrf) \ id and rr = (rf ; (po-loc & (R * R)) ; invrf) \ id in (ww|rw|wr|rr) (* The following applies to C only, where RMW is both R and W *) let rmwco = let _RMW = R & W in rf & (W * _RMW) (* co observation by atomicity *) let cobase = obsco|rmwco|co0 (* Catch uniproc violations early *) acyclic cobase as ConsCo include "cross.cat" with co from generate_cos(cobase) (* From now, co is a coherence order *) let coi = co & int let coe = co \ coi (* Compute fr *) let fr = (invrf ; co) \ id let fri = fr & int let fre = fr \ fri show co,fr herd-herdtools7-1ca343e/herd/libdir/cos.cat000066400000000000000000000001351475314470400206050ustar00rootroot00000000000000"Generate co's" if "cos-opt" include "cos-ok-opt.cat" else include "cos-no-opt.cat" end herd-herdtools7-1ca343e/herd/libdir/coscat.cat000066400000000000000000000007251475314470400213020ustar00rootroot00000000000000"Uniproc, no co generated" (* Utilities *) let invrf = rf^-1 let WW(r) = r & (W * W) let RW(r) = r & (R * W) (* Collect constraints on U order *) let U0 = po-loc | rf | co0 let rec U = U0 | WW(U;invrf)\id (* WR observation of co *) | RW(invrf;U)\id (* RW observation of co *) | U;U let co = WW(U) and fr = RW(U) (* From now, co is a coherence order *) let coi = co & int let coe = co \ coi (* Compute fr *) let fri = fr & int let fre = fr \ fri show fr,co herd-herdtools7-1ca343e/herd/libdir/cosllh.cat000066400000000000000000000011471475314470400213110ustar00rootroot00000000000000"Generate co's igoring load-load hazards" (* generates possible co's *) (* co observations in test *) let invrf = rf^-1 let obsco = let ww = po-loc & (W * W) and rw = rf ; (po-loc & (R * W)) and wr = (po-loc & (W * R)) ; invrf and rr = 0 in (ww|rw|wr|rr) \ id let RMW = R & W let rmwco = rf & (W * RMW) (* co observation by atomicity *) let cobase = obsco|rmwco|co0 (* Catch uniproc violations early *) acyclic cobase as ConsCo include "cross.cat" with co from generate_cos(cobase) let coe = co & ext let coi = co & int let fr = (invrf ; co) \ id let fre = fr & ext let fri = fr & int show co,fr herd-herdtools7-1ca343e/herd/libdir/cpp11.cfg000066400000000000000000000007671475314470400207500ustar00rootroot00000000000000macros c11.def model c11_partialSC.cat graph cluster squished true showevents noregs movelabel true fontsize 8 #scale 0.75 xscale 2.0 yscale 1.5 arrowsize 0.8 showinitrf false showfinalrf false splines spline pad 0.1 unshow data unshow addr doshow dd edgeattr dd,color,indigo edgeattr hb,color,indigo edgeattr co,color,blue edgeattr mo,color,blue edgeattr dr,color,darkgreen edgeattr scp,color,violetred3 edgeattr S,color,violetred2 edgeattr sw,color,violetred1 symetric dr,ur showraw hb edgemerge true herd-herdtools7-1ca343e/herd/libdir/cross.cat000066400000000000000000000013621475314470400211550ustar00rootroot00000000000000Cross (* Utilities for combining co's *) (* Compute linearisations per locations *) let co_locs (pco,wss) = let rec do_locs wss = match wss with || {} -> {} || ws ++ wss -> linearisations(ws,pco) ++ do_locs(wss) end in do_locs(wss) (* Cross product linearisations *) let cross = let rec do_cross (k,ys,oss) = match oss with || {} -> ys ++ k || os ++ oss -> let rec call_rec (k,os) = match os with || {} -> k || o ++ os -> call_rec (do_cross (k,o | ys,oss),os) end in call_rec (k,os) end in fun oss -> do_cross ({},0,oss) (* Generate co's that extend partial order pco *) let generate_orders(s,pco) = cross (co_locs (pco,partition s)) let generate_cos(pco) = generate_orders(W,pco) herd-herdtools7-1ca343e/herd/libdir/ctrl-bis.cat000066400000000000000000000052401475314470400215420ustar00rootroot00000000000000include "ncos.cat" (* Utilities *) let roots(r) = domain(r) \ range(r) let succs (e,r) = range ([e];r) let mapset2rel f = let rec map_rec xs = match xs with || {} -> 0 || x ++ xs -> f x | map_rec xs end in map_rec let mapset2set f = let rec map_rec xs = match xs with || {} -> {} || x ++ xs -> f x | map_rec xs end in map_rec (* Basic definitions *) let poDorW = [PoD|W];po;[PoD|W] let nextDorW = poDorW \ (poDorW;poDorW) let DpoDorW = [PoD];poDorW (* Add pair dw for w in ws More precisely: addD d (ws,dw) = dw U {(d,w) | w in ws} *) let addD d = let rec do_rec ws = match ws with || {} -> fun k -> k || w ++ ws -> let kws = do_rec ws in fun k -> (d,w) ++ kws k end in do_rec (* Set combination: union of equiv-related sets *) let addifequiv (equiv,ws0) = mapset2set (fun w -> succs (w,equiv) & ws0) let combine (equiv,ws1,ws2) = addifequiv (equiv,ws1) ws2 | addifequiv (equiv,ws2) ws1 (* Tree scan: returns ws,dw, where ws is the set of writes always performed at this level and dw is the relation from PoD to writes always performed *) let rec case_disjunction (equiv,e) = match { e } & PoD with || {} -> (* e is not a PoD, hence is a write *) let (ws,dw) = write_acc (equiv, (succs (e,nextDorW))) in (e ++ ws,dw) || d ++ es -> (* e is a PoD *) let (ws,dw) = keep_equiv_writes (equiv, (succs (d,nextDorW))) in (ws,addD d ws dw) end and write_acc (equiv,es) = match es with || {} -> ({},0) || e ++ es -> let (ws_e,dw_e) = case_disjunction (equiv, e) and (ws_es,dw_es) = write_acc (equiv, es) in (ws_e|ws_es, dw_e|dw_es) end (* Warning, base case is on singleton *) and keep_equiv_writes (equiv,es) = match es with || {} -> ({},0) (* No successors, ie no W po-after, special case *) || e ++ es -> match es with || {} -> case_disjunction(equiv,e) (* Singleton = base case *) || f ++ fs -> let (ws_e,dw_e) = case_disjunction(equiv,e) and (ws_es,dw_es) = keep_equiv_writes(equiv,es) in (combine (equiv,ws_e,ws_es), dw_e|dw_es) end end (* Final call *) let zyva equiv = mapset2rel (fun r -> let (ws,dw) = case_disjunction(equiv,r) in dw) let intrinsic = (iico_data | iico_ctrl)+ let udr r = domain r | range r let generated-by-stxr = udr(same-instr;[range(rmw)]) let rf-reg-restrict = let NW = ~generated-by-stxr in [NW];rf-reg let dd = (rf-reg | intrinsic)+ #let dd-restrict = (rf-reg-restrict | intrinsic)+ let to-PoD = [R]; dd; [PoD] let pre-ctrl = to-PoD; po; [W] let Dmins = roots(DpoDorW) let Dm=Dmins*Dmins let always-exec equiv = let DW = zyva equiv Dmins in to-PoD; DW let ctrlequiv equiv = pre-ctrl \ (always-exec equiv) herd-herdtools7-1ca343e/herd/libdir/ctrl.cat000066400000000000000000000056111475314470400207710ustar00rootroot00000000000000(* Utilities *) let roots(r) = domain(r) \ range(r) let succs (e,r) = range ([e];r) let mapset2rel f = let rec map_rec xs = match xs with || {} -> 0 || x ++ xs -> f x | map_rec xs end in map_rec let mapset2set f = let rec map_rec xs = match xs with || {} -> {} || x ++ xs -> f x | map_rec xs end in map_rec (* Basic definitions *) let poDorW = [PoD|W];po;[PoD|W] let nextDorW = poDorW \ (poDorW;poDorW) let sibling = let inv = nextDorW^-1 in fun s -> ([s];inv;nextDorW;[s])\(id|inv|nextDorW) let DpoDorW = [PoD];poDorW (* Add pair dw for w in ws More precisely: addD d (ws,dw) = dw U {(d,w) | w in ws} *) let addD d = let rec do_rec ws = match ws with || {} -> fun k -> k || w ++ ws -> let kws = do_rec ws in fun k -> (d,w) ++ kws k end in do_rec (* Set combination: union of equiv-related sets *) let addifequiv (equiv,ws0) = mapset2set (fun w -> succs (w,equiv) & ws0) let combine (equiv,ws1,ws2) = addifequiv (equiv,ws1) ws2 | addifequiv (equiv,ws2) ws1 (* Tree scan: returns ws,dw, where ws is the set of writes always performed at this level and dw is the relation from PoD to writes always performed *) let rec case_disjunction (equiv,e) = match { e } & PoD with || {} -> (* e is not a PoD, hence is a write *) let (ws,dw) = write_acc (equiv, (succs (e,nextDorW))) in (e ++ ws,dw) || d ++ es -> (* e is a PoD *) let nexts = (succs (d,nextDorW)) in match sibling(nexts) with || {} -> (* Only one branch, nothing equivalent *) ({},0) || _e ++ _es -> let (ws,dw) = keep_equiv_writes (equiv,nexts) in (ws,addD d ws dw) end end and write_acc (equiv,es) = match es with || {} -> ({},0) || e ++ es -> let (ws_e,dw_e) = case_disjunction (equiv, e) and (ws_es,dw_es) = write_acc (equiv, es) in (ws_e|ws_es, dw_e|dw_es) end (* Warning, base case is on singleton *) and keep_equiv_writes (equiv,es) = match es with || {} -> ({},0) (* No successors, ie no W po-after, special case *) || e ++ es -> match es with || {} -> case_disjunction(equiv,e) (* Singleton = base case *) || f ++ fs -> let (ws_e,dw_e) = case_disjunction(equiv,e) and (ws_es,dw_es) = keep_equiv_writes(equiv,es) in (combine (equiv,ws_e,ws_es), dw_e|dw_es) end end (* Final call *) let zyva equiv = mapset2rel (fun r -> let (ws,dw) = case_disjunction(equiv,r) in dw) let intrinsic = (iico_data | iico_ctrl)+ let udr r = domain r | range r let generated-by-stxr = udr(same-instr;[range(lxsx)]) let rf-reg-restrict = let NW = ~generated-by-stxr in [NW];rf-reg let dd = (rf-reg | intrinsic)+ let dd-restrict = (rf-reg-restrict | intrinsic)+ let to-PoD = [R]; dd-restrict; [PoD] let pre-ctrl = to-PoD; po; [W] let Dmins = roots(DpoDorW) let Dm=Dmins*Dmins let always-exec equiv = let DW = zyva equiv Dmins in to-PoD; DW let ctrlequiv equiv = pre-ctrl \ (always-exec equiv) herd-herdtools7-1ca343e/herd/libdir/deps-instances.cat000066400000000000000000000014141475314470400227420ustar00rootroot00000000000000include "ctrl.cat" let data = [R]; dd-restrict; [DATA]; intrinsic; [W] let addr = [R]; dd-restrict; [NDATA]; intrinsic; [M] let pom = po & (M*M) let sim = (same-instr & ((EXEC*SPEC) | (SPEC*EXEC))) \ id (* Alternative computation of equiv-spec, by intersection with equivalent histories at the instance level *) let instances = classes(same-instance) let depi = lift(instances,(rf-reg-restrict|rfi)^-1) in let diffw =(loc & (W * W)) \ id let diff = ((rfe^-1;diffw;rf)|(rf^-1;diffw;rfe)) let diffi = lift(instances,diff) let bisim = delift(bisimulation(depi,lift(instances,same-instr)\diffi))\id let equiv = (W*W) & bisim let ctrl = ctrlequiv equiv let AE = always-exec equiv let DW = zyva equiv Dmins let rf-mem = rf \ rf-reg show rf-reg show rf-mem as rf show co|fr as ca herd-herdtools7-1ca343e/herd/libdir/deps-new.cat000066400000000000000000000017711475314470400215520ustar00rootroot00000000000000include "ctrl.cat" let new-data = [R]; dd-restrict; [DATA]; intrinsic; [W] let new-addr = [R]; dd-restrict; [NDATA]; intrinsic; [M] let pom = po & (M*M) let sim = (same-instr & ((EXEC*SPEC) | (SPEC*EXEC))) \ id (* Original computation of equiv, by exclusion of differences in dependencies *) #let ddp = dd-restrict^-1; (po | po^-1); dd-restrict #let equiv = sim & (M*M) \ ddp (* Alternative computation of equiv-spec, by intersection with equivalent histories *) let instances = classes(same-instance) let depi = lift(instances,(rf-reg|rfi)^-1) #pairs of memory reads that read from different writes, one of which being external let diffw =(loc & (W * W)) \ id let diff = ((rfe^-1;diffw;rf)|(rf^-1;diffw;rfe)) let diffi = lift(instances,diff) let bisim = fulldelift(bisimulation(depi,lift(instances,same-instr)\diffi))\id let equiv = sim & (M*M) & bisim let new-ctrl = ctrlequiv equiv let AE = always-exec equiv let DW = zyva equiv Dmins let rf-mem = rf \ rf-reg show rf-reg show rf-mem as rf show co|fr as ca herd-herdtools7-1ca343e/herd/libdir/deps.cat000066400000000000000000000013061475314470400207550ustar00rootroot00000000000000include "ctrl.cat" let data = [R]; dd-restrict; [DATA]; intrinsic; [W] let addr = [R]; dd-restrict; [NDATA]; intrinsic; [M] let sim = (same-instr & ((EXEC*SPEC) | (SPEC*EXEC))) \ id (* Computation of equiv-spec, by intersection with equivalent histories *) let co-step = let ww-loc = [W];po-loc;[W] in ww-loc\(ww-loc;ww-loc) let dep = (iico_data|iico_ctrl|rf-reg-restrict|rfi|co-step)^-1 let diffw =(loc & (W * W)) \ id let diff = ((rfe^-1;diffw;rf)|(rf^-1;diffw;rfe)) let bisim = bisimulation(dep,same-static\diff)\id let equiv = (W*W) & bisim let ctrl = ctrlequiv equiv let AE = always-exec equiv let DW = zyva equiv Dmins let rf-mem = rf \ rf-reg show rf-reg show rf-mem as rf show co|fr as ca herd-herdtools7-1ca343e/herd/libdir/deps.cfg000066400000000000000000000007711475314470400207520ustar00rootroot00000000000000doshow addr,data,ctrl,rmw edgeattr rf-reg,color,red3 edgeattr intrinsic,color,grey edgeattr new-addr,color,indigo edgeattr new-data,color,indigo edgeattr new-ctrl,color,indigo edgeattr rmw,color,darkgreen edgeattr equiv,color,violetred edgeattr bisim,color,violetred1 edgeattr equiv-spec,color,violetred2 edgeattr same-instr,color,green3 edgeattr same-static,color,green4 edgeattr equiv,constraint,false edgeattr bisim,constraint,false symetric equiv,same-instr,same-instance,bisim,equiv-spec,same-static herd-herdtools7-1ca343e/herd/libdir/doc64.cat000066400000000000000000000042211475314470400207400ustar00rootroot00000000000000"AArch64, follow documentation" include "cos.cat" (* Uniproc *) acyclic po-loc | rf | fr | co as uniproc (* Utilities *) let dd = addr | data let rdw = po-loc & (fre;rfe) let detour = po-loc & (coe ; rfe) let addrpo = addr;po let com = fr | co | rf empty rmw & (fre;coe) as atomic include "aarch64fences.cat" let ci0 = ctrlisb | detour let ii0 = dd | rfi | rdw let cc0 = dd | ctrl | addrpo let ic0 = 0 include "ppo.cat" let acq = (A * M) & po let rel = (M * L) & po let ppo = ppo | acq let strongf = dmb.sy & (M * M) | dsb.sy & (M * M) | dmb.st & (W * W) | dsb.st & (W * W) | dmb.ld & (R * M) | dsb.ld & (R * M) let weakf = rel let fence = strongf | weakf let hb = (R * M) & fence | rfe | ppo acyclic hb as thin_air (* Now we take "observed" as defined in the doc *) let hbstar = hb* let comstar = (fr|rf|co)* (* prop is (almost) as before, basically fence effect *) (* coe? added, given the definition of observed writes: A write is said to be observed by an observer.. - when a subsequent read by the same observer return the values written by the observed write, or written by a write [to that location by any observer] that is sequenced in the Coherence order of the location after the observed write. -> rfe - A subsequent write of the location by the same observer is sequenced in the Coherence order of the location after the observed write -> coe *) (* Observation of external accesses *) let observe-write = rfe|coe let observe-read = fre let observe-access = observe-write|observe-read let prop_base = observe-access?;fence;hbstar let prop = prop_base & (W * W) | (comstar; prop_base*; strongf; hbstar) (* Observer: a thread that performs two observations, the second one is relatively new we assume: fre|coe ---> the target write is observed after the source event *) let observer = observe-write; ppo; (fre|coe) | observe-access; fence ; (fre|coe) | observe-access;(L * A) & po;fre irreflexive prop+;observer as observation (* As before *) let prop_al = (L * A) & (rf | po) | (A * L) & fr let xx = (W * W) & (X * X) & po acyclic co | prop | xx | prop_al;hbstar as propagation herd-herdtools7-1ca343e/herd/libdir/enslip.cfg000066400000000000000000000000411475314470400212770ustar00rootroot00000000000000conf apoil.cfg showevents noregs herd-herdtools7-1ca343e/herd/libdir/enumerations.cat000066400000000000000000000071151475314470400225370ustar00rootroot00000000000000(* * The Armv8 Application Level Memory Model. * * This is a machine-readable, executable and formal artefact, which aims to be * the latest stable version of the Armv8 memory model. * If you have comments on the content of this file, please send an email to * memory-model@arm.com * For a textual version of the model, see section B2.3 of the Armv8 ARM: * https://developer.arm.com/documentation/ddi0487/ * * Authors: * Jade Alglave * Nikos Nikoleris * Artem Khyzha * * Copyright (C) 2016-present, Arm Ltd. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 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. * * Neither the name of ARM nor the names of its contributors may be * used to endorse or promote products derived from this software * without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT * HOLDER 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. *) include "aarch64fences.cat" let Imp = NExp let C_TLBI = TLBI & domain(po; [dsb.full]) let C_IC = IC & domain(po; [dsb.full]) let add_pair p = map (fun r -> (p | r)) let rec add_both_choices (rs,wts) = match wts with || {} -> rs || wt ++ wts -> let wt = wt ++ 0 in (* Change pair into relation *) let tw = wt^-1 in (* Notice, ^-1 could operate on pairs directly *) let r1 = add_pair wt rs and r2 = add_pair tw rs in let rs = r1|r2 in add_both_choices (rs,wts) end (* takes a relation "unordered-pairs" of the form [X]; r; [Y] where "X" and "Y" are disjoint and "r" is meant to be symmetric and a relation "rel", and returns a set of acyclic relations consistent with "rel" and ordering the unordered pairs one way or the other. *) let enumerate-ordered-pairs (unordered-pairs,rel) = let no-choice = rel & (unordered-pairs | unordered-pairs^-1) in let need-choosing = unordered-pairs \ (no-choice | no-choice^-1) in add_both_choices ({no-choice},need-choosing) let TLBI-Imp_TTD_R-pairs = inv-scope & ((C_TLBI * (Imp & TTD & R)) \ (TLBInXS * PTEXS) \ ((~TLBIIS) * (Imp & TTD & R)) & ext) let all-TLBI-Imp_TTD_R-enums rel = enumerate-ordered-pairs ( TLBI-Imp_TTD_R-pairs, rel ) let all-DC-Exp_W-enums rel = enumerate-ordered-pairs ( scl & (DC.CVAU * (Exp & W)), rel | (IW * (_\IW)) ) let all-IC-Imp_Instr_R-enums rel = enumerate-ordered-pairs ( scl & (C_IC * (Imp & Instr & R)), rel ) herd-herdtools7-1ca343e/herd/libdir/fences.cat000066400000000000000000000004151475314470400212650ustar00rootroot00000000000000AllFences include "x86fences.cat" include "armfences.cat" include "ppcfences.cat" include "aarch64fences.cat" (* Correct isb/isync show *) let ctrlcfence = ctrlisb|ctrlisync show isync \ ctrlcfence as isync show isb \ ctrlcfence as isb show ctrl \ ctrlcfence as ctrl herd-herdtools7-1ca343e/herd/libdir/filters.cat000066400000000000000000000010261475314470400214710ustar00rootroot00000000000000filters (* Define filter functions (backward compatibility) *) let A = (try X with {})|(try A with {}) let P = M \ A let WW(r) = r & (W * W) and WR(r) = r & (W * R) and RW(r) = r & (R * W) and RR(r) = r & (R * R) and RM(r) = r & (R * M) and MR(r) = r & (M * R) and WM(r) = r & (W * M) and MW(r) = r & (M * W) and MM(r) = r & (M * M) and AA(r) = r & (A * A) and AP(r) = r & (A * P) and PA(r) = r & (P * A) and PP(r) = r & (P * P) and AM(r) = r & (A * M) and MA(r) = r & (M * A) let noid(r)= r \ id let invrf = rf^-1 let atom = [A] herd-herdtools7-1ca343e/herd/libdir/fulleieio.cat000066400000000000000000000012501475314470400217750ustar00rootroot00000000000000"Model with full eieio" include "filters.cat" include "cos.cat" (* Uniproc *) acyclic po-loc | rf | fr | co as uniproc (* Utilities *) let dd = addr | data let rdw = po-loc & (fre;rfe) let detour = po-loc & (coe ; rfe) let addrpo = addr;po (*******) (* ppo *) (*******) include "ppcfences.cat" (* Initial value *) let ci0 = ctrlisync | detour let ii0 = dd | rfi | rdw let cc0 = dd | po-loc | ctrl | addrpo let ic0 = 0 include "ppo.cat" (**********) (* fences *) (**********) (* Power *) let lwsync = RM(lwsync)|WW(lwsync) let eieio = WW(eieio) (* Common, all arm barriers are strong *) let strong = sync|eieio let light = lwsync show propbase include "ppc-checks.cat" herd-herdtools7-1ca343e/herd/libdir/herd.cat000066400000000000000000000000341475314470400207410ustar00rootroot00000000000000Model include "pretty.cat" herd-herdtools7-1ca343e/herd/libdir/herdcat.cat000066400000000000000000000000371475314470400214340ustar00rootroot00000000000000Model include "prettycat.cat" herd-herdtools7-1ca343e/herd/libdir/ifetch-cos.cat000066400000000000000000000032511475314470400220470ustar00rootroot00000000000000(* Isolating IC IALLU events *) let IC_all = IC & no-loc let IC_loc = IC \ IC_all (* Utilities for combining co's *) (* Compute linearisations per locations *) let co_locs (pco,wss) = let rec do_locs wss = match wss with || {} -> {} || ws ++ wss -> linearisations(ws | IC_all, pco) ++ do_locs(wss) end in do_locs(wss) (* Cross product linearisations *) let cross = let rec do_cross (k,ys,oss) = match oss with || {} -> ys ++ k || os ++ oss -> let rec call_rec (k,os) = match os with || {} -> k || o ++ os -> call_rec (do_cross (k,o | ys,oss),os) end in call_rec (k,os) end in fun oss -> do_cross ({},0,oss) (* Generate co's that extend partial order pco *) let generate_orders(s,pco) = cross (co_locs (pco,partition s)) let generate_cos(pco) = generate_orders(W|DC|IC_loc,pco) let cobase = co0 with wco from generate_cos(cobase) let co = ([W] ; wco ; [W]) & loc (* From now, co is a coherence order *) let coi = co & int let coe = co \ coi (* Custom program order *) let my_po = po \ ((IF * _ )|(_ * IF)) let my_po-loc = my_po & loc unshow po, my_po-loc show my_po (* Custom reads-from *) let irf = rf ; [IF] let ifr = (irf^-1; co) & loc show irf, ifr let base_rf = rf \ irf let base_rfi = base_rf & int let base_rfe = base_rf \ base_rfi unshow rf show base_rf (* Compute fr *) let base_fr = ((base_rf^-1) ; co) \ id let base_fri = base_fr & int let base_fre = base_fr \ base_fri show wco,base_fr (* Auxiliary *) let fe = [IF] ; (same-instance \ (same-instance;[IF])) let fpo = [IF] ; fe ; my_po ; fe^-1 ; [IF] let scl = loc (* FIXME: assuming for now that all locations on different cache lines *) show fe,fpoherd-herdtools7-1ca343e/herd/libdir/kernel.cfg000066400000000000000000000006251475314470400212750ustar00rootroot00000000000000macros kernel.def bell kernel.bell model kernel.cat graph columns squished true showevents noregs movelabel true fontsize 8 xscale 2.0 yscale 1.5 arrowsize 0.8 showinitrf false showfinalrf false showinitwrites false splines spline pad 0.1 edgeattr hb,color,indigo edgeattr co,color,blue edgeattr rb_dep,color,darkgreen edgeattr mb,color,darkgreen edgeattr wmb,color,darkgreen edgeattr rmb,color,darkgreen herd-herdtools7-1ca343e/herd/libdir/kernel.def000066400000000000000000000100441475314470400212700ustar00rootroot00000000000000// ONCE READ_ONCE(X) __load{once}(X) WRITE_ONCE(X,V) { __store{once}(X,V); } // Release Acquire and friends smp_store_release(X,V) { __store{release}(*X,V); } smp_load_acquire(X) __load{acquire}(*X) rcu_assign_pointer(X,V) { __store{release}(X,V); } lockless_dereference(X) __load{lderef}(X) rcu_dereference(X) __load{deref}(X) // Fences smp_mb() { __fence{mb} ; } smp_rmb() { __fence{rmb} ; } smp_wmb() { __fence{wmb} ; } smp_read_barrier_depends() { __fence{rb_dep}; } smp_mb__before_atomic() { __fence{before_atomic} ; } smp_mb__after_atomic() { __fence{after_atomic} ; } smp_mb__after_spinlock() { __fence{after_spinlock} ; } // Exchange xchg(X,V) __xchg{mb}(X,V) xchg_relaxed(X,V) __xchg{once}(X,V) xchg_release(X,V) __xchg{release}(X,V) xchg_acquire(X,V) __xchg{acquire}(X,V) cmpxchg(X,V,W) __cmpxchg{mb}(X,V,W) cmpxchg_relaxed(X,V,W) __cmpxchg{once}(X,V,W) cmpxchg_acquire(X,V,W) __cmpxchg{acquire}(X,V,W) cmpxchg_release(X,V,W) __cmpxchg{release}(X,V,W) // Spinlocks spin_lock(X) { __lock(X) ; } spin_unlock(X) { __unlock(X) ; } spin_trylock(X) __trylock(X) // RCU rcu_read_lock() { __fence{rcu_read_lock}; } rcu_read_unlock() { __fence{rcu_read_unlock};} synchronize_rcu() { __fence{sync}; } synchronize_rcu_expedited() { __fence{sync}; } // Atomic atomic_read(X) READ_ONCE(*X) atomic_set(X,V) { WRITE_ONCE(*X,V) ; } atomic_read_acquire(X) smp_load_acquire(X) atomic_set_release(X,V) { smp_store_release(X,V); } atomic_add(V,X) { __atomic_op(X,+,V) ; } atomic_sub(V,X) { __atomic_op(X,-,V) ; } atomic_inc(X) { __atomic_op(X,+,1) ; } atomic_dec(X) { __atomic_op(X,-,1) ; } atomic_add_return(V,X) __atomic_op_return{mb}(X,+,V) atomic_add_return_relaxed(V,X) __atomic_op_return{once}(X,+,V) atomic_add_return_acquire(V,X) __atomic_op_return{acquire}(X,+,V) atomic_add_return_release(V,X) __atomic_op_return{release}(X,+,V) atomic_fetch_add(V,X) __atomic_fetch_op{mb}(X,+,V) atomic_fetch_add_relaxed(V,X) __atomic_fetch_op{once}(X,+,V) atomic_fetch_add_acquire(V,X) __atomic_fetch_op{acquire}(X,+,V) atomic_fetch_add_release(V,X) __atomic_fetch_op{release}(X,+,V) atomic_inc_return(X) __atomic_op_return{mb}(X,+,1) atomic_inc_return_relaxed(X) __atomic_op_return{once}(X,+,1) atomic_inc_return_acquire(X) __atomic_op_return{acquire}(X,+,1) atomic_inc_return_release(X) __atomic_op_return{release}(X,+,1) atomic_fetch_inc(X) __atomic_fetch_op{mb}(X,+,1) atomic_fetch_inc_relaxed(X) __atomic_fetch_op{once}(X,+,1) atomic_fetch_inc_acquire(X) __atomic_fetch_op{acquire}(X,+,1) atomic_fetch_inc_release(X) __atomic_fetch_op{release}(X,+,1) atomic_sub_return(V,X) __atomic_op_return{mb}(X,-,V) atomic_sub_return_relaxed(V,X) __atomic_op_return{once}(X,-,V) atomic_sub_return_acquire(V,X) __atomic_op_return{acquire}(X,-,V) atomic_sub_return_release(V,X) __atomic_op_return{release}(X,-,V) atomic_fetch_sub(V,X) __atomic_fetch_op{mb}(X,-,V) atomic_fetch_sub_relaxed(V,X) __atomic_fetch_op{once}(X,-,V) atomic_fetch_sub_acquire(V,X) __atomic_fetch_op{acquire}(X,-,V) atomic_fetch_sub_release(V,X) __atomic_fetch_op{release}(X,-,V) atomic_dec_return(X) __atomic_op_return{mb}(X,-,1) atomic_dec_return_relaxed(X) __atomic_op_return{once}(X,-,1) atomic_dec_return_acquire(X) __atomic_op_return{acquire}(X,-,1) atomic_dec_return_release(X) __atomic_op_return{release}(X,-,1) atomic_fetch_dec(X) __atomic_fetch_op{mb}(X,-,1) atomic_fetch_dec_relaxed(X) __atomic_fetch_op{once}(X,-,1) atomic_fetch_dec_acquire(X) __atomic_fetch_op{acquire}(X,-,1) atomic_fetch_dec_release(X) __atomic_fetch_op{release}(X,-,1) atomic_xchg(X,V) __xchg{mb}(X,V) atomic_xchg_relaxed(X,V) __xchg{once}(X,V) atomic_xchg_release(X,V) __xchg{release}(X,V) atomic_xchg_acquire(X,V) __xchg{acquire}(X,V) atomic_cmpxchg(X,V,W) __cmpxchg{mb}(X,V,W) atomic_cmpxchg_relaxed(X,V,W) __cmpxchg{once}(X,V,W) atomic_cmpxchg_acquire(X,V,W) __cmpxchg{acquire}(X,V,W) atomic_cmpxchg_release(X,V,W) __cmpxchg{release}(X,V,W) atomic_sub_and_test(V,X) __atomic_op_return{mb}(X,-,V) == 0 atomic_dec_and_test(X) __atomic_op_return{mb}(X,-,1) == 0 atomic_inc_and_test(X) __atomic_op_return{mb}(X,+,1) == 0 atomic_add_negative(V,X) __atomic_op_return{mb}(X,+,V) < 0 herd-herdtools7-1ca343e/herd/libdir/lessrelaxed.cat000066400000000000000000000014371475314470400223420ustar00rootroot00000000000000"Less Relaxed ARM llh model" include "filters.cat" include "cosllh.cat" (* Uniproc *) let poi = WW(po-loc) | RW(po-loc) | WR(po-loc) let complus = fr|rf|co|(co;rf)|(fr;rf) irreflexive poi;complus as uniproc (* Utilities *) let dd = addr | data let rdw = po-loc & (fre;rfe) let detour = po-loc & (coe ; rfe) let addrpo = addr;po (*******) (* ppo *) (*******) include "armfences.cat" (* Initial value *) let ci0 = ctrlisb | detour let ii0 = dd | rfi | rdw let cc0 = dd | ctrl | addrpo | WW(po-loc) | RW(po-loc) | rdw | detour (* po-loc replaced *) let ic0 = 0 include "ppo.cat" (**********) (* fences *) (**********) (* ARM *) let dmb.st=WW(dmb.st) let dsb.st=WW(dsb.st) (* Common, all arm barriers are strong *) let strong = dmb|dsb|dmb.st|dsb.st let light = 0 include "ppc-checks.cat" herd-herdtools7-1ca343e/herd/libdir/mini.cat000066400000000000000000000001441475314470400207550ustar00rootroot00000000000000"Really minimal" include "cross.cat" with co from generate_cos(co0) show co show rf^-1 ; co as fr herd-herdtools7-1ca343e/herd/libdir/minimal.cat000066400000000000000000000001761475314470400214540ustar00rootroot00000000000000"Minimal model" include "fences.cat" include "cross.cat" with co from generate_cos(co0) let fr = (rf^-1 ; co)\id show co,fr herd-herdtools7-1ca343e/herd/libdir/minimalcat.cat000066400000000000000000000001251475314470400221360ustar00rootroot00000000000000"Minimal model" include "fences.cat" let co=co0+ let fr=(rf^-1;co) \ id show co,fr herd-herdtools7-1ca343e/herd/libdir/mips-tso.cat000066400000000000000000000004761475314470400216040ustar00rootroot00000000000000MIPS-TSO include "filters.cat" include "cos.cat" (* Uniproc check *) let com = rf | fr | co acyclic po-loc | com as uniproc (* Atomic *) empty rmw & (fre;coe) as atomic (* ppo, choosing pso at the moment *) include "mipsfences.cat" let ppo = (po \ (W*R)) | sync let ghb = ppo | rfe | fr | co acyclic ghb as tso herd-herdtools7-1ca343e/herd/libdir/mips.cat000066400000000000000000000004761475314470400210010ustar00rootroot00000000000000MIPS include "mipsfences.cat" include "cos.cat" (* Uniproc check *) let com = rf | fr | co acyclic po-loc | com as uniproc (* Atomic *) empty rmw & (fre;coe) as atomic (* ppo, choosing pso at the moment *) include "mipsfences.cat" let ppo = po & (R * M) | sync let ghb = ppo | rfe | fr | co acyclic ghb as pso herd-herdtools7-1ca343e/herd/libdir/mipsfences.cat000066400000000000000000000001601475314470400221530ustar00rootroot00000000000000MIPSFences (* Fences *) let sync = try fencerel(SYNC) with 0 show sync (* Dependencies *) show data,addr,ctrl herd-herdtools7-1ca343e/herd/libdir/naked.cat000066400000000000000000000000341475314470400211010ustar00rootroot00000000000000Naked include "fences.cat" herd-herdtools7-1ca343e/herd/libdir/ncos.cat000066400000000000000000000004471475314470400207710ustar00rootroot00000000000000"Generate co's" include "cross.cat" let invrf = rf^-1 let cobase = co0 with co from generate_orders(W\SPEC,cobase) (* From now, co is a coherence order *) let coi = co & int let coe = co \ coi (* Compute fr *) let fr = ([EXEC]; invrf ; co; [EXEC]) \ id let fri = fr & int let fre = fr \ fri herd-herdtools7-1ca343e/herd/libdir/ncross.cat000066400000000000000000000013661475314470400213370ustar00rootroot00000000000000Cross (* Utilities for combining co's *) (* Compute linarisations per locations *) let co_locs (pco,wss) = let rec do_locs wss = match wss with || {} -> {} || ws ++ wss -> linearisations(ws,pco) ++ do_locs(wss) end in do_locs(wss) (* Cross product linearisations *) let cross = let rec do_cross (k,ys,oss) = match oss with || {} -> ys ++ k || os ++ oss -> let rec call_rec (k,os) = match os with || {} -> k || o ++ os -> call_rec (do_cross (k,o | ys,oss),os) end in call_rec (k,os) end in fun oss -> do_cross ({},0,oss) (* Generate co's that extend partial order pco *) let generate_orders(s,pco) = cross (co_locs (pco,partition s)) let generate_cos(pco) = generate_orders(W\SPEC,pco) herd-herdtools7-1ca343e/herd/libdir/ppc-checks.cat000066400000000000000000000006401475314470400220420ustar00rootroot00000000000000PPCChecks let fence = strong|light (* happens before *) let hb = ppo | fence | rfe acyclic hb as thinair (* prop *) let hbstar = hb* let propbase = (fence|(rfe;fence));hbstar let chapo = rfe|fre|coe|(fre;rfe)|(coe;rfe) let prop = propbase & (W * W) | (chapo? ; propbase*; strong; hbstar) acyclic co|prop as propagation irreflexive fre;prop;hbstar as observation let xx = po & (X * X) acyclic co | xx as scXX herd-herdtools7-1ca343e/herd/libdir/ppc.cat000066400000000000000000000012421475314470400206030ustar00rootroot00000000000000PPC (* Model for Power *) include "cos.cat" (* Uniproc *) acyclic po-loc | rf | fr | co as scperlocation (* Atomic *) empty rmw & (fre;coe) as atomic (* Utilities *) let dd = addr | data let rdw = po-loc & (fre;rfe) let detour = po-loc & (coe ; rfe) let addrpo = addr;po (*******) (* ppo *) (*******) include "ppcfences.cat" show isync,ctrlisync (* Initial value *) let ci0 = ctrlisync | detour let ii0 = dd | rfi | rdw let cc0 = dd | po-loc | ctrl | addrpo let ic0 = 0 include "ppo.cat" (* fences *) let lwsync = lwsync \ (W * R) let eieio = eieio & (W * W) (* All arm barriers are strong *) let strong = sync let light = lwsync|eieio include "ppc-checks.cat" herd-herdtools7-1ca343e/herd/libdir/ppcfences.cat000066400000000000000000000005401475314470400217670ustar00rootroot00000000000000PPCFences let sync = try fencerel(SYNC) with 0 let lwsync = try fencerel(LWSYNC) with 0 let eieio = try fencerel(EIEIO) with 0 let isync = try fencerel(ISYNC) with 0 show sync,lwsync,eieio (* Dependencies *) show data,addr let ctrlisync = try ctrlcfence(ctrl,ISYNC) with 0 show ctrlisync show isync \ ctrlisync as isync show ctrl \ ctrlisync as ctrl herd-herdtools7-1ca343e/herd/libdir/ppo.cat000066400000000000000000000005661475314470400206270ustar00rootroot00000000000000PPO (* Computes ppo the ARM and PPC way *) (* Fixpoint from i -> c in instructions and transitivity *) let rec ci = ci0 | (ci;ii) | (cc;ci) and ii = ii0 | ci | (ic;ci) | (ii;ii) and cc = cc0 | ci | (ci;ic) | (cc;cc) and ic = ic0 | ii | cc | (ic;cc) | (ii ; ic) (* | ci inclus dans ii et cc *) let ppo = let ppoR = ii & (R * R) and ppoW = ic & (R * W) in ppoR | ppoW herd-herdtools7-1ca343e/herd/libdir/pretty.cat000066400000000000000000000025271475314470400213570ustar00rootroot00000000000000"Model pretty print" (* Same as model, shows only basic relations *) include "filters.cat" include "cross.cat" with co from generate_cos(co0) let fr = rf^-1;co let fre = fr & ext let coe = co & ext show fr,co (* Uniproc *) acyclic po-loc | rf | fr | co as uniproc (* Utilities *) let dd = addr | data let rdw = po-loc & (fre;rfe) let detour = po-loc & (coe ; rfe) let addrpo = addr;po (* Define fence relations, and correct isync/isb show *) include "armfences.cat" include "aarch64fences.cat" include "ppcfences.cat" let ctrlcfence = ctrlisync|ctrlisb show isync \ ctrlcfence as isync show isb \ ctrlcfence as isb show ctrl \ ctrlcfence as ctrl (*******) (* ppo *) (*******) (* Initial value *) let ci0 = ctrlisync| ctrlisb | detour let ii0 = dd | rfi | rdw let cc0 = dd | po-loc | ctrl | addrpo let ic0 = 0 include "ppo.cat" (**********) (* fences *) (**********) (* Power *) let lwsync_eff = RM(lwsync)|WW(lwsync) let eieio_eff = WW(eieio) show sync, lwsync, eieio (* ARM *) let dmb.st_eff=WW(dmb.st) let dsb.st_eff=WW(dsb.st) show dmb, dsb, dmb.st, dsb.st (* AArch64 *) let f64 = dsb.sy | dmb.sy | WW(dsb.st) | WW(dmb.st) | RM(dmb.ld) | RM(dsb.ld) show dmb.sy,dsb.sy,dmb.st,dsb.st,dmb.ld,dsb.ld (* Common, all arm barriers are strong *) let strong = sync|dmb|dsb|dmb.st_eff|dsb.st_eff|f64 let light = lwsync_eff|eieio_eff include "ppc-checks.cat" herd-herdtools7-1ca343e/herd/libdir/prettycat.cat000066400000000000000000000023701475314470400220430ustar00rootroot00000000000000"Model pretty print" include "filters.cat" (* Same as model, shows only basic relations *) (* Uniproc *) (**********************) (* Computes co and fr *) (**********************) let invrf=(rf) ^ -1 (* co observations in test *) let obsco = (WW(po-loc) |rf;RW(po-loc) |noid(WR(po-loc);invrf) |noid(rf;RR(po-loc);invrf)) let cobase = obsco|co0 acyclic cobase as uniproc let co = cobase+ let fr = noid(invrf;co) show fr show co let coi = co & int and fri = fr & int let coe = co \ coi and fre = fr \ fri (* Utilities *) let dd = addr | data let rdw = po-loc & (fre;rfe) let detour = po-loc & (coe ; rfe) let addrpo = addr;po (*******) (* ppo *) (*******) include "armfences.cat" include "ppcfences.cat" show isb,ctrlisb,isync,ctrlisync (* Initial value *) let ci0 = ctrlisync | ctrlisb | detour let ii0 = dd | rfi | rdw let cc0 = dd | po-loc | ctrl | addrpo let ic0 = 0 include "ppo.cat" (**********) (* fences *) (**********) (* Power *) let lwsync = RM(lwsync)|WW(lwsync) let eieio = WW(eieio) show sync, lwsync, eieio (* ARM *) let dmb.st=WW(dmb.st) let dsb.st=WW(dsb.st) show dmb, dsb, dmb.st, dsb.st (* Common, all arm barriers are strong *) let strong = sync|dmb|dsb|dmb.st|dsb.st let light = lwsync|eieio include "ppc-checks.cat" herd-herdtools7-1ca343e/herd/libdir/qualcomm.cat000066400000000000000000000015031475314470400216370ustar00rootroot00000000000000"ARM relaxing ppo to accommodate qualcomm behaviors" include "cos.cat" (* Uniproc *) let poi = po-loc let complus = fr|rf|co|(co;rf)|(fr;rf) irreflexive poi;complus as scperlocation (* Utilities *) let dd = addr | data let rdw = po-loc & (fre;rfe) let detour = po-loc & (coe ; rfe) let addrpo = addr;po (*******) (* ppo *) (*******) include "armfences.cat" show isb,ctrlisb (* Initial value *) let ci0 = ctrlisb | detour let ii0 = dd | rfi | rdw let cc0 = dd | ctrl | addrpo | ( po-loc \ ( rfi | (po-loc;rfi))) (* po-loc replaced *) let ic0 = 0 include "ppo.cat" (**********) (* fences *) (**********) let WW = W * W (* ARM *) let dmb.st=dmb.st & WW let dsb.st=dsb.st & WW show dmb, dsb, dmb.st, dsb.st (* Common, all arm barriers are strong *) let strong = dmb|dsb|dmb.st|dsb.st let light = 0 include "ppc-checks.cat" herd-herdtools7-1ca343e/herd/libdir/rc11.cat000066400000000000000000000021401475314470400205650ustar00rootroot00000000000000C RC11 (* * Repaired C11 model, following * "Repairing Sequential Consistency in C/C++11" in PLDI 2017 , by * Ori Lahav, Viktor Vafeiadis, Jeehoon Kang, Chung-Kil Hur, and Derek Dreyer * Cat coding by Simon Colin. *) include "cos.cat" let mo = co let sb = po let myrmw = [RMW] | rmw let rb = (rf^-1; mo) \ id let eco = (rf | mo | rb)+ let rs = [W]; (sb & loc)?; [W & (RLX | REL | ACQ_REL | ACQ | SC)]; (rf; myrmw)* let sw = [(REL | ACQ_REL | SC)]; ([F]; sb)?; rs; rf; [R & (RLX | REL | ACQ | ACQ_REL | SC)]; (sb; [F])?; [(ACQ | ACQ_REL | SC)] let hb = (sb | sw)+ let sbl = sb \ loc let hbl = hb & loc let scb = sb | sbl; hb; sbl | hbl | mo | rb let pscb = ([SC] | [F & SC]; hb?); scb; ([SC] | hb? ; [F & SC]) let pscf = [F & SC]; (hb | hb; eco; hb); [F & SC] let psc = pscb | pscf let cnf = ((W * _) | (_ * W)) & loc \ ((IW * _) | (_ * IW)) let dr = (cnf & ext) \ (hb | hb^-1 | A * A) undefined_unless empty dr as Dr irreflexive hb; eco? as coherence1 irreflexive (myrmw; eco) as coherencermw empty (myrmw & (rb; mo)) as atomicity acyclic psc as SC acyclic (sb | rf) as no-thin-air show hb, eco, psc, rmw herd-herdtools7-1ca343e/herd/libdir/riscv-defs.cat000066400000000000000000000031171475314470400220710ustar00rootroot00000000000000(*****************************************) (* The RISCV Instruction set manual v2.3 *) (*****************************************) (*************) (* Utilities *) (*************) let fence.r.r = [R];fencerel(Fence.r.r);[R] let fence.r.w = [R];fencerel(Fence.r.w);[W] let fence.r.rw = [R];fencerel(Fence.r.rw);[M] let fence.w.r = [W];fencerel(Fence.w.r);[R] let fence.w.w = [W];fencerel(Fence.w.w);[W] let fence.w.rw = [W];fencerel(Fence.w.rw);[M] let fence.rw.r = [M];fencerel(Fence.rw.r);[R] let fence.rw.w = [M];fencerel(Fence.rw.w);[W] let fence.rw.rw = [M];fencerel(Fence.rw.rw);[M] let fence.tso = let f = fencerel(Fence.tso) in ([W];f;[W]) | ([R];f;[M]) let fence = fence.r.r | fence.r.w | fence.r.rw | fence.w.r | fence.w.w | fence.w.rw | fence.rw.r | fence.rw.w | fence.rw.rw | fence.tso let po-loc-no-w = po-loc \ (po-loc?;[W];po-loc) let rsw = rf^-1;rf let AcqRel = AcqRel|Sc (* Compat *) let AQ = (Acq|AcqRel) and RL = (Rel|AcqRel) let AMO = try AMO with (R & W) (* Compat *) let RCsc = (Acq|Rel|AcqRel) & (AMO|X) (*************) (* ppo rules *) (*************) (* Overlapping-Address Orderings *) let r1 = [M];po-loc;[W] and r2 = ([R];po-loc-no-w;[R]) \ rsw and r3 = [AMO|X];rfi;[R] (* Explicit Synchronization *) and r4 = fence and r5 = [AQ];po;[M] and r6 = [M];po;[RL] and r7 = [RCsc];po;[RCsc] and r8 = rmw (* Syntactic Dependencies *) and r9 = [M];addr;[M] and r10 = [M];data;[W] and r11 = [M];ctrl;[W] (* Pipeline Dependencies *) and r12 = [M];(addr|data);[W];rfi;[R] and r13 = [M];addr;[M];po;[W] let ppo = r1 | r2 | r3 | r4 | r5 | r6 | r7 | r8 | r9 | r10 | r11 | r12 | r13 herd-herdtools7-1ca343e/herd/libdir/riscv-total.cat000066400000000000000000000023071475314470400222730ustar00rootroot00000000000000"Risc V total order model" (*****************************************) (* The RISCV Instruction set manual v2.3 *) (*****************************************) (* Notice that herd has defined its own rf relation *) (* Define ppo *) include "riscv-defs.cat" (********************************) (* Generate global memory order *) (********************************) let gmo0 = (* precursor: ie build gmo as an total order that include gmo0 *) loc & (W\FW) * FW | # Final write after any write to the same location ppo | # ppo compatible rfe # extends rf external (* Walk over all linear extensions of gmo0 *) with gmo from linearisations(M\IW,gmo0) (* Add initial writes upfront -- convenient for computing rfGMO *) let gmo = gmo | loc & IW * (M\IW) (**********) (* Axioms *) (**********) (* Compute rf according to the load value axiom, aka rfGMO *) let WR = loc & ([W];(gmo|po);[R]) let rfGMO = WR \ (loc&([W];gmo);WR) (* Check equality of herd rf and of rfGMO *) empty (rf\rfGMO)|(rfGMO\rf) as RfCons (* Atomicity axion *) let infloc = (gmo & loc)^-1 let inflocext = infloc & ext let winside = (infloc;rmw;inflocext) & (infloc;rf;rmw;inflocext) & [W] empty winside as Atomic herd-herdtools7-1ca343e/herd/libdir/riscv-tso-defs.cat000066400000000000000000000033661475314470400227020ustar00rootroot00000000000000(*****************************************) (* The RISCV Instruction set manual v2.3 *) (*****************************************) (*************) (* Utilities *) (*************) let fence.r.r = [R];fencerel(Fence.r.r);[R] let fence.r.w = [R];fencerel(Fence.r.w);[W] let fence.r.rw = [R];fencerel(Fence.r.rw);[M] let fence.w.r = [W];fencerel(Fence.w.r);[R] let fence.w.w = [W];fencerel(Fence.w.w);[W] let fence.w.rw = [W];fencerel(Fence.w.rw);[M] let fence.rw.r = [M];fencerel(Fence.rw.r);[R] let fence.rw.w = [M];fencerel(Fence.rw.w);[W] let fence.rw.rw = [M];fencerel(Fence.rw.rw);[M] let fence.tso = let f = fencerel(Fence.tso) in ([W];f;[W]) | ([R];f;[M]) let fence = fence.r.r | fence.r.w | fence.r.rw | fence.w.r | fence.w.w | fence.w.rw | fence.rw.r | fence.rw.w | fence.rw.rw | fence.tso let po-loc-no-w = po-loc \ (po-loc?;[W];po-loc) let rsw = rf^-1;rf let AcqRel = AcqRel|Sc (* Compat *) let AQ = (Acq|AcqRel) and RL = (Rel|AcqRel) let AMO = try AMO with (R & W) (* Compat *) (* All AMO ops have RCsc annotations *) let RCsc = (Acq|Rel|AcqRel|AMO) & (AMO|X) (*************) (* ppo rules *) (*************) (* Overlapping-Address Orderings *) let r1 = [M];po-loc;[W] and r2 = ([R];po-loc-no-w;[R]) \ rsw and r3 = [AMO|X];rfi;[R] (* Explicit Synchronization *) and r4 = fence and r5 = [AQ];po;[M] and r6 = [M];po;[RL] and r7 = [RCsc];po;[RCsc] and r8 = rmw (* Syntactic Dependencies *) and r9 = [M];addr;[M] and r10 = [M];data;[W] and r11 = [M];ctrl;[W] (* Pipeline Dependencies *) and r12 = [M];(addr|data);[W];rfi;[R] and r13 = [M];addr;[M];po;[W] (* All loads have RCpc Acquire *) and r14 = [R];po;[M] (* All stores have RCpc Release *) and r15 = [M];po;[W] let ppo = r1 | r2 | r3 | r4 | r5 | r6 | r7 | r8 | r9 | r10 | r11 | r12 | r13 | r14 | r15 herd-herdtools7-1ca343e/herd/libdir/riscv-tso.cat000066400000000000000000000010541475314470400217530ustar00rootroot00000000000000RISCV "Risc V partial order model with zTSO extension" (*****************************************) (* The RISCV Instruction set manual v2.3 *) (*****************************************) (***************) (* Definitions *) (***************) (* Define ppo *) include "riscv-tso-defs.cat" (* Compute coherence relation *) include "cos-opt.cat" (**********) (* Axioms *) (**********) (* Sc per location *) acyclic co|rf|fr|po-loc as Coherence (* Main model axiom *) acyclic co|rfe|fr|ppo as Model (* Atomicity axiom *) empty rmw & (fre;coe) as Atomic herd-herdtools7-1ca343e/herd/libdir/riscv.cat000066400000000000000000000010241475314470400211450ustar00rootroot00000000000000RISCV "Risc V partial order model" (*****************************************) (* The RISCV Instruction set manual v2.3 *) (*****************************************) (***************) (* Definitions *) (***************) (* Define ppo *) include "riscv-defs.cat" (* Compute coherence relation *) include "cos-opt.cat" (**********) (* Axioms *) (**********) (* Sc per location *) acyclic co|rf|fr|po-loc as Coherence (* Main model axiom *) acyclic co|rfe|fr|ppo as Model (* Atomicity axiom *) empty rmw & (fre;coe) as Atomic herd-herdtools7-1ca343e/herd/libdir/sc.cat000066400000000000000000000002551475314470400204310ustar00rootroot00000000000000SC include "fences.cat" include "cos.cat" (* Atomic *) empty rmw & (fre;coe) as atom (* Sequential consistency *) show sm\id as si acyclic po | ((fr | rf | co);sm) as sc herd-herdtools7-1ca343e/herd/libdir/sccat.cat000066400000000000000000000006401475314470400211170ustar00rootroot00000000000000"SC, no co generated" (* Include uniproc, for its U pre-order *) include "uniproccat.cat" let S0 = po | U let rec S = S0 | WW(Sloc;invrf)\id (* WR observation of co *) | RW(invrf;Sloc)\id (* RW observation of co *) | S;S and Sloc = S & loc when acyclic S as sc let co = WW(Sloc) and fr = RW(Sloc) show fr,co (* Also check atomic pairs *) let coe = co & ext and fre = fr & ext empty rmw & (fre; coe) as atom herd-herdtools7-1ca343e/herd/libdir/show-deps.cat000066400000000000000000000004701475314470400217340ustar00rootroot00000000000000(* Show dependencies *) show data,addr (* Show of control dependencies is restricted, so as not to clobber diagrams *) let ctrlisb = try ctrl;[ISB];po;[M] with 0 show ctrlisb show (ctrl;[M]) \ ctrlisb as ctrl (* Communication relations *) let rf-mem = rf \ rf-reg show rf-reg show rf-mem as rf show co|fr as ca herd-herdtools7-1ca343e/herd/libdir/simple-arm.cat000066400000000000000000000025111475314470400220670ustar00rootroot00000000000000"Simple ARM arch model" include "armfences.cat" show isb,ctrlisb include "cos.cat" (* Memory is coherent *) acyclic po-loc | fr | rf | co as uniproc (**************) (* Simple ppo *) (**************) let RW = R * W and WW = W * W and RR = R * R let ppo = (* True or False Address Dependency from Load to Store create externally visible order *) addr & RW | (* True Data Dependency from Load to Store creates externally visible order [derives from no visible write speculation rule] *) data & RW | (* NB 'false dependcies included... *) (* Address dependency from load tio load, forgotten by Richarch in its mail *) addr & RR | (* NB 'false dependcies included... *) (* True Control Dependency from Load to Store creates externally visible order [derives no visible write speculation rule] *) ctrl & RW | (* NB 'false dependcies included... *) (* CTRL + ISB will create externally visible order (derives from ISB cannot happen speculatively] *) ctrlisb (**********) (* Fences *) (**********) let dmb.st=dmb.st & WW let dsb.st=dsb.st & WW show dmb, dsb, dmb.st, dsb.st let fence = dsb.st | dmb.st | dsb | dmb (************) (* ordering *) (************) (* Non-fence 'visible order' *) let visible = ppo | fence | rfe (* Fence effect, with A-cumulativity *) let F = ((fr|rf|co)*;fence) acyclic (F | visible) as order herd-herdtools7-1ca343e/herd/libdir/simple-c11.cat000066400000000000000000000053511475314470400217010ustar00rootroot00000000000000"Simple C11" (* Model from POPL'15 article "Common Compiler Optimisations etc." by V. Vafeidis et al. *) (* Some sets *) let CACQ = ACQ | (SC & R) | ACQ_REL let CREL = REL | (SC & W) | ACQ_REL let Access = R | W (* And some id relations *) let a_id = toid(A) let rmw_id = toid(RMW) let crel_id = toid(CREL) let cacq_id = toid(CACQ) let sc_id = toid(SC) let asw = IW * (M \ IW) include "filters.cat" include "cos.cat" (********************) (* Release Sequence *) (********************) (* optimized; rsElem applies to co only.. *) let rsElem = coi | (co;rmw_id) (* Cannot be a compound release sequence *) let breakRseq = (co \ rsElem) let rseq = id | (rsElem \ (breakRseq;co)) (* Alternatives let rseq = rsElem \ (coe;[noRMW];co) let rseq = rsElem \ ((co \ rsElem); co) *) (***************) (* Synchronize *) (***************) let fence_id = toid(F) let fid = (fence_id;po)? let idf = (po;fence_id)? let sw = ext & (crel_id ; fid ; rseq ; rf ; a_id ; idf ; cacq_id) show sw let Y = po let hb = (po | asw | sw)+ let hb-loc = hb & loc (**********) (* Checks *) (**********) (* ConsSC *) (* empty ((hb | co) & (sc * sc)) \ S as ConsSC *) let scp = hb|co acyclic scp as ConsSC with S from linearisations(SC,scp) show S (* Consistent rf for non-atomic accesses *) let rfNA = rf \ AA(rf) empty rfNA \ hb-loc as ConsRFna (* SC Reads *) let S-loc = MM(S) & loc let minWRSC = let aux = WR(S-loc) in aux \ (WW(S-loc);aux) let rfSCSC = sc_id ; rf ; sc_id let rfXSC = (rf;sc_id) \ rfSCSC let X = hb ; minWRSC let badRFSC= (rfSCSC \ minWRSC) | (rfXSC & (hb ; minWRSC)) empty badRFSC as SCReads (* Acyclic happens-before *) irreflexive hb as IrrHB (*************) (* Coherence *) (*************) (* let invrf= rf^-1 irreflexive rf;hb-loc as ConsRFhb let coww = co;hb-loc let corr = co;rf;hb-loc;invrf let cowr = co;hb-loc;invrf let corw = co;rf;hb-loc irreflexive coww as CohWW irreflexive corr as CohRR irreflexive cowr as CohWR irreflexive corw as CohRW We rather consider the alternative: Consider fr = rf^-1 ; co corf = hb;rf coww = hb;co corr = hb;fr;rf cowr = hb;fr corw = hb;co;rf *) let chapo = rf|fr|co|(co;rf)|(fr;rf) acyclic hb-loc | chapo as Coh (* Atomicity *) let cosucc = co \ (co;co) empty (rf;rmw_id) \ (cosucc) as AtRMW (* Races *) let locSomeW = loc \ RR(loc) (* same location, at least a W *) let dr = let r1 = locSomeW & ext in (* By different threads *) let r2 = r1 \ AA(r1) in (* At least one non-atomic *) r2 \ (hb | hb^-1) (* unrelated by hb *) show dr undefined_unless empty dr as dataRace let ur = let r1 = locSomeW & int in (* By the same thread *) let r2 = noid(r1) in (* Different *) r2 \ (po | po^-1) (* unrelated by po *) show ur flag ~empty ur as unsequencedRace herd-herdtools7-1ca343e/herd/libdir/stdlib.cat000066400000000000000000000030641475314470400213060ustar00rootroot00000000000000stdlib (*************************) (* Herd standard library *) (*************************) (* Empty set of events *) let emptyset = domain 0 (* Backward compatibility *) let partition = classes-loc let tag2instrs = tag2events (* Aliases *) let PoD = B let BR = PoD (* Basic relations *) let po-loc = po & loc let rfe = rf & ext let rfi = rf & int (* co0 *) let co0 = loc & ((IW * (W\IW)) | ((W\FW) * FW)) (* Id relation on set *) let toid(s) = [s] (* Turn a fence set into a fence relation *) let fencerel(B) = (po & (_ * B)) ; po (* Control+cfence *) let ctrlcfence(ctrl,CFENCE) = (ctrl & (_ * CFENCE)) ; po (* Make the difference between load-reserve/store conditional and amo insructions *) let lxsx = rmw \ amo (* Backward compatibility *) let inv-field = try inv-domain with 0 (* Some utilities (cpp11) *) let imply (A, B) = ~A | B (* nodetour eliminates the triangle: *) (* .--R2--> c --R3--. *) (* / v *) (* a --------R1-------> b *) let nodetour (R1, R2, R3) = R1 \ ( R2; R3 ) let singlestep (R) = nodetour(R, R, R) procedure subseteq(A, B) = empty (A \ B) end procedure inclusion(r1, r2) = empty r1 \ r2 end procedure total(r,E) = let rt = (r | r^-1) call inclusion((E*E),rt) end (*Union of domain and range*) let udr r = domain r | range r (***************) (* Set library *) (***************) (* Apply function f to each member of a set or relation *) let map f = let rec do_map S = match S with || {} -> {} || e ++ S -> f e ++ do_map S end in do_map let LKW = try LKW with emptyset herd-herdtools7-1ca343e/herd/libdir/tso.cat000066400000000000000000000006361475314470400206340ustar00rootroot00000000000000TSO include "x86fences.cat" include "filters.cat" include "cos.cat" (* Uniproc check *) acyclic po-loc | rf | fr | co (* Atomic *) empty rmw & (fre;coe) (* GHB *) #implied barriers let poWR = [W];po;[R] let i1 = poWR;[A] let i2 = [A];poWR let implied = i1 | i2 #ppo let ppo = [R];po;[R] | [M];po;[W] | [M];po;[MFENCE];po;[M] | implied let ghb = ppo | ((rfe | fr | co);sm) show sm\id as si acyclic ghb as tso herd-herdtools7-1ca343e/herd/libdir/uni.cat000066400000000000000000000001251475314470400206130ustar00rootroot00000000000000"Uniproc model, minimal" include "cos.cat" acyclic po-loc | fr | rf | co as uniproc herd-herdtools7-1ca343e/herd/libdir/uniproc+sca.cat000066400000000000000000000003131475314470400222400ustar00rootroot00000000000000"UNIPROC+SCA" include "cos.cat" (* reflexive same memory access *) let si = sm irreflexive co;si;co;si as sca irreflexive rf;si;fr;si as sca acyclic po-loc | rf | fr | co as uniproc show si\id as si herd-herdtools7-1ca343e/herd/libdir/uniproc-normw-cat.cat000066400000000000000000000007241475314470400234110ustar00rootroot00000000000000"Uniproc model" (**********************) (* Computes co and fr *) (**********************) let invrf=rf -1 (* co observations in test *) let obsco = (WW(po-loc) |(rf;RW(po-loc)) |noid(WR(po-loc);invrf) |noid(rf;RR(po-loc);invrf)) let cobase = obsco|co0 let co = cobase+ let fr = noid(invrf;co) (* notice: avoid self fr (RMW) *) show fr show co (* a few additional shows *) include "fences.cat" (* uni check proper *) irreflexive co as uniproc herd-herdtools7-1ca343e/herd/libdir/uniproc.cat000066400000000000000000000001521475314470400214770ustar00rootroot00000000000000"Uniproc model" include "fences.cat" include "cos.cat" acyclic po-loc | fr | rf | co as sc-per-location herd-herdtools7-1ca343e/herd/libdir/uniproccat.cat000066400000000000000000000006401475314470400221710ustar00rootroot00000000000000"Uniproc, no co generated" (* Utilities *) let invrf = rf^-1 let WW(r) = r & (W * W) let RW(r) = r & (R * W) (* Collect constraints on U order *) let U0 = po-loc | rf | co0 let rec U = U0 | WW(U;invrf)\id (* WR observation of co *) | RW(invrf;U)\id (* RW observation of co *) | U;U when acyclic U as sc-per-location let co = WW(U) and fr = RW(U) show fr,co (* a few additional shows *) include "fences.cat" herd-herdtools7-1ca343e/herd/libdir/web.cfg000066400000000000000000000002721475314470400205700ustar00rootroot00000000000000graph columns squished true showevents memory showinitwrites false fontsize 8 scale 0.75 xscale 1.0 yscale 0.6667 arrowsize 0.5 showinitrf false showfinalrf false splines spline pad 0.1 herd-herdtools7-1ca343e/herd/libdir/x86fences.cat000066400000000000000000000002331475314470400216310ustar00rootroot00000000000000X86Fences let mfence = try fencerel(MFENCE) with 0 let lfence = try fencerel(LFENCE) with 0 let sfence = try fencerel(SFENCE) with 0 show data,addr,ctrl herd-herdtools7-1ca343e/herd/libdir/x86tso-mixed.cat000066400000000000000000000011231475314470400222760ustar00rootroot00000000000000"x86 TSO Mixed" include "x86fences.cat" include "cos.cat" (* Coherence-after *) let ca = fr | co (* Observed-by *) let obs = rfe | fre | coe (* Locally-ordered-before *) let rec lob = po \ ([W]; po; [R]) | [W]; po; [MFENCE]; po; [R] | [W]; po; [R & X] | [W & X]; po; [R] | lob; lob (* Ordered-before *) let rec ob = obs; si | lob | ob; ob (* Internal visibility requirement *) acyclic po-loc | ca | rf as internal (* Atomicity requirement *) empty rmw & (fre;coe) as atomic (* External visibility requirement *) irreflexive ob as external herd-herdtools7-1ca343e/herd/libdir/x86tso.cat000066400000000000000000000006571475314470400212050ustar00rootroot00000000000000X86 TSO include "x86fences.cat" include "filters.cat" include "cos.cat" (* Uniproc check *) let com = rf | fr | co acyclic po-loc | com (* Atomic *) empty rmw & (fre;coe) (* GHB *) #ppo let po_ghb = WW(po) | RM(po) #mfence include "x86fences.cat" #implied barriers let poWR = WR(po) let i1 = MA(poWR) let i2 = AM(poWR) let implied = i1 | i2 let ghb = mfence | implied | po_ghb | rfe | fr | co show implied acyclic ghb as tso herd-herdtools7-1ca343e/herd/libdir/xchg.def000066400000000000000000000002621475314470400207420ustar00rootroot00000000000000//T *xchg(T *p, v) xchg(X,Y) { __xchg{mb}(X,Y) } xchg_relaxed(X,Y) { __xchg{relaxed}(X,Y) } xchg_release(X,Y) { __xchg{release}(X,Y) } xchg_acquire(X,Y) { __xchg{acquire}(X,Y) } herd-herdtools7-1ca343e/herd/loader.ml000066400000000000000000000112101475314470400176570ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (************************************************) (* "load" program in memory, somehow abstracted *) (************************************************) let func_size = Pseudo.func_size let proc_size = 10000 let func_start_addr proc = function | MiscParser.Main -> (proc + 1) * proc_size | MiscParser.FaultHandler -> (proc + 1) * proc_size + func_size module type S = sig type nice_prog type program type start_points type code_segment val load : nice_prog -> program * start_points * code_segment end module Make(A:Arch_herd.S) = struct type nice_prog = A.nice_prog type program = A.program type start_points = A.start_points type code_segment = A.code_segment let preload_labels proc = let add_label lbl addr m = if Label.Map.mem lbl m then Warn.user_error "Label %s occurs more that once" lbl ; Label.Map.add lbl (proc,addr) m in A.fold_label_addr add_label let preload = List.fold_left (fun m ((proc,_,func),code) -> let addr = func_start_addr proc func in preload_labels proc m addr code) Label.Map.empty let convert_lbl_to_offset proc pc mem instr = let labelmap = let open BranchTarget in function | Lbl l -> let tgt_proc, tgt_addr = try Label.Map.find l mem with Not_found -> Warn.user_error "Label %s not found on %s, although used in the instruction %s" (Label.pp l) (Proc.pp proc) (A.dump_instruction instr) in if Proc.equal tgt_proc proc then Offset (tgt_addr - pc) else Warn.user_error "%s cannot refer to %s defined by %s, use register with initial value %s" (Proc.pp proc) (Label.pp l) (Proc.pp tgt_proc) (Label.Full.pp (tgt_proc,l)) | Offset _ as x -> x in A.map_labels_base labelmap instr let rec load_code proc addr mem rets = function | [] -> [],IntMap.add addr (proc,[]) rets | ins::code -> load_ins proc addr mem rets code ins and load_ins proc addr mem rets code = fun x -> match x with | A.Nop -> load_code proc addr mem rets code | A.Instruction ins -> let start,new_rets = load_code proc (addr+A.size_of_ins ins) mem rets code in let new_ins = convert_lbl_to_offset proc addr mem ins in let new_start = (addr,new_ins)::start in let newer_rets = IntMap.add addr (proc,new_start) new_rets in new_start,newer_rets | A.Label (_,ins) -> let start,new_rets = load_ins proc addr mem rets code ins in start,new_rets | A.Symbolic _ | A.Macro (_,_) -> assert false let load prog = let mem = preload prog in let rec load_iter = function | [] -> [],IntMap.empty | ((proc,_,func),code)::prog -> let starts,rets = load_iter prog in let addr = func_start_addr proc func in let start,fin_rets = load_code proc addr mem rets code in (proc,func,start)::starts,fin_rets in let starts,codes = load_iter prog in let mains,fhandlers = List.partition (fun (_,func,_) -> func=MiscParser.Main) starts in let add_fhandler (proc,_,start) = let fhandler = List.find_opt (fun (p,_,_) -> Proc.equal p proc) fhandlers in match fhandler with | Some (_,_,fh_start) -> (proc,start,Some fh_start) | None -> (proc,start,None) in Label.Map.map snd mem,List.map add_fhandler mains,codes end herd-herdtools7-1ca343e/herd/loader.mli000066400000000000000000000030611475314470400200350ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2012-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** "load" program in memory, somehow abstracted *) module type S = sig type nice_prog type program type start_points type code_segment val load : nice_prog -> program * start_points * code_segment end module Make : functor (A:Arch_herd.S) -> S with type nice_prog = A.nice_prog and type program = A.program and type start_points = A.start_points and type code_segment = A.code_segment herd-herdtools7-1ca343e/herd/machAction.ml000066400000000000000000000527621475314470400205000ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Implementation of the action interface for machine models *) module type A = sig include Arch_herd.S type lannot val empty_annot : lannot val ifetch_value_sets : (string * (V.v -> bool)) list val barrier_sets : (string * (barrier -> bool)) list val cmo_sets : (string * (CMO.t -> bool)) list val annot_sets : (string * (lannot -> bool)) list val pp_annot : lannot -> string include Explicit.S val pteval_sets : (string * (V.Cst.PteVal.t -> bool)) list val dirty_sets : (string * (DirtyBit.my_t -> V.Cst.PteVal.t -> bool)) list val is_atomic : lannot -> bool val is_isync : barrier -> bool val pp_isync : string module ArchAction : ArchAction.S with type v = V.v and type loc = location and type value_set = V.ValueSet.t and type solution = V.solution and type arch_lannot = lannot and type arch_explicit = explicit end module type Config = sig val hexa : bool val variant : Variant.t -> bool end module Make (C:Config) (A : A) : sig type commit_type = | Bcc | Pred | ExcReturn type action = | Access of Dir.dirn * A.location * A.V.v * A.lannot * A.explicit * MachSize.sz * Access.t | Barrier of A.barrier | Commit of commit_type * string option (* Atomic modify, (location,value read, value written, annotation *) | Amo of A.location * A.V.v * A.V.v * A.lannot * A.explicit * MachSize.sz * Access.t (* NB: Amo used in some arch only (e.g., Arm, RISCV) *) (* bool (fifth) argument is true when modeling fault handler entry *) | Fault of A.inst_instance_id * A.location option * Dir.dirn * A.lannot * bool * A.I.FaultType.t option * string option (* Unrolling control *) | CutOff of string (* TLB Invalidate event, operation (for print and level), address, if any. No adresss means complete invalidation at level *) | Inv of A.TLBI.op * A.location option | CMO of A.CMO.t * A.location option (* A placeholder action doing nothing *) | NoAction (* Arch specific actions *) | Arch of A.ArchAction.t val tag_access : MachSize.sz -> Dir.dirn -> A.location -> A.V.v -> action include Action.S with type action := action and module A = A val access_of_location_std : A.location -> Access.t end = struct module A = A module V = A.V open Dir open Access let kvm = C.variant Variant.VMSA let self = C.variant Variant.Ifetch let access_of_constant cst = let open Constant in match cst with | Symbolic (Virtual _) -> Access.VIR | Symbolic (Physical _) -> Access.PHY | Symbolic (TagAddr _) -> Access.TAG | Symbolic (System ((PTE|PTE2),_)) -> Access.PTE | Symbolic (System (TLB,_)) -> Access.TLB | Label _ -> Access.VIR | Tag _ | ConcreteVector _|Concrete _|ConcreteRecord _ | PteVal _|Instruction _|Frozen _ as v -> Warn.fatal "access_of_constant %s as an address" (V.pp_v (V.Val v)) (* assert false *) (* precondition: v is a constant symbol *) let access_of_value v = match v with | V.Var _ -> assert false | V.Val cst -> access_of_constant cst let access_of_location_init = function | A.Location_reg _ -> REG | A.Location_global v -> access_of_value v let access_of_location_std = let open Constant in function | A.Location_reg _ -> REG | A.Location_global (V.Val (Symbolic (Virtual _))|V.Var _) -> Access.VIR | A.Location_global (V.Val (Symbolic ((System ((PTE|PTE2),_))))) as loc -> if kvm then Access.PTE else Warn.fatal "PTE %s while -variant kvm is not active" (A.pp_location loc) | A.Location_global (V.Val (Label(_,_))) -> Access.VIR | A.Location_global v -> Warn.fatal "access_of_location_std on non-standard symbol '%s'" (V.pp_v v) type commit_type = | Bcc | Pred | ExcReturn type action = | Access of Dir.dirn * A.location * A.V.v * A.lannot * A.explicit * MachSize.sz * Access.t | Barrier of A.barrier | Commit of commit_type * string option | Amo of A.location * A.V.v * A.V.v * A.lannot * A.explicit * MachSize.sz * Access.t | Fault of A.inst_instance_id * A.location option * Dir.dirn * A.lannot * bool * A.I.FaultType.t option * string option | CutOff of string | Inv of A.TLBI.op * A.location option | CMO of A.CMO.t * A.location option | NoAction | Arch of A.ArchAction.t let tag_access sz d l v = Access (d,l,v,A.empty_annot,A.exp_annot,sz,Access.TAG) let mk_init_write l sz v = match l,v with | (A.Location_global lg,A.V.Val (Constant.Concrete _)) when A.V.check_ctag lg -> tag_access sz W l v | _,A.V.Val (Constant.Tag _) -> tag_access sz W l v | _ -> Access(W,l,v,A.empty_annot,A.exp_annot,sz,access_of_location_init l) let pp_action a = match a with | Access (d,l,v,an,exp_an,sz,_) -> Printf.sprintf "%s%s%s%s%s=%s" (pp_dirn d) (A.pp_location l) (A.pp_annot an) (A.pp_explicit exp_an) (if sz = MachSize.Word then "" else MachSize.pp_short sz) (V.pp C.hexa v) | Barrier b -> A.pp_barrier_short b | Commit (b,m) -> Printf.sprintf "%s%s" (match b with | Bcc -> "Branching(bcc)" | Pred -> "Branching(pred)" | ExcReturn -> "ExcReturn") (match m with None -> "" | Some txt -> "("^txt^")") | Amo (loc,v1,v2,an,exp_an,sz,_) -> Printf.sprintf "RMW(%s)%s%s%s(%s>%s)" (A.pp_annot an) (A.pp_explicit exp_an) (A.pp_location loc) (MachSize.pp_short sz) (V.pp C.hexa v1) (V.pp C.hexa v2) | Fault (_,loc,d,an,handler,ftype,msg) -> Printf.sprintf "%s(%s%s%s%s%s)" (if handler then "ExcEntry" else "Fault") (pp_dirn d) (Misc.pp_opt_arg (fun loc -> "loc:" ^ A.pp_location_old loc) loc) (A.pp_annot an) (Misc.pp_opt_arg A.I.FaultType.pp ftype) (Misc.pp_opt_arg (Printf.sprintf "type:%s") msg) | CutOff msg -> Printf.sprintf "CutOff:%s" msg | Inv (op,None) -> Printf.sprintf "TLBI(%s)" (A.TLBI.pp_op op) | Inv (op,Some loc) -> Printf.sprintf "TLBI(%s,%s)" (A.TLBI.pp_op op) (A.pp_location loc) | CMO (cmo,loc) -> A.CMO.pp cmo (Option.map A.pp_location loc) | NoAction -> "" | Arch a -> A.ArchAction.pp a (* Utility functions to pick out components *) let value_of a = match a with | Access (_,_ , v,_,_,_,_) -> Some v | Barrier _|Commit _|Amo _|Fault _|CutOff _|Inv _|CMO _|NoAction -> None | Arch a -> A.ArchAction.value_of a let read_of a = match a with | Access (R,_,v,_,_,_,_) | Amo (_,v,_,_,_,_,_) -> Some v | Arch a -> A.ArchAction.read_of a | Access (W, _, _, _,_,_,_)|Barrier _|Commit _|Fault _ | CutOff _|Inv _|CMO _|NoAction -> None and written_of a = match a with | Access (W,_,v,_,_,_,_) | Amo (_,_,v,_,_,_,_) -> Some v | Arch a -> A.ArchAction.written_of a | Access (R, _, _, _,_,_,_) | Barrier _|Commit _|Fault _ | CutOff _|Inv _|CMO _|NoAction -> None let location_of a = match a with | Access (_, l, _,_,_,_,_) | Amo (l,_,_,_,_,_,_) | Fault (_,Some l,_,_,_,_,_) | Inv (_,Some l) | CMO (_,Some l) -> Some l | Arch a -> A.ArchAction.location_of a | Barrier _ |Commit _ | CutOff _ | Fault (_,None,_,_,_,_,_) | Inv (_,None) | CMO (_,None) | NoAction -> None (* relative to memory *) let is_mem_arch_action a = match A.ArchAction.location_of a with | Some a -> A.is_global a | None -> false let is_mem_store a = match a with | Access (W,A.Location_global _,_,_,_,_,_) | Amo (A.Location_global _,_,_,_,_,_,_) -> true | Arch a -> is_mem_arch_action a && A.ArchAction.is_store a | _ -> false let is_mem_load a = match a with | Access (R,A.Location_global _,_,_,_,_,_) | Amo (A.Location_global _,_,_,_,_,_,_) -> true | Arch a -> is_mem_arch_action a && A.ArchAction.is_load a | _ -> false let is_additional_mem_load _ = false let is_mem a = match a with | Access (_,A.Location_global _,_,_,_,_,_) | Amo (A.Location_global _,_,_,_,_,_,_) -> true | Arch a -> is_mem_arch_action a | _ -> false let is_ifetch a = match a with | Access (R,A.Location_global _,_,_,exp,_,_) -> A.is_ifetch_annot exp | _ -> false let is_pt a = match a with | Access (_,A.Location_global (A.V.Val c),_,_,_,_,_) | Amo (A.Location_global (A.V.Val c),_,_,_,_,_,_) -> Constant.is_pt c | Arch a -> begin match A.ArchAction.location_of a with | Some (A.Location_global (A.V.Val c)) -> Constant.is_pt c | _ -> false end | _ -> false let is_additional_mem _ = false let is_atomic a = match a with | Access (_,_,_,an,_,_,_) -> is_mem a && A.is_atomic an | Arch a -> is_mem_arch_action a && A.is_atomic (A.ArchAction.get_lannot a) | _ -> false let is_tag = function | Access (_,_,_,_,_,_,Access.TAG) -> true | Access _|Barrier _|Commit _ | Amo _|Fault _|CutOff _|Inv _|CMO _|Arch _|NoAction-> false let is_inv = function | Inv _ -> true | Access _|Amo _|Commit _|Barrier _|Fault _|CutOff _|CMO _|Arch _|NoAction -> false let is_at_level lvl = function | Inv(op,_) -> A.TLBI.is_at_level lvl op | _ -> false let is_fault = function | Fault _ -> true | Access _ | Amo _ | Commit _ | Barrier _ | CutOff _ | Inv _ | CMO _ | Arch _ | NoAction -> false let is_faulting_read = function | Fault (_,_,Dir.R,_,_,_,_) -> true | _ -> false let is_faulting_write = function | Fault (_,_,Dir.W,_,_,_,_) -> true | _ -> false let is_fault_of_type ftypes = function | Fault (_,_,_,_,_,Some ftype,_) -> List.exists (fun i -> i=ftype) ftypes | _ -> false let is_exc_entry = function | Fault (_,_,_,_,true,_,_) -> true | Fault _ | Access _ | Amo _ | Commit _ | Barrier _ | CutOff _ | Inv _ | CMO _ | Arch _ | NoAction -> false let to_fault = function | Fault (i,Some (A.Location_global x),_,_,_,t,msg) -> Some ((i.A.proc,i.A.labels),Some x,t,msg) | Fault (i,None,_,_,_,t,msg) -> Some ((i.A.proc,i.A.labels),None,t,msg) | Fault _ | Access _ | Amo _ | Commit _ | Barrier _ | CutOff _ | Inv _ | CMO _ | Arch _ | NoAction -> None let get_mem_dir a = match a with | Access (d,A.Location_global _,_,_,_,_,_) -> d | _ -> assert false let get_mem_size a = match a with | Access (_,A.Location_global _,_,_,_,sz,_) -> sz | Arch a -> A.ArchAction.get_size a | _ -> assert false let is_PA_access = function | Access (_,_,_,_,_,_,(Access.PHY|Access.PHY_PTE)) | Amo (_,_,_,_,_,_,(Access.PHY|Access.PHY_PTE)) -> true | _ -> false let on_pteval pred act = let pred = function | Some (A.V.Val (Constant.PteVal p)) -> pred p | None|Some _ -> false in pred (written_of act) || pred (read_of act) let get_pteval act = match written_of act,read_of act with | None,None -> None | (Some v,None) | (_,Some v) (* written value has priority... *) -> let open Constant in begin match v with | A.V.Val (PteVal v) -> Some v | _ -> None end let is_pte_access = function | Access (_,_,_,_,_,_,Access.PTE) -> true | _ -> false let lift_explicit_predicate p act = match act with | Access(_,_,_,_,e,_,_)|Amo (_,_,_,_,e,_,_) -> p e | Arch a -> p (A.ArchAction.get_explicit a) | _ -> false let is_explicit = lift_explicit_predicate A.is_explicit_annot and is_not_explicit = lift_explicit_predicate A.is_not_explicit_annot (* relative to the registers of the given proc *) let is_reg_store a (p:int) = match a with | Access (W,A.Location_reg (q,_),_,_,_,_,_) -> p = q | _ -> false let is_reg_load a (p:int) = match a with | Access (R,A.Location_reg (q,_),_,_,_,_,_) -> p = q | _ -> false let is_reg a (p:int) = match a with | Access (_,A.Location_reg (q,_),_,_,_,_,_) -> p = q | _ -> false (* Store/Load anywhere *) let is_store a = match a with | Access (W,_,_,_,_,_,_)|Amo _ -> true | Arch a -> A.ArchAction.is_load a | Access (R,_,_,_,_,_,_) | Barrier _ | Commit _ | Fault _ | CutOff _ | Inv _ | CMO _ | NoAction -> false let is_load a = match a with | Access (R,_,_,_,_,_,_) | Amo _ -> true | Arch a -> A.ArchAction.is_store a | Access (W,_,_,_,_,_,_) | Barrier _ | Commit _ | Fault _ | CutOff _ | Inv _ | CMO _ | NoAction -> false let get_kind = function | (Access (_,_,_,_,_,_,k)|Amo (_,_,_,_,_,_,k)) ->k | Arch a -> A.ArchAction.get_kind a | _ -> assert false let compatible_accesses a1 a2 = let k1 = get_kind a1 and k2 = get_kind a2 in Access.compatible k1 k2 let is_reg_any a = match a with | Access (_,A.Location_reg _,_,_,_,_,_) -> true | _ -> false let is_reg_store_any a = match a with | Access (W,A.Location_reg _,_,_,_,_,_) -> true | _ -> false let is_reg_load_any a = match a with | Access (R,A.Location_reg _,_,_,_,_,_) -> true | _ -> false (* Barriers *) let is_barrier a = match a with | Barrier _ -> true | _ -> false let barrier_of a = match a with | Barrier b -> Some b | _ -> None let same_barrier_id _ _ = assert false (* Commits aka "branching events" *) let is_bcc a = match a with | Commit (Bcc,_) -> true | _ -> false let is_pred ?(cond=None) = function | Commit (Pred, cond0) -> Option.is_none cond || Option.equal String.equal cond cond0 | _ -> false let is_exc_return a = match a with | Commit (ExcReturn,_) -> true | _ -> false let is_commit a = match a with | Commit _ -> true | _ -> false (* Unroll control *) let cutoff msg = CutOff msg let is_cutoff = function | CutOff _ -> true | _ -> false and as_cutoff = function | CutOff msg -> Some msg | NoAction|Access _|Barrier _|Commit _ | Amo _|Fault _|Inv _|CMO _|Arch _ -> None (* Architecture-specific sets *) let arch_sets = let bsets = List.map (fun (tag,p) -> let p act = match act with | Barrier b -> p b | _ -> false in tag,p) A.barrier_sets and cutoff_set = ("CutOff",is_cutoff) and cmo_sets = List.map (fun (tag,p) -> let p act = match act with | CMO (cmo, _) -> p cmo | _ -> false in tag,p) A.cmo_sets and asets = List.map (fun (tag,p) -> let p act = match act with | Access(_,_,_,annot,_,_,_)|Amo (_,_,_,annot,_,_,_) | Fault (_,_,_,annot,_,_,_)-> p annot | Arch a -> p (A.ArchAction.get_lannot a) | _ -> false in tag,p) A.annot_sets and esets = List.map (fun (tag,p) -> let p = lift_explicit_predicate p in tag,p) A.explicit_sets and lsets = List.map (fun lvl -> A.pp_level lvl,is_at_level lvl) A.levels and aasets = List.map (fun (tag,p) -> let p act = match act with | Arch act -> p act | _ -> false in tag,p) A.ArchAction.sets and ifetch_sets = if self then let location_of_is_a_label a = match location_of a with | Some A.Location_global (A.V.Val c) -> Constant.is_label c | _ -> false in let is_ifetch a = (is_mem_load a || is_mem_store a) && location_of_is_a_label a in let check_value a f = match value_of a with | Some v -> f v | _ -> false in let ifetch_value_sets = List.map (fun (tag,p) -> tag, fun a -> is_ifetch a && (check_value a p)) A.ifetch_value_sets in ("Instr",is_ifetch)::ifetch_value_sets else [] and fault_sets = ("FAULT",is_fault):: ("FAULT-RD",is_faulting_read):: ("FAULT-WR",is_faulting_write):: ("EXC-ENTRY",is_exc_entry):: ("EXC-RET",is_exc_return):: List.map (fun (s,keys) -> (s,is_fault_of_type keys)) A.I.FaultType.sets and tlbi_sets = List.map (fun (tag, f) -> tag, function | Inv (op,_) -> f op | _ -> false) A.TLBI.sets in ("T",is_tag):: ("TLBI",is_inv):: ("no-loc", fun a -> Misc.is_none (location_of a)):: (if kvm then fun k -> ("PA",is_PA_access):: ("PTE",is_pt):: List.fold_right (fun (key,p) k -> (key,on_pteval p)::k) A.pteval_sets k else fun k -> k) (cutoff_set::bsets @ cmo_sets @ asets @ esets @ lsets @ aasets @ ifetch_sets @ fault_sets @ tlbi_sets) let arch_rels = if kvm then let inv_domain_act = let is_pt_loc act = match location_of act with | Some loc -> let open Constant in begin match A.symbol loc with | Some (System (PTE,_)) -> true | _ -> false end | None -> false in let inv_domain_sym a1 a2 = let open Constant in match a1,a2 with | (System ((PTE),s1),System (TLB,s2)) | (System (TLB,s2),System ((PTE),s1)) -> Misc.string_eq s1 s2 | _,_ -> false in let inv_domain_loc loc1 loc2 = let open Constant in match loc1,loc2 with | A.Location_global (A.V.Val (Symbolic a1)), A.Location_global (A.V.Val (Symbolic a2)) -> inv_domain_sym a1 a2 | _,_ -> false in fun act1 act2 -> match act1,act2 with | (act,Inv (_,None))|(Inv (_, None),act) -> is_pt_loc act | (e,Inv (_,Some loc1))|(Inv (_, Some loc1),e) -> is_mem e && begin match location_of e with | Some loc2 -> inv_domain_loc loc1 loc2 | None -> false end | _ -> false and alias_act = let get_pteval = let open Constant in function | Some (A.V.Val (PteVal v)) -> Some v | Some (A.V.Val (ConcreteVector _|Concrete _|Symbolic _|ConcreteRecord _ |Label (_, _)|Tag _|Instruction _ |Frozen _)) | None -> None | Some (A.V.Var _) -> Warn.fatal "Cannot decide alias on variables" and is_amo = function | Amo _ -> true | _ -> false in fun act1 act2 -> (* RMW events are not compatible with this alias that relies on event values. Reason: RWM events have two values.. *) assert (not (is_amo act1 || is_amo act2)) ; is_pt act1 && is_pt act2 && (match get_pteval (value_of act1), get_pteval (value_of act2) with | Some s1,Some s2 -> A.V.Cst.PteVal.same_oa s1 s2 | _,_ -> false) in [("inv-domain",inv_domain_act); ("alias",alias_act);] else [] let arch_dirty = if kvm then let check_pred f d = fun act -> is_pt act && (match get_pteval act with | None -> false | Some pteval -> f d pteval) in List.map (fun (key,f) -> key,check_pred f) A.dirty_sets else [] let is_isync act = match act with | Barrier b -> A.is_isync b | _ -> false let pp_isync = A.pp_isync (* Equations *) let undetermined_vars_in_action a = match a with | Access (_,l,v,_,_,_,_) -> V.ValueSet.union (A.undetermined_vars_in_loc l) (V.undetermined_vars v) | Amo (loc,v1,v2,_,_,_,_) -> V.ValueSet.union3 (A.undetermined_vars_in_loc loc) (V.undetermined_vars v1) (V.undetermined_vars v2) | Arch a -> A.ArchAction.undetermined_vars a | Barrier _|Commit _|Fault _|CutOff _|Inv _ |CMO _|NoAction -> V.ValueSet.empty let simplify_vars_in_action soln a = match a with | Access (d,l,v,an,exp_an,sz,t) -> let l = A.simplify_vars_in_loc soln l in let v = V.simplify_var soln v in Access (d,l,v,an,exp_an,sz,t) | Amo (loc,v1,v2,an,exp_an,sz,t) -> let loc = A.simplify_vars_in_loc soln loc in let v1 = V.simplify_var soln v1 in let v2 = V.simplify_var soln v2 in Amo (loc,v1,v2,an,exp_an,sz,t) | Fault (ii,loc,d,a,h,t,msg) -> let loc = Misc.map_opt (A.simplify_vars_in_loc soln) loc in Fault(ii,loc,d,a,h,t,msg) | Inv (op,oloc) -> let oloc = Misc.app_opt (A.simplify_vars_in_loc soln) oloc in Inv (op,oloc) | CMO (op,oloc) -> let oloc = Misc.app_opt (A.simplify_vars_in_loc soln) oloc in CMO (op,oloc) | Arch a -> Arch (A.ArchAction.simplify_vars soln a) | Barrier _ | Commit _|CutOff _|NoAction -> a let annot_in_list _str _ac = false end herd-herdtools7-1ca343e/herd/machModelChecker.ml000066400000000000000000000633361475314470400216070ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Check an event structure against a machine model *) module type Config = sig val fname : string val m : AST.t val bell_model_info : (string * BellModel.info) option (* Include events from the same instance in po, essential for the LKMM *) val wide_po : bool include Model.Config end module Make (O:Config) (S:Sem.Semantics) = struct let do_deps = O.variant Variant.Deps let morello = O.variant Variant.Morello let mixed = O.variant Variant.Mixed || morello let memtag = O.variant Variant.MemTag let kvm = O.variant Variant.VMSA let self = O.variant Variant.Ifetch let asl = S.A.arch = `ASL let optacetrue = let open OptAce in match O.optace with | True -> true | False|Iico -> false let bell_fname = Misc.app_opt (fun (x,_) -> x) O.bell_model_info let bell_info = Misc.app_opt (fun (_,x) -> x) O.bell_model_info let tr_proc = let open DirtyBit in match O.dirty with | None -> fun _ -> let f () = false in { my_ha=f; my_hd=f; } | Some dirty -> fun proc -> let my_ha () = dirty.ha proc and my_hd () = dirty.hd proc in { my_ha; my_hd; } module IConfig = struct let bell = false let bell_fname = bell_fname let compat = match S.A.arch with | `LISA -> O.variant Variant.BackCompat | _ -> false include O let doshow = S.O.PC.doshow let showraw = S.O.PC.showraw let symetric = S.O.PC.symetric let variant = let variant = if optacetrue then Misc.(|||) (Variant.equal Variant.CosOpt) O.variant else O.variant in Misc.delay_parse variant (fun s -> match Misc.lowercase s with | "dic" -> Some Variant.DIC | "idc" -> Some Variant.IDC | _ -> Variant.parse s) end module U = MemUtils.Make(S) module MU = ModelUtils.Make(O)(S) module IUtils = struct let partition_events = U.partition_events let loc2events x es = let open S in let x = A.V.nameToV x in E.EventSet.filter (fun e -> match E.location_of e with | Some (A.Location_global loc) -> A.V.compare loc x = 0 | None | Some _ -> false) es let check_through = MU.check_through let pp_failure test conc msg vb_pp = MU.pp_failure test conc (Printf.sprintf "%s: %s" test.Test_herd.name.Name.name msg) vb_pp let pp test conc msg vb_pp = MU.pp test conc (Printf.sprintf "%s: %s" test.Test_herd.name.Name.name msg) vb_pp (* fromto evts fs wher evts are all events and fs are fences *) let labels_of e = match e.S.E.iiid with | S.E.IdInit|S.E.IdSpurious -> Label.Set.empty | S.E.IdSome id -> id.S.A.labels let fencerel pbef paft po f = let open S in let before = E.EventSet.filter pbef (E.EventRel.preds po f) and after = E.EventSet.filter paft (E.EventRel.succs po f) in E.EventRel.cartesian before after let fromto po fs = let open S in let fs = E.EventSet.filter E.is_barrier fs in if E.EventSet.is_empty fs then E.EventRel.empty else let r = E.EventSet.fold (fun f r -> match f.E.iiid with | S.E.IdInit|S.E.IdSpurious -> assert false (* All fence evts generated by some ins *) | S.E.IdSome {A.inst=ins; _} -> let fr = match A.I.fromto_of_instr ins with | None -> fencerel (fun _ -> true) (fun _ -> true) po f | Some (l1,l2) -> let keep lbls e = not (Label.Set.disjoint lbls (labels_of e)) in fencerel (keep l1) (keep l2) po f in fr::r) fs [] in E.EventRel.unions r let same_value e1 e2 = match S.E.value_of e1,S.E.value_of e2 with | Some v1,Some v2 -> S.A.V.compare v1 v2 = 0 | _ -> false let same_oa e1 e2 = let open Constant in match S.E.value_of e1,S.E.value_of e2 with | Some (S.A.V.Val (PteVal p1)), Some (S.A.V.Val (PteVal p2)) -> S.A.V.Cst.PteVal.same_oa p1 p2 | _ -> false let writable2 = let writable ha hd e = match S.E.value_of e with | Some (S.A.V.Val (Constant.PteVal p)) -> S.A.V.Cst.PteVal.writable ha hd p | _ -> false in fun e1 e2 -> let p = S.E.proc_of e1 in match p with | None -> Warn.user_error "Init or spurious write as first argument of writable2" | Some p -> let ha,hd = let open DirtyBit in match O.dirty with | Some d -> d.ha p,d.hd p | None -> false,false in writable ha hd e1 || writable ha hd e2 end module I = Interpreter.Make(IConfig)(S)(IUtils) module Equiv = EquivSpec.Make(S) module E = S.E (* Fast "loc" relation computation *) module NameEnv = StringMap let loc_as_fault_base loc = let (>>=) = Option.bind in S.A.global loc >>= S.A.V.as_constant >>= Constant.as_fault_base let comp_loc evts = let mlocs,mfaults = E.EventSet.fold (fun e (mlocs,mfaults as k) -> match E.location_of e with | None -> k | Some loc -> if E.is_fault e then match loc_as_fault_base loc with | None -> k | Some name -> mlocs,NameEnv.accumulate name e mfaults else U.LocEnv.accumulate loc e mlocs,mfaults) evts (U.LocEnv.empty,NameEnv.empty) in let rel_locs = (* Standard "loc" relation same address *) U.LocEnv.fold (fun _ es k -> let es = E.EventSet.of_list es in E.EventRel.cartesian es es::k) mlocs [] |> E.EventRel.unions and rel_faults = (* Add faults with same base address *) if NameEnv.is_empty mfaults then E.EventRel.empty else let mnames = U.LocEnv.fold (fun loc es mnames -> match loc_as_fault_base loc with | None -> mnames | Some name -> begin match NameEnv.safe_find [] name mfaults with | [] -> mnames | _ -> let old = NameEnv.safe_find [] name mnames in NameEnv.add name (es@old) mnames end) mlocs NameEnv.empty in NameEnv.fold (fun name es k -> let fs = E.EventSet.of_list es in let es = NameEnv.safe_find [] name mnames |> E.EventSet.of_list in E.EventRel.cartesian es fs:: E.EventRel.cartesian fs es:: E.EventRel.cartesian fs fs::k) mfaults [] |> E.EventRel.unions in E.EventRel.union rel_locs rel_faults (* Efficient "same-low-order-bits" *) let comp_same_low_order_bits evts = let m = E.EventSet.fold (fun e m -> match E.global_index_of e with | None -> m | Some idx -> IntMap.accumulate idx e m) evts IntMap.empty in IntMap.fold (fun _ es k -> let es = E.EventSet.of_list es in E.EventRel.cartesian es es::k) m [] |> E.EventRel.unions (* Efficient "int" and "ext" relations *) let comp_by_proc evts = E.EventSet.fold (fun e (i,m) -> match E.proc_of e with | None -> e::i,m | Some p -> i,IntMap.accumulate p e m) evts ([],IntMap.empty) let comp_int m = IntMap.fold (fun _ es k -> let es = E.EventSet.of_list es in E.EventRel.cartesian es es::k) m [] |> E.EventRel.unions let comp_ext (i,m) = let ess = IntMap.fold (fun _ es k -> E.EventSet.of_list es::k) m [E.EventSet.of_list i] in let t = Array.of_list ess in let len = Array.length t in let rec do_rec i j r = if i >= len then r else if j >= len then do_rec (i+1) (i+2) r else let es_i = t.(i) and es_j = t.(j) in let r = E.EventRel.cartesian es_i es_j:: E.EventRel.cartesian es_j es_i::r in do_rec i (j+1) r in do_rec 0 1 [] |> E.EventRel.unions (* Local utility: bell event selection *) let add_bell_events m pred evts annots = I.add_sets m (StringSet.fold (fun annot k -> let tag = BellName.tag2instrs_var annot in let rel = lazy begin E.EventSet.filter (pred annot) evts end in if O.debug then Printf.eprintf "annotation %s recorded as set %s\n" annot tag ; let bd = tag,rel in let k = bd::k in k) annots []) (* Intepreter call *) let (opts,_,prog) = O.m let withco = opts.ModelOption.co let catdep = opts.ModelOption.catdep let run_interpret test kfail = let run = I.interpret test kfail in fun ks m vb_pp kont res -> (*Printf.eprintf "vb_pp = {%s}\n%!" (String.concat "," (List.map fst (Lazy.force vb_pp)));*) run ks m vb_pp (fun st res -> if not O.strictskip || StringSet.equal st.I.out_skipped O.skipchecks then let conc = ks.I.conc in kont conc conc.S.fs (st.I.out_sets,st.I.out_show) st.I.out_flags res else res) res let choose_spec f1 f2 x = if do_deps then f1 x else f2 x (* Enter here *) let check_event_structure test conc kfail kont res = let pr = lazy (MU.make_procrels E.is_isync conc) in let vb_pp = if O.showsome && O.verbose > 0 then lazy (MU.pp_procrels None (Lazy.force pr)) else lazy [] in let relevant = if do_deps || catdep || asl then fun _ -> true else fun e -> not (E.is_reg_any e) in let all_evts = conc.S.str.E.events in let evts = choose_spec Misc.identity (E.EventSet.filter relevant) all_evts in let () = if O.debug then Printf.eprintf "Cat run, fname=%s, nevts=%d\n%!" O.fname (E.EventSet.cardinal evts) in let by_proc = lazy (comp_by_proc evts) in let mem_evts = lazy (E.EventSet.filter E.is_mem evts) in let po = choose_spec Misc.identity (E.EventRel.filter (if O.wide_po then (fun (e1,e2) -> relevant e1 && relevant e2) else (fun (e1,e2) -> relevant e1 && relevant e2 && not (E.same_instance e1 e2)))) conc.S.po in let partial_po = lazy ( E.EventRel.filter_nodes relevant conc.S.partial_po ) in let id = lazy begin E.EventRel.of_list (List.rev_map (fun e -> e,e) (E.EventSet.elements evts)) end in let unv = lazy begin E.EventRel.cartesian evts evts end in let ks = { I.id; unv; evts; conc; po;} in let calc_si sca = let r = E.EventRel.unions (E.EventSetSet.map_list (fun sm -> E.EventRel.cartesian sm sm) sca) in if mixed || morello then r else let si_evts = E.EventSet.filter (fun x -> E.is_mem x || E.is_fault x) evts in E.EventRel.union r (E.EventRel.set_to_rln si_evts) in let si = lazy begin calc_si conc.S.str.E.sca end in let aligned = lazy begin let rs = List.map (fun (mem,sca) -> if U.is_aligned (S.type_env test) (S.size_env test) mem then calc_si (E.EventSetSet.singleton sca) else E.EventRel.empty) conc.S.str.E.aligned in E.EventRel.unions rs end in let rf_reg = lazy (U.make_rf_regs conc) in (* Initial env *) let m = I.add_rels I.init_env_empty ((if O.variant Variant.Success || O.variant Variant.Instr then fun k -> ("instr",lazy begin E.EventRel.of_pred all_evts all_evts E.po_eq end)::k else Misc.identity) (((if do_deps then Misc.identity else fun k -> ("tst", lazy (Lazy.force pr).S.tst):: ("addr", lazy (Lazy.force pr).S.addr):: ("data", lazy (Lazy.force pr).S.data):: ("ctrl", lazy (Lazy.force pr).S.ctrl)::k) ["id",id; "loc", lazy begin comp_loc evts; end; "same-low-order-bits", lazy begin comp_same_low_order_bits evts end; "int",lazy begin let _,m = Lazy.force by_proc in comp_int m end ; "ext",lazy begin comp_ext (Lazy.force by_proc) end ; "rmw",lazy conc.S.atomic_load_store; "amo", lazy begin E.EventRel.filter (fun (r,w) -> E.po_eq r w) conc.S.atomic_load_store end; "po", lazy po; "partial_po", partial_po; "depend", lazy (Lazy.force pr).S.depend; "success", lazy (Lazy.force pr).S.success; "rf", lazy (Lazy.force pr).S.rf; "control",lazy conc.S.str.E.control ; "sm",si; "si",si; "aligned",aligned; "iico_data", lazy conc.S.str.E.intra_causality_data; "iico_ctrl", lazy conc.S.str.E.intra_causality_control; "iico_order", lazy conc.S.str.E.intra_causality_order; "rf-reg", rf_reg ; "same-instr", lazy begin E.EventRel.of_pred all_evts all_evts E.same_instruction end; "same-static", lazy begin E.EventRel.of_pred all_evts all_evts E.same_static_event end; "same-instance", lazy begin E.EventRel.of_pred all_evts all_evts E.same_instance end; "equiv-spec", lazy begin Equiv.build (Lazy.force rf_reg) all_evts end; "pco", lazy conc.S.pco; ]))) in let m = let spec = conc.S.str.E.speculated in let is_spec = (fun e -> E.EventSet.mem e spec) in let data_ports = conc.S.str.E.data_ports in let is_data_port = (fun e -> E.EventSet.mem e data_ports) in let are_memtypes = let module MT = S.A.MemType in let mts = MT.parse test.Test_herd.info in MT.fold (fun mt k -> let tag = MT.pp mt and p e = match S.E.virtual_loc_of e with | Some s -> let mtx = try Misc.Simple.assoc s mts with Not_found -> MT.default in MT.equal mt mtx | None -> false in (tag,p)::k) in I.add_sets m (("M",mem_evts):: List.fold_right (fun (k,p) ps -> (k,lazy (E.EventSet.filter p (Lazy.force mem_evts)))::ps) (are_memtypes ["R", E.is_mem_load; "W", E.is_mem_store; "Exp", E.is_explicit; "NExp", E.is_not_explicit; "SPEC", is_spec; "EXEC", (fun e -> not (is_spec e)); "AMO",E.is_amo; "SPURIOUS", E.is_spurious; "IW", E.is_mem_store_init; "FW", (let ws = lazy (U.make_write_mem_finals conc) in fun e -> E.EventSet.mem e (Lazy.force ws)); ]) (List.map (fun (k,p) -> k,lazy (E.EventSet.filter p evts)) ["B", E.is_commit; "BCC", E.is_bcc; "PRED", E.is_pred; "F", E.is_barrier; "Rreg", E.is_reg_load_any; "Wreg", E.is_reg_store_any; "DATA", is_data_port; "NDATA", (fun e -> not (is_data_port e));])) in let m = if kvm then begin let attrs_of_evt e = let pteval_v = match E.read_of e with | Some _ as v -> v | _ -> E.written_of e in let open Constant in match pteval_v with | Some (S.A.V.Val (PteVal v)) -> S.A.V.Cst.PteVal.get_attrs v | _ -> assert false in let pte_accesses = E.EventSet.filter (fun e -> E.Act.is_pte_access e.E.action) (Lazy.force mem_evts) in let attr_evts = E.EventSet.filter (fun e -> (attrs_of_evt e) <> []) pte_accesses in let evts_map = E.EventSet.fold (fun e evts_map -> List.fold_right (fun attr evts_map -> let evts_w_attr = StringMap.safe_find E.EventSet.empty attr evts_map in let evts_w_attr = E.EventSet.add e evts_w_attr in let evts_map = StringMap.add attr evts_w_attr evts_map in evts_map) (attrs_of_evt e) evts_map) pte_accesses StringMap.empty in let s = [("PTEMemAttr", lazy attr_evts)] in I.add_sets m (StringMap.fold (fun k v l -> ("PTE" ^ k, lazy v) :: l) evts_map s) end else m in let m = I.add_sets m (List.map (fun (k,a) -> k,lazy (E.EventSet.filter (fun e -> a e.E.action) evts)) E.Act.arch_sets) in let m = (* To be deprecated *) if kvm then let mevt = match I.get_set m "PTEV" with | Some mevt -> mevt | None -> (* Must exists *) assert false in I.add_sets m (List.map (fun (k,a) -> k,lazy begin let open DirtyBit in E.EventSet.filter (fun e -> match E.proc_of e with | Some proc -> a (tr_proc proc) e.E.action (* For init consider all threads setting *) | None -> let d = match O.dirty with | None -> let f () = false in { my_ha=f; my_hd=f; } | Some dirty -> let k b () = b in { my_ha=k dirty.all_ha; my_hd=k dirty.all_hd; } in a d e.E.action) (Lazy.force mevt) end) E.Act.arch_dirty) else m in (* Override arch specific fences *) let m = I.add_rels m (List.map (fun (k,p) -> let pred (e1,e2) = p e1.E.action e2.E.action in k,lazy begin E.EventRel.filter pred (Lazy.force unv) end) E.Act.arch_rels) in (* Event sets from proc info *) let m = match test.Test_herd.proc_info with | [] -> m | _::_ as i -> let bds = U.lift_proc_info i evts in I.add_sets m bds in (* Event sets from bell_info *) let m = match bell_info with | None -> m | Some bi -> let m = add_bell_events m (fun annot e -> E.Act.annot_in_list annot e.E.action) evts (BellModel.get_mem_annots bi) in let open MiscParser in let extra = test.Test_herd.extra_data in begin List.fold_right (fun e m -> match e with (* No region in test, empty regions *) | BellExtra {BellInfo.regions=None;_} -> I.add_sets m (List.map (fun r -> BellName.tag2instrs_var r,lazy E.EventSet.empty) (StringSet.elements (BellModel.get_region_sets bi))) | BellExtra {BellInfo.regions=Some regions;_} -> let reg2loc = List.fold_left (fun m (x,rs) -> List.fold_left (fun m r -> let old = StringMap.safe_find StringSet.empty r m in StringMap.add r (StringSet.add x old) m) m rs) StringMap.empty regions in let loc2evts = U.collect_mem conc.S.str in let loc2evts = U.LocEnv.map E.EventSet.of_list loc2evts in I.add_sets m (StringSet.fold (fun region k -> let tag = BellName.tag2instrs_var region in let set = lazy begin let locs = StringMap.safe_find StringSet.empty region reg2loc in let evts = StringSet.fold (fun loc k -> let v = S.A.V.nameToV loc in let x = S.A.Location_global v in U.LocEnv.safe_find E.EventSet.empty x loc2evts::k) locs [] in E.EventSet.unions evts end in (tag,set)::k) (BellModel.get_region_sets bi) []) | CExtra _ -> m (* Ignore CExtra ?? *)) extra m end in (* Scope relations from bell info *) let m = match bell_info with | None -> m | Some _ -> let open MiscParser in let extract_tbi e = let extra = test.Test_herd.extra_data in let scope_opt = List.filter_map (function | CExtra _ -> None (* must be here as, O.bell_mode_info is *) | BellExtra tbi -> e tbi) extra in List.nth_opt scope_opt 0 in let scopes = extract_tbi (fun tbi -> tbi.BellInfo.scopes) in let m = match scopes with (* If no scope definition in test, do not build relations, will fail later if the model attempts to use scope relations *) | None -> m (* Otherwise, build scope relations *) | Some scopes -> let rs = U.get_scope_rels evts scopes in I.add_rels m (List.map (fun (scope,r) -> BellName.tag2rel_var scope,lazy r) rs) in let lvls = extract_tbi (fun tbi -> tbi.BellInfo.levels) in let m = match lvls with | None -> m | Some lvls -> let r,rs = U.get_level_rels evts lvls in I.add_rels m ((BellName.nextlevel,lazy r):: List.map (fun (lvl,r) -> BellName.tag2rel_var lvl,lazy r) rs) in m in (* Now call interpreter, with or without generated co *) if withco then let process_co co0 res = let co = S.tr co0 in let fr = U.make_fr conc co in let vb_pp = if O.showsome then lazy (("fr",fr)::("co",co0)::Lazy.force vb_pp) else lazy [] in let m = I.add_rels m [ "fr", lazy fr; "fre", lazy (U.ext fr); "fri", lazy (U.internal fr); "co", lazy co; "coe", lazy (U.ext co); "coi", lazy (U.internal co); ] in run_interpret test kfail ks m vb_pp kont res in U.apply_process_co test conc process_co res else (* let m = I.add_rels m ["co0",lazy conc.S.pco] in *) let kont x y z t u = if O.debug then prerr_endline "Cat over" ; kont x y z t u in run_interpret test kfail ks m vb_pp kont res end herd-herdtools7-1ca343e/herd/mem.ml000066400000000000000000002263411475314470400172040ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Authors: *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* Hadrien Renaud, University College London, UK. *) (****************************************************************************) (** Produce event structures (which include variables) + constraints, using instruction semantics *) module type CommonConfig = sig val verbose : int val optace : OptAce.t val unroll : int option val speedcheck : Speed.t val debug : Debug_herd.t val observed_finals_only : bool val initwrites : bool val check_filter : bool val maxphantom : int option val variant : Variant.t -> bool val fault_handling : Fault.Handling.t val mte_precision : Precision.t end module type Config = sig include CommonConfig val byte : MachSize.sz val dirty : DirtyBit.t option end module type S = sig module S : Sem.Semantics type result = { event_structures : (int * S.M.VC.cnstrnts * S.event_structure) list ; overwritable_labels : Label.Set.t ; } (** [glommed_event_structures t] performs "instruction semantics". * Argument [t] is a test. * The function returns a pair whose first component is a record. * * It includes a set (list) of "abstract" event structures. In such * structures, most values (and locations) are not resolved yet. Hence the * [S.M.VC.cnstrnts] second component. Those are equations to be solved * once some read-from relation on memory is selected by the function * [calculate_rf_with_cnstrnts] (see below). The record also includes * additional processing information to pass on to calculate_rf_with_cnstrnts, * which is the set of labels that are allowed to be addressed by stores. * * Second component of the returned pair is the test itself, * which can be slightly modified (noticeably in the case of * `-variant self`, initial values of overwitable code locations * are added. * * This modified test *must* be used in the following. *) val glommed_event_structures : S.test -> result * S.test (* A first generator, calculate_rf_with_cnstrnts test es constraints kont res, - test and es are test description and (abstract) event structure. By abstract, we here mean that some values and even memory locations in them are variables. - constraints is a set of constraint, which * Is solvable: ie resolution results in either an assigment of all variables in es, or in failure. * expresses the constraints generated by semantics. - kont : S.concrete -> VC.cnstrnts -> 'a -> 'a will be called on all generated concrete event structures, resulting in computation: kont (esN (... (kont es1 res))) where esK is the + abstract event structure with variables replaced by constants + [Failed] of [Warn] constraint from equations, if any + rfmap + final state (included in rfmap in fact) *) val calculate_rf_with_cnstrnts : S.test -> Label.Set.t -> S.event_structure -> S.M.VC.cnstrnts -> (S.concrete -> S.M.VC.cnstrnt option -> 'a -> 'a ) -> (* kont *) 'a -> 'a val solve_regs : S.test -> S.E.event_structure -> S.M.VC.cnstrnt list -> (S.E.event_structure * S.read_from S.RFMap.t * S.M.VC.cnstrnt list) option val solve_mem : S.test ->S.E.event_structure -> S.read_from S.RFMap.t -> S.M.VC.cnstrnt list -> (S.E.event_structure -> S.read_from S.RFMap.t -> S.M.VC.cnstrnt list -> 'a -> 'a) -> 'a -> 'a val check_sizes : S.test -> S.event_structure -> unit val check_rfmap : S.E.event_structure -> S.read_from S.RFMap.t -> bool val when_unsolved : S.test -> S.E.event_structure -> S.read_from S.RFMap.t -> S.M.VC.cnstrnt list -> 'a -> 'a val compute_final_state : S.test -> S.read_from S.RFMap.t -> S.E.EventSet.t -> S.A.state * S.A.FaultSet.t val check_filter : S.test -> S.A.state * S.A.FaultSet.t -> bool val get_loc : S.E.event -> S.E.A.location val make_atomic_load_store : S.E.event_structure -> S.E.EventRel.t end open Printf module Make(C:Config) (S:Sem.Semantics) : S with module S = S = struct module S = S module A = S.A module B = S.B module AM = A.Mixed(C) module V = A.V module E = S.E module EM = S.M module VC = EM.VC module U = MemUtils.Make(S) module W = Warn.Make(C) let dbg = C.debug.Debug_herd.mem let morello = C.variant Variant.Morello let mixed = C.variant Variant.Mixed || morello let unaligned = C.variant Variant.Unaligned let memtag = C.variant Variant.MemTag (* default is checking *) let check_mixed = not (C.variant Variant.DontCheckMixed) let do_deps = C.variant Variant.Deps let kvm = C.variant Variant.VMSA let self = C.variant Variant.Ifetch let asl = C.variant Variant.ASL let oota = C.variant Variant.OOTA let unroll = match C.unroll with | None -> Opts.unroll_default A.arch | Some u -> u (*****************************) (* Event structure generator *) (*****************************) (* Relabeling (eiid) events so as to get memory events labeled by 0,1, etc *) module IMap = Map.Make (struct type t = E.eiid let compare = Misc.int_compare end) let count_mem evts = E.EventSet.fold (fun e k -> if E.is_mem e then k+1 else k) evts 0 let build_map n_mem evts = let build_bd e (next_mem,next_other,k) = let key = e.E.eiid in if E.is_mem e then (next_mem+1,next_other,IMap.add key next_mem k) else (next_mem,next_other+1,IMap.add key next_other k) in let _,_,r = E.EventSet.fold build_bd evts (0,n_mem,IMap.empty) in r (* Note: events from mem_accesses are not relabeled, as they are not part of final events *) let relabel es = let n_mem = count_mem es.E.events in let map = build_map n_mem es.E.events in let relabel_event e = let id = e.E.eiid in try { e with E.eiid = IMap.find id map } with Not_found -> assert (E.EventSet.mem e es.E.mem_accesses) ; e in E.map_event_structure relabel_event es let (|*|) = EM.(|*|) let (>>>) = EM.(>>>) let is_back_jump addr_jmp addr_tgt = Misc.int_compare addr_jmp addr_tgt >= 0 type result = { event_structures : (int * S.M.VC.cnstrnts * S.event_structure) list ; overwritable_labels : Label.Set.t ; } (* All (virtual) locations from init state *) let get_all_locs_init init = let locs = A.state_fold (fun loc v locs -> let locs = match loc with | A.Location_global _ -> loc::locs | A.Location_reg _ -> locs in try match A.V.as_virtual v with | Some s -> let sym = Constant.mk_sym_virtual s in A.Location_global (A.V.Val sym)::locs | None -> locs with V.Undetermined -> locs) init [] in A.LocSet.of_list locs (* All (virtual) memory locations reachable by a test *) let get_all_mem_locs test = let locs_final = A.LocSet.filter (function | A.Location_global _ -> true | A.Location_reg _ -> false) (S.observed_locations test) and locs_init = get_all_locs_init test.Test_herd.init_state in let () = if dbg then begin let pp_locs locs = A.LocSet.pp_str "," A.dump_location locs in Printf.eprintf "locs_init={%s}, locs_final={%s}\n%!" (pp_locs locs_init) (pp_locs locs_final) end in let locs = A.LocSet.union locs_final locs_init in let locs = List.fold_left (fun locs (_,code,fh_code) -> let code = match fh_code with | Some fh_code -> code@fh_code | None -> code in List.fold_left (fun locs (_,ins) -> A.fold_addrs (fun x -> let loc = A.maybev_to_location x in match loc with | A.Location_global _ -> A.LocSet.add loc | _ -> fun locs -> locs) locs ins) locs code) locs test.Test_herd.start_points in let env = A.LocSet.fold (fun loc env -> try let v = A.look_address_in_state test.Test_herd.init_state loc in (loc,v)::env with A.LocUndetermined -> assert false) locs [] in env module SM = S.Mixed(C) type ('a,'b,'c) fetch_r = Ok of 'a * 'b | No of 'a | Segfault of 'c let segfault = Warn.user_error "Segmentation fault (kidding, label %s not found)" let glommed_event_structures (test:S.test) = let prog = test.Test_herd.program in let starts = test.Test_herd.start_points in let code_segment = test.Test_herd.code_segment in let procs = List.map (fun (p,_,_) -> p) starts in let labels_of_instr = test.Test_herd.entry_points in let exported_labels = S.get_exported_labels test in let is_exported_label lbl = Label.Full.Set.exists (fun (_,lbl0) -> Misc.string_eq lbl lbl0) exported_labels in (**********************************************************) (* In mode `-variant self` test init_state is changed: *) (* 1. Normalize labels in values *) (* 2. Add initialisation of overwritable instructions *) (* Labels have to be normalized because only one memory *) (* location holds the instruction that can be pointed to *) (* by several labels. Read and write events *must* use a *) (* canonical location (label). *) (**********************************************************) (* lbls2i -- overwritable instructions, with labels *) (* overwritable_labels -- the set of labels of instructions *) (* that are allowed to be overwritten *) let lbls2i, overwritable_labels = if self then List.fold_left (fun (ps, ls) (proc,code,fh_code) -> let code = match fh_code with | Some fh_code -> code@fh_code | None -> code in List.fold_left (fun (ps, ls) (addr,i) -> let lbls = labels_of_instr addr in if Label.Set.exists is_exported_label lbls then (lbls,(proc,i))::ps, Label.Set.union lbls ls else ps,ls) (ps,ls) code) ([], Label.Set.empty) starts else (* For Adr to work *) let lbl2code lbl = IntMap.find (Label.Map.find lbl prog) code_segment in let ps = Label.Full.Set.fold (fun (_,lab) ps -> try begin match lbl2code lab with | (p,(_,i)::_) -> (Label.Set.singleton lab,(p,i))::ps | (_,[]) -> ps end with Not_found -> ps) exported_labels [] in ps,Label.Set.empty in let norm_lbl = (* Normalize labels, useful in `-variant self` *) if self then let m = List.fold_left (fun m (lbls,_) -> match Label.norm lbls with | None -> assert false (* as lbls is non-empty *) | Some lbl0 -> Label.Set.fold (fun lbl m -> Label.Map.add lbl lbl0 m) lbls m) Label.Map.empty lbls2i in fun lbl -> try Label.Map.find lbl m with | Not_found -> if Label.Map.mem lbl prog then lbl else Warn.user_error "Label %s is undefined, yet it is used as constant" (Label.pp lbl) else (* Normalisation reduced to label existence check *) fun lbl -> ignore (Label.Map.find lbl prog) ; lbl in let norm_val = (* Normalize labels in values *) if self then fun v -> match v with | V.Val c -> V.Val (Constant.map_label norm_lbl c) | _ -> v else fun v -> v in let test = match lbls2i with | [] -> test | _::_ -> let open Test_herd in let init_state = (* Change labels into their canonical representants *) A.map_state norm_val test.init_state in let init_state = (* Add initialisation of overwritable instructions *) List.fold_left (fun env (lbls,(proc,i)) -> match Label.norm lbls with | None -> assert false (* as lbls is non-empty *) | Some lbl -> let loc = A.Location_global (A.V.cstToV (Constant.Label (proc, lbl))) and v = A.V.instructionToV i in A.state_add env loc v) init_state lbls2i in { test with init_state; } in (*****************************************************) (* Build events monad, _i.e._ run code in some sense *) (*****************************************************) (* Manage labels *) let see seen lbl = let x = try IntMap.find lbl seen with Not_found -> 0 in let x = x+1 in let seen = IntMap.add lbl x seen in x,seen in let get_label lbl addr = match lbl with | Some lbl -> lbl | None -> let lbls = labels_of_instr addr in match Label.norm lbls with | Some lbl -> lbl | None -> sprintf "##%d" addr in let tgt2lbl = function | B.Lbl lbl -> lbl | B.Addr addr -> get_label None addr in let fetch_addr check_back seen proc_jmp addr_jmp lbl addr = try let (proc_tgt,_) as tgt = IntMap.find addr code_segment in if (* Limit jump threshold to non determined jumps ? *) Misc.int_eq proc_jmp proc_tgt && check_back && is_back_jump addr_jmp addr then let x,seen = see seen addr in if x > unroll then begin W.warn "loop unrolling limit reached: %s" (get_label lbl addr); No tgt end else Ok (tgt,seen) else Ok (tgt,seen) with Not_found -> Segfault addr in let fetch_code check_back seen proc_jmp addr_jmp = function | B.Lbl lbl -> begin try let addr = Label.Map.find lbl prog in fetch_addr check_back seen proc_jmp addr_jmp (Some lbl) addr with Not_found -> segfault lbl end | B.Addr addr -> fetch_addr check_back seen proc_jmp addr_jmp None addr in (* All memory locations in a test, with initial values *) let env0 = get_all_mem_locs test in let addr2v proc s = try (* Look for label to overwritable instruction *) V.Val (Constant.Label (proc,norm_lbl s)) with e -> (* No, look for data location *) let v = A.V.nameToV s in if List.exists (fun (a,_) -> match a with | A.Location_global a -> A.V.compare v a=0 | _ -> false) env0 then v else (* No code nor data, check error *) match e with | Not_found -> Warn.user_error " Symbol %s is not a code label nor a location" s | e -> raise e in (* Call instruction semantics proper *) let wrap re_exec fetch_proc proc inst addr env m poi = let ii = { A.program_order_index = poi; proc = proc; fetch_proc; inst = inst; labels = labels_of_instr addr; lbl2addr = prog; addr = addr; addr2v=addr2v proc; env = env; in_handler = re_exec; } in if dbg then Printf.eprintf "%s env=%s\n" (A.dump_instruction ii.A.inst) (A.pp_reg_state ii.A.env.A.regs) ; if dbg && not (Label.Set.is_empty ii.A.labels) then eprintf "Instruction %s has labels {%s}\n" (A.dump_instruction inst) (Label.Set.pp_str "," Label.pp ii.A.labels) ; m ii in let sem_instr = SM.build_semantics test in let rec add_next_instr re_exec fetch_proc proc env seen addr inst nexts = wrap re_exec fetch_proc proc inst addr env sem_instr >>> fun branch -> let { A.regs=env; lx_sz=szo; fh_code } = env in let env = A.kill_regs (A.killed inst) env and szo = let open MachSize in match A.get_lx_sz inst with | No -> szo | St -> None | Ld sz -> Some sz in let env = match branch with | S.B.Next bds|S.B.Jump (_,bds)|S.B.IndirectJump (_,_,bds) | B.Fault bds -> List.fold_right (fun (r,v) -> A.set_reg r v) bds env | _ -> env in next_instr re_exec inst fetch_proc proc { A.regs=env; lx_sz=szo; fh_code} seen addr nexts branch and add_code re_exec fetch_proc proc env seen nexts = match nexts with | [] -> EM.unitcodeT true | (addr,inst)::nexts -> add_next_instr re_exec fetch_proc proc env seen addr inst nexts and add_lbl re_exec check_back proc env seen addr_jmp lbl = add_tgt re_exec check_back proc env seen addr_jmp (B.Lbl lbl) and add_tgt re_exec check_back proc env seen addr_jmp tgt = match fetch_code check_back seen proc addr_jmp tgt with | No (tgt_proc,(addr,inst)::_) -> let m ii = EM.addT (A.next_po_index ii.A.program_order_index) (EM.cutoffT (tgt2lbl tgt) ii (S.B.Next [])) in wrap re_exec tgt_proc proc inst addr env m >>> fun _ -> EM.unitcodeT true | No (_,[]) -> assert false (* Backward jump cannot be to end of code *) | Ok ((tgt_proc,code),seen) -> add_code re_exec tgt_proc proc env seen code | Segfault addr -> let msg = Printf.sprintf "Segmentation fault (kidding, address 0x%x does not point to code)" addr in EM.failcodeT (Misc.UserError msg) true and add_fault re_exec inst fetch_proc proc env seen addr nexts = match env.A.fh_code,re_exec with | Some _, true -> let e = "Fault inside a fault handler" in EM.warncodeT e true | Some fh_code, false -> add_code true fetch_proc proc env seen fh_code | None, true -> EM.unitcodeT false | None, false -> let open Fault.Handling in match C.fault_handling with | Fatal -> EM.unitcodeT true | Skip -> add_code false fetch_proc proc env seen nexts | Handled -> add_next_instr true fetch_proc proc env seen addr inst nexts and next_instr re_exec inst fetch_proc proc env seen addr nexts b = match b with | S.B.Exit -> EM.unitcodeT true | S.B.Next _ -> add_code re_exec fetch_proc proc env seen nexts | S.B.Jump (tgt,_) -> add_tgt re_exec true proc env seen addr tgt | S.B.Fault _ -> add_fault re_exec inst fetch_proc proc env seen addr nexts | S.B.FaultRet tgt -> add_tgt false true proc env seen addr tgt | S.B.CondJump (v,tgt) -> EM.condJumpT v (add_tgt re_exec (not (V.is_var_determined v)) proc env seen addr tgt) (add_code re_exec fetch_proc proc env seen nexts) | S.B.IndirectJump (v,lbls,_) -> EM.indirectJumpT v lbls (add_lbl re_exec true proc env seen addr) in (* Code monad returns a boolean. When false the code must be discarded. See also add_instr in eventsMonad.ml *) let jump_start proc env code = add_code false proc proc env IntMap.empty code in (* As name suggests, add events of one thread *) let add_events_for_a_processor env (proc,code,fh_code) evts = let env = if A.opt_env then A.build_reg_state proc A.reg_defaults env else A.reg_state_empty in let () = if dbg then Printf.eprintf "Init reg state for proc %s: %s\n%!" (Proc.pp proc) (A.pp_reg_state env) in let evts_proc = jump_start proc { A.regs=env; lx_sz=None; fh_code } code in evts_proc |*| evts in (* Initial events, some additional events from caller in madd *) let make_inits madd env size_env = let module MI = EM.Mixed(C) in if C.initwrites then MI.initwrites madd env size_env else EM.zerocodeT in (* Build code monad for one given set of events to add *) let set_of_all_instr_events madd = List.fold_right (add_events_for_a_processor test.Test_herd.init_state) starts (make_inits madd env0 test.Test_herd.size_env) in let transitive_po es = let r,e = es.E.po in (r,E.EventRel.transitive_closure e) in let af0 = (* locations with initial spurious update *) if match C.dirty with | None -> false | Some t -> t.DirtyBit.some_ha || t.DirtyBit.some_hd then begin (* One spurious update per observed pte (final load) *) if C.variant Variant.PhantomOnLoad then let look_pt rloc k = match rloc with | ConstrGen.Loc (A.Location_global (V.Val c as vloc)) when Constant.is_pt c -> vloc::k | _ -> k in A.RLocSet.fold look_pt test.Test_herd.observed [] else (* One spurious update per variable not accessed initially *) let add_setaf0 k (loc,v) = match loc with | A.Location_global (V.Val c as vloc) -> if Constant.is_pt c then match v with | V.Val (Constant.PteVal p) when not (V.Cst.PteVal.is_af p) -> vloc::k | _ -> k else k | _ -> k in List.fold_left add_setaf0 [] env0 end else [] in let rec index xs i = match xs with | [] -> W.warn "%i abstract event structures\n%!" i ; [] | (vcl,es)::xs -> let es = if C.debug.Debug_herd.monad then es else relabel es in let es = { es with E.procs = procs; E.po = if do_deps then transitive_po es else es.E.po } in (i,vcl,es)::index xs (i+1) in let r = Misc.fold_subsets_gen (fun vloc -> EM.(|||) (SM.spurious_setaf vloc)) (EM.unitT ()) af0 (fun maf0 -> EM.get_output (set_of_all_instr_events (EM.(|||) maf0))) [] in let r = match C.maxphantom with | None -> r | Some max -> let count_spurious es = E.EventSet.fold (fun e k -> if E.is_load e && E.is_spurious e then k+1 else k) es 0 in List.filter (fun (_,es) -> count_spurious es.E.events <= max) r in { event_structures=index r 0; overwritable_labels; },test (*******************) (* Rfmap generator *) (*******************) (* Step 1. make rfmap for registers and reservations *) let get_loc e = match E.location_of e with | Some loc -> loc | None -> assert false and get_read e = match E.read_of e with | Some v -> v | None -> assert false and get_written e = match E.written_of e with | Some v -> v | None -> assert false (* Add (local) final edges in rfm, ie for all (register) location, find the last (po+iico) store to it *) let add_finals es = U.LocEnv.fold (fun loc stores k -> let stores = List.filter (fun x -> not (E.EventSet.mem x (es.E.speculated))) stores in match stores with | [] -> k | ew::stores -> let last = List.fold_right (fun ew0 ew -> if U.is_before_strict es ew0 ew then ew else begin (* If writes to a given register by a given thread are not totally ordered, it gets weird to define the last or 'final'register write *) if not (U.is_before_strict es ew ew0) then Warn.fatal "Ambiguous po for register %s" (A.pp_location loc) ; ew0 end) stores ew in S.RFMap.add (S.Final loc) (S.Store last) k) (*******************************) (* Compute rfmap for registers *) (*******************************) let map_loc_find loc m = try U.LocEnv.find loc m with Not_found -> [] let match_reg_events es = let loc_loads = U.collect_reg_loads es and loc_stores = U.collect_reg_stores es (* Share computation of the iico relation *) and is_before_strict = U.is_before_strict es in (* For all loads find the right store, the one "just before" the load *) let rfm = U.LocEnv.fold (fun loc loads k -> let stores = map_loc_find loc loc_stores in List.fold_right (fun er k -> let rf = List.fold_left (fun rf ew -> if is_before_strict ew er then match rf with | S.Init -> S.Store ew | S.Store ew0 -> if U.is_before_strict es ew0 ew then S.Store ew else begin (* store order is total *) if not (is_before_strict ew ew0) then begin Printf.eprintf "Not ordered stores %a and %a\n" E.debug_event ew0 E.debug_event ew ; assert false end ; rf end else rf) S.Init stores in S.RFMap.add (S.Load er) rf k) loads k) loc_loads S.RFMap.empty in (* Complete with stores to final state *) add_finals es loc_stores rfm let get_rf_value test read rf = match rf with | S.Init -> let loc = get_loc read in let look_address = A.look_address_in_state test.Test_herd.init_state in begin try look_address loc with A.LocUndetermined -> assert false end | S.Store e -> get_written e (* Add a constraint for two values *) (* Optimization: adding constraint v1 := v2 should always work *) exception Contradiction let add_eq v1 v2 eqs = if V.is_var_determined v1 then if V.is_var_determined v2 then if V.equal v1 v2 then eqs else raise Contradiction else (* Here, v1 and v2 necessarily differ *) VC.Assign (v2, VC.Atom v1)::eqs else if V.equal v1 v2 then eqs else VC.Assign (v1, VC.Atom v2)::eqs let pp_nosol lvl test es rfm = let module PP = Pretty.Make(S) in eprintf "No solution at %s level\n%!" lvl; PP.show_es_rfm test es rfm ; () let solve_regs test es csn = let rfm = match_reg_events es in let csn = S.RFMap.fold (fun wt rf csn -> match wt with | S.Final _ -> csn | S.Load load -> let v_loaded = get_read load in let v_stored = get_rf_value test load rf in try add_eq v_loaded v_stored csn with Contradiction -> let loc = Misc.as_some (E.location_of load) in Printf.eprintf "Contradiction on reg %s: loaded %s vs. stored %s\n" (A.pp_location loc) (A.V.pp_v v_loaded) (A.V.pp_v v_stored) ; assert false) rfm csn in if C.debug.Debug_herd.solver then prerr_endline "++ Solve registers" ; match VC.solve csn with | VC.NoSolns -> if C.debug.Debug_herd.solver then pp_nosol "register" test es rfm ; None | VC.Maybe (sol,csn) -> Some (E.simplify_vars_in_event_structure sol es, S.simplify_vars_in_rfmap sol rfm, csn) (**************************************) (* Step 2. Generate rfmap for memory *) (**************************************) let get_loc_as_value e = match E.global_loc_of e with | None -> eprintf "%a\n" E.debug_event e ; assert false | Some v -> v (* Compatible location are: - either both determined and equal, - or at least one location is undetermined. *) let compatible_locs_mem e1 e2 = E.event_compare e1 e2 <> 0 && (* C RMWs cannot feed themselves *) E.compatible_accesses e1 e2 && begin let loc1 = get_loc e1 and loc2 = get_loc e2 in let ov1 = A.undetermined_vars_in_loc_opt loc1 and ov2 = A.undetermined_vars_in_loc_opt loc2 in match ov1,ov2 with | None,None -> E.same_location e1 e2 | (Some _,None)|(None,Some _) | (Some _,Some _) -> true end (* Add a constraint for a store/load match *) let pp_init load = if dbg then eprintf "Add eq load=%a, store=Init\n%!" E.debug_event load let pp_add load store = if dbg then eprintf "Add eq load=%a, store=%a\n%!" E.debug_event load E.debug_event store let add_mem_eqs test rf load eqs = let v_loaded = get_read load in match rf with | S.Init -> (* Tricky, if location (of load) is not know yet, emit a specific constraint *) let state = test.Test_herd.init_state and loc_load = get_loc load in pp_init load ; begin try let v_stored = A.look_address_in_state state loc_load in add_eq v_stored v_loaded eqs with A.LocUndetermined -> VC.Assign (v_loaded, VC.ReadInit (loc_load,state))::eqs end | S.Store store -> pp_add load store ; add_eq v_loaded (get_written store) (add_eq (get_loc_as_value store) (get_loc_as_value load) eqs) (* Our rather loose rfmaps can induce a cycle in causality. Check this. *) let rfmap_is_cyclic es rfm = let iico = E.iico es in let causality = S.RFMap.fold (fun load store k -> match load,store with | S.Load er,S.Store ew -> E.EventRel.add (ew,er) k | _,_ -> k) rfm iico in match E.EventRel.get_cycle causality with | None -> prerr_endline "no cycle"; false | Some cy -> if C.debug.Debug_herd.rfm then begin let debug_event chan e = fprintf chan "%i" e.E.eiid in eprintf "cycle = %a\n" debug_event (match cy with e::_ -> e | [] -> assert false) end; true (* solve_mem proper *) (* refrain from being subtle: match a load with all compatible stores, and there may be many *) (* First consider loads from init, in the initwrite case nothing to consider, as the initial stores should present as events *) let init = if C.initwrites then [] else [S.Init] let map_load_init loads = E.EventSet.fold (fun load k -> (load,init)::k) loads [] (*condition: soit le load est specule, auquel cas il peut lire de partout; soit le load n'est pas specule, auquel cas il ne peut pas lire de stores specules*) let check_speculation es store load = let spec = es.E.speculated in E.EventSet.mem load spec || not (E.EventSet.mem store spec) let is_spec es e = E.EventSet.mem e es.E.speculated (* Consider all stores that may feed a load - Compatible location. - Not after in program order (suppressed when uniproc is not optmised early) *) let map_load_possible_stores test es rfm loads stores compat_locs = let ok = match C.optace with | OptAce.False -> fun _ _ -> true | OptAce.True -> let pred = U.is_before_strict es and iico = U.iico es in fun er ew -> not (E.is_explicit er && E.is_explicit ew && pred er ew || E.EventRel.mem (er,ew) iico) | OptAce.Iico -> let iico = U.iico es in fun load store -> not (E.EventRel.mem (load,store) iico) in let m = E.EventSet.fold (fun store map_load -> List.map (fun ((load,stores) as c) -> if compat_locs store load && check_speculation es store load && ok load store then load,S.Store store::stores else c) map_load) stores (map_load_init loads) in if dbg then begin let pp_read_froms chan rfs = List.iter (fun rf -> match rf with | S.Init -> fprintf chan "Init" | S.Store e -> E.debug_event chan e ; fprintf chan ",") rfs in List.iter (fun (load,stores) -> eprintf "Pairing {%a} with {%a}\n" E.debug_event load pp_read_froms stores) m end ; (* Check for loads that cannot feed on some write *) if not do_deps && not asl then begin List.iter (fun (load,stores) -> match stores with | [] -> begin match E.location_of load with | Some loc -> begin match A.symbol loc with | Some sym -> if S.is_non_mixed_symbol test sym then Warn.fatal "read on location %s does not match any write" (A.pp_location loc) else if check_mixed then Warn.user_error "mixed-size test rejected (symbol %s), consider option -variant mixed" (A.pp_location loc) | None -> if dbg then begin let module PP = Pretty.Make(S) in eprintf "Failed to find at least one write for load %a\n%!" E.debug_event load ; PP.show_es_rfm test es rfm end ; Warn.fatal "Non symbolic location with no initial write: '%s'\n" (A.pp_location loc) end | _ -> assert false end | _::_ -> ()) m end ; m (* Add memory events to rfmap *) let add_mem = List.fold_right2 (fun er rf -> S.RFMap.add (S.Load er) rf) let add_some_mem = List.fold_right2 (fun er rf -> match rf with | None -> fun rfm -> rfm | Some rf -> S.RFMap.add (S.Load er) rf) let add_mems = List.fold_right2 (List.fold_right2 (fun r w -> S.RFMap.add (S.Load r) (S.Store w))) let solve_mem_or_res test es rfm cns kont res loads stores compat_locs add_eqs = let possible = map_load_possible_stores test es rfm loads stores compat_locs in let possible = List.map (fun (er,ws) -> let ws = List.map (fun w -> Some w) ws in (* Add reading from nowhere for speculated reads *) let ws = if is_spec es er then None::ws else ws in er,ws) possible in let loads,possible_stores = List.split possible in (* Cross product fold. Probably an overkill here *) Misc.fold_cross possible_stores (fun stores res -> (* stores is a list of stores that may match the loads list. Both lists in same order [by List.split above]. *) try (* Add constraints now *) if dbg then eprintf "Add equations\n" ; let cns = List.fold_right2 (fun load rf k -> match rf with | None -> k (* No write, no equation *) | Some rf -> add_eqs test rf load k) loads stores cns in if dbg then eprintf "\n%!" ; (* And solve *) if C.debug.Debug_herd.solver then prerr_endline "++ Solve memory" ; match VC.solve cns with | VC.NoSolns -> if C.debug.Debug_herd.solver then begin let rfm = add_some_mem loads stores rfm in pp_nosol "memory" test es rfm end ; res | VC.Maybe (sol,cs) -> (* Time to complete rfmap *) let rfm = add_some_mem loads stores rfm in (* And to make everything concrete *) let es = E.simplify_vars_in_event_structure sol es and rfm = S.simplify_vars_in_rfmap sol rfm in kont es rfm cs res with | Contradiction -> (* May be raised by add_mem_eqs *) if C.debug.Debug_herd.solver then begin let rfm = add_some_mem loads stores rfm in pp_nosol "memory" test es rfm end ; res | e -> if C.debug.Debug_herd.top then begin eprintf "Exception: %s\n%!" (Printexc.to_string e) ; let module PP = Pretty.Make(S) in let rfm = add_some_mem loads stores rfm in PP.show_es_rfm test es rfm end ; raise e ) res let when_unsolved test es rfm _cs res = (* This system in fact has no solution. In other words, it is not possible to make such event structures concrete. This occurs with cyclic rfmaps *) if C.debug.Debug_herd.solver then begin let module PP = Pretty.Make(S) in prerr_endline "Unsolvable system" ; PP.show_es_rfm test es rfm ; end ; assert (true || rfmap_is_cyclic es rfm); res let solve_mem_non_mixed test es rfm cns kont res = let compat_locs = compatible_locs_mem in if self then let code_store e = E.is_store e && match Misc.seq_opt A.global (E.location_of e) with | Some (V.Val (Constant.Label _)|V.Var _) -> true | Some _|None -> false in (* Select code accesses *) let code_loads = E.EventSet.filter E.is_ifetch es.E.events and code_stores = E.EventSet.filter code_store es.E.events in let kont es rfm cns res = (* We get here once code accesses are solved *) let loads = E.EventSet.filter E.is_mem_load es.E.events and stores = E.EventSet.filter E.is_mem_store es.E.events in let loads = (* Remove code loads that are now solved *) E.EventSet.diff loads code_loads in if dbg then begin eprintf "Left loads : %a\n"E.debug_events loads ; eprintf "All stores: %a\n"E.debug_events stores end ; solve_mem_or_res test es rfm cns kont res loads stores compat_locs add_mem_eqs in if dbg then begin eprintf "Code loads : %a\n"E.debug_events code_loads ; eprintf "Code stores: %a\n"E.debug_events code_stores end ; solve_mem_or_res test es rfm cns kont res code_loads code_stores compat_locs add_mem_eqs else let loads = E.EventSet.filter E.is_mem_load es.E.events and stores = E.EventSet.filter E.is_mem_store es.E.events in if dbg then begin eprintf "Loads : %a\n"E.debug_events loads ; eprintf "Stores: %a\n"E.debug_events stores end ; solve_mem_or_res test es rfm cns kont res loads stores compat_locs add_mem_eqs (*************************************) (* Mixed-size write-to-load matching *) (*************************************) exception CannotSca (* Various utilities on symbolic addresses as locations *) (* Absolute base of indexed symbol (i.e. array address) *) let get_base a = let open Constant in match A.symbolic_data a with | Some ({name=s;_} as sym) -> let s = if Misc.check_ctag s then Misc.tr_ctag s else s in A.of_symbolic_data {sym with name=s; offset=0;} | _ -> raise CannotSca (* Sort same_base *) let compare_index e1 e2 = let open Constant in let loc1 = E.location_of e1 and loc2 = E.location_of e2 in match Misc.seq_opt A.symbolic_data loc1, Misc.seq_opt A.symbolic_data loc2 with | Some {name=s1;offset=i1;_},Some {name=s2;offset=i2;_} when Misc.string_eq s1 s2 -> Misc.int_compare i1 i2 | Some {name=s1;_},Some {name=s2;_} when morello -> if Misc.check_ctag s1 && Misc.string_eq (Misc.tr_ctag s1) s2 then 1 else if Misc.check_ctag s2 && Misc.string_eq s1 (Misc.tr_ctag s2) then -1 else if Misc.check_ctag s1 && Misc.check_ctag s2 && Misc.string_eq s1 s2 then 0 else raise CannotSca | _,_ -> raise CannotSca let sort_same_base es = List.sort compare_index es let debug_events out es = Misc.pp_list out " " E.debug_event es module Match (R:sig type read val compare_index : read -> S.event -> int val debug_read : out_channel -> read -> unit end) = struct let debug_reads out es = Misc.pp_list out " " R.debug_read es let rec inter rs0 ws0 = match rs0 with | [] -> [],[] | r::rs -> begin match ws0 with | [] -> rs0,[] | w::ws -> let c = R.compare_index r w in if c < 0 then let rs,ws = inter rs ws0 in r::rs,ws else if c > 0 then let rs,ws = inter rs0 ws in rs,ws else let rs,ws = inter rs ws in rs,w::ws end let rec all_ws rs ws wss = if dbg then eprintf "Trying [%a] on [%a]\n" debug_reads rs debug_events ws ; let rs_diff,ws_inter = inter rs ws in if dbg then eprintf "Found [%a] (remains [%a])\n" debug_events ws_inter debug_reads rs_diff ; match ws_inter with | [] -> next_all_ws rs wss | _ -> List.fold_right (fun ws k -> (ws_inter@ws)::k) (next_all_ws rs_diff wss) (next_all_ws rs wss) and next_all_ws rs wss = match rs with | [] -> [[]] | _ -> begin match wss with | [] -> [] | ws::wss -> all_ws rs ws wss end let find_rfs_sca s rs wss = match next_all_ws rs wss with | _::_ as wss -> List.map sort_same_base wss | [] -> begin match rs with | [] -> assert false | _::_ -> Warn.user_error "out-of-bound access on %s" s end end module MatchRf = Match (struct type read = S.event let compare_index = compare_index let debug_read = E.debug_event end) let byte_sz = MachSize.nbytes C.byte let expose_sca es sca = let open Constant in let sca = E.EventSet.elements sca in let sca = sort_same_base sca in let fst = match sca with | e::_ -> e | [] -> assert false in let s,idx= match E.global_loc_of fst with | Some (V.Val (Symbolic (Virtual {name=s; offset=i;_}))) -> (if morello && Misc.check_ctag s then Misc.tr_ctag s else s),i | _ -> raise CannotSca in let sz = List.length sca*byte_sz in is_spec es fst,E.get_mem_dir fst,s,idx,sz,sca let expose_scas es = let scas = es.E.sca in let ms = E.EventSetSet.fold (fun sca k -> expose_sca es sca::k) scas [] in let rs,ws = List.fold_left (fun (rs,ws) (g,d,x,idx,sz,es) -> match d with | Dir.W -> let old = StringMap.safe_find [] x ws in rs,StringMap.add x ((g,idx,sz,es)::old) ws | Dir.R -> (g,x,idx,sz,es)::rs,ws) ([],StringMap.empty) ms in let ws = StringMap.map (List.sort (fun (_,_,sz1,_) (_,_,sz2,_) -> Misc.int_compare sz1 sz2)) ws in let ms = List.map (fun (gr,x,i,sz,rs) -> let ws = try StringMap.find x ws with Not_found -> assert false in (* Because of init writes *) let ws = List.filter (fun (gw,i_w,sz_w,_) -> not (not gr && gw) && (* non-ghost reads cannot read from ghost writes *) i+sz >= i_w && i < i_w+sz_w (* write and read intersects *)) ws in x,rs,List.map (fun (_,_,_,ws) -> ws) ws) rs in let ms = List.map (fun (x,rs,wss) -> rs,MatchRf.find_rfs_sca x rs wss) ms in if C.debug.Debug_herd.solver || C.debug.Debug_herd.mem then begin eprintf "+++++++++++++++++++++++\n" ; List.iter (fun (rs,wss) -> eprintf "[%a] ->\n" debug_events rs ; List.iter (fun ws -> eprintf " [%a]\n" debug_events ws) wss) ms ; flush stderr end ; ms (* Non-mixed pairing for tags, if any *) let pair_tags test es rfm = let tags = E.EventSet.filter E.is_tag es.E.events in let loads = E.EventSet.filter E.is_load tags and stores = E.EventSet.filter E.is_store tags in let m = map_load_possible_stores test es rfm loads stores compatible_locs_mem in m let solve_mem_mixed test es rfm cns kont res = let match_tags = if morello then [] else pair_tags test es rfm in let tag_loads,tag_possible_stores = List.split match_tags in let ms = expose_scas es in let rss,wsss = List.split ms in (* Cross product fold. Probably an overkill here *) Misc.fold_cross wsss (fun wss res -> (* Add memory constraints now *) try let cns = List.fold_right2 (fun rs ws eqs -> List.fold_right2 (fun r w eqs -> assert (E.same_location r w) ; add_eq (get_read r) (get_written w) eqs) rs ws eqs) rss wss cns in Misc.fold_cross tag_possible_stores (fun tag_stores res -> (* Add tag memory constraints *) try let cns = List.fold_right2 (fun load store k -> add_mem_eqs test store load k) tag_loads tag_stores cns in (* And solve *) match VC.solve cns with | VC.NoSolns -> res | VC.Maybe (sol,cs) -> (* Time to complete rfmap *) let rfm = add_mems rss wss rfm in let rfm = add_mem tag_loads tag_stores rfm in (* And to make everything concrete *) let es = E.simplify_vars_in_event_structure sol es and rfm = S.simplify_vars_in_rfmap sol rfm in kont es rfm cs res with | Contradiction -> res (* can be raised by add_mem_eqs *) | e -> if C.debug.Debug_herd.top then begin eprintf "Exception: %s\n%!" (Printexc.to_string e) ; let module PP = Pretty.Make(S) in let rfm = add_mems rss wss rfm in PP.show_es_rfm test es rfm end ; raise e) res with Contradiction -> res) (* can be raised by add_eq *) res let solve_mem test es rfm cns kont res = try if mixed && not C.debug.Debug_herd.mixed then solve_mem_mixed test es rfm cns kont res else solve_mem_non_mixed test es rfm cns kont res with | CannotSca -> solve_mem_non_mixed test es rfm cns kont res (*************************************) (* Final condition invalidation mode *) (*************************************) module CM = S.Cons.Mixed(C) (* Internal filter *) let check_filter test fsc = match test.Test_herd.filter with | None -> true | Some p -> not C.check_filter || CM.check_prop p (S.type_env test) (S.size_env test) fsc (*************************************) (* Final condition invalidation mode *) (*************************************) (* A little optimisation: we check whether the existence/non-existence of some vo would help in validation/invalidating the constraint of the test. If no, not need to go on *) module T = Test_herd.Make(S.A) let final_is_relevant test fsc = let open ConstrGen in let cnstr = T.find_our_constraint test in let senv = S.size_env test and tenv = S.type_env test in let check_prop p = CM.check_prop p tenv senv fsc in match cnstr with (* Looking for 'Allow' witness *) | NotExistsState p | ExistsState p -> check_prop p (* Looking for witness that invalidates 'Require' *) | ForallStates p -> not (check_prop p) (* Looking for witness that invalidates 'Forbid' *) let worth_going test fsc = match C.speedcheck with | Speed.True|Speed.Fast -> final_is_relevant test fsc | Speed.False -> true (***************************) (* Rfmap full exploitation *) (***************************) (* final state *) let tr_physical = let open Constant in if kvm then (function | A.Location_global (V.Val (Symbolic (Physical (s,idx)))) -> let sym = { default_symbolic_data with name=s; offset=idx; } in A.of_symbolic_data sym | A.Location_global (V.Val (Symbolic (TagAddr (PHY,s,o)))) -> A.Location_global (V.Val (Symbolic (TagAddr (VIR,s,o)))) | loc -> loc) else Misc.identity let compute_final_state test rfm es = let st = S.RFMap.fold (fun wt rf k -> match wt,rf with | S.Final loc,S.Store ew -> A.state_add k (tr_physical loc) (get_written ew) | _,_ -> k) rfm test.Test_herd.init_state in st, if A.FaultAtomSet.is_empty test.Test_herd.ffaults && not !Opts.dumpallfaults then A.FaultSet.empty else E.EventSet.fold (fun e k -> match E.to_fault e with | Some f -> A.FaultSet.add f k | None -> k) es A.FaultSet.empty (* View before relations easily available, from po_iico and rfmap *) (* Preserved Program Order, per memory location - same processor *) let make_ppoloc po_iico_data es = let mem_evts = E.mem_of es in E.EventRel.of_pred mem_evts mem_evts (fun e1 e2 -> E.same_location e1 e2 && E.EventRel.mem (e1,e2) po_iico_data) (* Store is before rfm load successor *) let store_load rfm = S.RFMap.fold (fun wt rf k -> match wt,rf with | S.Load er,S.Store ew -> E.EventRel.add (ew,er) k | _,_ -> k) rfm E.EventRel.empty (* Load from init is before all stores *) let init_load es rfm = let loc_stores = U.collect_stores es in S.RFMap.fold (fun wt rf k -> match wt,rf with | S.Load er,S.Init -> List.fold_left (fun k ew -> E.EventRel.add (er,ew) k) k (map_loc_find (get_loc er) loc_stores) | _,_ -> k) rfm E.EventRel.empty (* Reconstruct load/store atomic pairs *) let make_atomic_load_store es = let all = E.atomics_of es.E.events in let atms = U.collect_atomics es in U.LocEnv.fold (fun _loc atms k -> let atms = List.filter (fun e -> not (E.is_load e && E.is_store e)) atms in (* get rid of C RMW *) let rs,ws = List.partition E.is_load atms in List.fold_left (fun k r -> let exp = E.is_explicit r in List.fold_left (fun k w -> if S.atomic_pair_allowed r w && U.is_before_strict es r w && E.is_explicit w = exp && not (E.EventSet.exists (fun e -> E.is_explicit e = exp && U.is_before_strict es r e && U.is_before_strict es e w) all) then E.EventRel.add (r,w) k else k) k ws) k rs) atms E.EventRel.empty (* Retrieve last store from rfmap *) let get_max_store _test _es rfm loc = try match S.RFMap.find (S.Final loc) rfm with | S.Store ew -> Some ew | S.Init -> None (* means no store to loc *) with Not_found -> None (* let module PP = Pretty.Make(S) in eprintf "Uncomplete rfmap: %s\n%!" (A.pp_location loc) ; PP.show_es_rfm test es rfm ; assert false *) (* Store to final state comes last *) let last_store test es rfm = let loc_stores = U.collect_stores_non_spec es and loc_loads = U.collect_loads_non_spec es in U.LocEnv.fold (fun loc ws k -> match get_max_store test es rfm loc with | None -> k | Some max -> let loads = map_loc_find loc loc_loads in let k = List.fold_left (fun k er -> if E.event_equal er max then k (* possible with RMW *) else match S.RFMap.find (S.Load er) rfm with | S.Init -> E.EventRel.add (er,max) k | S.Store my_ew -> if E.event_equal my_ew max then k else E.EventRel.add (er,max) k) k loads in List.fold_left (fun k ew -> if E.event_equal ew max then k else E.EventRel.add (ew,max) k) k ws) loc_stores E.EventRel.empty let keep_observed_loc = if kvm then let open Constant in fun loc -> match loc with | A.Location_global (V.Val (Symbolic (Physical _|TagAddr (PHY, _, _) as sym1))) -> let p oloc = match oloc with | A.Location_global (V.Val (Symbolic sym2)) -> Constant.virt_match_phy sym2 sym1 | _ -> false in A.LocSet.exists p | _ -> A.LocSet.mem loc else A.LocSet.mem let pp_locations = A.LocSet.pp_str " " A.pp_location let all_finals_non_mixed test es = let loc_stores = U.remove_spec_from_map es (U.collect_mem_stores es) in let loc_stores = if C.observed_finals_only then let observed_locs = let locs = S.observed_locations test in if mixed then let senv = S.size_env test in A.LocSet.map_union (fun loc -> let open Constant in match loc with | A.Location_global (V.Val (Symbolic (Virtual {name=s;_})) as a) -> let eas = AM.byte_eas (A.look_size senv s) a in A.LocSet.of_list (List.map (fun a -> A.Location_global a) eas) | _ -> A.LocSet.singleton loc) locs else if morello then A.LocSet.map_union (fun loc -> let open Constant in match loc with | A.Location_global (A.V.Val (Symbolic (Virtual ({name=s; offset=0; _} as sym)))) -> A.LocSet.add (A.of_symbolic_data {sym with name=Misc.add_ctag s}) (A.LocSet.singleton loc) | _ -> A.LocSet.singleton loc) locs else locs in if C.debug.Debug_herd.mem then begin eprintf "Observed locs: {%s}\n" (pp_locations observed_locs) end ; U.LocEnv.fold (fun loc ws k -> if keep_observed_loc loc observed_locs then U.LocEnv.add loc ws k else k) loc_stores U.LocEnv.empty else loc_stores in let possible_finals = match C.optace with | OptAce.True -> U.LocEnv.fold (fun _loc ws k -> List.filter (fun w -> not (E.is_explicit w) || not (List.exists (fun w' -> E.is_explicit w' && U.is_before_strict es w w') ws)) ws::k) loc_stores [] | OptAce.False|OptAce.Iico -> U.LocEnv.fold (fun _loc ws k -> ws::k) loc_stores [] in if C.debug.Debug_herd.solver && Misc.consp possible_finals then begin eprintf "+++++++++ possible finals ++++++++++++++\n" ; List.iter (fun ws -> eprintf "[%a]\n" debug_events ws) possible_finals ; flush stderr end ; List.map (fun ws -> List.map (fun w -> [w]) ws) (possible_finals) let rec compare_len xs ys = match xs,ys with | [],[] -> 0 | [],_::_ -> -1 | _::_,[] -> 1 | _::xs,_::ys -> compare_len xs ys module MatchFinal = Match (struct type read = int let compare_index idx e = let open Constant in match Misc.seq_opt A.symbolic_data (E.location_of e) with | Some {name=s; offset=i; _} -> if Misc.check_ctag s then Misc.int_compare idx max_int (* always -1 ??? *) else Misc.int_compare idx i | _ -> assert false let debug_read out = fprintf out "%i" end) let all_finals_mixed test es = assert C.observed_finals_only ; let locs = S.observed_locations test in let locs = A.LocSet.filter A.is_global locs in let loc_wss = E.EventSetSet.fold (fun sca k -> let e = E.EventSet.choose sca in if E.is_store e && not (E.EventSet.mem e es.E.speculated) then match E.location_of e with | Some a -> let a0 = get_base a in let t = A.look_type (S.type_env test) a0 in let a = match t with | TestType.TyArray _ -> raise CannotSca | _ -> a0 in if keep_observed_loc a locs then let old = A.LocMap.safe_find [] a k in A.LocMap.add a (sort_same_base (E.EventSet.elements sca)::old) k else k | _ -> assert false (* Only globals in sca *) else k) es.E.sca A.LocMap.empty in let wsss = A.LocMap.fold (fun loc wss k -> let wss = List.sort compare_len (List.map sort_same_base wss) and rs = let senv = S.size_env test and o = Misc.as_some (A.offset loc) in AM.byte_indices o (A.look_size_location senv loc) in let rs = if morello then rs@[max_int] else rs in MatchFinal.find_rfs_sca (A.pp_location loc) rs wss::k) loc_wss [] in if C.debug.Debug_herd.solver && Misc.consp wsss then begin eprintf "+++++++++ possible finals ++++++++++++++\n" ; List.iter (fun wss -> List.iter (fun ws -> eprintf "[%a]\n" debug_events ws) wss ; eprintf "--------------\n") wsss ; flush stderr end ; wsss let fold_left_left f = List.fold_left (List.fold_left f) let all_finals test es = try if mixed && not C.debug.Debug_herd.mixed then all_finals_mixed test es else all_finals_non_mixed test es with CannotSca -> all_finals_non_mixed test es let some_same_rf_rmw rfm rmw = let loads = U.partition_events (E.EventRel.domain rmw) in List.exists (fun ers -> let rfs = E.EventSet.fold (fun er k -> try S.RFMap.find (S.Load er) rfm::k with Not_found -> assert false) ers [] in Misc.exists_pair S.read_from_equal rfs) loads let fold_mem_finals test es rfm ofail atomic_load_store kont res = (* We can build those now *) let evts = es.E.events in let po_iico = U.po_iico es in let partial_po = E.EventTransRel.to_implicitely_transitive_rel es.E.partial_po in let ppoloc = make_ppoloc po_iico evts in let store_load_vbf = store_load rfm and init_load_vbf = init_load es rfm in (* Now generate final stores *) let possible_finals = all_finals test es in if C.debug.Debug_herd.mem then begin eprintf "Possible finals:\n" ; List.iter (fun wss -> (List.iter (fun ws -> List.iter (eprintf " %a" E.debug_event) ws) wss ; eprintf "\n")) possible_finals end ; (* Add final loads from init for all locations, cleaner *) let loc_stores = U.collect_stores es and loc_loads = U.collect_loads es in let rfm = U.LocEnv.fold (fun loc _rs k -> try ignore (U.LocEnv.find loc loc_stores) ; k with Not_found -> S.RFMap.add (S.Final loc) S.Init k) loc_loads rfm in try let pco0 = if C.initwrites then U.compute_pco_init es else E.EventRel.empty in (*jade: looks ok even in specul case: writes from init are before all other writes, including speculated writes*) let pco = match C.optace with | OptAce.False|OptAce.Iico -> pco0 | OptAce.True -> (*jade: looks compatible with speculation, but there might be some unforeseen subtlety here so flagging it to be sure*) let ppoloc = E.EventRel.restrict_rel (fun e1 e2 -> E.is_explicit e1 && E.is_explicit e2) ppoloc in match U.compute_pco rfm ppoloc with | None -> raise Exit | Some pco -> E.EventRel.union pco0 pco in (* Cross product *) Misc.fold_cross possible_finals (fun ws res -> if C.debug.Debug_herd.mem then begin eprintf "Finals:" ; List.iter (fun ws -> List.iter (fun e -> eprintf " %a" E.debug_event e) ws) ws ; eprintf "\n"; end ; let rfm = fold_left_left (fun k w -> S.RFMap.add (S.Final (get_loc w)) (S.Store w) k) rfm ws in let fsc = compute_final_state test rfm es.E.events in if check_filter test fsc && worth_going test fsc then begin if C.debug.Debug_herd.solver then begin let module PP = Pretty.Make(S) in let fsc,_ = fsc in eprintf "Final rfmap, final state=%s\n%!" (S.A.dump_state fsc); PP.show_es_rfm test es rfm ; end ; let last_store_vbf = last_store test es rfm in let pco = E.EventRel.union pco (U.restrict_to_mem_stores last_store_vbf) in if E.EventRel.is_acyclic pco then let conc = { S.str = es ; rfmap = rfm ; fs = fsc ; po = po_iico ; partial_po = partial_po; pos = ppoloc ; pco = pco ; store_load_vbf = store_load_vbf ; init_load_vbf = init_load_vbf ; last_store_vbf = last_store_vbf ; atomic_load_store = atomic_load_store ; } in kont conc ofail res else begin if C.debug.Debug_herd.solver then begin let conc = { S.str = es ; rfmap = rfm ; fs = fsc ; po = po_iico ; partial_po = partial_po ; pos = ppoloc ; pco = pco ; store_load_vbf = store_load_vbf ; init_load_vbf = init_load_vbf ; last_store_vbf = last_store_vbf ; atomic_load_store = atomic_load_store ; } in let module PP = Pretty.Make(S) in eprintf "PCO is cyclic, discarding candidate\n%!" ; PP.show_legend test "PCO is cyclic" conc [("last_store_vbf",last_store_vbf); ("pco",pco);]; end ; res end end else res) res with Exit -> res (* Initial check of rfmap validity: no intervening writes. Limited to memory, since generated rfmaps are correct for registers *) (* NOTE: this is more like an optimization, models should rule out those anyway *) let check_rfmap es rfm = let po_iico = U.is_before_strict es in S.for_all_in_rfmap (fun wt rf -> match wt with | S.Load er when E.is_mem_load er && E.is_explicit er -> begin match rf with | S.Store ew -> not (E.is_explicit ew) || begin assert (not (po_iico er ew)) ; (* ok by construction, in theory *) not (E.EventSet.exists (fun e -> E.is_store e && E.same_location e ew && E.is_explicit e && po_iico ew e && po_iico e er) es.E.events) end | S.Init -> not (E.EventSet.exists (fun e -> E.is_store e && E.same_location e er && E.is_explicit e && po_iico e er) es.E.events) end | _ -> true) rfm let check_sizes test es = if check_mixed then begin (* No need to check initial writes, correct by construction. *) let loc_mems = U.collect_mem_non_init es in U.LocEnv.iter (fun loc evts -> let open Constant in begin match loc with | A.Location_global (V.Val (Symbolic sym)) when not (S.is_non_mixed_symbol test sym) -> Warn.user_error "mixed-size test rejected (symbol %s), consider option -variant mixed" (A.pp_location loc) | _ -> () end ; begin match evts with | [] -> () | e0::es -> let sz0 = E.get_mem_size e0 in List.iter (fun e -> let sz = E.get_mem_size e in if sz0 <> sz then begin Printf.eprintf "Size mismatch %a vs. %a, ie %s vs. %s\n" E.debug_event e0 E.debug_event e (MachSize.pp sz0) (MachSize.pp sz); Warn.user_error "Illegal mixed-size test" end) es end) loc_mems end let check_event_aligned test e = let a = Misc.as_some (E.global_loc_of e) in if not (U.is_aligned (S.type_env test) (S.size_env test) e) then begin if dbg then eprintf "UNALIGNED: %s\n" (E.pp_action e); Warn.user_error "Unaligned or out-of-bound access: %s, %d bytes" (A.V.pp_v a) (E.get_mem_size e |> MachSize.nbytes) end (* Check alignement in the mixed-size case. Check is performed on original memory accesses, not on splitted sub-events. Checking sub-events would be too permissive, as easily shown by splitting accesses into byte accesses. *) let check_aligned test es = E.EventSet.iter (fun e -> check_event_aligned test e) es.E.mem_accesses let check_symbolic_locations _test es = E.EventSet.iter (fun e -> match E.location_of e with | Some (A.Location_global (V.Val cst)) when Constant.is_symbol cst || Constant.is_label cst -> () | Some (A.Location_global (V.Var _)) -> () | Some loc -> Warn.user_error "Non-symbolic memory access found on '%s'" (A.pp_location loc) | None -> assert false) (E.mem_of es.E.events) let check_noifetch_limitations es = let non_init_stores = E.EventSet.filter (fun e -> E.is_mem_store e && not (E.is_mem_store_init e)) es.E.events in E.EventSet.iter (fun e -> match E.location_of e with | Some (A.Location_global (V.Val(Constant.Label(p, lbl)))) -> Warn.user_error "Store to %s:%s requires instruction fetch functionality.\n\ Please use `-variant self` as an argument to herd7 to enable it." (Proc.pp p) (Label.pp lbl) | _ -> () ) non_init_stores let check_ifetch_limitations test es owls = let stores = E.EventSet.filter E.is_mem_store es.E.events in let program = test.Test_herd.program and code_segment = test.Test_herd.code_segment in E.EventSet.iter (fun e -> match E.location_of e with | Some (A.Location_global (V.Val(Constant.Label(p, lbl))) as loc) -> if Label.Set.mem lbl owls then begin if false then (* insert a proper test here *) Warn.user_error "Illegal store to '%s'; overwrite with the given argument not supported" (A.pp_location loc) end else begin if not (E.is_mem_store_init e) then begin try match IntMap.find (Label.Map.find lbl program) code_segment with | (_,[]) -> Warn.user_error "Final label %s cannot be overwritten" (Label.pp lbl) | (_,(_,i)::_) -> Warn.user_error "Instruction %s:%s cannot be overwritten" (Label.pp lbl) (A.dump_instruction i) with | Not_found -> Warn.user_error "Label %s not found on %s, yet it is used as constant" (Label.pp lbl) (Proc.pp p) end end | _ -> () ) stores let calculate_rf_with_cnstrnts test owls es cs kont res = match solve_regs test es cs with | None -> res | Some (es,rfm,cs) -> if C.debug.Debug_herd.solver && C.verbose > 0 then begin let module PP = Pretty.Make(S) in prerr_endline "Reg solved" ; PP.show_es_rfm test es rfm ; end ; solve_mem test es rfm cs (fun es rfm cs res -> let ofail = VC.get_failed cs in match cs with | _::_ when (not oota) && (not C.initwrites || not do_deps) && not asl && Misc.is_none ofail -> (* Jade: on tolere qu'il reste des equations dans le cas d'evts specules - mais il faudrait sans doute le preciser dans la clause when ci-dessus. Luc: Done, or at least avoid accepting such candidates in non-deps mode. Namely, having non-sensical candidates rejected later by model entails a tremendous runtime penalty. *) when_unsolved test es rfm cs res | _ -> check_symbolic_locations test es ; if self then check_ifetch_limitations test es owls else check_noifetch_limitations es; if (mixed && not unaligned) then check_aligned test es ; if A.reject_mixed && not (mixed || memtag || morello) then check_sizes test es ; if C.debug.Debug_herd.solver && C.verbose > 0 then begin let module PP = Pretty.Make(S) in prerr_endline "Mem solved" ; PP.show_es_rfm test es rfm end ; if match C.optace with | OptAce.False|OptAce.Iico -> true | OptAce.True -> check_rfmap es rfm then (* Atomic load/store pairs *) let atomic_load_store = make_atomic_load_store es in if C.variant Variant.OptRfRMW && some_same_rf_rmw rfm atomic_load_store then begin if C.debug.Debug_herd.mem then begin let module PP = Pretty.Make(S) in eprintf "Atomicity violation anticipated from rf map%!" ; PP.show_es_rfm test es rfm end ; res end else fold_mem_finals test es rfm ofail atomic_load_store kont res else res) res end herd-herdtools7-1ca343e/herd/memUtils.ml000066400000000000000000000401121475314470400202130ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Printf module Make(S : SemExtra.S) = struct module S = S module E = S.E module A = S.A module PC = S.O.PC (*************) (* Utilities *) (*************) let iico es = E.EventRel.transitive_closure (E.iico es) let po_strict = if S.do_deps then fun es -> let _,e = es.E.po in e else fun es -> E.EventRel.of_pred es.E.events es.E.events E.po_strict let po_iico_data es = E.EventRel.union es.E.intra_causality_data (po_strict es) let po_iico es = E.EventRel.union (iico es) (po_strict es) let do_po_strict es e1 e2 = if S.do_deps then E.EventRel.mem (e1,e2) (po_strict es) else E.po_strict e1 e2 (* Slight extension of prog order *) let is_before_strict es = let iico = E.iico es in fun e1 e2 -> (do_po_strict es e1 e2) || (* e1 is po-before e2 *) (if do_po_strict es e2 e1 then false (* e2 is po-before e1 *) else (* e1 and e2 are from the same instruction *) E.EventRel.exists_path (e1,e2) iico) (* Fence *) let po_fence_po po pred = let r1 = E.EventRel.restrict_domains E.is_mem pred po and r2 = E.EventRel.restrict_domains pred E.is_mem po in E.EventRel.sequence r1 r2 let get_loc e = match E.location_of e with | Some loc -> loc | None -> assert false (* Lift dependance relation to memory *) let restrict p = E.EventRel.filter (fun (e1,e2) -> p e1 && p e2) let trans_close_mem r = restrict E.is_mem (S.tr r) let trans_close_mems r_p = List.map trans_close_mem r_p (***************************) (* Got all scope relations *) (***************************) (* Classify acording to proc *) module IntMap = MyMap.Make (struct type t = int let compare = Misc.int_compare end) let by_proc evts = let m = IntMap.empty in let m = E.EventSet.fold (fun e m -> match E.proc_of e with | Some p -> let old = IntMap.safe_find [] p m in IntMap.add p (e::old) m | None -> m) evts m in IntMap.map E.EventSet.of_list m (*******************) let ps2evts m ps = E.EventSet.unions (List.map (fun p -> IntMap.safe_find E.EventSet.empty p m) ps) let get_scope_classes m = let open BellInfo in let rec do_rec = function | Tree (s,ps,ts) -> let es = ps2evts m ps in let cls = StringMap.add s [es] StringMap.empty in let ess,clss = List.fold_left (fun (es,clss) t -> let es_t,cls_t = do_rec t in es_t::es,cls_t::clss) ([es],[cls]) ts in let es = E.EventSet.unions ess in let cls = StringMap.unions (@) clss in es,StringMap.add s [es] cls in fun sc -> let _,cls = do_rec sc in cls let get_level_classes m = let open BellInfo in let rec do_rec = function | Tree (s,ps,ts) -> let es = ps2evts m ps in let cls = StringMap.add s [es] StringMap.empty in let clss = List.fold_left (fun clss t -> let cls_t = do_rec t in cls_t::clss) [cls] ts in let cls = StringMap.unions (@) clss in cls in do_rec let tree2succ m = let open BellInfo in let rec do_rec = function | Tree (_,ps,ts) -> let es = ps2evts m ps in let rs = List.fold_left (fun rs t -> let es_t,r = do_rec t in E.EventRel.cartesian es es_t::r::rs) [] ts in es,E.EventRel.unions rs in fun t -> let _,r = do_rec t in r let classes2rels cls = StringMap.fold (fun s cls k -> let r = E.EventRel.unions (List.map (fun evts -> E.EventRel.cartesian evts evts) cls) in (s,r)::k) cls [] let get_scope_rels evts sc = classes2rels (get_scope_classes (by_proc evts) sc) let get_level_rels evts sc = let m = by_proc evts in let cls = get_level_classes m sc in let rs = classes2rels cls and s = tree2succ m sc in s,rs let lift_proc_info i evts = let m = by_proc evts in List.map (fun (tag,ps) -> let evts = lazy begin E.EventSet.unions (List.map (fun p -> IntMap.safe_find E.EventSet.empty p m) ps) end in tag,evts) i (******************) (* View of a proc *) (******************) let proc_view_event p e = (match E.proc_of e with Some q -> q = p | None -> false) || E.is_mem_store e let proc_view_event2 p (e1,e2) = proc_view_event p e1 && proc_view_event p e2 let proc_view p vb = E.EventRel.filter (proc_view_event2 p) vb (* Perform difference, columnwise, ie difference of projected relations *) let diff_p = List.map2 E.EventRel.diff (* Perform union, columnwise, ie union of projected relations *) let union_p = List.map2 E.EventRel.union let unions_p rows = let cols = try Misc.transpose rows with Misc.TransposeFailure -> assert false in List.map E.EventRel.unions cols let transitive_closure_p = List.map E.EventRel.transitive_closure (********) (* Misc *) (********) let find_source rfmap r = try S.RFMap.find (S.Load r) rfmap with Not_found -> assert false (*******************) (* RF/FR relations *) (*******************) let make_rf_from_rfmap rfmap = S.RFMap.fold (fun wt rf k -> match wt,rf with | S.Load er,S.Store ew when E.is_mem er -> E.EventRel.add (ew,er) k | _ -> k) rfmap E.EventRel.empty let make_rf conc = make_rf_from_rfmap conc.S.rfmap let find_rf er rfm = try S.RFMap.find (S.Load er) rfm with Not_found -> assert false let make_fr conc ws = let loads = E.mem_loads_of conc.S.str.E.events and stores = E.mem_stores_of conc.S.str.E.events in E.EventSet.fold (fun er k -> let erf = find_rf er conc.S.rfmap in E.EventSet.fold (fun ew k -> if not (E.event_equal er ew) (* RMW *) && E.same_location ew er then match erf with | S.Init -> E.EventRel.add (er,ew) k | S.Store erf -> if E.EventRel.mem (erf,ew) ws then E.EventRel.add (er,ew) k else k else k) stores k) loads E.EventRel.empty let make_write_mem_finals conc = let ws = S.RFMap.fold (fun wt rf k -> match wt,rf with | S.Final _,S.Store e when E.is_mem_store e -> e::k | _,_ -> k) conc.S.rfmap [] in E.EventSet.of_list ws let make_rf_regs conc = S.RFMap.fold (fun wt rf k -> match wt,rf with | S.Load er,S.Store ew when E.is_reg_any er -> E.EventRel.add (ew,er) k | _ -> k) conc.S.rfmap E.EventRel.empty let rext conc e = E.is_mem_load e && (match find_rf e conc.S.rfmap with | S.Init -> true | S.Store ew -> E.proc_of ew <> E.proc_of e) let same_source conc e1 e2 = match find_rf e1 conc.S.rfmap,find_rf e2 conc.S.rfmap with | S.Init,S.Init -> true | S.Store w1,S.Store w2 -> E.event_compare w1 w2 = 0 | S.Init,S.Store _ | S.Store _,S.Init -> false let ext r = E.EventRel.filter (fun (e1,e2) -> not (E.same_proc e1 e2)) r let internal r = E.EventRel.filter (fun (e1,e2) -> E.same_proc e1 e2) r (**************************************) (* Place loads in write_serialization *) (**************************************) (* Use rfmap to order loads and stores as much as possible *) (* ws is write serialization *) let find_rf er rfm = try S.RFMap.find (S.Load er) rfm with Not_found -> assert false let first_ws ws ew = E.EventSet.is_empty (E.EventRel.preds ew ws) let make_load_stores conc ws = let loads = E.mem_loads_of conc.S.str.E.events and stores = E.mem_stores_of conc.S.str.E.events in E.EventSet.fold (fun er k -> let erf = find_rf er conc.S.rfmap in E.EventSet.fold (fun ew k -> if E.same_location ew er then match erf with | S.Init -> if first_ws ew ws then E.EventRel.add (er,ew) k else k | S.Store erf -> if E.EventRel.mem (erf,ew) ws then E.EventRel.add (er,ew) k (* else if E.EventRel.mem (ew,erf) ws then E.EventRel.add (ew,er) k *) else k else k) stores k) loads E.EventRel.empty (******************************) (* Sets and Maps on locations *) (******************************) module LocEnv = MyMap.Make (struct type t = A.location let compare = A.location_compare end) (* Collect various events by their location *) let collect_by_loc es pred = E.EventSet.fold (fun e k -> if pred e then let loc = get_loc e in LocEnv.accumulate loc e k else k) es.E.events LocEnv.empty let not_speculated es e = not (E.EventSet.mem e es.E.speculated) let collect_reg_loads es = collect_by_loc es E.is_reg_load_any and collect_reg_stores es = collect_by_loc es E.is_reg_store_any and collect_mem_loads es = collect_by_loc es E.is_mem_load and collect_mem_stores es = collect_by_loc es E.is_mem_store and collect_mem es = collect_by_loc es E.is_mem and collect_mem_non_init es = collect_by_loc es (fun e -> E.is_mem e && Misc.is_some (E.proc_of e)) and collect_loads es = collect_by_loc es E.is_load and collect_stores es = collect_by_loc es E.is_store and collect_loads_non_spec es = collect_by_loc es (fun e -> E.is_load e && not_speculated es e) and collect_stores_non_spec es = collect_by_loc es (fun e -> E.is_store e && not_speculated es e) and collect_atomics es = collect_by_loc es E.is_atomic let partition_events es = let env = E.EventSet.fold (fun e k -> match E.location_of e with | Some loc -> LocEnv.accumulate loc e k | None -> k) es LocEnv.empty in LocEnv.fold (fun _ evts k -> E.EventSet.of_list evts::k) env [] (********************************************) (* Write serialization candidate generator. *) (********************************************) let restrict_to_mem_stores rel = E.EventRel.filter (fun (e1,e2) -> E.is_mem_store e1 && E.is_mem_store e2) rel let fold_write_serialization_candidates conc vb kont res = let vb = E.EventRel.union vb (restrict_to_mem_stores conc.S.last_store_vbf) in (* Because final state is fixed *) let stores_by_loc = collect_mem_stores conc.S.str in let orders = LocEnv.fold (fun _loc stores k -> let orders = E.EventRel.all_topos (PC.verbose > 0) (E.EventSet.of_list stores) vb in List.map E.EventRel.order_to_succ orders::k) stores_by_loc [] in Misc.fold_cross_gen E.EventRel.union E.EventRel.empty orders kont res (* With check *) let apply_process_co test conc process_co res = try fold_write_serialization_candidates conc conc.S.pco process_co res with E.EventRel.Cyclic -> if S.O.debug.Debug_herd.barrier && S.O.PC.verbose > 2 then begin let module PP = Pretty.Make(S) in let legend = sprintf "%s cyclic co precursor" test.Test_herd.name.Name.name in let pos = conc.S.pos in prerr_endline legend ; PP.show_legend test legend conc [ ("pos",S.rt pos); ("pco",S.rt conc.S.pco)] end ; res (*****************************************) (* Compute write serialization precursor *) (*****************************************) (* We asssume unicity of init write event to x, as a defensive measure, works when no init write exists *) let rec find_init = function | [] -> raise Not_found | e::es -> if E.is_mem_store_init e then e else find_init es (* Init store to loc is co-before stores to x *) let compute_pco_init es = let stores = collect_mem_stores es in let xs = LocEnv.fold (fun _loc ews k -> try let ei = find_init ews in List.fold_left (fun k ew -> if E.event_equal ei ew then k else (ei,ew)::k) k ews with Not_found -> k) stores [] in E.EventRel.of_list xs let is_rwm e = E.is_store e && E.is_load e let compute_pco rfmap ppoloc = let open Dir in let add e1 e2 d1 d2 k = match d1, d2 with | Dir.W,Dir.W -> E.EventRel.add (e1,e2) k | Dir.R,Dir.R -> begin match find_source rfmap e1, find_source rfmap e2 with | S.Store w1,S.Store w2 -> if E.event_equal w1 w2 then k else E.EventRel.add (w1,w2) k | S.Init,_ -> k | _,S.Init -> raise Exit end | Dir.R,Dir.W -> begin match find_source rfmap e1 with | S.Store w1 -> E.EventRel.add (w1,e2) k | S.Init -> k end | Dir.W,Dir.R -> begin match find_source rfmap e2 with | S.Store w2 -> if E.event_equal e1 w2 then k else E.EventRel.add (e1,w2) k | S.Init -> raise Exit end in let add1 e1 e2 d1 k = if is_rwm e2 then add e1 e2 d1 R (add e1 e2 d1 W k) else add e1 e2 d1 (E.get_mem_dir e2) k in try let pco = E.EventRel.fold (fun (e1,e2) k -> if is_rwm e1 then add1 e1 e2 R (add1 e1 e2 W k) else add1 e1 e2 (E.get_mem_dir e1) k) ppoloc E.EventRel.empty in Some pco with Exit -> None (*to handle speculation in final state*) let remove_spec_from_map es m = let spec = es.E.speculated in LocEnv.fold (fun loc es k -> let es = List.filter (fun e -> not (E.EventSet.mem e spec)) es in match es with | [] -> k | _ -> LocEnv.add loc es k) m LocEnv.empty (* Alignment check *) let is_aligned tenv senv e = let loc = Misc.as_some (E.location_of e) in let si = Misc.as_some (S.A.symbolic_data loc) in let loc0 = S.A.of_symbolic_data {si with Constant.offset=0;} in let t = S.A.look_type tenv loc0 in let open TestType in let array_sz = match t with | TyArray (_,sz) -> sz | _ -> 1 and sz_e = E.get_mem_size e in match si with | {Constant.name=s; offset=idx;_} -> let sz_s = A.look_size senv s in let nbytes_s = MachSize.nbytes sz_s in if MachSize.less_than_or_equal sz_e sz_s then begin let ncell = idx / nbytes_s and idx0 = idx mod nbytes_s in 0 <= ncell && ncell < array_sz && List.exists (Misc.int_eq idx0) (MachSize.get_off sz_s sz_e) end else begin idx >= 0 && (let nbytes_e = MachSize.nbytes sz_e in idx mod nbytes_e = 0 && (let idx_max = idx/nbytes_s + (nbytes_e/nbytes_s) in idx_max <= array_sz)) end end herd-herdtools7-1ca343e/herd/memUtils.mli000066400000000000000000000142321475314470400203700ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Utilities used when generating event structures *) module Make : functor (S: SemExtra.S) -> sig (* Program order as a relation *) val iico : S.event_structure -> S.event_rel val po_strict : S.event_structure -> S.event_rel val po_iico_data : S.event_structure -> S.event_rel val po_iico : S.event_structure -> S.event_rel (* po union iico_data union iico_control *) val is_before_strict : S.event_structure -> S.event -> S.event -> bool (* Fence like relations *) val po_fence_po : S.event_rel (* po *) -> (S.event -> bool) -> S.event_rel (* Lift relations to memory *) val trans_close_mem : S.event_rel -> S.event_rel val trans_close_mems : S.event_rel list -> S.event_rel list (* All scope relations *) val get_scope_rels : S.event_set -> BellInfo.scopes -> (string * S.event_rel) list val get_level_rels : S.event_set -> BellInfo.scopes -> S.event_rel * (string * S.event_rel) list val lift_proc_info : S.proc_info -> S.event_set -> (string * S.event_set Lazy.t) list (* View of a relation by a processor: restricted to local events and mem_stores *) val proc_view : S.proc -> S.event_rel -> S.event_rel val proc_view_event : S.proc -> S.event -> bool (* Perform operations columnwise *) val diff_p : S.event_rel list -> S.event_rel list -> S.event_rel list val union_p : S.event_rel list -> S.event_rel list -> S.event_rel list val unions_p : S.event_rel list list -> S.event_rel list val transitive_closure_p : S.event_rel list -> S.event_rel list (* Misc, but everywhere... *) val find_source :'a S.RFMap.t -> S.event -> 'a val rext : S.concrete -> S.event -> bool val same_source : S.concrete -> S.event -> S.event -> bool val ext : S.event_rel -> S.event_rel val internal : S.event_rel -> S.event_rel (* RF/FR relations for memory *) val make_rf_from_rfmap : S.rfmap -> S.event_rel val make_rf : S.concrete -> S.event_rel val make_write_mem_finals : S.concrete -> S.event_set val make_rf_regs : S.concrete -> S.event_rel (* make_fr conc ws, where ws is write serialization as a relation (ie as a transitive relation, not as a successor relation *) val make_fr : S.concrete -> S.event_rel -> S.event_rel (* Mapping from locations *) module LocEnv : MyMap.S with type key = S.location (* Collect various events, indexed by location *) val collect_reg_loads : S.event_structure -> S.event list LocEnv.t val collect_reg_stores : S.event_structure -> S.event list LocEnv.t val collect_mem_loads : S.event_structure -> S.event list LocEnv.t val collect_mem_stores : S.event_structure -> S.event list LocEnv.t val collect_mem : S.event_structure -> S.event list LocEnv.t val collect_mem_non_init : S.event_structure -> S.event list LocEnv.t val collect_loads : S.event_structure -> S.event list LocEnv.t val collect_stores : S.event_structure -> S.event list LocEnv.t val collect_stores_non_spec : S.event_structure -> S.event list LocEnv.t val collect_loads_non_spec : S.event_structure -> S.event list LocEnv.t val collect_atomics : S.event_structure -> S.event list LocEnv.t (* Partition by location *) val partition_events : S.event_set -> S.event_set list (* Utilities for relations *) val restrict_to_mem_stores : S.event_rel -> S.event_rel val remove_spec_from_map : S.event_structure -> S.event list LocEnv.t -> S.event list LocEnv.t (* Place loads given write serialization *) val make_load_stores : S.concrete -> S.event_rel -> S.event_rel (************************************************************) (* Stop early if we can, final condition invalisation mode. *) (************************************************************) (* Notice that a runtime option is checked, and that can_stop answers true if fast mode is disabled *) (* Test on memory is performed by fold_write_serialization_candidates below *) (************************) (* Fold over candidates *) (************************) (* fold a function over write serialization candidates 'fold_write_serialization_candidates test es env vb kont res' - test is test - es is concrete event structure - vb is a relation that candidates must include. - kont of type relation ->'a -> 'a will apply to each generated candidate NOTICE: The generator takes care of placing stores to final state correctly *) val fold_write_serialization_candidates : S.concrete -> S.event_rel -> (S.event_rel -> 'a -> 'a) -> 'a -> 'a (* Apply previous fold, catching cyclic graphs errors *) val apply_process_co : S.test -> S.concrete -> (S.event_rel -> 'a -> 'a) -> 'a -> 'a (*****************************************) (* Compute write serialization precursor *) (*****************************************) (* Iniital pco: account for init stores *) val compute_pco_init : S.event_structure -> S.event_rel (* Assumes complete uniproc and hence may fail (because of Init in rfmap *) val compute_pco : S.rfmap -> S.event_rel -> S.event_rel option (* Alignment check *) val is_aligned : S.A.type_env -> S.A.size_env -> S.event -> bool end herd-herdtools7-1ca343e/herd/model.ml000066400000000000000000000073131475314470400175220ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2012-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Printf (* Model indentifiers *) type cav12_opt = { cord : bool ; strongst : bool ; } type jade_opt = { jstrongst : bool;} type t = | File of string (* To convey model filename *) | CAV12 of cav12_opt | Generic of string * AST.t (* filename X ast *) let tags = [ "cav12"; ".cat" ] let parse tag = if Filename.check_suffix tag ".mdl" || Filename.check_suffix tag ".cat" then Some (File tag) else match Misc.lowercase tag with | "cav12" -> Some (CAV12 {cord=true; strongst=true;}) | "cav12_nocord" -> Some (CAV12 {cord=false; strongst=true;}) | "cav12_lightst" -> Some (CAV12 {cord=true; strongst=false;}) | "cav12_nocord_lightst" -> Some (CAV12 {cord=false; strongst=false;}) | _ -> None let pp = function | CAV12 {cord=true; strongst=true;} -> "cav12" | CAV12 {cord=false; strongst=true;} -> "cav12_nocord" | CAV12 {cord=true; strongst=false;} ->"cav12_lightst" | CAV12 {cord=false; strongst=false;} ->"cav12_nocord_lightst" | File fname -> fname | Generic (_,(opts,name,_)) -> sprintf "Generic%s(%s)" (ModelOption.pp opts) name (* What to let through *) type through = | ThroughAll (* Do not retain anything *) | ThroughInvalid (* Let invalid go through (ie retain uniproc violations) *) | ThroughNone (* Standard behaviour *) let tags_through = ["all";"invalid";"none";] let parse_through tag = match Misc.lowercase tag with | "all" -> Some ThroughAll | "invalid" -> Some ThroughInvalid | "none" -> Some ThroughNone | _ -> None let pp_through = function | ThroughAll -> "all" | ThroughInvalid -> "invalid" | ThroughNone -> "none" (* Common configuration *) module type Config = sig val showsome : bool val through : through val debug : bool val debug_files : bool val profile: bool val verbose : int val skipchecks : StringSet.t val strictskip : bool val cycles : StringSet.t val optace : OptAce.t val libfind : string -> string val variant : Variant.t -> bool val dirty : DirtyBit.t option end let get_default_model variant a = match a with | `X86 -> File "x86tso.cat" | `MIPS -> File "mips.cat" | `PPC -> File "ppc.cat" | `ARM -> File "arm.cat" | `BPF -> File "bpf.cat" | `AArch64 -> File (if variant Variant.Deps then "aarch64deps.cat" else "aarch64.cat") | `C -> File "c11_partialSC.cat" | `RISCV -> File "riscv.cat" | `X86_64 -> File "x86tso-mixed.cat" | `ASL -> File "asl.cat" | _ -> Warn.user_error "There is no default model for architecture %s.\nSpecify a model explicitly using the -model flag." (Archs.pp a) herd-herdtools7-1ca343e/herd/model.mli000066400000000000000000000044131475314470400176710ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2012-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Model identifiers *) type cav12_opt = { cord : bool ; strongst : bool ; } type jade_opt = { jstrongst : bool;} type t = | File of string (* To convey model filename *) | CAV12 of cav12_opt | Generic of string * AST.t (* Filename X ast *) val tags : string list val parse : string -> t option val pp : t -> string (* What to let through *) type through = | ThroughAll (* Do not retain anything *) | ThroughInvalid (* Let invalid go through (ie retain uniproc violations) *) | ThroughNone (* Standard behaviour *) val tags_through : string list val parse_through : string -> through option val pp_through : through -> string (* Common configuration *) module type Config = sig val showsome : bool val through : through val debug : bool val debug_files : bool val profile : bool val verbose : int val skipchecks : StringSet.t val strictskip : bool val cycles : StringSet.t val optace : OptAce.t val libfind : string -> string val variant : Variant.t -> bool val dirty : DirtyBit.t option end (* Defaults *) val get_default_model : (Variant.t -> bool) -> Archs.t -> t herd-herdtools7-1ca343e/herd/modelUtils.ml000066400000000000000000000211741475314470400205440ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make(O:Model.Config) (S:SemExtra.S) = struct module E = S.E module U = MemUtils.Make(S) let memtag = O.variant Variant.MemTag let morello = O.variant Variant.Morello let do_deps = O.variant Variant.Deps let iico_ctrl_as_dep = match S.A.arch with | `AArch64 -> true | _ -> false and kvm = O.variant Variant.VMSA let is_mem_kvm = if kvm then E.is_mem_physical else E.is_mem (*******************************************) (* Complete re-computation of dependencies *) (*******************************************) let seq_or_id r1 r2 = S.union (S.seq r1 r2) r2 let evt_relevant x = E.is_mem x || E.is_commit x || E.is_barrier x || E.is_additional_mem x let is_mem_load_total e = (is_mem_kvm e && E.is_load e) || E.is_additional_mem_load e let is_load_total e = E.is_load e || E.is_additional_mem_load e let make_procrels_deps conc = let iico = E.EventRel.union conc.S.str.E.intra_causality_data (if iico_ctrl_as_dep then conc.S.str.E.intra_causality_control else E.EventRel.empty) and rf_regs = U.make_rf_regs conc in let iico_regs = E.EventRel.restrict_rel (fun e1 e2 -> not (evt_relevant e1 || evt_relevant e2)) iico in let dd_inside = S.tr (E.EventRel.union rf_regs iico_regs) in let success = if O.variant Variant.Success then S.seq (E.EventRel.restrict_domain (fun e1 -> E.EventSet.mem e1 conc.S.str.E.success_ports) dd_inside) (E.EventRel.restrict_codomain E.is_mem iico) else E.EventRel.empty in let e = E.EventRel.empty in let addr = e and data = e and ctrl = e and depend = e and ctrlisync = e and data_commit = e in let rf = U.make_rf conc in { S.addr; data; ctrl; depend; ctrlisync; data_commit; success; rf; tst=e;},iico,dd_inside let make_procrels_nodeps is_isync conc = let pr0,iico,dd_inside = make_procrels_deps conc in let is_data_port = let data_ports = conc.S.str.E.data_ports in fun e -> E.EventSet.mem e data_ports in let iico_rmw = E.EventRel.inter conc.S.atomic_load_store conc.S.str.E.intra_causality_data in let iico_from_mem_load = (* First step of dependencies *) E.EventRel.restrict_domain is_mem_load_total iico in let dd_pre = (* Most dependencies start with a mem load, a few with a mem store + ctrl RISCV *) S.seq (E.EventRel.union (E.EventRel.restrict_domain E.is_mem_store conc.S.str.E.intra_causality_control) iico_from_mem_load) dd_inside in let data_dep = (* Data deps are (1) dd to commits (2) data deps to stores *) let last_data = E.EventRel.restrict_rel (fun e1 e2 -> E.is_commit e2 || (is_mem_kvm e2 && E.is_store e2 && is_data_port e1)) iico in S.union3 (E.EventRel.restrict_domain is_mem_load_total last_data) (S.seq dd_pre last_data) (iico_rmw) (* Internal data dep of RMW's *) and addr_dep = (* Address deps are (1) dd to loads, (2) non-data deps to stores, (3) extra abstract "memory" events (such as lock, unlock, etc. that have an address port *) let last_addr = E.EventRel.restrict_rel (fun e1 e2 -> (is_mem_kvm e2 && (E.is_load e2 || (E.is_store e2 && not (is_data_port e1)))) || E.is_additional_mem e2) (* Patch: a better solution would be a direct iico from read address register to access *) (if memtag || kvm || morello then E.EventRel.transitive_closure iico else iico) in S.union (E.EventRel.restrict_domain is_mem_load_total last_addr) (S.seq dd_pre last_addr) in let po = U.po_iico conc.S.str in let ctrl_one = (* For bcc: from commit to event by po *) S.restrict E.is_bcc evt_relevant po and ctrl_two = (* For predicated instruction from commit to event by iico *) S.restrict E.is_pred evt_relevant (U.iico conc.S.str) and ctrl_three = (* For structured if from event to event by instruction control *) S.restrict is_load_total evt_relevant conc.S.str.E.control in let ctrl = E.EventRel.union3 ctrl_one ctrl_two ctrl_three in let ctrl_dep = (* All dependencies, including to reg loads *) let dd = S.union3 dd_pre addr_dep data_dep in let control_from_load = E.EventRel.restrict_domain E.is_load conc.S.str.E.control in let ddplus = S.seq iico_from_mem_load (S.tr (S.union dd_inside control_from_load)) in S.restrict (fun e -> is_mem_load_total e || E.is_mem_store e) evt_relevant (S.union (S.seq dd ctrl) (seq_or_id ddplus control_from_load)) in let po = S.restrict evt_relevant evt_relevant po in let data_commit = E.EventRel.restrict_codomain E.is_commit data_dep in let data_dep = E.EventRel.restrict_codomain E.is_mem data_dep in let ctrlisync = try let r1 = S.restrict is_mem_load_total is_isync ctrl_dep and r2 = S.restrict is_isync E.is_mem po in S.seq r1 r2 with Misc.NoIsync -> S.E.EventRel.empty in { pr0 with S.addr=addr_dep; data=data_dep; ctrl=ctrl_dep; depend=dd_pre; ctrlisync; data_commit;} let make_procrels = if do_deps then fun _ conc -> let pr,_,_ = make_procrels_deps conc in pr else make_procrels_nodeps let pp_procrels pp_isync pr = let pp = ["data",pr.S.data; "addr",pr.S.addr;] in match pp_isync with | None -> ("ctrl",pr.S.ctrl)::pp | Some isync -> let ctrl = E.EventRel.diff pr.S.ctrl pr.S.ctrlisync in (Printf.sprintf "ctrl%s" isync,pr.S.ctrlisync):: ("ctrl",ctrl)::pp (***************************) (* A few factorized checks *) (***************************) open Model let pp test conc legend vb_pp = let module PP = Pretty.Make(S) in Printf.eprintf "%s\n%!" legend ; PP.show_legend test legend conc vb_pp let pp_failure test conc legend vb_pp = if O.debug then pp test conc legend vb_pp (* Through *) let check_through = match O.through with | ThroughAll|ThroughInvalid -> fun _ -> true | ThroughNone -> fun ok -> ok (* Uniproc *) let check_uniproc test conc rf fr co = let rel = S.unions [fr;rf;co;conc.S.pos] in let r = E.EventRel.is_acyclic rel in if S.O.optace = OptAce.True then assert r ; let r = let open Model in match O.through with | ThroughNone|ThroughInvalid -> r | ThroughAll -> true in if not r then pp_failure test conc (Printf.sprintf "%s: Uniproc violation" test.Test_herd.name.Name.name) [("co",S.rt co); ("fr",fr); ("pos",S.rt conc.S.pos)] ; r let check_atom test conc fr co = let ws = U.collect_mem_stores conc.S.str in let r = E.EventRel.for_all (fun (r,w) -> assert (E.same_location r w) ; let loc = match E.location_of w with | Some loc -> loc | None -> assert false in let ws = U.LocEnv.find loc ws in not (List.exists (fun w' -> E.proc_of r <> E.proc_of w' && E.EventRel.mem (r,w') fr && E.EventRel.mem (w',w) co) ws)) conc.S.atomic_load_store in let r = check_through r in if not r then pp_failure test conc (Printf.sprintf "%s: Atomicity violation" test.Test_herd.name.Name.name) ["co",S.rt co; "fr",fr;"r*/w*",conc.S.atomic_load_store;]; r end herd-herdtools7-1ca343e/herd/modelUtils.mli000066400000000000000000000043421475314470400207130ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Simple utilities used in many models *) module Make : functor (O:Model.Config) -> functor (S:SemExtra.S) -> sig (*******************************************) (* Complete re-computation of dependencies *) (*******************************************) val make_procrels : (S.event -> bool) -> S.concrete -> S.procrels val pp_procrels : string option -> S.procrels -> S.rel_pp (***************************) (* Draw execution diagrams *) (***************************) val pp : S.test -> S.concrete -> string -> S.rel_pp -> unit val pp_failure : S.test -> S.concrete -> string -> S.rel_pp -> unit (*************************) (* Some checks factorized *) (*************************) val check_through : bool -> bool (* Includes pretty printing of failures *) val check_uniproc : S.test -> S.concrete -> S.event_rel (* rf *)-> S.event_rel (* fr *)-> S.event_rel (* co *) -> bool val check_atom : S.test -> S.concrete -> S.event_rel (* fr *)-> S.event_rel (* co *) -> bool end herd-herdtools7-1ca343e/herd/monad.mli000066400000000000000000000365351475314470400177010ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Authors: *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* Hadrien Renaud, University College London, UK. *) (****************************************************************************) (** A monad for event structures *) (* Define a monad, which is a composition of event set state and a single variable state (to pick new eiids *) module type S = sig module A : Arch_herd.S module E : Event.S with module Act.A = A module VC : Valconstraint.S with type atom = A.V.v and type cst = A.V.Cst.v and type solution = A.V.solution and type location = A.location and type state = A.state and type arch_op1 = A.V.arch_op1 and type arch_op = A.V.arch_op type 'a t type 'a code val zeroT : 'a t val zerocodeT : 'a code val unitT : 'a -> 'a t val warnT : string -> 'a -> 'a t val failT : exn -> 'a -> 'a t val ignore : 'a -> unit t val unitcodeT : 'a -> 'a code val failcodeT : exn -> 'a -> 'a code val warncodeT : string -> 'a -> 'a code val delay_kont : string -> 'a t -> ('a -> 'a t -> 'b t) -> 'b t val delay : 'a t -> ('a * 'a t) t val set_standard_input_output : 'a t -> 'a t (* [restrict constraints] is an empty monad with the constraints [constraints] *) val restrict : VC.cnstrnts -> unit t (* Data composition, entry for snd monad: minimals for iico_data *) val (>>=) : 'a t -> ('a -> 'b t) -> 'b t (* Input to second arg *) val data_input_next : 'a t -> ('a -> 'b t) -> 'b t (* Input to both args *) val data_input_union : 'a t -> ('a -> 'b t) -> 'b t (* Same as [>>=] but sequences partial_po *) val asl_data : 'a t -> ('a -> 'b t) -> 'b t val (>>==) : 'a t -> ('a -> 'b t) -> 'b t (* Output events stay in first arg *) (* Input to both args *) val data_output_union : 'a t -> ('a -> 'b t) -> 'b t (** [data_output_union s f] returns a composition of the event structures of [s] and the result of [f] where the [iico_causality_data] includes pairs (e1, e2) where e1 is an output event of e1 and e2 an input event of the result of [f]. The output of the resulting event structure is the union of the output events of [s] and the output events of the result of [f]. *) (* Control composition *) val (>>*=) : 'a t -> ('a -> 'b t) -> 'b t val control_input_union : 'a t -> ('a -> 'b t) -> 'b t (** Input is union of both arg inputs *) val control_input_next : 'a t -> ('a -> 'b t) -> 'b t (** Input is second arg's input *) val (>>*==) : 'a t -> ('a -> 'b t) -> 'b t (* Output events stay in first argument *) val bind_control_set_data_input_first : 'a t -> ('a -> 'b t) -> 'b t (* Data input fixed in first argumst *) (* Control composition, avoid events from first argument) *) val bind_ctrl_avoid : 'c t -> 'a t -> ('a -> 'b t) -> 'b t (* Data composition, entry for snd monad: minimals for complete iico *) val bind_data_to_minimals : 'a t -> ('a -> 'b t) -> ('b) t val bind_data_to_output : 'a t -> ('a -> 'b t) -> 'b t (** [bind_data_to_output s f] returns a composition of the event structures of [s] and the result of [f] where the [iico_causality_data] includes pairs (e1, e2) where e1 is an output event of e1 and e2 an onput event of the result of [f]. The output of the resulting event structure is the union of the output events of [s] and the output events of the result of [f]. *) (* Control compoisition, but output events might be in first event if second is empty. *) val bind_ctrl_seq_data : 'a t -> ('a -> 'b t) -> 'b t (* Similar as [bind_ctrl_seq_data] but sequences partial_po *) val asl_ctrl : 'a t -> ('a -> 'b t) -> 'b t (* Hybrid composition m1 m2 m3, m1 -ctrl+data-> m3 and m2 -data-> m3. ctrl+data -> ctrl from maximal commit evts + data from monad output *) val bind_ctrldata_data : 'a t -> 'b t -> ('a -> 'b -> 'c t) -> 'c t (* Similar, no second argument *) val bind_ctrldata : 'a t -> ('a -> 'c t) -> 'c t (* Same as bind_ctrldata, all output from first argument *) val (>>**==) : 'a t -> ('a -> 'b t) -> 'b t (* Identical control dep only, all output from firtst argument *) val bind_ctrl_first_outputs : 'a t -> ('a -> 'b t) -> 'b t (* Same as [>>=] but with order deps instead of data between the arguments. *) val bind_order : 'a t -> ('a -> 'b t) -> 'b t val short : (E.event -> bool) -> (E.event -> bool) -> 'a t -> 'a t (** [short p1 p2 s] adds iico_causality_data relations to [s]. New relation start from all events in [s] that satisfy [p1] and finish on all events in [s] that satisfy [p2]. *) (* Another ad-hoc transformation. [upOneRW p m] * Let r be iico_data, e1 and e2 be events s.t. p is true, e1 is 1 read e2 is a write, * and there exists e0, s.r. e1 -r-> e0 -r-> e2, then replace e0 -r0-> e2 by e1 -r-> e2. *) val upOneRW : (E.event -> bool) -> 'a t -> 'a t val exch : 'a t -> 'a t -> ('a -> 'b t) -> ('a -> 'c t) -> ('b * 'c) t (* Those amo_strict and swp are the AArch64 combinators, with complete internal dependencies. In particular there is a iico_ctrl dependency from read_register to write_register. The dependency from read_mem to write_mem is iico_ctrl for swp and iico_data for amo_strict. First bool argument <=> physical access. *) val swp : bool -> ('loc t) -> ('loc -> A.V.v t) -> A.V.v t (* read reg *) -> ('loc -> A.V.v -> unit t) -> (A.V.v -> unit t) (* Write reg *) -> unit t val amo_strict : bool -> A.V.op_t -> ('loc t) -> ('loc -> A.V.v t) -> A.V.v t (* read reg *) -> ('loc -> A.V.v -> unit t) -> (A.V.v -> unit t) (* Write reg *) -> unit t val linux_exch : 'loc t -> 'v t -> ('loc -> 'w t) -> ('loc -> 'v -> unit t) -> 'w t (* Weak amo, without control dependency from read read to write reg. In fact, the write reg is absent *) val amo : A.V.op_t -> 'loc t -> A.V.v t -> ('loc -> A.V.v t) -> ('loc -> A.V.v -> unit t) -> A.V.v t val linux_cmpexch_ok : 'loc t -> 'v t -> 'v t -> ('loc -> 'v t) -> ('loc -> 'v -> unit t) -> ('v -> 'v -> unit t) -> 'v t val linux_cmpexch_no : 'loc t -> 'v t -> ('loc -> 'v t) -> ('v -> 'v -> unit t) -> 'v t val linux_add_unless_ok : 'loc t -> 'v t -> 'v t -> ('loc -> 'v t) -> ('loc -> 'v -> unit t) -> ('v -> 'v -> unit t) -> ('v -> 'v -> 'v t) -> 'v option -> 'v t val linux_add_unless_no : 'loc t -> 'v t -> ('loc -> 'v t) -> ('v -> 'v -> unit t) -> 'v option -> 'v t val riscv_store_conditional : A.V.v t -> A.V.v t -> A.V.v t -> (* read reserve, data, address *) (unit t) -> (* write reserve *) (A.V.v -> unit t) -> (* write result *) (A.V.v -> A.V.v -> A.V.v -> unit t) -> (* write mem *) unit t val aarch64_store_conditional : bool -> (* must fail *) A.V.v t -> A.V.v t -> A.V.v t -> (* read reserve, data, address *) (unit t) -> (* write reserve *) (A.V.v -> unit t) -> (* write result *) (A.V.v -> A.V.v -> A.V.v -> unit t) -> (* write mem *) unit t val aarch64_cas_no : bool -> (* physical access *) 'loc t -> 'v t -> ('v -> unit t) -> ('loc -> 'v t) -> ('loc -> unit t) -> ('v -> 'v -> unit t) -> unit t val aarch64_cas_no_with_writeback : bool -> (* physical access *) 'loc t -> 'v t -> ('v -> unit t) -> ('loc -> 'v t) -> ('loc -> 'v -> unit t) -> ('loc -> unit t) -> ('v -> 'v -> unit t) -> unit t val aarch64_cas_ok : bool -> (* physical access *) 'loc t -> 'v t -> 'v t -> ('v -> unit t) -> ('loc -> 'v t) -> ('loc -> 'v -> unit t) -> ('loc -> unit t) -> ('v -> 'v -> unit t) -> unit t (* Temporary morello variation of CAS *) val aarch64_cas_ok_morello : 'loc t -> 'v t -> 'v t -> ('loc -> 'v -> unit t) -> unit t val stu : 'a t -> 'a t -> ('a -> unit t) -> (('a * 'a) -> unit t) -> unit t type poi = int val add_instr : ('b -> bool) -> (poi -> (poi * 'a) t) -> ('a -> 'b code) -> 'b code val (>>>) : (poi -> (poi * 'a) t) -> ('a -> 'b code) -> 'b code val (>>>>) : 'a t -> ('a -> 'b t) -> 'b t (* Parallel composition *) val (>>|) : 'a t -> 'b t -> ('a * 'b) t val para_atomic : 'a t -> 'b t -> ('a * 'b) t (* For single copy atomic memory accesses *) val para_input_right : 'a t -> 'b t -> ('a * 'b) t (* Input in second argument *) val (>>::) : 'a t -> 'a list t -> 'a list t val (|||) : unit t -> unit t -> unit t val cseq : 'a t -> ('a -> 'b t) -> 'b t (** [cseq s1 s2] similar to [>>|], but binding style. *) val para_bind_output_right : 'a t -> ('a -> 'b t) -> 'b t (** [para_bind_output_right s f] returns a parallel composition of the event structures of [s] and the result of [f] where the input of the new event structure is the union of the inputs of [s] and the result of [f], like [cseq]. Unlike [cseq] the output of the resulting event structure is set to the result of [f]. *) val asl_seq : 'a t -> ('a -> 'b t) -> 'b t (** [asl_seq s f] returns a parallel composition of [s] and the result of [f] where the input of the new event structure is the union of the inputs of [s] and the result of [f], like [cseq] and [para_bind_output_right]. Unlike the later, a [partial_po] arrow is put between the two structures. *) val seq_mem : 'a t -> 'b t -> ('a * 'b) t (** [seq_mem s1 s2] returns a composition of the event structures of [s1] and [s2] where in addition to the existing relations, every memory event in [s1] is iico_order before every memory event in [s2] *) val seq_mem_list : 'a t -> 'a list t -> 'a list t (** [seq_mem_list] is similar to [seq_mem], but cons the results instead of pairing them *) val (|*|) : bool code -> unit code -> unit code (* Cross product *) (* val lockT : 'a t -> 'a t *) val forceT : 'a -> 'b t -> 'a t val (>>!) : 'a t -> 'b -> 'b t val discardT : 'a t -> unit t val addT : 'a -> 'b t -> ('a * 'b) t val assertT : A.V.v -> 'a t -> 'a t val choiceT : A.V.v -> 'a t -> 'a t -> 'a t val condPredT : A.V.v -> unit t -> 'a t -> 'a t -> 'a t val condJumpT : A.V.v -> 'a code -> 'a code -> 'a code val indirectJumpT : A.V.v -> Label.Full.Set.t -> (Label.t -> 'a code) -> 'a code val altT : 'a t -> 'a t -> 'a t val cutoffT : string -> E.A.inst_instance_id -> 'v -> 'v t val debugT : string -> 'a t -> 'a t (** [debugT str s] prints [str] followed by a string representation of the input event structure [s], and returns the input [s] without making any changes to it *) (**********************************************************) (* A few action instruction instance -> monad constructors *) (**********************************************************) val mk_singleton_es : E.action -> A.inst_instance_id -> unit t val mk_singleton_es_success : E.action -> A.inst_instance_id -> unit t val mk_singleton_es_eq : E.action -> VC.cnstrnts -> A.inst_instance_id -> unit t (****************) (* Basic monads *) (****************) (* read_loc is_data mk_action loc ii for each value v that could be read, make an event structure comprising a single event with instruction id "ii", and action "mk_action v loc". is_data charaterizes the data port of a store *) (* Read, the first, boolean, argument identifies a store data port *) val do_read_loc : bool -> (A.location -> A.V.v -> E.action) -> A.location -> E.iiid -> A.V.v t val read_loc : bool -> (A.location -> A.V.v -> E.action) -> A.location -> A.inst_instance_id -> A.V.v t val do_write_loc : (A.location -> E.action) -> A.location -> E.iiid -> unit t val write_loc : (A.location -> E.action) -> A.location -> A.inst_instance_id -> unit t (* Fence, must be used when output is absent *) val mk_fence : E.action -> A.inst_instance_id -> unit t (* Fetch and op *) val fetch : A.V.op_t -> A.V.v -> (A.V.v -> A.V.v -> E.action) -> A.inst_instance_id -> A.V.v t (* [as_data_port m] flags all events in [m] as data. *) val as_data_port : 'a t -> 'a t (**********************) (* Morello extensions *) (**********************) val add_atomic_tag_read : A.V.v t -> A.V.v -> (A.location -> A.V.v -> E.action) -> A.inst_instance_id -> A.V.v t val add_atomic_tag_write : unit t -> A.V.v -> A.V.v -> (A.location -> A.V.v -> E.action) -> A.inst_instance_id -> unit t module Mixed : functor (SZ : ByteSize.S) -> sig val read_mixed : bool ->MachSize.sz -> (MachSize.sz -> A.location -> A.V.v -> E.action) -> A.V.v -> A.inst_instance_id -> A.V.v t val write_mixed : MachSize.sz -> (MachSize.sz -> A.location -> A.V.v -> E.action) -> A.V.v -> A.V.v -> A.inst_instance_id -> unit t (* Generate initial code monad, first argument represent additional events, beyond intwrites themselves *) val initwrites : (unit t -> unit t) -> (A.location * A.V.v) list -> A.size_env -> unit code end (* Operations *) val op1 : A.V.op1_t -> A.V.v -> A.V.v t val op : A.V.op_t -> A.V.v -> A.V.v -> A.V.v t val op3 : Op.op3 -> A.V.v -> A.V.v -> A.V.v -> A.V.v t val add : A.V.v -> A.V.v -> A.V.v t (* Equality *) val assign : A.V.v -> A.V.v -> unit t val eqT : A.V.v -> A.V.v -> unit t (* Acts as an inequality equation *) val neqT : A.V.v -> A.V.v -> unit t (* Read out monad *) type evt_struct type output = VC.cnstrnts * evt_struct val get_output : 'a code -> output list -> output list (* Force executed only once. *) val force_once : 'a t -> 'a t end herd-herdtools7-1ca343e/herd/noLevelNorTLBI.ml000066400000000000000000000026331475314470400211600ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2020-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) type level let levels = [] let pp_level _ = assert false module TLBI = struct type op let pp_op = fun _ -> Printf.sprintf "no notion of TLBI op in arch" let is_at_level _lvl _op = assert false let inv_all _ = false let sets = [] end herd-herdtools7-1ca343e/herd/noLevelNorTLBI.mli000066400000000000000000000027271475314470400213350ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* No level, no TLBI fake module for architectures other than AArch64 *) type level val levels : level list val pp_level : level -> string module TLBI : sig type op val pp_op : op -> string val is_at_level : level -> op -> bool val inv_all : op -> bool val sets : (string * (op -> bool)) list end herd-herdtools7-1ca343e/herd/noSemEnv.ml000066400000000000000000000024761475314470400201610ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2021-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Do nothing semantics runtime approximations of context *) let opt_env = false let killed _ = [] let get_lx_sz _ = MachSize.No let reg_defaults = [] herd-herdtools7-1ca343e/herd/noSemEnv.mli000066400000000000000000000027341475314470400203270ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2021-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Do nothing semantics runtime approximations of context *) (* Perform approximation *) val opt_env : bool (* Registers killed by instruction *) val killed : 'i -> 'r list (* Size of load reserve access *) val get_lx_sz : 'i -> MachSize.lr_sc (* Register initialised by default *) val reg_defaults : 'r list herd-herdtools7-1ca343e/herd/optAce.ml000066400000000000000000000026611475314470400176360ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2021-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) type t = False | True | Iico let tags = ["false";"true";"iico";] let parse tag = match Misc.lowercase tag with | "false" -> Some False | "true" -> Some True | "iico" -> Some Iico | _ -> None let pp = function | False -> "false" | True -> "true" | Iico -> "iico" herd-herdtools7-1ca343e/herd/optAce.mli000066400000000000000000000024431475314470400200050ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2021-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** 'OptAce' tags *) type t = False | True | Iico val tags : string list val parse : string -> t option val pp : t -> string herd-herdtools7-1ca343e/herd/opts.ml000066400000000000000000000121101475314470400173760ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Parsing of command line options and reading of configuration files modify mutable variables defined here *) (* Myself *) let prog = if Array.length Sys.argv > 0 then Sys.argv.(0) else "herd" (* Local options *) let verbose = ref 0 let libdir = ref (Filename.concat Version.libdir "herd") let includes = ref [] let exit_if_failed = ref false let timeout = ref None let debug = ref Debug_herd.none let names = ref [] let excl = ref [] let rename = ref [] let kinds = ref [] let conds = ref [] let model = ref None let bell = ref None let macros = ref None let unroll_default = function |`ASL -> 4 | _ -> 2 let unroll = ref None let speedcheck = ref Speed.False let archcheck = ref true let optace = ref None let variant = ref (fun _ -> false) module Refs = struct let fault_handling = ref Fault.Handling.default let mte_precision = ref Precision.default let sve_vector_length = ref 128 let sme_vector_length = ref 128 end module OptS = ParseTag.MakeOptS(Variant)(Refs) let byte = ref MachSize.Tag.Auto let endian = ref None let initwrites = ref None let check_filter = ref true let badexecs = ref true let badflag = ref None let through = ref Model.ThroughNone let throughflag = ref None let skipchecks = ref StringSet.empty let strictskip = ref false let cycles = ref StringSet.empty let show = ref PrettyConf.ShowNone let nshow = ref None let candidates = ref false let restrict = ref Restrict.No let showkind = ref false let shortlegend = ref false let outcomereads = ref false let suffix = ref "" let dumpes = ref false let outputdir = ref PrettyConf.NoOutputdir let dumplem = ref false let dumptex = ref false let maxphantom= ref None let statelessrc11 = ref false let dumpallfaults = ref false (* Pretty printing configuration, deserves its own module *) module PP = struct open PrettyConf let dotmode = ref Plain let dotcom = ref None let view = ref None let showevents = ref NonRegEvents let texmacros = ref false let tikz = ref false let hexa = ref false let mono = ref false let fontname = ref None let fontsize = ref None let edgedelta = ref 0 let penwidth = ref None let arrowsize = ref None let splines = ref None let overlap = ref None let sep = ref None let pad = ref None let margin = ref None let scale = ref 1.0 let xscale = ref 1.0 let yscale = ref 1.0 let dsiy = ref 0.3 let siwidth = ref 0.75 let boxscale = ref 1.0 let ptscale = ref 3.0 let squished = ref false let graph = ref Graph.Cluster let showpo = ref true let relabel = ref false let withbox = ref false let labelbox = ref false let showthread = ref true let showlegend = ref true let showfinalrf = ref false let showinitrf = ref false let finaldotpos = ref (0.4,-0.3333) let initdotpos = ref (-0.4,0.3333) let oneinit = ref true let initpos = ref None let showinitwrites = ref true let threadposy = ref 0.6 let dotheader = ref None let brackets = ref true let showobserved = ref false let movelabel = ref false let fixedsize = ref false let edgeattrs = ref DotEdgeAttr.empty let add_edgeattr lbl a v = edgeattrs := DotEdgeAttr.add lbl a v !edgeattrs let get_edgeattrs () = !edgeattrs let doshow = ref StringSet.empty let unshow = ref StringSet.empty let add_doshow u = doshow := StringSet.union u !doshow ; unshow := StringSet.diff !unshow u let add_unshow u = unshow := StringSet.union u !unshow ; doshow := StringSet.diff !doshow u let noid = ref StringSet.empty let symetric = ref StringSet.empty let classes = ref None let showraw = ref StringSet.empty let extrachars = ref 0.0 let shift = ref [| |] let edgemerge = ref false let labelinit = ref true end (* Load file from library, list of includes to add to search paths given *) let libfind includes debug = let module ML = MyLib.Make (struct let includes = includes let env = Some "HERDLIB" let libdir = !libdir let debug = debug end) in ML.find herd-herdtools7-1ca343e/herd/opts.mli000066400000000000000000000114511475314470400175560ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Parsing of command line options and reading of configuration files *) (* modify mutable variables defined here *) (* Myself *) val prog : string (* Local options *) val verbose : int ref val libdir : string ref val includes : string list ref val exit_if_failed : bool ref val timeout : float option ref val debug : Debug_herd.t ref val names : string list ref val excl : string list ref val rename : string list ref val kinds : string list ref val conds : string list ref val model : Model.t option ref val bell : string option ref val macros : string option ref val unroll_default : [> `ASL ] -> int val unroll : int option ref val speedcheck : Speed.t ref val optace : OptAce.t option ref val archcheck : bool ref val variant : (Variant.t -> bool) ref module Refs : sig val fault_handling : Fault.Handling.t ref val mte_precision : Precision.t ref val sve_vector_length : int ref val sme_vector_length : int ref end module OptS : ParseTag.OptS with type t = Variant.t val byte : MachSize.Tag.t ref val endian : Endian.t option ref val initwrites : bool option ref val check_filter : bool ref val badexecs : bool ref val badflag : string option ref val through : Model.through ref val throughflag : string option ref val skipchecks : StringSet.t ref val strictskip : bool ref val cycles : StringSet.t ref val show : PrettyConf.show ref val nshow :int option ref val candidates : bool ref val restrict : Restrict.t ref val showkind : bool ref val shortlegend : bool ref val outcomereads : bool ref val outputdir : PrettyConf.outputdir_mode ref val suffix : string ref val dumpes : bool ref val dumplem : bool ref val dumptex : bool ref val maxphantom : int option ref val statelessrc11 : bool ref val dumpallfaults : bool ref (* Pretty printing configuration, deserves its own module *) module PP : sig open PrettyConf val dotmode : dotmode ref val dotcom : dotcom option ref val view : View.t option ref val showevents : showevents ref val texmacros : bool ref val tikz : bool ref val hexa : bool ref val mono : bool ref val fontname : string option ref val fontsize : int option ref val edgedelta : int ref val penwidth : float option ref val arrowsize : float option ref val splines : Splines.t option ref val overlap : string option ref val sep : string option ref val pad : float option ref val margin : float option ref val scale : float ref val xscale : float ref val yscale : float ref val dsiy : float ref val siwidth : float ref val boxscale : float ref val ptscale : float ref val squished : bool ref val graph : Graph.t ref val showpo : bool ref val relabel : bool ref val withbox : bool ref val labelbox : bool ref val showthread : bool ref val showlegend : bool ref val showfinalrf : bool ref val showinitrf : bool ref val finaldotpos : (float * float) ref val initdotpos : (float * float) ref val oneinit : bool ref val initpos : (float * float) option ref val showinitwrites : bool ref val threadposy : float ref val dotheader : string option ref val brackets : bool ref val showobserved : bool ref val movelabel : bool ref val fixedsize : bool ref val add_edgeattr : string -> string -> string -> unit val get_edgeattrs : unit -> DotEdgeAttr.t val doshow : StringSet.t ref val unshow : StringSet.t ref val add_doshow : StringSet.t -> unit val add_unshow : StringSet.t -> unit val noid : StringSet.t ref val symetric : StringSet.t ref val classes : string option ref val showraw : StringSet.t ref val extrachars : float ref val shift : float array ref val edgemerge : bool ref val labelinit : bool ref end val libfind : string list -> bool -> string -> string herd-herdtools7-1ca343e/herd/parseTest.ml000066400000000000000000000164471475314470400204040ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2012-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Authors: *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* Hadrien Renaud, University College London, UK. *) (****************************************************************************) module Top (TopConf:RunTest.Config) = struct module SP = Splitter.Make (struct let debug = TopConf.debug.Debug_herd.lexer let check_rename = TopConf.check_rename end) let do_from_file start_time env name chan = if TopConf.debug.Debug_herd.files then MyLib.pp_debug name ; (* First split the input file in sections *) let (splitted:Splitter.result) = SP.split name chan in let tname = splitted.Splitter.name.Name.name in let module Conf = struct (* override the precision and variant fields *) (* Modify variant with the 'Variant' field of test *) module TestConf = TestVariant.Make (struct module Opt = Variant let info = splitted.Splitter.info let variant = TopConf.variant let mte_precision = TopConf.mte_precision let fault_handling = TopConf.fault_handling let sve_vector_length = TopConf.sve_vector_length let sme_vector_length = TopConf.sme_vector_length end) (* Override *) include TopConf let unroll = Option.map (fun s -> try int_of_string s with Failure _ -> Warn.user_error "unroll exects an integer argument") (MiscParser.get_info_on_info MiscParser.unroll_key splitted.Splitter.info) |> (function | None -> unroll | Some _ as o -> o) let fault_handling = TestConf.fault_handling let mte_precision = TestConf.mte_precision let sve_vector_length = TestConf.sve_vector_length let sme_vector_length = TestConf.sme_vector_length let variant = TestConf.variant end in if Conf.check_name tname then begin (* Get arch *) let arch = splitted.Splitter.arch in (* Now, we have the architecture, call specific parsers generically. *) let model = GetModel.parse Conf.archcheck arch Conf.libfind Conf.variant Conf.model in let cache_type = CacheType.get splitted.Splitter.info in let variant_patched_with_cache_type = let dic_pred, idc_pred = let open CacheType in match cache_type with | None -> (fun _ -> false), (fun _ -> false) | Some cache_type -> cache_type.dic, cache_type.idc in Misc.(|||) Conf.variant (function | Variant.DIC -> dic_pred 0 | Variant.IDC -> idc_pred 0 | _ -> false) in let dirty = DirtyBit.get splitted.Splitter.info in let module ModelConfig = struct let bell_model_info = Conf.bell_model_info let model = model let showsome = begin match Conf.outputdir with | PrettyConf.StdoutOutput | PrettyConf.Outputdir _ -> true | _ -> false end || Misc.is_some Conf.PC.view || Conf.variant Variant.MemTag || Conf.variant Variant.Morello let through = Conf.through let debug = Conf.debug.Debug_herd.barrier let debug_files = Conf.debug.Debug_herd.files let profile = Conf.debug.Debug_herd.profile_cat let verbose = Conf.verbose let skipchecks = Conf.skipchecks let strictskip = Conf.strictskip let cycles = Conf.cycles let optace = Conf.optace let libfind = Conf.libfind let variant = variant_patched_with_cache_type let dirty = dirty let statelessrc11 = Conf.statelessrc11 end in let module ArchConfig = SemExtra.ConfigToArchConfig(Conf) in match arch with | `PPC -> let module X = PPCParseTest.Make(Conf)(ModelConfig) in X.run dirty start_time name chan env splitted | `ARM -> let module X = ARMParseTest.Make(Conf)(ModelConfig) in X.run dirty start_time name chan env splitted | `BPF -> let module X = BPFParseTest.Make(Conf)(ModelConfig) in X.run dirty start_time name chan env splitted | `AArch64 -> if Conf.variant Variant.ASL then let module X = AArch64ASLParseTest.Make(Conf)(ModelConfig) in X.run dirty start_time name chan env splitted else let module X = AArch64ParseTest.Make(Conf)(ModelConfig) in X.run dirty start_time name chan env splitted | `X86 -> let module X = X86ParseTest.Make(Conf)(ModelConfig) in X.run dirty start_time name chan env splitted | `X86_64 -> let module X = X86_64ParseTest.Make(Conf)(ModelConfig) in X.run dirty start_time name chan env splitted | `MIPS -> let module X = MIPSParseTest.Make(Conf)(ModelConfig) in X.run dirty start_time name chan env splitted | `RISCV -> let module X = RISCVParseTest.Make(Conf)(ModelConfig) in X.run dirty start_time name chan env splitted | `C -> let module X = CParseTest.Make(Conf)(ModelConfig) in X.run dirty start_time name chan env splitted | `JAVA -> let module X = JAVAParseTest.Make(Conf)(ModelConfig) in X.run dirty start_time name chan env splitted | `LISA -> let module X = LISAParseTest.Make(Conf)(ModelConfig) in X.run dirty start_time name chan env splitted (* START NOTWWW *) | `ASL -> let module X = ASLParseTest.Make(Conf)(ModelConfig) in X.run dirty start_time name chan env splitted (* END NOTWWW *) | arch -> Warn.fatal "no support for arch '%s'" (Archs.pp arch) end else env (* Enter here... *) let from_file name env = (* START NOTWWW *) (* Interval timer will be stopped just before output, see top_herd *) Itimer.start name TopConf.timeout ; (* END NOTWWW *) let start_time = Sys.time () in Misc.input_protect (do_from_file start_time env name) name end herd-herdtools7-1ca343e/herd/parseTest.mli000066400000000000000000000025341475314470400205450ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Run a test from source file, dispatch on tests architecture *) module Top : functor (C : RunTest.Config) -> sig val from_file : string -> TestHash.env -> TestHash.env end herd-herdtools7-1ca343e/herd/partition.ml000066400000000000000000000051361475314470400204340ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Imperative disjoint set data structure *) module Make (O:Set.OrderedType) : sig type t (* All creation steps must preceed union/find operations *) val create : unit -> t val add : O.t -> t -> t (* Union/Find *) val find : t -> O.t -> O.t val union : t -> O.t -> O.t -> unit (* Extract result *) module Sol : Map.S with type key = O.t val as_solution : t -> O.t Sol.t end = struct type cell = { value : O.t; mutable rank : int; mutable parent : cell; } module M = Map.Make(O) type t = cell M.t let map_find x m = try M.find x m with Not_found -> assert false (* Creation *) let create () = M.empty let add x m = let rec c = { value=x; rank=0; parent=c; } in M.add x c m (* Union/Find *) let rec find_aux c = if c == c.parent then c else let d = find_aux c.parent in c.parent <- d ; d let find m x = let c = map_find x m in let d = find_aux c in d.value let union_aux c1 c2 = let d1 = find_aux c1 and d2 = find_aux c2 in if d1.rank > d2.rank then d2.parent <- d1 else if d2.rank > d1.rank then d1.parent <- d2 else if d1 != d2 then begin d2.parent <- d1 ; d1.rank <- d1.rank+1 end let union m x1 x2 = union_aux (map_find x1 m) (map_find x2 m) (* Extract *) module Sol = M let as_solution m = M.fold (fun x c k -> if c.parent == c then k else M.add x c.parent.value k) m M.empty end herd-herdtools7-1ca343e/herd/partition.mli000066400000000000000000000030541475314470400206020ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Imperative disjoint set data structure *) module Make (O:Set.OrderedType) : sig type t (* All creation steps must precede union/find operations *) val create : unit -> t val add : O.t -> t -> t (* Union/Find *) val find : t -> O.t -> O.t val union : t -> O.t -> O.t -> unit (* Extract result *) module Sol : Map.S with type key = O.t val as_solution : t -> O.t Sol.t end herd-herdtools7-1ca343e/herd/prettyConf.ml000066400000000000000000000111021475314470400205460ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2012-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Pretty printing configuration *) type outputdir_mode = | NoOutputdir | Outputdir of string | StdoutOutput (* What to show *) type show = | ShowProp (* According to prop *) | ShowCond (* According to condition *) | ShowNone (* Nothing *) | ShowAll (* Everything *) | ShowNeg (* prop negation *) | ShowWit (* Be clever *) | ShowFlag of string (* Show execution flagged with string *) let tags_show =["prop";"all";"neg";"cond";"none";"wit";] let pp_show = function | ShowProp -> "prop" | ShowCond -> "cond" | ShowNone -> "none" | ShowAll -> "all" | ShowNeg -> "neg" | ShowWit -> "wit" | ShowFlag f -> Printf.sprintf "flag<%s>" f let parse_show tag = match Misc.lowercase tag with | "prop" -> Some ShowProp | "cond" -> Some ShowCond | "none" -> Some ShowNone | "all" -> Some ShowAll | "neg" -> Some ShowNeg | "wit" -> Some ShowWit | _ -> None type dotmode = Plain | Fig let tags_dotmode = ["plain";"fig";] let pp_dotmode = function | Plain -> "plain" | Fig -> "fig" let parse_dotmode s = match s with | "plain" -> Some Plain | "fig" -> Some Fig | _ -> None (* Control over dot command *) type dotcom = DotCom | NeatoCom | CircoCom let tags_dotcom = ["dot";"neato";"circo";] let pp_dotcom = function | DotCom -> "dot" | NeatoCom -> "neato" | CircoCom -> "circo" let parse_dotcom = function | "dot" -> Some DotCom | "neato" -> Some NeatoCom | "circo" -> Some CircoCom | _ -> None (* Events shown in figures *) type showevents = AllEvents | MemEvents | NonRegEvents | MemFenceEvents let tags_showevents = ["all"; "mem"; "noregs";"memf";] let pp_showevents = function | AllEvents -> "all" | MemEvents -> "mem" | NonRegEvents -> "noregs" | MemFenceEvents -> "memfence" let parse_showevents = function | "all" -> Some AllEvents | "mem"|"memory" -> Some MemEvents | "noregs" -> Some NonRegEvents | "memf"|"memfence" -> Some MemFenceEvents | _ -> None module type S = sig val debug : bool val verbose : int val dotcom : dotcom option val view : View.t option val dotmode : dotmode val showevents : showevents val texmacros : bool val tikz : bool val hexa : bool val mono : bool val fontname : string option val fontsize : int option val edgedelta : int val penwidth : float option val arrowsize : float option val splines : Splines.t option val overlap : string option val sep : string option val pad : float option val margin : float option val scale : float val xscale : float val yscale : float val dsiy : float val siwidth : float val boxscale : float val squished : bool val graph : Graph.t val showpo : bool val relabel : bool val withbox : bool val labelbox : bool val showthread : bool val showlegend : bool val showfinalrf : bool val showinitrf : bool val finaldotpos : float * float val initdotpos : float * float val oneinit : bool val initpos : (float * float) option val threadposy : float val showinitwrites : bool val dotheader : string option val brackets : bool val showobserved : bool val movelabel : bool val fixedsize : bool val edgeattrs : DotEdgeAttr.t val doshow : StringSet.t val unshow : StringSet.t val noid : StringSet.t val symetric : StringSet.t val classes : string option val showraw : StringSet.t val extrachars : float val shift : float array val ptscale : float val edgemerge : bool val labelinit : bool val variant : Variant.t -> bool end herd-herdtools7-1ca343e/herd/prettyConf.mli000066400000000000000000000074441475314470400207350ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2012-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Pretty printing configuration *) type outputdir_mode = | NoOutputdir | Outputdir of string | StdoutOutput (* What to show *) type show = | ShowProp (* According to prop *) | ShowCond (* According to condition *) | ShowNone (* Nothing *) | ShowAll (* Everything *) | ShowNeg (* prop negation *) | ShowWit (* Be clever *) | ShowFlag of string (* Show execution flagged with string *) val tags_show : string list val pp_show : show -> string val parse_show : string -> show option (* Control over dot files (fig needs some adaptation) *) type dotmode = Plain | Fig val tags_dotmode : string list val pp_dotmode : dotmode -> string val parse_dotmode : string -> dotmode option (* Control over dot command *) type dotcom = DotCom | NeatoCom | CircoCom val tags_dotcom : string list val pp_dotcom : dotcom -> string val parse_dotcom : string -> dotcom option (* Events shown in figures *) type showevents = AllEvents | MemEvents | NonRegEvents | MemFenceEvents val tags_showevents : string list val pp_showevents : showevents -> string val parse_showevents : string -> showevents option (* All options... *) module type S = sig val debug : bool val verbose : int val dotcom : dotcom option val view : View.t option val dotmode : dotmode val showevents : showevents val texmacros : bool val tikz : bool val hexa : bool val mono : bool val fontname : string option val fontsize : int option val edgedelta : int val penwidth : float option val arrowsize : float option val splines : Splines.t option val overlap : string option val sep : string option val pad : float option val margin : float option val scale : float val xscale : float val yscale : float val dsiy : float val siwidth : float val boxscale : float val squished : bool val graph : Graph.t val showpo : bool val relabel : bool val withbox : bool val labelbox : bool val showthread : bool val showlegend : bool val showfinalrf : bool val showinitrf : bool val finaldotpos : float * float val initdotpos : float * float val oneinit : bool val initpos : (float * float) option val threadposy : float val showinitwrites : bool val dotheader : string option val brackets : bool val showobserved : bool val movelabel : bool val fixedsize : bool val edgeattrs : DotEdgeAttr.t val doshow : StringSet.t val unshow : StringSet.t val noid : StringSet.t val symetric : StringSet.t val classes : string option val showraw : StringSet.t val extrachars : float val shift : float array val ptscale : float val edgemerge : bool val labelinit : bool val variant : Variant.t -> bool end herd-herdtools7-1ca343e/herd/prettyUtils.ml000066400000000000000000000100301475314470400207600ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make(S : SemExtra.S) = struct module A = S.A module E = S.E let progorder_as_list es = let by_po = E.EventSet.fold (fun e k -> match E.progorder_of e with | None -> k | Some poi -> let es_poi = IntMap.safe_find [] poi k in IntMap.add poi (e::es_poi) k) es IntMap.empty in let as_list = IntMap.fold (fun _ es k -> es::k) by_po [] in List.rev_map E.EventSet.of_list as_list let make_by_proc_and_poi es = let by_proc = E.proj_events es in List.map progorder_as_list by_proc let spurious_events es = E.EventSet.filter (fun e -> match e.E.iiid with | E.IdSpurious -> true | E.IdInit|E.IdSome _ -> false) es.E.events let observed test es = let locs = S.observed_locations test in let xss = make_by_proc_and_poi es in let xss = Misc.mapi (fun i x -> i,x) xss in let _,obs = List.fold_right (fun (i,ess) (locs,obs) -> let rec find_rec = function | [] -> locs,obs | es::rem -> let locs,obs as r = find_rec rem in let wr = (* significant written registers *) E.EventSet.fold (fun e k -> if E.is_reg_store e i then let rloc = Misc.as_some (E.location_of e) in if A.LocSet.mem rloc locs then A.LocSet.add rloc k else k else k) es A.LocSet.empty in if A.LocSet.is_empty wr then r else let locs = A.LocSet.diff locs wr and obs = let read = E.EventSet.filter E.is_mem_load es in E.EventSet.union obs read in locs,obs in find_rec ess) xss (locs,E.EventSet.empty) in obs (* All registers that read memory *) let all_regs_that_read es = let xss = make_by_proc_and_poi es in let xss = Misc.mapi (fun i x -> i,x) xss in let locs = List.fold_right (fun (i,ess) locs -> let rec find_rec = function | [] -> locs | es::rem -> let locs = find_rec rem in let wr = (* significant written registers *) if E.EventSet.exists E.is_mem_load es then E.EventSet.fold (fun e k -> if E.is_reg_store e i then let rloc = Misc.as_some (E.location_of e) in A.LocSet.add rloc k else k) es A.LocSet.empty else A.LocSet.empty in A.LocSet.union locs wr in find_rec ess) xss (A.LocSet.empty) in locs end herd-herdtools7-1ca343e/herd/prettyUtils.mli000066400000000000000000000032231475314470400211370ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Utilities for pretty-printing *) module Make : functor (S:SemExtra.S) -> sig (* Organize events, first by proc, then by po *) val make_by_proc_and_poi : S.event_structure -> S.event_set list list (* Extract spurious events *) val spurious_events : S.event_structure -> S.event_set (* Observed read events *) val observed : S.test -> S.event_structure -> S.event_set (* All registers that read from memory *) val all_regs_that_read : S.event_structure -> S.loc_set end herd-herdtools7-1ca343e/herd/pteValSets.ml000066400000000000000000000023461475314470400205150ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2021-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module No = struct let pteval_sets = [] let dirty_sets = [] end herd-herdtools7-1ca343e/herd/rc11.ml000066400000000000000000000165401475314470400171720ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2018-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (****************************************************************************) (* Authors: *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* Simon Colin, INRIA Paris, France. *) (****************************************************************************) open Printf module type Cfg = sig (* val coherence : bool val atomicity : bool val sc : bool val no_thin_air : bool *) include Model.Config end module Make (O:Cfg)(S:Sem.Semantics) = struct module S = S module E = S.E module A = S.A module U = MemUtils.Make(S) module MU = ModelUtils.Make(O)(S) module ER = E.EventRel let debug_proc chan p = fprintf chan "%i" p let debug_event chan e = fprintf chan "%s" (E.pp_eiid e) let debug_set chan s = output_char chan '{' ; E.EventSet.pp chan "," debug_event s ; output_char chan '}' let debug_events = debug_set let debug_rel chan r = ER.pp chan "," (fun chan (e1, e2) -> fprintf chan "%a -> %a" debug_event e1 debug_event e2) r let is_that_fence b e = match E.barrier_of e with | Some a -> a = b.S.barrier | None -> false let make_procrels conc = let is_isync = match S.isync with | None -> fun _ -> false | Some b -> is_that_fence b in MU.make_procrels is_isync conc let pp_failure test conc legend vb_pp = if O.debug && O.verbose > 1 then begin let module PP = Pretty.Make(S) in eprintf "%s\n%!" legend ; PP.show_legend test legend conc vb_pp end let check_event_structure test conc _kfail kont res = let pr = make_procrels conc in let proc_ws ws0 res = let ws = ER.transitive_closure ws0 in let unv = ER.cartesian conc.S.str.E.events conc.S.str.E.events in let rf = pr.rf in let mo = ws in let sb = conc.S.po in let rb = U.make_fr conc ws in let loc = ER.restrict_rel E.same_location unv in (* let int = ER.restrict_rel E.same_proc_not_init unv in *) let ext = ER.restrict_rel (fun e1 e2 -> not (E.same_proc e1 e2)) unv in let rmw = conc.S.atomic_load_store in let aux = fun x -> try List.assoc x S.E.Act.arch_sets with Not_found -> fun x -> true in let rlx = aux "RLX" in let acq = aux "ACQ" in let rel = aux "REL" in let acq_rel = aux "AQU_REL" in let sc = aux "SC" in let na = aux "NA" in let f = E.is_barrier in let a = aux "A" in let eco0 = ER.union3 rf mo rb in let eco = ER.transitive_closure eco0 in let rs0 = ER.sequence rf rmw in let rs1 = ER.transitive_closure rs0 in let rs2 = ER.restrict_domain (fun x -> E.is_mem_store x && (rlx x.action|| na x.action)) rs1 in let rs3 = ER.inter sb loc in let rs4 = ER.restrict_domains E.is_mem_store (fun x -> E.is_mem_store x && (rlx x.action|| na x.action)) rs3 in let rs5 = ER.sequence rs4 rs2 in let rs = ER.union rs2 rs5 in let sw0 = ER.sequence rs rf in let sw1 = ER.restrict_domain f sb in let sw2 = ER.sequence sw1 sw0 in let sw3 = ER.union sw0 sw2 in let sw4 = ER.restrict_domains (fun x -> rel x.action || acq_rel x.action || sc x.action) (fun x -> E.is_mem_store x && (rlx x.action || na x.action)) sw3 in let sw5 = ER.restrict_codomain f sb in let sw6 = ER.sequence sw4 sw5 in let sw7 = ER.union sw4 sw6 in let sw = ER.restrict_codomain (fun x -> acq x.action || acq_rel x.action || sc x.action) sw7 in let hb0 = ER.union sb sw in let hb = ER.transitive_closure hb0 in let sbl = ER.diff sb loc in let scb = ER.unions [sb; ER.sequences [sbl; hb; sbl]; ER.inter sb loc; mo; rb] in let pscb0 = ER.restrict_domain (fun x -> sc x.action) scb in let pscb1 = ER.restrict_domain (fun x -> f x && sc x.action) unv in let pscb2 = ER.inter pscb1 hb in let pscb3 = ER.sequence pscb2 scb in let pscb4 = ER.inter pscb1 scb in let pscb5 = ER.union3 pscb0 pscb3 pscb4 in let pscb6 = ER.restrict_codomain (fun x -> sc x.action) pscb5 in let pscb7 = ER.sequence pscb5 hb in let pscb8 = ER.union pscb5 pscb7 in let pscb9 = ER.restrict_codomain (fun x -> f x && sc x.action) pscb8 in let pscb = ER.union pscb6 pscb9 in let pscf0 = ER.union hb (ER.sequences [hb; eco; hb]) in let fsc = fun x -> f x && sc x.action in let pscf = ER.restrict_domains fsc fsc pscf0 in let psc = ER.union pscb pscf in let r0 = ER.union hb (ER.sequence hb eco) in let coherence = ER.is_irreflexive r0 in let r1 = ER.inter rmw (ER.sequence rb mo) in let atomicity = ER.is_empty r1 in let asc = ER.is_acyclic psc in let r2 = ER.union sb rf in let nothinair = ER.is_acyclic r2 in let cnf0 = ER.restrict_domain E.is_mem_store loc in let cnf1 = ER.restrict_codomain E.is_mem_store loc in let cnf2 = ER.union cnf0 cnf1 in let cnf3 = ER.restrict_domain (fun x -> not (E.is_mem_store_init x)) cnf2 in let cnf = ER.restrict_codomain (fun x -> not (E.is_mem_store_init x)) cnf3 in let dr0 = ER.inter cnf ext in let dr1 = ER.diff dr0 (ER.union hb (ER.inverse hb)) in let dr = ER.restrict_rel (fun x y -> not (a x.action) && not (a y.action)) dr1 in let pp_relns = lazy begin ("fr", rb):: ("mo", mo):: ("hb", hb):: ("eco", eco):: ("rmw", rmw):: ("psc", psc)::[] end in let ok = coherence && atomicity && asc && nothinair in if ok then if not (ER.is_empty dr) then kont conc conc.S.fs pp_relns (Flag.Set.add Flag.Undef Flag.Set.empty) res else kont conc conc.S.fs pp_relns Flag.Set.empty res else res in U.apply_process_co test conc proc_ws res end herd-herdtools7-1ca343e/herd/restrict.ml000066400000000000000000000031241475314470400202550ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2012-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Output restriction *) type t = Observed | NonAmbiguous | No | CondOne let tags = ["observed"; "nonambiguous"; "condone"; "none"; ] let parse tag = match Misc.lowercase tag with | "none" -> Some No | "observed" -> Some Observed | "nonambiguous" -> Some NonAmbiguous | "condone" -> Some CondOne | _ -> None let pp = function | No -> "none" | Observed -> "observed" | NonAmbiguous -> "nonambiguous" | CondOne -> "condone" herd-herdtools7-1ca343e/herd/restrict.mli000066400000000000000000000024721475314470400204330ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2012-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Output restriction *) type t = Observed | NonAmbiguous | No | CondOne val tags : string list val parse : string -> t option val pp : t -> string herd-herdtools7-1ca343e/herd/runTest.ml000066400000000000000000000067331475314470400200730ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module type Config = sig val model : Model.t option val archcheck : bool val through : Model.through val strictskip : bool val cycles : StringSet.t val bell_model_info : (string * BellModel.info) option val macros : string option val check_name : string -> bool val check_rename : string -> string option val libfind : string -> string include GenParser.Config include Top_herd.CommonConfig include Sem.Config val statelessrc11 : bool val dumpallfaults : bool val byte : MachSize.Tag.t val sve_vector_length : int val sme_vector_length : int end type runfun = DirtyBit.t option -> float (* start time *) -> string (* file name *) -> in_channel (* source channel *) -> TestHash.env -> Splitter.result -> TestHash.env module Make (S:Sem.Semantics) (P:sig type pseudo val parse : in_channel -> Splitter.result -> pseudo MiscParser.t end with type pseudo = S.A.pseudo) (M:XXXMem.S with module S = S) (C:Config) = struct module T = Test_herd.Make(S.A) let run dirty start_time filename chan env splitted = try let parsed = P.parse chan splitted in let name = splitted.Splitter.name in let hash = MiscParser.get_hash parsed in let env = match hash with | None -> env | Some hash -> TestHash.check_env env name.Name.name filename hash in let test = T.build name parsed in (* Compute basic machine size *) let sz = if S.A.is_mixed then begin match C.byte with | MachSize.Tag.Size sz -> sz | MachSize.Tag.Auto -> let szs = test.Test_herd.access_size in match szs with | [] -> MachSize.Byte | [sz] -> MachSize.pred sz | sz::_ -> sz (* Do not split the smallest size involved *) end else begin (* Cannot that easily check the test not to mix sizes, as there are several locations in test that may be of different sizes *) MachSize.Byte end in (* And run test *) let module T = Top_herd.Make (struct include C let byte = sz let dirty = dirty end)(M) in T.run start_time test ; env with TestHash.Seen -> env end herd-herdtools7-1ca343e/herd/runTest.mli000066400000000000000000000044121475314470400202340ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Run a test from source file, arch being abstracted *) module type Config = sig val model : Model.t option val archcheck : bool val through : Model.through val strictskip : bool val cycles : StringSet.t val bell_model_info : (string * BellModel.info) option val macros : string option val check_name : string -> bool val check_rename : string -> string option val libfind : string -> string include GenParser.Config include Top_herd.CommonConfig include Sem.Config val statelessrc11 : bool val dumpallfaults : bool val byte : MachSize.Tag.t val sve_vector_length : int val sme_vector_length : int end type runfun = DirtyBit.t option -> float (* start time *) -> string (* file name *) -> in_channel (* source channel *) -> TestHash.env -> Splitter.result -> TestHash.env module Make : functor(S:Sem.Semantics) -> functor (P:sig type pseudo val parse : in_channel -> Splitter.result -> pseudo MiscParser.t end with type pseudo = S.A.pseudo) -> functor (M:XXXMem.S with module S = S) -> functor (C:Config) -> sig val run : runfun end herd-herdtools7-1ca343e/herd/sem.mli000066400000000000000000000033411475314470400173540ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Semantics of instructions *) module type Config = SemExtra.Config module type Semantics = sig include SemExtra.S (* Barrier pretty print (for minimal model) *) val barriers : pp_barrier list val isync : pp_barrier option (* Extra condition on RMW *) val atomic_pair_allowed : event -> event -> bool (* Instruction semantics, highly arch dependant *) module Mixed(SZ:ByteSize.S) : sig val build_semantics : test -> A.inst_instance_id -> (A.program_order_index * branch) M.t val spurious_setaf : A.V.v -> unit M.t end end herd-herdtools7-1ca343e/herd/semExtra.ml000066400000000000000000000366111475314470400202150ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Centralized definition for types to be included by the XXXSem *) (* Some configuration *) module type Config = sig val verbose : int val optace : OptAce.t val debug : Debug_herd.t val fault_handling : Fault.Handling.t val mte_precision : Precision.t val variant : Variant.t -> bool val endian : Endian.t option val unroll : int option module PC : PrettyConf.S end module type S = sig module O : Config (* Options, for Sem consumer *) module A : Arch_herd.S module E : Event.S with module A = A and module Act.A = A module M : Monad.S with module A = A and module E = E and type evt_struct = E.event_structure module Cons : Constraints.S with module A = A (* Report some flags *) val do_deps : bool (* A good place to (re)define all these types *) type cst = A.V.Cst.v type v = A.V.v type proc = A.proc type instruction = A.instruction type global_loc = A.global_loc type location = A.location type state = A.state type final_state = A.final_state type program = A.program type prop = A.prop type constr = A.constr type nice_prog = A.nice_prog type start_points = A.start_points type code_segment = A.code_segment type entry_points = A.entry_points type proc_info = Test_herd.proc_info type test = (program, nice_prog, start_points, code_segment, entry_points, state, A.size_env, A.type_env, prop, location, A.RLocSet.t, A.FaultAtomSet.t) Test_herd.t val size_env : test -> A.size_env val type_env : test -> A.type_env (* Get sets of locations observed in outcomes *) type loc_set = A.LocSet.t type rloc_set = A.RLocSet.t val observed_rlocations : test -> rloc_set (* Notice, array rlocations are expanded to the locations of their elements *) val observed_locations : test -> loc_set val displayed_rlocations : test -> rloc_set val is_non_mixed_symbol : test -> Constant.symbol -> bool (* "Exported" labels, i.e. labels that can find their way to registers *) (* In initial state *) val get_exported_labels_init : test -> Label.Full.Set.t (* In code *) val get_exported_labels_code : test -> Label.Full.Set.t (* Both of them *) val get_exported_labels : test -> Label.Full.Set.t type event = E.event type event_structure = E.event_structure type event_set = E.EventSet.t type event_rel = E.EventRel.t (* Abreviations *) val tr : event_rel -> event_rel val rt : event_rel -> event_rel val restrict : (event -> bool) -> (event -> bool) -> event_rel -> event_rel val doWW : event_rel -> event_rel val doWR : event_rel -> event_rel val doRR : event_rel -> event_rel val doRW : event_rel -> event_rel val seq : event_rel -> event_rel -> event_rel val seqs : event_rel list -> event_rel val union : event_rel -> event_rel -> event_rel val union3 : event_rel -> event_rel -> event_rel -> event_rel val unions : event_rel list -> event_rel (* relations packed to be shown on graphs *) type rel_pp = (string * event_rel) list type set_pp = event_set StringMap.t (* Dependencies : ie complement for ace *) type procrels = { addr : event_rel; data : event_rel; depend : event_rel; data_commit : event_rel; ctrl : event_rel; ctrlisync : event_rel; success : event_rel; rf : event_rel; tst: event_rel; } (*********) (* RFMap *) (*********) type write_to = | Final of location | Load of event type read_from = | Init | Store of event val write_to_compare : write_to -> write_to -> int val read_from_compare : read_from -> read_from -> int val read_from_equal : read_from -> read_from -> bool val event_rf_equal : event -> read_from -> bool module RFMap : Map.S with type key = write_to type rfmap = read_from RFMap.t (* For pretty print, string arg is like the one of String.concat *) val pp_rfmap : out_channel -> string -> (out_channel -> write_to -> read_from -> unit) -> rfmap -> unit val for_all_in_rfmap : (write_to -> read_from -> bool) -> rfmap -> bool val simplify_vars_in_rfmap : A.V.solution -> rfmap -> rfmap (**************************************) (* Complete, concrete event structure *) (**************************************) type concrete = { str : event_structure ; (* event structure proper *) rfmap : rfmap ; (* rfmap *) fs : state * A.FaultSet.t ; (* final state *) po : event_rel ; (* program order (in fact po + iico) *) partial_po : event_rel ; pos : event_rel ; (* Same location same processor accesses *) (* Write serialization precursor ie uniproc induced constraints over writes *) pco : event_rel ; (* View before relation deduced from rfmaps *) store_load_vbf : event_rel ; (* stores preceed their loads *) init_load_vbf : event_rel; (* load from init preceed all stores *) last_store_vbf : event_rel; (* stores to final state come last *) atomic_load_store : event_rel; (* eg load-and-link/store conditional *) } val conc_zero : concrete (************) (* Branches *) (************) module B : Branch.S with type reg = A.reg and type v = v and type 'a monad = 'a M.t type branch = B.t val tgt2tgt : A.inst_instance_id -> BranchTarget.t -> B.tgt val tgt2offset : A.inst_instance_id -> BranchTarget.t -> int val find_cutoff : E.EventSet.t -> string option (************) (* Barriers *) (************) (* barrier + cumulativity *) type barrier = A.barrier type pp_barrier = { barrier:barrier ; pp:string; } end module Make(C:Config) (A:Arch_herd.S) (Act:Action.S with module A = A) : (S with module A = A and module E.Act = Act) = struct module O = C module A = A module V = A.V module E = Event.Make(C)(A)(Act) module CEM = struct (* Configure event monads *) let hexa = C.PC.hexa let debug = C.debug let variant = C.variant end module M = EventsMonad.Make(CEM)(A)(E) module Cons = Constraints.Make (C.PC)(A) let do_deps = C.variant Variant.Deps (* A good place to (re)define all these types *) type cst = A.V.Cst.v type v = A.V.v type proc = A.proc type instruction = A.instruction type global_loc = A.global_loc type location = A.location type state = A.state type final_state = A.final_state type prop = A.prop type constr = A.constr type program = A.program type nice_prog = A.nice_prog type start_points = A.start_points type code_segment = A.code_segment type entry_points = A.entry_points type proc_info = Test_herd.proc_info type test = (program, nice_prog, start_points, code_segment, entry_points, state, A.size_env, A.type_env, prop, location, A.RLocSet.t, A.FaultAtomSet.t) Test_herd.t let size_env t = t.Test_herd.size_env and type_env t = t.Test_herd.type_env (* Sets of relevant location *) type loc_set = A.LocSet.t type rloc_set = A.RLocSet.t let loc_of_rloc test rloc k = let locs = A.locs_of_rloc (type_env test) rloc in A.LocSet.union (A.LocSet.of_list locs) k let locs_of_rlocs test rlocs = A.RLocSet.fold (fun rloc k -> loc_of_rloc test rloc k) rlocs A.LocSet.empty let observed_rlocations t = t.Test_herd.observed let observed_locations t = locs_of_rlocs t (observed_rlocations t) let displayed_rlocations t = t.Test_herd.displayed let is_non_mixed_offset test s o = match o with | 0 -> true | _ -> o > 0 && begin let sym0 = Constant.mk_sym_virtual s in let loc0 = A.Location_global (A.V.Val sym0) in let t = A.look_type (type_env test) loc0 in let open TestType in match t with | TyArray (t,sz) -> let sz_elt = MachSize.nbytes (A.size_of_t t) in o mod sz_elt = 0 && o < sz*sz_elt | _ -> false end let is_non_mixed_symbol_virtual test sym = let open Constant in match sym.offset with | 0 -> true | o -> is_non_mixed_offset test sym.name o let is_non_mixed_symbol test sym = let open Constant in match sym with | Virtual sd -> is_non_mixed_symbol_virtual test sd | Physical (s,o) -> is_non_mixed_offset test s o | TagAddr _ | System ((PTE|PTE2|TLB),_) -> true (* Exported labels: * 1. Labels from init environments * 2. Labels from instructions that transfer labels into regs. *) let get_exported_labels_init test = let { Test_herd.init_state=st; _ } = test in A.state_fold (fun _ v k -> match v with | V.Val cst -> begin match Constant.as_label cst with | Some lbl -> Label.Full.Set.add lbl k | None -> k end | V.Var _ -> k) st Label.Full.Set.empty module AU = ArchUtils.Make(A)(V.Cst.Instr) let get_exported_labels_code test = let { Test_herd.nice_prog=prog; _ } = test in AU.get_exported_labels_code prog let get_exported_labels test = Label.Full.Set.union (get_exported_labels_init test) (get_exported_labels_code test) (**********) (* Events *) (**********) type event = E.event let event_compare = E.event_compare type event_set = E.EventSet.t type event_structure = E.event_structure type event_rel = E.EventRel.t (* Abreviations *) let tr = E.EventRel.transitive_closure let rt = E.EventRel.remove_transitive_edges let restrict = E.EventRel.restrict_domains let doRR = restrict E.is_mem_load E.is_mem_load let doRW = restrict E.is_mem_load E.is_mem_store let doWW = restrict E.is_mem_store E.is_mem_store let doWR = restrict E.is_mem_store E.is_mem_load let seq = E.EventRel.sequence let seqs = E.EventRel.sequences let union = E.EventRel.union let union3 = E.EventRel.union3 let unions = E.EventRel.unions (* relations packed to be shown on graphs *) type rel_pp = (string * event_rel) list type set_pp = event_set StringMap.t (* Dependencies : ie complement for ace *) type procrels = { addr : event_rel; data : event_rel; depend : event_rel; data_commit : event_rel; ctrl : event_rel; ctrlisync : event_rel; success : event_rel; rf : event_rel; tst : event_rel; } (* Read-From maps exploitation *) type write_to = | Final of location | Load of event type read_from = | Init | Store of event let write_to_compare wt1 wt2 = match wt1,wt2 with | Final loc1, Final loc2 -> A.location_compare loc1 loc2 | Final _, Load _ -> -1 | Load _,Final _ -> 1 | Load e1, Load e2 -> event_compare e1 e2 let read_from_compare rf1 rf2 = match rf1,rf2 with | Init, Init -> 0 | Init, Store _ -> -1 | Store _,Init -> 1 | Store e1, Store e2 -> event_compare e1 e2 let read_from_equal rf1 rf2 = read_from_compare rf1 rf2 = 0 let event_rf_equal e rf = match rf with | Init -> false | Store e' -> E.event_equal e e' module RFMap = Map.Make (struct type t = write_to let compare = write_to_compare end) type rfmap = read_from RFMap.t let pp_rfmap chan delim pp rfm = let first = ref true in RFMap.iter (fun wt rf -> if not !first then output_string chan delim else first := false ; pp chan wt rf) rfm let for_all_in_rfmap pred rfm = RFMap.fold (fun wt rf k -> pred wt rf && k) rfm true let simplify_rf solns = function | Init -> Init | Store e -> Store (E.simplify_vars_in_event solns e) and simplify_wt solns = function | Final loc -> Final (A.simplify_vars_in_loc solns loc) | Load e -> Load (E.simplify_vars_in_event solns e) let simplify_vars_in_rfmap solns rfm = if V.Solution.is_empty solns then rfm else RFMap.fold (fun wt rf k -> RFMap.add (simplify_wt solns wt) (simplify_rf solns rf) k) rfm RFMap.empty (**************************************) (* Complete, concrete event structure *) (**************************************) type concrete = { str : event_structure ; (* event structure proper *) rfmap : rfmap ; (* rfmap *) fs : state * A.FaultSet.t ; (* final state *) po : event_rel ; partial_po : event_rel ; pos : event_rel ; (* Same location same processor accesses *) pco : event_rel ; (* View before relation deduced from rfmaps *) store_load_vbf : event_rel ; (* stores preceed their loads *) init_load_vbf : event_rel; (* load from init preceed all stores *) last_store_vbf : event_rel; (* stores to final state come last *) atomic_load_store : event_rel; (* eg load-and-link/store conditional *) } let conc_zero = { str = E.empty_event_structure ; rfmap = RFMap.empty ; fs = A.state_empty,A.FaultSet.empty; partial_po = E.EventRel.empty; po = E.EventRel.empty ; pos = E.EventRel.empty ; pco = E.EventRel.empty ; store_load_vbf = E.EventRel.empty ; init_load_vbf = E.EventRel.empty ; last_store_vbf = E.EventRel.empty ; atomic_load_store = E.EventRel.empty ; } (************) (* Branches *) (************) module B = Branch.Make(M) type branch = B.t let tgt2tgt ii = function | BranchTarget.Lbl lbl -> B.Lbl lbl | BranchTarget.Offset o -> B.Addr (ii.A.addr + o) let tgt2offset ii = function | BranchTarget.Offset o -> o | BranchTarget.Lbl lbl -> let b = try Label.Map.find lbl ii.A.lbl2addr with Not_found -> assert false in b-ii.A.addr let find_cutoff es = Option.bind (E.EventSet.find_opt E.is_cutoff es) E.as_cutoff (************) (* Barriers *) (************) type barrier = A.barrier type pp_barrier = { barrier:barrier ; pp:string; } end module ConfigToArchConfig(C:Config) : ArchExtra_herd.Config = struct let verbose = C.verbose let texmacros = C.PC.texmacros let hexa = C.PC.hexa let brackets = C.PC.brackets let variant = C.variant let endian = C.endian let default_to_symb = false end herd-herdtools7-1ca343e/herd/show.ml000066400000000000000000000061561475314470400174060ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (************************************************************) (* Show feature, for debug, pops up a window to show graphs *) (************************************************************) open Printf module Generator(O:PrettyConf.S) = struct let generator = match O.dotcom with | None -> begin match O.graph with | Graph.Columns -> "neato" | Graph.Free|Graph.Cluster -> "dot" end | Some com -> PrettyConf.pp_dotcom com end module Make(O:PrettyConf.S) = struct module W = Warn.Make(O) let my_remove name = if not O.debug then try Sys.remove name with e -> W.warn "remove failed: %s" (Printexc.to_string e) let extfile name_dot ext = let base = try Filename.chop_extension name_dot with Invalid_argument _ -> name_dot in base ^ "." ^ ext module G = Generator(O) let generator = G.generator let do_show_file name_dot prog ext = let name_ps = extfile name_dot ext in Handler.push (fun () -> my_remove name_ps) ; let cmd = sprintf "%s -T%s %s > %s 2>/dev/null ; %s %s 2>/dev/null%s" generator ext name_dot name_ps prog name_ps (if O.debug then "" else sprintf " && /bin/rm -f %s" name_ps) in let r = Sys.command cmd in if O.debug then eprintf "Command: [%s] -> %i\n" cmd r ; Handler.pop () let show_file_with_view view name_dot = let open View in match view with | GV -> do_show_file name_dot "gv" "ps" | Evince -> do_show_file name_dot "evince" "pdf" | Preview -> do_show_file name_dot "open -a Preview" "pdf" let show_file name_dot = match O.view with | None -> () | Some v -> show_file_with_view v name_dot let show ouput_dot = match O.view with | None -> () | Some view -> let name_dot = Filename.temp_file "herd" ".dot" in Handler.push (fun () -> my_remove name_dot) ; Misc.output_protect ouput_dot name_dot ; show_file_with_view view name_dot ; my_remove name_dot ; Handler.pop () end herd-herdtools7-1ca343e/herd/show.mli000066400000000000000000000030431475314470400175470ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Show dot files as Postscript, controlled by '-view viewer' option *) module Generator : functor (O:PrettyConf.S) -> sig val generator : string end module Make : functor (O:PrettyConf.S) -> sig (* Fork a gv window to show that file *) val show_file : string -> unit (* Idem, but show the graph produced by the argument function *) val show : (out_channel -> unit) -> unit end herd-herdtools7-1ca343e/herd/slrc11.ml000066400000000000000000001155231475314470400175320ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2018-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (****************************************************************************) (* Authors: *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* Simon Colin, INRIA Paris, France. *) (****************************************************************************) open Printf module type Cfg = sig val skipchecks : StringSet.t include Mem.S end module Make (M:Cfg) = struct module S = M.S module E = S.E module A = S.A module U = MemUtils.Make(S) module Sol = E.Act.A.V.Solution type exec = { po : E.EventRel.t; iico : E.EventRel.t; mo : E.EventRel.t; rf : E.EventRel.t; toadd : (int * E.EventSet.t) list; added : E.EventSet.t; revisit : E.EventSet.t; safe : E.EventSet.t; rmws : E.EventRel.t; exvals : E.event -> bool; rfm : M.S.rfmap; flags : Flag.Set.t; psc : E.EventRel.t; debug_rels : (string * E.EventRel.t) list; } (* debug *) let debug = false let debug_proc chan p = fprintf chan "%i" p let debug_event chan e = fprintf chan "%s:%s " (E.pp_eiid e) (S.E.Act.pp_action e.E.action) let debug_event_set chan e = let _ = print_string "[" in let _ = E.EventSet.iter (fun x -> debug_event chan x) e in print_string "]\n" let debug_cnstrnts chan e = fprintf chan "\n[ %s ]" (S.M.VC.pp_cnstrnts e) let debug_set chan r = E.EventRel.pp chan "," (fun chan (e1, e2) -> fprintf chan "%a -> %a" debug_event e1 debug_event e2) r let debug_rel chan r = E.EventRel.pp chan "," (fun chan (e1, e2) -> fprintf chan "%a -> %a" debug_event e1 debug_event e2) r let debug_procs chan procs = List.iter (fun (x, y) -> let _ = printf "proc %d \t:" x in debug_event_set chan y) procs let debug_rf chan wt rf = let _ = match wt with | M.S.Final loc -> fprintf chan "Final %s ->" (A.pp_location loc) | M.S.Load ev -> debug_event chan ev in match rf with | M.S.Init -> fprintf chan "init\n" | M.S.Store ev ->let _ = debug_event chan ev in print_string "\n" let debug_exec chan ex = let _ = fprintf chan "execution\n\npo : " in let _ = debug_rel chan (E.EventRel.remove_transitive_edges (E.EventRel.restrict_domains E.is_mem E.is_mem ex.po)) in let _ = fprintf chan "\n\nmo : " in let _ = debug_rel chan (E.EventRel.remove_transitive_edges ex.mo) in let _ = fprintf chan "\n\nrf : " in let _ = debug_rel chan ex.rf in let _ = fprintf chan "\n\nadded : " in let _ = debug_event_set chan ex.added in let _ = fprintf chan "\ntoadd : " in let _ = debug_procs chan ex.toadd in let _ = fprintf chan "\nrevisit : " in let _ = debug_event_set chan ex.revisit in let _ = printf "rmws = %a\n" debug_rel ex.rmws in fprintf chan "\n--------------------\n\n" (* relations and events *) let aux = fun x -> try List.assoc x S.E.Act.arch_sets with Not_found -> Warn.fatal "annotation %s not found" x let rmw = aux "RMW" let rlx = aux "RLX" let acq = aux "ACQ" let rel = aux "REL" let acq_rel = aux "ACQ_REL" let sc = aux "SC" let na = aux "NA" let fence = E.is_barrier let atomic = aux "A" (* a; b? *) let seq_union a b = E.EventRel.union a (E.EventRel.sequence a b) let added a r = E.EventRel.restrict_domains (fun x -> E.EventSet.mem x a) (fun x -> E.EventSet.mem x a) r (* sbr = (sb | rf)+ *) let sbrf ex = added ex.added (E.EventRel.transitive_closure (E.EventRel.union (added ex.added ex.po) ex.rf)) (* rseq = [W]; (sb & loc)?; [W & (RLX | REL | ACQ_REL | ACQ | SC)]; (rf; rmw)* *) let rseq ex = let rs0 = E.EventRel.restrict_rel E.same_location ex.po in let rs1 = E.EventRel.set_to_rln (E.EventSet.filter E.is_mem_store ex.added) in let rs2 = E.EventRel.sequence rs1 rs0 in let rs3 = E.EventRel.set_to_rln (E.EventSet.filter (fun x -> E.is_mem_store x && (rlx x.E.action || rel x.E.action || acq x.E.action || acq_rel x.E.action || sc x.E.action)) ex.added) in let rs4 = E.EventRel.sequence rs2 rs3 in let rs5 = E.EventRel.inter rs1 rs3 in let rs6 = E.EventRel.union rs4 rs5 in let rs7 = E.EventRel.transitive_closure (E.EventRel.sequence ex.rf (added ex.added ex.rmws)) in E.EventRel.union rs6 (E.EventRel.sequence rs6 rs7) (* sw = [(REL | ACQ_REL | SC)]; ([F]; sb)?; rs; rf; [R & (RLX | REL | ACQ | ACQ_REL | SC)]; (sb; [F])?; [(ACQ | ACQ_REL | SC)] *) let sw ex = let mpo = ex.po in let rseq = rseq ex in let fences = E.EventSet.filter fence ex.added in let sw0 = E.EventRel.sequence rseq ex.rf in let sw1 = E.EventRel.set_to_rln (E.EventSet.filter (fun x -> rel x.E.action || acq_rel x.E.action || sc x.E.action) ex.added) in let sw2 = E.EventRel.sequence (E.EventRel.set_to_rln fences) mpo in let sw3 = E.EventRel.union sw1 (E.EventRel.sequence sw1 sw2) in let sw4 = E.EventRel.sequence sw3 sw0 in let sw5 = E.EventRel.set_to_rln (E.EventSet.filter (fun x -> (rlx x.E.action || rel x.E.action || acq x.E.action || acq_rel x.E.action || sc x.E.action) && E.is_mem_load x) ex.added) in let sw6 = E.EventRel.sequence sw4 sw5 in let sw7 = E.EventRel.sequence mpo (E.EventRel.set_to_rln fences) in let sw8 = E.EventRel.set_to_rln (E.EventSet.filter (fun x -> acq x.E.action || acq_rel x.E.action || sc x.E.action) ex.added) in let sw9 = E.EventRel.union sw8 (E.EventRel.sequence sw7 sw8) in let sw = E.EventRel.sequence sw6 sw9 in sw (* hb = (sb | sw)+ *) let hb ex = let sw0 = sw ex in let hb0 = E.EventRel.union ex.po sw0 in E.EventRel.transitive_closure hb0 (* is part of a rmw operation *) let is_exclusive rmws e = E.EventRel.exists (fun (x, y) -> x = e || y = e) rmws (* preproc *) let solve test es cs = match M.solve_regs test es cs with | None -> (es, M.S.RFMap.empty, cs) | Some (es, rfm, cs) -> (es, rfm, cs) (* postproc *) let clean_exec e = let nrf = E.EventRel.remove_transitive_edges (E.EventRel.restrict_domains E.is_mem E.is_mem e.rf) in let nmo = E.EventRel.remove_transitive_edges (E.EventRel.restrict_domains E.is_mem E.is_mem e.mo) in let npo = E.EventRel.remove_transitive_edges (E.EventRel.restrict_domains E.is_mem E.is_mem e.po) in {e with rf = nrf; po = npo; mo = nmo} (* assigning variables *) let is_final_write w ex = E.is_mem_store w && not (E.EventRel.exists (fun (x, _) -> x = w) ex.mo) let make_cnstrnts ex = E.EventRel.fold (fun rel cns -> match (E.written_of (fst rel), E.read_of (snd rel)) with | Some w, Some v -> M.S.M.VC.Assign (v, M.S.M.VC.Atom w) :: cns | _ -> cns) ex.rf [] (* stateless algorithm aux functions *) (* next event : pending write if there is one or next event according to thread number ascending order and po *) let nextp exec po revisit pending = let rec aux e p = begin match e with | [] -> None | (_, e) :: tl -> try match E.EventRel.roots (E.EventRel.restrict_rel (fun x y -> E.EventSet.mem x e && E.EventSet.mem y e) p) with | x when E.EventSet.is_empty x && E.EventSet.is_empty e -> aux tl p | x when E.EventSet.is_empty x -> Some (E.EventSet.choose e) | x -> Some (E.EventSet.choose x) with Not_found -> None end in try match E.EventSet.cardinal pending with | 2 -> (Some (E.EventSet.find (fun x -> not (E.EventSet.mem x revisit)) pending)) | 1 -> (Some (E.EventSet.choose pending)) | 0 -> aux exec po | _ -> assert false with Not_found -> None let extract_event exec po revisit pending = match nextp exec po revisit pending with | None -> (None, exec) | Some e -> (Some e, List.map (fun (x, y) -> (x, E.EventSet.remove e y)) exec) (* pending write : not yet added write of a rmw whose read has been added *) let pending ex = let cpo = E.EventRel.restrict_codomain (fun x -> E.EventSet.mem x ex.added) ex.po in let crmw = E.EventRel.restrict_domain (fun x -> E.EventSet.mem x ex.added) ex.rmws in E.EventRel.codomain (E.EventRel.restrict_domains (fun x -> not (E.EventRel.exists (fun (y,_) -> E.event_compare y x = 0) cpo)) (fun x -> not (E.EventSet.mem x ex.added)) crmw) let check_revisit ex = let t0 = (E.EventRel.codomain (added ex.added (E.EventRel.sequences [E.EventRel.set_to_rln ex.revisit; sbrf ex; E.EventRel.set_to_rln (E.EventSet.filter (fun x -> E.is_mem_load x && not (E.is_mem_store x)) ex.added)]))) in if not (E.EventSet.subset t0 ex.revisit) then let _ = if debug then printf "4.1.1\n" else () in false else true let check_exec ex = let c1 = E.EventRel.filter (fun (x, y) -> not (E.EventSet.mem x ex.added) || not (E.EventSet.mem y ex.added)) (E.EventRel.union ex.rf ex.mo) in if not (E.EventRel.is_empty c1) then let _ = if debug then printf "%a\n%a\n" debug_exec ex debug_rel c1 else () in false else if E.EventSet.exists (fun x -> E.EventRel.cardinal (E.EventRel.restrict_codomain (fun y -> y = x) ex.rf) != 1) (E.EventSet.filter E.is_mem_load ex.added) then let _ = if debug then printf "2 : %a\n%a\n" debug_rel ex.rf debug_event_set (E.EventSet.filter (fun x -> E.is_mem_load x && not (E.is_mem_store x)) ex.added) else () in false else let grp = E.EventSet.filter (is_exclusive ex.rmws) (pending ex) in let t1 = E.EventRel.sequences [E.EventRel.set_to_rln grp; E.EventRel.inverse ex.rf; ex.rf; E.EventRel.set_to_rln (E.EventSet.diff (E.EventSet.filter (is_exclusive ex.rmws) ex.added) grp)] in if not (E.EventRel.is_empty (E.EventRel.restrict_rel (fun x y -> not (E.EventSet.mem y ex.revisit) || E.EventSet.mem x ex.revisit) t1)) then false else true let check_cns ex cs = let ncs = (List.append cs (make_cnstrnts {ex with rf = added ex.safe ex.rf})) in match M.S.M.VC.solve ncs with | M.S.M.VC.NoSolns -> false | _ -> true (* return events in g to their respective threads in toadd *) let return_events toadd g = let insert_event toadd e = List.map (fun (x, y) -> match E.proc_of e with | Some p when x = p -> (x, E.EventSet.add e y) | _ -> (x, y)) toadd in E.EventSet.fold (fun x y -> insert_event y x) g toadd (* modify ex.rf such that all the reads in r read from w *) let set_rf ex w r = let nr = E.EventSet.inter ex.added r in let nrf0 = E.EventRel.restrict_codomain (fun x -> not (E.EventSet.mem x nr)) ex.rf in let nrf = E.EventRel.union (E.EventRel.cartesian (E.EventSet.of_list [w]) nr) nrf0 in let out = {ex with rf = nrf} in out (* returns the event a such that (e,a) in mo but there exists no b such that (e,b) and (e,a) in mo *) let succ mo e = let s0 = E.EventRel.restrict_domain (fun x -> x = e) mo in let s1 = E.EventRel.restrict_domains (fun x -> E.EventSet.mem x (E.EventRel.codomain s0)) (fun x -> E.EventSet.mem x (E.EventRel.codomain s0)) mo in let out = E.EventRel.roots s1 in match E.EventSet.cardinal out with | 0 | 1 -> out | _ -> assert false (* put wp after w in mo *) let insert_mo ex wp w = let m = E.EventRel.restrict_rel (fun x y -> x != w && y != w) ex.mo in let mo0 = E.EventRel.restrict_codomain (fun x -> x = wp) m in let mo1 = E.EventRel.domain mo0 in let mo2 = E.EventSet.add wp mo1 in let mo3 = E.EventRel.cartesian mo2 (E.EventSet.of_list [w]) in let mo4 = E.EventRel.restrict_domain (fun x -> x = wp) m in let mo5 = E.EventRel.codomain mo4 in let mo6 = E.EventRel.cartesian (E.EventSet.of_list [w]) mo5 in let mo7 = E.EventRel.union mo3 mo6 in let out = {ex with mo = E.EventRel.union ex.mo mo7} in out let extend_safe ex w = let sbr = sbrf ex in let r0 = E.EventRel.restrict_domains (fun x -> E.EventSet.mem x ex.revisit) (fun x -> x = w) sbr in if E.EventRel.is_empty r0 then (true, {ex with safe = E.EventSet.add w ex.safe}) else (false, ex) (* the algorithm itself *) let rec visit_write ex cs w kont res = let _ = assert (E.EventSet.is_empty (E.EventSet.diff ex.safe ex.added)) in (* let _ = printf "visiting write %a\n" debug_event w in*) (* if w is part of a rmw that reads from a write wp then w goes after wp in ex.mo *) let r0 = E.EventRel.sequence ex.rf (added ex.added ex.rmws) in let r1 = E.EventRel.restrict_codomain (E.event_equal w) r0 in if not (E.EventRel.is_empty r1) then (* let _ = printf "case 1\n" in*) let wp = E.EventSet.choose (E.EventRel.domain r1) in revisit_reads (insert_mo ex wp w) cs w kont res else (* let _ = printf "case 2\n" in*) (* w0 = ex.mo maximal write to the same location as w *) let m1 = E.EventRel.restrict_domain (E.same_location w) ex.mo in let w0 = try E.EventSet.choose (E.EventRel.leaves m1) with Not_found -> E.EventSet.choose (E.EventSet.filter (fun x -> E.is_mem_store_init x && E.same_location x w) ex.added) in (* let _ = printf "rvr\n" in*) let nex = insert_mo ex w0 w in let (b, nex0) = (extend_safe nex w) in let rvr = if b && not (check_cns nex0 cs) then (*let _ = printf "prune3\n" in*) res else (revisit_reads nex0 cs w kont res) in (* revisit every execution extension *) let hb0 = hb ex in let s0 = E.EventRel.union ex.mo (E.EventRel.sequence ex.mo ex.rf) in let s1 = E.EventRel.sequence s0 hb0 in let s3 = E.EventRel.sequence s1 (E.EventRel.singleton (w,w)) in let s4 = E.EventRel.sequence ex.rf (E.EventRel.set_to_rln (E.EventSet.inter (E.EventSet.filter (E.same_location w) ex.added) (E.EventRel.domain ex.rmws))) in let s5 = E.EventRel.union s3 s4 in let s6 = E.EventRel.domain s5 in let s7 = E.EventSet.filter (fun x -> E.is_mem_store x && E.same_location w x) ex.added in let s = E.EventSet.filter (fun x -> x != w0 && not (E.EventSet.mem x s6) && w != x) s7 in let sbr = sbrf ex in E.EventSet.fold (fun wp res1 -> (* let _ = printf "fold\n" in*) let sb0 = E.EventRel.set_to_rln (succ ex.mo wp) in let sb1 = E.EventRel.add (w, w) sb0 in let sb2 = E.EventRel.sequence sbr sb1 in let sb3 = E.EventRel.domain sb2 in let nrevisit = E.EventSet.filter (fun x -> not (E.EventSet.mem x sb3)) ex.revisit in let nex = insert_mo {ex with revisit = nrevisit} wp w in let (b, nex0) = (extend_safe nex w) in if b && not (check_cns nex0 cs) then (*let _ = printf "prune3\n" in*) res1 else (revisit_reads nex0 cs w kont res1)) s rvr and revisit_reads ex cs w kont res = let _ = assert (E.EventSet.is_empty (E.EventSet.diff ex.safe ex.added)) in (* let _ = printf "revisiting reads %a for %a\n" debug_event_set ex.revisit debug_event w in*) let mpo = added ex.added ex.po in let r0 = E.EventSet.filter (E.same_location w) ex.revisit in let sbr = sbrf ex in let hbf = hb ex in (* r2 = r0 \ domain(sbr;[w]) otherwise we would have [w];rf;sbr[w] cycles *) let r1 = E.EventRel.sequence sbr (E.EventRel.of_list [(w,w)]) in let r2 = E.EventSet.diff r0 (E.EventRel.domain r1) in (* r6 = r2 \ codomain ([w];mo;rf?;hb?;sb) otherwise we could have [w];mo;rf?;hb?;sb;rf;[w] cycles *) let r3 = E.EventRel.union ex.mo (E.EventRel.sequence ex.mo ex.rf) in let r4 = E.EventRel.union r3 (E.EventRel.sequence r3 hbf) in let r5 = E.EventRel.sequence r4 mpo in let r5b = E.EventRel.sequence (E.EventRel.singleton (w,w)) r5 in let r6 = E.EventSet.diff r2 (E.EventRel.codomain r5b) in (* if w is part of a rmw that reads from the same write as another rmw b, we must revisit the read of b or atomicity will not be maintained *) let km0 = E.EventRel.sequences [E.EventRel.inverse ex.rf; ex.rf; added ex.added ex.rmws] in let km1 = E.EventRel.restrict_domains (fun x -> E.is_mem_load x && is_exclusive ex.rmws x) (fun x -> x = w) km0 in let km2 = (E.EventRel.diff km1 (added ex.added ex.rmws)) in let kmust = E.EventSet.inter ex.added (E.EventRel.domain km2) in if (not (E.EventRel.is_empty (E.EventRel.sequences [(E.EventRel.set_to_rln kmust); sbr; (E.EventRel.set_to_rln (E.EventSet.singleton w))]))) then res else let r7 = E.EventRel.restrict_domain (fun x -> E.EventSet.mem x kmust) sbr in let r8 = E.EventSet.union kmust (E.EventRel.codomain r7) in let r = E.EventSet.diff r6 r8 in (* we compute any subset of r that does not reach itself within sbr and revisit it *) let kl0 = E.EventSet.fold (fun e l -> List.append l (List.map (fun x -> E.EventSet.add e x) l)) (E.EventSet.inter ex.added r) [E.EventSet.empty] in let kl = List.filter (fun x -> not (E.EventRel.exists (fun (y, z) -> E.EventSet.mem y x && E.EventSet.mem z x) sbr)) kl0 in List.fold_left (fun res1 k1 -> let k = if E.EventSet.is_empty kmust then k1 else let k00 = E.EventRel.set_to_rln k1 in let k01 = E.EventRel.sequence k00 sbr in let k02 = E.EventRel.codomain k01 in let k03 = E.EventSet.diff kmust k02 in E.EventSet.union k1 k03 in (* we remove sbrf successors of k and make the reads in k read from w *) let g0 = E.EventRel.set_to_rln k in let g1 = E.EventRel.sequence g0 sbr in let g = E.EventRel.codomain g1 in let ntoadd = return_events ex.toadd g in let nadded = E.EventSet.diff ex.added g in let nmo = added nadded ex.mo in let nrf = added nadded ex.rf in if not (E.EventSet.mem w nadded) then let _ = assert false in res1 else let nex = set_rf {ex with added = nadded; toadd = ntoadd; mo = nmo; rf = nrf; revisit = E.EventSet.inter nadded ex.revisit} w k in let nsbr = sbrf nex in let nrevisit0 = E.EventRel.set_to_rln k1 in let nrevisit1 = E.EventRel.union nrevisit0 (E.EventRel.sequence nsbr nrevisit0) in let nrevisit2 = E.EventRel.domain nrevisit1 in let nrevisit =E.EventSet.filter (fun x -> not (E.EventSet.mem x nrevisit2)) nex.revisit in let nex0 = {nex with revisit = nrevisit; debug_rels = List.append nex.debug_rels [("kmust", E.EventRel.set_to_rln kmust)]; safe = E.EventSet.union ex.safe nrevisit2} in if not (E.EventSet.is_empty nrevisit2) && not (check_cns nex0 cs) then (*let _ = printf "prune2\n" in*) res1 else visit nex0 cs kont res1) res kl and visit_read (ex : exec) cs r kont res = let _ = assert (E.EventSet.is_empty (E.EventSet.diff ex.safe ex.added)) in (* let _ = printf "visiting read %a\n" debug_event r in*) let w0 = E.EventSet.filter (fun x -> E.is_mem_store x && E.same_location r x) ex.added in let h = hb ex in (* we remove writes that are mo;rf?;hb before r to avoid [r];rf^-1;mo;hb;[r] = [r];eco;hb[r] cycles (coherence) *) let c0 = E.EventRel.sequences [ex.mo; ex.rf; h] in let c1 = E.EventRel.sequence ex.mo h in let c2 = E.EventRel.union c0 c1 in let c3 = E.EventRel.sequence c2 (E.EventRel.set_to_rln (E.EventSet.singleton r)) in let w1 = E.EventSet.filter (fun x -> not (E.EventSet.mem x (E.EventRel.domain c3))) w0 in let sbr = sbrf ex in let w2 = if is_exclusive ex.rmws r then let a1 = E.EventSet.filter (E.same_location r) ex.added in let a20 = E.EventRel.set_to_rln (E.EventSet.diff (E.EventRel.domain (added (E.EventSet.filter (E.same_location r) ex.added) ex.rmws)) ex.revisit) in let a21 = E.EventRel.set_to_rln (E.EventSet.inter ex.revisit (E.EventRel.domain (added (E.EventSet.filter (E.same_location r) ex.added) ex.rmws))) in let a22 = E.EventRel.sequences [a21; sbr; E.EventRel.set_to_rln (E.EventSet.singleton r)] in let a23 = E.EventRel.union a22 a20 in let a24 = E.EventRel.sequence ex.rf a23 in let a2 = E.EventRel.domain a24 in E.EventSet.inter ex.added (E.EventSet.filter (fun x -> not (E.EventSet.mem x a1 && E.EventSet.mem x a2)) w1) else w1 in let rec aux w0 = let r0 = E.EventRel.set_to_rln w0 in let r1 = E.EventRel.sequences [r0;sbr;added ex.added ex.rmws] in let r2 = E.EventRel.codomain (E.EventRel.restrict_codomain (E.same_location r) r1) in if E.EventSet.is_empty r2 then w0 else aux r2 in let w3 = E.EventRel.restrict_codomain (fun x -> x = r) sbr in let w4 = E.EventSet.inter w2 (E.EventRel.domain w3) in let _ = assert (not (E.EventSet.exists (fun x -> not (E.same_location x r)) w4)) in let w = aux w4 in let wx = try E.EventSet.choose w with Not_found -> E.EventSet.choose (aux w2) in let ex0 = (set_rf {ex with revisit = E.EventSet.add r ex.revisit} wx (E.EventSet.of_list [r])) in let res0 = if not (check_cns ex0 cs) then (*let _ = printf "prune0\n" in*) res else visit ex0 cs kont res in E.EventSet.fold (fun x res1 -> let nex = (set_rf ex x (E.EventSet.of_list [r])) in let nsbr = sbrf nex in let nr0 = E.EventRel.sequence nsbr (E.EventRel.of_list [(r,r);(x,x)]) in let nr1 = E.EventRel.domain nr0 in let nrevisit = E.EventSet.diff nex.revisit nr1 in let nex0 = {nex with revisit = nrevisit; safe = E.EventSet.union3 (E.EventSet.of_list [x;r]) nr1 ex.safe} in if not (check_cns nex0 cs) then res1 else visit nex0 cs kont res1) (E.EventSet.remove wx w2) res0 and visit (ex : exec) cs kont res = let _ = assert (E.EventSet.is_empty (E.EventSet.diff ex.safe ex.added)) in let pending = pending ex in let a0 = extract_event ex.toadd ex.po ex.revisit pending in match a0 with | (Some e, ntoadd) -> begin let nadded = E.EventSet.add e ex.added in let newex = {ex with toadd = ntoadd; added = nadded;} in try match e with | x when E.is_mem_store x -> visit_write newex cs e kont res | x when E.is_mem_load x -> visit_read newex cs e kont res | _ -> visit newex cs kont res with Not_found -> visit newex cs kont res end | None, _ -> let h = hb ex in let r0 = E.EventRel.cartesian ex.added ex.added in let r1 = E.EventRel.restrict_rel (fun x y -> E.same_location x y && (E.is_mem_store x || E.is_mem_store y) && not (E.is_mem_store_init x) && not (E.is_mem_store_init y)) r0 in let r2 = E.EventRel.restrict_rel (fun x y -> not (E.same_proc x y)) r1 in let r3 = E.EventRel.diff r2 (E.EventRel.union h (E.EventRel.inverse h)) in let realevents = E.EventSet.filter (fun x -> E.is_mem x || fence x) ex.added in let dr = E.EventRel.restrict_rel (fun x y -> not (atomic x.E.action && atomic y.E.action)) r3 in let sbl = E.EventRel.restrict_rel (fun x y -> not (E.same_location x y) && E.EventSet.mem x realevents && E.EventSet.mem y realevents) ex.po in let hbl = E.EventRel.restrict_rel (fun x y -> E.same_location x y && E.EventSet.mem x realevents && E.EventSet.mem y realevents) h in let scb0 = E.EventRel.sequences [sbl; h; sbl] in let scb1 = E.EventRel.sequence (E.EventRel.inverse ex.rf) ex.mo in let scb = E.EventRel.unions [ex.po; scb0; hbl; ex.mo; scb1] in let scfence = (fun x -> fence x && sc x.E.action) in let fences = E.EventSet.filter scfence ex.added in let fencesrel = E.EventRel.set_to_rln fences in let sce = E.EventSet.filter (fun x -> sc x.E.action) ex.added in let psc0 = E.EventRel.union fencesrel (E.EventRel.sequence fencesrel h) in let psc1 = E.EventRel.union psc0 (E.EventRel.set_to_rln sce) in let psc2 = E.EventRel.sequence psc1 scb in let psc3 = E.EventRel.sequence h fencesrel in let psc4 = E.EventRel.union3 psc3 fencesrel (E.EventRel.set_to_rln sce) in let psc5 = E.EventRel.sequence psc2 psc4 in let eco0 = E.EventRel.union3 ex.mo ex.rf (E.EventRel.sequence (E.EventRel.inverse ex.rf) ex.mo) in let eco = E.EventRel.transitive_closure eco0 in let psc10 = E.EventRel.union (E.EventRel.sequences [h; eco; h]) h in let psc11 = E.EventRel.restrict_domains scfence scfence psc10 in let psc = E.EventRel.union psc5 psc11 in if not (StringSet.mem "SC" M.skipchecks) && not (E.EventRel.is_acyclic psc) then res else (* let _ = printf "done\n" in*) let rs10 = E.EventRel.set_to_rln (E.EventSet.filter (fun x -> E.is_mem_store x && (rlx x.E.action || rel x.E.action || acq_rel x.E.action || acq x.E.action || sc x.E.action)) ex.added) in let cyc = match E.EventRel.get_cycle psc with | None -> E.EventRel.empty | Some x -> E.EventRel.singleton (List.hd x, List.hd x) in let nex = {ex with debug_rels = List.append ex.debug_rels [("psc", psc); ("eco",eco); ("scb", scb); ("pscb", psc5); ("pscf", psc11); ("rseq", rseq ex); ("rs10", rs10); ("cycle", cyc); ("sbl", sbl); ("hbl", hbl); ("sce", E.EventRel.set_to_rln sce); ("psc2", psc2); ("psc4", psc4); ("fencesrel", fencesrel); ("psc0", psc0); ("psc1", psc1); ("scb0", scb0); ("scb1", scb1) ]} in if E.EventRel.is_empty dr then let out = (clean_exec {nex with psc = psc}) in kont out res else let out = (clean_exec {nex with flags = Flag.Set.add Flag.Undef ex.flags}) in kont out res let finals ex = let out = E.EventSet.elements (E.EventSet.filter (fun x -> is_final_write x ex) ex.added) in out let replace_events ex es = let find ev = E.EventSet.find (fun x -> E.event_equal ev x) es in let nadded = E.EventSet.map (fun x -> find x) ex.added in let nrf = E.EventRel.map (fun (x, y) -> (find x, find y)) ex.rf in let nmo = E.EventRel.map (fun (x, y) -> (find x, find y)) ex.mo in let npo = E.EventRel.map (fun (x, y) -> (find x, find y)) ex.po in let ndebugrels = List.map (fun (str, rel) -> (str, E.EventRel.map (fun (x, y) -> (find x, find y)) rel)) ex.debug_rels in {ex with added = nadded; rf = nrf; mo = nmo; po = npo; debug_rels = ndebugrels} let mykont test model_kont es cs = (fun e res -> let ncs = (List.append cs (make_cnstrnts e)) in M.solve_mem test es e.rfm ncs (fun es0 rfm0 cs0 res0 -> match cs0 with | [] -> if S.A.reject_mixed then M.check_sizes test es0; if S.O.optace <> OptAce.True || M.check_rfmap es0 rfm0 then let ne = replace_events e es0.M.S.E.events in let pp_relns = lazy begin ("mo", ne.mo):: ("hb", E.EventRel.remove_transitive_edges (hb ne)):: ("rf", ne.rf):: ("po", ne.po):: ("revisit", E.EventSet.fold (fun ev rels -> E.EventRel.add (ev, ev) rels) ne.revisit E.EventRel.empty):: ("rmw", ne.rmws):: ("rs", rseq ne):: ("sw", sw ne):: ne.debug_rels end in let rfm = List.fold_left (fun k w -> M.S.RFMap.add (M.S.Final (M.get_loc w)) (M.S.Store w) k) rfm0 (finals ne) in let fsc = M.compute_final_state test rfm es.E.events in let conc = { S.str = es0; rfmap = rfm; fs = fsc; po = E.EventRel.empty; pos = E.EventRel.empty; pco = E.EventRel.empty; partial_po = E.EventRel.empty; store_load_vbf = E.EventRel.empty; init_load_vbf = E.EventRel.empty; last_store_vbf = E.EventRel.empty; atomic_load_store = E.EventRel.empty } in model_kont conc conc.S.fs (lazy StringMap.empty,pp_relns) e.flags res0 else begin res0 end | _ -> M.when_unsolved test es0 rfm0 cs0 (fun c -> c) res0) res) let real e = fence e || E.is_mem e let check_rfms test rfms _kfail _kont model_kont res = let (_, cs0, es0) = rfms in let (es, rfm, cs) = solve test es0 cs0 in let rmws = M.make_atomic_load_store es in let evts = E.EventSet.filter real es.E.events in let inits = E.EventSet.filter E.is_mem_store_init evts in let po = U.po_iico es in let iico = U.iico es in let procs = List.map (fun x -> let e = E.EventSet.filter (fun y -> match E.proc_of y with | Some p when p = x -> true | _ -> false) evts in x, e, E.EventRel.restrict_rel (fun x y -> E.EventSet.mem x e && E.EventSet.mem y e) po) es.E.procs in let toadd = List.map (fun (x, y, _) -> x, y) procs in let ex_init = { toadd = toadd; added = inits; po = (E.EventRel.union rmws po); iico = iico; mo = E.EventRel.empty; rf = E.EventRel.empty; revisit = E.EventSet.empty; safe = inits; exvals = (fun _ -> false); rmws = rmws; rfm = rfm; flags = Flag.Set.empty; psc = E.EventRel.empty; debug_rels = [] } in (visit ex_init cs (mykont test model_kont es cs) res) let check_event_structure test (rfms : (_ * S.M.VC.cnstrnts * S.event_structure) list) kfail kont model_kont (res : 'a) = List.fold_left (fun re rf -> check_rfms test rf kfail kont model_kont re) res rfms end herd-herdtools7-1ca343e/herd/speed.ml000066400000000000000000000026611475314470400175230ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) type t = False | True | Fast let tags = ["false";"true";"fast";] let parse tag = match Misc.lowercase tag with | "false" -> Some False | "true" -> Some True | "fast" -> Some Fast | _ -> None let pp = function | False -> "false" | True -> "true" | Fast -> "fast" herd-herdtools7-1ca343e/herd/speed.mli000066400000000000000000000024421475314470400176710ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** 'Speed' tags *) type t = False | True | Fast val tags : string list val parse : string -> t option val pp : t -> string herd-herdtools7-1ca343e/herd/splines.ml000066400000000000000000000032501475314470400200730ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) type t = Spline | Line | Polyline | Ortho | Curved | No let tags = ["spline"; "true"; "line"; "false"; "polyline"; "ortho"; "curved";"none"] let parse tag = match Misc.lowercase tag with | "spline"|"true" -> Some Spline | "line"|"false" -> Some Line | "polyline" -> Some Polyline | "ortho" -> Some Ortho | "curved" -> Some Curved | "none" -> Some No | _ -> None let pp = function | Spline -> "spline" | Line -> "line" | Polyline -> "polyline" | Ortho -> "ortho" | Curved -> "curved" | No -> "none" herd-herdtools7-1ca343e/herd/splines.mli000066400000000000000000000025121475314470400202440ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Edges in graphical output *) type t = Spline | Line | Polyline | Ortho | Curved | No val tags : string list val parse : string -> t option val pp : t -> string herd-herdtools7-1ca343e/herd/test_herd.ml000066400000000000000000000176741475314470400204160ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) type proc_info = (string * int list) list type ('prog,'nice_prog,'start,'ret,'entry,'state, 'size_env, 'type_env, 'prop,'loc,'locset,'fset) t = { arch : Archs.t ; name : Name.t ; info : MiscParser.info ; program : 'prog ; nice_prog : 'nice_prog ; start_points : 'start ; code_segment : 'ret ; entry_points : 'entry; init_state : 'state ; size_env : 'size_env ; type_env : 'type_env ; filter : 'prop option ; cond : 'prop ConstrGen.constr ; flocs : 'loc ConstrGen.rloc list ; ffaults: 'fset; observed : 'locset ; displayed : 'locset ; extra_data : MiscParser.extra_data ; access_size : MachSize.sz list ; proc_info : proc_info ; } (* Name and nothing else *) let simple_name test = test.name.Name.name (* human-readable test name/filename combination *) let readable_name test = test.name.Name.name (* and just the first part of that, for use in latex index *) let very_readable_name test = test.name.Name.name (* Name from filename *) let basename test = let base = Filename.basename test.name.Name.file in try Filename.chop_extension base with Invalid_argument _ -> base module Make(A:Arch_herd.S) = struct type result = (A.program, A.nice_prog, A.start_points, A.code_segment, A.entry_points, A.state, A.size_env, A.type_env, A.prop, A.location, A.RLocSet.t,A.FaultAtomSet.t) t (* Symb register allocation is external, since litmus needs it *) module ArchAlloc = struct include A (* Here values and global (addresses) are identical, NB: this is not the case for litmus! *) let maybevToV = V.maybevToV type global = A.V.v let maybevToGlobal = V.maybevToV module FaultType = A.I.FaultType end module Alloc = SymbReg.Make(ArchAlloc) (* Code loader is external, since litmus tests need it too *) module Load = Loader.Make(A) let collect_atom a r = let open ConstrGen in match a with | LV (loc,_v) -> A.RLocSet.add loc r | LL (l1,l2) -> A.RLocSet.add (Loc l1) (A.RLocSet.add (Loc l2) r) | FF _ -> r let collect_atom_fault a r = let open ConstrGen in match a with | (LV _|LL _) -> r | FF f -> f::r (*******************) (* Mem size access *) (*******************) (* From init *) let mem_access_size_init init = let szs = List.fold_left (fun k (loc,(t,_)) -> if A.is_global loc then A.mem_access_size_of_t t::k else k) [] init in MachSize.Set.of_list szs (* From code *) let mem_access_size_of_code sz code = List.fold_left (A.pseudo_fold (fun sz0 ins -> match A.mem_access_size ins with | Some sz -> MachSize.Set.add sz sz0 | None -> sz0)) sz code let mem_access_size_prog p = List.fold_left (fun sz (_,code) -> mem_access_size_of_code sz code) MachSize.Set.empty p let mem_access_size init prog = if A.is_mixed then (* Useful for mixed-size only *) let szs = MachSize.Set.union (mem_access_size_init init) (mem_access_size_prog prog) in MachSize.Set.elements szs else [] (***************) (* Entry point *) (***************) let build name t = let t = Alloc.allocate_regs t in let {MiscParser.init = init ; info = info ; prog = nice_prog ; filter = filter ; condition = final ; locations = locs ; extra_data = extra_data ; } = t in let prog,starts,rets = Load.load nice_prog in (* ensure labels in the init list are present in the body of the test*) List.iter (fun (_,(_,v)) -> match v with | A.V.Val (Constant.Label (p,s)) -> begin if not (Label.Map.mem s prog) then Warn.user_error "Label %s not found on P%d, yet it is used in the initialization list" s p end | _ -> ()) init ; let entry_points = let instr2labels = let one_label lbl addr res = let ins_lbls = IntMap.safe_find Label.Set.empty addr res in IntMap.add addr (Label.Set.add lbl ins_lbls) res in Label.Map.fold one_label prog IntMap.empty in fun addr -> IntMap.safe_find Label.Set.empty addr instr2labels in let init_state = A.build_state init in let type_env = A.build_type_env init in let flocs,ffaults = LocationsItem.locs_and_faults locs in let displayed = let flocs = A.RLocSet.of_list flocs in ConstrGen.fold_constr collect_atom final flocs in let observed = match filter with | None -> displayed | Some filter -> ConstrGen.fold_prop collect_atom filter displayed in let ffaults = A.FaultAtomSet.of_list (ConstrGen.fold_constr collect_atom_fault final ffaults) in let proc_info = let m = List.fold_left (fun m ((p,ao,_),_) -> match ao with | None -> m | Some ans -> List.fold_left (fun m an -> let old = StringMap.safe_find [] an m in StringMap.add an (p::old) m) m ans) StringMap.empty nice_prog in StringMap.bindings m in { arch = A.arch ; name = name ; info = info ; program = prog ; nice_prog = nice_prog ; start_points = starts ; code_segment = rets ; entry_points = entry_points; init_state = init_state ; filter = filter ; cond = final ; flocs = flocs ; ffaults; observed = observed ; displayed = displayed ; extra_data = extra_data ; size_env = A.build_size_env init ; type_env; access_size = mem_access_size init nice_prog ; proc_info; } let empty_test = let empty_name = { Name.name = ""; Name.file = ""; Name.texname = ""; Name.doc = ""; } in let fake_constr = ConstrGen.ExistsState (ConstrGen.And []) in { arch = A.arch ; name = empty_name ; info = [] ; program = Label.Map.empty ; nice_prog = [] ; start_points = [] ; code_segment = IntMap.empty ; entry_points = (fun _ -> Label.Set.empty) ; init_state = A.state_empty; size_env = A.size_env_empty ; type_env = A.type_env_empty ; filter = None ; cond = fake_constr ; flocs = [] ; ffaults = A.FaultAtomSet.empty; observed = A.RLocSet.empty; displayed = A.RLocSet.empty; extra_data = MiscParser.empty_extra; access_size = []; proc_info = []; } let find_our_constraint test = test.cond end herd-herdtools7-1ca343e/herd/test_herd.mli000066400000000000000000000055771475314470400205660ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Litmus tests *) type proc_info = (string * int list) list type ('prog,'nice_prog,'start,'ret,'entry,'state, 'size_env, 'type_env, 'prop,'loc,'locset,'fset) t = { arch : Archs.t ; name : Name.t ; info : MiscParser.info ; program : 'prog ; nice_prog : 'nice_prog ; start_points : 'start ; code_segment : 'ret ; entry_points : 'entry; init_state : 'state ; size_env : 'size_env ; type_env : 'type_env ; filter : 'prop option ; cond : 'prop ConstrGen.constr ; flocs : 'loc ConstrGen.rloc list ; ffaults : 'fset; observed : 'locset ; displayed : 'locset ; extra_data : MiscParser.extra_data ; access_size : MachSize.sz list ; proc_info : proc_info ; } val simple_name : ('prog,'nice_prog,'start,'ret,'entry,'state, 'size_env,'type_env, 'prop,'loc,'locset,'fset) t -> string val readable_name : ('prog,'nice_prog,'start,'ret,'entry,'state, 'size_env,'type_env, 'prop,'loc,'locset,'fset) t -> string val very_readable_name : ('prog,'nice_prog,'start,'ret,'entry,'state, 'size_env,'type_env, 'prop,'loc,'locset,'fset) t -> string val basename : ('prog,'nice_prog,'start,'ret,'entry,'state, 'size_env,'type_env, 'prop,'loc,'locset,'fset) t -> string module Make(A:Arch_herd.S) : sig type result = (A.program, A.nice_prog, A.start_points, A.code_segment, A.entry_points, A.state, A.size_env, A.type_env, A.prop, A.location, A.RLocSet.t, A.FaultAtomSet.t ) t val build : Name.t -> A.pseudo MiscParser.t -> result val find_our_constraint : result -> A.constr (* needed to interpret bell *) val empty_test : result end herd-herdtools7-1ca343e/herd/tests/000077500000000000000000000000001475314470400172265ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/000077500000000000000000000000001475314470400210655ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.MTE/000077500000000000000000000000001475314470400226415ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.MTE/LB+dmb.sy+amo.ldaddal-polp.litmus.expected000066400000000000000000000005511475314470400324720ustar00rootroot00000000000000Test LB+dmb.sy+amo.ldaddal-polp Allowed States 6 0:X1=0; 1:X1=0; [y]=1; 0:X1=0; 1:X1=1; [y]=1; 0:X1=0; 1:X1=1; [y]=3; 0:X1=1; 1:X1=0; [y]=1; 0:X1=1; 1:X1=1; [y]=1; 0:X1=1; 1:X1=1; [y]=3; Ok Witnesses Positive: 1 Negative: 5 Condition exists ([y]=3 /\ 0:X1=1 /\ 1:X1=1) Observation LB+dmb.sy+amo.ldaddal-polp Sometimes 1 5 Hash=17bc6369fabbd03dc92fee1a469c1247 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.MTE/LB+dmb.sy+amo.ldaddal-polt.litmus.expected000066400000000000000000000007711475314470400325020ustar00rootroot00000000000000Test LB+dmb.sy+amo.ldaddal-polt Allowed States 6 0:X1=0; 1:X1=0; [y]=1; ~Fault(P0,x); 0:X1=0; 1:X1=0; [y]=1; Fault(P0,x:red,TagCheck); 0:X1=0; 1:X1=1; [y]=1; ~Fault(P0,x); 0:X1=0; 1:X1=1; [y]=1; Fault(P0,x:red,TagCheck); 0:X1=0; 1:X1=1; [y]=3; ~Fault(P0,x); 0:X1=0; 1:X1=1; [y]=3; Fault(P0,x:red,TagCheck); Ok Witnesses Positive: 1 Negative: 5 Condition exists ([y]=3 /\ 0:X1=0 /\ 1:X1=1 /\ not (fault(P0,x))) Observation LB+dmb.sy+amo.ldaddal-polt Sometimes 1 5 Hash=d03abdfed2cd95ba87dc0d3549be20e0 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.MTE/LB+dmb.sypt+amo.ldaddal-polp.litmus.expected000066400000000000000000000006461475314470400330430ustar00rootroot00000000000000Test LB+dmb.sypt+amo.ldaddal-polp Allowed States 4 0:X1=0; 1:X1=0; [y]=1; ~Fault(P1,y); 0:X1=0; 1:X1=0; [y]=1; Fault(P1,y:red,TagCheck); 0:X1=1; 1:X1=0; [y]=1; ~Fault(P1,y); 0:X1=1; 1:X1=0; [y]=1; Fault(P1,y:red,TagCheck); Ok Witnesses Positive: 1 Negative: 3 Condition exists ([y]=1 /\ 0:X1=1 /\ 1:X1=0 /\ not (fault(P1,y))) Observation LB+dmb.sypt+amo.ldaddal-polp Sometimes 1 3 Hash=87309187ae3bab33ea58c7d5b4d190a0 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.MTE/LB+dmb.sypt+amo.ldaddal-polt.litmus.expected000066400000000000000000000010041475314470400330340ustar00rootroot00000000000000Test LB+dmb.sypt+amo.ldaddal-polt Allowed States 4 0:X1=0; 1:X1=0; [y]=1; ~Fault(P1,y); ~Fault(P0,x); 0:X1=0; 1:X1=0; [y]=1; Fault(P0,x:red,TagCheck); ~Fault(P1,y); 0:X1=0; 1:X1=0; [y]=1; Fault(P0,x:red,TagCheck); Fault(P1,y:red,TagCheck); 0:X1=0; 1:X1=0; [y]=1; Fault(P1,y:red,TagCheck); ~Fault(P0,x); Ok Witnesses Positive: 1 Negative: 3 Condition exists ([y]=1 /\ 0:X1=0 /\ 1:X1=0 /\ not (fault(P0,x) \/ fault(P1,y))) Observation LB+dmb.sypt+amo.ldaddal-polt Sometimes 1 3 Hash=1678822dfd5adb60be5a14fd6abde5a8 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.MTE/LB+dmb.sytp+amo.ldaddal-polp.litmus.expected000066400000000000000000000005001475314470400330300ustar00rootroot00000000000000Test LB+dmb.sytp+amo.ldaddal-polp Allowed States 3 0:X0=x:green; 1:X1=0; [y]=1; 0:X0=x:green; 1:X1=1; [y]=1; 0:X0=x:green; 1:X1=1; [y]=3; Ok Witnesses Positive: 1 Negative: 2 Condition exists ([y]=3 /\ 0:X0=x:green /\ 1:X1=1) Observation LB+dmb.sytp+amo.ldaddal-polp Sometimes 1 2 Hash=35764c17e93b51902564b58bca616e90 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.MTE/LB+dmb.sytp+amo.ldaddal-polt.litmus.expected000066400000000000000000000006171475314470400330450ustar00rootroot00000000000000Test LB+dmb.sytp+amo.ldaddal-polt Allowed States 6 0:X0=x:green; 1:X1=0; [y]=1; 0:X0=x:green; 1:X1=1; [y]=1; 0:X0=x:green; 1:X1=1; [y]=3; 0:X0=x:red; 1:X1=0; [y]=1; 0:X0=x:red; 1:X1=1; [y]=1; 0:X0=x:red; 1:X1=1; [y]=3; Ok Witnesses Positive: 1 Negative: 5 Condition exists ([y]=3 /\ 0:X0=x:red /\ 1:X1=1) Observation LB+dmb.sytp+amo.ldaddal-polt Sometimes 1 5 Hash=b0710f9e71f1e8eb2f708e5d5cd210e6 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.MTE/LB+dmb.sytt+amo.ldaddal-polp.litmus.expected000066400000000000000000000005411475314470400330410ustar00rootroot00000000000000Test LB+dmb.sytt+amo.ldaddal-polp Allowed States 2 0:X0=x:green; 1:X1=0; [y]=1; ~Fault(P1,y); 0:X0=x:green; 1:X1=0; [y]=1; Fault(P1,y:red,TagCheck); Ok Witnesses Positive: 1 Negative: 1 Condition exists ([y]=1 /\ 0:X0=x:green /\ 1:X1=0 /\ not (fault(P1,y))) Observation LB+dmb.sytt+amo.ldaddal-polp Sometimes 1 1 Hash=89b43b02ede8882f386b8d8f6114b280 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.MTE/LB+dmb.sytt+amo.ldaddal-polt.litmus.expected000066400000000000000000000006761475314470400330560ustar00rootroot00000000000000Test LB+dmb.sytt+amo.ldaddal-polt Allowed States 4 0:X0=x:green; 1:X1=0; [y]=1; ~Fault(P1,y); 0:X0=x:green; 1:X1=0; [y]=1; Fault(P1,y:red,TagCheck); 0:X0=x:red; 1:X1=0; [y]=1; ~Fault(P1,y); 0:X0=x:red; 1:X1=0; [y]=1; Fault(P1,y:red,TagCheck); Ok Witnesses Positive: 1 Negative: 3 Condition exists ([y]=1 /\ 0:X0=x:red /\ 1:X1=0 /\ not (fault(P1,y))) Observation LB+dmb.sytt+amo.ldaddal-polt Sometimes 1 3 Hash=16742ff0fc19815a0c23d536994a4002 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.MTE/MP+dmb.sy+amo.ldaddal-polp.litmus.expected000066400000000000000000000005511475314470400325110ustar00rootroot00000000000000Test MP+dmb.sy+amo.ldaddal-polp Allowed States 6 1:X1=0; 1:X4=0; [y]=1; 1:X1=0; 1:X4=1; [y]=1; 1:X1=1; 1:X4=0; [y]=1; 1:X1=1; 1:X4=0; [y]=3; 1:X1=1; 1:X4=1; [y]=1; 1:X1=1; 1:X4=1; [y]=3; Ok Witnesses Positive: 1 Negative: 5 Condition exists ([y]=3 /\ 1:X1=1 /\ 1:X4=0) Observation MP+dmb.sy+amo.ldaddal-polp Sometimes 1 5 Hash=5dc5c187bcebd8248b69c1da91f5a5e3 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.MTE/MP+dmb.sy+amo.ldaddal-polt.litmus.expected000066400000000000000000000004741475314470400325210ustar00rootroot00000000000000Test MP+dmb.sy+amo.ldaddal-polt Allowed States 3 1:X1=0; 1:X3=x:green; [y]=1; 1:X1=1; 1:X3=x:green; [y]=1; 1:X1=1; 1:X3=x:green; [y]=3; Ok Witnesses Positive: 1 Negative: 2 Condition exists ([y]=3 /\ 1:X1=1 /\ 1:X3=x:green) Observation MP+dmb.sy+amo.ldaddal-polt Sometimes 1 2 Hash=185683e89e9d791c8aa40bccb3ecc364 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.MTE/MP+dmb.sypt+amo.ldaddal-polp.litmus.expected000066400000000000000000000006461475314470400330620ustar00rootroot00000000000000Test MP+dmb.sypt+amo.ldaddal-polp Allowed States 4 1:X1=0; 1:X4=0; [y]=1; ~Fault(P1,y); 1:X1=0; 1:X4=0; [y]=1; Fault(P1,y:red,TagCheck); 1:X1=0; 1:X4=1; [y]=1; ~Fault(P1,y); 1:X1=0; 1:X4=1; [y]=1; Fault(P1,y:red,TagCheck); Ok Witnesses Positive: 1 Negative: 3 Condition exists ([y]=1 /\ 1:X1=0 /\ 1:X4=0 /\ not (fault(P1,y))) Observation MP+dmb.sypt+amo.ldaddal-polp Sometimes 1 3 Hash=6faf62fa651f6c4c98c4d5f3c2b380ea herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.MTE/MP+dmb.sypt+amo.ldaddal-polt.litmus.expected000066400000000000000000000005411475314470400330600ustar00rootroot00000000000000Test MP+dmb.sypt+amo.ldaddal-polt Allowed States 2 1:X1=0; 1:X3=x:green; [y]=1; ~Fault(P1,y); 1:X1=0; 1:X3=x:green; [y]=1; Fault(P1,y:red,TagCheck); Ok Witnesses Positive: 1 Negative: 1 Condition exists ([y]=1 /\ 1:X1=0 /\ 1:X3=x:green /\ not (fault(P1,y))) Observation MP+dmb.sypt+amo.ldaddal-polt Sometimes 1 1 Hash=9b6058dae5ff2ee1392680b3206be720 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.MTE/MP+dmb.sytp+amo.ldaddal-polp.litmus.expected000066400000000000000000000010031475314470400330460ustar00rootroot00000000000000Test MP+dmb.sytp+amo.ldaddal-polp Allowed States 6 1:X1=0; 1:X4=0; [y]=1; ~Fault(P1,x); 1:X1=0; 1:X4=0; [y]=1; Fault(P1,x:green,TagCheck); 1:X1=1; 1:X4=0; [y]=1; ~Fault(P1,x); 1:X1=1; 1:X4=0; [y]=1; Fault(P1,x:green,TagCheck); 1:X1=1; 1:X4=0; [y]=3; ~Fault(P1,x); 1:X1=1; 1:X4=0; [y]=3; Fault(P1,x:green,TagCheck); Ok Witnesses Positive: 1 Negative: 5 Condition exists ([y]=3 /\ 1:X1=1 /\ 1:X4=0 /\ not (fault(P1,x))) Observation MP+dmb.sytp+amo.ldaddal-polp Sometimes 1 5 Hash=e3e470b75006d9ccf4635f3d73e234b9 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.MTE/MP+dmb.sytp+amo.ldaddal-polt.litmus.expected000066400000000000000000000006211475314470400330570ustar00rootroot00000000000000Test MP+dmb.sytp+amo.ldaddal-polt Allowed States 6 1:X1=0; 1:X3=x:green; [y]=1; 1:X1=0; 1:X3=x:red; [y]=1; 1:X1=1; 1:X3=x:green; [y]=1; 1:X1=1; 1:X3=x:green; [y]=3; 1:X1=1; 1:X3=x:red; [y]=1; 1:X1=1; 1:X3=x:red; [y]=3; Ok Witnesses Positive: 1 Negative: 5 Condition exists ([y]=3 /\ 1:X1=1 /\ 1:X3=x:green) Observation MP+dmb.sytp+amo.ldaddal-polt Sometimes 1 5 Hash=31e288332fabd4a60afc236bdef9e38a herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.MTE/MP+dmb.sytt+amo.ldaddal-polp.litmus.expected000066400000000000000000000010101475314470400330500ustar00rootroot00000000000000Test MP+dmb.sytt+amo.ldaddal-polp Allowed States 4 1:X1=0; 1:X4=0; [y]=1; ~Fault(P1,y); ~Fault(P1,x); 1:X1=0; 1:X4=0; [y]=1; Fault(P1,x:green,TagCheck); ~Fault(P1,y); 1:X1=0; 1:X4=0; [y]=1; Fault(P1,x:green,TagCheck); Fault(P1,y:red,TagCheck); 1:X1=0; 1:X4=0; [y]=1; Fault(P1,y:red,TagCheck); ~Fault(P1,x); Ok Witnesses Positive: 1 Negative: 3 Condition exists ([y]=1 /\ 1:X1=0 /\ 1:X4=0 /\ not (fault(P1,x) \/ fault(P1,y))) Observation MP+dmb.sytt+amo.ldaddal-polp Sometimes 1 3 Hash=3545f816e5ace9ece8ab98f7ceb07273 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.MTE/MP+dmb.sytt+amo.ldaddal-polt.litmus.expected000066400000000000000000000007001475314470400330610ustar00rootroot00000000000000Test MP+dmb.sytt+amo.ldaddal-polt Allowed States 4 1:X1=0; 1:X3=x:green; [y]=1; ~Fault(P1,y); 1:X1=0; 1:X3=x:green; [y]=1; Fault(P1,y:red,TagCheck); 1:X1=0; 1:X3=x:red; [y]=1; ~Fault(P1,y); 1:X1=0; 1:X3=x:red; [y]=1; Fault(P1,y:red,TagCheck); Ok Witnesses Positive: 1 Negative: 3 Condition exists ([y]=1 /\ 1:X1=0 /\ 1:X3=x:green /\ not (fault(P1,y))) Observation MP+dmb.sytt+amo.ldaddal-polt Sometimes 1 3 Hash=9b64e5f5eb3c140d70336e29c6d375a1 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.MTE/MTE.cfg000066400000000000000000000007521475314470400237530ustar00rootroot00000000000000variant memtag,async #All tests should be allowed when model is relaxed. skipchecks external graph cluster squished true showevents noregs withbox true labelbox true fontsize 12 xscale 2.0 yscale 1.5 arrowsize 0.8 splines spline pad 0.1 doshow data doshow addr edgeattr iico_data,color,violetred edgeattr iico_ctrl,color,lightblue edgeattr rmw,color,indigo edgeattr rf-reg,color,red3 withbox true unshow dd,intrinsic labelbox true doshow fr,co,rmw unshow dmb.sy,dmb.st,dmb.ld,ca,dsb.sy,isb herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.MTE/S+dmb.sy+amo.ldaddal-polp.litmus.expected000066400000000000000000000005401475314470400323750ustar00rootroot00000000000000Test S+dmb.sy+amo.ldaddal-polp Allowed States 6 1:X1=0; [x]=1; [y]=1; 1:X1=0; [x]=2; [y]=1; 1:X1=1; [x]=1; [y]=1; 1:X1=1; [x]=1; [y]=3; 1:X1=1; [x]=2; [y]=1; 1:X1=1; [x]=2; [y]=3; Ok Witnesses Positive: 1 Negative: 5 Condition exists ([x]=2 /\ [y]=3 /\ 1:X1=1) Observation S+dmb.sy+amo.ldaddal-polp Sometimes 1 5 Hash=ac31d6fe1185d8d544d2c220fa02ccb6 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.MTE/S+dmb.sy+amo.ldaddal-polt.litmus.expected000066400000000000000000000007601475314470400324050ustar00rootroot00000000000000Test S+dmb.sy+amo.ldaddal-polt Allowed States 6 1:X1=0; [x]=1; [y]=1; ~Fault(P0,x); 1:X1=0; [x]=1; [y]=1; Fault(P0,x:red,TagCheck); 1:X1=1; [x]=1; [y]=1; ~Fault(P0,x); 1:X1=1; [x]=1; [y]=1; Fault(P0,x:red,TagCheck); 1:X1=1; [x]=1; [y]=3; ~Fault(P0,x); 1:X1=1; [x]=1; [y]=3; Fault(P0,x:red,TagCheck); Ok Witnesses Positive: 1 Negative: 5 Condition exists ([x]=1 /\ [y]=3 /\ 1:X1=1 /\ not (fault(P0,x))) Observation S+dmb.sy+amo.ldaddal-polt Sometimes 1 5 Hash=fc144829a130dfafd143834b20f10285 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.MTE/S+dmb.sypt+amo.ldaddal-polp.litmus.expected000066400000000000000000000006371475314470400327500ustar00rootroot00000000000000Test S+dmb.sypt+amo.ldaddal-polp Allowed States 4 1:X1=0; [x]=1; [y]=1; ~Fault(P1,y); 1:X1=0; [x]=1; [y]=1; Fault(P1,y:red,TagCheck); 1:X1=0; [x]=2; [y]=1; ~Fault(P1,y); 1:X1=0; [x]=2; [y]=1; Fault(P1,y:red,TagCheck); Ok Witnesses Positive: 1 Negative: 3 Condition exists ([x]=2 /\ [y]=1 /\ 1:X1=0 /\ not (fault(P1,y))) Observation S+dmb.sypt+amo.ldaddal-polp Sometimes 1 3 Hash=e9d45b526e1b489b2325fab6e114e48c herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.MTE/S+dmb.sypt+amo.ldaddal-polt.litmus.expected000066400000000000000000000007751475314470400327570ustar00rootroot00000000000000Test S+dmb.sypt+amo.ldaddal-polt Allowed States 4 1:X1=0; [x]=1; [y]=1; ~Fault(P1,y); ~Fault(P0,x); 1:X1=0; [x]=1; [y]=1; Fault(P0,x:red,TagCheck); ~Fault(P1,y); 1:X1=0; [x]=1; [y]=1; Fault(P0,x:red,TagCheck); Fault(P1,y:red,TagCheck); 1:X1=0; [x]=1; [y]=1; Fault(P1,y:red,TagCheck); ~Fault(P0,x); Ok Witnesses Positive: 1 Negative: 3 Condition exists ([x]=1 /\ [y]=1 /\ 1:X1=0 /\ not (fault(P0,x) \/ fault(P1,y))) Observation S+dmb.sypt+amo.ldaddal-polt Sometimes 1 3 Hash=7f918b600dafb66778128e36ebffacbd herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.MTE/S+dmb.sytp+amo.ldaddal-polp.litmus.expected000066400000000000000000000010621475314470400327410ustar00rootroot00000000000000Test S+dmb.sytp+amo.ldaddal-polp Allowed States 6 1:X1=0; [y]=1; [tag(x)]=:red; ~Fault(P1,x); 1:X1=0; [y]=1; [tag(x)]=:red; Fault(P1,x:green,TagCheck); 1:X1=1; [y]=1; [tag(x)]=:red; ~Fault(P1,x); 1:X1=1; [y]=1; [tag(x)]=:red; Fault(P1,x:green,TagCheck); 1:X1=1; [y]=3; [tag(x)]=:red; ~Fault(P1,x); 1:X1=1; [y]=3; [tag(x)]=:red; Fault(P1,x:green,TagCheck); Ok Witnesses Positive: 1 Negative: 5 Condition exists ([tag(x)]=:red /\ [y]=3 /\ 1:X1=1 /\ not (fault(P1,x))) Observation S+dmb.sytp+amo.ldaddal-polp Sometimes 1 5 Hash=1584470bb16be5b8c59c856576584bf7 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.MTE/S+dmb.sytp+amo.ldaddal-polt.litmus.expected000066400000000000000000000006401475314470400327460ustar00rootroot00000000000000Test S+dmb.sytp+amo.ldaddal-polt Allowed States 6 1:X1=0; [y]=1; [tag(x)]=:blue; 1:X1=0; [y]=1; [tag(x)]=:red; 1:X1=1; [y]=1; [tag(x)]=:blue; 1:X1=1; [y]=1; [tag(x)]=:red; 1:X1=1; [y]=3; [tag(x)]=:blue; 1:X1=1; [y]=3; [tag(x)]=:red; Ok Witnesses Positive: 1 Negative: 5 Condition exists ([tag(x)]=:blue /\ [y]=3 /\ 1:X1=1) Observation S+dmb.sytp+amo.ldaddal-polt Sometimes 1 5 Hash=935319150350fb5621f087696e8ab7e8 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.MTE/S+dmb.sytt+amo.ldaddal-polp.litmus.expected000066400000000000000000000010511475314470400327430ustar00rootroot00000000000000Test S+dmb.sytt+amo.ldaddal-polp Allowed States 4 1:X1=0; [y]=1; [tag(x)]=:red; ~Fault(P1,y); ~Fault(P1,x); 1:X1=0; [y]=1; [tag(x)]=:red; Fault(P1,x:green,TagCheck); ~Fault(P1,y); 1:X1=0; [y]=1; [tag(x)]=:red; Fault(P1,x:green,TagCheck); Fault(P1,y:red,TagCheck); 1:X1=0; [y]=1; [tag(x)]=:red; Fault(P1,y:red,TagCheck); ~Fault(P1,x); Ok Witnesses Positive: 1 Negative: 3 Condition exists ([tag(x)]=:red /\ [y]=1 /\ 1:X1=0 /\ not (fault(P1,x) \/ fault(P1,y))) Observation S+dmb.sytt+amo.ldaddal-polp Sometimes 1 3 Hash=d58df4fc5dbc47469494c72325885498 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.MTE/S+dmb.sytt+amo.ldaddal-polt.litmus.expected000066400000000000000000000007121475314470400327520ustar00rootroot00000000000000Test S+dmb.sytt+amo.ldaddal-polt Allowed States 4 1:X1=0; [y]=1; [tag(x)]=:blue; ~Fault(P1,y); 1:X1=0; [y]=1; [tag(x)]=:blue; Fault(P1,y:red,TagCheck); 1:X1=0; [y]=1; [tag(x)]=:red; ~Fault(P1,y); 1:X1=0; [y]=1; [tag(x)]=:red; Fault(P1,y:red,TagCheck); Ok Witnesses Positive: 1 Negative: 3 Condition exists ([tag(x)]=:blue /\ [y]=1 /\ 1:X1=0 /\ not (fault(P1,y))) Observation S+dmb.sytt+amo.ldaddal-polt Sometimes 1 3 Hash=a4e30010d224cb17e7372b451ea77e35 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.strict/000077500000000000000000000000001475314470400246315ustar00rootroot00000000000000MP+dmb.syh2h0+amo.casa.w0w0-pow0w0.litmus.expected000066400000000000000000000005501475314470400354030ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.strictTest MP+dmb.syh2h0+amo.casa.w0w0-pow0w0 Allowed States 3 1:X1=0x0; 1:X3=0x0; [y]=0x101; 1:X1=0x0; 1:X3=0x1010000; [y]=0x101; 1:X1=0x101; 1:X3=0x1010000; [y]=0x2020202; No Witnesses Positive: 0 Negative: 8 Condition exists ([y]=0x2020202 /\ 1:X1=0x101 /\ 1:X3=0x0) Observation MP+dmb.syh2h0+amo.casa.w0w0-pow0w0 Never 0 8 Hash=de0b51dd0baeae300ccb7bb64c89c67f MP+dmb.syh2h0+rmwa.w0w0-pow0w0.litmus.expected000066400000000000000000000010331475314470400346640ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.strictTest MP+dmb.syh2h0+rmwa.w0w0-pow0w0 Allowed States 6 1:X1=0x0; 1:X3=0x0; 1:X4=0x0; [y]=0x2020101; 1:X1=0x0; 1:X3=0x0; 1:X4=0x1010000; [y]=0x2020101; 1:X1=0x0; 1:X3=0x1; 1:X4=0x0; [y]=0x101; 1:X1=0x0; 1:X3=0x1; 1:X4=0x1010000; [y]=0x101; 1:X1=0x101; 1:X3=0x0; 1:X4=0x1010000; [y]=0x2020202; 1:X1=0x101; 1:X3=0x1; 1:X4=0x1010000; [y]=0x101; No Witnesses Positive: 0 Negative: 6 Condition exists ([y]=0x2020202 /\ 1:X3=0x0 /\ 1:X1=0x101 /\ 1:X4=0x0) Observation MP+dmb.syh2h0+rmwa.w0w0-pow0w0 Never 0 6 Hash=4314d60349bb069b9216fadcff66b408 MP+dmb.syh2h2+amo.casa.w0w0-pow0w0.litmus.expected000066400000000000000000000005701475314470400354070ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.strictTest MP+dmb.syh2h2+amo.casa.w0w0-pow0w0 Allowed States 3 1:X2=0x0; 1:X4=0x0; [y]=0x1010000; 1:X2=0x0; 1:X4=0x1010000; [y]=0x1010000; 1:X2=0x1010000; 1:X4=0x1010000; [y]=0x2020202; No Witnesses Positive: 0 Negative: 8 Condition exists ([y]=0x2020202 /\ 1:X2=0x1010000 /\ 1:X4=0x0) Observation MP+dmb.syh2h2+amo.casa.w0w0-pow0w0 Never 0 8 Hash=ccd1563306b43f28d7565b33bc2812c4 MP+dmb.syh2h2+rmwa.w0w0-pow0w0.litmus.expected000066400000000000000000000010631475314470400346710ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.strictTest MP+dmb.syh2h2+rmwa.w0w0-pow0w0 Allowed States 6 1:X1=0x0; 1:X3=0x0; 1:X4=0x0; [y]=0x1010202; 1:X1=0x0; 1:X3=0x0; 1:X4=0x1010000; [y]=0x1010202; 1:X1=0x0; 1:X3=0x1; 1:X4=0x0; [y]=0x1010000; 1:X1=0x0; 1:X3=0x1; 1:X4=0x1010000; [y]=0x1010000; 1:X1=0x1010000; 1:X3=0x0; 1:X4=0x1010000; [y]=0x2020202; 1:X1=0x1010000; 1:X3=0x1; 1:X4=0x1010000; [y]=0x1010000; No Witnesses Positive: 0 Negative: 6 Condition exists ([y]=0x2020202 /\ 1:X3=0x0 /\ 1:X1=0x1010000 /\ 1:X4=0x0) Observation MP+dmb.syh2h2+rmwa.w0w0-pow0w0 Never 0 6 Hash=f56e96d5bea787face50423eb6acd80e MP+dmb.syh2w0+amo.casa.h0h0-poh0w0.litmus.expected000066400000000000000000000005601475314470400353460ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.strictTest MP+dmb.syh2w0+amo.casa.h0h0-poh0w0 Allowed States 3 1:X1=0x0; 1:X3=0x0; [y]=0x1010101; 1:X1=0x0; 1:X3=0x1010000; [y]=0x1010101; 1:X1=0x101; 1:X3=0x1010000; [y]=0x1010202; No Witnesses Positive: 0 Negative: 8 Condition exists ([y]=0x1010202 /\ 1:X1=0x101 /\ 1:X3=0x0) Observation MP+dmb.syh2w0+amo.casa.h0h0-poh0w0 Never 0 8 Hash=91643c1d02ebd53a9c3fb07ad22b176e MP+dmb.syh2w0+amo.casa.h2h2-poh2w0.litmus.expected000066400000000000000000000005601475314470400353540ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.strictTest MP+dmb.syh2w0+amo.casa.h2h2-poh2w0 Allowed States 3 1:X1=0x0; 1:X4=0x0; [y]=0x1010101; 1:X1=0x0; 1:X4=0x1010000; [y]=0x1010101; 1:X1=0x101; 1:X4=0x1010000; [y]=0x2020101; No Witnesses Positive: 0 Negative: 8 Condition exists ([y]=0x2020101 /\ 1:X1=0x101 /\ 1:X4=0x0) Observation MP+dmb.syh2w0+amo.casa.h2h2-poh2w0 Never 0 8 Hash=a505ef52a19e87a874d77d613b2644a1 MP+dmb.syh2w0+rmwa.h0h0-poh0w0.litmus.expected000066400000000000000000000010471475314470400346330ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.strictTest MP+dmb.syh2w0+rmwa.h0h0-poh0w0 Allowed States 6 1:X1=0x0; 1:X3=0x0; 1:X4=0x0; [y]=0x1010101; 1:X1=0x0; 1:X3=0x0; 1:X4=0x1010000; [y]=0x1010101; 1:X1=0x0; 1:X3=0x1; 1:X4=0x0; [y]=0x1010101; 1:X1=0x0; 1:X3=0x1; 1:X4=0x1010000; [y]=0x1010101; 1:X1=0x101; 1:X3=0x0; 1:X4=0x1010000; [y]=0x1010202; 1:X1=0x101; 1:X3=0x1; 1:X4=0x1010000; [y]=0x1010101; No Witnesses Positive: 0 Negative: 6 Condition exists ([y]=0x1010202 /\ 1:X3=0x0 /\ 1:X1=0x101 /\ 1:X4=0x0) Observation MP+dmb.syh2w0+rmwa.h0h0-poh0w0 Never 0 6 Hash=270fab22a7c12a158aea69779324edf5 MP+dmb.syh2w0+rmwa.h2h2-poh2w0.litmus.expected000066400000000000000000000010471475314470400346410ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.strictTest MP+dmb.syh2w0+rmwa.h2h2-poh2w0 Allowed States 6 1:X1=0x0; 1:X4=0x0; 1:X5=0x0; [y]=0x1010101; 1:X1=0x0; 1:X4=0x0; 1:X5=0x1010000; [y]=0x1010101; 1:X1=0x0; 1:X4=0x1; 1:X5=0x0; [y]=0x1010101; 1:X1=0x0; 1:X4=0x1; 1:X5=0x1010000; [y]=0x1010101; 1:X1=0x101; 1:X4=0x0; 1:X5=0x1010000; [y]=0x2020101; 1:X1=0x101; 1:X4=0x1; 1:X5=0x1010000; [y]=0x1010101; No Witnesses Positive: 0 Negative: 6 Condition exists ([y]=0x2020101 /\ 1:X4=0x0 /\ 1:X1=0x101 /\ 1:X5=0x0) Observation MP+dmb.syh2w0+rmwa.h2h2-poh2w0 Never 0 6 Hash=c1d309c050670a2b353b7fcb7647db6b MP+dmb.syw0h0+amo.casa.w0w0-pow0h0.litmus.expected000066400000000000000000000005401475314470400354000ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.strictTest MP+dmb.syw0h0+amo.casa.w0w0-pow0h0 Allowed States 3 1:X1=0x0; 1:X3=0x0; [y]=0x101; 1:X1=0x0; 1:X3=0x101; [y]=0x101; 1:X1=0x101; 1:X3=0x101; [y]=0x2020202; No Witnesses Positive: 0 Negative: 8 Condition exists ([y]=0x2020202 /\ 1:X1=0x101 /\ 1:X3=0x0) Observation MP+dmb.syw0h0+amo.casa.w0w0-pow0h0 Never 0 8 Hash=012860ecc04db3a0c0cca4401aa0a718 MP+dmb.syw0h0+rmwa.w0w0-pow0h0.litmus.expected000066400000000000000000000010131475314470400346600ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.strictTest MP+dmb.syw0h0+rmwa.w0w0-pow0h0 Allowed States 6 1:X1=0x0; 1:X3=0x0; 1:X4=0x0; [y]=0x2020101; 1:X1=0x0; 1:X3=0x0; 1:X4=0x101; [y]=0x2020101; 1:X1=0x0; 1:X3=0x1; 1:X4=0x0; [y]=0x101; 1:X1=0x0; 1:X3=0x1; 1:X4=0x101; [y]=0x101; 1:X1=0x101; 1:X3=0x0; 1:X4=0x101; [y]=0x2020202; 1:X1=0x101; 1:X3=0x1; 1:X4=0x101; [y]=0x101; No Witnesses Positive: 0 Negative: 6 Condition exists ([y]=0x2020202 /\ 1:X3=0x0 /\ 1:X1=0x101 /\ 1:X4=0x0) Observation MP+dmb.syw0h0+rmwa.w0w0-pow0h0 Never 0 6 Hash=57a7bb49754c69116685b24f2ce72503 MP+dmb.syw0h2+amo.casa.w0w0-pow0h0.litmus.expected000066400000000000000000000005601475314470400354040ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.strictTest MP+dmb.syw0h2+amo.casa.w0w0-pow0h0 Allowed States 3 1:X2=0x0; 1:X4=0x0; [y]=0x1010000; 1:X2=0x0; 1:X4=0x101; [y]=0x1010000; 1:X2=0x1010000; 1:X4=0x101; [y]=0x2020202; No Witnesses Positive: 0 Negative: 8 Condition exists ([y]=0x2020202 /\ 1:X2=0x1010000 /\ 1:X4=0x0) Observation MP+dmb.syw0h2+amo.casa.w0w0-pow0h0 Never 0 8 Hash=ce2a7c8ea6503ba5f9bc7011832e680e MP+dmb.syw0h2+rmwa.w0w0-pow0h0.litmus.expected000066400000000000000000000010431475314470400346650ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.strictTest MP+dmb.syw0h2+rmwa.w0w0-pow0h0 Allowed States 6 1:X1=0x0; 1:X3=0x0; 1:X4=0x0; [y]=0x1010202; 1:X1=0x0; 1:X3=0x0; 1:X4=0x101; [y]=0x1010202; 1:X1=0x0; 1:X3=0x1; 1:X4=0x0; [y]=0x1010000; 1:X1=0x0; 1:X3=0x1; 1:X4=0x101; [y]=0x1010000; 1:X1=0x1010000; 1:X3=0x0; 1:X4=0x101; [y]=0x2020202; 1:X1=0x1010000; 1:X3=0x1; 1:X4=0x101; [y]=0x1010000; No Witnesses Positive: 0 Negative: 6 Condition exists ([y]=0x2020202 /\ 1:X3=0x0 /\ 1:X1=0x1010000 /\ 1:X4=0x0) Observation MP+dmb.syw0h2+rmwa.w0w0-pow0h0 Never 0 6 Hash=d49dfe5d923bb3de9524ebe4e9e110f3 MP+dmb.syw0w0+amo.casa.h0h0-poh0h0.litmus.expected000066400000000000000000000005501475314470400353430ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.strictTest MP+dmb.syw0w0+amo.casa.h0h0-poh0h0 Allowed States 3 1:X1=0x0; 1:X3=0x0; [y]=0x1010101; 1:X1=0x0; 1:X3=0x101; [y]=0x1010101; 1:X1=0x101; 1:X3=0x101; [y]=0x1010202; No Witnesses Positive: 0 Negative: 8 Condition exists ([y]=0x1010202 /\ 1:X1=0x101 /\ 1:X3=0x0) Observation MP+dmb.syw0w0+amo.casa.h0h0-poh0h0 Never 0 8 Hash=9f7ea35957b7fcaa3c120cad7b8ed304 MP+dmb.syw0w0+amo.casa.h2h2-poh2h0.litmus.expected000066400000000000000000000005501475314470400353510ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.strictTest MP+dmb.syw0w0+amo.casa.h2h2-poh2h0 Allowed States 3 1:X1=0x0; 1:X4=0x0; [y]=0x1010101; 1:X1=0x0; 1:X4=0x101; [y]=0x1010101; 1:X1=0x101; 1:X4=0x101; [y]=0x2020101; No Witnesses Positive: 0 Negative: 8 Condition exists ([y]=0x2020101 /\ 1:X1=0x101 /\ 1:X4=0x0) Observation MP+dmb.syw0w0+amo.casa.h2h2-poh2h0 Never 0 8 Hash=27e2a650c1b171931160eba3ded2ec7c MP+dmb.syw0w0+rmwa.h0h0-poh0h0.litmus.expected000066400000000000000000000010271475314470400346270ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.strictTest MP+dmb.syw0w0+rmwa.h0h0-poh0h0 Allowed States 6 1:X1=0x0; 1:X3=0x0; 1:X4=0x0; [y]=0x1010101; 1:X1=0x0; 1:X3=0x0; 1:X4=0x101; [y]=0x1010101; 1:X1=0x0; 1:X3=0x1; 1:X4=0x0; [y]=0x1010101; 1:X1=0x0; 1:X3=0x1; 1:X4=0x101; [y]=0x1010101; 1:X1=0x101; 1:X3=0x0; 1:X4=0x101; [y]=0x1010202; 1:X1=0x101; 1:X3=0x1; 1:X4=0x101; [y]=0x1010101; No Witnesses Positive: 0 Negative: 6 Condition exists ([y]=0x1010202 /\ 1:X3=0x0 /\ 1:X1=0x101 /\ 1:X4=0x0) Observation MP+dmb.syw0w0+rmwa.h0h0-poh0h0 Never 0 6 Hash=8f27065e5163d82a74b4a257910b7e7c MP+dmb.syw0w0+rmwa.h2h2-poh2h0.litmus.expected000066400000000000000000000010271475314470400346350ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.strictTest MP+dmb.syw0w0+rmwa.h2h2-poh2h0 Allowed States 6 1:X1=0x0; 1:X4=0x0; 1:X5=0x0; [y]=0x1010101; 1:X1=0x0; 1:X4=0x0; 1:X5=0x101; [y]=0x1010101; 1:X1=0x0; 1:X4=0x1; 1:X5=0x0; [y]=0x1010101; 1:X1=0x0; 1:X4=0x1; 1:X5=0x101; [y]=0x1010101; 1:X1=0x101; 1:X4=0x0; 1:X5=0x101; [y]=0x2020101; 1:X1=0x101; 1:X4=0x1; 1:X5=0x101; [y]=0x1010101; No Witnesses Positive: 0 Negative: 6 Condition exists ([y]=0x2020101 /\ 1:X4=0x0 /\ 1:X1=0x101 /\ 1:X5=0x0) Observation MP+dmb.syw0w0+rmwa.h2h2-poh2h0 Never 0 6 Hash=cd0a3cd53085724a3a66d61c5f6b517b herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.strict/README.txt000066400000000000000000000005521475314470400263310ustar00rootroot00000000000000Test option -variant mixed,MixedStrictOverlap Strict overalap of mixed-size accesses is enforced on both sides of teh genric same access relaxation Fre, but not on both sides of Amo.Cas and LxSx. Indeed, such a configuration of accesses is the only possibility for Amo nstructions (by nature) and for Load/Store exclusive pairs (* because UB are disallowed *) herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.strict/mixed.cfg000077700000000000000000000000001475314470400326522../AArch64.mixed/mixed.cfgustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/000077500000000000000000000000001475314470400237335ustar00rootroot00000000000000MP+pow0l.w0+addra.h0a.h0.litmus.expected000066400000000000000000000004261475314470400326370ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32Test MP+pow0l.w0+addra.h0a.h0 Allowed States 3 1:X1=0x0; 1:X3=0x0; 1:X1=0x0; 1:X3=0x101; 1:X1=0x101; 1:X3=0x101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x101 /\ 1:X3=0x0) Observation MP+pow0l.w0+addra.h0a.h0 Never 0 3 Hash=41fc5a689f77a5c23f9393b6c2cb4896 MP+pow0l.w0+addra.h0a.h2.litmus.expected000066400000000000000000000004261475314470400326410ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32Test MP+pow0l.w0+addra.h0a.h2 Allowed States 3 1:X1=0x0; 1:X3=0x0; 1:X1=0x0; 1:X3=0x101; 1:X1=0x101; 1:X3=0x101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x101 /\ 1:X3=0x0) Observation MP+pow0l.w0+addra.h0a.h2 Never 0 3 Hash=8de643fb5b90da65ad92e848a4b2570e MP+pow0l.w0+addra.h0a.w0.litmus.expected000066400000000000000000000004361475314470400326570ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32Test MP+pow0l.w0+addra.h0a.w0 Allowed States 3 1:X1=0x0; 1:X3=0x0; 1:X1=0x0; 1:X3=0x1010101; 1:X1=0x101; 1:X3=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x101 /\ 1:X3=0x0) Observation MP+pow0l.w0+addra.h0a.w0 Never 0 3 Hash=1862ded9f722e8f60b4434fec8aabba8 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/MP+pow0l.w0+addra.h0h0.litmus.expected000066400000000000000000000004221475314470400324730ustar00rootroot00000000000000Test MP+pow0l.w0+addra.h0h0 Allowed States 3 1:X1=0x0; 1:X3=0x0; 1:X1=0x0; 1:X3=0x101; 1:X1=0x101; 1:X3=0x101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x101 /\ 1:X3=0x0) Observation MP+pow0l.w0+addra.h0h0 Never 0 3 Hash=c3449c21e2e9ce5b8e582e9b836e188d herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/MP+pow0l.w0+addra.h0h2.litmus.expected000066400000000000000000000004221475314470400324750ustar00rootroot00000000000000Test MP+pow0l.w0+addra.h0h2 Allowed States 3 1:X1=0x0; 1:X3=0x0; 1:X1=0x0; 1:X3=0x101; 1:X1=0x101; 1:X3=0x101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x101 /\ 1:X3=0x0) Observation MP+pow0l.w0+addra.h0h2 Never 0 3 Hash=b7d9b5073dd9ee074027423267c81c94 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/MP+pow0l.w0+addra.h0w0.litmus.expected000066400000000000000000000004321475314470400325130ustar00rootroot00000000000000Test MP+pow0l.w0+addra.h0w0 Allowed States 3 1:X1=0x0; 1:X3=0x0; 1:X1=0x0; 1:X3=0x1010101; 1:X1=0x101; 1:X3=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x101 /\ 1:X3=0x0) Observation MP+pow0l.w0+addra.h0w0 Never 0 3 Hash=c4b667f290f4e99e22a96574e513cb53 MP+pow0l.w0+addra.h2a.h0.litmus.expected000066400000000000000000000004261475314470400326410ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32Test MP+pow0l.w0+addra.h2a.h0 Allowed States 3 1:X1=0x0; 1:X4=0x0; 1:X1=0x0; 1:X4=0x101; 1:X1=0x101; 1:X4=0x101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x101 /\ 1:X4=0x0) Observation MP+pow0l.w0+addra.h2a.h0 Never 0 3 Hash=31632baf6d38bb2294e87044a3e612b8 MP+pow0l.w0+addra.h2a.h2.litmus.expected000066400000000000000000000004261475314470400326430ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32Test MP+pow0l.w0+addra.h2a.h2 Allowed States 3 1:X1=0x0; 1:X4=0x0; 1:X1=0x0; 1:X4=0x101; 1:X1=0x101; 1:X4=0x101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x101 /\ 1:X4=0x0) Observation MP+pow0l.w0+addra.h2a.h2 Never 0 3 Hash=091ec43cf285fbb3920292a5ca8242c3 MP+pow0l.w0+addra.h2a.w0.litmus.expected000066400000000000000000000004361475314470400326610ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32Test MP+pow0l.w0+addra.h2a.w0 Allowed States 3 1:X1=0x0; 1:X4=0x0; 1:X1=0x0; 1:X4=0x1010101; 1:X1=0x101; 1:X4=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x101 /\ 1:X4=0x0) Observation MP+pow0l.w0+addra.h2a.w0 Never 0 3 Hash=c8955a305a8a68ec6e6e63e867e0a88e herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/MP+pow0l.w0+addra.h2h0.litmus.expected000066400000000000000000000004221475314470400324750ustar00rootroot00000000000000Test MP+pow0l.w0+addra.h2h0 Allowed States 3 1:X1=0x0; 1:X4=0x0; 1:X1=0x0; 1:X4=0x101; 1:X1=0x101; 1:X4=0x101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x101 /\ 1:X4=0x0) Observation MP+pow0l.w0+addra.h2h0 Never 0 3 Hash=d7922d1ea5934f9b498235f4a98c508f herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/MP+pow0l.w0+addra.h2h2.litmus.expected000066400000000000000000000004221475314470400324770ustar00rootroot00000000000000Test MP+pow0l.w0+addra.h2h2 Allowed States 3 1:X1=0x0; 1:X4=0x0; 1:X1=0x0; 1:X4=0x101; 1:X1=0x101; 1:X4=0x101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x101 /\ 1:X4=0x0) Observation MP+pow0l.w0+addra.h2h2 Never 0 3 Hash=945ecc6d139f35b751dd49327c5cc49c herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/MP+pow0l.w0+addra.h2w0.litmus.expected000066400000000000000000000004321475314470400325150ustar00rootroot00000000000000Test MP+pow0l.w0+addra.h2w0 Allowed States 3 1:X1=0x0; 1:X4=0x0; 1:X1=0x0; 1:X4=0x1010101; 1:X1=0x101; 1:X4=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x101 /\ 1:X4=0x0) Observation MP+pow0l.w0+addra.h2w0 Never 0 3 Hash=0b30f76456762ea67e7ad4fa2bd168f6 MP+pow0l.w0+addra.w0a.h0.litmus.expected000066400000000000000000000004361475314470400326570ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32Test MP+pow0l.w0+addra.w0a.h0 Allowed States 3 1:X1=0x0; 1:X3=0x0; 1:X1=0x0; 1:X3=0x101; 1:X1=0x1010101; 1:X3=0x101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x1010101 /\ 1:X3=0x0) Observation MP+pow0l.w0+addra.w0a.h0 Never 0 3 Hash=a04e784efce3d045069124b7df0d5701 MP+pow0l.w0+addra.w0a.h2.litmus.expected000066400000000000000000000004361475314470400326610ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32Test MP+pow0l.w0+addra.w0a.h2 Allowed States 3 1:X1=0x0; 1:X3=0x0; 1:X1=0x0; 1:X3=0x101; 1:X1=0x1010101; 1:X3=0x101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x1010101 /\ 1:X3=0x0) Observation MP+pow0l.w0+addra.w0a.h2 Never 0 3 Hash=cfbcd08438689ab3aea1b5ce0df34ec6 MP+pow0l.w0+addra.w0a.w0.litmus.expected000066400000000000000000000004461475314470400326770ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32Test MP+pow0l.w0+addra.w0a.w0 Allowed States 3 1:X1=0x0; 1:X3=0x0; 1:X1=0x0; 1:X3=0x1010101; 1:X1=0x1010101; 1:X3=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x1010101 /\ 1:X3=0x0) Observation MP+pow0l.w0+addra.w0a.w0 Never 0 3 Hash=68f4145d7e6baf46cf119f735743589f herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/MP+pow0l.w0+addra.w0h0.litmus.expected000066400000000000000000000004321475314470400325130ustar00rootroot00000000000000Test MP+pow0l.w0+addra.w0h0 Allowed States 3 1:X1=0x0; 1:X3=0x0; 1:X1=0x0; 1:X3=0x101; 1:X1=0x1010101; 1:X3=0x101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x1010101 /\ 1:X3=0x0) Observation MP+pow0l.w0+addra.w0h0 Never 0 3 Hash=c4489e2f59d8f51892eb69bc92d2999b herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/MP+pow0l.w0+addra.w0h2.litmus.expected000066400000000000000000000004321475314470400325150ustar00rootroot00000000000000Test MP+pow0l.w0+addra.w0h2 Allowed States 3 1:X1=0x0; 1:X3=0x0; 1:X1=0x0; 1:X3=0x101; 1:X1=0x1010101; 1:X3=0x101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x1010101 /\ 1:X3=0x0) Observation MP+pow0l.w0+addra.w0h2 Never 0 3 Hash=f7555940c122588ca4c4186fbe495c74 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/MP+pow0l.w0+addra.w0w0.litmus.expected000066400000000000000000000004421475314470400325330ustar00rootroot00000000000000Test MP+pow0l.w0+addra.w0w0 Allowed States 3 1:X1=0x0; 1:X3=0x0; 1:X1=0x0; 1:X3=0x1010101; 1:X1=0x1010101; 1:X3=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x1010101 /\ 1:X3=0x0) Observation MP+pow0l.w0+addra.w0w0 Never 0 3 Hash=4eda68aab0a341a9a993c604cee0b7d9 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/README.txt000066400000000000000000000001031475314470400254230ustar00rootroot00000000000000Check that X and W registers are well selected in mixed-size tests herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/S+pow0l.w0+addra.h0h0.litmus.expected000066400000000000000000000004401475314470400323610ustar00rootroot00000000000000Test S+pow0l.w0+addra.h0h0 Allowed States 3 1:X1=0x0; [x]=0x2020101; 1:X1=0x0; [x]=0x2020202; 1:X1=0x101; [x]=0x2020101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x101) Observation S+pow0l.w0+addra.h0h0 Never 0 3 Hash=7cf2ce0664822ea76c2e5df5d04e8280 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/S+pow0l.w0+addra.h0h2.litmus.expected000066400000000000000000000004401475314470400323630ustar00rootroot00000000000000Test S+pow0l.w0+addra.h0h2 Allowed States 3 1:X1=0x0; [x]=0x1010202; 1:X1=0x0; [x]=0x2020202; 1:X1=0x101; [x]=0x1010202; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x101) Observation S+pow0l.w0+addra.h0h2 Never 0 3 Hash=0c59aafca70db6bb3d80b21206d7213a S+pow0l.w0+addra.h0l.h0.litmus.expected000066400000000000000000000004441475314470400325400ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32Test S+pow0l.w0+addra.h0l.h0 Allowed States 3 1:X1=0x0; [x]=0x2020101; 1:X1=0x0; [x]=0x2020202; 1:X1=0x101; [x]=0x2020101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x101) Observation S+pow0l.w0+addra.h0l.h0 Never 0 3 Hash=5d1deb5807b07c7224dbd77e5e828006 S+pow0l.w0+addra.h0l.h2.litmus.expected000066400000000000000000000004441475314470400325420ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32Test S+pow0l.w0+addra.h0l.h2 Allowed States 3 1:X1=0x0; [x]=0x1010202; 1:X1=0x0; [x]=0x2020202; 1:X1=0x101; [x]=0x1010202; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x101) Observation S+pow0l.w0+addra.h0l.h2 Never 0 3 Hash=1970a2e842521b11274d44a41ff95b00 S+pow0l.w0+addra.h0l.w0.litmus.expected000066400000000000000000000004441475314470400325570ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32Test S+pow0l.w0+addra.h0l.w0 Allowed States 3 1:X1=0x0; [x]=0x1010101; 1:X1=0x0; [x]=0x2020202; 1:X1=0x101; [x]=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x101) Observation S+pow0l.w0+addra.h0l.w0 Never 0 3 Hash=4220b7bcc0db14732a0871da696c54d8 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/S+pow0l.w0+addra.h0w0.litmus.expected000066400000000000000000000004401475314470400324000ustar00rootroot00000000000000Test S+pow0l.w0+addra.h0w0 Allowed States 3 1:X1=0x0; [x]=0x1010101; 1:X1=0x0; [x]=0x2020202; 1:X1=0x101; [x]=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x101) Observation S+pow0l.w0+addra.h0w0 Never 0 3 Hash=2bbd59fe96d67e8c0b2ea3cbb5599efe herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/S+pow0l.w0+addra.h2h0.litmus.expected000066400000000000000000000004401475314470400323630ustar00rootroot00000000000000Test S+pow0l.w0+addra.h2h0 Allowed States 3 1:X1=0x0; [x]=0x2020101; 1:X1=0x0; [x]=0x2020202; 1:X1=0x101; [x]=0x2020101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x101) Observation S+pow0l.w0+addra.h2h0 Never 0 3 Hash=084f30805de9fe14136adbeb727edee3 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/S+pow0l.w0+addra.h2h2.litmus.expected000066400000000000000000000004401475314470400323650ustar00rootroot00000000000000Test S+pow0l.w0+addra.h2h2 Allowed States 3 1:X1=0x0; [x]=0x1010202; 1:X1=0x0; [x]=0x2020202; 1:X1=0x101; [x]=0x1010202; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x101) Observation S+pow0l.w0+addra.h2h2 Never 0 3 Hash=408a178f2c8ed8df9331aa698016c825 S+pow0l.w0+addra.h2l.h0.litmus.expected000066400000000000000000000004441475314470400325420ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32Test S+pow0l.w0+addra.h2l.h0 Allowed States 3 1:X1=0x0; [x]=0x2020101; 1:X1=0x0; [x]=0x2020202; 1:X1=0x101; [x]=0x2020101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x101) Observation S+pow0l.w0+addra.h2l.h0 Never 0 3 Hash=1ab9cabd68e83c3009449de8d6355c28 S+pow0l.w0+addra.h2l.h2.litmus.expected000066400000000000000000000004441475314470400325440ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32Test S+pow0l.w0+addra.h2l.h2 Allowed States 3 1:X1=0x0; [x]=0x1010202; 1:X1=0x0; [x]=0x2020202; 1:X1=0x101; [x]=0x1010202; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x101) Observation S+pow0l.w0+addra.h2l.h2 Never 0 3 Hash=82336db1414d661a4476bf707538295a S+pow0l.w0+addra.h2l.w0.litmus.expected000066400000000000000000000004441475314470400325610ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32Test S+pow0l.w0+addra.h2l.w0 Allowed States 3 1:X1=0x0; [x]=0x1010101; 1:X1=0x0; [x]=0x2020202; 1:X1=0x101; [x]=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x101) Observation S+pow0l.w0+addra.h2l.w0 Never 0 3 Hash=066f61dd1dd83557b8d41d3a8a9b2cce herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/S+pow0l.w0+addra.h2w0.litmus.expected000066400000000000000000000004401475314470400324020ustar00rootroot00000000000000Test S+pow0l.w0+addra.h2w0 Allowed States 3 1:X1=0x0; [x]=0x1010101; 1:X1=0x0; [x]=0x2020202; 1:X1=0x101; [x]=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x101) Observation S+pow0l.w0+addra.h2w0 Never 0 3 Hash=029265acf486078ae32a953b8dbc7fdd herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/S+pow0l.w0+addra.w0h0.litmus.expected000066400000000000000000000004501475314470400324010ustar00rootroot00000000000000Test S+pow0l.w0+addra.w0h0 Allowed States 3 1:X1=0x0; [x]=0x2020101; 1:X1=0x0; [x]=0x2020202; 1:X1=0x1010101; [x]=0x2020101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x1010101) Observation S+pow0l.w0+addra.w0h0 Never 0 3 Hash=0ed2f9b82f64a0cd39bb2025a83081d3 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/S+pow0l.w0+addra.w0h2.litmus.expected000066400000000000000000000004501475314470400324030ustar00rootroot00000000000000Test S+pow0l.w0+addra.w0h2 Allowed States 3 1:X1=0x0; [x]=0x1010202; 1:X1=0x0; [x]=0x2020202; 1:X1=0x1010101; [x]=0x1010202; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x1010101) Observation S+pow0l.w0+addra.w0h2 Never 0 3 Hash=87c3f37ff51a532730d81f31dcc01b22 S+pow0l.w0+addra.w0l.h0.litmus.expected000066400000000000000000000004541475314470400325600ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32Test S+pow0l.w0+addra.w0l.h0 Allowed States 3 1:X1=0x0; [x]=0x2020101; 1:X1=0x0; [x]=0x2020202; 1:X1=0x1010101; [x]=0x2020101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x1010101) Observation S+pow0l.w0+addra.w0l.h0 Never 0 3 Hash=8fd4ae149b876a64fcc1812bc5cd7b2d S+pow0l.w0+addra.w0l.h2.litmus.expected000066400000000000000000000004541475314470400325620ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32Test S+pow0l.w0+addra.w0l.h2 Allowed States 3 1:X1=0x0; [x]=0x1010202; 1:X1=0x0; [x]=0x2020202; 1:X1=0x1010101; [x]=0x1010202; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x1010101) Observation S+pow0l.w0+addra.w0l.h2 Never 0 3 Hash=459256ecd797b0a505ae6a875a045060 S+pow0l.w0+addra.w0l.w0.litmus.expected000066400000000000000000000004541475314470400325770ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32Test S+pow0l.w0+addra.w0l.w0 Allowed States 3 1:X1=0x0; [x]=0x1010101; 1:X1=0x0; [x]=0x2020202; 1:X1=0x1010101; [x]=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x1010101) Observation S+pow0l.w0+addra.w0l.w0 Never 0 3 Hash=5dcbc935bf445df61bb73c351cd4a846 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/S+pow0l.w0+addra.w0w0.litmus.expected000066400000000000000000000004501475314470400324200ustar00rootroot00000000000000Test S+pow0l.w0+addra.w0w0 Allowed States 3 1:X1=0x0; [x]=0x1010101; 1:X1=0x0; [x]=0x2020202; 1:X1=0x1010101; [x]=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x1010101) Observation S+pow0l.w0+addra.w0w0 Never 0 3 Hash=63285f16a74ae74e54762e3095d894e4 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/S+pow0l.w0+dataa.h0h0.litmus.expected000066400000000000000000000004401475314470400323600ustar00rootroot00000000000000Test S+pow0l.w0+dataa.h0h0 Allowed States 3 1:X1=0x0; [x]=0x2020101; 1:X1=0x0; [x]=0x2020202; 1:X1=0x101; [x]=0x2020101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x101) Observation S+pow0l.w0+dataa.h0h0 Never 0 3 Hash=8aeca24cd3c4a538e8bc9df7f569c75d herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/S+pow0l.w0+dataa.h0h2.litmus.expected000066400000000000000000000004401475314470400323620ustar00rootroot00000000000000Test S+pow0l.w0+dataa.h0h2 Allowed States 3 1:X1=0x0; [x]=0x1010202; 1:X1=0x0; [x]=0x2020202; 1:X1=0x101; [x]=0x1010202; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x101) Observation S+pow0l.w0+dataa.h0h2 Never 0 3 Hash=00e31210c6758092a902c810256af53e S+pow0l.w0+dataa.h0l.h0.litmus.expected000066400000000000000000000004441475314470400325370ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32Test S+pow0l.w0+dataa.h0l.h0 Allowed States 3 1:X1=0x0; [x]=0x2020101; 1:X1=0x0; [x]=0x2020202; 1:X1=0x101; [x]=0x2020101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x101) Observation S+pow0l.w0+dataa.h0l.h0 Never 0 3 Hash=a919f0de7bedf98f3755fcfa2212de23 S+pow0l.w0+dataa.h0l.h2.litmus.expected000066400000000000000000000004441475314470400325410ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32Test S+pow0l.w0+dataa.h0l.h2 Allowed States 3 1:X1=0x0; [x]=0x1010202; 1:X1=0x0; [x]=0x2020202; 1:X1=0x101; [x]=0x1010202; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x101) Observation S+pow0l.w0+dataa.h0l.h2 Never 0 3 Hash=f724ae899fed56e67be30d0ee8e4c3ad S+pow0l.w0+dataa.h0l.w0.litmus.expected000066400000000000000000000004441475314470400325560ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32Test S+pow0l.w0+dataa.h0l.w0 Allowed States 3 1:X1=0x0; [x]=0x1010101; 1:X1=0x0; [x]=0x2020202; 1:X1=0x101; [x]=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x101) Observation S+pow0l.w0+dataa.h0l.w0 Never 0 3 Hash=2d5296cfe4d93aae06e830a714d74468 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/S+pow0l.w0+dataa.h0w0.litmus.expected000066400000000000000000000004401475314470400323770ustar00rootroot00000000000000Test S+pow0l.w0+dataa.h0w0 Allowed States 3 1:X1=0x0; [x]=0x1010101; 1:X1=0x0; [x]=0x2020202; 1:X1=0x101; [x]=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x101) Observation S+pow0l.w0+dataa.h0w0 Never 0 3 Hash=6e7a69051a8b7c762269c3a08dfcc699 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/S+pow0l.w0+dataa.h2h0.litmus.expected000066400000000000000000000004401475314470400323620ustar00rootroot00000000000000Test S+pow0l.w0+dataa.h2h0 Allowed States 3 1:X1=0x0; [x]=0x2020101; 1:X1=0x0; [x]=0x2020202; 1:X1=0x101; [x]=0x2020101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x101) Observation S+pow0l.w0+dataa.h2h0 Never 0 3 Hash=5185516d969d586f3643ad30c9b084f5 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/S+pow0l.w0+dataa.h2h2.litmus.expected000066400000000000000000000004401475314470400323640ustar00rootroot00000000000000Test S+pow0l.w0+dataa.h2h2 Allowed States 3 1:X1=0x0; [x]=0x1010202; 1:X1=0x0; [x]=0x2020202; 1:X1=0x101; [x]=0x1010202; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x101) Observation S+pow0l.w0+dataa.h2h2 Never 0 3 Hash=0ca72953407e193ead820106c2bf4ffe S+pow0l.w0+dataa.h2l.h0.litmus.expected000066400000000000000000000004441475314470400325410ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32Test S+pow0l.w0+dataa.h2l.h0 Allowed States 3 1:X1=0x0; [x]=0x2020101; 1:X1=0x0; [x]=0x2020202; 1:X1=0x101; [x]=0x2020101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x101) Observation S+pow0l.w0+dataa.h2l.h0 Never 0 3 Hash=d787f10d3459133305ec2d27f479074e S+pow0l.w0+dataa.h2l.h2.litmus.expected000066400000000000000000000004441475314470400325430ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32Test S+pow0l.w0+dataa.h2l.h2 Allowed States 3 1:X1=0x0; [x]=0x1010202; 1:X1=0x0; [x]=0x2020202; 1:X1=0x101; [x]=0x1010202; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x101) Observation S+pow0l.w0+dataa.h2l.h2 Never 0 3 Hash=dfaa8228035b54c0152819274ee22c8e S+pow0l.w0+dataa.h2l.w0.litmus.expected000066400000000000000000000004441475314470400325600ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32Test S+pow0l.w0+dataa.h2l.w0 Allowed States 3 1:X1=0x0; [x]=0x1010101; 1:X1=0x0; [x]=0x2020202; 1:X1=0x101; [x]=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x101) Observation S+pow0l.w0+dataa.h2l.w0 Never 0 3 Hash=ac6277657c490276d038cf351255b269 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/S+pow0l.w0+dataa.h2w0.litmus.expected000066400000000000000000000004401475314470400324010ustar00rootroot00000000000000Test S+pow0l.w0+dataa.h2w0 Allowed States 3 1:X1=0x0; [x]=0x1010101; 1:X1=0x0; [x]=0x2020202; 1:X1=0x101; [x]=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x101) Observation S+pow0l.w0+dataa.h2w0 Never 0 3 Hash=f6270616ea6426a6d2547179d4801603 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/S+pow0l.w0+dataa.w0h0.litmus.expected000066400000000000000000000004501475314470400324000ustar00rootroot00000000000000Test S+pow0l.w0+dataa.w0h0 Allowed States 3 1:X1=0x0; [x]=0x2020101; 1:X1=0x0; [x]=0x2020202; 1:X1=0x1010101; [x]=0x2020101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x1010101) Observation S+pow0l.w0+dataa.w0h0 Never 0 3 Hash=d31b4543b010996ab04a68fe5622c604 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/S+pow0l.w0+dataa.w0h2.litmus.expected000066400000000000000000000004501475314470400324020ustar00rootroot00000000000000Test S+pow0l.w0+dataa.w0h2 Allowed States 3 1:X1=0x0; [x]=0x1010202; 1:X1=0x0; [x]=0x2020202; 1:X1=0x1010101; [x]=0x1010202; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x1010101) Observation S+pow0l.w0+dataa.w0h2 Never 0 3 Hash=b54835d3e75d9c5a366528377d01e1b8 S+pow0l.w0+dataa.w0l.h0.litmus.expected000066400000000000000000000004541475314470400325570ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32Test S+pow0l.w0+dataa.w0l.h0 Allowed States 3 1:X1=0x0; [x]=0x2020101; 1:X1=0x0; [x]=0x2020202; 1:X1=0x1010101; [x]=0x2020101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x1010101) Observation S+pow0l.w0+dataa.w0l.h0 Never 0 3 Hash=b4f5dc7c9c4e5aaca3147bd75c085e3e S+pow0l.w0+dataa.w0l.h2.litmus.expected000066400000000000000000000004541475314470400325610ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32Test S+pow0l.w0+dataa.w0l.h2 Allowed States 3 1:X1=0x0; [x]=0x1010202; 1:X1=0x0; [x]=0x2020202; 1:X1=0x1010101; [x]=0x1010202; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x1010101) Observation S+pow0l.w0+dataa.w0l.h2 Never 0 3 Hash=447ce817964803ccca7c86ef38ce9f4a S+pow0l.w0+dataa.w0l.w0.litmus.expected000066400000000000000000000004541475314470400325760ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32Test S+pow0l.w0+dataa.w0l.w0 Allowed States 3 1:X1=0x0; [x]=0x1010101; 1:X1=0x0; [x]=0x2020202; 1:X1=0x1010101; [x]=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x1010101) Observation S+pow0l.w0+dataa.w0l.w0 Never 0 3 Hash=468a696b7d772416bc7689b9d8b4970d herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/S+pow0l.w0+dataa.w0w0.litmus.expected000066400000000000000000000004501475314470400324170ustar00rootroot00000000000000Test S+pow0l.w0+dataa.w0w0 Allowed States 3 1:X1=0x0; [x]=0x1010101; 1:X1=0x0; [x]=0x2020202; 1:X1=0x1010101; [x]=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x2020202 /\ 1:X1=0x1010101) Observation S+pow0l.w0+dataa.w0w0 Never 0 3 Hash=fb82861d31d12aab2e57a6dfb4d1baad herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v32/mixed.cfg000077700000000000000000000000001475314470400317542../AArch64.mixed/mixed.cfgustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/000077500000000000000000000000001475314470400237405ustar00rootroot00000000000000MP+poq0l.q0+addra.q0a.q0.litmus.expected000066400000000000000000000005061475314470400326510ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64Test MP+poq0l.q0+addra.q0a.q0 Allowed States 3 1:X1=0x0; 1:X3=0x0; 1:X1=0x0; 1:X3=0x101010101010101; 1:X1=0x101010101010101; 1:X3=0x101010101010101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x101010101010101 /\ 1:X3=0x0) Observation MP+poq0l.q0+addra.q0a.q0 Never 0 3 Hash=090589129d526ecc4d7c48bce349786b MP+poq0l.q0+addra.q0a.w0.litmus.expected000066400000000000000000000004661475314470400326640ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64Test MP+poq0l.q0+addra.q0a.w0 Allowed States 3 1:X1=0x0; 1:X3=0x0; 1:X1=0x0; 1:X3=0x1010101; 1:X1=0x101010101010101; 1:X3=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x101010101010101 /\ 1:X3=0x0) Observation MP+poq0l.q0+addra.q0a.w0 Never 0 3 Hash=e03a8aa7124f8ec167c81a482485e170 MP+poq0l.q0+addra.q0a.w4.litmus.expected000066400000000000000000000004661475314470400326700ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64Test MP+poq0l.q0+addra.q0a.w4 Allowed States 3 1:X1=0x0; 1:X3=0x0; 1:X1=0x0; 1:X3=0x1010101; 1:X1=0x101010101010101; 1:X3=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x101010101010101 /\ 1:X3=0x0) Observation MP+poq0l.q0+addra.q0a.w4 Never 0 3 Hash=8bff3afda1f44f0fe3dfacda4b77d897 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/MP+poq0l.q0+addra.q0q0.litmus.expected000066400000000000000000000005021475314470400325050ustar00rootroot00000000000000Test MP+poq0l.q0+addra.q0q0 Allowed States 3 1:X1=0x0; 1:X3=0x0; 1:X1=0x0; 1:X3=0x101010101010101; 1:X1=0x101010101010101; 1:X3=0x101010101010101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x101010101010101 /\ 1:X3=0x0) Observation MP+poq0l.q0+addra.q0q0 Never 0 3 Hash=fea7dd8f94832567a3338364392fbfdf herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/MP+poq0l.q0+addra.q0w0.litmus.expected000066400000000000000000000004621475314470400325200ustar00rootroot00000000000000Test MP+poq0l.q0+addra.q0w0 Allowed States 3 1:X1=0x0; 1:X3=0x0; 1:X1=0x0; 1:X3=0x1010101; 1:X1=0x101010101010101; 1:X3=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x101010101010101 /\ 1:X3=0x0) Observation MP+poq0l.q0+addra.q0w0 Never 0 3 Hash=f85a10ed439afc7bc2ff2119aca0cfea herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/MP+poq0l.q0+addra.q0w4.litmus.expected000066400000000000000000000004621475314470400325240ustar00rootroot00000000000000Test MP+poq0l.q0+addra.q0w4 Allowed States 3 1:X1=0x0; 1:X3=0x0; 1:X1=0x0; 1:X3=0x1010101; 1:X1=0x101010101010101; 1:X3=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x101010101010101 /\ 1:X3=0x0) Observation MP+poq0l.q0+addra.q0w4 Never 0 3 Hash=680b80f1040f297a5b165ff5a03c2d05 MP+poq0l.q0+addra.w0a.q0.litmus.expected000066400000000000000000000004661475314470400326640ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64Test MP+poq0l.q0+addra.w0a.q0 Allowed States 3 1:X1=0x0; 1:X3=0x0; 1:X1=0x0; 1:X3=0x101010101010101; 1:X1=0x1010101; 1:X3=0x101010101010101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x1010101 /\ 1:X3=0x0) Observation MP+poq0l.q0+addra.w0a.q0 Never 0 3 Hash=f07ddeb5f27987799f96f675568187be MP+poq0l.q0+addra.w0a.w0.litmus.expected000066400000000000000000000004461475314470400326700ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64Test MP+poq0l.q0+addra.w0a.w0 Allowed States 3 1:X1=0x0; 1:X3=0x0; 1:X1=0x0; 1:X3=0x1010101; 1:X1=0x1010101; 1:X3=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x1010101 /\ 1:X3=0x0) Observation MP+poq0l.q0+addra.w0a.w0 Never 0 3 Hash=716f90e5ff1326a6dd81a4b78617eab9 MP+poq0l.q0+addra.w0a.w4.litmus.expected000066400000000000000000000004461475314470400326740ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64Test MP+poq0l.q0+addra.w0a.w4 Allowed States 3 1:X1=0x0; 1:X3=0x0; 1:X1=0x0; 1:X3=0x1010101; 1:X1=0x1010101; 1:X3=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x1010101 /\ 1:X3=0x0) Observation MP+poq0l.q0+addra.w0a.w4 Never 0 3 Hash=9a1212ee9f57eabf3deebec9d6921fc1 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/MP+poq0l.q0+addra.w0q0.litmus.expected000066400000000000000000000004621475314470400325200ustar00rootroot00000000000000Test MP+poq0l.q0+addra.w0q0 Allowed States 3 1:X1=0x0; 1:X3=0x0; 1:X1=0x0; 1:X3=0x101010101010101; 1:X1=0x1010101; 1:X3=0x101010101010101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x1010101 /\ 1:X3=0x0) Observation MP+poq0l.q0+addra.w0q0 Never 0 3 Hash=56a5440a101b852025af951ccc004f05 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/MP+poq0l.q0+addra.w0w0.litmus.expected000066400000000000000000000004421475314470400325240ustar00rootroot00000000000000Test MP+poq0l.q0+addra.w0w0 Allowed States 3 1:X1=0x0; 1:X3=0x0; 1:X1=0x0; 1:X3=0x1010101; 1:X1=0x1010101; 1:X3=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x1010101 /\ 1:X3=0x0) Observation MP+poq0l.q0+addra.w0w0 Never 0 3 Hash=dfd864dda068c223f3c7393a67edb1b9 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/MP+poq0l.q0+addra.w0w4.litmus.expected000066400000000000000000000004421475314470400325300ustar00rootroot00000000000000Test MP+poq0l.q0+addra.w0w4 Allowed States 3 1:X1=0x0; 1:X3=0x0; 1:X1=0x0; 1:X3=0x1010101; 1:X1=0x1010101; 1:X3=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x1010101 /\ 1:X3=0x0) Observation MP+poq0l.q0+addra.w0w4 Never 0 3 Hash=2c4e2990abdc84d2501faf4f112e3035 MP+poq0l.q0+addra.w4a.q0.litmus.expected000066400000000000000000000004661475314470400326700ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64Test MP+poq0l.q0+addra.w4a.q0 Allowed States 3 1:X1=0x0; 1:X4=0x0; 1:X1=0x0; 1:X4=0x101010101010101; 1:X1=0x1010101; 1:X4=0x101010101010101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x1010101 /\ 1:X4=0x0) Observation MP+poq0l.q0+addra.w4a.q0 Never 0 3 Hash=b388e7b1022fc93cccbc3714962f112d MP+poq0l.q0+addra.w4a.w0.litmus.expected000066400000000000000000000004461475314470400326740ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64Test MP+poq0l.q0+addra.w4a.w0 Allowed States 3 1:X1=0x0; 1:X4=0x0; 1:X1=0x0; 1:X4=0x1010101; 1:X1=0x1010101; 1:X4=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x1010101 /\ 1:X4=0x0) Observation MP+poq0l.q0+addra.w4a.w0 Never 0 3 Hash=9359d47a4925a54c07b6d2d3efadbba2 MP+poq0l.q0+addra.w4a.w4.litmus.expected000066400000000000000000000004461475314470400327000ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64Test MP+poq0l.q0+addra.w4a.w4 Allowed States 3 1:X1=0x0; 1:X4=0x0; 1:X1=0x0; 1:X4=0x1010101; 1:X1=0x1010101; 1:X4=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x1010101 /\ 1:X4=0x0) Observation MP+poq0l.q0+addra.w4a.w4 Never 0 3 Hash=607ef7bd4bc5dbd65c4f22370cc9de3b herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/MP+poq0l.q0+addra.w4q0.litmus.expected000066400000000000000000000004621475314470400325240ustar00rootroot00000000000000Test MP+poq0l.q0+addra.w4q0 Allowed States 3 1:X1=0x0; 1:X4=0x0; 1:X1=0x0; 1:X4=0x101010101010101; 1:X1=0x1010101; 1:X4=0x101010101010101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x1010101 /\ 1:X4=0x0) Observation MP+poq0l.q0+addra.w4q0 Never 0 3 Hash=a030aeda49ae4bd444c829f1ba25e46b herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/MP+poq0l.q0+addra.w4w0.litmus.expected000066400000000000000000000004421475314470400325300ustar00rootroot00000000000000Test MP+poq0l.q0+addra.w4w0 Allowed States 3 1:X1=0x0; 1:X4=0x0; 1:X1=0x0; 1:X4=0x1010101; 1:X1=0x1010101; 1:X4=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x1010101 /\ 1:X4=0x0) Observation MP+poq0l.q0+addra.w4w0 Never 0 3 Hash=c6e980137542f0912132cb1b1a9945c5 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/MP+poq0l.q0+addra.w4w4.litmus.expected000066400000000000000000000004421475314470400325340ustar00rootroot00000000000000Test MP+poq0l.q0+addra.w4w4 Allowed States 3 1:X1=0x0; 1:X4=0x0; 1:X1=0x0; 1:X4=0x1010101; 1:X1=0x1010101; 1:X4=0x1010101; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=0x1010101 /\ 1:X4=0x0) Observation MP+poq0l.q0+addra.w4w4 Never 0 3 Hash=d3cdaeb0db2ef8fe33b0f99e28767185 S+poq0l.q0+addra.q0l.q0.litmus.expected000066400000000000000000000005341475314470400325530ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64Test S+poq0l.q0+addra.q0l.q0 Allowed States 3 1:X1=0x0; [x]=0x101010101010101; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x101010101010101; [x]=0x101010101010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x101010101010101) Observation S+poq0l.q0+addra.q0l.q0 Never 0 3 Hash=e52525e19de0c7841cf070c32bd95e34 S+poq0l.q0+addra.q0l.w0.litmus.expected000066400000000000000000000005341475314470400325610ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64Test S+poq0l.q0+addra.q0l.w0 Allowed States 3 1:X1=0x0; [x]=0x202020201010101; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x101010101010101; [x]=0x202020201010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x101010101010101) Observation S+poq0l.q0+addra.q0l.w0 Never 0 3 Hash=7c7bb55b5dbf2138b7f9985d7d479ea8 S+poq0l.q0+addra.q0l.w4.litmus.expected000066400000000000000000000005341475314470400325650ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64Test S+poq0l.q0+addra.q0l.w4 Allowed States 3 1:X1=0x0; [x]=0x101010102020202; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x101010101010101; [x]=0x101010102020202; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x101010101010101) Observation S+poq0l.q0+addra.q0l.w4 Never 0 3 Hash=c3b3d9f9dc291ece956cb43edd5cdd98 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/S+poq0l.q0+addra.q0q0.litmus.expected000066400000000000000000000005301475314470400323740ustar00rootroot00000000000000Test S+poq0l.q0+addra.q0q0 Allowed States 3 1:X1=0x0; [x]=0x101010101010101; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x101010101010101; [x]=0x101010101010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x101010101010101) Observation S+poq0l.q0+addra.q0q0 Never 0 3 Hash=a5ac21f79d5f46486ec7f0c57d6e21de herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/S+poq0l.q0+addra.q0w0.litmus.expected000066400000000000000000000005301475314470400324020ustar00rootroot00000000000000Test S+poq0l.q0+addra.q0w0 Allowed States 3 1:X1=0x0; [x]=0x202020201010101; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x101010101010101; [x]=0x202020201010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x101010101010101) Observation S+poq0l.q0+addra.q0w0 Never 0 3 Hash=0c3d2abfed6b1ea81109da38fe8c214a herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/S+poq0l.q0+addra.q0w4.litmus.expected000066400000000000000000000005301475314470400324060ustar00rootroot00000000000000Test S+poq0l.q0+addra.q0w4 Allowed States 3 1:X1=0x0; [x]=0x101010102020202; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x101010101010101; [x]=0x101010102020202; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x101010101010101) Observation S+poq0l.q0+addra.q0w4 Never 0 3 Hash=f4c09220ed7b9b5a794227cddcdfc865 S+poq0l.q0+addra.w0l.q0.litmus.expected000066400000000000000000000005141475314470400325570ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64Test S+poq0l.q0+addra.w0l.q0 Allowed States 3 1:X1=0x0; [x]=0x101010101010101; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x1010101; [x]=0x101010101010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x1010101) Observation S+poq0l.q0+addra.w0l.q0 Never 0 3 Hash=d4b7a9f8f1d502c54a47cc0e7ff60a96 S+poq0l.q0+addra.w0l.w0.litmus.expected000066400000000000000000000005141475314470400325650ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64Test S+poq0l.q0+addra.w0l.w0 Allowed States 3 1:X1=0x0; [x]=0x202020201010101; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x1010101; [x]=0x202020201010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x1010101) Observation S+poq0l.q0+addra.w0l.w0 Never 0 3 Hash=9f427d437c33d686d2e4b7b6402bd10d S+poq0l.q0+addra.w0l.w4.litmus.expected000066400000000000000000000005141475314470400325710ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64Test S+poq0l.q0+addra.w0l.w4 Allowed States 3 1:X1=0x0; [x]=0x101010102020202; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x1010101; [x]=0x101010102020202; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x1010101) Observation S+poq0l.q0+addra.w0l.w4 Never 0 3 Hash=b25f5702f2785a928e5eb46709534cbb herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/S+poq0l.q0+addra.w0q0.litmus.expected000066400000000000000000000005101475314470400324000ustar00rootroot00000000000000Test S+poq0l.q0+addra.w0q0 Allowed States 3 1:X1=0x0; [x]=0x101010101010101; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x1010101; [x]=0x101010101010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x1010101) Observation S+poq0l.q0+addra.w0q0 Never 0 3 Hash=674eccb230f0f1a927bf26ce21f7f644 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/S+poq0l.q0+addra.w0w0.litmus.expected000066400000000000000000000005101475314470400324060ustar00rootroot00000000000000Test S+poq0l.q0+addra.w0w0 Allowed States 3 1:X1=0x0; [x]=0x202020201010101; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x1010101; [x]=0x202020201010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x1010101) Observation S+poq0l.q0+addra.w0w0 Never 0 3 Hash=9d9480490922de56ed6c0d695ef17003 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/S+poq0l.q0+addra.w0w4.litmus.expected000066400000000000000000000005101475314470400324120ustar00rootroot00000000000000Test S+poq0l.q0+addra.w0w4 Allowed States 3 1:X1=0x0; [x]=0x101010102020202; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x1010101; [x]=0x101010102020202; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x1010101) Observation S+poq0l.q0+addra.w0w4 Never 0 3 Hash=6ebe561d90486575385587f65702a9a6 S+poq0l.q0+addra.w4l.q0.litmus.expected000066400000000000000000000005141475314470400325630ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64Test S+poq0l.q0+addra.w4l.q0 Allowed States 3 1:X1=0x0; [x]=0x101010101010101; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x1010101; [x]=0x101010101010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x1010101) Observation S+poq0l.q0+addra.w4l.q0 Never 0 3 Hash=7c575e2bb2f265c6a5dc7547949fe4e3 S+poq0l.q0+addra.w4l.w0.litmus.expected000066400000000000000000000005141475314470400325710ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64Test S+poq0l.q0+addra.w4l.w0 Allowed States 3 1:X1=0x0; [x]=0x202020201010101; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x1010101; [x]=0x202020201010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x1010101) Observation S+poq0l.q0+addra.w4l.w0 Never 0 3 Hash=0d7c232985911261c36d4c6013bb763b S+poq0l.q0+addra.w4l.w4.litmus.expected000066400000000000000000000005141475314470400325750ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64Test S+poq0l.q0+addra.w4l.w4 Allowed States 3 1:X1=0x0; [x]=0x101010102020202; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x1010101; [x]=0x101010102020202; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x1010101) Observation S+poq0l.q0+addra.w4l.w4 Never 0 3 Hash=99168bb23f3fc44694a6c89509ed2454 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/S+poq0l.q0+addra.w4q0.litmus.expected000066400000000000000000000005101475314470400324040ustar00rootroot00000000000000Test S+poq0l.q0+addra.w4q0 Allowed States 3 1:X1=0x0; [x]=0x101010101010101; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x1010101; [x]=0x101010101010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x1010101) Observation S+poq0l.q0+addra.w4q0 Never 0 3 Hash=3d3867495a84616e3c472f2c8947b24c herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/S+poq0l.q0+addra.w4w0.litmus.expected000066400000000000000000000005101475314470400324120ustar00rootroot00000000000000Test S+poq0l.q0+addra.w4w0 Allowed States 3 1:X1=0x0; [x]=0x202020201010101; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x1010101; [x]=0x202020201010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x1010101) Observation S+poq0l.q0+addra.w4w0 Never 0 3 Hash=4c932bfa691e36a7d7e196afbfd34d41 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/S+poq0l.q0+addra.w4w4.litmus.expected000066400000000000000000000005101475314470400324160ustar00rootroot00000000000000Test S+poq0l.q0+addra.w4w4 Allowed States 3 1:X1=0x0; [x]=0x101010102020202; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x1010101; [x]=0x101010102020202; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x1010101) Observation S+poq0l.q0+addra.w4w4 Never 0 3 Hash=2dca01a3017b63cfcf5ce9eb1a0ab6d3 S+poq0l.q0+dataa.q0l.q0.litmus.expected000066400000000000000000000005341475314470400325520ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64Test S+poq0l.q0+dataa.q0l.q0 Allowed States 3 1:X1=0x0; [x]=0x101010101010101; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x101010101010101; [x]=0x101010101010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x101010101010101) Observation S+poq0l.q0+dataa.q0l.q0 Never 0 3 Hash=f865fde5c559ca6fcca85828216562c0 S+poq0l.q0+dataa.q0l.w0.litmus.expected000066400000000000000000000005341475314470400325600ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64Test S+poq0l.q0+dataa.q0l.w0 Allowed States 3 1:X1=0x0; [x]=0x202020201010101; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x101010101010101; [x]=0x202020201010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x101010101010101) Observation S+poq0l.q0+dataa.q0l.w0 Never 0 3 Hash=ca5496fa8fdf52c580a3456f7390d261 S+poq0l.q0+dataa.q0l.w4.litmus.expected000066400000000000000000000005341475314470400325640ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64Test S+poq0l.q0+dataa.q0l.w4 Allowed States 3 1:X1=0x0; [x]=0x101010102020202; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x101010101010101; [x]=0x101010102020202; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x101010101010101) Observation S+poq0l.q0+dataa.q0l.w4 Never 0 3 Hash=d7cca9502887edd99a40a13a10bed9c7 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/S+poq0l.q0+dataa.q0q0.litmus.expected000066400000000000000000000005301475314470400323730ustar00rootroot00000000000000Test S+poq0l.q0+dataa.q0q0 Allowed States 3 1:X1=0x0; [x]=0x101010101010101; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x101010101010101; [x]=0x101010101010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x101010101010101) Observation S+poq0l.q0+dataa.q0q0 Never 0 3 Hash=e8de8adb0e2c0e3e803619d655124781 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/S+poq0l.q0+dataa.q0w0.litmus.expected000066400000000000000000000005301475314470400324010ustar00rootroot00000000000000Test S+poq0l.q0+dataa.q0w0 Allowed States 3 1:X1=0x0; [x]=0x202020201010101; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x101010101010101; [x]=0x202020201010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x101010101010101) Observation S+poq0l.q0+dataa.q0w0 Never 0 3 Hash=12061da7f38ee5834d7532db78ee1c61 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/S+poq0l.q0+dataa.q0w4.litmus.expected000066400000000000000000000005301475314470400324050ustar00rootroot00000000000000Test S+poq0l.q0+dataa.q0w4 Allowed States 3 1:X1=0x0; [x]=0x101010102020202; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x101010101010101; [x]=0x101010102020202; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x101010101010101) Observation S+poq0l.q0+dataa.q0w4 Never 0 3 Hash=60b1cf50dd7fd91c0e9e2282c324f8f5 S+poq0l.q0+dataa.w0l.q0.litmus.expected000066400000000000000000000005141475314470400325560ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64Test S+poq0l.q0+dataa.w0l.q0 Allowed States 3 1:X1=0x0; [x]=0x101010101010101; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x1010101; [x]=0x101010101010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x1010101) Observation S+poq0l.q0+dataa.w0l.q0 Never 0 3 Hash=252eb6a87976c24086b9d882bb0487cc S+poq0l.q0+dataa.w0l.w0.litmus.expected000066400000000000000000000005141475314470400325640ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64Test S+poq0l.q0+dataa.w0l.w0 Allowed States 3 1:X1=0x0; [x]=0x202020201010101; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x1010101; [x]=0x202020201010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x1010101) Observation S+poq0l.q0+dataa.w0l.w0 Never 0 3 Hash=a573ed5bc193d5ef11224455c72b985d S+poq0l.q0+dataa.w0l.w4.litmus.expected000066400000000000000000000005141475314470400325700ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64Test S+poq0l.q0+dataa.w0l.w4 Allowed States 3 1:X1=0x0; [x]=0x101010102020202; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x1010101; [x]=0x101010102020202; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x1010101) Observation S+poq0l.q0+dataa.w0l.w4 Never 0 3 Hash=f82ede56f7e928badd245f3389054b35 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/S+poq0l.q0+dataa.w0q0.litmus.expected000066400000000000000000000005101475314470400323770ustar00rootroot00000000000000Test S+poq0l.q0+dataa.w0q0 Allowed States 3 1:X1=0x0; [x]=0x101010101010101; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x1010101; [x]=0x101010101010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x1010101) Observation S+poq0l.q0+dataa.w0q0 Never 0 3 Hash=4e73661fd824bd869bf67e98ce043b30 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/S+poq0l.q0+dataa.w0w0.litmus.expected000066400000000000000000000005101475314470400324050ustar00rootroot00000000000000Test S+poq0l.q0+dataa.w0w0 Allowed States 3 1:X1=0x0; [x]=0x202020201010101; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x1010101; [x]=0x202020201010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x1010101) Observation S+poq0l.q0+dataa.w0w0 Never 0 3 Hash=bc58189978c4c511d372375555fa8c03 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/S+poq0l.q0+dataa.w0w4.litmus.expected000066400000000000000000000005101475314470400324110ustar00rootroot00000000000000Test S+poq0l.q0+dataa.w0w4 Allowed States 3 1:X1=0x0; [x]=0x101010102020202; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x1010101; [x]=0x101010102020202; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x1010101) Observation S+poq0l.q0+dataa.w0w4 Never 0 3 Hash=3165ae4824098a75ec1f377f2954cdfa S+poq0l.q0+dataa.w4l.q0.litmus.expected000066400000000000000000000005141475314470400325620ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64Test S+poq0l.q0+dataa.w4l.q0 Allowed States 3 1:X1=0x0; [x]=0x101010101010101; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x1010101; [x]=0x101010101010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x1010101) Observation S+poq0l.q0+dataa.w4l.q0 Never 0 3 Hash=7b186adc7154dd5b42ba934c9a48d8a6 S+poq0l.q0+dataa.w4l.w0.litmus.expected000066400000000000000000000005141475314470400325700ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64Test S+poq0l.q0+dataa.w4l.w0 Allowed States 3 1:X1=0x0; [x]=0x202020201010101; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x1010101; [x]=0x202020201010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x1010101) Observation S+poq0l.q0+dataa.w4l.w0 Never 0 3 Hash=2d64a0d1a9a6cb088fadc37450958bdb S+poq0l.q0+dataa.w4l.w4.litmus.expected000066400000000000000000000005141475314470400325740ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64Test S+poq0l.q0+dataa.w4l.w4 Allowed States 3 1:X1=0x0; [x]=0x101010102020202; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x1010101; [x]=0x101010102020202; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x1010101) Observation S+poq0l.q0+dataa.w4l.w4 Never 0 3 Hash=11e47efbc01fe6973eb2ad9b33eb646b herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/S+poq0l.q0+dataa.w4q0.litmus.expected000066400000000000000000000005101475314470400324030ustar00rootroot00000000000000Test S+poq0l.q0+dataa.w4q0 Allowed States 3 1:X1=0x0; [x]=0x101010101010101; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x1010101; [x]=0x101010101010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x1010101) Observation S+poq0l.q0+dataa.w4q0 Never 0 3 Hash=6795b240af17854f8399b403bc88d1e8 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/S+poq0l.q0+dataa.w4w0.litmus.expected000066400000000000000000000005101475314470400324110ustar00rootroot00000000000000Test S+poq0l.q0+dataa.w4w0 Allowed States 3 1:X1=0x0; [x]=0x202020201010101; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x1010101; [x]=0x202020201010101; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x1010101) Observation S+poq0l.q0+dataa.w4w0 Never 0 3 Hash=e0f37df8080301fd5839189a9f9e29ca herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed.v64/S+poq0l.q0+dataa.w4w4.litmus.expected000066400000000000000000000005101475314470400324150ustar00rootroot00000000000000Test S+poq0l.q0+dataa.w4w4 Allowed States 3 1:X1=0x0; [x]=0x101010102020202; 1:X1=0x0; [x]=0x202020202020202; 1:X1=0x1010101; [x]=0x101010102020202; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=0x202020202020202 /\ 1:X1=0x1010101) Observation S+poq0l.q0+dataa.w4w4 Never 0 3 Hash=bc2a58ed254c2ad84705e671b19d80e7 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/000077500000000000000000000000001475314470400233225ustar00rootroot000000000000006e05f8a017e91d2028e6329c962deacfa8f3f979.paxheader00006660000000000000000000000253147531447040020552xustar00rootroot00000000000000171 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+amo.cash0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.cash2h2-poh2w0.litmus.expected 6e05f8a017e91d2028e6329c962deacfa8f3f979.data000066400000000000000000000017311475314470400174120ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+amo.cash0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.cash2h2-poh2w0 Allowed States 8 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x3030303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x3030303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; Ok Witnesses Positive: 4 Negative: 28 Condition exists ([y]=0x3030303 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X1=0x0 /\ 1:X4=0x202 /\ 1:X7=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+amo.cash0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.cash2h2-poh2w0 Sometimes 4 28 Hash=e5533e40eea441f80bf2c4513e209bba 9152962fe38877eda178f31037b6f690a6f44a59.paxheader00006660000000000000000000000255147531447040020262xustar00rootroot00000000000000173 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+amo.cash0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldaddh2h2-poh2w0.litmus.expected 9152962fe38877eda178f31037b6f690a6f44a59.data000066400000000000000000000017351475314470400171240ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+amo.cash0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldaddh2h2-poh2w0 Allowed States 8 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x5050303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x5050303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x5050303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x5050303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x5050303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x5050303; 0:X1=0x0; 0:X3=0x5050303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x5050303; 0:X1=0x0; 0:X3=0x5050303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x5050303; Ok Witnesses Positive: 2 Negative: 14 Condition exists ([y]=0x5050303 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X1=0x0 /\ 1:X4=0x202 /\ 1:X7=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+amo.cash0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldaddh2h2-poh2w0 Sometimes 2 14 Hash=016d429d4e57100dbd868f1beb645c16 8e902c89fdcc0716381b20cc10f5e500de5b0983.paxheader00006660000000000000000000000255147531447040020437xustar00rootroot00000000000000173 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+amo.cash0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldclrh2h2-poh2w0.litmus.expected 8e902c89fdcc0716381b20cc10f5e500de5b0983.data000066400000000000000000000016611475314470400172770ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+amo.cash0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldclrh2h2-poh2w0 Allowed States 8 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x303; 0:X1=0x0; 0:X3=0x303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x303; 0:X1=0x0; 0:X3=0x303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x303; Ok Witnesses Positive: 2 Negative: 14 Condition exists ([y]=0x303 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X1=0x0 /\ 1:X4=0x202 /\ 1:X7=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+amo.cash0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldclrh2h2-poh2w0 Sometimes 2 14 Hash=6421a0178c732d8800708e9a89ae40c9 8b55d694790879afd2b61e05a9b6f48144d23a67.paxheader00006660000000000000000000000255147531447040020334xustar00rootroot00000000000000173 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+amo.cash0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldeorh2h2-poh2w0.litmus.expected 8b55d694790879afd2b61e05a9b6f48144d23a67.data000066400000000000000000000017351475314470400171760ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+amo.cash0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldeorh2h2-poh2w0 Allowed States 8 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x1010303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x1010303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x1010303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x1010303; 0:X1=0x0; 0:X3=0x1010303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x1010303; 0:X1=0x0; 0:X3=0x1010303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x1010303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x1010303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x1010303; Ok Witnesses Positive: 2 Negative: 14 Condition exists ([y]=0x1010303 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X1=0x0 /\ 1:X4=0x202 /\ 1:X7=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+amo.cash0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldeorh2h2-poh2w0 Sometimes 2 14 Hash=2d32e2719decefacb88ec36c2d478dd6 999492f0502fed54ba1ec4d665bb454cb36424c0.paxheader00006660000000000000000000000255147531447040020445xustar00rootroot00000000000000173 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+amo.cash0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldseth2h2-poh2w0.litmus.expected 999492f0502fed54ba1ec4d665bb454cb36424c0.data000066400000000000000000000017351475314470400173070ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+amo.cash0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldseth2h2-poh2w0 Allowed States 8 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x3030303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x3030303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; Ok Witnesses Positive: 2 Negative: 14 Condition exists ([y]=0x3030303 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X1=0x0 /\ 1:X4=0x202 /\ 1:X7=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+amo.cash0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldseth2h2-poh2w0 Sometimes 2 14 Hash=99d179980b1d3ffec9fe15ddf2b73b1e 93003d436da1d66f0c3225005e967fc50c381f02.paxheader00006660000000000000000000000255147531447040020205xustar00rootroot00000000000000173 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+amo.ldaddh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.cash2h2-poh2w0.litmus.expected 93003d436da1d66f0c3225005e967fc50c381f02.data000066400000000000000000000017351475314470400170470ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+amo.ldaddh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.cash2h2-poh2w0 Allowed States 8 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x3030303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x3030303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; Ok Witnesses Positive: 2 Negative: 14 Condition exists ([y]=0x3030303 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X1=0x0 /\ 1:X4=0x202 /\ 1:X7=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+amo.ldaddh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.cash2h2-poh2w0 Sometimes 2 14 Hash=c54d948abf5930dcbe86bc4142753aff 09344771b2d46018766e8d32ef91f3e6244e26c2.paxheader00006660000000000000000000000257147531447040020163xustar00rootroot00000000000000175 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+amo.ldaddh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldaddh2h2-poh2w0.litmus.expected 09344771b2d46018766e8d32ef91f3e6244e26c2.data000066400000000000000000000017371475314470400170250ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+amo.ldaddh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldaddh2h2-poh2w0 Allowed States 8 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x5050303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x5050303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x5050303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x5050303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x5050303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x5050303; 0:X1=0x0; 0:X3=0x5050303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x5050303; 0:X1=0x0; 0:X3=0x5050303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x5050303; Ok Witnesses Positive: 1 Negative: 7 Condition exists ([y]=0x5050303 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X1=0x0 /\ 1:X4=0x202 /\ 1:X7=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+amo.ldaddh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldaddh2h2-poh2w0 Sometimes 1 7 Hash=470bfc908e25f77c861cd1298b20d9ad 12d6cb839f06aa2d6103c7d66fb38bcb9aecfa9e.paxheader00006660000000000000000000000257147531447040021106xustar00rootroot00000000000000175 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+amo.ldaddh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldclrh2h2-poh2w0.litmus.expected 12d6cb839f06aa2d6103c7d66fb38bcb9aecfa9e.data000066400000000000000000000016631475314470400177460ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+amo.ldaddh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldclrh2h2-poh2w0 Allowed States 8 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x303; 0:X1=0x0; 0:X3=0x303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x303; 0:X1=0x0; 0:X3=0x303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x303; Ok Witnesses Positive: 1 Negative: 7 Condition exists ([y]=0x303 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X1=0x0 /\ 1:X4=0x202 /\ 1:X7=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+amo.ldaddh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldclrh2h2-poh2w0 Sometimes 1 7 Hash=8417ea2188865d550e7c41197fa7be5c e50fde01c25ace1ba9e2b45074c5f475bb317879.paxheader00006660000000000000000000000257147531447040020603xustar00rootroot00000000000000175 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+amo.ldaddh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldeorh2h2-poh2w0.litmus.expected e50fde01c25ace1ba9e2b45074c5f475bb317879.data000066400000000000000000000017371475314470400174450ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+amo.ldaddh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldeorh2h2-poh2w0 Allowed States 8 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x1010303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x1010303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x1010303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x1010303; 0:X1=0x0; 0:X3=0x1010303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x1010303; 0:X1=0x0; 0:X3=0x1010303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x1010303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x1010303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x1010303; Ok Witnesses Positive: 1 Negative: 7 Condition exists ([y]=0x1010303 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X1=0x0 /\ 1:X4=0x202 /\ 1:X7=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+amo.ldaddh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldeorh2h2-poh2w0 Sometimes 1 7 Hash=0180ea90e0087fb7bcf545da8d49058c ff2364bfd70e291ae530aee99e40d0eec9e80371.paxheader00006660000000000000000000000257147531447040020674xustar00rootroot00000000000000175 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+amo.ldaddh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldseth2h2-poh2w0.litmus.expected ff2364bfd70e291ae530aee99e40d0eec9e80371.data000066400000000000000000000017371475314470400175360ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+amo.ldaddh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldseth2h2-poh2w0 Allowed States 8 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x3030303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x3030303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; Ok Witnesses Positive: 1 Negative: 7 Condition exists ([y]=0x3030303 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X1=0x0 /\ 1:X4=0x202 /\ 1:X7=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+amo.ldaddh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldseth2h2-poh2w0 Sometimes 1 7 Hash=bf481e989d27dcd111a1fc9fcc49e346 62fb4dcc399ab2f31fd3d6c6f818467b24788f53.paxheader00006660000000000000000000000255147531447040020554xustar00rootroot00000000000000173 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+amo.ldclrh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.cash2h2-poh2w0.litmus.expected 62fb4dcc399ab2f31fd3d6c6f818467b24788f53.data000066400000000000000000000015151475314470400174120ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+amo.ldclrh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.cash2h2-poh2w0 Allowed States 6 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030202; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030202; 0:X1=0x0; 0:X3=0x2020202; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030202; 0:X1=0x0; 0:X3=0x2020202; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030202; 0:X1=0x0; 0:X3=0x3030202; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030202; 0:X1=0x0; 0:X3=0x3030202; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030202; Ok Witnesses Positive: 4 Negative: 12 Condition exists ([y]=0x3030202 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X1=0x0 /\ 1:X4=0x202 /\ 1:X7=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+amo.ldclrh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.cash2h2-poh2w0 Sometimes 4 12 Hash=0a85d394b286c36d20c563878fffa5b4 07cfaae83d2b21a4fbe37790bda78a4971afbad6.paxheader00006660000000000000000000000257147531447040021100xustar00rootroot00000000000000175 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+amo.ldclrh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldaddh2h2-poh2w0.litmus.expected 07cfaae83d2b21a4fbe37790bda78a4971afbad6.data000066400000000000000000000015171475314470400177360ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+amo.ldclrh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldaddh2h2-poh2w0 Allowed States 6 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x5050202; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x5050202; 0:X1=0x0; 0:X3=0x2020202; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x5050202; 0:X1=0x0; 0:X3=0x2020202; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x5050202; 0:X1=0x0; 0:X3=0x5050202; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x5050202; 0:X1=0x0; 0:X3=0x5050202; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x5050202; Ok Witnesses Positive: 2 Negative: 6 Condition exists ([y]=0x5050202 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X1=0x0 /\ 1:X4=0x202 /\ 1:X7=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+amo.ldclrh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldaddh2h2-poh2w0 Sometimes 2 6 Hash=9b64ed5f3ac2115f14954647f8040024 cb676d40656274c2342af5526f931963a34db860.paxheader00006660000000000000000000000257147531447040020155xustar00rootroot00000000000000175 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+amo.ldclrh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldclrh2h2-poh2w0.litmus.expected cb676d40656274c2342af5526f931963a34db860.data000066400000000000000000000014531475314470400170120ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+amo.ldclrh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldclrh2h2-poh2w0 Allowed States 6 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x202; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x202; 0:X1=0x0; 0:X3=0x202; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x202; 0:X1=0x0; 0:X3=0x202; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x202; 0:X1=0x0; 0:X3=0x2020202; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x202; 0:X1=0x0; 0:X3=0x2020202; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x202; Ok Witnesses Positive: 2 Negative: 6 Condition exists ([y]=0x202 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X1=0x0 /\ 1:X4=0x202 /\ 1:X7=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+amo.ldclrh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldclrh2h2-poh2w0 Sometimes 2 6 Hash=9f60969ee4761bf3657901c328d99a82 dbc59ff9b1eb86f68ce32dfcc384c403df348710.paxheader00006660000000000000000000000257147531447040020766xustar00rootroot00000000000000175 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+amo.ldclrh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldeorh2h2-poh2w0.litmus.expected dbc59ff9b1eb86f68ce32dfcc384c403df348710.data000066400000000000000000000015171475314470400176240ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+amo.ldclrh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldeorh2h2-poh2w0 Allowed States 6 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x1010202; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x1010202; 0:X1=0x0; 0:X3=0x1010202; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x1010202; 0:X1=0x0; 0:X3=0x1010202; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x1010202; 0:X1=0x0; 0:X3=0x2020202; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x1010202; 0:X1=0x0; 0:X3=0x2020202; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x1010202; Ok Witnesses Positive: 2 Negative: 6 Condition exists ([y]=0x1010202 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X1=0x0 /\ 1:X4=0x202 /\ 1:X7=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+amo.ldclrh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldeorh2h2-poh2w0 Sometimes 2 6 Hash=b9d95dea6e91842dc42b616f8d3c6111 fdffd63c0f27d6e7a03cff994812a8eba9c87831.paxheader00006660000000000000000000000257147531447040020776xustar00rootroot00000000000000175 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+amo.ldclrh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldseth2h2-poh2w0.litmus.expected fdffd63c0f27d6e7a03cff994812a8eba9c87831.data000066400000000000000000000015171475314470400176340ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+amo.ldclrh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldseth2h2-poh2w0 Allowed States 6 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030202; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030202; 0:X1=0x0; 0:X3=0x2020202; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030202; 0:X1=0x0; 0:X3=0x2020202; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030202; 0:X1=0x0; 0:X3=0x3030202; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030202; 0:X1=0x0; 0:X3=0x3030202; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030202; Ok Witnesses Positive: 2 Negative: 6 Condition exists ([y]=0x3030202 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X1=0x0 /\ 1:X4=0x202 /\ 1:X7=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+amo.ldclrh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldseth2h2-poh2w0 Sometimes 2 6 Hash=73341d186d9dc6aa0b7eef1643eb9c24 e281f3580178ef1e462fcc49d4c9575bd942b106.paxheader00006660000000000000000000000255147531447040020404xustar00rootroot00000000000000173 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+amo.ldeorh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.cash2h2-poh2w0.litmus.expected e281f3580178ef1e462fcc49d4c9575bd942b106.data000066400000000000000000000017351475314470400172460ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+amo.ldeorh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.cash2h2-poh2w0 Allowed States 8 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x3030303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x3030303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; Ok Witnesses Positive: 2 Negative: 14 Condition exists ([y]=0x3030303 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X1=0x0 /\ 1:X4=0x202 /\ 1:X7=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+amo.ldeorh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.cash2h2-poh2w0 Sometimes 2 14 Hash=75d826526eda76443e756504e0b39b06 8ecf0217e499a70c61d8b77ea6801b23c2b06089.paxheader00006660000000000000000000000257147531447040020372xustar00rootroot00000000000000175 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+amo.ldeorh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldaddh2h2-poh2w0.litmus.expected 8ecf0217e499a70c61d8b77ea6801b23c2b06089.data000066400000000000000000000017371475314470400172340ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+amo.ldeorh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldaddh2h2-poh2w0 Allowed States 8 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x5050303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x5050303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x5050303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x5050303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x5050303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x5050303; 0:X1=0x0; 0:X3=0x5050303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x5050303; 0:X1=0x0; 0:X3=0x5050303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x5050303; Ok Witnesses Positive: 1 Negative: 7 Condition exists ([y]=0x5050303 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X1=0x0 /\ 1:X4=0x202 /\ 1:X7=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+amo.ldeorh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldaddh2h2-poh2w0 Sometimes 1 7 Hash=219aee1d9c84878520026218902604a0 9c2bb4419b9afacafc073ff8ea4ca3d2c8911aa8.paxheader00006660000000000000000000000257147531447040021160xustar00rootroot00000000000000175 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+amo.ldeorh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldclrh2h2-poh2w0.litmus.expected 9c2bb4419b9afacafc073ff8ea4ca3d2c8911aa8.data000066400000000000000000000016631475314470400200200ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+amo.ldeorh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldclrh2h2-poh2w0 Allowed States 8 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x303; 0:X1=0x0; 0:X3=0x303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x303; 0:X1=0x0; 0:X3=0x303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x303; Ok Witnesses Positive: 1 Negative: 7 Condition exists ([y]=0x303 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X1=0x0 /\ 1:X4=0x202 /\ 1:X7=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+amo.ldeorh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldclrh2h2-poh2w0 Sometimes 1 7 Hash=77e9d1fca9d523e08eddffecc225e13c ad7c0f20a6c44f071f7e98daec8921d3091bedf9.paxheader00006660000000000000000000000257147531447040020755xustar00rootroot00000000000000175 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+amo.ldeorh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldeorh2h2-poh2w0.litmus.expected ad7c0f20a6c44f071f7e98daec8921d3091bedf9.data000066400000000000000000000017371475314470400176170ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+amo.ldeorh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldeorh2h2-poh2w0 Allowed States 8 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x1010303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x1010303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x1010303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x1010303; 0:X1=0x0; 0:X3=0x1010303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x1010303; 0:X1=0x0; 0:X3=0x1010303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x1010303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x1010303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x1010303; Ok Witnesses Positive: 1 Negative: 7 Condition exists ([y]=0x1010303 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X1=0x0 /\ 1:X4=0x202 /\ 1:X7=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+amo.ldeorh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldeorh2h2-poh2w0 Sometimes 1 7 Hash=a96c6ed5b0f41298537bfdee5d75eec7 7a13ee7b4887ae442d502e53fb3902be09cf590c.paxheader00006660000000000000000000000257147531447040020531xustar00rootroot00000000000000175 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+amo.ldeorh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldseth2h2-poh2w0.litmus.expected 7a13ee7b4887ae442d502e53fb3902be09cf590c.data000066400000000000000000000017371475314470400173730ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+amo.ldeorh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldseth2h2-poh2w0 Allowed States 8 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x3030303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x3030303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; Ok Witnesses Positive: 1 Negative: 7 Condition exists ([y]=0x3030303 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X1=0x0 /\ 1:X4=0x202 /\ 1:X7=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+amo.ldeorh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldseth2h2-poh2w0 Sometimes 1 7 Hash=1f4738a7086fe13180bb2dcb3983be8e de369ffecdb973814e958be9be93a44a04db1ddb.paxheader00006660000000000000000000000255147531447040021127xustar00rootroot00000000000000173 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+amo.ldseth0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.cash2h2-poh2w0.litmus.expected de369ffecdb973814e958be9be93a44a04db1ddb.data000066400000000000000000000017351475314470400177710ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+amo.ldseth0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.cash2h2-poh2w0 Allowed States 8 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x3030303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x3030303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; Ok Witnesses Positive: 2 Negative: 14 Condition exists ([y]=0x3030303 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X1=0x0 /\ 1:X4=0x202 /\ 1:X7=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+amo.ldseth0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.cash2h2-poh2w0 Sometimes 2 14 Hash=f97e329187de5a3598bda40f6d1a5a4a fc8593ccdf803221637f673636a34091e3a6ead4.paxheader00006660000000000000000000000257147531447040020375xustar00rootroot00000000000000175 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+amo.ldseth0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldaddh2h2-poh2w0.litmus.expected fc8593ccdf803221637f673636a34091e3a6ead4.data000066400000000000000000000017371475314470400172370ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+amo.ldseth0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldaddh2h2-poh2w0 Allowed States 8 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x5050303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x5050303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x5050303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x5050303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x5050303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x5050303; 0:X1=0x0; 0:X3=0x5050303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x5050303; 0:X1=0x0; 0:X3=0x5050303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x5050303; Ok Witnesses Positive: 1 Negative: 7 Condition exists ([y]=0x5050303 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X1=0x0 /\ 1:X4=0x202 /\ 1:X7=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+amo.ldseth0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldaddh2h2-poh2w0 Sometimes 1 7 Hash=f95ae27bb711ad6fe1387080260459ab d4a99943e9505383ed0a2de51da6ee86a21e099a.paxheader00006660000000000000000000000257147531447040020542xustar00rootroot00000000000000175 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+amo.ldseth0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldclrh2h2-poh2w0.litmus.expected d4a99943e9505383ed0a2de51da6ee86a21e099a.data000066400000000000000000000016631475314470400174020ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+amo.ldseth0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldclrh2h2-poh2w0 Allowed States 8 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x303; 0:X1=0x0; 0:X3=0x303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x303; 0:X1=0x0; 0:X3=0x303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x303; Ok Witnesses Positive: 1 Negative: 7 Condition exists ([y]=0x303 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X1=0x0 /\ 1:X4=0x202 /\ 1:X7=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+amo.ldseth0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldclrh2h2-poh2w0 Sometimes 1 7 Hash=b500f3d55942d3d408568573c7f4b0ab 448cb752a961ea5c053f5136b425f0607f4bd15b.paxheader00006660000000000000000000000257147531447040020356xustar00rootroot00000000000000175 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+amo.ldseth0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldeorh2h2-poh2w0.litmus.expected 448cb752a961ea5c053f5136b425f0607f4bd15b.data000066400000000000000000000017371475314470400172200ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+amo.ldseth0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldeorh2h2-poh2w0 Allowed States 8 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x1010303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x1010303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x1010303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x1010303; 0:X1=0x0; 0:X3=0x1010303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x1010303; 0:X1=0x0; 0:X3=0x1010303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x1010303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x1010303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x1010303; Ok Witnesses Positive: 1 Negative: 7 Condition exists ([y]=0x1010303 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X1=0x0 /\ 1:X4=0x202 /\ 1:X7=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+amo.ldseth0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldeorh2h2-poh2w0 Sometimes 1 7 Hash=58d357ae3364f20884b118abef6c97c2 a4ec42aca8edc2880100f041422eba17b0849462.paxheader00006660000000000000000000000257147531447040020414xustar00rootroot00000000000000175 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+amo.ldseth0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldseth2h2-poh2w0.litmus.expected a4ec42aca8edc2880100f041422eba17b0849462.data000066400000000000000000000017371475314470400172560ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+amo.ldseth0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldseth2h2-poh2w0 Allowed States 8 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x3030303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x3030303; 1:X1=0x0; 1:X4=0x202; 1:X7=0x1010101; [y]=0x3030303; Ok Witnesses Positive: 1 Negative: 7 Condition exists ([y]=0x3030303 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X1=0x0 /\ 1:X4=0x202 /\ 1:X7=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+amo.ldseth0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldseth2h2-poh2w0 Sometimes 1 7 Hash=f2b611d2a0aef6e2b11015db4a12baf5 RR+RR+amo.ldsetw0w0-pow0w0+rmwh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.cash2h2-poh2w0.litmus.expected000066400000000000000000000030461475314470400444240ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixedTest RR+RR+amo.ldsetw0w0-pow0w0+rmwh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.cash2h2-poh2w0 Allowed States 14 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x0; [y]=0x3030202; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x1010101; [y]=0x3030202; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x2020202; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x0; [y]=0x3030202; 0:X1=0x0; 0:X3=0x2020202; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x1010101; [y]=0x3030202; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x3030202; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x0; [y]=0x3030202; 0:X1=0x0; 0:X3=0x3030202; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x1010101; [y]=0x3030202; 0:X1=0x0; 0:X3=0x3030303; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x3030303; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x1010101; [y]=0x3030303; Ok Witnesses Positive: 2 Negative: 26 Condition exists ([y]=0x3030303 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X3=0x0 /\ 1:X1=0x0 /\ 1:X5=0x202 /\ 1:X8=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+rmwh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.cash2h2-poh2w0 Sometimes 2 26 Hash=c6a1aff6350811ed74fa89bd3a085b78 b38c505c86098f7d4b9d03520699e23c79f7c924.paxheader00006660000000000000000000000251147531447040020257xustar00rootroot00000000000000169 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+rmwh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldaddh2h2-poh2w0.litmus.expected b38c505c86098f7d4b9d03520699e23c79f7c924.data000066400000000000000000000030521475314470400171170ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+rmwh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldaddh2h2-poh2w0 Allowed States 14 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x0; [y]=0x5050303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x1010101; [y]=0x5050303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x0; [y]=0x5050202; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x1010101; [y]=0x5050202; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x0; [y]=0x5050303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x1010101; [y]=0x5050303; 0:X1=0x0; 0:X3=0x2020202; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x0; [y]=0x5050202; 0:X1=0x0; 0:X3=0x2020202; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x1010101; [y]=0x5050202; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x0; [y]=0x5050303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x1010101; [y]=0x5050303; 0:X1=0x0; 0:X3=0x5050202; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x0; [y]=0x5050202; 0:X1=0x0; 0:X3=0x5050202; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x1010101; [y]=0x5050202; 0:X1=0x0; 0:X3=0x5050303; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x0; [y]=0x5050303; 0:X1=0x0; 0:X3=0x5050303; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x1010101; [y]=0x5050303; Ok Witnesses Positive: 1 Negative: 13 Condition exists ([y]=0x5050303 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X3=0x0 /\ 1:X1=0x0 /\ 1:X5=0x202 /\ 1:X8=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+rmwh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldaddh2h2-poh2w0 Sometimes 1 13 Hash=5212a612c0cd38b9b70803f84782c412 d433f219287babffda950f2ed95cceee362b52d9.paxheader00006660000000000000000000000251147531447040021033xustar00rootroot00000000000000169 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+rmwh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldclrh2h2-poh2w0.litmus.expected d433f219287babffda950f2ed95cceee362b52d9.data000066400000000000000000000027361475314470400177030ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+rmwh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldclrh2h2-poh2w0 Allowed States 14 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x0; [y]=0x303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x1010101; [y]=0x303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x0; [y]=0x202; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x1010101; [y]=0x202; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x0; [y]=0x303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x1010101; [y]=0x303; 0:X1=0x0; 0:X3=0x202; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x0; [y]=0x202; 0:X1=0x0; 0:X3=0x202; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x1010101; [y]=0x202; 0:X1=0x0; 0:X3=0x303; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x0; [y]=0x303; 0:X1=0x0; 0:X3=0x303; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x1010101; [y]=0x303; 0:X1=0x0; 0:X3=0x2020202; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x0; [y]=0x202; 0:X1=0x0; 0:X3=0x2020202; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x1010101; [y]=0x202; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x0; [y]=0x303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x1010101; [y]=0x303; Ok Witnesses Positive: 1 Negative: 13 Condition exists ([y]=0x303 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X3=0x0 /\ 1:X1=0x0 /\ 1:X5=0x202 /\ 1:X8=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+rmwh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldclrh2h2-poh2w0 Sometimes 1 13 Hash=f81de79e3e08868ad968f82155d2fc02 3cc9024fed302c8857aaee24d3c63ae16b5f2730.paxheader00006660000000000000000000000251147531447040020567xustar00rootroot00000000000000169 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+rmwh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldeorh2h2-poh2w0.litmus.expected 3cc9024fed302c8857aaee24d3c63ae16b5f2730.data000066400000000000000000000030521475314470400174270ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+rmwh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldeorh2h2-poh2w0 Allowed States 14 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x0; [y]=0x1010303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x1010101; [y]=0x1010303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x0; [y]=0x1010202; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x1010101; [y]=0x1010202; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x0; [y]=0x1010303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x1010101; [y]=0x1010303; 0:X1=0x0; 0:X3=0x1010202; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x0; [y]=0x1010202; 0:X1=0x0; 0:X3=0x1010202; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x1010101; [y]=0x1010202; 0:X1=0x0; 0:X3=0x1010303; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x0; [y]=0x1010303; 0:X1=0x0; 0:X3=0x1010303; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x1010101; [y]=0x1010303; 0:X1=0x0; 0:X3=0x2020202; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x0; [y]=0x1010202; 0:X1=0x0; 0:X3=0x2020202; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x1010101; [y]=0x1010202; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x0; [y]=0x1010303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x1010101; [y]=0x1010303; Ok Witnesses Positive: 1 Negative: 13 Condition exists ([y]=0x1010303 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X3=0x0 /\ 1:X1=0x0 /\ 1:X5=0x202 /\ 1:X8=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+rmwh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldeorh2h2-poh2w0 Sometimes 1 13 Hash=6fb9a1713b31744f0b45a632066126d8 068b31d7c97dfe038357fdd4c32c151fb996d37f.paxheader00006660000000000000000000000251147531447040020544xustar00rootroot00000000000000169 path=herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/RR+RR+amo.ldsetw0w0-pow0w0+rmwh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldseth2h2-poh2w0.litmus.expected 068b31d7c97dfe038357fdd4c32c151fb996d37f.data000066400000000000000000000030521475314470400174040ustar00rootroot00000000000000Test RR+RR+amo.ldsetw0w0-pow0w0+rmwh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldseth2h2-poh2w0 Allowed States 14 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x0; [y]=0x3030202; 0:X1=0x0; 0:X3=0x0; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x1010101; [y]=0x3030202; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x101; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x2020202; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x0; [y]=0x3030202; 0:X1=0x0; 0:X3=0x2020202; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x1010101; [y]=0x3030202; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x2020303; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x1010101; [y]=0x3030303; 0:X1=0x0; 0:X3=0x3030202; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x0; [y]=0x3030202; 0:X1=0x0; 0:X3=0x3030202; 1:X1=0x0; 1:X3=0x1; 1:X5=0x202; 1:X8=0x1010101; [y]=0x3030202; 0:X1=0x0; 0:X3=0x3030303; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x0; [y]=0x3030303; 0:X1=0x0; 0:X3=0x3030303; 1:X1=0x0; 1:X3=0x0; 1:X5=0x202; 1:X8=0x1010101; [y]=0x3030303; Ok Witnesses Positive: 1 Negative: 13 Condition exists ([y]=0x3030303 /\ 0:X1=0x0 /\ 0:X3=0x0 /\ 1:X3=0x0 /\ 1:X1=0x0 /\ 1:X5=0x202 /\ 1:X8=0x0) Observation RR+RR+amo.ldsetw0w0-pow0w0+rmwh0h0-rfih0w0-amo.staddw0w0-rfiw0h2-amo.ldseth2h2-poh2w0 Sometimes 1 13 Hash=c435428406ad6d3243b8c8ff10eb8b14 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.mixed/mixed.cfg000066400000000000000000000003231475314470400251070ustar00rootroot00000000000000variant mixed squished true graph cluster withbox true labelbox true hexa true symetric sm symetric si doshow data,addr,fr.co unshow sm,isb,ca,intrinsic edgeattr si,constraint,false edgeattr si,color,violetred1 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.store/000077500000000000000000000000001475314470400233505ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.store/LB+dmb.sy+addrR-pos-store.litmus.expected000066400000000000000000000005761475314470400330650ustar00rootroot00000000000000Test LB+dmb.sy+addrR-pos-store Allowed States 5 0:X1=0; 1:X1=0; 1:X3=1; [x]=2; 0:X1=0; 1:X1=1; 1:X3=1; [x]=2; 0:X1=1; 1:X1=0; 1:X3=1; [x]=2; 0:X1=1; 1:X1=1; 1:X3=1; [x]=2; 0:X1=2; 1:X1=0; 1:X3=1; [x]=2; No Witnesses Positive: 0 Negative: 5 Condition exists ([x]=2 /\ 0:X1=2 /\ 1:X1=1 /\ 1:X3=0) Observation LB+dmb.sy+addrR-pos-store Never 0 5 Hash=9ca8ccdd3aeb0efee0960d544096c5aa herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.store/LB+dmb.sy+dataW-pos-store.litmus.expected000066400000000000000000000005431475314470400330630ustar00rootroot00000000000000Test LB+dmb.sy+dataW-pos-store Allowed States 6 0:X1=0; 1:X1=0; [x]=3; 0:X1=0; 1:X1=1; [x]=3; 0:X1=1; 1:X1=0; [x]=3; 0:X1=2; 1:X1=0; [x]=3; 0:X1=2; 1:X1=1; [x]=3; 0:X1=3; 1:X1=0; [x]=3; No Witnesses Positive: 0 Negative: 6 Condition exists ([x]=3 /\ 0:X1=3 /\ 1:X1=1) Observation LB+dmb.sy+dataW-pos-store Never 0 6 Hash=46dd84898474c77fc610d54a530de7f7 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.store/MP+dmb.sy+addrR-pos-store.litmus.expected000066400000000000000000000006351475314470400331000ustar00rootroot00000000000000Test MP+dmb.sy+addrR-pos-store Allowed States 6 1:X1=0; 1:X3=1; 1:X5=1; [x]=1; 1:X1=0; 1:X3=1; 1:X5=1; [x]=2; 1:X1=0; 1:X3=1; 1:X5=2; [x]=2; 1:X1=0; 1:X3=2; 1:X5=2; [x]=2; 1:X1=1; 1:X3=1; 1:X5=1; [x]=1; 1:X1=1; 1:X3=2; 1:X5=2; [x]=2; No Witnesses Positive: 0 Negative: 6 Condition exists ([x]=2 /\ 1:X1=1 /\ 1:X3=0 /\ 1:X5=1) Observation MP+dmb.sy+addrR-pos-store Never 0 6 Hash=87fa6a4609f1907b491f1563f5314d5a herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.store/MP+dmb.sy+dataW-pos-store.litmus.expected000066400000000000000000000004651475314470400331050ustar00rootroot00000000000000Test MP+dmb.sy+dataW-pos-store Allowed States 4 1:X1=0; 1:X4=1; [x]=1; 1:X1=0; 1:X4=1; [x]=3; 1:X1=0; 1:X4=3; [x]=3; 1:X1=1; 1:X4=1; [x]=1; No Witnesses Positive: 0 Negative: 6 Condition exists ([x]=3 /\ 1:X1=1 /\ 1:X4=2) Observation MP+dmb.sy+dataW-pos-store Never 0 6 Hash=471054350ce898ada2aa9f86be28b15e herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.store/S+dmb.sy+addrR-pos-store.litmus.expected000066400000000000000000000005121475314470400327600ustar00rootroot00000000000000Test S+dmb.sy+addrR-pos-store Allowed States 5 1:X1=0; 1:X3=1; [x]=2; 1:X1=0; 1:X3=1; [x]=3; 1:X1=0; 1:X3=3; [x]=2; 1:X1=1; 1:X3=1; [x]=2; 1:X1=1; 1:X3=3; [x]=2; No Witnesses Positive: 0 Negative: 6 Condition exists ([x]=3 /\ 1:X1=1 /\ 1:X3=0) Observation S+dmb.sy+addrR-pos-store Never 0 6 Hash=b02e1f5e5cc2f56cffc34792b3ef7c76 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64.store/S+dmb.sy+dataW-pos-store.litmus.expected000066400000000000000000000003721475314470400327700ustar00rootroot00000000000000Test S+dmb.sy+dataW-pos-store Allowed States 3 1:X1=0; [x]=3; 1:X1=0; [x]=4; 1:X1=1; [x]=3; No Witnesses Positive: 0 Negative: 6 Condition exists ([x]=4 /\ 1:X1=1) Observation S+dmb.sy+dataW-pos-store Never 0 6 Hash=9b9f360bfb20364426a9d2e633d7a612 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/000077500000000000000000000000001475314470400222155ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/2+2W+dmb.sy+po.litmus.expected000066400000000000000000000003641475314470400275060ustar00rootroot00000000000000Test 2+2W+dmb.sy+po Allowed States 4 [x]=1; [y]=1; [x]=1; [y]=2; [x]=2; [y]=1; [x]=2; [y]=2; Ok Witnesses Positive: 1 Negative: 3 Condition exists ([x]=2 /\ [y]=2) Observation 2+2W+dmb.sy+po Sometimes 1 3 Hash=5dbeaed3a1aa88c4cdded063346ba075 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/2+2W+dmb.sys.litmus.expected000066400000000000000000000003361475314470400272560ustar00rootroot00000000000000Test 2+2W+dmb.sys Allowed States 3 [x]=1; [y]=1; [x]=1; [y]=2; [x]=2; [y]=1; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=2 /\ [y]=2) Observation 2+2W+dmb.sys Never 0 3 Hash=9495f1f810a4f034c732242a8a2c3eed herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/2+2W.litmus.expected000066400000000000000000000003401475314470400256760ustar00rootroot00000000000000Test 2+2W Allowed States 4 [x]=1; [y]=1; [x]=1; [y]=2; [x]=2; [y]=1; [x]=2; [y]=2; Ok Witnesses Positive: 1 Negative: 3 Condition exists ([x]=2 /\ [y]=2) Observation 2+2W Sometimes 1 3 Hash=5112e7c862483914f9d4e140b60657b2 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/LB+addr+po.litmus.expected000066400000000000000000000003661475314470400270760ustar00rootroot00000000000000Test LB+addr+po Allowed States 4 0:X1=0; 1:X1=0; 0:X1=0; 1:X1=1; 0:X1=1; 1:X1=0; 0:X1=1; 1:X1=1; Ok Witnesses Positive: 1 Negative: 3 Condition exists (0:X1=1 /\ 1:X1=1) Observation LB+addr+po Sometimes 1 3 Hash=9b7edf393c9b4fda2a8a1ba336a86817 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/LB+ctrl+po.litmus.expected000066400000000000000000000003661475314470400271300ustar00rootroot00000000000000Test LB+ctrl+po Allowed States 4 0:X1=0; 1:X1=0; 0:X1=0; 1:X1=1; 0:X1=1; 1:X1=0; 0:X1=1; 1:X1=1; Ok Witnesses Positive: 1 Negative: 3 Condition exists (0:X1=1 /\ 1:X1=1) Observation LB+ctrl+po Sometimes 1 3 Hash=5974994699c94e5618796424ee2f56b5 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/LB+data+po.litmus.expected000066400000000000000000000003661475314470400270750ustar00rootroot00000000000000Test LB+data+po Allowed States 4 0:X1=0; 1:X1=0; 0:X1=0; 1:X1=1; 0:X1=1; 1:X1=0; 0:X1=1; 1:X1=1; Ok Witnesses Positive: 1 Negative: 3 Condition exists (0:X1=1 /\ 1:X1=1) Observation LB+data+po Sometimes 1 3 Hash=f9b33b785d9c4aed6b99cac41bf52cba herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/LB+dmb.sy+addr.litmus.expected000066400000000000000000000003521475314470400276470ustar00rootroot00000000000000Test LB+dmb.sy+addr Allowed States 3 0:X1=0; 1:X1=0; 0:X1=0; 1:X1=1; 0:X1=1; 1:X1=0; No Witnesses Positive: 0 Negative: 3 Condition exists (0:X1=1 /\ 1:X1=1) Observation LB+dmb.sy+addr Never 0 3 Hash=4bb883a351011b44213ec9117d5b01cf herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/LB+dmb.sy+ctrl.litmus.expected000066400000000000000000000003521475314470400277010ustar00rootroot00000000000000Test LB+dmb.sy+ctrl Allowed States 3 0:X1=0; 1:X1=0; 0:X1=0; 1:X1=1; 0:X1=1; 1:X1=0; No Witnesses Positive: 0 Negative: 3 Condition exists (0:X1=1 /\ 1:X1=1) Observation LB+dmb.sy+ctrl Never 0 3 Hash=f1a339ea0c2006dcbe393941fa524a7f herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/LB+dmb.sy+data.litmus.expected000066400000000000000000000003521475314470400276460ustar00rootroot00000000000000Test LB+dmb.sy+data Allowed States 3 0:X1=0; 1:X1=0; 0:X1=0; 1:X1=1; 0:X1=1; 1:X1=0; No Witnesses Positive: 0 Negative: 3 Condition exists (0:X1=1 /\ 1:X1=1) Observation LB+dmb.sy+data Never 0 3 Hash=f99a78ed66f290e9ac8e924fec4b9427 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/LB+dmb.sy+po.litmus.expected000066400000000000000000000003721475314470400273550ustar00rootroot00000000000000Test LB+dmb.sy+po Allowed States 4 0:X1=0; 1:X1=0; 0:X1=0; 1:X1=1; 0:X1=1; 1:X1=0; 0:X1=1; 1:X1=1; Ok Witnesses Positive: 1 Negative: 3 Condition exists (0:X1=1 /\ 1:X1=1) Observation LB+dmb.sy+po Sometimes 1 3 Hash=8083d9ae4ef74f218457001062189689 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/LB+dmb.sys.litmus.expected000066400000000000000000000003421475314470400271230ustar00rootroot00000000000000Test LB+dmb.sys Allowed States 3 0:X1=0; 1:X1=0; 0:X1=0; 1:X1=1; 0:X1=1; 1:X1=0; No Witnesses Positive: 0 Negative: 3 Condition exists (0:X1=1 /\ 1:X1=1) Observation LB+dmb.sys Never 0 3 Hash=58f58841a29b4785c0318afb13b06b93 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/LB.litmus.expected000066400000000000000000000003461475314470400255540ustar00rootroot00000000000000Test LB Allowed States 4 0:X1=0; 1:X1=0; 0:X1=0; 1:X1=1; 0:X1=1; 1:X1=0; 0:X1=1; 1:X1=1; Ok Witnesses Positive: 1 Negative: 3 Condition exists (0:X1=1 /\ 1:X1=1) Observation LB Sometimes 1 3 Hash=75efc9d3fd2408a0f1d61e2dbe4a5037 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/MP+dmb.sy+addr.litmus.expected000066400000000000000000000003521475314470400276660ustar00rootroot00000000000000Test MP+dmb.sy+addr Allowed States 3 1:X1=0; 1:X3=0; 1:X1=0; 1:X3=1; 1:X1=1; 1:X3=1; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=1 /\ 1:X3=0) Observation MP+dmb.sy+addr Never 0 3 Hash=c52a30359fab0b4568025bff745f4f68 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/MP+dmb.sy+ctrlisb.litmus.expected000066400000000000000000000003601475314470400304150ustar00rootroot00000000000000Test MP+dmb.sy+ctrlisb Allowed States 3 1:X1=0; 1:X3=0; 1:X1=0; 1:X3=1; 1:X1=1; 1:X3=1; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=1 /\ 1:X3=0) Observation MP+dmb.sy+ctrlisb Never 0 3 Hash=a8b6dcfab940eae54eeba0b925c9d744 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/MP+dmb.sy+po.litmus.expected000066400000000000000000000003721475314470400273740ustar00rootroot00000000000000Test MP+dmb.sy+po Allowed States 4 1:X1=0; 1:X3=0; 1:X1=0; 1:X3=1; 1:X1=1; 1:X3=0; 1:X1=1; 1:X3=1; Ok Witnesses Positive: 1 Negative: 3 Condition exists (1:X1=1 /\ 1:X3=0) Observation MP+dmb.sy+po Sometimes 1 3 Hash=4e133de79065843db2e2bbaf079d080a herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/MP+dmb.sys.litmus.expected000066400000000000000000000003421475314470400271420ustar00rootroot00000000000000Test MP+dmb.sys Allowed States 3 1:X1=0; 1:X3=0; 1:X1=0; 1:X3=1; 1:X1=1; 1:X3=1; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X1=1 /\ 1:X3=0) Observation MP+dmb.sys Never 0 3 Hash=ba6fa85f3a14d91cf1d52c22f60d9b83 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/MP+po+addr.litmus.expected000066400000000000000000000003661475314470400271150ustar00rootroot00000000000000Test MP+po+addr Allowed States 4 1:X1=0; 1:X3=0; 1:X1=0; 1:X3=1; 1:X1=1; 1:X3=0; 1:X1=1; 1:X3=1; Ok Witnesses Positive: 1 Negative: 3 Condition exists (1:X1=1 /\ 1:X3=0) Observation MP+po+addr Sometimes 1 3 Hash=d3eb85363c83e07602100a601b1d5146 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/MP+po+ctrlisb.litmus.expected000066400000000000000000000003741475314470400276440ustar00rootroot00000000000000Test MP+po+ctrlisb Allowed States 4 1:X1=0; 1:X3=0; 1:X1=0; 1:X3=1; 1:X1=1; 1:X3=0; 1:X1=1; 1:X3=1; Ok Witnesses Positive: 1 Negative: 3 Condition exists (1:X1=1 /\ 1:X3=0) Observation MP+po+ctrlisb Sometimes 1 3 Hash=1061edabaf9b0c0b10ac078e284920be herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/MP+po+dmb.sy.litmus.expected000066400000000000000000000003721475314470400273740ustar00rootroot00000000000000Test MP+po+dmb.sy Allowed States 4 1:X1=0; 1:X3=0; 1:X1=0; 1:X3=1; 1:X1=1; 1:X3=0; 1:X1=1; 1:X3=1; Ok Witnesses Positive: 1 Negative: 3 Condition exists (1:X1=1 /\ 1:X3=0) Observation MP+po+dmb.sy Sometimes 1 3 Hash=5dccf49d050a0fcb3c6ad3f3d8e2a20c herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/MP.litmus.expected000066400000000000000000000003461475314470400255730ustar00rootroot00000000000000Test MP Allowed States 4 1:X1=0; 1:X3=0; 1:X1=0; 1:X3=1; 1:X1=1; 1:X3=0; 1:X1=1; 1:X3=1; Ok Witnesses Positive: 1 Negative: 3 Condition exists (1:X1=1 /\ 1:X3=0) Observation MP Sometimes 1 3 Hash=9827c55a473553b4e097483de0205966 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/R+dmb.sy+po.litmus.expected000066400000000000000000000003631475314470400272610ustar00rootroot00000000000000Test R+dmb.sy+po Allowed States 4 1:X3=0; [y]=1; 1:X3=0; [y]=2; 1:X3=1; [y]=1; 1:X3=1; [y]=2; Ok Witnesses Positive: 1 Negative: 3 Condition exists ([y]=2 /\ 1:X3=0) Observation R+dmb.sy+po Sometimes 1 3 Hash=0e843011df9fd5cccf3979cd65b81870 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/R+dmb.sys.litmus.expected000066400000000000000000000003341475314470400270300ustar00rootroot00000000000000Test R+dmb.sys Allowed States 3 1:X3=0; [y]=1; 1:X3=1; [y]=1; 1:X3=1; [y]=2; No Witnesses Positive: 0 Negative: 3 Condition exists ([y]=2 /\ 1:X3=0) Observation R+dmb.sys Never 0 3 Hash=d8feed7146fa9f77ff983d26efc9d029 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/R+po+dmb.sy.litmus.expected000066400000000000000000000003631475314470400272610ustar00rootroot00000000000000Test R+po+dmb.sy Allowed States 4 1:X3=0; [y]=1; 1:X3=0; [y]=2; 1:X3=1; [y]=1; 1:X3=1; [y]=2; Ok Witnesses Positive: 1 Negative: 3 Condition exists ([y]=2 /\ 1:X3=0) Observation R+po+dmb.sy Sometimes 1 3 Hash=f8a6aa6da9a958eb179dcab604d3a51e herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/R.litmus.expected000066400000000000000000000003371475314470400254600ustar00rootroot00000000000000Test R Allowed States 4 1:X3=0; [y]=1; 1:X3=0; [y]=2; 1:X3=1; [y]=1; 1:X3=1; [y]=2; Ok Witnesses Positive: 1 Negative: 3 Condition exists ([y]=2 /\ 1:X3=0) Observation R Sometimes 1 3 Hash=4aea2c57cbf1dc72c1fbf77b57062773 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/S+dmb.sy+addr.litmus.expected000066400000000000000000000003441475314470400275550ustar00rootroot00000000000000Test S+dmb.sy+addr Allowed States 3 1:X1=0; [x]=1; 1:X1=0; [x]=2; 1:X1=1; [x]=1; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=2 /\ 1:X1=1) Observation S+dmb.sy+addr Never 0 3 Hash=f70a654bb81aab586d7c4c0e2c8458aa herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/S+dmb.sy+ctrl.litmus.expected000066400000000000000000000003441475314470400276070ustar00rootroot00000000000000Test S+dmb.sy+ctrl Allowed States 3 1:X1=0; [x]=1; 1:X1=0; [x]=2; 1:X1=1; [x]=1; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=2 /\ 1:X1=1) Observation S+dmb.sy+ctrl Never 0 3 Hash=658b4cc3040879409baa8155dd55f6b6 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/S+dmb.sy+data.litmus.expected000066400000000000000000000003441475314470400275540ustar00rootroot00000000000000Test S+dmb.sy+data Allowed States 3 1:X1=0; [x]=1; 1:X1=0; [x]=2; 1:X1=1; [x]=1; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=2 /\ 1:X1=1) Observation S+dmb.sy+data Never 0 3 Hash=5f7433ab67b974a2b8b770016ff25387 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/S+dmb.sy+po.litmus.expected000066400000000000000000000003631475314470400272620ustar00rootroot00000000000000Test S+dmb.sy+po Allowed States 4 1:X1=0; [x]=1; 1:X1=0; [x]=2; 1:X1=1; [x]=1; 1:X1=1; [x]=2; Ok Witnesses Positive: 1 Negative: 3 Condition exists ([x]=2 /\ 1:X1=1) Observation S+dmb.sy+po Sometimes 1 3 Hash=15ad98e55f7098898ad567e00f3adb87 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/S+dmb.sys.litmus.expected000066400000000000000000000003341475314470400270310ustar00rootroot00000000000000Test S+dmb.sys Allowed States 3 1:X1=0; [x]=1; 1:X1=0; [x]=2; 1:X1=1; [x]=1; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=2 /\ 1:X1=1) Observation S+dmb.sys Never 0 3 Hash=2a684d141e99d8a17d8801bd6311d477 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/S+po+addr.litmus.expected000066400000000000000000000003571475314470400270030ustar00rootroot00000000000000Test S+po+addr Allowed States 4 1:X1=0; [x]=1; 1:X1=0; [x]=2; 1:X1=1; [x]=1; 1:X1=1; [x]=2; Ok Witnesses Positive: 1 Negative: 3 Condition exists ([x]=2 /\ 1:X1=1) Observation S+po+addr Sometimes 1 3 Hash=ecfa56f99b5ed89a5b907848e37edfa9 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/S+po+ctrl.litmus.expected000066400000000000000000000003571475314470400270350ustar00rootroot00000000000000Test S+po+ctrl Allowed States 4 1:X1=0; [x]=1; 1:X1=0; [x]=2; 1:X1=1; [x]=1; 1:X1=1; [x]=2; Ok Witnesses Positive: 1 Negative: 3 Condition exists ([x]=2 /\ 1:X1=1) Observation S+po+ctrl Sometimes 1 3 Hash=1824aff7e6dfcbce98f7ce262ecbead5 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/S+po+data.litmus.expected000066400000000000000000000003571475314470400270020ustar00rootroot00000000000000Test S+po+data Allowed States 4 1:X1=0; [x]=1; 1:X1=0; [x]=2; 1:X1=1; [x]=1; 1:X1=1; [x]=2; Ok Witnesses Positive: 1 Negative: 3 Condition exists ([x]=2 /\ 1:X1=1) Observation S+po+data Sometimes 1 3 Hash=c675ce57d6e48260a4fe1f77473d0d44 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/S+po+dmb.sy.litmus.expected000066400000000000000000000003631475314470400272620ustar00rootroot00000000000000Test S+po+dmb.sy Allowed States 4 1:X1=0; [x]=1; 1:X1=0; [x]=2; 1:X1=1; [x]=1; 1:X1=1; [x]=2; Ok Witnesses Positive: 1 Negative: 3 Condition exists ([x]=2 /\ 1:X1=1) Observation S+po+dmb.sy Sometimes 1 3 Hash=7bdbb892d7eecca9087d4ce0dfb0f475 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/S.litmus.expected000066400000000000000000000003371475314470400254610ustar00rootroot00000000000000Test S Allowed States 4 1:X1=0; [x]=1; 1:X1=0; [x]=2; 1:X1=1; [x]=1; 1:X1=1; [x]=2; Ok Witnesses Positive: 1 Negative: 3 Condition exists ([x]=2 /\ 1:X1=1) Observation S Sometimes 1 3 Hash=4a8390a6db1dd4bb80b5f2347e861742 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/SB+dmb.sy+po.litmus.expected000066400000000000000000000003721475314470400273640ustar00rootroot00000000000000Test SB+dmb.sy+po Allowed States 4 0:X3=0; 1:X3=0; 0:X3=0; 1:X3=1; 0:X3=1; 1:X3=0; 0:X3=1; 1:X3=1; Ok Witnesses Positive: 1 Negative: 3 Condition exists (0:X3=0 /\ 1:X3=0) Observation SB+dmb.sy+po Sometimes 1 3 Hash=acd016f60ab03ac5b9097f42209cb065 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/SB+dmb.sys.litmus.expected000066400000000000000000000003421475314470400271320ustar00rootroot00000000000000Test SB+dmb.sys Allowed States 3 0:X3=0; 1:X3=1; 0:X3=1; 1:X3=0; 0:X3=1; 1:X3=1; No Witnesses Positive: 0 Negative: 3 Condition exists (0:X3=0 /\ 1:X3=0) Observation SB+dmb.sys Never 0 3 Hash=c6a533fb255005c1a89998321e552a86 herd-herdtools7-1ca343e/herd/tests/diycross/AArch64/SB.litmus.expected000066400000000000000000000003461475314470400255630ustar00rootroot00000000000000Test SB Allowed States 4 0:X3=0; 1:X3=0; 0:X3=0; 1:X3=1; 0:X3=1; 1:X3=0; 0:X3=1; 1:X3=1; Ok Witnesses Positive: 1 Negative: 3 Condition exists (0:X3=0 /\ 1:X3=0) Observation SB Sometimes 1 3 Hash=0e1eb22a42a7de6af162a7e5cbb4e4d3 herd-herdtools7-1ca343e/herd/tests/diycross/C/000077500000000000000000000000001475314470400212475ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/C/C.cfg000066400000000000000000000000341475314470400221070ustar00rootroot00000000000000conf cpp11.cfg cat rc11.cat herd-herdtools7-1ca343e/herd/tests/diycross/C/LB+fetch.addrlxrlx-porlxrlxs.litmus.expected000066400000000000000000000005021475314470400317430ustar00rootroot00000000000000Test LB+fetch.addrlxrlx-porlxrlxs Allowed States 3 0:r0=0; 1:r0=0; [x]=1; [y]=1; 0:r0=0; 1:r0=1; [x]=1; [y]=3; 0:r0=1; 1:r0=0; [x]=3; [y]=1; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=3 /\ [y]=3 /\ 0:r0=1 /\ 1:r0=1) Observation LB+fetch.addrlxrlx-porlxrlxs Never 0 3 Hash=fe66b6eadbe105fba30116ad60a70bd6 herd-herdtools7-1ca343e/herd/tests/diycross/C/LB+porlxrlx+fetch.addrlxrlx-porlxrlx.litmus.expected000066400000000000000000000004641475314470400334550ustar00rootroot00000000000000Test LB+porlxrlx+fetch.addrlxrlx-porlxrlx Allowed States 3 0:r0=0; 1:r0=0; [y]=1; 0:r0=0; 1:r0=1; [y]=3; 0:r0=1; 1:r0=0; [y]=1; No Witnesses Positive: 0 Negative: 3 Condition exists ([y]=3 /\ 0:r0=1 /\ 1:r0=1) Observation LB+porlxrlx+fetch.addrlxrlx-porlxrlx Never 0 3 Hash=431a6363ef1a57fdce2ffe6286ca7cbd herd-herdtools7-1ca343e/herd/tests/diycross/C/LB+porlxrlx+posWrlxrlx-porlxrlx.litmus.expected000066400000000000000000000005301475314470400325570ustar00rootroot00000000000000Test LB+porlxrlx+posWrlxrlx-porlxrlx Allowed States 5 0:r0=0; 1:r0=0; [y]=1; 0:r0=0; 1:r0=0; [y]=2; 0:r0=0; 1:r0=1; [y]=2; 0:r0=1; 1:r0=0; [y]=1; 0:r0=1; 1:r0=0; [y]=2; No Witnesses Positive: 0 Negative: 5 Condition exists ([y]=2 /\ 0:r0=1 /\ 1:r0=1) Observation LB+porlxrlx+posWrlxrlx-porlxrlx Never 0 5 Hash=eecfc8f12b0ef73a3912bcc452ac4aab herd-herdtools7-1ca343e/herd/tests/diycross/C/LB+porlxrlx+rmwrlxrlx-porlxrlx.litmus.expected000066400000000000000000000004501475314470400324350ustar00rootroot00000000000000Test LB+porlxrlx+rmwrlxrlx-porlxrlx Allowed States 3 0:r0=0; 1:r0=0; [y]=1; 0:r0=0; 1:r0=1; [y]=2; 0:r0=1; 1:r0=0; [y]=1; No Witnesses Positive: 0 Negative: 3 Condition exists ([y]=2 /\ 0:r0=1 /\ 1:r0=1) Observation LB+porlxrlx+rmwrlxrlx-porlxrlx Never 0 3 Hash=478ba61f055e14380ab54ae40f9735e7 LB+posWrlxrlx-porlxrlx+fetch.addrlxrlx-porlxrlx.litmus.expected000066400000000000000000000006441475314470400356000ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/CTest LB+posWrlxrlx-porlxrlx+fetch.addrlxrlx-porlxrlx Allowed States 5 0:r0=0; 1:r0=0; [x]=1; [y]=1; 0:r0=0; 1:r0=0; [x]=2; [y]=1; 0:r0=0; 1:r0=1; [x]=1; [y]=3; 0:r0=0; 1:r0=1; [x]=2; [y]=3; 0:r0=1; 1:r0=0; [x]=2; [y]=1; No Witnesses Positive: 0 Negative: 5 Condition exists ([x]=2 /\ [y]=3 /\ 0:r0=1 /\ 1:r0=1) Observation LB+posWrlxrlx-porlxrlx+fetch.addrlxrlx-porlxrlx Never 0 5 Hash=2c8aa4cfdfb4ba7e167a051222ddebbf LB+rmwrlxrlx-porlxrlx+fetch.addrlxrlx-porlxrlx.litmus.expected000066400000000000000000000005461475314470400354560ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/CTest LB+rmwrlxrlx-porlxrlx+fetch.addrlxrlx-porlxrlx Allowed States 3 0:r0=0; 1:r0=0; [x]=1; [y]=1; 0:r0=0; 1:r0=1; [x]=1; [y]=3; 0:r0=1; 1:r0=0; [x]=2; [y]=1; No Witnesses Positive: 0 Negative: 3 Condition exists ([x]=2 /\ [y]=3 /\ 0:r0=1 /\ 1:r0=1) Observation LB+rmwrlxrlx-porlxrlx+fetch.addrlxrlx-porlxrlx Never 0 3 Hash=811fb70431f64f24aae74f0a36b5f2a2 herd-herdtools7-1ca343e/herd/tests/diycross/C/MP+porlxrlx+fetch.addrlxrlx-porlxrlx.litmus.expected000066400000000000000000000005171475314470400334730ustar00rootroot00000000000000Test MP+porlxrlx+fetch.addrlxrlx-porlxrlx Allowed States 4 1:r0=0; 1:r1=0; [y]=1; 1:r0=0; 1:r1=1; [y]=1; 1:r0=1; 1:r1=0; [y]=3; 1:r0=1; 1:r1=1; [y]=3; Ok Witnesses Positive: 1 Negative: 3 Condition exists ([y]=3 /\ 1:r0=1 /\ 1:r1=0) Observation MP+porlxrlx+fetch.addrlxrlx-porlxrlx Sometimes 1 3 Hash=c09fadf6d368461066b2797070475866 herd-herdtools7-1ca343e/herd/tests/diycross/C/MP+porlxrlx+posWrlxrlx-porlxrlx.litmus.expected000066400000000000000000000005631475314470400326040ustar00rootroot00000000000000Test MP+porlxrlx+posWrlxrlx-porlxrlx Allowed States 6 1:r0=0; 1:r1=0; [y]=1; 1:r0=0; 1:r1=0; [y]=2; 1:r0=0; 1:r1=1; [y]=1; 1:r0=0; 1:r1=1; [y]=2; 1:r0=1; 1:r1=0; [y]=2; 1:r0=1; 1:r1=1; [y]=2; Ok Witnesses Positive: 1 Negative: 5 Condition exists ([y]=2 /\ 1:r0=1 /\ 1:r1=0) Observation MP+porlxrlx+posWrlxrlx-porlxrlx Sometimes 1 5 Hash=b40d62540270ba77271169f203d43c0a herd-herdtools7-1ca343e/herd/tests/diycross/C/MP+porlxrlx+rmwrlxrlx-porlxrlx.litmus.expected000066400000000000000000000005031475314470400324530ustar00rootroot00000000000000Test MP+porlxrlx+rmwrlxrlx-porlxrlx Allowed States 4 1:r0=0; 1:r1=0; [y]=1; 1:r0=0; 1:r1=1; [y]=1; 1:r0=1; 1:r1=0; [y]=2; 1:r0=1; 1:r1=1; [y]=2; Ok Witnesses Positive: 1 Negative: 3 Condition exists ([y]=2 /\ 1:r0=1 /\ 1:r1=0) Observation MP+porlxrlx+rmwrlxrlx-porlxrlx Sometimes 1 3 Hash=926567c64bc6cd2c9a5c0ab3cda54d0e RR+RW+fetch.addrlxrlx-porlxrlx+posWrlxrlx-porlxrlx.litmus.expected000066400000000000000000000006251475314470400361510ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/CTest RR+RW+fetch.addrlxrlx-porlxrlx+posWrlxrlx-porlxrlx Allowed States 4 0:r0=0; 0:r1=0; 1:r0=0; [x]=1; 0:r0=0; 0:r1=1; 1:r0=0; [x]=1; 0:r0=1; 0:r1=0; 1:r0=0; [x]=3; 0:r0=1; 0:r1=1; 1:r0=0; [x]=3; Ok Witnesses Positive: 1 Negative: 3 Condition exists ([x]=3 /\ 0:r0=1 /\ 0:r1=0 /\ 1:r0=0) Observation RR+RW+fetch.addrlxrlx-porlxrlx+posWrlxrlx-porlxrlx Sometimes 1 3 Hash=e07dd4e2489838a059d51126f6329dcc RR+RW+fetch.addrlxrlx-porlxrlx+rmwrlxrlx-porlxrlx.litmus.expected000066400000000000000000000006231475314470400360240ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/CTest RR+RW+fetch.addrlxrlx-porlxrlx+rmwrlxrlx-porlxrlx Allowed States 4 0:r0=0; 0:r1=0; 1:r0=0; [x]=1; 0:r0=0; 0:r1=1; 1:r0=0; [x]=1; 0:r0=1; 0:r1=0; 1:r0=0; [x]=3; 0:r0=1; 0:r1=1; 1:r0=0; [x]=3; Ok Witnesses Positive: 1 Negative: 3 Condition exists ([x]=3 /\ 0:r0=1 /\ 0:r1=0 /\ 1:r0=0) Observation RR+RW+fetch.addrlxrlx-porlxrlx+rmwrlxrlx-porlxrlx Sometimes 1 3 Hash=3d32ac24b8757f7a7cf9c73e5555f5f9 herd-herdtools7-1ca343e/herd/tests/diycross/C/RR+RW+fetch.addrlxrlx-porlxrlxs.litmus.expected000066400000000000000000000005571475314470400323270ustar00rootroot00000000000000Test RR+RW+fetch.addrlxrlx-porlxrlxs Allowed States 4 0:r0=0; 0:r1=0; 1:r0=0; [x]=1; 0:r0=0; 0:r1=1; 1:r0=0; [x]=1; 0:r0=1; 0:r1=0; 1:r0=0; [x]=3; 0:r0=1; 0:r1=1; 1:r0=0; [x]=3; Ok Witnesses Positive: 1 Negative: 3 Condition exists ([x]=3 /\ 0:r0=1 /\ 0:r1=0 /\ 1:r0=0) Observation RR+RW+fetch.addrlxrlx-porlxrlxs Sometimes 1 3 Hash=82a15e023cea24dfc8be55f259634f94 RR+RW+porlxrlx+fetch.addrlxrlx-porlxrlx.litmus.expected000066400000000000000000000005321475314470400337440ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/CTest RR+RW+porlxrlx+fetch.addrlxrlx-porlxrlx Allowed States 4 0:r0=0; 0:r1=0; 1:r0=0; 0:r0=0; 0:r1=1; 1:r0=0; 0:r0=1; 0:r1=0; 1:r0=0; 0:r0=1; 0:r1=1; 1:r0=0; Ok Witnesses Positive: 1 Negative: 3 Condition exists (0:r0=1 /\ 0:r1=0 /\ 1:r0=0) Observation RR+RW+porlxrlx+fetch.addrlxrlx-porlxrlx Sometimes 1 3 Hash=0dd4d9924b61866ac0f5ca42b65d5bfb herd-herdtools7-1ca343e/herd/tests/diycross/C/RR+RW+porlxrlx+posWrlxrlx-porlxrlx.litmus.expected000066400000000000000000000005201475314470400331300ustar00rootroot00000000000000Test RR+RW+porlxrlx+posWrlxrlx-porlxrlx Allowed States 4 0:r0=0; 0:r1=0; 1:r0=0; 0:r0=0; 0:r1=1; 1:r0=0; 0:r0=1; 0:r1=0; 1:r0=0; 0:r0=1; 0:r1=1; 1:r0=0; Ok Witnesses Positive: 1 Negative: 3 Condition exists (0:r0=1 /\ 0:r1=0 /\ 1:r0=0) Observation RR+RW+porlxrlx+posWrlxrlx-porlxrlx Sometimes 1 3 Hash=06098fb2bd372cb6f864350eadd7c59c herd-herdtools7-1ca343e/herd/tests/diycross/C/RR+RW+porlxrlx+rmwrlxrlx-porlxrlx.litmus.expected000066400000000000000000000005161475314470400330120ustar00rootroot00000000000000Test RR+RW+porlxrlx+rmwrlxrlx-porlxrlx Allowed States 4 0:r0=0; 0:r1=0; 1:r0=0; 0:r0=0; 0:r1=1; 1:r0=0; 0:r0=1; 0:r1=0; 1:r0=0; 0:r0=1; 0:r1=1; 1:r0=0; Ok Witnesses Positive: 1 Negative: 3 Condition exists (0:r0=1 /\ 0:r1=0 /\ 1:r0=0) Observation RR+RW+porlxrlx+rmwrlxrlx-porlxrlx Sometimes 1 3 Hash=49a67c88ff40855bd9c3d5ce7f41507a RR+WR+fetch.addrlxrlx-porlxrlx+porlxrlx.litmus.expected000066400000000000000000000005321475314470400337440ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/CTest RR+WR+fetch.addrlxrlx-porlxrlx+porlxrlx Allowed States 4 0:r0=0; 0:r1=0; 1:r0=0; 0:r0=0; 0:r1=0; 1:r0=1; 0:r0=0; 0:r1=1; 1:r0=0; 0:r0=0; 0:r1=1; 1:r0=1; Ok Witnesses Positive: 1 Negative: 3 Condition exists (0:r0=0 /\ 0:r1=0 /\ 1:r0=0) Observation RR+WR+fetch.addrlxrlx-porlxrlx+porlxrlx Sometimes 1 3 Hash=5611301eed53e6e00bcfa42ba5efd519 herd-herdtools7-1ca343e/herd/tests/diycross/C/RR+WR+posWrlxrlx-porlxrlx+porlxrlx.litmus.expected000066400000000000000000000005201475314470400331300ustar00rootroot00000000000000Test RR+WR+posWrlxrlx-porlxrlx+porlxrlx Allowed States 4 0:r0=0; 0:r1=0; 1:r0=0; 0:r0=0; 0:r1=0; 1:r0=1; 0:r0=0; 0:r1=1; 1:r0=0; 0:r0=0; 0:r1=1; 1:r0=1; Ok Witnesses Positive: 1 Negative: 3 Condition exists (0:r0=0 /\ 0:r1=0 /\ 1:r0=0) Observation RR+WR+posWrlxrlx-porlxrlx+porlxrlx Sometimes 1 3 Hash=a29a1365ace5bbef91ba2882f5d7c56e herd-herdtools7-1ca343e/herd/tests/diycross/C/RR+WR+rmwrlxrlx-porlxrlx+porlxrlx.litmus.expected000066400000000000000000000005161475314470400330120ustar00rootroot00000000000000Test RR+WR+rmwrlxrlx-porlxrlx+porlxrlx Allowed States 4 0:r0=0; 0:r1=0; 1:r0=0; 0:r0=0; 0:r1=0; 1:r0=1; 0:r0=0; 0:r1=1; 1:r0=0; 0:r0=0; 0:r1=1; 1:r0=1; Ok Witnesses Positive: 1 Negative: 3 Condition exists (0:r0=0 /\ 0:r1=0 /\ 1:r0=0) Observation RR+WR+rmwrlxrlx-porlxrlx+porlxrlx Sometimes 1 3 Hash=54912e3b81a1713124ee05c0778e22b0 RW+WR+fetch.addrlxrlx-porlxrlx+porlxrlx.litmus.expected000066400000000000000000000005251475314470400337530ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/diycross/CTest RW+WR+fetch.addrlxrlx-porlxrlx+porlxrlx Allowed States 4 0:r0=0; 1:r0=0; [y]=1; 0:r0=0; 1:r0=0; [y]=2; 0:r0=0; 1:r0=1; [y]=1; 0:r0=0; 1:r0=1; [y]=2; Ok Witnesses Positive: 1 Negative: 3 Condition exists ([y]=2 /\ 0:r0=0 /\ 1:r0=0) Observation RW+WR+fetch.addrlxrlx-porlxrlx+porlxrlx Sometimes 1 3 Hash=680377353a537d48e0c206257fb46ddc herd-herdtools7-1ca343e/herd/tests/diycross/C/RW+WR+posWrlxrlx-porlxrlx+porlxrlx.litmus.expected000066400000000000000000000005131475314470400331370ustar00rootroot00000000000000Test RW+WR+posWrlxrlx-porlxrlx+porlxrlx Allowed States 4 0:r0=0; 1:r0=0; [y]=1; 0:r0=0; 1:r0=0; [y]=2; 0:r0=0; 1:r0=1; [y]=1; 0:r0=0; 1:r0=1; [y]=2; Ok Witnesses Positive: 1 Negative: 3 Condition exists ([y]=2 /\ 0:r0=0 /\ 1:r0=0) Observation RW+WR+posWrlxrlx-porlxrlx+porlxrlx Sometimes 1 3 Hash=0f6030b24414f3b2ea9ae76b840a2bfe herd-herdtools7-1ca343e/herd/tests/diycross/C/RW+WR+rmwrlxrlx-porlxrlx+porlxrlx.litmus.expected000066400000000000000000000005111475314470400330120ustar00rootroot00000000000000Test RW+WR+rmwrlxrlx-porlxrlx+porlxrlx Allowed States 4 0:r0=0; 1:r0=0; [y]=1; 0:r0=0; 1:r0=0; [y]=2; 0:r0=0; 1:r0=1; [y]=1; 0:r0=0; 1:r0=1; [y]=2; Ok Witnesses Positive: 1 Negative: 3 Condition exists ([y]=2 /\ 0:r0=0 /\ 1:r0=0) Observation RW+WR+rmwrlxrlx-porlxrlx+porlxrlx Sometimes 1 3 Hash=c778d9a88fba14a89e795b879b80f3d2 herd-herdtools7-1ca343e/herd/tests/diycross/C/S+porlxrlx+fetch.addrlxrlx-porlxrlx.litmus.expected000066400000000000000000000005101475314470400333520ustar00rootroot00000000000000Test S+porlxrlx+fetch.addrlxrlx-porlxrlx Allowed States 4 1:r0=0; [x]=1; [y]=1; 1:r0=0; [x]=2; [y]=1; 1:r0=1; [x]=1; [y]=3; 1:r0=1; [x]=2; [y]=3; Ok Witnesses Positive: 1 Negative: 3 Condition exists ([x]=2 /\ [y]=3 /\ 1:r0=1) Observation S+porlxrlx+fetch.addrlxrlx-porlxrlx Sometimes 1 3 Hash=036bab568a042fa8b875e724054a54d6 herd-herdtools7-1ca343e/herd/tests/diycross/C/S+porlxrlx+posWrlxrlx-porlxrlx.litmus.expected000066400000000000000000000005521475314470400324700ustar00rootroot00000000000000Test S+porlxrlx+posWrlxrlx-porlxrlx Allowed States 6 1:r0=0; [x]=1; [y]=1; 1:r0=0; [x]=1; [y]=2; 1:r0=0; [x]=2; [y]=1; 1:r0=0; [x]=2; [y]=2; 1:r0=1; [x]=1; [y]=2; 1:r0=1; [x]=2; [y]=2; Ok Witnesses Positive: 1 Negative: 5 Condition exists ([x]=2 /\ [y]=2 /\ 1:r0=1) Observation S+porlxrlx+posWrlxrlx-porlxrlx Sometimes 1 5 Hash=aeba8df0705685bf4a5b3309ce3e8110 herd-herdtools7-1ca343e/herd/tests/diycross/C/S+porlxrlx+rmwrlxrlx-porlxrlx.litmus.expected000066400000000000000000000004741475314470400323500ustar00rootroot00000000000000Test S+porlxrlx+rmwrlxrlx-porlxrlx Allowed States 4 1:r0=0; [x]=1; [y]=1; 1:r0=0; [x]=2; [y]=1; 1:r0=1; [x]=1; [y]=2; 1:r0=1; [x]=2; [y]=2; Ok Witnesses Positive: 1 Negative: 3 Condition exists ([x]=2 /\ [y]=2 /\ 1:r0=1) Observation S+porlxrlx+rmwrlxrlx-porlxrlx Sometimes 1 3 Hash=c113916b80d46fa5e3f7ee7fc2bea61e herd-herdtools7-1ca343e/herd/tests/instructions/000077500000000000000000000000001475314470400217725ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/instructions/AArch32/000077500000000000000000000000001475314470400231155ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/instructions/AArch32/A016.litmus000066400000000000000000000004621475314470400247650ustar00rootroot00000000000000ARM A016 { 0:R1=x; 1:R1=x; 0:R3=y; 1:R3=y; } P0 | P1 ; MOV R0, #1 | MOV R2, #1 ; L0: | STL R2, [R3] ; LDAEX R6, [R1] | LDA R0, [R1] ; STLEX R4,R0,[R1] | ; CMP R4, #0 | ; BNE L0 | ; LDA R2, [R3] | ; exists(0:R2=0 /\ 1:R0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch32/A016.litmus.expected000066400000000000000000000003331475314470400265620ustar00rootroot00000000000000Test A016 Allowed States 3 0:R2=0; 1:R0=1; 0:R2=1; 1:R0=0; 0:R2=1; 1:R0=1; Loop No Witnesses Positive: 0 Negative: 9 Condition exists (0:R2=0 /\ 1:R0=0) Observation A016 Never 0 9 Hash=f9537c416b340c5c1d7afc4295df5253 herd-herdtools7-1ca343e/herd/tests/instructions/AArch32/A016.litmus.expected-warn000066400000000000000000000001761475314470400275340ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch32/A016.litmus": unrolling limit exceeded at L0, legal outcomes may be missing. herd-herdtools7-1ca343e/herd/tests/instructions/AArch32/A017.litmus000066400000000000000000000005071475314470400247660ustar00rootroot00000000000000ARM A017 { 0:R1=x; 1:R1=x; 0:R3=y; 1:R3=y; } P0 | P1 ; MOV R0, #1 | MOV R2, #1 ; L0: | STL R2, [R3] ; LDAEX R6, [R1] | LDA R0, [R1] ; STLEX R4,R0,[R1] | ; CMP R4, #0 | ; BNE L0 | ; LDR R2, [R3] | ; DMB ISH | ; exists(0:R2=0 /\ 1:R0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch32/A017.litmus.expected000066400000000000000000000004331475314470400265640ustar00rootroot00000000000000Test A017 Allowed States 4 0:R2=0; 1:R0=0; 0:R2=0; 1:R0=1; 0:R2=1; 1:R0=0; 0:R2=1; 1:R0=1; Loop Ok Witnesses Positive: 3 Negative: 9 Flag Assuming-common-inner-shareable-domain Condition exists (0:R2=0 /\ 1:R0=0) Observation A017 Sometimes 3 9 Hash=ecb3d7f444cf1f6f6954389197887144 herd-herdtools7-1ca343e/herd/tests/instructions/AArch32/A017.litmus.expected-warn000066400000000000000000000001761475314470400275350ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch32/A017.litmus": unrolling limit exceeded at L0, legal outcomes may be missing. herd-herdtools7-1ca343e/herd/tests/instructions/AArch32/A018.litmus000066400000000000000000000005071475314470400247670ustar00rootroot00000000000000ARM A018 { 0:R1=x; 1:R1=x; 0:R3=y; 1:R3=y; } P0 | P1 ; MOV R0, #1 | MOV R2, #1 ; L0: | STL R2, [R3] ; LDAEX R6, [R1] | LDA R0, [R1] ; STLEX R4,R0,[R1] | ; CMP R4, #0 | ; BNE L0 | ; LDREX R2, [R3] | ; DMB ISH | ; exists(0:R2=0 /\ 1:R0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch32/A018.litmus.expected000066400000000000000000000004331475314470400265650ustar00rootroot00000000000000Test A018 Allowed States 4 0:R2=0; 1:R0=0; 0:R2=0; 1:R0=1; 0:R2=1; 1:R0=0; 0:R2=1; 1:R0=1; Loop Ok Witnesses Positive: 3 Negative: 9 Flag Assuming-common-inner-shareable-domain Condition exists (0:R2=0 /\ 1:R0=0) Observation A018 Sometimes 3 9 Hash=3d5fb7cad4c9bc287ca8875afd5d42ec herd-herdtools7-1ca343e/herd/tests/instructions/AArch32/A018.litmus.expected-warn000066400000000000000000000001761475314470400275360ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch32/A018.litmus": unrolling limit exceeded at L0, legal outcomes may be missing. herd-herdtools7-1ca343e/herd/tests/instructions/AArch32/A019.litmus000066400000000000000000000005351475314470400247710ustar00rootroot00000000000000ARM A019 { 0:R1=x; 1:R1=x; 0:R3=y; 1:R3=y; } P0 | P1 ; MOV R0, #1 | MOV R2, #1 ; L0: | STL R2, [R3] ; LDAEX R6, [R1] | LDA R0, [R1] ; STLEX R4,R0,[R1] | ; CMP R4, #0 | ; BNE L0 | ; DMB ISH | ; LDREX R2, [R3] | ; DMB ISH | ; exists(0:R2=0 /\ 1:R0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch32/A019.litmus.expected000066400000000000000000000004071475314470400265670ustar00rootroot00000000000000Test A019 Allowed States 3 0:R2=0; 1:R0=1; 0:R2=1; 1:R0=0; 0:R2=1; 1:R0=1; Loop No Witnesses Positive: 0 Negative: 9 Flag Assuming-common-inner-shareable-domain Condition exists (0:R2=0 /\ 1:R0=0) Observation A019 Never 0 9 Hash=0d88387a17be7a964ab6c4e969f60e5d herd-herdtools7-1ca343e/herd/tests/instructions/AArch32/A019.litmus.expected-warn000066400000000000000000000001761475314470400275370ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch32/A019.litmus": unrolling limit exceeded at L0, legal outcomes may be missing. herd-herdtools7-1ca343e/herd/tests/instructions/AArch32/aarch32.cfg000066400000000000000000000000361475314470400250200ustar00rootroot00000000000000model herd/libdir/aarch32.cat herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/000077500000000000000000000000001475314470400235405ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/ADD01.litmus000066400000000000000000000002321475314470400255250ustar00rootroot00000000000000AArch64 ADD01 { 0:X0=1; } P0 ; ADD W0,W0,#4095 ; ADD W0,W0,#-4095 ; ADD W0,W0,#1, LSL 12 ; ADD W0,W0,#-1, LSL 12 ; forall 0:X0=1herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/ADD01.litmus.expected000066400000000000000000000002501475314470400273250ustar00rootroot00000000000000Test ADD01 Required States 1 0:X0=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=1) Observation ADD01 Always 1 0 Hash=2b82c69a7a95ea648ec61463afa60141 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/ADD02.litmus000066400000000000000000000001631475314470400255310ustar00rootroot00000000000000AArch64 ADD02 { 0:X0=1; 0:X1=-2; int64_t 0:X2; } P0 ; ADD W2,W1,W0 ; forall 0:X2=4294967295herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/ADD02.litmus.expected000066400000000000000000000002721475314470400273320ustar00rootroot00000000000000Test ADD02 Required States 1 0:X2=4294967295; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=4294967295) Observation ADD02 Always 1 0 Hash=502f00a12d9a45353343894fb2a98845 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/ADDEXT001.litmus000066400000000000000000000001431475314470400261670ustar00rootroot00000000000000AArch64 ADDEXT01 { 0:X0=x; 0:X1=4; } P0 ; ADD X2,X0,W1,SXTW ; locations [0:X2;] herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/ADDEXT001.litmus.expected000066400000000000000000000002561475314470400277740ustar00rootroot00000000000000Test ADDEXT01 Required States 1 0:X2=x+4; Ok Witnesses Positive: 1 Negative: 0 Condition forall (true) Observation ADDEXT01 Always 1 0 Hash=ac17dc410c5be1bbfed37f414d2c793a herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/ADDEXT002.litmus000066400000000000000000000001621475314470400261710ustar00rootroot00000000000000AArch64 ADDEXT02 { 0:X0=4; 0:X1=-4; } P0 ; ADD X2,X0,W1,SXTW ; locations [0:X2;] forall 0:X2=0 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/ADDEXT002.litmus.expected000066400000000000000000000002561475314470400277750ustar00rootroot00000000000000Test ADDEXT02 Required States 1 0:X2=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=0) Observation ADDEXT02 Always 1 0 Hash=46768c1a69fcfdc354ab34efcd393619 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/ASR00.litmus000066400000000000000000000002731475314470400255660ustar00rootroot00000000000000AArch64 ASR00 { uint64_t 0:X8=0xff000000000000ff; uint64_t 0:X9; } P0 ; ORR X9,XZR,X8,ASR 8 ; ASRV X9,X9,XZR ; ASR X9,X9,#8 ; forall 0:X9=0xffffff0000000000herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/ASR00.litmus.expected000066400000000000000000000003101475314470400273560ustar00rootroot00000000000000Test ASR00 Required States 1 0:X9=18446742974197923840; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X9=-1099511627776) Observation ASR00 Always 1 0 Hash=53510b8fe12f32a7ab06716773da0a35 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/BRANCH01.litmus000066400000000000000000000002251475314470400260740ustar00rootroot00000000000000AArch64 BRANCH01 { } P0 ; B L0 ; ADD W0,W0,#1 ; B .+8 ; L0: ; B .-4 ; ADD W0,W0,#1 ; forall 0:X0=1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/BRANCH01.litmus.expected000066400000000000000000000002561475314470400277000ustar00rootroot00000000000000Test BRANCH01 Required States 1 0:X0=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=1) Observation BRANCH01 Always 1 0 Hash=ec1043de14b74d54bab701a4832cb3fa herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/BRANCH02.litmus000066400000000000000000000001441475314470400260750ustar00rootroot00000000000000AArch64 BRANCH02 { 0:X0=1; 0:X1=0; } P0 ; CBZ W1,.+8 ; ADD W0,W0,#1 ; forall 0:X0=1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/BRANCH02.litmus.expected000066400000000000000000000002561475314470400277010ustar00rootroot00000000000000Test BRANCH02 Required States 1 0:X0=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=1) Observation BRANCH02 Always 1 0 Hash=e209abfd990ad3d4436d755011d784db herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/BRANCH03.litmus000066400000000000000000000001441475314470400260760ustar00rootroot00000000000000AArch64 BRANCH03 { 0:X0=1; 0:X1=0; } P0 ; CBNZ W1,.+8 ; ADD W0,W0,#1 ; forall 0:X0=2 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/BRANCH03.litmus.expected000066400000000000000000000002561475314470400277020ustar00rootroot00000000000000Test BRANCH03 Required States 1 0:X0=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=2) Observation BRANCH03 Always 1 0 Hash=9fc0fb3ca924e141bcc940c55ea07579 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/BRANCH04.litmus000066400000000000000000000003231475314470400260760ustar00rootroot00000000000000AArch64 BRANCH04 { int x=1; 0:X0=1; 0:X2=x; 1:X0=1; 1:X2=x; } P0 | P1 ; LDR W1,[X2] | LDR W1,[X2] ; CBNZ W1,.+8 | CBZ W1,.+8 ; ADD W0,W0,#1 | ADD W0,W0,#1 ; forall 0:X0=1 /\ 1:X0=2 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/BRANCH04.litmus.expected000066400000000000000000000003001475314470400276710ustar00rootroot00000000000000Test BRANCH04 Required States 1 0:X0=1; 1:X0=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=1 /\ 1:X0=2) Observation BRANCH04 Always 1 0 Hash=bf0031223d3f7eafe24b44e11c1f0cb7 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/BRANCH05.litmus000066400000000000000000000001641475314470400261020ustar00rootroot00000000000000AArch64 BRANCH05 { 0:X0=1; 0:X1=1; } P0 ; CMP W1,#1 ; B.NE .+8 ; ADD W0,W0,#1 ; forall 0:X0=2 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/BRANCH05.litmus.expected000066400000000000000000000002561475314470400277040ustar00rootroot00000000000000Test BRANCH05 Required States 1 0:X0=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=2) Observation BRANCH05 Always 1 0 Hash=37cc9ba415441cd0389f9feec2014fe9 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/BRANCH06.litmus000066400000000000000000000001641475314470400261030ustar00rootroot00000000000000AArch64 BRANCH06 { 0:X0=1; 0:X1=1; } P0 ; CMP W1,#1 ; B.EQ .+8 ; ADD W0,W0,#1 ; forall 0:X0=1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/BRANCH06.litmus.expected000066400000000000000000000002561475314470400277050ustar00rootroot00000000000000Test BRANCH06 Required States 1 0:X0=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=1) Observation BRANCH06 Always 1 0 Hash=30a651cabc68f6be659b5554416283de herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/BRANCH07.litmus000066400000000000000000000002641475314470400261050ustar00rootroot00000000000000AArch64 BRANCH07 { int x=0; 0:X1=x; 1:X1=x; } P0 | P1 ; MOV W0,#1 | LDR W0,[X1] ; STR W0,[X1] | CBZ W0,.+8 ; | ADD W0,W0,#2 ; exists 1:X0=0;herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/BRANCH07.litmus.expected000066400000000000000000000002701475314470400277020ustar00rootroot00000000000000Test BRANCH07 Allowed States 2 1:X0=0; 1:X0=3; Ok Witnesses Positive: 1 Negative: 1 Condition exists (1:X0=0) Observation BRANCH07 Sometimes 1 1 Hash=6ab8f05c8f2cd2bfd4ad9967e7858353 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/BRANCH08.litmus000066400000000000000000000003221475314470400261010ustar00rootroot00000000000000AArch64 BRANCH08 { int x=0; 0:X1=x; 1:X1=x; } P0 | P1 ; MOV W0,#1 | LDR W0,[X1] ; STR W0,[X1] | CMP W0,#1 ; | B.GE .+8 ; | ADD W0,W0,#1 ; forall 1:X0=1;herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/BRANCH08.litmus.expected000066400000000000000000000002561475314470400277070ustar00rootroot00000000000000Test BRANCH08 Required States 1 1:X0=1; Ok Witnesses Positive: 2 Negative: 0 Condition forall (1:X0=1) Observation BRANCH08 Always 2 0 Hash=a94b8494be14d72a26d1c41a13efa0a6 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/BRANCH09.litmus000066400000000000000000000004121475314470400261020ustar00rootroot00000000000000AArch64 BRANCH09 { 0:X1=x; 0:X3=y; 1:X0=y; 1:X2=x; } P0 | P1 ; MOV W0,#1 | LDR W1,[X0] ; STR W0,[X1] | CBZ W1,Lout ; MOV W2,#1 | ISB ; STLR W2,[X3] | LDR W3,[X2] ; |Lout: ; ~exists (1:X1=1 /\ 1:X3=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/BRANCH09.litmus.expected000066400000000000000000000003211475314470400277010ustar00rootroot00000000000000Test BRANCH09 Forbidden States 2 1:X1=0; 1:X3=0; 1:X1=1; 1:X3=1; Ok Witnesses Positive: 2 Negative: 0 Condition ~exists (1:X1=1 /\ 1:X3=0) Observation BRANCH09 Never 0 2 Hash=815139f427ede35a0ecf953225593a5e herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/BRANCH10.litmus000066400000000000000000000005101475314470400260710ustar00rootroot00000000000000AArch64 BRANCH10 { 0:X1=x; 0:X3=y; 1:X0=y; 1:X2=x; } P0 | P1 ; MOV W0,#1 | LDR W1,[X0] ; STR W0,[X1] | CBNZ W1,L01 ; MOV W2,#1 | B L02 ; STLR W2,[X3] |L01: ; | ISB ; | LDR W3,[X2] ; |L02: ; ~exists (1:X1=1 /\ 1:X3=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/BRANCH10.litmus.expected000066400000000000000000000003211475314470400276710ustar00rootroot00000000000000Test BRANCH10 Forbidden States 2 1:X1=0; 1:X3=0; 1:X1=1; 1:X3=1; Ok Witnesses Positive: 2 Negative: 0 Condition ~exists (1:X1=1 /\ 1:X3=0) Observation BRANCH10 Never 0 2 Hash=b33a5fecfc2e17d323b890097d9bc4a7 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/CAS01.litmus000066400000000000000000000002441475314470400255460ustar00rootroot00000000000000AArch64 CAS01 (* CAS, ok case *) { int64_t x = 3; int64_t 0: X1 = 3; int64_t 0: X2 = 4; 0: X3 = x; } P0 ; CAS X1, X2, [X3] ; exists (0: X1 = 3 /\ x = 4) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/CAS01.litmus.expected000066400000000000000000000002671475314470400273530ustar00rootroot00000000000000Test CAS01 Allowed States 1 0:X1=3; [x]=4; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X1=3 /\ [x]=4) Observation CAS01 Always 1 0 Hash=568b1e62df1a8f57ba2c4fc0131048d6 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/CAS02.litmus000066400000000000000000000002441475314470400255470ustar00rootroot00000000000000AArch64 CAS02 (* CAS, no case *) { int64_t x = 3; int64_t 0: X1 = 2; int64_t 0: X2 = 4; 0: X3 = x; } P0 ; CAS X1, X2, [X3] ; exists (0: X1 = 3 /\ x = 3) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/CAS02.litmus.expected000066400000000000000000000002671475314470400273540ustar00rootroot00000000000000Test CAS02 Allowed States 1 0:X1=3; [x]=3; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X1=3 /\ [x]=3) Observation CAS02 Always 1 0 Hash=5a1df8a6a77dfdcf886e04d2f916feb2 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/CAS03.litmus000066400000000000000000000004511475314470400255500ustar00rootroot00000000000000AArch64 CAS03 (* * This test was failing, because the 32bits memory * reads was returning a bitvector of size 64, which * compared negatively with the bitvector of size 32 * read from the register W0. *) { int x; 0:X3=x; } P0 ; MOV W2,#1 ; CAS W0,W2,[X3] ; forall [x]=1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/CAS03.litmus.expected000066400000000000000000000002461475314470400273520ustar00rootroot00000000000000Test CAS03 Required States 1 [x]=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=1) Observation CAS03 Always 1 0 Hash=337d3b9628962897752d5dd8bce6694a herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/CAS04.litmus000066400000000000000000000003711475314470400255520ustar00rootroot00000000000000AArch64 CAS04 { int x=-1; int64_t 0:X0=-1; 0:X3=x; int64_t 0:X4; int64_t 0:X5; } P0 ; MOV W2,#1 ; CAS W0,W2,[X3] ; ADD W4,W4,W0 ; ADD X5,X5,W0,SXTW ; forall [x]=1 /\ 0:X0=4294967295 /\ 0:X4=4294967295 /\ 0:X5=-1herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/CAS04.litmus.expected000066400000000000000000000004021475314470400273450ustar00rootroot00000000000000Test CAS04 Required States 1 0:X0=4294967295; 0:X4=4294967295; 0:X5=-1; [x]=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=1 /\ 0:X0=4294967295 /\ 0:X4=4294967295 /\ 0:X5=-1) Observation CAS04 Always 1 0 Hash=2670239e8db7a47c0e8ed67db0a654d0 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/CSEL01.litmus000066400000000000000000000003171475314470400256670ustar00rootroot00000000000000AArch64 CSEL01 (* Basic csel, without really a condition check *) { int64_t 0: X1 = 3; int64_t 0: X2 = 4; int64_t 0: X8 = 8; int64_t 0: X9 = 9; } P0 ; CMP X8, X9; CSEL X3, X1, X2, EQ ; forall (0: X3 = 4) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/CSEL01.litmus.expected000066400000000000000000000002521475314470400274650ustar00rootroot00000000000000Test CSEL01 Required States 1 0:X3=4; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=4) Observation CSEL01 Always 1 0 Hash=5e6964f8e0602bd543aa767bfeab5be4 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/CSEL02.litmus000066400000000000000000000002741475314470400256720ustar00rootroot00000000000000AArch64 CSEL02 (* Basic csel, without really a condition check *) { int64_t 0: X1 = 3; int64_t 0: X2 = 4; int64_t 0: X8 = 8; } P0 ; CMP X8, #9; CSEL X3, X1, X2, MI ; forall (0: X3 = 3) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/CSEL02.litmus.expected000066400000000000000000000002521475314470400274660ustar00rootroot00000000000000Test CSEL02 Required States 1 0:X3=3; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=3) Observation CSEL02 Always 1 0 Hash=216ac4e7e9a61df78c78140378b8d0a3 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/CSET.litmus000066400000000000000000000002551475314470400255370ustar00rootroot00000000000000AArch64 CSET { 0:X0=1; 0:X1=1; } P0 ; CMP W0,W1 ; CSET W2,EQ ; CSET W3,LT ; CSETM W4,EQ ; CSETM W5,GT ; forall 0:X2=1 /\ 0:X3=0 /\ 0:X4=-1 /\ 0:X5=0 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/CSET.litmus.expected000066400000000000000000000003361475314470400273370ustar00rootroot00000000000000Test CSET Required States 1 0:X2=1; 0:X3=0; 0:X4=-1; 0:X5=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=1 /\ 0:X3=0 /\ 0:X4=-1 /\ 0:X5=0) Observation CSET Always 1 0 Hash=87d63dd83933539eb697c53b9633361f herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/EXTR00.litmus000066400000000000000000000005551475314470400257260ustar00rootroot00000000000000AArch64 EXTR { 0:X1=0x01234567; 0:X0=0x89ABCDEF; uint64_t 0:X4=0x0123456789ABCDEF; uint64_t 0:X3=0xFEDCBA9876543210; uint64_t 0:X5; uint64_t 0:X7; } P0 ; EXTR W2,W1,W0,#16 ; EXTR X5,X4,X3,#32 ; EXTR W6,W1,W1,#16 ; EXTR X7,X4,X4,#32 ; locations [0:X7;] forall 0:X2=0x456789ab /\ 0:X5=0x89abcdeffedcba98 /\ 0:X6=0x45670123 /\ 0:X7=0x89abcdef01234567herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/EXTR00.litmus.expected000066400000000000000000000005121475314470400275170ustar00rootroot00000000000000Test EXTR Required States 1 0:X2=1164413355; 0:X5=9920249034870405784; 0:X6=1164378403; 0:X7=9920249030613615975; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=1164413355 /\ 0:X5=-8526495038839145832 /\ 0:X6=1164378403 /\ 0:X7=-8526495043095935641) Observation EXTR Always 1 0 Hash=900a4acffb948a7f8eb44440ad2f5458 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/FENCES.litmus000066400000000000000000000003741475314470400257460ustar00rootroot00000000000000AArch64 FENCES { 0:X1=x; 0:X3=y; 1:X0=y; 1:X2=x; } P0 | P1 ; MOV W0,#1 | LDR W1,[X0] ; STR W0,[X1] | DMB ISHLD ; DSB ST | LDR W3,[X2] ; MOV W2,#1 | ; STR W2,[X3] | ; ~exists (1:X1=1 /\ 1:X3=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/FENCES.litmus.expected000066400000000000000000000004111475314470400275360ustar00rootroot00000000000000Test FENCES Forbidden States 3 1:X1=0; 1:X3=0; 1:X1=0; 1:X3=1; 1:X1=1; 1:X3=1; Ok Witnesses Positive: 3 Negative: 0 Flag Assuming-common-inner-shareable-domain Condition ~exists (1:X1=1 /\ 1:X3=0) Observation FENCES Never 0 3 Hash=2139547fd6c5fe72f2dfb254b6eac972 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LDADD00.litmus000066400000000000000000000002101475314470400257400ustar00rootroot00000000000000AArch64 LDADD00 { int64_t x = 5; int64_t 0:X1 = 3; 0:X3 = x; } P0 ; LDADD X1, X2, [X3] ; forall 0:X2=5 /\ [x]=8 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LDADD00.litmus.expected000066400000000000000000000002741475314470400275520ustar00rootroot00000000000000Test LDADD00 Required States 1 0:X2=5; [x]=8; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=5 /\ [x]=8) Observation LDADD00 Always 1 0 Hash=0edc7a1a68684e86cca2bdbd02535a66 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LDADD01.litmus000066400000000000000000000002141475314470400257450ustar00rootroot00000000000000AArch64 LDADD01 { x = -1; 0:X1 = 2; 0:X3 = x; int64_t 0:X2; } P0 ; LDADD W1, W2, [X3] ; forall 0:X2=4294967295 /\ [x]=1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LDADD01.litmus.expected000066400000000000000000000003161475314470400275500ustar00rootroot00000000000000Test LDADD01 Required States 1 0:X2=4294967295; [x]=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=4294967295 /\ [x]=1) Observation LDADD01 Always 1 0 Hash=90c1a39225ffa51afc62411d474242a1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LDADD02.litmus000066400000000000000000000002141475314470400257460ustar00rootroot00000000000000AArch64 LDADD01 { x = -1; 0:X1 = 2; 0:X3 = x; int64_t 0:X2; } P0 ; LDADD W1, W2, [X3] ; forall 0:X2=4294967295 /\ [x]=1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LDADD02.litmus.expected000066400000000000000000000003161475314470400275510ustar00rootroot00000000000000Test LDADD01 Required States 1 0:X2=4294967295; [x]=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=4294967295 /\ [x]=1) Observation LDADD01 Always 1 0 Hash=90c1a39225ffa51afc62411d474242a1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LDAPR.litmus000066400000000000000000000001451475314470400256410ustar00rootroot00000000000000AArch64 LDAPR { 0:X1=x; int64_t x=15; int64_t 0:X0; } P0 ; LDAPR W0,[X1] ; forall 0:X0=15herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LDAPR.litmus.expected000066400000000000000000000002521475314470400274400ustar00rootroot00000000000000Test LDAPR Required States 1 0:X0=15; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=15) Observation LDAPR Always 1 0 Hash=9efac2aa4e8006ede4dde8b73406367a herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LDAR.litmus000066400000000000000000000001201475314470400255120ustar00rootroot00000000000000AArch64 LDAR { 0:X1=x; int x=15; } P0 ; LDAR W0,[X1] ; forall 0:X0=15herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LDAR.litmus.expected000066400000000000000000000002501475314470400273160ustar00rootroot00000000000000Test LDAR Required States 1 0:X0=15; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=15) Observation LDAR Always 1 0 Hash=d7d4643d35c3d4f4f785e8c6946462c5 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LDEOR00.litmus000066400000000000000000000002011475314470400257750ustar00rootroot00000000000000AArch64 LDEOR00 { x = -1; 0:X1 = 128; 0:X3 = x; 0:X2; } P0 ; LDEOR W1, W2, [X3] ; forall 0:X2=-1 /\ [x]=-129 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LDEOR00.litmus.expected000066400000000000000000000003041475314470400276010ustar00rootroot00000000000000Test LDEOR00 Required States 1 0:X2=-1; [x]=-129; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=-1 /\ [x]=-129) Observation LDEOR00 Always 1 0 Hash=3a752cebbec41960f99e380742e13a58 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LDR01.litmus000066400000000000000000000002131475314470400255550ustar00rootroot00000000000000AArch64 LDR01 (* Test ASL instruction LDR *) { int64_t x = 2 ; int64_t 0:X2 ; 0: X1 = x; } P0 ; LDR X2, [X1]; forall (0: X2 = 2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LDR01.litmus.expected000066400000000000000000000002501475314470400273560ustar00rootroot00000000000000Test LDR01 Required States 1 0:X2=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=2) Observation LDR01 Always 1 0 Hash=ea0b2e5e6df229142ed14771174a6f58 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LDR02.litmus000066400000000000000000000001221475314470400255550ustar00rootroot00000000000000AArch64 LDR02 { int x = 1 ; 0:X1=x; } P0 ; LDR W0,[X1] ; forall 0:X0=1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LDR02.litmus.expected000066400000000000000000000002501475314470400273570ustar00rootroot00000000000000Test LDR02 Required States 1 0:X0=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=1) Observation LDR02 Always 1 0 Hash=64feb72405036040a5ab3924aca0feb9 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LDR03.litmus000066400000000000000000000002011475314470400255540ustar00rootroot00000000000000AArch64 LDR03 { int t[2] = { 1, 2 }; 0:X0=t; } P0 ; MOV W1,#4 ; LDR W2,[X0,W1,SXTW] ; forall 0:X2=2herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LDR03.litmus.expected000066400000000000000000000002501475314470400273600ustar00rootroot00000000000000Test LDR03 Required States 1 0:X2=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=2) Observation LDR03 Always 1 0 Hash=1858150ef66e22e18267a451f64fc1b4 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LDSMIN00.litmus000066400000000000000000000001741475314470400261270ustar00rootroot00000000000000AArch64 LDSMIN00 { x = 0; 0:X1 = -128; 0:X3 = x; } P0 ; LDSMIN W1, W2, [X3] ; forall 0:X2=0 /\ [x]=-128 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LDSMIN00.litmus.expected000066400000000000000000000003041475314470400277220ustar00rootroot00000000000000Test LDSMIN00 Required States 1 0:X2=0; [x]=-128; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=0 /\ [x]=-128) Observation LDSMIN00 Always 1 0 Hash=294d9016cf92887f46065fa13868a1e0 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LDSMIN01.litmus000066400000000000000000000004031475314470400261230ustar00rootroot00000000000000AArch64 LDSMIN01 (* The smin result is zero-extended before being stored to teh destination register 0:X2 *) { int x[2] = {-1,0}; 0:X1 = -128; 0:X3 = x; int64_t 0:X2; } P0 ; LDSMIN W1, W2, [X3] ; forall 0:X2=-1 /\ x[0]=-128 /\ x[1] = 0 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LDSMIN01.litmus.expected000066400000000000000000000003411475314470400277240ustar00rootroot00000000000000Test LDSMIN01 Required States 1 0:X2=4294967295; x[0]=-128; x[1]=0; No Witnesses Positive: 0 Negative: 1 Condition forall (0:X2=-1 /\ x[0]=-128 /\ x[1]=0) Observation LDSMIN01 Never 0 1 Hash=189905288c4e5353a9326adbb28afb6b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LDUMIN00.litmus000066400000000000000000000001741475314470400261310ustar00rootroot00000000000000AArch64 LDUMIN00 { x = 0; 0:X1 = -128; 0:X3 = x; } P0 ; LDUMIN W1, W2, [X3] ; forall 0:X2=0 /\ [x]=-128 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LDUMIN00.litmus.expected000066400000000000000000000003001475314470400277200ustar00rootroot00000000000000Test LDUMIN00 Required States 1 0:X2=0; [x]=0; No Witnesses Positive: 0 Negative: 1 Condition forall (0:X2=0 /\ [x]=-128) Observation LDUMIN00 Never 0 1 Hash=3adec7fbf6ac5bf7d7cc1898364d85ec herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LOGI01.litmus000066400000000000000000000002461475314470400256740ustar00rootroot00000000000000AArch64 LOGI01 { } P0 ; ORR W0,WZR,#3 ; ORR W0,W0,#4096 ; ORR W0,W0,#8192 ; AND W0,W0,#65534 ; EOR W0,W0,#255 ; forall 0:X0 = 12541 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LOGI01.litmus.expected000066400000000000000000000002621475314470400274720ustar00rootroot00000000000000Test LOGI01 Required States 1 0:X0=12541; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=12541) Observation LOGI01 Always 1 0 Hash=4fc2197b659a507a056299b9ecba86b6 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LXSX.litmus000066400000000000000000000003071475314470400255750ustar00rootroot00000000000000AArch64 LXSX { int x = 1; 0:X1=x; 0:X3=2; 1:X1=x; 1:X0=4; } P0 | P1 ; LDXR W0,[X1] | STR W0,[X1] ; STXR W2,W3,[X1] | ; forall x=2 /\ 0:X2=0 /\ 0:X0=4 \/ x=4herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/LXSX.litmus.expected000066400000000000000000000004261475314470400273770ustar00rootroot00000000000000Test LXSX Required States 4 0:X0=1; 0:X2=0; [x]=4; 0:X0=1; 0:X2=1; [x]=4; 0:X0=4; 0:X2=0; [x]=2; 0:X0=4; 0:X2=1; [x]=4; Ok Witnesses Positive: 4 Negative: 0 Condition forall ([x]=2 /\ 0:X2=0 /\ 0:X0=4 \/ [x]=4) Observation LXSX Always 4 0 Hash=cd5e9df8844fa1ff8fefdb82c40eb07a herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/MADD.litmus000066400000000000000000000002271475314470400255050ustar00rootroot00000000000000AArch64 MADD { 0:X0=65536; 0:X1=65535; } P0 ; MADD W3,W0,W1,W0 ; MUL W4,W1,W1 ; locations [0:X3;0:X4;] forall 0:X3=0 /\ 0:X4=-131071herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/MADD.litmus.expected000066400000000000000000000003041475314470400273010ustar00rootroot00000000000000Test MADD Required States 1 0:X3=0; 0:X4=-131071; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=0 /\ 0:X4=-131071) Observation MADD Always 1 0 Hash=37b637d8e9d53b68c8fad63415cc190b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/MOV.litmus000066400000000000000000000001601475314470400254350ustar00rootroot00000000000000AArch64 MOV variant=ASLv0 { int64_t 0: X1 = 2 } P0 ; MOV X2, X1 ; forall ( 0: X1 = 2 /\ 0: X2 = 2 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/MOV.litmus.expected000066400000000000000000000002661475314470400272440ustar00rootroot00000000000000Test MOV Required States 1 0:X1=2; 0:X2=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=2 /\ 0:X2=2) Observation MOV Always 1 0 Hash=4432ffbe4cd1d6b393267a607fa14fb4 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/MOVI01.litmus000066400000000000000000000003301475314470400257060ustar00rootroot00000000000000AArch64 MOVI01 { int64_t 0:X1; int64_t 0:X2; } P0 ; MOV W0,#65536 ; MOV X1,#4294967296 ; MOV X2,#281474976710656 ; forall 0:X0=65536 /\ 0:X1=4294967296 /\ 0:X2=281474976710656 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/MOVI01.litmus.expected000066400000000000000000000004041475314470400275100ustar00rootroot00000000000000Test MOVI01 Required States 1 0:X0=65536; 0:X1=4294967296; 0:X2=281474976710656; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=65536 /\ 0:X1=4294967296 /\ 0:X2=281474976710656) Observation MOVI01 Always 1 0 Hash=e76ac2dfc39f920800ba79b620245dc0 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/MOVI02.litmus000066400000000000000000000003151475314470400257120ustar00rootroot00000000000000AArch64 MOVI02 { int64_t 0:X2; } P0 ; MOV W0,#-1 ; MOV W1,#65535 ; MOV X2,#-206158430209 ; locations [0:X2;] forall 0:X0=-1 /\ 0:X1 = 65535 /\ 0:X2=-206158430209 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/MOVI02.litmus.expected000066400000000000000000000003601475314470400275120ustar00rootroot00000000000000Test MOVI02 Required States 1 0:X0=-1; 0:X1=65535; 0:X2=-206158430209; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=-1 /\ 0:X1=65535 /\ 0:X2=-206158430209) Observation MOVI02 Always 1 0 Hash=2db5a09f0e723b53c361d22d9df220c5 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/MP01.litmus000066400000000000000000000003301475314470400254500ustar00rootroot00000000000000AArch64 MP01 { 0:X7=x; 0:X8=y; 1:X7=x; 1:X8=y; } P0 | P1 ; LDR W1,[X7] | MOV W0,#1 ; CMP W1,#0 | STR W0,[X8] ; LDR W3,[X8] | STLR W0,[X7] ; exists (0:X1=1 /\ 0:X3=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/MP01.litmus.expected000066400000000000000000000003521475314470400272540ustar00rootroot00000000000000Test MP01 Allowed States 4 0:X1=0; 0:X3=0; 0:X1=0; 0:X3=1; 0:X1=1; 0:X3=0; 0:X1=1; 0:X3=1; Ok Witnesses Positive: 1 Negative: 3 Condition exists (0:X1=1 /\ 0:X3=0) Observation MP01 Sometimes 1 3 Hash=f6e8d163288dce9e9b25d40d69f01a3c herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/MSUB.litmus000066400000000000000000000002151475314470400255430ustar00rootroot00000000000000AArch64 MSUB { 0:X0=65536; 0:X1=65535; 0:X2= -65536; } P0 ; MSUB W3,W2,W1,W0 ; MNEG W4,W1,W1 ; forall 0:X3=0 /\ 0:X4=131071herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/MSUB.litmus.expected000066400000000000000000000003021475314470400273400ustar00rootroot00000000000000Test MSUB Required States 1 0:X3=0; 0:X4=131071; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=0 /\ 0:X4=131071) Observation MSUB Always 1 0 Hash=dd705259084ac3576e32782a08c99293 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/NOASL000066400000000000000000000001341475314470400243350ustar00rootroot00000000000000#CAS tests yield the same outcomes but less execution candidates... CAS01 CAS02 CAS03 CAS04 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/NOP.litmus000066400000000000000000000000771475314470400254370ustar00rootroot00000000000000AArch64 NOP (* ASL variant test *) variant ASL {} P0; NOP; herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/NOP.litmus.expected000066400000000000000000000002331475314470400272310ustar00rootroot00000000000000Test NOP Required States 1 Ok Witnesses Positive: 1 Negative: 0 Condition forall (true) Observation NOP Always 1 0 Hash=536990778bf38c18e78222d5d185951b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/NORUN000066400000000000000000000001221475314470400243570ustar00rootroot00000000000000#Do not run those with litmus7, results are not significant ADDEXT01 BRANCH01 NOP herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/ROR00.litmus000066400000000000000000000005061475314470400256020ustar00rootroot00000000000000AArch64 ROR00 { 0:X1=0x01234567; 0:X2=10; uint64_t 0:X4=0x0123456789ABCDEF; uint64_t 0:X3=40; uint64_t 0:X7; uint64_t 0:X8; } P0 ; ROR W6,W1,#16 ; ROR W5,W1,W2 ; ROR X7,X4,#32 ; ROR X8,X4,X3 ; locations [0:X5;0:X8;] forall 0:X5=0x59c048d1 /\ 0:X6=0x45670123 /\ 0:X7=0x89abcdef01234567 /\ 0:X8=0x6789abcdef012345herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/ROR00.litmus.expected000066400000000000000000000005131475314470400274000ustar00rootroot00000000000000Test ROR00 Required States 1 0:X5=1505773777; 0:X6=1164378403; 0:X7=9920249030613615975; 0:X8=7460683158682411845; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X5=1505773777 /\ 0:X6=1164378403 /\ 0:X7=-8526495043095935641 /\ 0:X8=7460683158682411845) Observation ROR00 Always 1 0 Hash=0947d03ed91727a85e963b5d88dc19af herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/STCLR00.litmus000066400000000000000000000001551475314470400260270ustar00rootroot00000000000000AArch64 STCLR00 { uint64_t x=15; uint64_t 0:X0=5; 0:X1=x; } P0 ; STCLR X0,[X1] ; forall [x]=10 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/STCLR00.litmus.expected000066400000000000000000000002541475314470400276270ustar00rootroot00000000000000Test STCLR00 Required States 1 [x]=10; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=10) Observation STCLR00 Always 1 0 Hash=6dce510cf1ec8087064858128b894317 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/STLR.litmus000066400000000000000000000001161475314470400255610ustar00rootroot00000000000000AArch64 STLR { 0:X0=15; 0:X1=x; } P0 ; STLR W0,[X1] ; forall [x]=15herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/STLR.litmus.expected000066400000000000000000000002461475314470400273650ustar00rootroot00000000000000Test STLR Required States 1 [x]=15; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=15) Observation STLR Always 1 0 Hash=4458e8f19e5398ba20875a30195dc432 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/STR01.litmus000066400000000000000000000002241475314470400256060ustar00rootroot00000000000000AArch64 STR01 (* Basic test for STR functionnality *) { int64_t x = 0; int64_t 0: X1 = 3; 0: X2 = x; } P0 ; STR X1, [X2] ; forall (x = 3) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/STR01.litmus.expected000066400000000000000000000002461475314470400274120ustar00rootroot00000000000000Test STR01 Required States 1 [x]=3; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=3) Observation STR01 Always 1 0 Hash=1aeb1e048117683d5d7e8cc14fda01fd herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/STR02.litmus000066400000000000000000000001411475314470400256050ustar00rootroot00000000000000AArch64 STR02 { int x = 0 ; 0:X1=x; } P0 ; MOV W0,#1 ; STR W0,[X1] ; forall [x]=1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/STR02.litmus.expected000066400000000000000000000002461475314470400274130ustar00rootroot00000000000000Test STR02 Required States 1 [x]=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=1) Observation STR02 Always 1 0 Hash=b0e9cabd5402db054215ea5c67974e00 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/STR03.litmus000066400000000000000000000002351475314470400256120ustar00rootroot00000000000000AArch64 STR03 { int t[2] = { 1, 2 }; 0:X0=t; } P0 ; MOV W1,#4 ; MOV W2,3 ; STR W2,[X0,W1,SXTW] ; forall t = { 1,3 }herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/STR03.litmus.expected000066400000000000000000000002521475314470400274110ustar00rootroot00000000000000Test STR03 Required States 1 t={1,3}; Ok Witnesses Positive: 1 Negative: 0 Condition forall (t={1,3}) Observation STR03 Always 1 0 Hash=9c01e35640d853d0827d7c5422362b95 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/SWP+SAME.litmus000066400000000000000000000002141475314470400261660ustar00rootroot00000000000000AArch64 swap+same { int64_t x = 5; int64_t 0: X1 = 3; 0: X3 = x; } P0 ; SWP X1, X1, [X3] ; forall ( 0: X1 = 5 /\ x = 3 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/SWP+SAME.litmus.expected000066400000000000000000000003001475314470400277620ustar00rootroot00000000000000Test swap+same Required States 1 0:X1=5; [x]=3; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=5 /\ [x]=3) Observation swap+same Always 1 0 Hash=8f20c78b54026dc52fe77ba75b684ccb herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/SWP+TWO.litmus000066400000000000000000000002221475314470400261110ustar00rootroot00000000000000AArch64 SWP+TWO { 0:X1=1; 0:X0=x; 1:X1=2; 1:X0=x; } P0 | P1 ; SWP W1,W2,[X0] | SWP W1,W2,[X0] ; forall (0:X2=2 \/ 1:X2=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/SWP+TWO.litmus.expected000066400000000000000000000003161475314470400277150ustar00rootroot00000000000000Test SWP+TWO Required States 2 0:X2=0; 1:X2=1; 0:X2=2; 1:X2=0; Ok Witnesses Positive: 2 Negative: 0 Condition forall (0:X2=2 \/ 1:X2=1) Observation SWP+TWO Always 2 0 Hash=ca9a6147848dd5387d6b1d0b90af0166 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/SWP.litmus000066400000000000000000000002071475314470400254470ustar00rootroot00000000000000AArch64 swap { int64_t x = 5; int64_t 0: X1 = 3; 0: X3 = x; } P0 ; SWP X1, X2, [X3] ; forall ( 0: X2 = 5 /\ x = 3 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/SWP.litmus.expected000066400000000000000000000002661475314470400272540ustar00rootroot00000000000000Test swap Required States 1 0:X2=5; [x]=3; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=5 /\ [x]=3) Observation swap Always 1 0 Hash=f1448306be548941f08d4cc6fed56c17 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/SXTW01.litmus000066400000000000000000000001621475314470400257440ustar00rootroot00000000000000AArch64 SXTW01 { int64_t 0:X1; int 0:X0=0xffffffff; } P0 ; SXTW X1,W0 ; forall 0:X1=-1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/SXTW01.litmus.expected000066400000000000000000000002541475314470400275460ustar00rootroot00000000000000Test SXTW01 Required States 1 0:X1=-1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=-1) Observation SXTW01 Always 1 0 Hash=50be8eb6a78d3f344e6b9b551b92348d herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/asl.cfg000066400000000000000000000001071475314470400247760ustar00rootroot00000000000000variant asl,strict #For now, reference is advanced asl variant asl+exp herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/noasl-mixed.cfg000066400000000000000000000001161475314470400264370ustar00rootroot00000000000000excl ./herd/tests/instructions/AArch64.ASL/NOASL variant mixed machsize byte herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.ASL/noasl.cfg000066400000000000000000000000621475314470400253330ustar00rootroot00000000000000excl ./herd/tests/instructions/AArch64.ASL/NOASL herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/000077500000000000000000000000001475314470400235465ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/AK001.litmus000066400000000000000000000001001475314470400255100ustar00rootroot00000000000000AArch64 AK001 {} P0 ; ADR X0,L0 ; L0: ; NOP ;herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/AK001.litmus.expected000066400000000000000000000002371475314470400273230ustar00rootroot00000000000000Test AK001 Required States 1 Ok Witnesses Positive: 1 Negative: 0 Condition forall (true) Observation AK001 Always 1 0 Hash=933e6d21cb8006a6d0b82acc2b9eaed0 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/AK002.litmus000066400000000000000000000000631475314470400255210ustar00rootroot00000000000000AArch64 AK002 { 0:X9=P0:L0; } P0 ; L0: ; NOP ;herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/AK002.litmus.expected000066400000000000000000000002371475314470400273240ustar00rootroot00000000000000Test AK002 Required States 1 Ok Witnesses Positive: 1 Negative: 0 Condition forall (true) Observation AK002 Always 1 0 Hash=87f5f630a2b92cb633415f356ff3f20f herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/AK003.litmus000066400000000000000000000002641475314470400255250ustar00rootroot00000000000000AArch64 AK003 { tag(z)=:green; 0:X1=z:red; } P0 | P0.F ; STR W0,[X1] | ADR X9,L0 ; L0: | MSR ELR_EL1,X9 ; NOP | ERET ;herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/AK003.litmus.expected000066400000000000000000000002371475314470400273250ustar00rootroot00000000000000Test AK003 Required States 1 Ok Witnesses Positive: 1 Negative: 0 Condition forall (true) Observation AK003 Always 1 0 Hash=ada35d7fc3c99ded00b8ecb318534623 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/B001.litmus000066400000000000000000000003061475314470400254060ustar00rootroot00000000000000AArch64 B001 (* Memory operation must fail *) { 0:X1=x:red; } P0 ; MOV W4,#1 ; LDEORAL W4,W3,[X1] ; MOV W5,#2 ; locations [Fault(P0,x);] forall [x]=0 /\ 0:X5=0 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/B001.litmus.expected000066400000000000000000000003201475314470400272020ustar00rootroot00000000000000Test B001 Required States 1 0:X5=0; [x]=0; Fault(P0,x:red,TagCheck); Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=0 /\ 0:X5=0) Observation B001 Always 1 0 Hash=f71247cb81b2fe331994046291ecd8dd herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/B002.litmus000066400000000000000000000003131475314470400254050ustar00rootroot00000000000000AArch64 B002 (* Memory operatiom must succeed *) { 0:X1=x:green; } P0 ; MOV W4,#1 ; LDEORAL W4,W3,[X1] ; MOV W5,#2 ; locations [Fault(P0,x);] forall [x]=1 /\ 0:X5=2 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/B002.litmus.expected000066400000000000000000000003051475314470400272060ustar00rootroot00000000000000Test B002 Required States 1 0:X5=2; [x]=1; ~Fault(P0,x); Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=1 /\ 0:X5=2) Observation B002 Always 1 0 Hash=3eae7eabf625381a1e02ed299419cd85 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/B003.litmus000066400000000000000000000001711475314470400254100ustar00rootroot00000000000000AArch64 B003 Variant=fatal { 0:X1=x:red; } P0 ; L0: ; LDR W0,[X1] ; forall(fault(P0:L0,x,TagCheck)) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/B003.litmus.expected000066400000000000000000000003151475314470400272100ustar00rootroot00000000000000Test B003 Required States 1 Fault(P0:L0,x:red,TagCheck); Ok Witnesses Positive: 1 Negative: 0 Condition forall (fault(P0:L0,x,TagCheck)) Observation B003 Always 1 0 Hash=3f26bf76b73ca2381e4121035bb6e888 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/B004.litmus000066400000000000000000000001661475314470400254150ustar00rootroot00000000000000AArch64 B004 Variant=async { 0:X1=x:red } P0 ; MOV W0,#1 ; STR W0,[X1] ; forall([x]=1 /\ 0:TFSR_ELx=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/B004.litmus.expected000066400000000000000000000003021475314470400272050ustar00rootroot00000000000000Test B004 Required States 1 0:TFSR_ELx=1; [x]=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=1 /\ 0:TFSR_ELx=1) Observation B004 Always 1 0 Hash=a8708b099b5f95ad916f70e33c905ffc herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/B005.litmus000066400000000000000000000001671475314470400254170ustar00rootroot00000000000000AArch64 B005 Variant=mte,sync,faultToNext { 0:X1=x:red; } P0 ; LDR W0,[X1] ; MOV W2,#1 ; forall(0:X2=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/B005.litmus.expected000066400000000000000000000002461475314470400272150ustar00rootroot00000000000000Test B005 Required States 1 0:X2=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=1) Observation B005 Always 1 0 Hash=92ce7c8ed051bc37bffd09f2abe7bb5d herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/B006.litmus000066400000000000000000000002621475314470400254140ustar00rootroot00000000000000AArch64 B006 Variant=mte,sync,handled { 0:X1=x:red; 1:X0=x:red; 1:X1=x; } P0 | P1 ; LDR W0,[X1] | STG X0,[X1] ; MOV W2,#1 | ; forall(0:X2=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/B006.litmus.expected000066400000000000000000000002461475314470400272160ustar00rootroot00000000000000Test B006 Required States 1 0:X2=1; Ok Witnesses Positive: 2 Negative: 0 Condition forall (0:X2=1) Observation B006 Always 2 0 Hash=bb89dcef73943ae09ecb778349f34a6b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/B007.litmus000066400000000000000000000003171475314470400254160ustar00rootroot00000000000000AArch64 B007 Variant=mte,asym,fatal { 0:X1=x:red; 1:X1=x:red; } P0 | P1 ; LDR W0,[X1] | MOV W0,#2 ; MOV W2,#1 | STR W0,[X1] ; | MOV W2,#1 ; forall(0:X2=0 /\ 1:X2=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/B007.litmus.expected000066400000000000000000000002701475314470400272140ustar00rootroot00000000000000Test B007 Required States 1 0:X2=0; 1:X2=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=0 /\ 1:X2=1) Observation B007 Always 1 0 Hash=a8f826b9b17927e1c9b398a95db3fd99 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/B009.litmus000066400000000000000000000003001475314470400254100ustar00rootroot00000000000000AArch64 B009 { int x[8]={1,2,3,4,5,6,7,8}; 0:X0=x:green; 0:X1=x:red; } P0 ; STG X1,[X0,#16] ; DSB SY ; MOV W2,#9 ; STR W2,[X0,#16] ; forall fault(P0,x) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/B009.litmus.expected000066400000000000000000000003031475314470400272130ustar00rootroot00000000000000Test B009 Required States 1 Fault(P0,x:green+16,TagCheck); Ok Witnesses Positive: 1 Negative: 0 Condition forall (fault(P0,x)) Observation B009 Always 1 0 Hash=e709dfa5687229ee24c64baa4be1d1d9 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/B010.litmus000066400000000000000000000003011475314470400254010ustar00rootroot00000000000000AArch64 B010 { int x[8]={1,2,3,4,5,6,7,8}; 0:X0=x:green; 0:X1=x:red; } P0 ; STG X1,[X0,#16] ; DSB SY ; MOV W2,#9 ; STR W2,[X0,#12] ; forall ~fault(P0,x) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/B010.litmus.expected000066400000000000000000000002711475314470400272070ustar00rootroot00000000000000Test B010 Required States 1 ~Fault(P0,x); Ok Witnesses Positive: 1 Negative: 0 Condition forall (not (fault(P0,x))) Observation B010 Always 1 0 Hash=683370b37c1159c10a7517d849f3c051 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/B011.litmus000066400000000000000000000003001475314470400254010ustar00rootroot00000000000000AArch64 B011 { int x[8]={1,2,3,4,5,6,7,8}; 0:X0=x:green; 0:X1=x:red; } P0 ; STG X1,[X0,#16] ; DSB SY ; MOV W2,#9 ; STR W2,[X1] ; forall fault(P0,x) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/B011.litmus.expected000066400000000000000000000002761475314470400272150ustar00rootroot00000000000000Test B011 Required States 1 Fault(P0,x:red,TagCheck); Ok Witnesses Positive: 1 Negative: 0 Condition forall (fault(P0,x)) Observation B011 Always 1 0 Hash=6d2736480bf9fc9b54cd2c78b0330fbe herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/B012.litmus000066400000000000000000000003021475314470400254040ustar00rootroot00000000000000AArch64 B012 { int x[8]={1,2,3,4,5,6,7,8}; 0:X0=x:green; 0:X1=x:red; } P0 ; STG X1,[X0,#16] ; DSB SY ; MOV W2,#9 ; STR W2,[X1,#16] ; forall ~fault(P0,x) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/B012.litmus.expected000066400000000000000000000002711475314470400272110ustar00rootroot00000000000000Test B012 Required States 1 ~Fault(P0,x); Ok Witnesses Positive: 1 Negative: 0 Condition forall (not (fault(P0,x))) Observation B012 Always 1 0 Hash=373fea60dc2524676ae0d6095296613a herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/B013.litmus000066400000000000000000000003431475314470400254120ustar00rootroot00000000000000AArch64 B013 { int x[8]={1,2,3,4,5,6,7,8}; 0:X0=x:green; 0:X1=x:red; } P0 ; STG X1,[X0,#16] ; DSB SY ; LDG X2,[X0] ; LDG X3,[X0,#16] ; SUB X3,X3,#16 ; forall 0:X2=x:green /\ 0:X3=x:red herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/B013.litmus.expected000066400000000000000000000003141475314470400272100ustar00rootroot00000000000000Test B013 Required States 1 0:X2=x:green; 0:X3=x:red; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=x:green /\ 0:X3=x:red) Observation B013 Always 1 0 Hash=ff1d49fd5f406a9bad36312fd738487f herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/B014.litmus000066400000000000000000000003761475314470400254210ustar00rootroot00000000000000AArch64 B014 (* Should not come through *) { int x[8]={1,2,3,4,5,6,7,8}; 0:X0=x:green; 0:X1=x:red; } P0 ; STG X1,[X0,#1] ; DSB SY ; LDG X2,[X0] ; LDG X3,[X0,#1] ; SUB X3,X3,#16 ; forall 0:X2=x:green /\ 0:X3=x:red herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/B014.litmus.expected-failure000066400000000000000000000001651475314470400306420ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64.MTE/B014.litmus": Illegal instruction 'STG X1,[X0,#1]' (User error) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/L00.litmus000066400000000000000000000003131475314470400253350ustar00rootroot00000000000000AArch64 L00 Variant=mixed,mte,sync { int x[6]={1,2,3,4,5,6}; 0:X1=x; 0:X2=x:red; } P0 ; STZG X2,[X1] ; MOV W0,#7 ; STR W0,[X2] ; STR W0,[X1,#20] ; forall x={7,0,0,0,5,7} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/L00.litmus.expected000066400000000000000000000002661475314470400271440ustar00rootroot00000000000000Test L00 Required States 1 x={7,0,0,0,5,7}; Ok Witnesses Positive: 1 Negative: 0 Condition forall (x={7,0,0,0,5,7}) Observation L00 Always 1 0 Hash=686ab9d457f82594fb739b04bbe5a40b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/L01.litmus000066400000000000000000000007771475314470400253540ustar00rootroot00000000000000AArch64 S+dmb.sytt+addrpt Orig=DMB.SYdWWTT RfeTP DpAddrdWPT CoeTT Variant=mte,async (* Test is allowed in asynchronous mode, by lack of iico_ctrl relation from tag test to read in P1 LDR *) { 0:X0=x:blue; 0:X1=x:red; 0:X2=y:red; 0:X3=y:green; 1:X0=y:red; 1:X3=x:red; 1:X4=x:green; } P0 | P1 ; STG X0,[X1] | LDR W1,[X0] ; DMB SY | EOR W2,W1,W1 ; STG X2,[X3] | ADD X5,X4,W2,SXTW ; | STG X3,[X5] ; exists (1:X1=0 /\ [tag(x)]=:blue /\ ~fault(P1,y)) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/L01.litmus.expected000066400000000000000000000006211475314470400271400ustar00rootroot00000000000000Test S+dmb.sytt+addrpt Allowed States 4 1:X1=0; [tag(x)]=:blue; ~Fault(P1,y); 1:X1=0; [tag(x)]=:blue; Fault(P1,y:red,TagCheck); 1:X1=0; [tag(x)]=:red; ~Fault(P1,y); 1:X1=0; [tag(x)]=:red; Fault(P1,y:red,TagCheck); Ok Witnesses Positive: 1 Negative: 3 Condition exists (1:X1=0 /\ [tag(x)]=:blue /\ not (fault(P1,y))) Observation S+dmb.sytt+addrpt Sometimes 1 3 Hash=e590f3a6e742d25cc38d360f8014889e herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/L02.litmus000066400000000000000000000003231475314470400253400ustar00rootroot00000000000000AArch64 L02 Variant=mixed,mte,sync { int x[8]={1,2,3,4,5,6,7,8}; 0:X1=x; 0:X2=x:red; } P0 ; STZ2G X2,[X1] ; MOV W0,#9 ; STR W0,[X2] ; STR W0,[X2,#28] ; forall x={9,0,0,0,0,0,0,9} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/L02.litmus.expected000066400000000000000000000002761475314470400271470ustar00rootroot00000000000000Test L02 Required States 1 x={9,0,0,0,0,0,0,9}; Ok Witnesses Positive: 1 Negative: 0 Condition forall (x={9,0,0,0,0,0,0,9}) Observation L02 Always 1 0 Hash=ac1c69c0bcf4aad96545b4f61a6e329b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/L03.litmus000066400000000000000000000003521475314470400253430ustar00rootroot00000000000000AArch64 L03 (* Non-mixed test: STZG store zero in x, neglecting overflow, to change? *) Variant=mte,sync { int x=1; 0:X1=x:green; 0:X2=x:red; } P0 ; MOV W0,#2 ; STZG X2,[X1] ; LDR W0,[X2] ; forall 0:X0=0 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/L03.litmus.expected000066400000000000000000000002441475314470400271430ustar00rootroot00000000000000Test L03 Required States 1 0:X0=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=0) Observation L03 Always 1 0 Hash=7ad8343d0a87a8209e1c5027acdd499a herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/L04.litmus000066400000000000000000000006041475314470400253440ustar00rootroot00000000000000AArch64 L04 (* Check that tag addresses are based upon physical addresses *) Variant=vmsa,memtag,sync { [PTE(x)]=(oa:PA(y),attrs:(TaggedNormal)); (* Notice, x is virtual notation, but initialise tag(PA(x)) *) [tag(x)]=:red; (* Idem, x is virtual, but initialise PA(x) *) int x=1; int y=2; 0:X1=x; } P0 ; LDR W0,[X1] ; (* Reading PA(y) with the color of PA(y) *) forall 0:X0=2;herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/L04.litmus.expected000066400000000000000000000003241475314470400271430ustar00rootroot00000000000000Test L04 Required States 1 0:X0=2; Ok Witnesses Positive: 1 Negative: 0 Flag combining-vmsa-and-memtag-is-not-supported Condition forall (0:X0=2) Observation L04 Always 1 0 Hash=a8c2d90712b54d8c6d4bec4489b05034 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/L05.litmus000066400000000000000000000002731475314470400253470ustar00rootroot00000000000000AArch64 L05 { int t[8] = {1,2,3,4,5,6,7,8}; 0:X1=t:green; 0:X3=t:red; } P0 ; STZG X3,[X1] ; LDR W0,[X3,#12] ; LDR W2,[X1,#16] ; locations [t;] forall 0:X0=0 /\ 0:X2=5 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/L05.litmus.expected-failure000066400000000000000000000002121475314470400305650ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64.MTE/L05.litmus": Array location and STZG instruction without -variant mixed (User error) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/L06.litmus000066400000000000000000000003111475314470400253410ustar00rootroot00000000000000AArch64 L06 Variant=mixed { int t[8] = {1,2,3,4,5,6,7,8}; 0:X1=t:green; 0:X3=t:red; } P0 ; STZG X3,[X1] ; LDR W0,[X3,#12] ; LDR W2,[X1,#16] ; locations [t;] forall 0:X0=0 /\ 0:X2=5 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/L06.litmus.expected000066400000000000000000000003131475314470400271430ustar00rootroot00000000000000Test L06 Required States 1 0:X0=0; 0:X2=5; t={0,0,0,0,5,6,7,8}; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=0 /\ 0:X2=5) Observation L06 Always 1 0 Hash=b92fca2f16c4739549786c669e41edc0 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.MTE/mte.cfg000066400000000000000000000000271475314470400250130ustar00rootroot00000000000000variant memtag,precise herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/000077500000000000000000000000001475314470400237165ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A001.litmus000066400000000000000000000002301475314470400255510ustar00rootroot00000000000000AArch64 A001 Variant=fatal { x=1; [PTE(x)]=(oa:PA(x),valid:0); 0:X1=x; 0:X2=0; } P0 ; LDR W0,[X1] ; MOV W2, #1 ; forall (0:X0=0 /\ 0:X2=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A001.litmus.expected000066400000000000000000000002701475314470400273550ustar00rootroot00000000000000Test A001 Required States 1 0:X0=0; 0:X2=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=0 /\ 0:X2=0) Observation A001 Always 1 0 Hash=b4f76ddaf0ec77a089ddb069cb87815f herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A002.litmus000066400000000000000000000002271475314470400255600ustar00rootroot00000000000000AArch64 A002 Variant=skip { x=1; [PTE(x)]=(oa:PA(x),valid:0); 0:X1=x; 0:X2=0; } P0 ; LDR W0,[X1] ; MOV W2, #1 ; forall (0:X0=0 /\ 0:X2=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A002.litmus.expected000066400000000000000000000002701475314470400273560ustar00rootroot00000000000000Test A002 Required States 1 0:X0=0; 0:X2=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=0 /\ 0:X2=1) Observation A002 Always 1 0 Hash=b4f76ddaf0ec77a089ddb069cb87815f herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A003.litmus000066400000000000000000000003511475314470400255570ustar00rootroot00000000000000AArch64 A003 Variant=handled { x=1; [PTE(x)]=(oa:PA(x),valid:0); 0:X1=x; 0:X2=0; 1:X0=(oa:PA(x),valid:1); 1:X1=PTE(x) } P0 | P1 ; LDR W0,[X1] | STR X0,[X1] ; MOV W2, #1 | ; forall(0:X0=1 /\ 0:X2=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A003.litmus.expected000066400000000000000000000002701475314470400273570ustar00rootroot00000000000000Test A003 Required States 1 0:X0=1; 0:X2=1; Ok Witnesses Positive: 2 Negative: 0 Condition forall (0:X0=1 /\ 0:X2=1) Observation A003 Always 2 0 Hash=0f2847d5367fde735ca5ae4a6e03cd9b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A004.litmus000066400000000000000000000002111475314470400255530ustar00rootroot00000000000000AArch64 A004 Variant=fatal { [PTE(x)]=(oa:PA(x),valid:0); 0:X1=x; } P0 ; L0: ; LDR W0,[X1] ; forall(fault(P0:L0,x)) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A004.litmus.expected000066400000000000000000000003071475314470400273610ustar00rootroot00000000000000Test A004 Required States 1 Fault(P0:L0,x,MMU:Translation); Ok Witnesses Positive: 1 Negative: 0 Condition forall (fault(P0:L0,x)) Observation A004 Always 1 0 Hash=abfed1dff47d259c77dbd4bc5cef0cc5 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A005.litmus000066400000000000000000000004011475314470400255550ustar00rootroot00000000000000AArch64 A005 { [x]=1; [PTE(x)]=(oa:PA(x),valid:0); 0:X1=x; } P0 | P0.F ; LDR W0,[X1] | MOV W2,#1 ; L0: | ADR X4,L0 ; MOV W3,#1 | MSR ELR_EL1,X4 ; | ERET ; forall(0:X0=0 /\ 0:X2=1 /\ 0:X3=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A005.litmus.expected000066400000000000000000000003121475314470400273560ustar00rootroot00000000000000Test A005 Required States 1 0:X0=0; 0:X2=1; 0:X3=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=0 /\ 0:X2=1 /\ 0:X3=1) Observation A005 Always 1 0 Hash=63fe95c5d285e45a9e941fb36d381f70 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A006.litmus000066400000000000000000000003771475314470400255720ustar00rootroot00000000000000AArch64 A006 { [x]=1; [PTE(x)]=(oa:PA(x),valid:0); 0:X1=x; } P0 | P0.F ; L0: | MRS X2,ELR_EL1 ; LDR W0,[X1] | ADR X3,L1 ; L1: | MSR ELR_EL1,X3 ; | ERET ; locations[0:X2;] forall(0:X0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A006.litmus.expected000066400000000000000000000002721475314470400273640ustar00rootroot00000000000000Test A006 Required States 1 0:X0=0; 0:X2=label:"P0:L0"; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=0) Observation A006 Always 1 0 Hash=9cb24c27e27d2bedb06c012822963a02 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A007.litmus000066400000000000000000000003261475314470400255650ustar00rootroot00000000000000AArch64 A007 { [x]=1; [PTE(x)]=(valid:0); 0:X0=PTE(x); 0:X1=(valid:1,oa:PA(x)); 1:X0=x; } P0 | P1 | P1.F ; STR X1,[X0] | LDR W1,[X0] | LDR W2,[X0] ; locations[1:X1;] exists (1:X2=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A007.litmus.expected000066400000000000000000000003001475314470400273550ustar00rootroot00000000000000Test A007 Allowed States 2 1:X1=0; 1:X2=1; 1:X1=1; 1:X2=0; Ok Witnesses Positive: 1 Negative: 1 Condition exists (1:X2=1) Observation A007 Sometimes 1 1 Hash=0013cab22a273b4ea8fe84264f78039b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A007.litmus.expected-warn000066400000000000000000000001051475314470400303250ustar00rootroot00000000000000Warning: Fault inside a fault handler, legal outcomes may be missing herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A008.litmus000066400000000000000000000011451475314470400255660ustar00rootroot00000000000000AArch64 A008 variant=fatal (** * This tests raises the warning * "Fault inside a fault handler. Legal outcomes may be missing" * However, the handler "P0.F" triggers the fault only if * a CoRR violation occurs, which any model will forbid. *Future fix may get rid of the warning. **) { 0:X0=x; 0:X2=z; 1:X0=x; [PTE(z)]=(valid:0); } P0 | P1 | P0.F ; LDR W1,[X0] | MOV W1,#1 | CBZ W1,L0 ; LDR W3,[X0] | STR W1,[X0] | CBNZ W3,L0 ; LDR W5,[X2] | | LDR W7,[X2] ; | |L0: ; locations [0:X1;0:X3;] exists 0:X1=1 /\ 0:X3=0 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A008.litmus.expected000066400000000000000000000003261475314470400273660ustar00rootroot00000000000000Test A008 Allowed States 3 0:X1=0; 0:X3=0; 0:X1=0; 0:X3=1; 0:X1=1; 0:X3=1; No Witnesses Positive: 0 Negative: 3 Condition exists (0:X1=1 /\ 0:X3=0) Observation A008 Never 0 3 Hash=47c0d5abe4c93f43062380b5cfad18be herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A008.litmus.expected-warn000066400000000000000000000001051475314470400303260ustar00rootroot00000000000000Warning: Fault inside a fault handler, legal outcomes may be missing herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A009.litmus000066400000000000000000000002321475314470400255630ustar00rootroot00000000000000AArch64 A009 Variant=fatal { [PTE(x)]=(oa:PA(x),valid:0); 0:X1=x; } P0 ; L0: ; LDR W0,[X1] ; forall(fault(P0:L0,x,MMU:Translation)) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A009.litmus.expected000066400000000000000000000003271475314470400273700ustar00rootroot00000000000000Test A009 Required States 1 Fault(P0:L0,x,MMU:Translation); Ok Witnesses Positive: 1 Negative: 0 Condition forall (fault(P0:L0,x,MMU:Translation)) Observation A009 Always 1 0 Hash=abfed1dff47d259c77dbd4bc5cef0cc5 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A010.litmus000066400000000000000000000002261475314470400255560ustar00rootroot00000000000000AArch64 A010 Variant=fatal { [PTE(x)]=(oa:PA(x),af:0); 0:X1=x; } P0 ; L0: ; LDR W0,[X1] ; forall(fault(P0:L0,x,MMU:AccessFlag)) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A010.litmus.expected000066400000000000000000000003251475314470400273560ustar00rootroot00000000000000Test A010 Required States 1 Fault(P0:L0,x,MMU:AccessFlag); Ok Witnesses Positive: 1 Negative: 0 Condition forall (fault(P0:L0,x,MMU:AccessFlag)) Observation A010 Always 1 0 Hash=e18778764923d960b192d56f6245cf89 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A011.litmus000066400000000000000000000002451475314470400255600ustar00rootroot00000000000000AArch64 A011 Variant=fatal { [PTE(x)]=(oa:PA(x),db:0); 0:X1=x; } P0 ; MOV W0,#1 ; L0: ; STR W0,[X1] ; forall(fault(P0:L0,x,MMU:Permission)) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A011.litmus.expected000066400000000000000000000003251475314470400273570ustar00rootroot00000000000000Test A011 Required States 1 Fault(P0:L0,x,MMU:Permission); Ok Witnesses Positive: 1 Negative: 0 Condition forall (fault(P0:L0,x,MMU:Permission)) Observation A011 Always 1 0 Hash=f6a789da14367c3011386455e4dc8532 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A012.litmus000066400000000000000000000004731475314470400255640ustar00rootroot00000000000000AArch64 A012 Variant=faultToNext { [PTE(x)]=(valid:0); [PTE(y)]=(af:0); 0:X1=x; 0:X2=y; } P0 ; L0: ; UDF #0 ; L1: ; LDR W0,[X1] ; L2: ; LDR W0,[X2] ; forall(fault(P0:L0,UndefinedInstruction) /\ fault(P0:L1,x,MMU:Translation) /\ fault(P0:L2,y,MMU:AccessFlag)) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A012.litmus.expected000066400000000000000000000005371475314470400273650ustar00rootroot00000000000000Test A012 Required States 1 Fault(P0:L0,UndefinedInstruction); Fault(P0:L1,x,MMU:Translation); Fault(P0:L2,y,MMU:AccessFlag); Ok Witnesses Positive: 1 Negative: 0 Condition forall (fault(P0:L0,UndefinedInstruction) /\ fault(P0:L1,x,MMU:Translation) /\ fault(P0:L2,y,MMU:AccessFlag)) Observation A012 Always 1 0 Hash=fceea3352bd9a66e0ccf240f75a7e6f4 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A013.litmus000066400000000000000000000003401475314470400255560ustar00rootroot00000000000000AArch64 A013 Variant=faultToNext { [PTE(x)]=(valid:0); [PTE(y)]=(af:0); 0:X1=x; 0:X2=y; } P0 ; L0: ; UDF #0 ; L1: ; LDR W0,[X1] ; L2: ; LDR W0,[X2] ; forall(fault(P0)) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A013.litmus.expected000066400000000000000000000004041475314470400273570ustar00rootroot00000000000000Test A013 Required States 1 Fault(P0:L0,UndefinedInstruction); Fault(P0:L1,x,MMU:Translation); Fault(P0:L2,y,MMU:AccessFlag); Ok Witnesses Positive: 1 Negative: 0 Condition forall (fault(P0)) Observation A013 Always 1 0 Hash=3bb0ea14af4dd60a39e415c543a44f81 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A014.litmus000066400000000000000000000003651475314470400255660ustar00rootroot00000000000000AArch64 A014 Variant=faultToNext { [PTE(x)]=(valid:0); [PTE(y)]=(af:0); 0:X1=x; 0:X2=y; } P0 ; L0: ; UDF #0 ; L1: ; LDR W0,[X1] ; L2: ; LDR W0,[X2] ; forall(fault(P0,UndefinedInstruction)) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A014.litmus.expected000066400000000000000000000003321475314470400273600ustar00rootroot00000000000000Test A014 Required States 1 Fault(P0:L0,UndefinedInstruction); Ok Witnesses Positive: 1 Negative: 0 Condition forall (fault(P0,UndefinedInstruction)) Observation A014 Always 1 0 Hash=3bb0ea14af4dd60a39e415c543a44f81 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A015.litmus000066400000000000000000000003051475314470400255610ustar00rootroot00000000000000AArch64 A015 Variant=faultToNext { [PTE(x)]=(valid:0); [PTE(y)]=(af:0); 0:X1=x; 0:X2=y; } P0 ; UDF #0 ; LDR W0,[X1] ; LDR W0,[X2] ; forall(fault(P0,UndefinedInstruction)) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A015.litmus.expected000066400000000000000000000003271475314470400273650ustar00rootroot00000000000000Test A015 Required States 1 Fault(P0,UndefinedInstruction); Ok Witnesses Positive: 1 Negative: 0 Condition forall (fault(P0,UndefinedInstruction)) Observation A015 Always 1 0 Hash=5c03b2be21b0fa13dbc39816c24b39ef herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A016.litmus000066400000000000000000000002321475314470400255610ustar00rootroot00000000000000AArch64 A016 Variant=fatal { x=1; [PTE(x)]=(valid:0); 0:X1=x; } P0 ; L0: ; LDR W0,[X1] ; exists(fault(P0,UndefinedInstruction)) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A016.litmus.expected000066400000000000000000000003271475314470400273660ustar00rootroot00000000000000Test A016 Allowed States 1 ~Fault(P0,UndefinedInstruction); No Witnesses Positive: 0 Negative: 1 Condition exists (fault(P0,UndefinedInstruction)) Observation A016 Never 0 1 Hash=c7c806b44e223196ff70c5299d93ef93 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A017.litmus000066400000000000000000000005611475314470400255670ustar00rootroot00000000000000AArch64 A017 variant=fatal { int x=1 ; [PTE(x)]=(valid:0); 1:X0=x; 0:X0=PTE(x); 0:X1=(oa:PA(x),db:0); 0:X2=(oa:PA(x)); } P0 | P1 ; STR X1,[X0] | MOV W1,#1 ; STR X2,[X0] |L0: ; | STR W1,[X0]; locations [fault(P1:L0,x,MMU:Translation);] (* Fix a glitch: line "~Fault(P1:L0,x,MMU:Translation);" was occuring twice in output *)herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A017.litmus.expected000066400000000000000000000003401475314470400273620ustar00rootroot00000000000000Test A017 Required States 2 ~Fault(P1:L0,x,MMU:Translation); Fault(P1:L0,x,MMU:Translation); Ok Witnesses Positive: 3 Negative: 0 Condition forall (true) Observation A017 Always 3 0 Hash=83f44c15d73037901c1a990dcd68f0a4 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A018.litmus000066400000000000000000000003421475314470400255650ustar00rootroot00000000000000AArch64 A018 { [PTE(x)]=(valid:0); [x]=1; 0:X1=x; 0:X2=(valid:1, oa:PA(x)); 0:X3=PTE(x); } P0 | P0.F ; L0: | STR X2,[X3] ; LDR W0,[X1] | DSB ISHST ; | ERET ; forall(0:X0=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A018.litmus.expected000066400000000000000000000003271475314470400273700ustar00rootroot00000000000000Test A018 Required States 1 0:X0=1; Loop Ok Witnesses Positive: 1 Negative: 0 Flag Assuming-common-inner-shareable-domain Condition forall (0:X0=1) Observation A018 Always 1 0 Hash=218f088f0c448c84eeeb7c12fcb86c43 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A018.litmus.expected-warn000066400000000000000000000002021475314470400303250ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64.kvm/A018.litmus": unrolling limit exceeded at L0, legal outcomes may be missing. herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A019.litmus000066400000000000000000000002501475314470400255640ustar00rootroot00000000000000AArch64 A019 TTHM=P0:HD Variant=vmsa { 0:X1=x; 0:X2=7; 0:X0=42; TTD(x)=(oa:PA(x),db:0,dbm:1); } P0 ; CAS W0,W2,[X1] ; exists TTD(x)=(oa:PA(x),db:0,dbm:1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/A019.litmus.expected000066400000000000000000000003701475314470400273670ustar00rootroot00000000000000Test A019 Allowed States 2 [PTE(x)]=(oa:PA(x), db:0, dbm:1); [PTE(x)]=(oa:PA(x), dbm:1); Ok Witnesses Positive: 2 Negative: 3 Condition exists ([PTE(x)]=(oa:PA(x), db:0, dbm:1)) Observation A019 Sometimes 2 3 Hash=f45eee29aa2a126c7370f37a156463ea herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/F000.litmus000066400000000000000000000002331475314470400255600ustar00rootroot00000000000000AArch64 F000 Variant=fatal { int x=1; 0:X0=x; [PTE(x)]=(valid:0); } P0 ; ADD X0,X0,#0 ; L0: ; LDR W1,[X0] ; forall fault(P0:L0,x);herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/F000.litmus.expected000066400000000000000000000003071475314470400273620ustar00rootroot00000000000000Test F000 Required States 1 Fault(P0:L0,x,MMU:Translation); Ok Witnesses Positive: 1 Negative: 0 Condition forall (fault(P0:L0,x)) Observation F000 Always 1 0 Hash=fe8d2da69f8d807ca1e67749d58389ea herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/F001.litmus000066400000000000000000000004241475314470400255630ustar00rootroot00000000000000AArch64 F001 { int x=1; 0:X0=x; [PTE(x)]=(valid:0); } P0 | P0.F ; ADD X0,X0,#0 | MOV W2,#1 ; L0: | ADR X3,L1 ; LDR W1,[X0] | MSR ELR_EL1,X3 ; L1: | ERET ; MOV W4,#2 | ; forall 0:X2=1 /\ 0:X4=2herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/F001.litmus.expected000066400000000000000000000002701475314470400273620ustar00rootroot00000000000000Test F001 Required States 1 0:X2=1; 0:X4=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=1 /\ 0:X4=2) Observation F001 Always 1 0 Hash=b5c642a95c9e164933da1098ebb3bd25 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/F002.litmus000066400000000000000000000002401475314470400255600ustar00rootroot00000000000000AArch64 F002 Variant=fatal EL0=P0 { int x=1; 0:X0=x; [PTE(x)]=(el0:0); } P0 ; ADD X0,X0,#0 ; L0: ; LDR W1,[X0] ; forall fault(P0:L0,x);herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/F002.litmus.expected000066400000000000000000000003061475314470400273630ustar00rootroot00000000000000Test F002 Required States 1 Fault(P0:L0,x,MMU:Permission); Ok Witnesses Positive: 1 Negative: 0 Condition forall (fault(P0:L0,x)) Observation F002 Always 1 0 Hash=797831f79778fce447669af5b1b2ef4f herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/F003.litmus000066400000000000000000000003561475314470400255710ustar00rootroot00000000000000AArch64 F003 EL0=P0 { int x=1; 0:X0=x; [PTE(x)]=(el0:0); } P0 | P0.F ; ADD X0,X0,#0 | LDR W2,[X0] ; L0: | ADR X3,L1 ; LDR W1,[X0] | MSR ELR_EL1,X3 ; L1: | ERET ; forall 0:X2=1;herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/F003.litmus.expected000066400000000000000000000002461475314470400273670ustar00rootroot00000000000000Test F003 Required States 1 0:X2=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=1) Observation F003 Always 1 0 Hash=ab82c40f892da13f020a9c573e484f84 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.kvm/kvm.cfg000066400000000000000000000000151475314470400251700ustar00rootroot00000000000000variant kvm herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/000077500000000000000000000000001475314470400242275ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/A102.litmus000066400000000000000000000002501475314470400260660ustar00rootroot00000000000000AArch64 A102 (* strb immediate, with offset, symbolic location *) Variant=mixed { 0:x0=1; 0:x2=x; uint64_t x = 0; } P0; STRB W0, [X2, #4]; forall (x=4294967296) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/A102.litmus.expected000066400000000000000000000002701475314470400276700ustar00rootroot00000000000000Test A102 Required States 1 [x]=0x100000000; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=0x100000000) Observation A102 Always 1 0 Hash=554f95a88ee6ad0347f6ca1694bfc520 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/A104.litmus000066400000000000000000000002521475314470400260720ustar00rootroot00000000000000AArch64 A104 (* Strb register, with offset, symbolic location *) Variant=mixed { uint32_t x; 0:x0=1; 0:x2=x; 0:x3=1;} P0; STRB W0, [X2, X3]; forall (x=256 /\ y=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/A104.litmus.expected000066400000000000000000000003001475314470400276640ustar00rootroot00000000000000Test A104 Required States 1 [x]=0x100; [y]=0x0; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=0x100 /\ [y]=0x0) Observation A104 Always 1 0 Hash=2a2d0c7db89f18d0a0f72781c23d0dd0 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/A113.litmus000066400000000000000000000002321475314470400260700ustar00rootroot00000000000000AArch64 A113 (* strh immediate, with offset, symbolic location *) Variant=mixed { 0:x0=1; 0:x2=x; uint64_t x;} P0; STRH W0, [X2, #4]; forall (x=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/A113.litmus.expected000066400000000000000000000002571475314470400276770ustar00rootroot00000000000000Test A113 Required States 1 [x]=0x100000000; No Witnesses Positive: 0 Negative: 1 Condition forall ([x]=0x0) Observation A113 Never 0 1 Hash=4004151daf47c1c13517281d9010dc3e herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/A115.litmus000066400000000000000000000002321475314470400260720ustar00rootroot00000000000000AArch64 A115 (* Strh register, with offset, symbolic location *) { 0:x0=1; 0:x2=x; 0:x3=4; uint64_t x; } P0; STRH W0, [X2, X3]; forall (x=0 /\ y=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/A115.litmus.expected000066400000000000000000000003031475314470400276710ustar00rootroot00000000000000Test A115 Required States 1 [x]=0x100000000; [y]=0x0; No Witnesses Positive: 0 Negative: 1 Condition forall ([x]=0x0 /\ [y]=0x0) Observation A115 Never 0 1 Hash=b74dac0e2f2a48f8e95799037283f1e1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/A12.litmus000066400000000000000000000002211475314470400260040ustar00rootroot00000000000000AArch64 A12 (* Store immediate, with offset, symbolic location *) { int64_t x; 0:x0=1; 0:x2=x;} P0; STR W0, [X2, #4]; exists (x=4294967296) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/A12.litmus.expected000066400000000000000000000002651475314470400276140ustar00rootroot00000000000000Test A12 Allowed States 1 [x]=0x100000000; Ok Witnesses Positive: 1 Negative: 0 Condition exists ([x]=0x100000000) Observation A12 Always 1 0 Hash=86545e2af1a0880e99658d8d4d00c83c herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/A14.litmus000066400000000000000000000002421475314470400260110ustar00rootroot00000000000000AArch64 A14 (* Store register, with offset, symbolic location *) { uint64_t x; 0:x0=1; 0:x2=x; int64_t 0:x3=4;} P0; STR W0, [X2, X3]; exists (x=4294967296) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/A14.litmus.expected000066400000000000000000000002651475314470400276160ustar00rootroot00000000000000Test A14 Allowed States 1 [x]=0x100000000; Ok Witnesses Positive: 1 Negative: 0 Condition exists ([x]=0x100000000) Observation A14 Always 1 0 Hash=020d200946f57025e6078483a217d42c herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/A157.litmus000066400000000000000000000003321475314470400261010ustar00rootroot00000000000000AArch64 A157 (* Tests load acquire register, symbolic location, no offset*) (* Equivalent to A22 but testing mixed mode *) Variant=mixed { uint64_t 0:X0; 0:X1=x; uint64_t x; } P0; LDAR X0, [X1]; exists (0:X0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/A157.litmus.expected000066400000000000000000000002511475314470400277010ustar00rootroot00000000000000Test A157 Allowed States 1 0:X0=0x0; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=0x0) Observation A157 Always 1 0 Hash=12580598dd4d65a207378484b3c51242 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/A159.litmus000066400000000000000000000003351475314470400261060ustar00rootroot00000000000000AArch64 A159 (* Tests load exclusive register, symbolic location, no offset*) (* Equivalent to A24, but testing mixed mode *) Variant=mixed { uint64_t 0:X0; 0:X1=x; uint64_t x; } P0; LDXR X0, [X1]; forall (0:X0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/A159.litmus.expected000066400000000000000000000002521475314470400277040ustar00rootroot00000000000000Test A159 Required States 1 0:X0=0x0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=0x0) Observation A159 Always 1 0 Hash=7a373f975e0a3bf459b4577cada7f4df herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/A161.litmus000066400000000000000000000004171475314470400261000ustar00rootroot00000000000000AArch64 A161 (* Test load exclusive; Store exclusive, symbolic location *) (* Equivalent to A43 but testing mixed mode *) Variant=mixed { 0:X4=z; uint64_t z=2; } P0; LDXR X0, [X4]; ADD X0, X0, #1; STXR W3, X0, [X4]; forall ((z=2 /\ 0:X3=1) \/ (z=3 /\ 0:X3=0)) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/A161.litmus.expected000066400000000000000000000003501475314470400276740ustar00rootroot00000000000000Test A161 Required States 2 0:X3=0x0; [z]=0x3; 0:X3=0x1; [z]=0x2; Ok Witnesses Positive: 2 Negative: 0 Condition forall ([z]=0x2 /\ 0:X3=0x1 \/ [z]=0x3 /\ 0:X3=0x0) Observation A161 Always 2 0 Hash=801cdab07257d3e78999199f60244eb9 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/L033.litmus000077700000000000000000000000001475314470400313252../AArch64/L033.litmusustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/L033.litmus.expected000066400000000000000000000003741475314470400277130ustar00rootroot00000000000000Test L033 Required States 1 0:X0=0xffffffffffffffff; 0:X1=0xfffffffffffffffe; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=0xffffffffffffffff /\ 0:X1=0xfffffffffffffffe) Observation L033 Always 1 0 Hash=3965f0341290b70d2cf947b46046dd57 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/M000.litmus000066400000000000000000000004211475314470400260770ustar00rootroot00000000000000AArch64 M000 (* Does not work yet without option -debug mixed... *) { uint8_t t[4]; 0:X2=t; } P0 ; MOV W0,#1 ; STRB W0,[X2] ; MOV W0,#2 ; STRH W0,[X2,#2] ; LDR W1,[X2] ; locations [t;] forall t[0]=1 /\ t[1]=0 /\ t[2]=2 /\ 0:X1=0x20001 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/M000.litmus.expected000066400000000000000000000004111475314470400276760ustar00rootroot00000000000000Test M000 Required States 1 0:X1=0x20001; t={0x1,0x0,0x2,0x0}; t[0]=0x1; t[1]=0x0; t[2]=0x2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (t[0]=0x1 /\ t[1]=0x0 /\ t[2]=0x2 /\ 0:X1=0x20001) Observation M000 Always 1 0 Hash=17fa4fc37961f227ee4fd9d6623a3757 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/M001.litmus000066400000000000000000000003151475314470400261020ustar00rootroot00000000000000AArch64 M001 (* Test elementary size computation (also scanning initialisations) *) { uint8_t t[4]={ 0,0,0,0 }; 0:X2=t; } P0 ; MOV W0,#1 ; SUB W0,WZR,W0 ; STR W0,[X2] ; locations [t;] herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/M001.litmus.expected000066400000000000000000000002651475314470400277060ustar00rootroot00000000000000Test M001 Required States 1 t={0xff,0xff,0xff,0xff}; Ok Witnesses Positive: 1 Negative: 0 Condition forall (true) Observation M001 Always 1 0 Hash=192e33ccf5ce7ad96d47e0f528afd7e6 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/M002.litmus000066400000000000000000000002551475314470400261060ustar00rootroot00000000000000AArch64 M002 (* Tests STR barrel shifters *) { uint64_t x; 0:x0=1; 0:x2=x; int64_t 0:x3=1;} P0 ; STR W0, [X2, X3, LSL#2]; exists (x=4294967296) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/M002.litmus.expected000066400000000000000000000002671475314470400277110ustar00rootroot00000000000000Test M002 Allowed States 1 [x]=0x100000000; Ok Witnesses Positive: 1 Negative: 0 Condition exists ([x]=0x100000000) Observation M002 Always 1 0 Hash=822a4c2b0005fec10225b46de30bd2fe herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/M003.litmus000066400000000000000000000002541475314470400261060ustar00rootroot00000000000000AArch64 M003 (* Tests STR barrel shifters - LSL *) { uint64_t x; 0:x0=1; 0:x2=x; int64_t 0:x3=0;} P0 ; STR W0, [X2, X3, LSL#0]; exists (x=0x1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/M003.litmus.expected000066400000000000000000000002471475314470400277100ustar00rootroot00000000000000Test M003 Allowed States 1 [x]=0x1; Ok Witnesses Positive: 1 Negative: 0 Condition exists ([x]=0x1) Observation M003 Always 1 0 Hash=58679802d7cfe5367afbfae7eb94ca24 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/M004.litmus000066400000000000000000000002541475314470400261070ustar00rootroot00000000000000AArch64 M004 (* Tests STR barrel shifters - SXTW *) { uint64_t x; 0:x0=1; 0:x2=x; int32_t 0:x3=0;} P0 ; STR W0, [X2, W3, SXTW]; exists (x=0x1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/M004.litmus.expected000066400000000000000000000002471475314470400277110ustar00rootroot00000000000000Test M004 Allowed States 1 [x]=0x1; Ok Witnesses Positive: 1 Negative: 0 Condition exists ([x]=0x1) Observation M004 Always 1 0 Hash=1e61a83b6f7566c8526ca4540c009b2f herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/M005.litmus000066400000000000000000000002541475314470400261100ustar00rootroot00000000000000AArch64 M005 (* Tests STR barrel shifters - UXTW *) { uint64_t x; 0:x0=1; 0:x2=x; int32_t 0:x3=0;} P0 ; STR W0, [X2, W3, UXTW]; exists (x=0x1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/M005.litmus.expected000066400000000000000000000002471475314470400277120ustar00rootroot00000000000000Test M005 Allowed States 1 [x]=0x1; Ok Witnesses Positive: 1 Negative: 0 Condition exists ([x]=0x1) Observation M005 Always 1 0 Hash=2c1dc0ae671fb6f35401c54bde5b7845 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/M006.litmus000066400000000000000000000003271475314470400261120ustar00rootroot00000000000000AArch64 M006 (* Tests STR barrel shifters *) (* Same as M002 but using vectors*) { uint32_t x[2] = {2,2}; 0:x0=1; 0:x2=x; int64_t 0:x3=1;} P0 ; STR W0, [X2, X3, LSL#2]; exists (x={2,1}) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/M006.litmus.expected000066400000000000000000000002571475314470400277140ustar00rootroot00000000000000Test M006 Allowed States 1 x={0x2,0x1}; Ok Witnesses Positive: 1 Negative: 0 Condition exists (x={0x2,0x1}) Observation M006 Always 1 0 Hash=4d6e36211c150aee5ee2723464a442f6 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/M007.litmus000066400000000000000000000003371475314470400261140ustar00rootroot00000000000000AArch64 M007 (* LX/SX pair with same address but different sizes. Success is Constrained unpredictable *) { int x=0; 0:X0=x; } P0 ; MOV W3,#1 ; LDXRH W1,[X0] ; STXR W4,W3,[X0] ; forall x=0; herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/M007.litmus.expected000066400000000000000000000002501475314470400277060ustar00rootroot00000000000000Test M007 Required States 1 [x]=0x0; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=0x0) Observation M007 Always 1 0 Hash=864a185273e1e1e0538afaad1c74c38d herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/M008.litmus000066400000000000000000000006441475314470400261160ustar00rootroot00000000000000AArch64 M008 "PodWWPh0 Rfeh0h0 Amo.Cash0h0 PodWWh0P Coe" Orig=PodWWPh0 Rfeh0h0 Amo.Cash0h0 PodWWh0P Coe (* Test bug fixed by PR #296 *) { 0:X1=x; 0:X3=y; 1:X0=y; 1:X4=x; } P0 | P1 ; MOV W0,#2 | MOV W1,#257 ; STR W0,[X1] | MOV W2,#514 ; MOV W2,#257 | CASH W1,W2,[X0] ; STRH W2,[X3] | MOV W3,#1 ; | STR W3,[X4] ; exists ([x]=0x2 /\ [y]=0x202 /\ 1:X1=0x101) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/M008.litmus.expected000066400000000000000000000004701475314470400277130ustar00rootroot00000000000000Test M008 Allowed States 4 1:X1=0x0; [x]=0x1; [y]=0x101; 1:X1=0x0; [x]=0x2; [y]=0x101; 1:X1=0x101; [x]=0x1; [y]=0x202; 1:X1=0x101; [x]=0x2; [y]=0x202; Ok Witnesses Positive: 2 Negative: 8 Condition exists ([x]=0x2 /\ [y]=0x202 /\ 1:X1=0x101) Observation M008 Sometimes 2 8 Hash=dce7776cf1382a6e5b1afce5eab68a83 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.mixed/mixed.cfg000066400000000000000000000000301475314470400260070ustar00rootroot00000000000000variant mixed hexa true herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/000077500000000000000000000000001475314470400240605ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/NORUN000066400000000000000000000001321475314470400247000ustar00rootroot00000000000000#Syntax error V57 V58 #Uses ladp1 instruction V65 #Uses ldapur and stlur instructions V66 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V01.litmus000066400000000000000000000002741475314470400256700ustar00rootroot00000000000000AArch64 V01 (* Tests LD1/ST1 single structure with 8 bit lanes *) { uint8_t x=1; uint8_t y; 0:X0=x; 0:X1=y; } P0 ; LD1 {V0.B}[2],[X0] ; ST1 {V0.B}[2],[X1] ; forall(y=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V01.litmus.expected000066400000000000000000000002421475314470400274630ustar00rootroot00000000000000Test V01 Required States 1 [y]=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([y]=1) Observation V01 Always 1 0 Hash=9ec259d1bca8391f70cffb88eeb18d36 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V02.litmus000066400000000000000000000002631475314470400256670ustar00rootroot00000000000000AArch64 V02 (* Tests LD1/ST1 single structure with 32 bit lanes *) { uint32_t x=1; 0:X0=x; 0:X1=y; } P0 ; LD1 {V0.S}[2],[X0] ; ST1 {V0.S}[2],[X1] ; forall(y=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V02.litmus.expected000066400000000000000000000002421475314470400274640ustar00rootroot00000000000000Test V02 Required States 1 [y]=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([y]=1) Observation V02 Always 1 0 Hash=c435f21b565641f898dc5872d1326978 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V03.litmus000066400000000000000000000003021475314470400256620ustar00rootroot00000000000000AArch64 V03 (* Tests LD1/ST1 single structure with 8 bit lanes *) { uint8_t x=255; uint8_t y; 0:X0=x; 0:X1=y; } P0 ; LD1 {V0.B}[15],[X0] ; ST1 {V0.B}[15],[X1] ; forall(y=255) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V03.litmus.expected000066400000000000000000000002461475314470400274710ustar00rootroot00000000000000Test V03 Required States 1 [y]=255; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([y]=255) Observation V03 Always 1 0 Hash=1974f603ac6b11ee6293451696a82ab5 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V04.litmus000066400000000000000000000003651475314470400256740ustar00rootroot00000000000000AArch64 V04 (* Tests LD1 multiple structure *) { uint8_t x[8]={255,255,0,0,0,0,0,0}; uint8_t y; uint8_t z; 0:X0=x; 0:X1=y; 0:X2=z; } P0 ; LD1 {V0.8B},[X0] ; ST1 {V0.B}[0],[X1] ; ST1 {V0.B}[1],[X2] ; forall(y=255 /\ z=255) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V04.litmus.expected000066400000000000000000000002721475314470400274710ustar00rootroot00000000000000Test V04 Required States 1 [y]=255; [z]=255; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([y]=255 /\ [z]=255) Observation V04 Always 1 0 Hash=e6544e79cb649d1d42bed4b901f14bb3 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V05.litmus000066400000000000000000000003521475314470400256710ustar00rootroot00000000000000AArch64 V05 (* Tests LD1 multiple structure *) { uint8_t x[8]={255,0,0,0,0,0,0,0}; 0:X0=x; 0:X1=y; 0:X2=z; } P0 ; LD1 {V0.8B},[X0] ; ST1 {V0.B}[0],[X1] ; ST1 {V0.B}[8],[X2] ; forall(y=255 /\ z=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V05.litmus.expected000066400000000000000000000002661475314470400274750ustar00rootroot00000000000000Test V05 Required States 1 [y]=255; [z]=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([y]=255 /\ [z]=0) Observation V05 Always 1 0 Hash=0eef97914231a4a8a2c3019929588fbc herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V06.litmus000066400000000000000000000003601475314470400256710ustar00rootroot00000000000000AArch64 V06 (* Tests LD2 single structure *) { uint8_t x[2]={254,255}; 0:X0=x; 0:X1=y; 0:X2=z; } P0 ; LD2 {V0.B,V1.B}[0],[X0] ; ST1 {V0.B}[0],[X1] ; ST1 {V1.B}[0],[X2] ; forall(y=254 /\ z=255) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V06.litmus.expected000066400000000000000000000002721475314470400274730ustar00rootroot00000000000000Test V06 Required States 1 [y]=254; [z]=255; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([y]=254 /\ [z]=255) Observation V06 Always 1 0 Hash=fdf8b3c8a75fea5a28764852d32d6c96 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V07.litmus000066400000000000000000000006731475314470400257010ustar00rootroot00000000000000AArch64 V07 (* Tests LD3 single structure *) { uint8_t x[3]={254,255,0}; 0:X0=x; 0:X1=a; 0:X2=b; 0:X3=c; 0:X4=d; 0:X5=e; } P0 ; LD3 {V0.B,V1.B,V2.B}[1],[X0] ; LD2 {V3.B,V4.B}[0],[X0] ; ST1 {V0.B}[1],[X1] ; ST1 {V1.B}[1],[X2] ; ST1 {V2.B}[1],[X3] ; ST1 {V3.B}[0],[X4] ; ST1 {V4.B}[0],[X5] ; forall(a=254 /\ b=255 /\ c=0 /\ d=254 /\ e=255) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V07.litmus.expected000066400000000000000000000003621475314470400274740ustar00rootroot00000000000000Test V07 Required States 1 [a]=254; [b]=255; [c]=0; [d]=254; [e]=255; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([a]=254 /\ [b]=255 /\ [c]=0 /\ [d]=254 /\ [e]=255) Observation V07 Always 1 0 Hash=b624f7352a3fb9f499e5c2d7f2a87a00 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V08.litmus000066400000000000000000000002521475314470400256730ustar00rootroot00000000000000AArch64 V08 (* Tests load / store immediate, no offset *) { uint8_t x=1; uint8_t y; 0:X0=x; 0:X1=y } P0 ; LDR B0, [X0] ; STR B0, [X1] ; forall (y=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V08.litmus.expected000066400000000000000000000002421475314470400274720ustar00rootroot00000000000000Test V08 Required States 1 [y]=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([y]=1) Observation V08 Always 1 0 Hash=8aad4753b4fbb90fcb565ce80b183e71 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V09.litmus000066400000000000000000000002721475314470400256760ustar00rootroot00000000000000AArch64 V09 (* Tests load immediate, post-indexed *) { uint8_t x[2]={1,1}; 0:X0=x; 0:X1=y; } P0 ; LDR B0, [X0], #1 ; STR B0, [X0] ; forall (x[0]=1 /\ x[1]=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V09.litmus.expected000066400000000000000000000002661475314470400275010ustar00rootroot00000000000000Test V09 Required States 1 x[0]=1; x[1]=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (x[0]=1 /\ x[1]=1) Observation V09 Always 1 0 Hash=1e281d8019b889f9038b1947983be351 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V10.litmus000066400000000000000000000003561475314470400256710ustar00rootroot00000000000000AArch64 V10 (* Tests load / store immediate, with offset *) { uint64_t x[2]={0,0}; uint64_t y; 0:X0=x; 0:X2=y; } P0 ; MOV X1,#1 ; STR X1, [X0, #8] ; LDR D0, [X0, #8] ; STR D0, [X2] ; forall (y=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V10.litmus.expected000066400000000000000000000002421475314470400274630ustar00rootroot00000000000000Test V10 Required States 1 [y]=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([y]=1) Observation V10 Always 1 0 Hash=f687c365e5c1b2d38692593298e65664 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V11.litmus000066400000000000000000000003311475314470400256630ustar00rootroot00000000000000AArch64 V11 (* Tests store immediate, post-indexed *) { uint8_t a=1; uint8_t x[2]; 0:X0=a; 0:X1=x; } P0 ; LDR B0, [X0] ; STR B0, [X1], #1 ; STR B0, [X1] ; forall (x[0]=1 /\ x[1]=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V11.litmus.expected000066400000000000000000000002661475314470400274720ustar00rootroot00000000000000Test V11 Required States 1 x[0]=1; x[1]=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (x[0]=1 /\ x[1]=1) Observation V11 Always 1 0 Hash=8579c47ba1b0ede48f2da0d31f4ad971 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V12.litmus000066400000000000000000000003701475314470400256670ustar00rootroot00000000000000AArch64 V12 (* Tests LD1R, no offset *) { uint64_t x=1; 0:X0=x;0:X1=y; 0:X2=z; 0:X3=a; } P0 ; LD1R {V0.2S}, [X0] ; ST1 {V0.S}[0], [X1] ; ST1 {V0.S}[1], [X2] ; ST1 {V0.S}[2], [X3] ; forall (y=1 /\ z=1 /\ a=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V12.litmus.expected000066400000000000000000000003021475314470400274620ustar00rootroot00000000000000Test V12 Required States 1 [a]=0; [y]=1; [z]=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([y]=1 /\ [z]=1 /\ [a]=0) Observation V12 Always 1 0 Hash=10f848be208c3461171aba83166de18b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V13.litmus000066400000000000000000000005611475314470400256720ustar00rootroot00000000000000AArch64 V13 (* Tests LD2R, no offset *) { uint8_t x[2]={255,1}; uint8_t y; uint8_t z; uint8_t a; uint8_t b; 0:X0=x;0:X1=y; 0:X2=z; 0:X3=a; 0:X4=b; } P0 ; LD2R {V0.8B,V1.8B}, [X0] ; ST1 {V0.B}[0], [X1] ; ST1 {V0.B}[7], [X2] ; ST1 {V1.B}[0], [X3] ; ST1 {V1.B}[7], [X4] ; forall (y=255 /\ z=255 /\ a=1 /\ b=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V13.litmus.expected000066400000000000000000000003321475314470400274660ustar00rootroot00000000000000Test V13 Required States 1 [a]=1; [b]=1; [y]=255; [z]=255; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([y]=255 /\ [z]=255 /\ [a]=1 /\ [b]=1) Observation V13 Always 1 0 Hash=9702dfa0827f4778b5f3774c0edd94f8 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V14.litmus000066400000000000000000000004171475314470400256730ustar00rootroot00000000000000AArch64 V14 (* Tests MOVI 8 bit no shift *) { uint8_t x; uint8_t y; uint8_t z; 0:X0=x;0:X1=y; 0:X2=z; } P0 ; MOVI V0.8B,#1 ; ST1 {V0.B}[0], [X0] ; ST1 {V0.B}[7], [X1] ; ST1 {V1.B}[8], [X2] ; forall (x=1 /\ y=1 /\ z=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V14.litmus.expected000066400000000000000000000003021475314470400274640ustar00rootroot00000000000000Test V14 Required States 1 [x]=1; [y]=1; [z]=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=1 /\ [y]=1 /\ [z]=0) Observation V14 Always 1 0 Hash=b480c51a41848ef4a92be165ad9b032f herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V15.litmus000066400000000000000000000003161475314470400256720ustar00rootroot00000000000000AArch64 V15 (* Tests MOVI scalar variant *) { uint8_t x; uint8_t y; 0:X0=x;0:X1=y; } P0 ; MOVI D0,#255 ; ST1 {V0.B}[0], [X0] ; ST1 {V0.B}[1], [X1] ; forall (x=255 /\ y=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V15.litmus.expected000066400000000000000000000002661475314470400274760ustar00rootroot00000000000000Test V15 Required States 1 [x]=255; [y]=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=255 /\ [y]=0) Observation V15 Always 1 0 Hash=704364f237c8863040541c2bb52b8b94 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V16.litmus000066400000000000000000000004751475314470400257010ustar00rootroot00000000000000AArch64 V16 (* Tests MOVI 64-bit variant *) { uint8_t x; uint8_t y; uint8_t z; uint8_t a; 0:X0=x;0:X1=y;0:X2=z;0:X3=a; } P0 ; MOVI V0.2D,#255 ; ST1 {V0.B}[0], [X0] ; ST1 {V0.B}[1], [X1] ; ST1 {V0.B}[8], [X2] ; ST1 {V0.B}[9], [X3] ; forall (x=255 /\ y=0 /\ z=255 /\ a=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V16.litmus.expected000066400000000000000000000003321475314470400274710ustar00rootroot00000000000000Test V16 Required States 1 [a]=0; [x]=255; [y]=0; [z]=255; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=255 /\ [y]=0 /\ [z]=255 /\ [a]=0) Observation V16 Always 1 0 Hash=58dbfa0a0bd0a96666e6cf6ab431f3fb herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V17.litmus000066400000000000000000000004621475314470400256760ustar00rootroot00000000000000AArch64 V17 (* Tests MOV element *) { uint8_t x; uint8_t y; uint8_t z; 0:X0=x;0:X1=y;0:X2=z; } P0 ; MOVI V0.8B,#1 ; MOV V1.B[0], V0.B[0] ; MOV V1.B[1], V0.B[7] ; ST1 {V1.B}[0], [X0] ; ST1 {V1.B}[1], [X1] ; ST1 {V1.B}[2], [X2] ; forall (x=1 /\ y=1 /\ z=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V17.litmus.expected000066400000000000000000000003021475314470400274670ustar00rootroot00000000000000Test V17 Required States 1 [x]=1; [y]=1; [z]=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=1 /\ [y]=1 /\ [z]=0) Observation V17 Always 1 0 Hash=8be250a1589ff4af5f657befc66bb1fc herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V18.litmus000066400000000000000000000003771475314470400257040ustar00rootroot00000000000000AArch64 V18 (* Tests MOV from general *) { uint32_t x=1; uint8_t y; uint8_t z; 0:X0=x;0:X1=y;0:X2=z; } P0 ; LDR W3,[X0] ; MOV V0.B[0],W3 ; ST1 {V0.B}[0], [X1] ; ST1 {V0.B}[1], [X2] ; forall (y=1 /\ z=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V18.litmus.expected000066400000000000000000000002621475314470400274750ustar00rootroot00000000000000Test V18 Required States 1 [y]=1; [z]=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([y]=1 /\ [z]=0) Observation V18 Always 1 0 Hash=678beb476ce9c84d94ae250f177635de herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V19.litmus000066400000000000000000000004301475314470400256730ustar00rootroot00000000000000AArch64 V19 (* Tests MOV vector *) { uint8_t x; uint8_t y; uint8_t z; 0:X0=x;0:X1=y; 0:X2=z; } P0 ; MOVI V0.8B,#1 ; MOV V1.8B,V0.8B ; ST1 {V1.B}[0], [X0] ; ST1 {V1.B}[7], [X1] ; ST1 {V1.B}[8], [X2] ; forall (x=1 /\ y=1 /\ z=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V19.litmus.expected000066400000000000000000000003021475314470400274710ustar00rootroot00000000000000Test V19 Required States 1 [x]=1; [y]=1; [z]=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=1 /\ [y]=1 /\ [z]=0) Observation V19 Always 1 0 Hash=65d078abec8ff979af7283d4ee0e3785 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V20.litmus000066400000000000000000000002271475314470400256670ustar00rootroot00000000000000AArch64 V20 (* Tests MOV to general *) { } P0 ; MOVI V0.2S,#1 ; MOV W0,V0.S[0] ; MOV W1,V0.S[1] ; forall (0:X0=1 /\ 0:X1=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V20.litmus.expected000066400000000000000000000002661475314470400274720ustar00rootroot00000000000000Test V20 Required States 1 0:X0=1; 0:X1=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=1 /\ 0:X1=1) Observation V20 Always 1 0 Hash=9757abe712a4d6d4faf4becce89c26a6 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V21.litmus000066400000000000000000000005101475314470400256630ustar00rootroot00000000000000AArch64 V21 (* Tests MOV scalar *) { uint8_t x; uint8_t y; uint8_t z; 0:X0=x;0:X1=y;0:X2=z; } P0 ; MOVI V0.8B,#1 ; MOV B1,V0.8B[0] ; MOV B2,V0.8B[1] ; MOV B3,V0.8B[8] ; ST1 {V1.B}[0],[X0] ; ST1 {V2.B}[0],[X1] ; ST1 {V3.B}[0],[X2] ; forall (x=1 /\ y=1 /\ z=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V21.litmus.expected000066400000000000000000000003021475314470400274620ustar00rootroot00000000000000Test V21 Required States 1 [x]=1; [y]=1; [z]=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=1 /\ [y]=1 /\ [z]=0) Observation V21 Always 1 0 Hash=05146534366d427476fe882231ac3799 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V22.litmus000066400000000000000000000004151475314470400256700ustar00rootroot00000000000000AArch64 V22 (* Tests LD2 multiple structure *) { uint8_t x[16]={255,255,0,0,0,0,0,0,0,0,0,0,0,0,0,0}; uint8_t y; uint8_t z; 0:X0=x; 0:X1=y; 0:X2=z; } P0 ; LD2 {V0.8B,V1.8B},[X0] ; ST1 {V0.B}[0],[X1] ; ST1 {V1.B}[0],[X2] ; forall(y=255 /\ z=255) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V22.litmus.expected000066400000000000000000000002721475314470400274710ustar00rootroot00000000000000Test V22 Required States 1 [y]=255; [z]=255; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([y]=255 /\ [z]=255) Observation V22 Always 1 0 Hash=486b4c600472a2d1443e460e52bbe16a herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V23.litmus000066400000000000000000000005611475314470400256730ustar00rootroot00000000000000AArch64 V23 (* Tests ST2 multiple structure *) { uint32_t b[4]; 0:X1=x;0:X2=y;0:X3=z;0:X4=a;0:X0=b; } P0 ; MOVI V0.2S,#1 ; MOVI V1.2S,#1 ; ST2 {V0.2S,V1.2S},[X0] ; LD1 {V2.4S},[X0] ; ST1 {V2.S}[0],[X1] ; ST1 {V2.S}[1],[X2] ; ST1 {V2.S}[2],[X3] ; ST1 {V2.S}[3],[X4] ; forall(x=1 /\ y=1 /\ z=1 /\ a=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V23.litmus.expected000066400000000000000000000003221475314470400274660ustar00rootroot00000000000000Test V23 Required States 1 [a]=1; [x]=1; [y]=1; [z]=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=1 /\ [y]=1 /\ [z]=1 /\ [a]=1) Observation V23 Always 1 0 Hash=2ead36775b1b81664fc1036e3ff0673e herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V34.litmus000066400000000000000000000002651475314470400256760ustar00rootroot00000000000000AArch64 V34 (* Test Neon final state checking LD1 single structure *) { uint32_t x=22; 0:X0=x; } P0 ; LD1 {V0.S}[0],[X0] ; forall(0:V0.4S = {22,0,0,0}) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V34.litmus.expected000066400000000000000000000002741475314470400274760ustar00rootroot00000000000000Test V34 Required States 1 0:V0.4S={22,0,0,0}; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:V0.4S={22,0,0,0}) Observation V34 Always 1 0 Hash=18ad18350b76783bb8c477e0b66d1722 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V35.litmus000066400000000000000000000002541475314470400256750ustar00rootroot00000000000000AArch64 V35 (* Test Neon final state checking LD1 single structure *) { x=22; 0:X0=x; } P0 ; LD1 {V0.S}[3],[X0] ; forall(0:V0.4S = {0,0,0,22}) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V35.litmus.expected000066400000000000000000000002741475314470400274770ustar00rootroot00000000000000Test V35 Required States 1 0:V0.4S={0,0,0,22}; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:V0.4S={0,0,0,22}) Observation V35 Always 1 0 Hash=91d6e72e5d29f2cdcef7c69831b69a3a herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V36.litmus000066400000000000000000000004271475314470400257000ustar00rootroot00000000000000AArch64 V36 (* Test Neon final state checking LD2 single structure *) { uint32_t x[2]={22,0}; 0:X0=x; } P0 ; MOV W1,#1 ; STR W1,[X0,#4] ; LD2 {V0.S,V1.S}[0],[X0] ; forall(0:V0.4S = {22,0,0,0} /\ 0:V1.4S = {1,0,0,0}) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V36.litmus.expected000066400000000000000000000003441475314470400274760ustar00rootroot00000000000000Test V36 Required States 1 0:V0.4S={22,0,0,0}; 0:V1.4S={1,0,0,0}; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:V0.4S={22,0,0,0} /\ 0:V1.4S={1,0,0,0}) Observation V36 Always 1 0 Hash=03b6492afc8ab7292f7f54f733cf0825 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V37.litmus000066400000000000000000000006011475314470400256730ustar00rootroot00000000000000AArch64 V37 (* Test Neon final state checking LD1 multiple structure *) { uint32_t x[4] = {22,0,0,0}; 0:X0=x; } P0 ; MOV W1,#1 ; STR W1,[X0,#4] ; MOV W1,#5 ; STR W1,[X0,#8] ; MOV W1,#44 ; STR W1,[X0,#12] ; LD1 {V0.4S},[X0] ; forall(0:V0.4S = {22,1,5,44}) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V37.litmus.expected000066400000000000000000000002761475314470400275030ustar00rootroot00000000000000Test V37 Required States 1 0:V0.4S={22,1,5,44}; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:V0.4S={22,1,5,44}) Observation V37 Always 1 0 Hash=889f7f18abd9c86bcc4d7b4bda2e86c7 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V38.litmus000066400000000000000000000003761475314470400257050ustar00rootroot00000000000000AArch64 V38 (* Test EOR (vector) *) { uint8_t x; uint8_t y; 0:X0=x; 0:X1=y; } P0; MOVI V0.8B,#1 ; MOVI V1.8B,#2 ; EOR V2.8B, V0.8B, V1.8B ; ST1 {V2.B}[0],[X0] ; ST1 {V2.B}[9],[X1] ; forall (x=3 /\ y=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V38.litmus.expected000066400000000000000000000002621475314470400274770ustar00rootroot00000000000000Test V38 Required States 1 [x]=3; [y]=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=3 /\ [y]=0) Observation V38 Always 1 0 Hash=aeb398354ec5575a5e6fdfd49869639c herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V39.litmus000066400000000000000000000003631475314470400257020ustar00rootroot00000000000000AArch64 V39 (* Test ADD (vector, scalar variant) *) { uint64_t x=1; uint64_t y=2; uint64_t z; 0:X0=x; 0:X1=y; 0:X2=z; } P0; LD1 {V0.D}[0],[X0] ; LD1 {V1.D}[0],[X1] ; ADD D2,D0,D1 ; STR D2,[X2] ; forall (z=3) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V39.litmus.expected000066400000000000000000000002421475314470400274760ustar00rootroot00000000000000Test V39 Required States 1 [z]=3; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([z]=3) Observation V39 Always 1 0 Hash=3bf51624352b685a680c2d5656d161ee herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V40.litmus000066400000000000000000000004241475314470400256700ustar00rootroot00000000000000AArch64 V40 (* Test ADD (vector, vector variant) *) { uint8_t x; uint8_t y; 0:X0=x; 0:X1=y; } P0; MOVI V0.8B,#1 ; MOVI V1.8B,#8 ; MOVI V2.8B,#0 ; ADD V2.8B,V0.8B,V1.8B ; ST1 {V2.B}[0],[X0] ; ST1 {V2.B}[9],[X1] ; forall (x=9 /\ y=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V40.litmus.expected000066400000000000000000000002621475314470400274700ustar00rootroot00000000000000Test V40 Required States 1 [x]=9; [y]=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=9 /\ [y]=0) Observation V40 Always 1 0 Hash=e838e06aed7899fef86b138f4ed09516 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V41.litmus000066400000000000000000000004741475314470400256760ustar00rootroot00000000000000AArch64 V41 (* Tests LDP - load pair without offset *) { uint32_t x[2]; uint32_t y; uint32_t z; 0:X0=x; 0:X1=y; 0:X2=z; 0:X3=1; 0:X4=2; } P0 ; STR W3, [X0] ; STR W4, [X0, #4] ; LDP S0, S1, [X0] ; STR S0, [X1] ; STR S1, [X2] ; forall (y=1 /\ z=2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V41.litmus.expected000066400000000000000000000002621475314470400274710ustar00rootroot00000000000000Test V41 Required States 1 [y]=1; [z]=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([y]=1 /\ [z]=2) Observation V41 Always 1 0 Hash=2c8fd07f253618e025eb7afba380300d herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V42.litmus000066400000000000000000000004701475314470400256730ustar00rootroot00000000000000AArch64 V42 (* Tests LDP - load pair with offset *) { uint32_t x[3]; uint32_t y; uint32_t z; 0:X0=x; 0:X1=y; 0:X2=z; 0:X3=1; 0:X4=2; } P0 ; STR W3, [X0, #4] ; STR W4, [X0, #8] ; LDP S0, S1, [X0, #4] ; STR S0, [X1] ; STR S1, [X2] ; forall (y=1 /\ z=2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V42.litmus.expected000066400000000000000000000002621475314470400274720ustar00rootroot00000000000000Test V42 Required States 1 [y]=1; [z]=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([y]=1 /\ [z]=2) Observation V42 Always 1 0 Hash=51c5ef1d6f66e78fa2fe5c1a847a6241 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V43.litmus000066400000000000000000000005571475314470400257020ustar00rootroot00000000000000AArch64 V43 (* Tests LDP - load pair, post-indexed *) { uint32_t x[3]; uint32_t y; uint32_t z; 0:X0=x; 0:X1=y; 0:X2=z; 0:X3=1; 0:X4=2; } P0 ; STR W3, [X0] ; STR W4, [X0, #4] ; LDP S0, S1, [X0], #4 ; STR S0, [X1] ; STR S1, [X2] ; SUB X0,X0,#4 ; (* For litmus *) forall (0:X0=x /\ y=1 /\ z=2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V43.litmus.expected000066400000000000000000000003041475314470400274700ustar00rootroot00000000000000Test V43 Required States 1 0:X0=x; [y]=1; [z]=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=x /\ [y]=1 /\ [z]=2) Observation V43 Always 1 0 Hash=c4e1b018b4ba682ad25dea1aee9e10bd herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V44.litmus000066400000000000000000000003411475314470400256720ustar00rootroot00000000000000AArch64 V44 (* Tests STP - store pair without offset *) { uint64_t x[2]; 0:X0=x; } P0 ; MOVI D0, #65535 ; MOVI D1, #255 ; STP D0, D1, [X0] ; exists (x[0]=65535 /\ x[1]=255) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V44.litmus.expected000066400000000000000000000003011475314470400274660ustar00rootroot00000000000000Test V44 Allowed States 1 x[0]=65535; x[1]=255; Ok Witnesses Positive: 1 Negative: 0 Condition exists (x[0]=65535 /\ x[1]=255) Observation V44 Always 1 0 Hash=defbf9207549dbd82105c6b6cc0dc38b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V45.litmus000066400000000000000000000005401475314470400256740ustar00rootroot00000000000000AArch64 V45 (* Tests STP - store pair, post-indexed *) { uint64_t x[2]; uint64_t y; 0:X0=x; 0:X1=y; } P0 ; MOVI D0, #65535 ; MOVI D1, #255 ; STP D0, D1, [X0], #-8 ; LDR D2, [X0, #16] ; STR D2, [X1] ; ADD X0,X0,#8 ; (* For litmus *) forall (x={65535,255} /\ y=255 /\ 0:X0=x) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V45.litmus.expected000066400000000000000000000003301475314470400274710ustar00rootroot00000000000000Test V45 Required States 1 0:X0=x; x={65535,255}; [y]=255; Ok Witnesses Positive: 1 Negative: 0 Condition forall (x={65535,255} /\ [y]=255 /\ 0:X0=x) Observation V45 Always 1 0 Hash=ac44a31cce026ff27e9edef537af099f herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V46.litmus000066400000000000000000000004131475314470400256740ustar00rootroot00000000000000AArch64 V46 (* Tests LD1/ST1 single structure, post-indexed immediate offset *) { uint32_t x[3]={0,0,32}; 0:X0=x; } P0 ; LD1 {V0.S}[0],[X0],#4 ; ST1 {V0.S}[0],[X0],#4 ; LDR W1,[X0] ; SUB X0,X0,#8 ; forall(0:X1=32 /\ 0:X0=x) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V46.litmus.expected000066400000000000000000000002701475314470400274750ustar00rootroot00000000000000Test V46 Required States 1 0:X0=x; 0:X1=32; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=32 /\ 0:X0=x) Observation V46 Always 1 0 Hash=a174615745f6a26b576573ddf9071944 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V47.litmus000066400000000000000000000004531475314470400257010ustar00rootroot00000000000000AArch64 V47 (* Tests LD1/ST1 single structure, post-indexed register offset *) { uint32_t x[3]={0,0,32}; 0:X0=x; int64_t 0:X1=4; } P0 ; LD1 {V0.S}[0],[X0],X1 ; ST1 {V0.S}[0],[X0],X1 ; LDR W2,[X0] ; SUB X0,X0,#8 ; (* For litmus *) forall(0:X2=32 /\ 0:X0=x) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V47.litmus.expected000066400000000000000000000002701475314470400274760ustar00rootroot00000000000000Test V47 Required States 1 0:X0=x; 0:X2=32; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=32 /\ 0:X0=x) Observation V47 Always 1 0 Hash=8c0a05664c81098387cdbd76a20395a3 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V48.litmus000066400000000000000000000004121475314470400256750ustar00rootroot00000000000000AArch64 V48 (* Tests 128-bit Neon loads *) { uint64_t x[2] = {1, 2}; uint64_t* 0:X0 = &x; uint64_t 0:X1; uint64_t 0:X2; uint128_t 0:V0.2D; } P0 ; LDR Q0, [X0] ; MOV X1, V0.D[0] ; MOV X2, V0.D[1] ; forall(0:X1 = 1 /\ 0:X2 = 2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V48.litmus.expected000066400000000000000000000002661475314470400275040ustar00rootroot00000000000000Test V48 Required States 1 0:X1=1; 0:X2=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=1 /\ 0:X2=2) Observation V48 Always 1 0 Hash=035c21a806594e9692c65c9480a3ba1b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V49.litmus000066400000000000000000000004121475314470400256760ustar00rootroot00000000000000AArch64 V49 (* Tests 128-bit Neon stores *) { uint64_t x[2]; uint64_t* 0:X0 = &x; uint64_t 0:X1 = 1; uint64_t 0:X2 = 2; uint128_t 0:V0.2D; } P0 ; MOV V0.D[0], X1 ; MOV V0.D[1], X2 ; STR Q0, [X0] ; forall(x[0] = 1 /\ x[1] = 2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V49.litmus.expected000066400000000000000000000002661475314470400275050ustar00rootroot00000000000000Test V49 Required States 1 x[0]=1; x[1]=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (x[0]=1 /\ x[1]=2) Observation V49 Always 1 0 Hash=6872bf22c202f59b9322af74d54ce4ad herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V50.litmus000066400000000000000000000006261475314470400256750ustar00rootroot00000000000000AArch64 V50 (* Tests 128-bit Neon pair stores *) { uint64_t x[4]; uint64_t* 0:X0 = &x; uint64_t 0:X1 = 1; uint64_t 0:X2 = 2; uint64_t 0:X3 = 3; uint64_t 0:X4 = 4; uint128_t 0:V0.2D; uint128_t 0:V1.2D; } P0 ; MOV V0.D[0], X1 ; MOV V0.D[1], X2 ; MOV V1.D[0], X3 ; MOV V1.D[1], X4 ; STP Q0, Q1, [X0] ; forall(x[0] = 1 /\ x[1] = 2 /\ x[2] = 3 /\ x[3] = 4) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V50.litmus.expected000066400000000000000000000003321475314470400274670ustar00rootroot00000000000000Test V50 Required States 1 x[0]=1; x[1]=2; x[2]=3; x[3]=4; Ok Witnesses Positive: 1 Negative: 0 Condition forall (x[0]=1 /\ x[1]=2 /\ x[2]=3 /\ x[3]=4) Observation V50 Always 1 0 Hash=7abaa3850bcb60f7bc0413b94368909e herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V51.litmus000066400000000000000000000006251475314470400256750ustar00rootroot00000000000000AArch64 V51 (* Tests 128-bit Neon pair stores *) { uint64_t x[4] = {1, 2, 3, 4}; uint64_t* 0:X0 = &x; uint64_t 0:X1; uint64_t 0:X2; uint64_t 0:X3; uint64_t 0:X4; uint128_t 0:V0.2D; uint128_t 0:V1.2D; } P0 ; LDP Q0, Q1, [X0] ; MOV X1, V0.D[0] ; MOV X2, V0.D[1] ; MOV X3, V1.D[0] ; MOV X4, V1.D[1] ; forall(0:X1 = 1 /\ 0:X2 = 2 /\ 0:X3 = 3 /\ 0:X4 = 4) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V51.litmus.expected000066400000000000000000000003321475314470400274700ustar00rootroot00000000000000Test V51 Required States 1 0:X1=1; 0:X2=2; 0:X3=3; 0:X4=4; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=1 /\ 0:X2=2 /\ 0:X3=3 /\ 0:X4=4) Observation V51 Always 1 0 Hash=1e4ecd994b4d2bcda31e934a277858e2 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V52.litmus000066400000000000000000000005421475314470400256740ustar00rootroot00000000000000AArch64 V52 (* Tests 128-bit Neon loads with post-increment *) { uint64_t x[2] = {1, 2}; uint64_t* 0:X0 = &x; uint64_t 0:X1; uint64_t 0:X2; uint128_t 0:V0.2D; uint128_t 0:V1.2D; } P0 ; LDR Q0, [X0], #16 ; MOV X1, V0.D[0] ; MOV X2, V0.D[1] ; ADD X0, X0, #-16 ; forall(0:X1 = 1 /\ 0:X2 = 2 /\ 0:X0 = x) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V52.litmus.expected000066400000000000000000000003101475314470400274650ustar00rootroot00000000000000Test V52 Required States 1 0:X0=x; 0:X1=1; 0:X2=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=1 /\ 0:X2=2 /\ 0:X0=x) Observation V52 Always 1 0 Hash=285b569b324f36721060d6dfbbb8748a herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V53.litmus000066400000000000000000000005351475314470400256770ustar00rootroot00000000000000AArch64 V53 (* Tests 128-bit Neon stores with post-increment *) { uint64_t x[2]; uint64_t* 0:X0 = &x; uint64_t 0:X1 = 1; uint64_t 0:X2 = 2; uint128_t 0:V0.2D; uint128_t 0:V1.2D; } P0 ; MOV V0.D[0], X1 ; MOV V0.D[1], X2 ; STR Q0, [X0], #16 ; ADD X0, X0, #-16 ; forall(x[0] = 1 /\ x[1] = 2 /\ 0:X0 = x) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V53.litmus.expected000066400000000000000000000003101475314470400274660ustar00rootroot00000000000000Test V53 Required States 1 0:X0=x; x[0]=1; x[1]=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (x[0]=1 /\ x[1]=2 /\ 0:X0=x) Observation V53 Always 1 0 Hash=9251f6b3063469d8a1911781f0e5a546 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V54.litmus000066400000000000000000000007521475314470400257010ustar00rootroot00000000000000AArch64 V54 (* Tests 128-bit Neon pair loads with post-increment *) { uint64_t x[4] = {1, 2, 3, 4}; uint64_t* 0:X0 = &x; uint64_t 0:X1; uint64_t 0:X2; uint64_t 0:X3; uint64_t 0:X4; uint128_t 0:V0.2D; uint128_t 0:V1.2D; } P0 ; LDP Q0, Q1, [X0], #16 ; MOV X1, V0.D[0] ; MOV X2, V0.D[1] ; MOV X3, V1.D[0] ; MOV X4, V1.D[1] ; ADD X0, X0, #-16 ; forall(0:X1 = 1 /\ 0:X2 = 2 /\ 0:X3 = 3 /\ 0:X4 = 4 /\ 0:X0 = x) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V54.litmus.expected000066400000000000000000000003541475314470400274770ustar00rootroot00000000000000Test V54 Required States 1 0:X0=x; 0:X1=1; 0:X2=2; 0:X3=3; 0:X4=4; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=1 /\ 0:X2=2 /\ 0:X3=3 /\ 0:X4=4 /\ 0:X0=x) Observation V54 Always 1 0 Hash=f3ee4446b60115a1888b7e1cc47e14a6 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V55.litmus000066400000000000000000000007721475314470400257040ustar00rootroot00000000000000AArch64 V55 (* Tests 128-bit Neon pair loads with post-increment *) { uint64_t x[4] = {1, 2, 3, 4}; uint64_t* 0:X0 = &x; uint64_t 0:X1 = 1; uint64_t 0:X2 = 2; uint64_t 0:X3 = 3; uint64_t 0:X4 = 4; uint128_t 0:V0.2D; uint128_t 0:V1.2D; } P0 ; MOV V0.D[0], X1 ; MOV V0.D[1], X2 ; MOV V1.D[0], X3 ; MOV V1.D[1], X4 ; STP Q0, Q1, [X0], #16 ; ADD X0, X0, #-16 ; forall(x[0] = 1 /\ x[1] = 2 /\ x[2] = 3 /\ x[3] = 4 /\ 0:X0 = x) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V55.litmus.expected000066400000000000000000000003541475314470400275000ustar00rootroot00000000000000Test V55 Required States 1 0:X0=x; x[0]=1; x[1]=2; x[2]=3; x[3]=4; Ok Witnesses Positive: 1 Negative: 0 Condition forall (x[0]=1 /\ x[1]=2 /\ x[2]=3 /\ x[3]=4 /\ 0:X0=x) Observation V55 Always 1 0 Hash=c23c33d1de5adc9094f5b03bae2c1cdb herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V56.litmus000066400000000000000000000014751475314470400257060ustar00rootroot00000000000000AArch64 V56 "An 128-bit store need not be SCA in its entirety" { uint64_t x[2]; uint64_t* 0:X0 = &x; uint64_t* 1:X0 = &x; uint64_t* 2:X0 = &x; uint128_t 0:V0.2D = 0; uint64_t 0:X1 = 1; uint64_t 0:X2 = 2; uint64_t 1:X1; uint64_t 1:X2; uint64_t 2:X1; uint64_t 2:X2; } (* If a 128-bit SIMD store was SCA, then for two 64-bit loads with a load * barrier inbetween, if the first load observed part of the store, then the * other load should also observe the "other" part of the store *) P0 | P1 | P2 ; MOV V0.D[0], X1 | LDR X1, [X0] | LDR X2, [X0, #8] ; MOV V0.D[1], X2 | DMB ISHLD | DMB ISHLD ; STR Q0, [X0] | LDR X2, [X0, #8] | LDR X1, [X0] ; exists( (1:X1 = 1 /\ 1:X2 != 2) \/ (2:X2 = 2 /\ 2:X1 != 1) ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V56.litmus.expected000066400000000000000000000013251475314470400275000ustar00rootroot00000000000000Test V56 Allowed States 15 1:X1=0; 1:X2=0; 2:X1=0; 2:X2=0; 1:X1=0; 1:X2=0; 2:X1=0; 2:X2=2; 1:X1=0; 1:X2=0; 2:X1=1; 2:X2=0; 1:X1=0; 1:X2=0; 2:X1=1; 2:X2=2; 1:X1=0; 1:X2=2; 2:X1=0; 2:X2=0; 1:X1=0; 1:X2=2; 2:X1=0; 2:X2=2; 1:X1=0; 1:X2=2; 2:X1=1; 2:X2=0; 1:X1=0; 1:X2=2; 2:X1=1; 2:X2=2; 1:X1=1; 1:X2=0; 2:X1=0; 2:X2=0; 1:X1=1; 1:X2=0; 2:X1=1; 2:X2=0; 1:X1=1; 1:X2=0; 2:X1=1; 2:X2=2; 1:X1=1; 1:X2=2; 2:X1=0; 2:X2=0; 1:X1=1; 1:X2=2; 2:X1=0; 2:X2=2; 1:X1=1; 1:X2=2; 2:X1=1; 2:X2=0; 1:X1=1; 1:X2=2; 2:X1=1; 2:X2=2; Ok Witnesses Positive: 6 Negative: 9 Flag Assuming-common-inner-shareable-domain Condition exists (1:X1=1 /\ not (1:X2=2) \/ 2:X2=2 /\ not (2:X1=1)) Observation V56 Sometimes 6 9 Hash=2838dacac7cba036ce5f68c4ed07182d herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V57.litmus000066400000000000000000000002441475314470400257000ustar00rootroot00000000000000AArch64 V57 (* Tests 128-bit Neon pair loads with post-increment - register INVALID SYNTAX*) { } P0 ; LDP Q0, Q1, [X0], Q2 ; forall(0:X1 = 0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V57.litmus.expected-failure000066400000000000000000000002041475314470400311210ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64.neon/V57.litmus", line 7, characters 18-20: unexpected 'Q2' (in prog) (User error) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V58.litmus000066400000000000000000000002441475314470400257010ustar00rootroot00000000000000AArch64 V58 (* Tests 128-bit Neon pair store with post-increment - register INVALID SYNTAX*) { } P0 ; STP Q0, Q1, [X0], Q2 ; forall(0:X1 = 0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V58.litmus.expected-failure000066400000000000000000000002041475314470400311220ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64.neon/V58.litmus", line 7, characters 18-20: unexpected 'Q2' (in prog) (User error) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V59.litmus000066400000000000000000000001621475314470400257010ustar00rootroot00000000000000AArch64 V59 (* Test DUP *) { } P0: ; MOV W1,#1 ; DUP V0.4S,W1 ; forall 0:V0.4S={1,1,1,1} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V59.litmus.expected000066400000000000000000000002721475314470400275030ustar00rootroot00000000000000Test V59 Required States 1 0:V0.4S={1,1,1,1}; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:V0.4S={1,1,1,1}) Observation V59 Always 1 0 Hash=ef8d888e6a606d01bfaf9fbdc5246597 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V60.litmus000066400000000000000000000001521475314470400256700ustar00rootroot00000000000000AArch64 V60 (* Test FMOV (to general) *) {} P0 ; MOVI V0.4S,#1 ; FMOV W0,S0 ; forall 0:X0=1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V60.litmus.expected000066400000000000000000000002441475314470400274720ustar00rootroot00000000000000Test V60 Required States 1 0:X0=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=1) Observation V60 Always 1 0 Hash=ca3dae5244d456916a35e023a99e71b9 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V61.litmus000066400000000000000000000001571475314470400256760ustar00rootroot00000000000000AArch64 V61 (* Test ADDV * ) {} P0 ; MOVI V0.4S,#1 ; ADDV S1,V0.4S ; FMOV W1,S1 ; forall 0:X1=4 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V61.litmus.expected000066400000000000000000000002441475314470400274730ustar00rootroot00000000000000Test V61 Required States 1 0:X1=4; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=4) Observation V61 Always 1 0 Hash=9623cb4da7b349772b85ecae0442196a herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V62.litmus000066400000000000000000000004551475314470400257000ustar00rootroot00000000000000AArch64 V62 (* Test LD1 multiple structure (multiple registers)*) { int x[16]={255,0,0,0,0,255,0,0,0,0,255,0,0,0,0,255}; 0:X0=x; } P0 ; LD1 {V0.4S,V1.4S,V2.4S,V3.4S},[X0]; forall 0:V0.4S={255,0,0,0} /\ 0:V1.4S={0,255,0,0} /\ 0:V2.4S={0,0,255,0} /\ 0:V3.4S={0,0,0,255} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V62.litmus.expected000066400000000000000000000005021475314470400274710ustar00rootroot00000000000000Test V62 Required States 1 0:V0.4S={255,0,0,0}; 0:V1.4S={0,255,0,0}; 0:V2.4S={0,0,255,0}; 0:V3.4S={0,0,0,255}; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:V0.4S={255,0,0,0} /\ 0:V1.4S={0,255,0,0} /\ 0:V2.4S={0,0,255,0} /\ 0:V3.4S={0,0,0,255}) Observation V62 Always 1 0 Hash=5e7da463e724d2cf5994922af9f7c86f herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V63.litmus000066400000000000000000000007561475314470400257050ustar00rootroot00000000000000AArch64 V63 (* Test ST1 multiple structure (multiple registers)*) { int x[16]; 0:X0=x; } P0 ; MOVI V0.4S,#1 ; MOVI V1.4S,#2 ; MOVI V2.4S,#3 ; MOVI V3.4S,#4 ; ST1 {V0.4S,V1.4S,V2.4S,V3.4S},[X0]; forall x[0]=1 /\ x[1]=1 /\ x[2]=1 /\ x[3]=1 /\ x[4]=2 /\ x[5]=2 /\ x[6]=2 /\ x[7]=2 /\ x[8]=3 /\ x[9]=3 /\ x[10]=3/\ x[11]=3 /\ x[12]=4/\ x[13]=4/\ x[14]=4/\ x[15]=4 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V63.litmus.expected000066400000000000000000000006761475314470400275060ustar00rootroot00000000000000Test V63 Required States 1 x[0]=1; x[1]=1; x[2]=1; x[3]=1; x[4]=2; x[5]=2; x[6]=2; x[7]=2; x[8]=3; x[9]=3; x[10]=3; x[11]=3; x[12]=4; x[13]=4; x[14]=4; x[15]=4; Ok Witnesses Positive: 1 Negative: 0 Condition forall (x[0]=1 /\ x[1]=1 /\ x[2]=1 /\ x[3]=1 /\ x[4]=2 /\ x[5]=2 /\ x[6]=2 /\ x[7]=2 /\ x[8]=3 /\ x[9]=3 /\ x[10]=3 /\ x[11]=3 /\ x[12]=4 /\ x[13]=4 /\ x[14]=4 /\ x[15]=4) Observation V63 Always 1 0 Hash=a18095a3646c8accad7d875cdd67831b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V64.litmus000066400000000000000000000005551475314470400257030ustar00rootroot00000000000000AArch64 V64 (* Tests initialisation of neon registers (try litmus) *) { uint64_t x[4] = { 255,255,255,255 }; uint64_t* 0:X0 = &x; uint64_t 0:X2 = 2; uint64_t 0:X3 = 3; uint128_t 0:V0.2D; uint128_t 0:V1.2D; } P0 ; MOV V0.D[1], X2 ; MOV V1.D[0], X3 ; STP Q0, Q1, [X0] ; forall(x[0] = 0 /\ x[1] = 2 /\ x[2] = 3 /\ x[3] = 0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V64.litmus.expected000066400000000000000000000003321475314470400274740ustar00rootroot00000000000000Test V64 Required States 1 x[0]=0; x[1]=2; x[2]=3; x[3]=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (x[0]=0 /\ x[1]=2 /\ x[2]=3 /\ x[3]=0) Observation V64 Always 1 0 Hash=0a4bf3e001a5bd32fceaf3651e759f70 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V65.litmus000066400000000000000000000003101475314470400256710ustar00rootroot00000000000000AArch64 V65 (* Tests LDAP1/STL1 single structure with 64 bit lanes *) { uint64_t x=1; uint64_t y; 0:X0=x; 0:X1=y; } P0 ; LDAP1 {V0.D}[1],[X0] ; STL1 {V0.D}[1],[X1] ; forall(y=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V65.litmus.expected000066400000000000000000000002421475314470400274750ustar00rootroot00000000000000Test V65 Required States 1 [y]=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([y]=1) Observation V65 Always 1 0 Hash=7b6eb8f377ec0aaadc98fc925703166f herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V66.litmus000066400000000000000000000002561475314470400257030ustar00rootroot00000000000000AArch64 V66 (* Tests LDAPUR/STLUR single structure with 32 bit lanes *) { int x=1; int y; 0:X0=x; 0:X1=y; } P0 ; LDAPUR S0,[X0] ; STLUR S0,[X1] ; forall(y=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V66.litmus.expected000066400000000000000000000002421475314470400274760ustar00rootroot00000000000000Test V66 Required States 1 [y]=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([y]=1) Observation V66 Always 1 0 Hash=5d98d6e849d5a50e323705f8e6866979 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V67.litmus000066400000000000000000000005061475314470400257020ustar00rootroot00000000000000AArch64 V67 { uint8_t x[16]; 0 : X0 = x; } P0; MOVI V0.16B,#1 ; (* V0 = {1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1} *) MOVI V1.16B,#2 ; (* V1 = {2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2} *) EOR V2.8B,V1.8B,V0.8B ; (* V2 = {3,3,3,3,3,3,3,3,0,0,0,0,0,0,0,0} *) ST1{V2.16B},[X0] ; forall x={3,3,3,3,3,3,3,3,0,0,0,0,0,0,0,0} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V67.litmus.expected000066400000000000000000000003361475314470400275030ustar00rootroot00000000000000Test V67 Required States 1 x={3,3,3,3,3,3,3,3,0,0,0,0,0,0,0,0}; Ok Witnesses Positive: 1 Negative: 0 Condition forall (x={3,3,3,3,3,3,3,3,0,0,0,0,0,0,0,0}) Observation V67 Always 1 0 Hash=24bfe8345767d32cf5f5aca4f56af385 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V68.litmus000066400000000000000000000003621475314470400257030ustar00rootroot00000000000000AArch64 V68 { uint64_t t[2] = {0xffffffffffffffff,0x0}; uint64_t u[2] = {0x1,0x0}; 0:X0=t; 0:X1=u; } P0 ; LD1 {V0.2D},[X0] ; LD1 {V1.2D},[X1] ; ADD V0.2D,V0.2D,V1.2D ; ST1 {V0.2D},[X0] ; forall t={0,0} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V68.litmus.expected000066400000000000000000000002461475314470400275040ustar00rootroot00000000000000Test V68 Required States 1 t={0,0}; Ok Witnesses Positive: 1 Negative: 0 Condition forall (t={0,0}) Observation V68 Always 1 0 Hash=770eeca30938fabdcbbe69ff224d56f3 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V69.litmus000066400000000000000000000002501475314470400257000ustar00rootroot00000000000000AArch64 V69 { int16_t x[4] = { 11,22,33,44 }; 0:X0=x; } P0 ; MOVI D0,#65535 ; ADD D0,D0,D0 ; ST1 {V0.4H},[X0] ; forall x[0]=-2 /\ x[1]=1 /\ x[2]=0 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V69.litmus.expected000066400000000000000000000003121475314470400274770ustar00rootroot00000000000000Test V69 Required States 1 x[0]=-2; x[1]=1; x[2]=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (x[0]=-2 /\ x[1]=1 /\ x[2]=0) Observation V69 Always 1 0 Hash=fd76dd54fc222de1e09af7f008893f8e herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V70.litmus000066400000000000000000000002161475314470400256720ustar00rootroot00000000000000AArch64 V70 { int x=1; 0:X0=x; 0:X3=y; } P0 ; LDR S1,[X3]; FMOV W1,S1 ; LDR W2,[X0,W1,SXTW] ; forall 0:X2=1herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.neon/V70.litmus.expected000066400000000000000000000002441475314470400274730ustar00rootroot00000000000000Test V70 Required States 1 0:X2=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=1) Observation V70 Always 1 0 Hash=0e93be9471bfe31656ec91878a8f2670 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/000077500000000000000000000000001475314470400240525ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A001.litmus000066400000000000000000000002271475314470400257130ustar00rootroot00000000000000AArch64 A001 { 0:X0=NOP; 0:X1=P0:l1; 0:X2=0; } P0 ; l1:l2:B l0 ; MOV W2, #1 ; l0: ; STR W0, [X1] ; ~exists (0:X2=1)herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A001.litmus.expected000066400000000000000000000002471475314470400275150ustar00rootroot00000000000000Test A001 Forbidden States 1 0:X2=0; Ok Witnesses Positive: 1 Negative: 0 Condition ~exists (0:X2=1) Observation A001 Never 0 1 Hash=116be2f8c45818a4c863280ecf0deabd herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A002.litmus000066400000000000000000000002151475314470400257110ustar00rootroot00000000000000AArch64 A002 { 0:X0=NOP; 0:X1=P0:l1; 0:X2=0; } P0 ; STR W0, [X1] ; l1:l2:B l0 ; MOV W2, #1 ; l0: ; ~exists (0:X2=0)herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A002.litmus.expected000066400000000000000000000002631475314470400275140ustar00rootroot00000000000000Test A002 Forbidden States 2 0:X2=0; 0:X2=1; No Witnesses Positive: 1 Negative: 1 Condition ~exists (0:X2=0) Observation A002 Sometimes 1 1 Hash=52bd3462912a5b1dfd31fe8a2717df18 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A003.litmus000066400000000000000000000003341475314470400257140ustar00rootroot00000000000000AArch64 A003 { 0:X2=0; 1:X0=NOP; 1:X1=P0:L1; } P0 | P1 ; L1: | STR W0,[X1] ; B L0 | ; MOV W2, #1 | ; L0: | ; exists (0:X2=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A003.litmus.expected000066400000000000000000000002601475314470400275120ustar00rootroot00000000000000Test A003 Allowed States 2 0:X2=0; 0:X2=1; Ok Witnesses Positive: 1 Negative: 1 Condition exists (0:X2=1) Observation A003 Sometimes 1 1 Hash=d667ef56712c52f047c986962a317d89 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A004.litmus000066400000000000000000000013121475314470400257120ustar00rootroot00000000000000AArch64 A004 (* Herd gives incorrect result at the moment, * because instruction B L02 on P1 is * referenced to by two labels. *) "PodWW Irfe PodRR Ifre" Generator=diyone7 (version 7.56+02~dev) Com=Irf Ifr Orig=PodWW Irfe PodRR Ifre { 0:X0=NOP; 0:X1=P1:Lself00; 0:X2=P1:Lself01; } P0 | P1 ; STR W0,[X1] | Lself01: ; STR W0,[X2] | B L00 ; | MOV W0,#2 ; | B L01 ; | L00: ; | MOV W0,#1 ; | L01: ; | Lself00: ; | B L02 ; | MOV W1,#2 ; | B L03 ; | L02: ; | MOV W1,#1 ; | L03: ; exists (1:X0=2 /\ 1:X1=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A004.litmus.expected000066400000000000000000000004601475314470400275150ustar00rootroot00000000000000Test A004 Allowed States 4 1:X0=1; 1:X1=1; 1:X0=1; 1:X1=2; 1:X0=2; 1:X1=1; 1:X0=2; 1:X1=2; Ok Witnesses Positive: 1 Negative: 3 Flag Assuming-no-two-modified-instructions-are-on-the-same-cache-line Condition exists (1:X0=2 /\ 1:X1=1) Observation A004 Sometimes 1 3 Hash=a4610bdbbb2405e7c82c9a4b56acbae1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A005.litmus000066400000000000000000000011471475314470400257210ustar00rootroot00000000000000AArch64 A005 (* A0004 Fixed, with L01 and Lself00 merged *) "PodWW Irfe PodRR Ifre" Generator=diyone7 (version 7.56+02~dev) Com=Irf Ifr Orig=PodWW Irfe PodRR Ifre { 0:X0=NOP; 0:X1=P1:Lself00; 0:X2=P1:Lself01; } P0 | P1 ; STR W0,[X1] | Lself01: ; STR W0,[X2] | B L00 ; | MOV W0,#2 ; | B Lself00 ; | L00: ; | MOV W0,#1 ; | Lself00: ; | B L02 ; | MOV W1,#2 ; | B L03 ; | L02: ; | MOV W1,#1 ; | L03: ; exists (1:X0=2 /\ 1:X1=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A005.litmus.expected000066400000000000000000000004601475314470400275160ustar00rootroot00000000000000Test A005 Allowed States 4 1:X0=1; 1:X1=1; 1:X0=1; 1:X1=2; 1:X0=2; 1:X1=1; 1:X0=2; 1:X1=2; Ok Witnesses Positive: 1 Negative: 3 Flag Assuming-no-two-modified-instructions-are-on-the-same-cache-line Condition exists (1:X0=2 /\ 1:X1=1) Observation A005 Sometimes 1 3 Hash=0b9c5c8e0512403e4721211613df6252 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A006.litmus000066400000000000000000000020201475314470400257110ustar00rootroot00000000000000AArch64 A006 "PodWW Irfe PodRR Ifre PodWW Irfe PodRR Ifre" Generator=diyone7 (version 7.56+02~dev) Com=Irf Ifr Irf Ifr Orig=PodWW Irfe PodRR Ifre PodWW Irfe PodRR Ifre { 0:X0=NOP; 0:X1=P3:L05; 0:X2=P1:Lself01; 2:X0=NOP; 2:X1=P1:L01; 2:X2=P3:Lself03; } P0 | P1 | P2 | P3 ; STR W0,[X1] | Lself01: | STR W0,[X1] | Lself03: ; STR W0,[X2] | B L00 | STR W0,[X2] | B L04 ; | MOV W0,#2 | | MOV W0,#2 ; | B L01 | | B L05 ; | L00: | | L04: ; | MOV W0,#1 | | MOV W0,#1 ; | L01: | | L05: ; | B L02 | | B L06 ; | MOV W1,#2 | | MOV W1,#2 ; | B L03 | | B L07 ; | L02: | | L06: ; | MOV W1,#1 | | MOV W1,#1 ; | L03: | | L07: ; exists (1:X0=2 /\ 1:X1=1 /\ 3:X0=2 /\ 3:X1=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A006.litmus.expected000066400000000000000000000014071475314470400275210ustar00rootroot00000000000000Test A006 Allowed States 16 1:X0=1; 1:X1=1; 3:X0=1; 3:X1=1; 1:X0=1; 1:X1=1; 3:X0=1; 3:X1=2; 1:X0=1; 1:X1=1; 3:X0=2; 3:X1=1; 1:X0=1; 1:X1=1; 3:X0=2; 3:X1=2; 1:X0=1; 1:X1=2; 3:X0=1; 3:X1=1; 1:X0=1; 1:X1=2; 3:X0=1; 3:X1=2; 1:X0=1; 1:X1=2; 3:X0=2; 3:X1=1; 1:X0=1; 1:X1=2; 3:X0=2; 3:X1=2; 1:X0=2; 1:X1=1; 3:X0=1; 3:X1=1; 1:X0=2; 1:X1=1; 3:X0=1; 3:X1=2; 1:X0=2; 1:X1=1; 3:X0=2; 3:X1=1; 1:X0=2; 1:X1=1; 3:X0=2; 3:X1=2; 1:X0=2; 1:X1=2; 3:X0=1; 3:X1=1; 1:X0=2; 1:X1=2; 3:X0=1; 3:X1=2; 1:X0=2; 1:X1=2; 3:X0=2; 3:X1=1; 1:X0=2; 1:X1=2; 3:X0=2; 3:X1=2; Ok Witnesses Positive: 1 Negative: 15 Flag Assuming-no-two-modified-instructions-are-on-the-same-cache-line Condition exists (1:X0=2 /\ 1:X1=1 /\ 3:X0=2 /\ 3:X1=1) Observation A006 Sometimes 1 15 Hash=edec135b7ea827ac20b4c3a788c485de herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A007.litmus000066400000000000000000000004241475314470400257200ustar00rootroot00000000000000AArch64 A007 (* This test should fail, as overwriting the addition instruction not well defined *) { 0:X2=0; 1:X0=NOP; 1:X1=P0:L1; } P0 | P1 ; L1: | STR W0,[X1] ; ADD W2,W2,#1 | ; ADD W2,W2,#1 | ; exists (0:X2=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A007.litmus.expected000066400000000000000000000003211475314470400275140ustar00rootroot00000000000000Test A007 Allowed States 2 0:X2=1; 0:X2=2; Ok Witnesses Positive: 1 Negative: 1 Flag violates-CMODX-requirements Condition exists (0:X2=1) Observation A007 Sometimes 1 1 Hash=77032c0be8690b2b66d8c9f20e2a5363 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A008.litmus000066400000000000000000000002211475314470400257140ustar00rootroot00000000000000AArch64 A008 (* Illegal test *) { 0:X2=0; 1:X0=NOP; 1:X1=P0:L1; } P0 | P1 ; L1: | STR W0,[X1] ; exists (0:X2=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A008.litmus.expected-failure000066400000000000000000000001661475314470400311510ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64.self/A008.litmus": Final label L1 cannot be overwritten (User error) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A009.litmus000066400000000000000000000003211475314470400257160ustar00rootroot00000000000000AArch64 A009 (* Illegal test *) { 0:X2=0; 1:X0=NOP; 1:X1=P0:L2; } P0 | P1 ; L1: | STR W0,[X1] ; B L0 | ; MOV W2,#1 | ; exists (0:X2=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A009.litmus.expected-failure000066400000000000000000000002211475314470400311420ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64.self/A009.litmus": Label L0 not found on P0, although used in the instruction B L0 (User error) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A010.litmus000066400000000000000000000002311475314470400257060ustar00rootroot00000000000000AArch64 A010 { 0:X2=0; 0:X0=NOP; } P0 ; L1: ; ADD W2,W2,#1 ; ADD W2,W2,#1 ; ADR X3,L1 ; STR W0,[X3] ; forall (0:X2=2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A010.litmus.expected000066400000000000000000000002461475314470400275140ustar00rootroot00000000000000Test A010 Required States 1 0:X2=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=2) Observation A010 Always 1 0 Hash=77b235b3243a7010216394415245557e herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A011.litmus000066400000000000000000000002461475314470400257150ustar00rootroot00000000000000AArch64 A011 { 0:X2=0; 0:X0=NOP; 0:X3=P0:L1; } P0 ; STR W0,[X3] ; L1: ; B L0 ; ADD W2,W2,#1 ; L0: ; exists (0:X2=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A011.litmus.expected000066400000000000000000000002601475314470400275110ustar00rootroot00000000000000Test A011 Allowed States 2 0:X2=0; 0:X2=1; Ok Witnesses Positive: 1 Negative: 1 Condition exists (0:X2=0) Observation A011 Sometimes 1 1 Hash=7c2889d6cfa4501cd73ee70ba35c713b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A012.litmus000066400000000000000000000002531475314470400257140ustar00rootroot00000000000000AArch64 A012 { 0:X2=0; 0:X0=NOP; } P0 ; ADR X3,L1 ; STR W0,[X3] ; L1: ; B L0 ; ADD W2,W2,#1 ; L0: ; exists (0:X2=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A012.litmus.expected000066400000000000000000000002601475314470400275120ustar00rootroot00000000000000Test A012 Allowed States 2 0:X2=0; 0:X2=1; Ok Witnesses Positive: 1 Negative: 1 Condition exists (0:X2=0) Observation A012 Sometimes 1 1 Hash=866e8ca7d9d70e7a5bc48c3f9c657975 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A013.litmus000066400000000000000000000003621475314470400257160ustar00rootroot00000000000000AArch64 A013 { 0:X0=instr:"NOP"; 0:X1=P0:Lself00; 0:X3=P0:L0; } P0 ; LDR W2,[X3] ; L0: ; B L1 ; NOP ; L1: ; ; STR W0,[X1] ; Lself00: ; B Lout ; Lout: ; herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A013.litmus.expected000066400000000000000000000003431475314470400275150ustar00rootroot00000000000000Test A013 Required States 1 Ok Witnesses Positive: 2 Negative: 0 Flag Assuming-no-two-modified-instructions-are-on-the-same-cache-line Condition forall (true) Observation A013 Always 2 0 Hash=2709172bb2cddf652d30338fd2804dea herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A014.litmus000066400000000000000000000003401475314470400257130ustar00rootroot00000000000000AArch64 A014 { 0:X1=P0:Lself00; 0:X3=P0:L0; } P0 ; LDR W2,[X3] ; L0: ; B L1 ; NOP ; L1: ; ; STR W2,[X1] ; Lself00: ; B Lout ; Lout: ; herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A014.litmus.expected-failure000066400000000000000000000002251475314470400311420ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64.self/A014.litmus": Segmentation fault (kidding, address 0x2728 does not point to code) (User error) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A015.litmus000066400000000000000000000002441475314470400257170ustar00rootroot00000000000000AArch64 A015 { 0:X0=NOP;0:X1=P0:Lself00; 0:X9=0; } P0 ; L0:L1: STR W0,[X1]; Lself00: ; B Lout ; MOV W9,#1 ; Lout: ; exists 0:X9=0 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A015.litmus.expected000066400000000000000000000002601475314470400275150ustar00rootroot00000000000000Test A015 Allowed States 2 0:X9=0; 0:X9=1; Ok Witnesses Positive: 1 Negative: 1 Condition exists (0:X9=0) Observation A015 Sometimes 1 1 Hash=6630f9344320cf27835f71f1bc488e31 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A016.litmus000066400000000000000000000003631475314470400257220ustar00rootroot00000000000000AArch64 A016 { 0:X1=P0:Lself00; 0:X9=0; 0:X2=P1:Lsrc; } P0 | P1; LDR W0,[X2]| B Lout1 ; STR W0,[X1]| L2: B Lout1; Lself00: | L1:L0:Lsrc: NOP; B Lout | NOP ; MOV W9,#1 | NOP ; Lout: | Lout1: ; exists 0:X9=0 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A016.litmus.expected000066400000000000000000000003661475314470400275250ustar00rootroot00000000000000Test A016 Allowed States 2 0:X9=0; 0:X9=1; Ok Witnesses Positive: 1 Negative: 1 Flag Assuming-no-two-modified-instructions-are-on-the-same-cache-line Condition exists (0:X9=0) Observation A016 Sometimes 1 1 Hash=4030de5673678c66761560ccadc0ba40 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A017.litmus000066400000000000000000000003321475314470400257170ustar00rootroot00000000000000AArch64 A017 Stable=X30 { (* necessary to generate an initial write for P0:L1 *) 0:X1=P0:L1; } P0 ; BL L0 ; L1: ; NOP ; L0: ; LDR W0,[X30] ; forall(0:X0=instr:"NOP") herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/A017.litmus.expected000066400000000000000000000002521475314470400275200ustar00rootroot00000000000000Test A017 Required States 1 0:X0=NOP; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=NOP) Observation A017 Always 1 0 Hash=46b8ce018c9628c159332ad9f5900cf9 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/NORUN000066400000000000000000000001621475314470400246750ustar00rootroot00000000000000A007 A008 A009 A010 S05 S06 S10 S11 S12 S13 S14 S15 S16 S17 S23 #This test faults on non-existing instruction S20 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S01.litmus000066400000000000000000000006171475314470400256600ustar00rootroot00000000000000AArch64 S01 Stable=X9 { 0:X8=P1:f; 2:X0 = P1:f ; } P0 | P1 | P2 ; MOV W9,#0 | MOV W9,#1 | MOV w9,#2 ; BLR X8 | BL f | BLR X0 ; | B L1 | ; |f: | ; | ADD W9,W9,#1 | ; | RET | ; |L1: | ; forall (0:X9=1 /\ 1:X9=2 /\ 2:X9=3) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S01.litmus.expected000066400000000000000000000003101475314470400274460ustar00rootroot00000000000000Test S01 Required States 1 0:X9=1; 1:X9=2; 2:X9=3; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X9=1 /\ 1:X9=2 /\ 2:X9=3) Observation S01 Always 1 0 Hash=438ad24b0e65caf529ff8558108d8efc herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S02.litmus000066400000000000000000000012721475314470400256570ustar00rootroot00000000000000AArch64 S02 Stable=X9 { 0:X0 = P1:f ; 2:X0 = P1:f ; 3:X0 = P1:f ; 3:X1 = NOP ; } P0 | P1 | P2 | P3 ; MOV W9,#0 | MOV W9,#1 | MOV w9,#2 | STR W1,[X0] ; BLR X0 | BL f | BLR X0 | ; | B L1 | | ; |f: | | ; | B L0 | | ; | RET | | ; |L0: | | ; | ADD W9,W9,#1 | | ; | RET | | ; |L1: | | ; exists 0:X9=0 /\ 1:X9=1 /\ 2:X9=2 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S02.litmus.expected000066400000000000000000000005621475314470400274600ustar00rootroot00000000000000Test S02 Allowed States 8 0:X9=0; 1:X9=1; 2:X9=2; 0:X9=0; 1:X9=1; 2:X9=3; 0:X9=0; 1:X9=2; 2:X9=2; 0:X9=0; 1:X9=2; 2:X9=3; 0:X9=1; 1:X9=1; 2:X9=2; 0:X9=1; 1:X9=1; 2:X9=3; 0:X9=1; 1:X9=2; 2:X9=2; 0:X9=1; 1:X9=2; 2:X9=3; Ok Witnesses Positive: 1 Negative: 7 Condition exists (0:X9=0 /\ 1:X9=1 /\ 2:X9=2) Observation S02 Sometimes 1 7 Hash=8b2fa650454ef4f7024c0dc9cc9a64e6 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S03.litmus000066400000000000000000000001711475314470400256550ustar00rootroot00000000000000AArch64 S03 { 0:X0=0; 0:X30=P0:L0; } P0 ; BR X30 ; MOV W0, #1 ; L0: ; forall (0:X0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S03.litmus.expected000066400000000000000000000002441475314470400274560ustar00rootroot00000000000000Test S03 Required States 1 0:X0=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=0) Observation S03 Always 1 0 Hash=c6df1ca4b7b712518e28305c624a5333 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S04.litmus000066400000000000000000000002631475314470400256600ustar00rootroot00000000000000AArch64 S04 { 0:X0=0; 0:X1=P0:L0; 0:X30=P0:L1; } P0 ; RET X1 ; MOV W0, #1 ; L1: ; MOV W0, #2 ; L0: ; forall (0:X0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S04.litmus.expected000066400000000000000000000002441475314470400274570ustar00rootroot00000000000000Test S04 Required States 1 0:X0=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=0) Observation S04 Always 1 0 Hash=c26a84806451815b7bde72577f6771f7 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S05.litmus000066400000000000000000000002011475314470400256510ustar00rootroot00000000000000AArch64 S05 { 0:X0=0; 0:X30=P0:L0; } P0 ; RET ; MOV W0, #1 ; L0: ; forall (0:X0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S05.litmus.expected000066400000000000000000000002441475314470400274600ustar00rootroot00000000000000Test S05 Required States 1 0:X0=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=0) Observation S05 Always 1 0 Hash=9be4e0f9bac58040fa8221390bb595ed herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S06.litmus000066400000000000000000000002151475314470400256570ustar00rootroot00000000000000AArch64 S06 { 0:X0=0; } P0 ; BL L0 ; MOV W0, #1 ; L0: ; locations [0:X0; 0:X30;] forall (0:X0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S06.litmus.expected000066400000000000000000000002611475314470400274600ustar00rootroot00000000000000Test S06 Required States 1 0:X0=0; 0:X30=10004; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=0) Observation S06 Always 1 0 Hash=f6594ca314e73b63847cbd4ea234b633 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S07.litmus000066400000000000000000000003351475314470400256630ustar00rootroot00000000000000AArch64 S07 { 0:X0=0; 0:X1=0; 0:X30=P0:L0; } P0 ; B L1 ; L0: ; MOV W0, #1 ; RET ; L1: ; BL L0 ; MOV W1, #1 ; forall (0:X0=1/\0:X1=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S07.litmus.expected000066400000000000000000000002661475314470400274660ustar00rootroot00000000000000Test S07 Required States 1 0:X0=1; 0:X1=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=1 /\ 0:X1=1) Observation S07 Always 1 0 Hash=a4121ff3b0515da6b9b8e9aae2074400 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S08.litmus000066400000000000000000000002721475314470400256640ustar00rootroot00000000000000AArch64 S08 { 0:X0=0; 0:X30=P0:L0; } P0 ; B L1 ; L0: ; MOV W0, #1 ; RET ; L1: ; BL L0 ; forall (0:X0=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S08.litmus.expected000066400000000000000000000002441475314470400274630ustar00rootroot00000000000000Test S08 Required States 1 0:X0=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=1) Observation S08 Always 1 0 Hash=4d76be266b03d6557fff7cc2d6dc0ff2 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S09.litmus000066400000000000000000000004071475314470400256650ustar00rootroot00000000000000AArch64 S09 { 0:X0=0; 0:X1=0; 0:X2=P1:L0; } P0 | P1; BLR X2 | B L1 ; MOV W1, #1 | L0: ; | MOV W0, #1 ; | RET ; | L1: ; forall (0:X0=1/\0:X1=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S09.litmus.expected000066400000000000000000000002661475314470400274700ustar00rootroot00000000000000Test S09 Required States 1 0:X0=1; 0:X1=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=1 /\ 0:X1=1) Observation S09 Always 1 0 Hash=1c91bb28ac14473d8ce9f8db6894ddc3 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S10.litmus000066400000000000000000000003211475314470400256500ustar00rootroot00000000000000AArch64 S10 { 0:X0=0; } P0 | P1; BR L0 | B L1 ; | L0: ; | MOV X0, #1 ; | L1: ; locations [0:X0; 1:X0;] herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S10.litmus.expected-failure000066400000000000000000000002021475314470400310730ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64.self/S10.litmus", line 6, characters 5-7: unexpected 'L0' (in prog) (User error) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S11.litmus000066400000000000000000000002321475314470400256520ustar00rootroot00000000000000AArch64 S11 { [x]=P0:L0; 0:X0=0; 0:X1=x; } P0 ; LDR X2, [X1] ; BR X2 ; MOV W0, #1 ; L0: ; forall (0:X0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S11.litmus.expected000066400000000000000000000002441475314470400274550ustar00rootroot00000000000000Test S11 Required States 1 0:X0=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=0) Observation S11 Always 1 0 Hash=fc8c01ec749740e1bc57bb8588d8c743 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S12.litmus000066400000000000000000000003461475314470400256610ustar00rootroot00000000000000AArch64 S12 { [x]=P0:L0; 0:X0=0; 0:X1=x; } P0 ; LDR X2, [X1] ; BLR X2 ; ADD W0,W0,#1 ; B L1 ; L0: ; MOV W0,#1 ; RET ; L1: ; forall (0:X0=2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S12.litmus.expected000066400000000000000000000002441475314470400274560ustar00rootroot00000000000000Test S12 Required States 1 0:X0=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=2) Observation S12 Always 1 0 Hash=e560b8b2a90cc1dcdea4dea559c59773 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S13.litmus000066400000000000000000000006271475314470400256640ustar00rootroot00000000000000AArch64 S13 Stable=X0 { [x]=P1:L1; 0:X0=0; 0:X1=x; 1:X2=P1:L2; 1:X1=x; } P0 | P1; LDR X2,[X1] | STR X2,[X1]; BLR X2 | B L0 ; | L1: ; | ADD W0,W0,#1; | L2: ; | ADD W0,W0,#1; | RET ; | L0: ; forall (0:X0=1 \/ 0:X0=2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S13.litmus.expected000066400000000000000000000003741475314470400274630ustar00rootroot00000000000000Test S13 Required States 2 0:X0=1; 0:X0=2; Ok Witnesses Positive: 2 Negative: 0 Flag Assuming-no-two-modified-instructions-are-on-the-same-cache-line Condition forall (0:X0=1 \/ 0:X0=2) Observation S13 Always 2 0 Hash=f16cfb44fbd6372cf1b443fa042b4d90 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S14.litmus000066400000000000000000000007161475314470400256640ustar00rootroot00000000000000AArch64 S14 Stable=X0 { [x]=P1:L1; 0:X0=0; 0:X1=x; 1:X2=P1:L2; 1:X1=x; } P0 | P1; LDR X2, [X1] | STR X2, [X1] ; BLR X2 | B L0 ; LDR X2, [X1] |L1: ; BLR X2 | ADD W0,W0,#1 ; | RET ; | L2: ; | ADD W0,W0,#2 ; | RET ; | L0: ; forall (0:X0=2 \/ 0:X0=3 \/ 0:X0=4) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S14.litmus.expected000066400000000000000000000004161475314470400274610ustar00rootroot00000000000000Test S14 Required States 3 0:X0=2; 0:X0=3; 0:X0=4; Ok Witnesses Positive: 3 Negative: 0 Flag Assuming-no-two-modified-instructions-are-on-the-same-cache-line Condition forall (0:X0=2 \/ 0:X0=3 \/ 0:X0=4) Observation S14 Always 3 0 Hash=037d336cd00d0983446ae270e9369843 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S15.litmus000066400000000000000000000001741475314470400256630ustar00rootroot00000000000000AArch64 S15 { 0:X0=0; 0:X1=x; } P0 ; BR X1 ; MOV W0, #1 ; L0: ; forall (0:X0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S15.litmus.expected-failure000066400000000000000000000002201475314470400311000ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64.self/S15.litmus": illegal argument for the indirect branch instruction BR X1 (must be a label) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S16.litmus000066400000000000000000000001741475314470400256640ustar00rootroot00000000000000AArch64 S16 { 0:X0=0; 0:X1=0; } P0 ; BR X1 ; MOV W0, #1 ; L0: ; forall (0:X0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S16.litmus.expected-failure000066400000000000000000000002211475314470400311020ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64.self/S16.litmus": Segmentation fault (kidding, address 0x0 does not point to code) (User error) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S17.litmus000066400000000000000000000001761475314470400256670ustar00rootroot00000000000000AArch64 S17 { 0:X0=0; 0:X1=NOP; } P0 ; BR X1 ; MOV W0, #1 ; L0: ; forall (0:X0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S17.litmus.expected-failure000066400000000000000000000002201475314470400311020ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64.self/S17.litmus": illegal argument for the indirect branch instruction BR X1 (must be a label) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S18.litmus000066400000000000000000000001571475314470400256670ustar00rootroot00000000000000AArch64 S18 { } P0 ; L0: ; NOP ; ADR X0,L0 ; LDR W1,[X0] ; forall 0:X1=NOPherd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S18.litmus.expected000066400000000000000000000002501475314470400274610ustar00rootroot00000000000000Test S18 Required States 1 0:X1=NOP; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=NOP) Observation S18 Always 1 0 Hash=0ec5b76486b4557f5b593bdf869bb5d8 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S19.litmus000066400000000000000000000002151475314470400256630ustar00rootroot00000000000000AArch64 S19 { } P0 ; L0: ; B L1 ; L1: ; ADR X0,L0 ; LDR W1,[X0] ; ~exists 0:X1=NOP herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S19.litmus.expected000066400000000000000000000002631475314470400274660ustar00rootroot00000000000000Test S19 Forbidden States 1 0:X1=instr:"B .+4"; Ok Witnesses Positive: 1 Negative: 0 Condition ~exists (0:X1=NOP) Observation S19 Never 0 1 Hash=575460720804ab203c8c1e1fe3afe1f7 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S20.litmus000066400000000000000000000003561475314470400256610ustar00rootroot00000000000000AArch64 S20 Variant=fatal { 0:X0=0; 0:X1=P1:L1; } P0 | P1 ; STR W0,[X1] | MOV W0,#1 ; |L1: ; | NOP ; | ADD W0,W0,#3 ; locations [1:X0;] exists 1:X0=1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S20.litmus.expected000066400000000000000000000002561475314470400274600ustar00rootroot00000000000000Test S20 Allowed States 2 1:X0=1; 1:X0=4; Ok Witnesses Positive: 1 Negative: 1 Condition exists (1:X0=1) Observation S20 Sometimes 1 1 Hash=e566f5afe87c909e98f7bb7b25660da0 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S21.litmus000066400000000000000000000003041475314470400256530ustar00rootroot00000000000000AArch64 S21 { } P0 ; L0: ; NOP ; ADR X0,L0 ; ADR X1,L1 ; LDR W2,[X0] ; STR W2,[X1] ; L1: ; B L2 ; MOV W3,#1 ; L2: ; exists 0:X3=1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S21.litmus.expected000066400000000000000000000003641475314470400274610ustar00rootroot00000000000000Test S21 Allowed States 2 0:X3=0; 0:X3=1; Ok Witnesses Positive: 1 Negative: 1 Flag Assuming-no-two-modified-instructions-are-on-the-same-cache-line Condition exists (0:X3=1) Observation S21 Sometimes 1 1 Hash=3959ffccf8d2c829f46dc74ade96b1f8 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S22.litmus000066400000000000000000000002211475314470400256520ustar00rootroot00000000000000AArch64 S22 { 0:X2=NOP; } P0 ; ADR X1,L1 ; STR W2,[X1] ; L1: ; B L2 ; MOV W3,#1 ; L2: ; exists 0:X3=1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S22.litmus.expected000066400000000000000000000002561475314470400274620ustar00rootroot00000000000000Test S22 Allowed States 2 0:X3=0; 0:X3=1; Ok Witnesses Positive: 1 Negative: 1 Condition exists (0:X3=1) Observation S22 Sometimes 1 1 Hash=587ad449c604e21ebde156dc74ae72c6 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S23.litmus000066400000000000000000000005261475314470400256630ustar00rootroot00000000000000AArch64 S23 { int t[2] = { 1,2 } ; 0:X1=P1:L0; 0:X3=P1:L1; 1:X2=t; } P0 | P1 ; LDR W0,[X3] | MOV W1,#3 ; STR W0,[X1] |L0: ; | STR W1,[X2,#4] ; | B L2 ; |L1: ; | STR W1,[X2] ; |L2: ; locations [t;] herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S23.litmus.expected000066400000000000000000000004231475314470400274570ustar00rootroot00000000000000Test S23 Required States 2 t={1,3}; t={3,2}; Ok Witnesses Positive: 2 Negative: 0 Flag Assuming-no-two-modified-instructions-are-on-the-same-cache-line Flag violates-CMODX-requirements Condition forall (true) Observation S23 Always 2 0 Hash=b5828ee8a20d1f9c72c22257755f5515 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S24.litmus000066400000000000000000000003261475314470400256620ustar00rootroot00000000000000AArch64 S24 { 1:X1=P0:L0; 1:X2=instr:"B .+4"; } P0 | P1 ; MOV W3,#1 | STR W2,[X1] ; L0: | ; B .+8 | ; ADD W3,W3,#2 | ; exists 0:X3=1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S24.litmus.expected000066400000000000000000000002561475314470400274640ustar00rootroot00000000000000Test S24 Allowed States 2 0:X3=1; 0:X3=3; Ok Witnesses Positive: 1 Negative: 1 Condition exists (0:X3=1) Observation S24 Sometimes 1 1 Hash=1fb919303b294cca31dc287fe2c2315a herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S25.litmus000066400000000000000000000006531475314470400256660ustar00rootroot00000000000000AArch64 S25 (* Some of the latter discarded candidate execution trigger a delayed error. More precisely, herd cannot hander overwriting MOV W6,W4 with ADR X3.+4, because there is no label on target. *) { ins_t 0:X4=instr:"BL .+8"; 0:X1=P0:L0; ins_t 0:X0; ins_t 0:X2; ins_t 0:X6; } P0 ; L0: ; ADR X3,L1 ; L1: ; MOV W6,W4 ; LDR W0,[X1] ; LDR W2,[X3] ; locations [0:X0;0:X2;0:X6;] herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S25.litmus.expected000066400000000000000000000004461475314470400274660ustar00rootroot00000000000000Test S25 Required States 1 0:X0=instr:"ADR X3,.+4"; 0:X2=instr:"MOV W6,W4"; 0:X6=instr:"BL .+8"; Ok Witnesses Positive: 1 Negative: 0 Flag Assuming-no-two-modified-instructions-are-on-the-same-cache-line Condition forall (true) Observation S25 Always 1 0 Hash=353531dc6e6299b14776426e2440091c herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S26.litmus000066400000000000000000000006471475314470400256720ustar00rootroot00000000000000AArch64 S26 (* Some of the latter discarded candidate execution trigger a delayed error. More precisely, herd cannot hander overwriting MOV W6,W4 with ADR X3.+8, because there is no label on target. *) { 0:X0=P0:L0; 0:X1=P0:L1; ins_t 0:X5; 0:X2=1; } P0 ; LDR W4,[X0] ; B .+8 ; L0: ; ADR X3,L1 ; STR W4,[X1] ; L1: ; MOV W6,W2 ; LDR W5,[X1] ; locations [0:X5;0:X6;] herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S26.litmus.expected-failure000066400000000000000000000001501475314470400311040ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64.self/S26.litmus": Overwriting with ADR, cannot handle herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S27.litmus000066400000000000000000000005631475314470400256700ustar00rootroot00000000000000AArch64 S27 (* Similar to S26, yielding no error, because ADDR X3,.+0 miraculously correspong to label L1 when after instruction at L1 is overwritten *) { 0:X0=P0:L0; 0:X1=P0:L1; ins_t 0:X5; 0:X2=1; } P0 ; LDR W4,[X0] ; B .+8 ; L0: ; ADR X3,L0 ; STR W4,[X1] ; L1: ; MOV W6,W2 ; LDR W5,[X1] ; locations [0:X5;0:X6;] herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S27.litmus.expected000066400000000000000000000005031475314470400274620ustar00rootroot00000000000000Test S27 Required States 2 0:X5=instr:"ADR X3,.+0"; 0:X6=0; 0:X5=instr:"ADR X3,.+0"; 0:X6=1; Ok Witnesses Positive: 2 Negative: 0 Flag Assuming-no-two-modified-instructions-are-on-the-same-cache-line Flag violates-CMODX-requirements Condition forall (true) Observation S27 Always 2 0 Hash=dafd07478617c823bca682aaa6e8d197 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S28.litmus000066400000000000000000000003501475314470400256630ustar00rootroot00000000000000AArch64 S28 { 0:X2=NOP; 0:X1=P1:L0; } P0 | P1 ; STR W2,[X1] |L0: ; | B L1 ; | ADD W2,W2,#1 ; |L1: ; | ADD W2,W2,#2 ; exists 1:X2=3 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S28.litmus.expected000066400000000000000000000002561475314470400274700ustar00rootroot00000000000000Test S28 Allowed States 2 1:X2=2; 1:X2=3; Ok Witnesses Positive: 1 Negative: 1 Condition exists (1:X2=3) Observation S28 Sometimes 1 1 Hash=67619acbffb4c487f2a597a5337e9e6c herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S29.litmus000066400000000000000000000003571475314470400256730ustar00rootroot00000000000000AArch64 S29 { 0:X2=NOP; 0:X0=p; [p]=P1:L0; } P0 | P1 ; LDR X1,[X0] |L0: ; STR W2,[X1] | B L1 ; | ADD W2,W2,#1 ; |L1: ; | ADD W2,W2,#2 ; exists 1:X2=3 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/S29.litmus.expected000066400000000000000000000002561475314470400274710ustar00rootroot00000000000000Test S29 Allowed States 2 1:X2=2; 1:X2=3; Ok Witnesses Positive: 1 Negative: 1 Condition exists (1:X2=3) Observation S29 Sometimes 1 1 Hash=1aa81afc46710352152cc1b5fb403941 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.self/self.cfg000066400000000000000000000000501475314470400254570ustar00rootroot00000000000000variant ifetch unroll 1 cat aarch64.cat herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/000077500000000000000000000000001475314470400237055ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V01.litmus000066400000000000000000000006251475314470400255150ustar00rootroot00000000000000AArch64 V01 {} P0 ; MOV Z0.S,#1 ; SMSTART SM ; (* That would zero-out Z* and P* registers *) PTRUE P0.S,VL4 ; UADDV D0,P0,Z0.S ; FMOV W0,S0 ; MOV Z1.S,#2 ; PTRUE P1.S,VL4 ; UADDV D1,P1,Z1.S ; FMOV W1,S1 ; SMSTOP SM ; (* That would zero-out Z* and P* registers *) forall 0:V0.4S={0,0,0,0} /\ 0:V1.4S={0,0,0,0} /\ 0:X0=0 /\ 0:X1=8 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V01.litmus.expected000066400000000000000000000004721475314470400273150ustar00rootroot00000000000000Test V01 Required States 1 0:X0=0; 0:X1=8; 0:V0.4S={0,0,0,0}; 0:V1.4S={0,0,0,0}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Matrix-Extensions-is-work-in-progress Condition forall (0:V0.4S={0,0,0,0} /\ 0:V1.4S={0,0,0,0} /\ 0:X0=0 /\ 0:X1=8) Observation V01 Always 1 0 Hash=74f1ff03050a34cea97027a6e212626d herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V02.litmus000066400000000000000000000004341475314470400255140ustar00rootroot00000000000000AArch64 V02 { uint32_t x[4]; 0:X0=x; } P0 ; SMSTART ; INDEX Z0.S,#1,#1 ; PTRUE P0.S,VL4 ; MOV W12,WZR ; MOVA ZA0H.S[W12,0],P0/M,Z0.S ; ST1W {ZA0H.S[W12,0]},P0,[X0] ; SMSTOP ; forall x={1,2,3,4}herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V02.litmus.expected000066400000000000000000000003421475314470400273120ustar00rootroot00000000000000Test V02 Required States 1 x={1,2,3,4}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Matrix-Extensions-is-work-in-progress Condition forall (x={1,2,3,4}) Observation V02 Always 1 0 Hash=d18b411051ee55414d5c67bcdeb8f273 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V03.litmus000066400000000000000000000006111475314470400255120ustar00rootroot00000000000000AArch64 V03 { uint32_t x[4] = {1,2,3,4}; 0:X0=x; } P0 ; SMSTART ; PTRUE P0.S,VL4 ; MOV W12,WZR ; LD1W {ZA1H.S[W12,0]},P0/Z,[X0]; MOVA Z0.S,P0/M,ZA1H.S[W12,0] ; UADDV D1,P0,Z0.S ; FMOV W1,S1 ; (* Stash result in GP register or SMSTOP would zero it out *) SMSTOP ; forall 0:X1=10 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V03.litmus.expected000066400000000000000000000003321475314470400273120ustar00rootroot00000000000000Test V03 Required States 1 0:X1=10; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Matrix-Extensions-is-work-in-progress Condition forall (0:X1=10) Observation V03 Always 1 0 Hash=3735f297bb64925ffd8f875869f0d2b1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V04.litmus000066400000000000000000000004731475314470400255210ustar00rootroot00000000000000AArch64 V04 { uint32_t x[4]; 0:X0=x; } P0 ; SMSTART ; INDEX Z0.S,#1,#1 ; PTRUE P0.S ; MOV W12,WZR ; MOVA ZA0H.S[W12,0],P0/M,Z0.S ; PTRUE P1.S,VL4 ; ST1W {ZA0V.S[W12,2]},P1,[X0] ; SMSTOP ; forall x={3,0,0,0}herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V04.litmus.expected000066400000000000000000000003421475314470400273140ustar00rootroot00000000000000Test V04 Required States 1 x={3,0,0,0}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Matrix-Extensions-is-work-in-progress Condition forall (x={3,0,0,0}) Observation V04 Always 1 0 Hash=9d3f357c7c92ca5f5e0b16d7ace2ed71 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V05.litmus000066400000000000000000000007661475314470400255270ustar00rootroot00000000000000AArch64 V05 { uint32_t x[4]; 0:X0=x; } P0 ; SMSTART ; INDEX Z0.S,#1,#1 ; INDEX Z1.S,#2,#2 ; INDEX Z2.S,#3,#3 ; INDEX Z3.S,#4,#4 ; PTRUE P0.S ; MOV W12,WZR ; MOVA ZA0H.S[W12,0],P0/M,Z0.S ; MOVA ZA0H.S[W12,1],P0/M,Z1.S ; MOVA ZA0H.S[W12,2],P0/M,Z2.S ; MOVA ZA0H.S[W12,3],P0/M,Z3.S ; PTRUE P1.S,VL4 ; ST1W {ZA0V.S[W12,0]},P1,[X0] ; SMSTOP ; forall x={1,2,3,4} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V05.litmus.expected000066400000000000000000000003421475314470400273150ustar00rootroot00000000000000Test V05 Required States 1 x={1,2,3,4}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Matrix-Extensions-is-work-in-progress Condition forall (x={1,2,3,4}) Observation V05 Always 1 0 Hash=0cf19d9833300d409985c4f4c607de19 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V06.litmus000066400000000000000000000005431475314470400255210ustar00rootroot00000000000000AArch64 V06 { uint32_t x[4]; uint32_t y[4]; 0:X0=x; 0:X1=y; } P0 ; SMSTART ; INDEX Z0.S,#1,#1 ; PTRUE P0.S ; ADDHA ZA0.S,P0/M,P0/M,Z0.S ; PTRUE P1.S,VL4 ; ST1W {ZA0H.S[W12,0]},P1,[X0] ; ST1W {ZA0V.S[W12,0]},P1,[X1] ; SMSTOP ; forall x={1,2,3,4} /\ y={1,1,1,1}herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V06.litmus.expected000066400000000000000000000003761475314470400273250ustar00rootroot00000000000000Test V06 Required States 1 x={1,2,3,4}; y={1,1,1,1}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Matrix-Extensions-is-work-in-progress Condition forall (x={1,2,3,4} /\ y={1,1,1,1}) Observation V06 Always 1 0 Hash=f2a44fe50a32e2b90d5b5ab0f290b968 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V07.litmus000066400000000000000000000005431475314470400255220ustar00rootroot00000000000000AArch64 V07 { uint32_t x[4]; uint32_t y[4]; 0:X0=x; 0:X1=y; } P0 ; SMSTART ; INDEX Z0.S,#1,#1 ; PTRUE P0.S ; ADDVA ZA0.S,P0/M,P0/M,Z0.S ; PTRUE P1.S,VL4 ; ST1W {ZA0H.S[W12,0]},P1,[X0] ; ST1W {ZA0V.S[W12,0]},P1,[X1] ; SMSTOP ; forall x={1,1,1,1} /\ y={1,2,3,4}herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V07.litmus.expected000066400000000000000000000003761475314470400273260ustar00rootroot00000000000000Test V07 Required States 1 x={1,1,1,1}; y={1,2,3,4}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Matrix-Extensions-is-work-in-progress Condition forall (x={1,1,1,1} /\ y={1,2,3,4}) Observation V07 Always 1 0 Hash=caa0c4811f6f4e7cf8d9840493ad4622 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V08.litmus000066400000000000000000000006021475314470400255170ustar00rootroot00000000000000AArch64 V08 { uint32_t x[4]; uint32_t y[4]; 0:X0=x; 0:X1=y; } P0 ; SMSTART ; INDEX Z0.S,#1,#1 ; PTRUE P0.S ; PTRUE P1.S,VL2 ; ADDHA ZA0.S,P0/M,P1/M,Z0.S ; PTRUE P2.S,VL4 ; ST1W {ZA0H.S[W12,0]},P2,[X0] ; ST1W {ZA0V.S[W12,0]},P2,[X1] ; SMSTOP ; forall x={1,2,0,0} /\ y={1,1,1,1}herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V08.litmus.expected000066400000000000000000000003761475314470400273270ustar00rootroot00000000000000Test V08 Required States 1 x={1,2,0,0}; y={1,1,1,1}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Matrix-Extensions-is-work-in-progress Condition forall (x={1,2,0,0} /\ y={1,1,1,1}) Observation V08 Always 1 0 Hash=a03f6bd061c6c11a40cc9dde050f0cc2 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V09.litmus000066400000000000000000000006031475314470400255210ustar00rootroot00000000000000AArch64 V09 { uint32_t x[4]; uint32_t y[4]; 0:X0=x; 0:X1=y; } P0 ; SMSTART ; INDEX Z0.S,#1,#1 ; PTRUE P0.S ; PTRUE P1.S,VL2 ; ADDHA ZA0.S,P1/M,P0/M,Z0.S ; PTRUE P2.S,VL4 ; ST1W {ZA0H.S[W12,0]},P2,[X0] ; ST1W {ZA0V.S[W12,0]},P2,[X1] ; SMSTOP ; forall x={1,2,3,4} /\ y={1,1,0,0} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V09.litmus.expected000066400000000000000000000003761475314470400273300ustar00rootroot00000000000000Test V09 Required States 1 x={1,2,3,4}; y={1,1,0,0}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Matrix-Extensions-is-work-in-progress Condition forall (x={1,2,3,4} /\ y={1,1,0,0}) Observation V09 Always 1 0 Hash=d59f35f076c358f1289420acebdfb8d5 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V10.litmus000066400000000000000000000012631475314470400255140ustar00rootroot00000000000000AArch64 V10 { uint32_t out1[4]; uint32_t out2[4]; uint32_t out3[4]; uint32_t out4[4]; 0:X0=out1; 0:X1=out2; 0:X2=out3; 0:X3=out4; } P0 ; SMSTART ; INDEX Z0.S,#1,#1 ; PTRUE P0.S,VL4 ; ADDHA ZA0.S,P0/M,P0/M,Z0.S ; MOV W12,WZR ; MOVA Z1.S,P0/M,ZA0H.S[W12,0] ; MOVA Z2.S,P0/M,ZA0H.S[W12,1] ; MOVA Z3.S,P0/M,ZA0H.S[W12,2] ; MOVA Z4.S,P0/M,ZA0H.S[W12,3] ; ST1W {Z1.S},P0,[X0] ; ST1W {Z2.S},P0,[X1] ; ST1W {Z3.S},P0,[X2] ; ST1W {Z4.S},P0,[X3] ; SMSTOP ; forall out1={1,2,3,4} /\ out2={1,2,3,4} /\ out3={1,2,3,4} /\ out4={1,2,3,4} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V10.litmus.expected000066400000000000000000000005161475314470400273140ustar00rootroot00000000000000Test V10 Required States 1 out1={1,2,3,4}; out2={1,2,3,4}; out3={1,2,3,4}; out4={1,2,3,4}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Matrix-Extensions-is-work-in-progress Condition forall (out1={1,2,3,4} /\ out2={1,2,3,4} /\ out3={1,2,3,4} /\ out4={1,2,3,4}) Observation V10 Always 1 0 Hash=1cb750fb394b15b71a64fda3b2a736c5 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V11.litmus000066400000000000000000000007551475314470400255220ustar00rootroot00000000000000AArch64 V11 { uint64_t out1[2]; uint64_t out2[2]; 0:X0=out1; 0:X1=out2; } P0 ; SMSTART ; INDEX Z0.D,#1,#1 ; PTRUE P0.D,VL2 ; PTRUE P1.D,VL1 ; ADDHA ZA0.S,P1/M,P0/M,Z0.S ; MOV W12,WZR ; MOVA Z1.D,P0/M,ZA0H.D[W12,0] ; MOVA Z2.D,P0/M,ZA0H.D[W12,1] ; ST1D {Z1.D},P0,[X0] ; ST1D {Z2.D},P0,[X1] ; SMSTOP ; forall out1={1,2} /\ out2={0,0} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V11.litmus.expected000066400000000000000000000003721475314470400273150ustar00rootroot00000000000000Test V11 Required States 1 out1={1,2}; out2={0,0}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Matrix-Extensions-is-work-in-progress Condition forall (out1={1,2} /\ out2={0,0}) Observation V11 Always 1 0 Hash=dba8211d428abd43000d886a161202b4 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V12.litmus000066400000000000000000000013631475314470400255170ustar00rootroot00000000000000AArch64 V12 { uint16_t out1[8]; uint16_t out2[8]; uint16_t out3[8]; uint16_t out4[8]; 0:X0=out1; 0:X1=out2; 0:X2=out3; 0:X3=out4; } P0 ; SMSTART ; INDEX Z0.H,#1,#1 ; PTRUE P0.H,VL4 ; PTRUE P1.H,VL2 ; ADDHA ZA0.S,P0/M,P1/M,Z0.S ; MOV W12,WZR ; MOVA Z1.H,P0/M,ZA0H.H[W12,0] ; MOVA Z2.H,P0/M,ZA0H.H[W12,1] ; MOVA Z3.H,P0/M,ZA0H.H[W12,2] ; MOVA Z4.H,P0/M,ZA0H.H[W12,3] ; ST1H {Z1.H},P0,[X0] ; ST1H {Z2.H},P0,[X1] ; ST1H {Z3.H},P0,[X2] ; ST1H {Z4.H},P0,[X3] ; SMSTOP ; forall out1={1,2,0,0,0,0,0,0} /\ out2={0,0,0,0,0,0,0,0} /\ out3={1,2,0,0,0,0,0,0} /\ out4={0,0,0,0,0,0,0,0} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V12.litmus.expected000066400000000000000000000006161475314470400273170ustar00rootroot00000000000000Test V12 Required States 1 out1={1,2,0,0,0,0,0,0}; out2={0,0,0,0,0,0,0,0}; out3={1,2,0,0,0,0,0,0}; out4={0,0,0,0,0,0,0,0}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Matrix-Extensions-is-work-in-progress Condition forall (out1={1,2,0,0,0,0,0,0} /\ out2={0,0,0,0,0,0,0,0} /\ out3={1,2,0,0,0,0,0,0} /\ out4={0,0,0,0,0,0,0,0}) Observation V12 Always 1 0 Hash=b36d32cd4b9399a8fef3c8a4e9d4e47b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V13.litmus000066400000000000000000000016571475314470400255260ustar00rootroot00000000000000AArch64 V13 { uint32_t out1[4]; uint32_t out2[4]; uint32_t out3[4]; uint32_t out4[4]; 0:X0=out1; 0:X1=out2; 0:X2=out3; 0:X3=out4; } P0 ; SMSTART ; INDEX Z0.S,#1,#1 ; INDEX Z1.S,#2,#2 ; INDEX Z2.S,#3,#3 ; INDEX Z3.S,#4,#4 ; INDEX Z4.S,#5,#5 ; PTRUE P0.S,VL4 ; MOV W12,WZR ; MOVA ZA0H.S[W12,0],P0/M,Z0.S ; MOVA ZA0H.S[W12,1],P0/M,Z1.S ; MOVA ZA0H.S[W12,2],P0/M,Z2.S ; MOVA ZA0H.S[W12,3],P0/M,Z3.S ; ADDHA ZA0.S,P0/M,P0/M,Z4.S ; MOVA Z5.S,P0/M,ZA0H.S[W12,0] ; MOVA Z6.S,P0/M,ZA0H.S[W12,1] ; MOVA Z7.S,P0/M,ZA0H.S[W12,2] ; MOVA Z8.S,P0/M,ZA0H.S[W12,3] ; ST1W {Z5.S},P0,[X0] ; ST1W {Z6.S},P0,[X1] ; ST1W {Z7.S},P0,[X2] ; ST1W {Z8.S},P0,[X3] ; SMSTOP ; forall out1={6,12,18,24} /\ out2={7,14,21,28} /\ out3={8,16,24,32} /\ out4={9,18,27,36} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V13.litmus.expected000066400000000000000000000005461475314470400273220ustar00rootroot00000000000000Test V13 Required States 1 out1={6,12,18,24}; out2={7,14,21,28}; out3={8,16,24,32}; out4={9,18,27,36}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Matrix-Extensions-is-work-in-progress Condition forall (out1={6,12,18,24} /\ out2={7,14,21,28} /\ out3={8,16,24,32} /\ out4={9,18,27,36}) Observation V13 Always 1 0 Hash=48dd54a0560b53ac51afd1495d1c6531 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V14.litmus000066400000000000000000000016541475314470400255240ustar00rootroot00000000000000AArch64 T { uint32_t out1[4]; uint32_t out2[4]; uint32_t out3[4]; uint32_t out4[4]; 0:X0=out1; 0:X1=out2; 0:X2=out3; 0:X3=out4; } P0 ; SMSTART ; INDEX Z0.S,#1,#1 ; INDEX Z1.S,#2,#2 ; INDEX Z2.S,#3,#3 ; INDEX Z3.S,#4,#4 ; INDEX Z4.S,#5,#5 ; PTRUE P0.S,VL4 ; MOV W12,WZR ; MOVA ZA0H.S[W12,0],P0/M,Z0.S ; MOVA ZA0H.S[W12,1],P0/M,Z1.S ; MOVA ZA0H.S[W12,2],P0/M,Z2.S ; MOVA ZA0H.S[W12,3],P0/M,Z3.S ; ADDVA ZA0.S,P0/M,P0/M,Z4.S ; MOVA Z5.S,P0/M,ZA0H.S[W12,0] ; MOVA Z6.S,P0/M,ZA0H.S[W12,1] ; MOVA Z7.S,P0/M,ZA0H.S[W12,2] ; MOVA Z8.S,P0/M,ZA0H.S[W12,3] ; ST1W {Z5.S},P0,[X0] ; ST1W {Z6.S},P0,[X1] ; ST1W {Z7.S},P0,[X2] ; ST1W {Z8.S},P0,[X3] ; SMSTOP ; forall out1={6,7,8,9} /\ out2={12,14,16,18} /\ out3={18,21,24,27} /\ out4={24,28,32,36}herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V14.litmus.expected000066400000000000000000000005421475314470400273170ustar00rootroot00000000000000Test T Required States 1 out1={6,7,8,9}; out2={12,14,16,18}; out3={18,21,24,27}; out4={24,28,32,36}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Matrix-Extensions-is-work-in-progress Condition forall (out1={6,7,8,9} /\ out2={12,14,16,18} /\ out3={18,21,24,27} /\ out4={24,28,32,36}) Observation T Always 1 0 Hash=31753689ce7fc54b85ad30ff7c13808e herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V15.litmus000066400000000000000000000011661475314470400255230ustar00rootroot00000000000000AArch64 V15 { uint8_t out1[16]; uint8_t out2[16]; 0:X0=out1; 0:X1=out2; } P0 ; SMSTART ; INDEX Z0.B,#1,#1 ; INDEX Z1.B,#2,#2 ; INDEX Z4.B,#5,#5 ; PTRUE P0.B,VL4 ; MOV W12,WZR ; MOVA ZA0V.B[W12,0],P0/M,Z0.B ; MOVA ZA0V.B[W12,1],P0/M,Z1.B ; ADDVA ZA0.S,P0/M,P0/M,Z4.S ; MOVA Z5.B,P0/M,ZA0V.B[W12,0] ; MOVA Z6.B,P0/M,ZA0V.B[W12,1] ; ST1B {Z5.B},P0,[X0] ; ST1B {Z6.B},P0,[X1] ; SMSTOP ; forall out1={6,2,3,4,0,0,0,0,0,0,0,0,0,0,0,0} /\ out2={12,4,6,8,0,0,0,0,0,0,0,0,0,0,0,0}herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V15.litmus.expected000066400000000000000000000005541475314470400273230ustar00rootroot00000000000000Test V15 Required States 1 out1={6,2,3,4,0,0,0,0,0,0,0,0,0,0,0,0}; out2={12,4,6,8,0,0,0,0,0,0,0,0,0,0,0,0}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Matrix-Extensions-is-work-in-progress Condition forall (out1={6,2,3,4,0,0,0,0,0,0,0,0,0,0,0,0} /\ out2={12,4,6,8,0,0,0,0,0,0,0,0,0,0,0,0}) Observation V15 Always 1 0 Hash=e543292764b340f4a2c44192e1b4acb5 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V16.litmus000066400000000000000000000011051475314470400255150ustar00rootroot00000000000000AArch64 V16 { uint16_t out1[3]; uint16_t out2[3]; 0:X0=out1; 0:X1=out2; } P0 ; SMSTART ; INDEX Z2.H,#3,#3 ; INDEX Z3.H,#4,#4 ; INDEX Z4.H,#5,#5 ; PTRUE P0.H,VL3 ; MOV W12,WZR ; MOVA ZA0V.H[W12,2],P0/M,Z2.H ; MOVA ZA0V.H[W12,3],P0/M,Z3.H ; ADDHA ZA0.S,P0/M,P0/M,Z4.S ; MOVA Z7.H,P0/M,ZA0V.H[W12,2] ; MOVA Z8.H,P0/M,ZA0V.H[W12,3] ; ST1H {Z7.H},P0,[X0] ; ST1H {Z8.H},P0,[X1] ; SMSTOP ; forall out1={18,6,24} /\ out2={24,8,32}herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V16.litmus.expected000066400000000000000000000004121475314470400273150ustar00rootroot00000000000000Test V16 Required States 1 out1={18,6,24}; out2={24,8,32}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Matrix-Extensions-is-work-in-progress Condition forall (out1={18,6,24} /\ out2={24,8,32}) Observation V16 Always 1 0 Hash=51b39d2dc6abd0d1ff28fd7d37dbb410 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V17.litmus000066400000000000000000000014611475314470400255230ustar00rootroot00000000000000AArch64 V17 { uint32_t x[4] = {101,102,103,104}; uint32_t out1[4]; uint32_t out2[4]; uint32_t out3[4]; uint32_t out4[4]; 0:X0=x; 0:X2=out1; 0:X3=out2; 0:X4=out3; 0:X5=out4; } P0 ; SMSTART ; INDEX Z0.S,#1,#1 ; PTRUE P0.S,VL4 ; PTRUE P1.S,VL4 ; ADDHA ZA0.S,P0/M,P1/M,Z0.S ; MOV W12,WZR ; LD1W {ZA0H.S[W12,0]},P1/Z,[X0]; MOVA Z1.S,P0/M,ZA0H.S[W12,0] ; MOVA Z2.S,P0/M,ZA0H.S[W12,1] ; MOVA Z3.S,P0/M,ZA0H.S[W12,2] ; MOVA Z4.S,P0/M,ZA0H.S[W12,3] ; ST1W {Z1.S},P0,[X2] ; ST1W {Z2.S},P0,[X3] ; ST1W {Z3.S},P0,[X4] ; ST1W {Z4.S},P0,[X5] ; SMSTOP ; forall out1={101,102,103,104} /\ out2={1,2,3,4} /\ out3={1,2,3,4} /\ out4={1,2,3,4} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V17.litmus.expected000066400000000000000000000005361475314470400273250ustar00rootroot00000000000000Test V17 Required States 1 out1={101,102,103,104}; out2={1,2,3,4}; out3={1,2,3,4}; out4={1,2,3,4}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Matrix-Extensions-is-work-in-progress Condition forall (out1={101,102,103,104} /\ out2={1,2,3,4} /\ out3={1,2,3,4} /\ out4={1,2,3,4}) Observation V17 Always 1 0 Hash=70e4d0b029b6e123b1d018c4f89b58ef herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V18.litmus000066400000000000000000000016061475314470400255250ustar00rootroot00000000000000AArch64 V18 { uint32_t x[4] = {101,102,103,104}; uint32_t y[4] = {201,202,203,204}; uint32_t out1[4]; uint32_t out2[4]; uint32_t out3[4]; uint32_t out4[4]; 0:X0=x; 0:X1=y; 0:X2=out1; 0:X3=out2; 0:X4=out3; 0:X5=out4; } P0 ; SMSTART ; INDEX Z0.S,#1,#1 ; PTRUE P0.S,VL4 ; PTRUE P1.S,VL4 ; ADDHA ZA0.S,P0/M,P1/M,Z0.S ; MOV W12,WZR ; LD1W {ZA0H.S[W12,0]},P1/Z,[X0]; LD1W {ZA0H.S[W12,1]},P1/Z,[X1]; MOVA Z1.S,P0/M,ZA0H.S[W12,0] ; MOVA Z2.S,P0/M,ZA0H.S[W12,1] ; MOVA Z3.S,P0/M,ZA0H.S[W12,2] ; MOVA Z4.S,P0/M,ZA0H.S[W12,3] ; ST1W {Z1.S},P0,[X2] ; ST1W {Z2.S},P0,[X3] ; ST1W {Z3.S},P0,[X4] ; ST1W {Z4.S},P0,[X5] ; SMSTOP ; forall out1={101,102,103,104} /\ out2={201,202,203,204} /\ out3={1,2,3,4} /\ out4={1,2,3,4} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V18.litmus.expected000066400000000000000000000005561475314470400273300ustar00rootroot00000000000000Test V18 Required States 1 out1={101,102,103,104}; out2={201,202,203,204}; out3={1,2,3,4}; out4={1,2,3,4}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Matrix-Extensions-is-work-in-progress Condition forall (out1={101,102,103,104} /\ out2={201,202,203,204} /\ out3={1,2,3,4} /\ out4={1,2,3,4}) Observation V18 Always 1 0 Hash=9cad396b92195f291eb9799da7f64b7b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V19.litmus000066400000000000000000000012441475314470400255240ustar00rootroot00000000000000AArch64 V19 { uint32_t x[4] = {101,102,103,104}; uint32_t y[4] = {201,202,203,204}; uint32_t out1[4]; uint32_t out2[4]; 0:X0=x; 0:X1=y; 0:X2=out1; 0:X3=out2; } P0 ; SMSTART ; INDEX Z0.S,#1,#1 ; PTRUE P0.S,VL4 ; PTRUE P1.S,VL4 ; ADDHA ZA0.S,P0/M,P1/M,Z0.S ; MOV W12,WZR ; LD1W {ZA0H.S[W12,0]},P1/Z,[X0]; LD1W {ZA1H.S[W12,1]},P1/Z,[X1]; MOVA Z1.S,P0/M,ZA0H.S[W12,0] ; MOVA Z2.S,P0/M,ZA1H.S[W12,1] ; ST1W {Z1.S},P0,[X2] ; ST1W {Z2.S},P0,[X3] ; SMSTOP ; forall out1={101,102,103,104} /\ out2={201,202,203,204} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V19.litmus.expected000066400000000000000000000004521475314470400273240ustar00rootroot00000000000000Test V19 Required States 1 out1={101,102,103,104}; out2={201,202,203,204}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Matrix-Extensions-is-work-in-progress Condition forall (out1={101,102,103,104} /\ out2={201,202,203,204}) Observation V19 Always 1 0 Hash=8b4a5ce7c1dc5b3590c0cb217e97a6f6 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V20.litmus000066400000000000000000000011041475314470400255070ustar00rootroot00000000000000AArch64 V20 { uint32_t x[4] = {101,102,103,104}; uint32_t y[4] = {201,202,203,204}; 0:X0=x; 0:X1=y; uint32_t out1[4]; uint32_t out2[4]; 0:X2=out1; 0:X3=out2; } P0 ; SMSTART ; PTRUE P1.S,VL4 ; MOV W12,WZR ; LD1W {ZA0H.S[W12,1]},P1/Z,[X0]; LD1W {ZA1H.S[W12,0]},P1/Z,[X1]; MOVA Z0.S,P1/M,ZA0H.S[W12,1] ; MOVA Z1.S,P1/M,ZA1H.S[W12,0] ; ST1W {Z0.S},P1,[X2] ; ST1W {Z1.S},P1,[X3] ; SMSTOP ; forall out1={101,102,103,104} /\ out2={201,202,203,204} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V20.litmus.expected000066400000000000000000000004521475314470400273140ustar00rootroot00000000000000Test V20 Required States 1 out1={101,102,103,104}; out2={201,202,203,204}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Matrix-Extensions-is-work-in-progress Condition forall (out1={101,102,103,104} /\ out2={201,202,203,204}) Observation V20 Always 1 0 Hash=bb6eb56aaad338240d1de3408688030b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V21.litmus000066400000000000000000000006031475314470400255130ustar00rootroot00000000000000AArch64 V21 { uint32_t x[4]; uint32_t y[4]; 0:X0=x; 0:X1=y; } P0 ; SMSTART ; INDEX Z0.S,#1,#1 ; PTRUE P0.S ; PTRUE P1.S,VL2 ; ADDVA ZA0.S,P0/M,P1/M,Z0.S ; PTRUE P2.S,VL4 ; ST1W {ZA0H.S[W12,0]},P2,[X0] ; ST1W {ZA0V.S[W12,0]},P2,[X1] ; SMSTOP ; forall x={1,1,0,0} /\ y={1,2,3,4} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sme/V21.litmus.expected000066400000000000000000000003761475314470400273220ustar00rootroot00000000000000Test V21 Required States 1 x={1,1,0,0}; y={1,2,3,4}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Matrix-Extensions-is-work-in-progress Condition forall (x={1,1,0,0} /\ y={1,2,3,4}) Observation V21 Always 1 0 Hash=e488225ea924f48a536cd42e3c785833 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/000077500000000000000000000000001475314470400237165ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V01.litmus000066400000000000000000000004101475314470400255160ustar00rootroot00000000000000AArch64 V01 (* Add vectors (unpredicated) *) { } P0 ; MOV Z0.S, #1 ; MOV Z1.S, #2 ; ADD Z2.S,Z1.S,Z0.S ; MOV Z3.D, #3 ; MOV Z4.D, #4 ; ADD Z5.D,Z4.D,Z3.D ; forall 0:V2.4S={3,3,3,3} /\ 0:V5.4S={7,0,7,0} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V01.litmus.expected000066400000000000000000000004261475314470400273250ustar00rootroot00000000000000Test V01 Required States 1 0:V2.4S={3,3,3,3}; 0:V5.4S={7,0,7,0}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (0:V2.4S={3,3,3,3} /\ 0:V5.4S={7,0,7,0}) Observation V01 Always 1 0 Hash=dd05dffbd617d9f8658242b89d30bec8 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V02.litmus000066400000000000000000000003661475314470400255310ustar00rootroot00000000000000AArch64 V02 (* Broadcast general-purpose register to vector elements (unpredicated) *) { } P0 ; MOV W0,#4 ; DUP Z0.H, W0 ; DUP Z1.S, W0 ; forall 0:V0.4S={0x40004,0x40004,0x40004,0x40004} /\ 0:V1.4S={4,4,4,4} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V02.litmus.expected000066400000000000000000000004761475314470400273330ustar00rootroot00000000000000Test V02 Required States 1 0:V0.4S={262148,262148,262148,262148}; 0:V1.4S={4,4,4,4}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (0:V0.4S={262148,262148,262148,262148} /\ 0:V1.4S={4,4,4,4}) Observation V02 Always 1 0 Hash=de76ac983b66dc71631de247107dea60 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V03.litmus000066400000000000000000000003051475314470400255230ustar00rootroot00000000000000AArch64 V03 (* Initialise predicate from named constraint *) { int x[4]; 0:X0=x; } P0 ; PTRUE P0.S,VL3 ; MOV Z0.S,#1 ; ST1W {Z0.S},P0,[X0]; forall(x = {1,1,1,0}) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V03.litmus.expected000066400000000000000000000003421475314470400273240ustar00rootroot00000000000000Test V03 Required States 1 x={1,1,1,0}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (x={1,1,1,0}) Observation V03 Always 1 0 Hash=4d6c70541c7e2576a5148e43c261e804 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V04.litmus000066400000000000000000000004541475314470400255310ustar00rootroot00000000000000AArch64 V04 (* Contiguous load unsigned bytes to vector (scalar index), 32-bit element *) { uint8_t x[4] = {1,2,3,4}; 0:X0=x; } P0 ; MOV X1,#0 ; PTRUE P0.S,VL4 ; LD1B {Z1.S},P0/Z,[X0,X1] ; forall(0:V1.4S = {1,2,3,4}) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V04.litmus.expected000066400000000000000000000003561475314470400273320ustar00rootroot00000000000000Test V04 Required States 1 0:V1.4S={1,2,3,4}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (0:V1.4S={1,2,3,4}) Observation V04 Always 1 0 Hash=6c05c2f57e2f2a230130f55ecf9803c1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V05.litmus000066400000000000000000000005321475314470400255270ustar00rootroot00000000000000AArch64 V05 (* Contiguous load two-word structures to two vectors (scalar index) *) { uint16_t x[8] = {1,2,0,0,0,0,0,0}; 0:X0=x; } P0 ; MOV X2,#0 ; PTRUE P0.H,VL1 ; LD2H {Z0.H,Z1.H},P0/Z,[X0,X2,LSL #1] ; forall(0:V0.4S = {1,0,0,0} /\ 0:V1.4S = {2,0,0,0}) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V05.litmus.expected000066400000000000000000000004261475314470400273310ustar00rootroot00000000000000Test V05 Required States 1 0:V0.4S={1,0,0,0}; 0:V1.4S={2,0,0,0}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (0:V0.4S={1,0,0,0} /\ 0:V1.4S={2,0,0,0}) Observation V05 Always 1 0 Hash=82b3428acf9418cdbdbcd1cac3a5204b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V06.litmus000066400000000000000000000006151475314470400255320ustar00rootroot00000000000000AArch64 V06 (* Contiguous load three-word structures to three vectors (scalar index) *) { int x[12] = {1,2,3,1,2,3,1,2,3,1,2,3}; 0:X0=x; } P0 ; MOV X2,#0 ; PTRUE P0.S,VL4 ; LD3W {Z0.S,Z1.S,Z2.S},P0/Z,[X0,X2,LSL #2] ; forall(0:V0.4S = {1,1,1,1} /\ 0:V1.4S = {2,2,2,2} /\ 0:V2.4S = {3,3,3,3}) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V06.litmus.expected000066400000000000000000000004761475314470400273370ustar00rootroot00000000000000Test V06 Required States 1 0:V0.4S={1,1,1,1}; 0:V1.4S={2,2,2,2}; 0:V2.4S={3,3,3,3}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (0:V0.4S={1,1,1,1} /\ 0:V1.4S={2,2,2,2} /\ 0:V2.4S={3,3,3,3}) Observation V06 Always 1 0 Hash=0b0d64e1c8f343cdce7976205bc08f2b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V07.litmus000066400000000000000000000006551475314470400255370ustar00rootroot00000000000000AArch64 V07 (* Contiguous load four-word structures to four vectors (scalar index) *) { uint64_t x[8] = {1,2,3,4,1,2,3,4}; 0:X0=x; } P0 ; MOV X2,#0 ; PTRUE P0.D,VL2 ; LD4D {Z0.D,Z1.D,Z2.D,Z3.D},P0/Z,[X0,X2,LSL #3]; forall(0:V0.4S = {1,0,1,0} /\ 0:V1.4S = {2,0,2,0} /\ 0:V2.4S = {3,0,3,0} /\ 0:V3.4S = {4,0,4,0}) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V07.litmus.expected000066400000000000000000000005461475314470400273360ustar00rootroot00000000000000Test V07 Required States 1 0:V0.4S={1,0,1,0}; 0:V1.4S={2,0,2,0}; 0:V2.4S={3,0,3,0}; 0:V3.4S={4,0,4,0}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (0:V0.4S={1,0,1,0} /\ 0:V1.4S={2,0,2,0} /\ 0:V2.4S={3,0,3,0} /\ 0:V3.4S={4,0,4,0}) Observation V07 Always 1 0 Hash=b6883bda119e7c00f9493ab4b2a289a8 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V08.litmus000066400000000000000000000003411475314470400255300ustar00rootroot00000000000000AArch64 V08 (* Broadcast signed immediate to vector elements (unpredicated) *) { } P0 ; MOV Z0.S,#4 ; MOV Z1.B,#1 ; forall 0:V0.4S={4,4,4,4} /\ 0:V1.4S={0x1010101,0x1010101,0x1010101,0x1010101} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V08.litmus.expected000066400000000000000000000005161475314470400273340ustar00rootroot00000000000000Test V08 Required States 1 0:V0.4S={4,4,4,4}; 0:V1.4S={16843009,16843009,16843009,16843009}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (0:V0.4S={4,4,4,4} /\ 0:V1.4S={16843009,16843009,16843009,16843009}) Observation V08 Always 1 0 Hash=325848570958ac8e2b931cf1c48564dd herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V09.litmus000066400000000000000000000004441475314470400255350ustar00rootroot00000000000000AArch64 V09 (* Contiguous store words from vector (scalar index) *) { uint8_t x[4]; 0:X0=x; } P0 ; MOV Z1.S,#1 ; MOV X1,#0 ; PTRUE P0.H,VL4 ; ST1B {Z1.H},P0,[X0,X1] ; forall x={1,0,1,0} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V09.litmus.expected000066400000000000000000000003421475314470400273320ustar00rootroot00000000000000Test V09 Required States 1 x={1,0,1,0}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (x={1,0,1,0}) Observation V09 Always 1 0 Hash=b5926a609acc60970724fd0fd2512677 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V10.litmus000066400000000000000000000006011475314470400255200ustar00rootroot00000000000000AArch64 V10 (* Contiguous store two-word structures from two vectors (scalar index) *) { uint16_t x[8]; 0:X0=x; } P0 ; MOV Z1.H,#1 ; MOV Z2.H,#2 ; MOV X1,#0 ; PTRUE P0.H,VL4 ; ST2H {Z1.H,Z2.H},P0,[X0,X1, LSL #1] ; forall x={1,2,1,2,1,2,1,2} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V10.litmus.expected000066400000000000000000000003621475314470400273240ustar00rootroot00000000000000Test V10 Required States 1 x={1,2,1,2,1,2,1,2}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (x={1,2,1,2,1,2,1,2}) Observation V10 Always 1 0 Hash=b9d08a35b5381eeb0056a1674df33653 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V11.litmus000066400000000000000000000007061475314470400255270ustar00rootroot00000000000000AArch64 V11 (* Contiguous store three-word structures from three vectors (scalar index) *) { int x[12]; 0:X0=x; } P0 ; MOV Z1.S,#1 ; MOV Z2.S,#2 ; MOV Z3.S,#3 ; MOV X1,#0 ; PTRUE P0.S,VL4 ; ST3W {Z1.S,Z2.S,Z3.S},P0,[X0,X1, LSL #2]; forall x={1,2,3,1,2,3,1,2,3,1,2,3} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V11.litmus.expected000066400000000000000000000004021475314470400273200ustar00rootroot00000000000000Test V11 Required States 1 x={1,2,3,1,2,3,1,2,3,1,2,3}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (x={1,2,3,1,2,3,1,2,3,1,2,3}) Observation V11 Always 1 0 Hash=a3c15b9b49c3645ba9113a9354c7a46a herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V12.litmus000066400000000000000000000010431475314470400255230ustar00rootroot00000000000000AArch64 V12 (* Contiguous store four-word structures from four vectors (scalar index) *) { uint64_t x[8]; 0:X0=x; } P0 ; MOV Z1.D,#1 ; MOV Z2.D,#2 ; MOV Z3.D,#3 ; MOV Z4.D,#4 ; MOV X1,#0 ; PTRUE P0.D,VL2 ; ST4D {Z1.D,Z2.D,Z3.D,Z4.D},P0,[X0,X1, LSL #3] ; forall x={1,2,3,4,1,2,3,4} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V12.litmus.expected000066400000000000000000000003621475314470400273260ustar00rootroot00000000000000Test V12 Required States 1 x={1,2,3,4,1,2,3,4}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (x={1,2,3,4,1,2,3,4}) Observation V12 Always 1 0 Hash=f059652d76c3a984d2cb9d3649b83389 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V13.litmus000066400000000000000000000002521475314470400255250ustar00rootroot00000000000000AArch64 V13 (* Unsigned add reduction to scalar *) { } P0 ; MOV Z0.S,#4 ; PTRUE P0.S,VL3 ; UADDV D1,P0,Z0.S ; forall 0:V1.4S={12,0,0,0} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V13.litmus.expected000066400000000000000000000003601475314470400273250ustar00rootroot00000000000000Test V13 Required States 1 0:V1.4S={12,0,0,0}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (0:V1.4S={12,0,0,0}) Observation V13 Always 1 0 Hash=5e391bba5dda1e4a4f1f0a45c2c48975 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V14.litmus000066400000000000000000000004071475314470400255300ustar00rootroot00000000000000AArch64 V14 (* INDEX *) { } P0 ; MOV W0,#2 ; INDEX Z0.S,W0,#3 ; INDEX Z1.S,#0,#1 ; INDEX Z2.H,W0,W0 ; INDEX Z3.D,#1,#2 ; forall 0:V0.4S={2,5,8,11} /\ 0:V1.4S={0,1,2,3} /\ 0:V2.4S={0x40002,0x80006,0xc000a,0x10000e} /\ 0:V3.4S={1,0,3,0} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V14.litmus.expected000066400000000000000000000006221475314470400273270ustar00rootroot00000000000000Test V14 Required States 1 0:V0.4S={2,5,8,11}; 0:V1.4S={0,1,2,3}; 0:V2.4S={262146,524294,786442,1048590}; 0:V3.4S={1,0,3,0}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (0:V0.4S={2,5,8,11} /\ 0:V1.4S={0,1,2,3} /\ 0:V2.4S={262146,524294,786442,1048590} /\ 0:V3.4S={1,0,3,0}) Observation V14 Always 1 0 Hash=93b29826278f620a466dfd3446e3f014 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V15.litmus000066400000000000000000000023521475314470400255320ustar00rootroot00000000000000AArch64 V15 (* WHILELT (predicate) *) { } P0 ; MOV W0,#0 ; MOV W1,#0 ; WHILELT P0.S,W0,W1 ; (* No active elemenets *) B.EQ L0 ; (* All Active elements were FALSE or there were no Active elements. Z == 1 *) MOV W2,#1 ; L0: ; B.CS L1 ; (* The Last active element was FALSE or there were no Active elements. C == 1 *) MOV W2,#2 ; L1: ; B.PL L3 ; (* The First active element was FALSE or there were no Active elements. N == 0 *) MOV W2,#3 ; L3: MOV W1,#1 ; (* First element is active but not Last *) WHILELT P1.S,W0,W1 ; B.NE L4 ; (* An Active element was TRUE. Z == 0 *) MOV W2,#4 ; L4: ; B.MI L5 ; (* The First active element was TRUE. N == 1 *) MOV W2,#5 ; L5: ; B.HI L6 ; (* An Active element was TRUE, but the Last active element was FALSE. C ==1 && Z == 0 *) MOV W2,#6 ; L6: ; MOV W1,#64 ; WHILELT P2.S,W0,W1 ; (* All elements are active including Last *) B.CC END ; (* The Last active element was TRUE. C == 0 *) MOV W2,#7 ; END: ; forall 0:X2=0 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V15.litmus.expected000066400000000000000000000003301475314470400273240ustar00rootroot00000000000000Test V15 Required States 1 0:X2=0; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (0:X2=0) Observation V15 Always 1 0 Hash=a5e517ea61f31faa909e892130e6b597 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V16.litmus000066400000000000000000000005231475314470400255310ustar00rootroot00000000000000AArch64 V16 { int x[4]={0,1,2,3}; int y[4]={5,6,7,8}; 0:X0=x; 0:X1=y; } P0 ; MOV W2,#0 ; MOV W3,#4 ; WHILELT P0.S,W2,W3 ; LD1W {Z1.S},P0/Z,[X0] ; LD1W {Z2.S},P0/Z,[X1,Z1.S,UXTW #2]; forall 0:V1.4S={0,1,2,3} /\ 0:V2.4S={5,6,7,8} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V16.litmus.expected000066400000000000000000000004261475314470400273330ustar00rootroot00000000000000Test V16 Required States 1 0:V1.4S={0,1,2,3}; 0:V2.4S={5,6,7,8}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (0:V1.4S={0,1,2,3} /\ 0:V2.4S={5,6,7,8}) Observation V16 Always 1 0 Hash=97b55b740335168c5e12a073693d253a herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V17.litmus000066400000000000000000000005731475314470400255370ustar00rootroot00000000000000AArch64 V17 { int x[4]; int y[4]; 0:X0=x; 0:X1=y } P0 ; MOV W2,#0 ; MOV W3,#4 ; WHILELT P0.S,W2,W3 ; MOV Z0.S,#4 ; ST1W {Z0.S},P0,[X0] ; INDEX Z1.S,W2,#1 ; ST1W {Z1.S},P0,[X1,Z1.S,UXTW #2] ; forall x={4,4,4,4} /\ y={0,1,2,3} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V17.litmus.expected000066400000000000000000000003761475314470400273400ustar00rootroot00000000000000Test V17 Required States 1 x={4,4,4,4}; y={0,1,2,3}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (x={4,4,4,4} /\ y={0,1,2,3}) Observation V17 Always 1 0 Hash=f50938e525aa0cec3773dbec42193ada herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V18.litmus000066400000000000000000000003251475314470400255330ustar00rootroot00000000000000AArch64 V18 { int x[8] = {1,2,1,2,1,2,1,2}; 0:X0=x; } P0 ; PTRUE P0.S,VL4 ; LD2W {Z0.S,Z1.S},P0/Z,[X0] ; forall 0:V0.4S = {1,1,1,1} /\ 0:V1.4S = {2,2,2,2} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V18.litmus.expected000066400000000000000000000004261475314470400273350ustar00rootroot00000000000000Test V18 Required States 1 0:V0.4S={1,1,1,1}; 0:V1.4S={2,2,2,2}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (0:V0.4S={1,1,1,1} /\ 0:V1.4S={2,2,2,2}) Observation V18 Always 1 0 Hash=55d8e3d714ba1b661c4ad767c5d3cbee herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V19.litmus000066400000000000000000000003301475314470400255300ustar00rootroot00000000000000AArch64 V19 {} P0 ; MOV Z0.S,#1 ; MOV Z1.S,#2 ; MOV Z2.S,#-1 ; PTRUE P0.S,VL2 ; MOVPRFX Z1.S,P0/Z,Z0.S ; NEG Z1.S,P0/M,Z2.S ; forall 0:V1.4S={1,1,0,0} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V19.litmus.expected000066400000000000000000000003561475314470400273400ustar00rootroot00000000000000Test V19 Required States 1 0:V1.4S={1,1,0,0}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (0:V1.4S={1,1,0,0}) Observation V19 Always 1 0 Hash=2a7dcf8717c679858b3d9b0347124aca herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V20.litmus000066400000000000000000000003301475314470400255200ustar00rootroot00000000000000AArch64 V20 {} P0 ; MOV Z0.S,#1 ; MOV Z1.S,#2 ; MOV Z2.S,#-1 ; PTRUE P0.S,VL3 ; MOVPRFX Z1.S,P0/M,Z0.S ; NEG Z1.S,P0/M,Z2.S ; forall 0:V1.4S={1,1,1,2} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V20.litmus.expected000066400000000000000000000003561475314470400273300ustar00rootroot00000000000000Test V20 Required States 1 0:V1.4S={1,1,1,2}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (0:V1.4S={1,1,1,2}) Observation V20 Always 1 0 Hash=f5073ff7daa0f2b6acb6dea49f4fc61a herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V21.litmus000066400000000000000000000002461475314470400255270ustar00rootroot00000000000000AArch64 V21 {} P0 ; MOV Z0.S,#-1 ; MOV Z1.S,#2 ; PTRUE P0.S,VL3 ; NEG Z1.S,P0/M,Z0.S ; forall 0:V1.4S={1,1,1,2} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V21.litmus.expected000066400000000000000000000003561475314470400273310ustar00rootroot00000000000000Test V21 Required States 1 0:V1.4S={1,1,1,2}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (0:V1.4S={1,1,1,2}) Observation V21 Always 1 0 Hash=b2c63565af19e50740733f57fc3bf64a herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V22.litmus000066400000000000000000000003261475314470400255270ustar00rootroot00000000000000AArch64 V22 { uint32_t t[4] = {1,2,3,4}; uint32_t u[4]; 0:X0=t; 0:X2=u; } P0 ; PTRUE P0.D,VL2 ; LD1W {Z0.S},P0/Z,[X0] ; PTRUE P1.S,VL4 ; ST1W {Z0.S},P1,[X2] ; forall u={1,0,3,0} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V22.litmus.expected000066400000000000000000000003421475314470400273250ustar00rootroot00000000000000Test V22 Required States 1 u={1,0,3,0}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (u={1,0,3,0}) Observation V22 Always 1 0 Hash=127c963482a7f302ee802ab4edf0d57f herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V23.litmus000066400000000000000000000002751475314470400255330ustar00rootroot00000000000000AArch64 V23 Variant=sve:512 { uint64_t 0:X0; uint64_t 0:X1; } P0 ; RDVL X0,#0 ; RDVL X1,#1 ; forall 0:X0=0 /\ 0:X1=64 (* Notice: 0:X1 value depends on the target test runs on *) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V23.litmus.expected000066400000000000000000000003541475314470400273310ustar00rootroot00000000000000Test V23 Required States 1 0:X0=0; 0:X1=64; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (0:X0=0 /\ 0:X1=64) Observation V23 Always 1 0 Hash=2e5dfca61b0bd045b16659236f6c3297 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V24.litmus000066400000000000000000000006621475314470400255340ustar00rootroot00000000000000AArch64 V24 Variant=sve:512 { uint64_t 0:X0; uint64_t 0:X1; uint64_t 0:X2; uint64_t 0:X3; uint64_t 0:X4; } P0 ; CNTB X0,VL4 ; INCB X0,VL4 ; CNTW X1 ; INCW X1 ; CNTD X2,ALL,MUL 16 ; INCD X2,ALL,MUL 16 ; CNTW X3,MUL3 ; INCW X3,MUL3 ; CNTD X4,MUL4 ; INCD X4,MUL4 ; CNTW XZR ; forall 0:X0=8 /\ 0:X1=32 /\ 0:X2=256 /\ 0:X3=30 /\ 0:X4=16 (* Notice: contents of registers 0:X1 to 0:X4 depend on where test runs *) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V24.litmus.expected000066400000000000000000000004521475314470400273310ustar00rootroot00000000000000Test V24 Required States 1 0:X0=8; 0:X1=32; 0:X2=256; 0:X3=30; 0:X4=16; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (0:X0=8 /\ 0:X1=32 /\ 0:X2=256 /\ 0:X3=30 /\ 0:X4=16) Observation V24 Always 1 0 Hash=b8d825a2a1e147c6c00a1289b0020343 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V25.litmus000066400000000000000000000012771475314470400255400ustar00rootroot00000000000000AArch64 V25 { uint32_t t[8] = {1,2,3,4,5,6,7,8}; 0:X1=t; } (* This test does not depends on scalable vector length *) P0 ; CNTW X0 ; CMP X0,#8 ; B.GT L3 ; MOV X2,#0 ; PTRUE P0.S ; L1: ; LD1W {Z0.S},P0/Z,[X1] ; ADD Z0.S,Z0.S,Z0.S ; ST1W {Z0.S},P0,[X1] ; ADD W9,W9,#1 ; ADD X1,X1,X0,LSL #2 ; INCW X2 ; L2: ; CMP X2,#8 ; B.LT L1 ; B L0 ; L3: ; PTRUE P0.S,VL8 ; LD1W {Z0.S},P0/Z,[X1] ; ADD Z0.S,Z0.S,Z0.S ; ST1W {Z0.S},P0,[X1] ; L0: ; forall t={2,4,6,8,10,12,14,16} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V25.litmus.expected000066400000000000000000000003721475314470400273330ustar00rootroot00000000000000Test V25 Required States 1 t={2,4,6,8,10,12,14,16}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (t={2,4,6,8,10,12,14,16}) Observation V25 Always 1 0 Hash=958bdcbf1110aef9cf71940cd7bcf316 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V26.litmus000066400000000000000000000007331475314470400255350ustar00rootroot00000000000000AArch64 V26 (* This test is independant of vector length *) { uint32_t x[8] = {1,2,3,4,5,6,7,8}; 0:X0=x; } P0 ; MOV X1,#0 ; MOV X2,#8 ; WHILELT P0.S,X1,X2 ; L0: ; LD1W {Z0.S},P0/Z,[X0,X1,LSL #2]; ADD Z0.S,Z0.S,Z0.S ; ST1W {Z0.S},P0,[X0,X1,LSL #2] ; INCW X1 ; WHILELT P0.S,X1,X2 ; B.FIRST L0 ; forall x={2,4,6,8,10,12,14,16} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V26.litmus.expected000066400000000000000000000003721475314470400273340ustar00rootroot00000000000000Test V26 Required States 1 x={2,4,6,8,10,12,14,16}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (x={2,4,6,8,10,12,14,16}) Observation V26 Always 1 0 Hash=4a5e6f3283cc09704cdac82fc224a11b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V27.litmus000066400000000000000000000004131475314470400255310ustar00rootroot00000000000000AArch64 V27 { uint64_t t[2] = {0xffffffffffffffff,0x0}; uint64_t u[2] = {0x1,0x0}; 0:X0=t; 0:X1=u; } P0 ; PTRUE P0.D,VL2 ; LD1D {Z0.D},P0/Z,[X0] ; LD1D {Z1.D},P0/Z,[X1] ; ADD Z0.D,Z0.D,Z1.D ; ST1D {Z0.D},P0,[X0] ; forall t={0,0} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V27.litmus.expected000066400000000000000000000003321475314470400273310ustar00rootroot00000000000000Test V27 Required States 1 t={0,0}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (t={0,0}) Observation V27 Always 1 0 Hash=0f6e065f907c5a7fe1ad1218b44ea0e1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V28.litmus000066400000000000000000000003661475314470400255410ustar00rootroot00000000000000AArch64 V28 { uint8_t t[6] = {255,255,255,255,255,255}; 0:X0=t; } P0 ; INDEX Z1.B,#1,#3 ; PTRUE P0.B,VL6 ; LD1B {Z0.B},P0/Z,[X0] ; ADD Z0.B,Z0.B,Z1.B ; ST1B {Z0.B},P0,[X0] ; forall t={0,3,6,9,12,15} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V28.litmus.expected000066400000000000000000000003561475314470400273400ustar00rootroot00000000000000Test V28 Required States 1 t={0,3,6,9,12,15}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (t={0,3,6,9,12,15}) Observation V28 Always 1 0 Hash=bc74fed293e5506ea70cae45c5fb0911 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V29.litmus000066400000000000000000000002071475314470400255340ustar00rootroot00000000000000AArch64 V29 (* Output vector lenght, in bytes *) Variant=sve:512 { uint64_t 0:X0; } P0 ; CNTB X0 ; forall 0:X0=64 ; herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V29.litmus.expected000066400000000000000000000003321475314470400273330ustar00rootroot00000000000000Test V29 Required States 1 0:X0=64; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (0:X0=64) Observation V29 Always 1 0 Hash=c0179047f87d6ae87f6e7c40bee8fd71 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V30.litmus000066400000000000000000000007671475314470400255370ustar00rootroot00000000000000AArch64 V30 (* Write scatter. In particular, test sign extension *) Variant=sve:512 { int t[4]; uint8_t u[8]; int v[4]; 0:X0=t; 0:X1=u; 0:X2=v; } P0 ; INDEX Z0.S,#0,#1 ; INDEX Z1.S,#2,#2 ; PTRUE P0.S,VL4 ; ST1W {Z1.S},P0,[X0,Z0.S,SXTW #2] ; INDEX Z1.D,#0,#2 ; PTRUE P0.D,VL4 ; ST1B {Z1.D},P0,[X1,Z1.D] ; ADD X2,X2,#16; INDEX Z0.S,#1,#1 ; INDEX Z1.S,#-1,#-1 ; PTRUE P0.S,VL4 ; ST1W {Z0.S},P0,[X2,Z1.S,SXTW #2] ; forall t={2,4,6,8} /\ u={0,0,2,0,4,0,6,0} /\ v={4,3,2,1} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/V30.litmus.expected000066400000000000000000000004521475314470400273260ustar00rootroot00000000000000Test V30 Required States 1 t={2,4,6,8}; u={0,0,2,0,4,0,6,0}; v={4,3,2,1}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (t={2,4,6,8} /\ u={0,0,2,0,4,0,6,0} /\ v={4,3,2,1}) Observation V30 Always 1 0 Hash=ea0982ad9093c09519535eb5fbd35b38 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/Y01.litmus000066400000000000000000000004221475314470400255240ustar00rootroot00000000000000AArch64 Y01 (* EOR *) { uint64_t t[2] = {1,2}; uint64_t s[2] = {3,4}; 0:X0=t; 0:X1=s; } P0 ; PTRUE P0.D,VL2 ; LD1D {Z0.D},P0/Z,[X0] ; LD1D {Z1.D},P0/Z,[X1] ; EOR Z0.D,Z0.D,Z1.D ; ST1D {Z0.D},P0,[X0] ; forall ( t={2,6} /\ s={3,4} ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.sve/Y01.litmus.expected000066400000000000000000000003561475314470400273320ustar00rootroot00000000000000Test Y01 Required States 1 s={3,4}; t={2,6}; Ok Witnesses Positive: 1 Negative: 0 Flag Scalable-Vector-Extensions-is-work-in-progress Condition forall (t={2,6} /\ s={3,4}) Observation Y01 Always 1 0 Hash=c4df84c412ce399286611bf8e695a12a herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/000077500000000000000000000000001475314470400246505ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A001.litmus000066400000000000000000000002601475314470400265060ustar00rootroot00000000000000AArch64 A001 { [PTE(x)]=(oa:PA(x),attrs:(TaggedNormal)); 0:X0=x:green; } P0 ; MOV W1,#1 ; L0: ; STR W1,[X0] ; locations[fault(P0:L0,x);] forall([x]=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A001.litmus.expected000066400000000000000000000003461475314470400303130ustar00rootroot00000000000000Test A001 Required States 1 [x]=1; ~Fault(P0:L0,x); Ok Witnesses Positive: 1 Negative: 0 Flag combining-vmsa-and-memtag-is-not-supported Condition forall ([x]=1) Observation A001 Always 1 0 Hash=15101ca2a5774fd3ea63c508af175bc5 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A002.litmus000066400000000000000000000002411475314470400265060ustar00rootroot00000000000000AArch64 A002 { [PTE(x)]=(valid:0); 0:X0=x:green; } P0 ; MOV W1,#1 ; L0: ; STR W1,[X0] ; forall([x]=0 /\ fault(P0:L0,x,MMU:Translation)) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A002.litmus.expected000066400000000000000000000004341475314470400303120ustar00rootroot00000000000000Test A002 Required States 1 [x]=0; Fault(P0:L0,x:green,MMU:Translation); Ok Witnesses Positive: 1 Negative: 0 Flag combining-vmsa-and-memtag-is-not-supported Condition forall ([x]=0 /\ fault(P0:L0,x,MMU:Translation)) Observation A002 Always 1 0 Hash=28724503810e0526ec2b6e8518813c37 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A003.litmus000066400000000000000000000002541475314470400265130ustar00rootroot00000000000000AArch64 A003 { [PTE(x)]=(db:0,attrs:(Normal)); 0:X0=x:green; } P0 ; MOV W1,#1 ; L0: ; STR W1,[X0] ; forall([x]=0 /\ fault(P0:L0,x,MMU:Permission)) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A003.litmus.expected000066400000000000000000000004321475314470400303110ustar00rootroot00000000000000Test A003 Required States 1 [x]=0; Fault(P0:L0,x:green,MMU:Permission); Ok Witnesses Positive: 1 Negative: 0 Flag combining-vmsa-and-memtag-is-not-supported Condition forall ([x]=0 /\ fault(P0:L0,x,MMU:Permission)) Observation A003 Always 1 0 Hash=e7bf1b4fe19ba1d138df90036a21cbe5 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A004.litmus000066400000000000000000000002561475314470400265160ustar00rootroot00000000000000AArch64 A004 { [PTE(x)]=(oa:PA(x),attrs:(TaggedNormal)); 0:X0=x:red; } P0 ; MOV W1,#1 ; L0: ; STR W1,[X0] ; forall([x]=0 /\ fault(P0:L0,x,TagCheck)) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A004.litmus.expected000066400000000000000000000004141475314470400303120ustar00rootroot00000000000000Test A004 Required States 1 [x]=0; Fault(P0:L0,x:red,TagCheck); Ok Witnesses Positive: 1 Negative: 0 Flag combining-vmsa-and-memtag-is-not-supported Condition forall ([x]=0 /\ fault(P0:L0,x,TagCheck)) Observation A004 Always 1 0 Hash=bf45c6a8a3dec235d4ba99539f6e2979 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A005.litmus000066400000000000000000000002711475314470400265140ustar00rootroot00000000000000AArch64 A005 { [PTE(x)]=(oa:PA(x),db:0,attrs:(TaggedNormal)); 0:X0=x:red; } P0 ; MOV W1,#1 ; L0: ; STR W1,[X0] ; forall([x]=0 /\ fault(P0:L0,x,MMU:Permission)) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A005.litmus.expected000066400000000000000000000004301475314470400303110ustar00rootroot00000000000000Test A005 Required States 1 [x]=0; Fault(P0:L0,x:red,MMU:Permission); Ok Witnesses Positive: 1 Negative: 0 Flag combining-vmsa-and-memtag-is-not-supported Condition forall ([x]=0 /\ fault(P0:L0,x,MMU:Permission)) Observation A005 Always 1 0 Hash=fe308bb85bd50ea32864c623d03c6b2a herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A006.litmus000066400000000000000000000002541475314470400265160ustar00rootroot00000000000000AArch64 A006 { [PTE(x)]=(oa:PA(x),attrs:(Normal)); 0:X0=x:red; } P0 ; MOV W1,#1 ; L0: ; STR W1,[X0] ; locations[fault(P0:L0,x);] forall([x]=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A006.litmus.expected000066400000000000000000000003461475314470400303200ustar00rootroot00000000000000Test A006 Required States 1 [x]=1; ~Fault(P0:L0,x); Ok Witnesses Positive: 1 Negative: 0 Flag combining-vmsa-and-memtag-is-not-supported Condition forall ([x]=1) Observation A006 Always 1 0 Hash=7a7266deb5d908ed212b3f3d1182f155 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A007.litmus000066400000000000000000000001331475314470400265130ustar00rootroot00000000000000AArch64 A007 { 0:X0=x:red; 0:X1=x; } P0 ; STG X0,[X1] ; forall([tag(x)]=:red) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A007.litmus.expected000066400000000000000000000003441475314470400303170ustar00rootroot00000000000000Test A007 Required States 1 [tag(x)]=:red; Ok Witnesses Positive: 1 Negative: 0 Flag combining-vmsa-and-memtag-is-not-supported Condition forall ([tag(x)]=:red) Observation A007 Always 1 0 Hash=c6ef897bedbc9dcae809229c4d98e62d herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A008.litmus000066400000000000000000000003651475314470400265230ustar00rootroot00000000000000AArch64 A008 { [x]=1; [PTE(x)]=(valid:0); 0:X0=x; 0:X1=x:red; 1:X1=(oa:PA(x),valid:1); 1:X0=PTE(x); } P0 | P1 ; L0: | STR X1,[X0] ; STZG X1,[X0] | ; exists(fault(P0:L0,x,MMU:Translation) /\ [x]=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A008.litmus.expected000066400000000000000000000005501475314470400303170ustar00rootroot00000000000000Test A008 Allowed States 3 [x]=0; ~Fault(P0:L0,x,MMU:Translation); [x]=0; Fault(P0:L0,x,MMU:Translation); [x]=1; Fault(P0:L0,x,MMU:Translation); Ok Witnesses Positive: 1 Negative: 4 Flag combining-vmsa-and-memtag-is-not-supported Condition exists (fault(P0:L0,x,MMU:Translation) /\ [x]=0) Observation A008 Sometimes 1 4 Hash=476835ada4ec0e0c73096d09264acc89 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A009.litmus000066400000000000000000000004311475314470400265160ustar00rootroot00000000000000AArch64 A009 Variant=vmsa,mte,fatal,sync { [x]=1; [PTE(x)]=(valid:0); 0:X0=x; 0:X1=x:red; 1:X1=(oa:PA(x),valid:1); 1:X0=PTE(x); } P0 | P1 ; L0: | STR X1,[X0] ; STZG X1,[X0] | ; exists(fault(P0:L0,x,MMU:Translation) /\ [tag(x)]=:red) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A009.litmus.expected000066400000000000000000000006121475314470400303170ustar00rootroot00000000000000Test A009 Allowed States 3 [tag(x)]=:green; Fault(P0:L0,x,MMU:Translation); [tag(x)]=:red; ~Fault(P0:L0,x,MMU:Translation); [tag(x)]=:red; Fault(P0:L0,x,MMU:Translation); Ok Witnesses Positive: 1 Negative: 4 Flag combining-vmsa-and-memtag-is-not-supported Condition exists (fault(P0:L0,x,MMU:Translation) /\ [tag(x)]=:red) Observation A009 Sometimes 1 4 Hash=280421b2e57a7340aa55ba5d655bde3b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A010.litmus000066400000000000000000000002651475314470400265130ustar00rootroot00000000000000AArch64 A010 { [x]=1; [tag(x)]=:green; [PTE(x)]=(oa:PA(x),attrs:(Normal)); 0:X0=x:red; } P0 ; L0: ; LDR W1,[X0] ; forall(0:X1=1 /\ ~fault(P0:L0,x,TagCheck)) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A010.litmus.expected000066400000000000000000000004221475314470400303060ustar00rootroot00000000000000Test A010 Required States 1 0:X1=1; ~Fault(P0:L0,x,TagCheck); Ok Witnesses Positive: 1 Negative: 0 Flag combining-vmsa-and-memtag-is-not-supported Condition forall (0:X1=1 /\ not (fault(P0:L0,x,TagCheck))) Observation A010 Always 1 0 Hash=f1f7d09e33e99c0f6d5214cf37835072 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A011.litmus000066400000000000000000000004501475314470400265100ustar00rootroot00000000000000AArch64 A011 { [tag(x)]=:green; [PTE(x)]=(oa:PA(x),db:1,attrs:(TaggedNormal)); 0:X0=x:red; 1:X4=PTE(x); 1:X3=(oa:PA(x),db:0,attrs:(Normal)); } P0 | P1 ; MOV W1,#1 | STR X3,[X4] ; L0: | ; STR W1,[X0] | ; exists([x]=1 /\ ~fault(P0:L0,x)) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A011.litmus.expected000066400000000000000000000005161475314470400303130ustar00rootroot00000000000000Test A011 Allowed States 3 [x]=0; Fault(P0:L0,x:red,TagCheck); [x]=0; Fault(P0:L0,x:red,MMU:Permission); [x]=1; ~Fault(P0:L0,x); Ok Witnesses Positive: 1 Negative: 2 Flag combining-vmsa-and-memtag-is-not-supported Condition exists ([x]=1 /\ not (fault(P0:L0,x))) Observation A011 Sometimes 1 2 Hash=134d988c72472374b559eaf4c6a4fea8 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A012.litmus000066400000000000000000000004501475314470400265110ustar00rootroot00000000000000AArch64 A012 { [tag(x)]=:green; [PTE(x)]=(oa:PA(x),db:0,attrs:(Normal)); 0:X0=x:red; 1:X4=PTE(x); 1:X3=(oa:PA(x),db:1,attrs:(TaggedNormal)); } P0 | P1 ; MOV W1,#1 | STR X3,[X4] ; L0: | ; STR W1,[X0] | ; exists([x]=1 /\ ~fault(P0:L0,x)) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A012.litmus.expected000066400000000000000000000005161475314470400303140ustar00rootroot00000000000000Test A012 Allowed States 3 [x]=0; Fault(P0:L0,x:red,TagCheck); [x]=0; Fault(P0:L0,x:red,MMU:Permission); [x]=1; ~Fault(P0:L0,x); Ok Witnesses Positive: 1 Negative: 2 Flag combining-vmsa-and-memtag-is-not-supported Condition exists ([x]=1 /\ not (fault(P0:L0,x))) Observation A012 Sometimes 1 2 Hash=3fce4d56177b06c14bfd934326a0645b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A013.litmus000066400000000000000000000004171475314470400265150ustar00rootroot00000000000000AArch64 A013 { [tag(x)]=:green; [PTE(x)]=(oa:PA(x),attrs:(TaggedNormal)); 0:X0=x:green; 1:X4=PTE(x); 1:X3=(valid:0); } P0 | P1 ; MOV W1,#1 | STR X3,[X4] ; L0: | ; STR W1,[X0] | ; exists(fault(P0:L0,x,TagCheck)) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A013.litmus.expected000066400000000000000000000003711475314470400303140ustar00rootroot00000000000000Test A013 Allowed States 1 ~Fault(P0:L0,x,TagCheck); No Witnesses Positive: 0 Negative: 3 Flag combining-vmsa-and-memtag-is-not-supported Condition exists (fault(P0:L0,x,TagCheck)) Observation A013 Never 0 3 Hash=97ccf51bf223b3e722cb9f5529718041 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A014.litmus000066400000000000000000000004251475314470400265150ustar00rootroot00000000000000AArch64 A014 { [tag(x)]=:green; [PTE(x)]=(oa:PA(x),attrs:(TaggedNormal)); 0:X0=x:green; 1:X4=PTE(x); 1:X3=(oa:PA(x),af:0); } P0 | P1 ; MOV W1,#1 | STR X3,[X4] ; L0: | ; STR W1,[X0] | ; exists(fault(P0:L0,x,TagCheck)) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A014.litmus.expected000066400000000000000000000003711475314470400303150ustar00rootroot00000000000000Test A014 Allowed States 1 ~Fault(P0:L0,x,TagCheck); No Witnesses Positive: 0 Negative: 3 Flag combining-vmsa-and-memtag-is-not-supported Condition exists (fault(P0:L0,x,TagCheck)) Observation A014 Never 0 3 Hash=59d8a9b824c05e58c85797010cc158ea herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A015.litmus000066400000000000000000000004201475314470400265110ustar00rootroot00000000000000AArch64 A014 { [tag(x)]=:green; [PTE(x)]=(oa:PA(x),af:0,attrs:(Normal)); 0:X0=x:red; 1:X4=PTE(x); 1:X3=(oa:PA(x),attrs:(TaggedNormal)); } P0 | P1 ; MOV W1,#1 | STR X3,[X4] ; L0: | ; STR W1,[X0] | ; exists([x]=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/A015.litmus.expected000066400000000000000000000003221475314470400303120ustar00rootroot00000000000000Test A014 Allowed States 1 [x]=0; No Witnesses Positive: 0 Negative: 3 Flag combining-vmsa-and-memtag-is-not-supported Condition exists ([x]=1) Observation A014 Never 0 3 Hash=7241fe036f5d711341ead6574ec6f446 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64.vmsa+mte/vmsa+mte.cfg000066400000000000000000000000341475314470400270550ustar00rootroot00000000000000variant memtag,precise,vmsa herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/000077500000000000000000000000001475314470400231225ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A01.litmus000066400000000000000000000002161475314470400247010ustar00rootroot00000000000000AArch64 A01 (* Tests ldrb (register), UXTW *) { uint64_t 0:X0; 0:X1=x; uint64_t x; 0:X2=0; } P0; LDRB W0, [X1, X2, UXTW]; exists (0:X0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A01.litmus.expected000066400000000000000000000002431475314470400265010ustar00rootroot00000000000000Test A01 Allowed States 1 0:X0=0; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=0) Observation A01 Always 1 0 Hash=fac9c0d41ef2dc619014a5f8545de0ad herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A02.litmus000066400000000000000000000002161475314470400247020ustar00rootroot00000000000000AArch64 A02 (* Tests ldrb (register), SXTW *) { uint64_t 0:X0; 0:X1=x; uint64_t x; 0:X2=0; } P0; LDRB W0, [X1, X2, SXTW]; exists (0:X0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A02.litmus.expected000066400000000000000000000002431475314470400265020ustar00rootroot00000000000000Test A02 Allowed States 1 0:X0=0; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=0) Observation A02 Always 1 0 Hash=b505f1228d4794132acb1bb19d459940 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A03.litmus000066400000000000000000000002171475314470400247040ustar00rootroot00000000000000AArch64 A03 (* Tests ldrb (register), LSL *) { uint64_t 0:X0; 0:X1=x; uint64_t x; 0:X2=0; } P0; LDRB W0, [X1, X2, LSL #0]; exists (0:X0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A03.litmus.expected000066400000000000000000000002431475314470400265030ustar00rootroot00000000000000Test A03 Allowed States 1 0:X0=0; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=0) Observation A03 Always 1 0 Hash=2091a15266c6e14759d4dddcd55b94d6 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A04.litmus000066400000000000000000000002141475314470400247020ustar00rootroot00000000000000AArch64 A4 (* Tests load immediate, no offset, from location *) { uint64_t 0:X0; 0:X1=x; uint64_t x;} P0; LDR X0, [X1]; exists (0:X0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A04.litmus.expected000066400000000000000000000002411475314470400265020ustar00rootroot00000000000000Test A4 Allowed States 1 0:X0=0; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=0) Observation A4 Always 1 0 Hash=d64e911ddfaa8df8f0c4d17557b7562d herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A05.litmus000066400000000000000000000002171475314470400247060ustar00rootroot00000000000000AArch64 A05 (* Tests ldrh (register), UXTW *) { uint64_t 0:X0; 0:X1=x; uint64_t x; 0:X2=0; } P0; LDRH W0, [X1, X2, UXTW]; exists (0:X0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A05.litmus.expected000066400000000000000000000002431475314470400265050ustar00rootroot00000000000000Test A05 Allowed States 1 0:X0=0; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=0) Observation A05 Always 1 0 Hash=d94520bd5db652cd923ef07452e2cd84 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A06.litmus000066400000000000000000000002221475314470400247030ustar00rootroot00000000000000AArch64 A06 (* Tests ldrh (register), LSL 0 *) { uint64_t 0:X0; 0:X1=x; uint64_t x; 0:X2=0; } P0; LDRH W0, [X1, X2, LSL #0]; exists (0:X0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A06.litmus.expected000066400000000000000000000002431475314470400265060ustar00rootroot00000000000000Test A06 Allowed States 1 0:X0=0; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=0) Observation A06 Always 1 0 Hash=83c02e5e819020441192084e55e50887 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A07.litmus000066400000000000000000000002171475314470400247100ustar00rootroot00000000000000AArch64 A07 (* Tests ldrh (register), SXTW *) { uint64_t 0:X0; 0:X1=x; uint64_t x; 0:X2=0; } P0; LDRH W0, [X1, X2, SXTW]; exists (0:X0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A07.litmus.expected000066400000000000000000000002431475314470400265070ustar00rootroot00000000000000Test A07 Allowed States 1 0:X0=0; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=0) Observation A07 Always 1 0 Hash=f9e49f8c289ba262f75d16c89d629cdc herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A08.litmus000066400000000000000000000003671475314470400247170ustar00rootroot00000000000000AArch64 A8 (* Tests load immediate, post-indexed, symbolic location *) { uint64_t x=1; 0:x1=x; uint64_t 0:X0; } P0; LDR X0, [X1], #44; ADD X1,X1,#-44 ; exists (0:X0=1 /\ 0:X1=x) (* See test A9 for a variant that uses a concrete address*) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A08.litmus.expected000066400000000000000000000002631475314470400265120ustar00rootroot00000000000000Test A8 Allowed States 1 0:X0=1; 0:X1=x; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=1 /\ 0:X1=x) Observation A8 Always 1 0 Hash=e5aa271b69d99c8a02af8f2d7c973f98 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A09.litmus000066400000000000000000000002221475314470400247060ustar00rootroot00000000000000AArch64 A09 (* Tests strb (register), UXTW *) { int8_t 0:X0 = 255; 0:X1=x; uint64_t x; 0:X2=0; } P0; STRB W0, [X1, X2, UXTW]; exists (x=255) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A09.litmus.expected000066400000000000000000000002451475314470400265130ustar00rootroot00000000000000Test A09 Allowed States 1 [x]=255; Ok Witnesses Positive: 1 Negative: 0 Condition exists ([x]=255) Observation A09 Always 1 0 Hash=6267b21bf3ff7747d3301530889f9067 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A10.litmus000066400000000000000000000001271475314470400247020ustar00rootroot00000000000000AArch64 A10 { int64_t x; int64_t 0:x0=1; 0:x2=x} P0; STR X0, [X2]; exists (x=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A10.litmus.expected000066400000000000000000000002411475314470400264770ustar00rootroot00000000000000Test A10 Allowed States 1 [x]=1; Ok Witnesses Positive: 1 Negative: 0 Condition exists ([x]=1) Observation A10 Always 1 0 Hash=ea5191f717adc74412c7fe1dae4db891 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A100.litmus000066400000000000000000000001701475314470400247600ustar00rootroot00000000000000AArch64 A100 (* Strb immediate, no offset, symbolic location *) { 0:x0=1; 0:x2=x} P0; STRB W0, [X2]; forall (x=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A100.litmus.expected000066400000000000000000000002441475314470400265620ustar00rootroot00000000000000Test A100 Required States 1 [x]=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=1) Observation A100 Always 1 0 Hash=e9af5da7f48c174199e8b3acbf2c33cb herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A107.litmus000066400000000000000000000001641475314470400247720ustar00rootroot00000000000000AArch64 A107 (* Tests ldrh immediate, no offset, from location *) { 0:X1=x } P0; LDRH W0, [X1]; exists (0:X0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A107.litmus.expected000066400000000000000000000002451475314470400265720ustar00rootroot00000000000000Test A107 Allowed States 1 0:X0=0; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=0) Observation A107 Always 1 0 Hash=b3b5d8702bd55bdb0a378dfc95625659 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A11.litmus000066400000000000000000000003701475314470400247030ustar00rootroot00000000000000AArch64 A11 (* Tests strb (register), UXTW - overflow on 8 bit store gives value 0 as expected*) (* Same as A09 but with a bump on the value in X0 *) { int8_t 0:X0 = 256; 0:X1=x; uint64_t x; 0:X2=0; } P0; STRB W0, [X1, X2, UXTW]; exists (x=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A11.litmus.expected000066400000000000000000000002411475314470400265000ustar00rootroot00000000000000Test A11 Allowed States 1 [x]=0; Ok Witnesses Positive: 1 Negative: 0 Condition exists ([x]=0) Observation A11 Always 1 0 Hash=a8c6534df7dbf0ba0b8e146aaf76977d herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A117.litmus000066400000000000000000000001771475314470400247770ustar00rootroot00000000000000AArch64 A117 (* unconditional Branch instruction *) { 0:X0=1; } P0; B foo; ADD W0, W0, #1; foo: NOP; forall (0:X0=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A117.litmus.expected000066400000000000000000000002461475314470400265740ustar00rootroot00000000000000Test A117 Required States 1 0:X0=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=1) Observation A117 Always 1 0 Hash=1e56e7a378d422667a5081fc63e22f1e herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A118.litmus000066400000000000000000000001641475314470400247740ustar00rootroot00000000000000AArch64 A118 (* CBZ instruction *) { 0:X0=0; } P0; CBZ W0, foo; ADD W0, W0, #1; foo: NOP; forall (0:X0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A118.litmus.expected000066400000000000000000000002461475314470400265750ustar00rootroot00000000000000Test A118 Required States 1 0:X0=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=0) Observation A118 Always 1 0 Hash=54e26119a5492ac372bf070888562b3b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A119.litmus000066400000000000000000000001641475314470400247750ustar00rootroot00000000000000AArch64 A119 (* CBZ instruction *) { 0:X0=1; } P0; CBZ W0, foo; ADD W0, W0, #1; foo: NOP; forall (0:X0=2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A119.litmus.expected000066400000000000000000000002461475314470400265760ustar00rootroot00000000000000Test A119 Required States 1 0:X0=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=2) Observation A119 Always 1 0 Hash=87510685dc7604b10f8b785edbe23953 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A12.litmus000066400000000000000000000002231475314470400247010ustar00rootroot00000000000000AArch64 A12 (* Tests strb (register), LSL 0*) { int8_t 0:X0 = 255; 0:X1=x; uint64_t x; 0:X2=0; } P0; STRB W0, [X1, X2, LSL 0]; exists (x=255) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A12.litmus.expected000066400000000000000000000002451475314470400265050ustar00rootroot00000000000000Test A12 Allowed States 1 [x]=255; Ok Witnesses Positive: 1 Negative: 0 Condition exists ([x]=255) Observation A12 Always 1 0 Hash=d7b040e2ba97c9869b2503fbb48115ec herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A120.litmus000066400000000000000000000001661475314470400247670ustar00rootroot00000000000000AArch64 A120 (* CBNZ instruction *) { 0:X0=0; } P0; CBNZ W0, foo; ADD W0, W0, #1; foo: NOP; forall (0:X0=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A120.litmus.expected000066400000000000000000000002461475314470400265660ustar00rootroot00000000000000Test A120 Required States 1 0:X0=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=1) Observation A120 Always 1 0 Hash=1127acef883d76cd0d861a76f7d07610 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A121.litmus000066400000000000000000000001661475314470400247700ustar00rootroot00000000000000AArch64 A121 (* CBNZ instruction *) { 0:X0=1; } P0; CBNZ W0, foo; ADD W0, W0, #1; foo: NOP; forall (0:X0=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A121.litmus.expected000066400000000000000000000002461475314470400265670ustar00rootroot00000000000000Test A121 Required States 1 0:X0=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=1) Observation A121 Always 1 0 Hash=e0ddca60db898bea5246b082ca6d9639 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A122.litmus000066400000000000000000000002171475314470400247660ustar00rootroot00000000000000AArch64 A122 (* BEQ instruction, relies on CMP *) { 0:X0=1; } P0; CMP W0, #1; B.EQ foo; ADD W0, W0, #1; foo: NOP; forall (0:X0=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A122.litmus.expected000066400000000000000000000002461475314470400265700ustar00rootroot00000000000000Test A122 Required States 1 0:X0=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=1) Observation A122 Always 1 0 Hash=099b38ef4b2a13d46a8b80c353265c86 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A123.litmus000066400000000000000000000002171475314470400247670ustar00rootroot00000000000000AArch64 A123 (* BEQ instruction, relies on CMP *) { 0:X0=1; } P0; CMP W0, #0; B.EQ foo; ADD W0, W0, #1; foo: NOP; forall (0:X0=2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A123.litmus.expected000066400000000000000000000002461475314470400265710ustar00rootroot00000000000000Test A123 Required States 1 0:X0=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=2) Observation A123 Always 1 0 Hash=b1863627eef9e603caca319c2f66d348 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A124.litmus000066400000000000000000000002171475314470400247700ustar00rootroot00000000000000AArch64 A124 (* BNE instruction, relies on CMP *) { 0:X0=1; } P0; CMP W0, #1; B.NE foo; ADD W0, W0, #1; foo: NOP; forall (0:X0=2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A124.litmus.expected000066400000000000000000000002461475314470400265720ustar00rootroot00000000000000Test A124 Required States 1 0:X0=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=2) Observation A124 Always 1 0 Hash=bcae08e6fe5e405577125d788aa54172 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A125.litmus000066400000000000000000000002171475314470400247710ustar00rootroot00000000000000AArch64 A125 (* BNE instruction, relies on CMP *) { 0:X0=0; } P0; CMP W0, #1; B.NE foo; ADD W0, W0, #1; foo: NOP; forall (0:X0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A125.litmus.expected000066400000000000000000000002461475314470400265730ustar00rootroot00000000000000Test A125 Required States 1 0:X0=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=0) Observation A125 Always 1 0 Hash=e1e62b8611f67ddb02586b3f16053a32 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A127.litmus000066400000000000000000000002561475314470400247760ustar00rootroot00000000000000AArch64 A127 (* MOV value from symbolic register into concrete reg *) { uint64_t X0; uint64_t %symbolic_reg = x; uint64_t x } P0; MOV X0, %symbolic_reg; exists (0:X0 = x) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A127.litmus.expected000066400000000000000000000002451475314470400265740ustar00rootroot00000000000000Test A127 Allowed States 1 0:X0=x; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=x) Observation A127 Always 1 0 Hash=2b1331e0638ebbd02667eb17dc2b0e99 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A128.litmus000066400000000000000000000003001475314470400247650ustar00rootroot00000000000000AArch64 A128 (* Tests accessing a location - symbolic location in vector *) { int64_t 0:X0; 0:X2=v; int64_t v[2] = {22,44}; } P0; LDR X0, [X2]; forall (0:X0=22 /\ v[0] = 22 /\ v[1] = 44) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A128.litmus.expected000066400000000000000000000003201475314470400265670ustar00rootroot00000000000000Test A128 Required States 1 0:X0=22; v[0]=22; v[1]=44; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=22 /\ v[0]=22 /\ v[1]=44) Observation A128 Always 1 0 Hash=23a48b741f952ec9386e04d448f648e2 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A129.litmus000066400000000000000000000003031475314470400247710ustar00rootroot00000000000000AArch64 A129 (* tests accessing a location within the array, but offset *) (* symbolic locations *) { int64_t 0:X0; 0:X2 = v; int64_t v[2] = {1, 2}; } P0; LDR X0, [X2, #8]; forall (0:X0 = 2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A129.litmus.expected000066400000000000000000000002461475314470400265770ustar00rootroot00000000000000Test A129 Required States 1 0:X0=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=2) Observation A129 Always 1 0 Hash=51795781d981d9911eb50371337d7b20 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A13.litmus000066400000000000000000000002231475314470400247020ustar00rootroot00000000000000AArch64 A13 (* Tests strb (register), LSL 1*) { int8_t 0:X0 = 128; 0:X1=x; uint64_t x; 0:X2=0; } P0; STRB W0, [X1, X2, LSL 1]; exists (x=128) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A13.litmus.expected000066400000000000000000000002451475314470400265060ustar00rootroot00000000000000Test A13 Allowed States 1 [x]=128; Ok Witnesses Positive: 1 Negative: 0 Condition exists ([x]=128) Observation A13 Always 1 0 Hash=2a7d5c2a1b537b10e178abde02536370 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A130.litmus000066400000000000000000000001551475314470400247660ustar00rootroot00000000000000AArch64 A130 { int64_t 0:X0; 0:X2 = v; int64_t v[2] = {1, 2}; } P0; LDR X0, [X2, #8]; forall (0:X0 = 2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A130.litmus.expected000066400000000000000000000002461475314470400265670ustar00rootroot00000000000000Test A130 Required States 1 0:X0=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=2) Observation A130 Always 1 0 Hash=51795781d981d9911eb50371337d7b20 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A131.litmus000066400000000000000000000003201475314470400247610ustar00rootroot00000000000000AArch64 A131 Variant=memtag (* LDG value from symbolic register into concrete reg *) { uint64_t X0; uint64_t %symbolic_reg = x:red; uint64_t x; } P0; LDG X0, [X1, %symbolic_reg]; exists (0:X0 = x:green) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A131.litmus.expected-failure000066400000000000000000000002131475314470400302070ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64/A131.litmus", line 9, characters 13-26: unexpected '%symbolic_reg' (in prog) (User error) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A132.litmus000066400000000000000000000002701475314470400247660ustar00rootroot00000000000000AArch64 A132 (* Tests storing to an array location *) (* symbolic location *) { 0:X2=v; int64_t 0:X0 = 2; int64_t v[2] = {22,44}} P0; STR X0, [X2]; forall (v[0] = 2 /\ v[1] = 44) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A132.litmus.expected000066400000000000000000000002721475314470400265700ustar00rootroot00000000000000Test A132 Required States 1 v[0]=2; v[1]=44; Ok Witnesses Positive: 1 Negative: 0 Condition forall (v[0]=2 /\ v[1]=44) Observation A132 Always 1 0 Hash=4e470762840f45597ede3b53116fca7a herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A133.litmus000066400000000000000000000003171475314470400247710ustar00rootroot00000000000000AArch64 A133 (* tests storing to a location within the array, but offset *) (* symbolic locations *) { 0:X0 = 42; 0:X2 = v; int64_t v[2] = {1, 2}; } P0; STR W0, [X2, #8]; forall (v[0] = 1 /\ v[1] = 42) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A133.litmus.expected000066400000000000000000000002721475314470400265710ustar00rootroot00000000000000Test A133 Required States 1 v[0]=1; v[1]=42; Ok Witnesses Positive: 1 Negative: 0 Condition forall (v[0]=1 /\ v[1]=42) Observation A133 Always 1 0 Hash=b2ee5623d12ebbc74131b4d3cee4d187 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A134.litmus000066400000000000000000000003641475314470400247740ustar00rootroot00000000000000AArch64 A134 (* tests storing a location outside of the array bounds, but next to the array *) (* This should fail as v[16] is unallocated *) { int64_t 0:X0=42; 0:X2 = v; int64_t v[2] = {1, 2} } P0; STR X0, [X2, #16]; exists (v[3] = 42) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A134.litmus.expected-failure000066400000000000000000000001541475314470400302160ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64/A134.litmus": Out of bounds access on array v (User error) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A135.litmus000066400000000000000000000002331475314470400247700ustar00rootroot00000000000000AArch64 A135 (* tests STR when write-back value is RV - INVALID SYNTAX *) { %symbolic_reg = x; int x = 1} P0; STR X1, [X2], %symbolic_reg; forall(x=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A135.litmus.expected-failure000066400000000000000000000002131475314470400302130ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64/A135.litmus", line 8, characters 14-27: unexpected '%symbolic_reg' (in prog) (User error) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A136.litmus000066400000000000000000000002441475314470400247730ustar00rootroot00000000000000AArch64 A136 Variant=morello (* tests ALIGND when value is RV - INVALID SYNTAX *) { %symbolic_reg = x; int x = 1} P0; ALIGND C0, C1, %symbolic_reg; forall(x=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A136.litmus.expected-failure000066400000000000000000000002131475314470400302140ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64/A136.litmus", line 9, characters 15-28: unexpected '%symbolic_reg' (in prog) (User error) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A137.litmus000066400000000000000000000002441475314470400247740ustar00rootroot00000000000000AArch64 A137 Variant=morello (* tests ALIGNU when value is RV - INVALID SYNTAX *) { %symbolic_reg = x; int x = 1} P0; ALIGNU C0, C1, %symbolic_reg; forall(x=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A137.litmus.expected-failure000066400000000000000000000002131475314470400302150ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64/A137.litmus", line 9, characters 15-28: unexpected '%symbolic_reg' (in prog) (User error) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A138.litmus000066400000000000000000000003361475314470400247770ustar00rootroot00000000000000AArch64 A138 Variant=memtag (* STG value from symbolic register into concrete reg INVALID SYNTAX *) { uint64_t X0 = x; uint64_t x:red = 1; %symbolic_reg = 0; } P0; STG X0, [X1, %symbolic_reg]; exists (0:X0 = x:green) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A138.litmus.expected-failure000066400000000000000000000002131475314470400302160ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64/A138.litmus", line 9, characters 13-26: unexpected '%symbolic_reg' (in prog) (User error) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A139.litmus000066400000000000000000000004641475314470400250020ustar00rootroot00000000000000AArch64 A139 (* Tests whether we can load from a pointer - symbolic location+offset *) { int *pointer_to_x = x; int x[2]={4,42} } P0; ADR X1, pointer_to_x; (* loads pointer_to_x into X1 *) LDR X1, [X1]; (* loads x into X1 *) LDR W0, [X1, #4]; (* loads x[1] into X1 *) exists (0:X0 = 42) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A139.litmus.expected-failure000066400000000000000000000002451475314470400302240ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64/A139.litmus": Label pointer_to_x not found on P0, although used in the instruction ADR X1,pointer_to_x (User error) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A14.litmus000066400000000000000000000002211475314470400247010ustar00rootroot00000000000000AArch64 A14 (* Tests strb (register), SXTW*) { int8_t 0:X0 = 128; 0:X1=x; uint64_t x; 0:X2=0; } P0; STRB W0, [X1, X2, SXTW]; exists (x=128) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A14.litmus.expected000066400000000000000000000002451475314470400265070ustar00rootroot00000000000000Test A14 Allowed States 1 [x]=128; Ok Witnesses Positive: 1 Negative: 0 Condition exists ([x]=128) Observation A14 Always 1 0 Hash=4e2d0c26ed20807b1168d7d27230c3f2 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A140.litmus000066400000000000000000000003401475314470400247630ustar00rootroot00000000000000AArch64 A140 Variant=memtag (* STZG value from symbolic register into concrete reg INVALID SYNTAX *) { uint64_t X0 = x; uint64_t x:red = 1; %symbolic_reg = 0; } P0; STZG X0, [X1, %symbolic_reg]; exists (0:X0 = x:green) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A140.litmus.expected-failure000066400000000000000000000002131475314470400302070ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64/A140.litmus", line 9, characters 14-27: unexpected '%symbolic_reg' (in prog) (User error) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A147.litmus000066400000000000000000000003271475314470400247770ustar00rootroot00000000000000AArch64 A147 (* tests storing to a location within the array, but offset *) (* symbolic locations *) { int64_t 0:X0 = 42; 0:X2 = v; int64_t v[2] = {1, 2}; } P0; STR X0, [X2, #8]; forall (v[0] = 1 /\ v[1] = 42) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A147.litmus.expected000066400000000000000000000002721475314470400265760ustar00rootroot00000000000000Test A147 Required States 1 v[0]=1; v[1]=42; Ok Witnesses Positive: 1 Negative: 0 Condition forall (v[0]=1 /\ v[1]=42) Observation A147 Always 1 0 Hash=8ca55b2ecb41272f50f74d42d03b1a5f herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A15.litmus000066400000000000000000000002351475314470400247070ustar00rootroot00000000000000AArch64 A15 (* Tests ldrb (register), overflowing load*) { int8_t 0:X0 = 0; 0:X1=x; int8_t x = 257; 0:X2=0; } P0; LDRB W0, [X1, X2, SXTW]; exists (x=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A15.litmus.expected000066400000000000000000000002411475314470400265040ustar00rootroot00000000000000Test A15 Allowed States 1 [x]=1; Ok Witnesses Positive: 1 Negative: 0 Condition exists ([x]=1) Observation A15 Always 1 0 Hash=8d15b0661c6c857314565371199836af herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A16.litmus000066400000000000000000000002411475314470400247050ustar00rootroot00000000000000AArch64 A16 (* Tests ldrh (register), overflowing load*) { int16_t 0:X0 = 0; 0:X1=x; int16_t x = 65537; 0:X2=0; } P0; LDRH W0, [X1, X2, SXTW]; exists (x=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A16.litmus.expected000066400000000000000000000002411475314470400265050ustar00rootroot00000000000000Test A16 Allowed States 1 [x]=1; Ok Witnesses Positive: 1 Negative: 0 Condition exists ([x]=1) Observation A16 Always 1 0 Hash=93da6aa75832b7c6974bd86e28a99740 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A162.litmus000066400000000000000000000004461475314470400247760ustar00rootroot00000000000000AArch64 A162 (* Test load exclusive; Store exclusive, symbolic location *) { 0:X4=z; uint64_t z=2; int64_t 1:X5=5; 1:X6=z} P0 | P1; LDXR X0, [X4] | STR X5, [X6]; ADD X0, X0, #1 | ; STXR W3, X0, [X4] | ; forall not ((z=3 /\ 0:X3=1) \/ (z=6 /\ 0:X3=1)) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A162.litmus.expected000066400000000000000000000003551475314470400265750ustar00rootroot00000000000000Test A162 Required States 3 0:X3=0; [z]=5; 0:X3=0; [z]=6; 0:X3=1; [z]=5; Ok Witnesses Positive: 4 Negative: 0 Condition forall (not ([z]=3 /\ 0:X3=1 \/ [z]=6 /\ 0:X3=1)) Observation A162 Always 4 0 Hash=25040183ed31f3d7cffd1886266907ca herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A164.litmus000066400000000000000000000003371475314470400247770ustar00rootroot00000000000000AArch64 A164 (* CMP shifted register is equivalent to SUBS WZR *) (* tests xreg *) { int64_t 0:X1=1; int64_t 0:X0; } P0; CMP XZR, X1, ASR #1; B.EQ foo; MOV X0, #1; foo: NOP; forall (0:X1=1 /\ 0:XZR=0 /\ 0:X0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A164.litmus.expected000066400000000000000000000003141475314470400265720ustar00rootroot00000000000000Test A164 Required States 1 0:XZR=0; 0:X0=0; 0:X1=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=1 /\ 0:XZR=0 /\ 0:X0=0) Observation A164 Always 1 0 Hash=d3617cb7b874545ac2f5214b9bea5b07 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A165.litmus000066400000000000000000000003121475314470400247710ustar00rootroot00000000000000AArch64 A165 (* CMP shifted register is equivalent to SUBS WZR *) (* tests xwreg *) { 0:X1=1; } P0; CMP WZR, W1, ASR #1; B.EQ foo; MOV X0, #1; foo: NOP; forall (0:X1=1 /\ 0:XZR=0 /\ 0:X0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A165.litmus.expected000066400000000000000000000003141475314470400265730ustar00rootroot00000000000000Test A165 Required States 1 0:XZR=0; 0:X0=0; 0:X1=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=1 /\ 0:XZR=0 /\ 0:X0=0) Observation A165 Always 1 0 Hash=e48a8df97eecd5c13e11852310f40a04 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A166.litmus000066400000000000000000000004141475314470400247750ustar00rootroot00000000000000AArch64 A166 (* CMP shifted register is equivalent to SUBS WZR *) (* This test is equivalent to to A164 - but uses SUBS*) { int64_t 0:X1=1; int64_t 0:X0; } P0; SUBS XZR, XZR, X1, ASR #1; B.EQ foo; MOV X0, #1; foo: NOP; forall (0:X1=1 /\ 0:XZR=0 /\ 0:X0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A166.litmus.expected000066400000000000000000000003141475314470400265740ustar00rootroot00000000000000Test A166 Required States 1 0:XZR=0; 0:X0=0; 0:X1=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=1 /\ 0:XZR=0 /\ 0:X0=0) Observation A166 Always 1 0 Hash=d3617cb7b874545ac2f5214b9bea5b07 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A167.litmus000066400000000000000000000003661475314470400250040ustar00rootroot00000000000000AArch64 A167 (* CMP shifted register is equivalent to SUBS WZR *) (* This test is equivalent to to A165 - but uses SUBS*) { 0:X1=1; } P0; SUBS WZR, WZR, W1, ASR #1; B.EQ foo; MOV X0, #1; foo: NOP; forall (0:X1=1 /\ 0:XZR=0 /\ 0:X0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A167.litmus.expected000066400000000000000000000003141475314470400265750ustar00rootroot00000000000000Test A167 Required States 1 0:XZR=0; 0:X0=0; 0:X1=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=1 /\ 0:XZR=0 /\ 0:X0=0) Observation A167 Always 1 0 Hash=e48a8df97eecd5c13e11852310f40a04 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A17.litmus000066400000000000000000000002201475314470400247030ustar00rootroot00000000000000AArch64 A17 (* Tests strh (register), SXTW*) { int16_t 0:X0 = 44; 0:X1=x; uint64_t x; 0:X2=0; } P0; STRB W0, [X1, X2, SXTW]; exists (x=44) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A17.litmus.expected000066400000000000000000000002431475314470400265100ustar00rootroot00000000000000Test A17 Allowed States 1 [x]=44; Ok Witnesses Positive: 1 Negative: 0 Condition exists ([x]=44) Observation A17 Always 1 0 Hash=e59d8739bd436c143a2025bcfe9b9d18 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A172.litmus000066400000000000000000000002341475314470400247720ustar00rootroot00000000000000AArch64 A172 (* Tests load immediate, no offset, from stack pointer*) { 0:sp = x; uint64_t x=1; uint64_t 0:X1 = 0; } P0; ldr X1, [SP]; forall (0:X1=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A172.litmus.expected000066400000000000000000000002461475314470400265750ustar00rootroot00000000000000Test A172 Required States 1 0:X1=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=1) Observation A172 Always 1 0 Hash=bf9bc25d44c8579a87f8d01aefd1536f herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A173.litmus000066400000000000000000000002061475314470400247720ustar00rootroot00000000000000AArch64 A173 (* Tests Add, from stack pointer*) { uint64_t 0:SP = 1; x=1; uint64_t 0:X2=0; } P0; add X2, SP, #8; forall (0:X2=9) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A173.litmus.expected000066400000000000000000000002461475314470400265760ustar00rootroot00000000000000Test A173 Required States 1 0:X2=9; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=9) Observation A173 Always 1 0 Hash=81e30b7672e9d35849025c5af0cb2d71 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A174.litmus000066400000000000000000000002171475314470400247750ustar00rootroot00000000000000AArch64 A174 (* Tests mov immediate, no offset, from stack pointer*) { uint64_t 0:SP = 1; uint64_t 0:X6; } P0; mov X6, SP; forall (0:X6=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A174.litmus.expected000066400000000000000000000002461475314470400265770ustar00rootroot00000000000000Test A174 Required States 1 0:X6=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X6=1) Observation A174 Always 1 0 Hash=535879c1c8a17cd9288b4bfc126f607f herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A175.litmus000066400000000000000000000005441475314470400250010ustar00rootroot00000000000000AArch64 A175 (* tests illegal input to initial state of the form "v[i] = scalar" *) (* only vector initializations can use v[i] in init of the form "v[i] = lbrack scalar_list rbrack" *) (* This should fail as v[3] = 3 is not allowed in init *) { uint64_t 0:X0=42; 0:X2 = v; int64_t v[2] = {1, 2}; v[3] = 3 } P0; STR X0, [X2, #16]; exists (v[3] = 42) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A175.litmus.expected-failure000066400000000000000000000001761475314470400302270ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64/A175.litmus", line 7, characters 62-62: unexpected '' (in init) (User error) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A176.litmus000066400000000000000000000003631475314470400250010ustar00rootroot00000000000000AArch64 A176 (* Test reading integer partially. The trick allows enforcing alignement constraint more stringent than using type of smaller size. *) { uint64_t x = 0x0000000100000002; 0:X2=x; } P0; LDR W0, [X2]; forall (0:X0=2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A176.litmus.expected000066400000000000000000000002461475314470400266010ustar00rootroot00000000000000Test A176 Required States 1 0:X0=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=2) Observation A176 Always 1 0 Hash=d37c9375e376d5c07b9b6cb64acf3480 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A177.litmus000066400000000000000000000001331475314470400247750ustar00rootroot00000000000000AArch64 A177 { int *p = &x; int x=1; 0:X2=p; } P0; LDR W0,[X2]; locations [0:X0;] herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A177.litmus.expected-failure000066400000000000000000000001521475314470400302230ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64/A177.litmus": Illegal operation mask32 on x (User error) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A178.litmus000066400000000000000000000004431475314470400250020ustar00rootroot00000000000000AArch64 A178 (* Combine illegal load of address in 32bits register and indirect access. Should fail *) variant=DontCheckMixed { int *p = &x; int x=1; 0:X2=p; 1:X2=p; } P0 | P1 ; LDR X0,[X2] | LDR W0,[X2] ; LDR W1,[X0] | ; locations [0:X0; 0:X1;] herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A178.litmus.expected-failure000066400000000000000000000001521475314470400302240ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64/A178.litmus": Illegal operation mask32 on x (User error) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A179.litmus000066400000000000000000000005611475314470400250040ustar00rootroot00000000000000AArch64 A179 (* Combine illegal load of address in 32bits register and indirect access. Should fail *) Variant=DontCheckMixed { int x = 1; int64_t y = 2; int *p = &x; 0:X2=p; 1:X2=p; 1:X1=y; 2:X2=p; } P0 | P1 | P2 ; LDR X0,[X2] | STR X1,[X2] | STR X2,[X2] ; LDR W1,[X0] | | ; locations [0:X0; 0:X1;] herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A179.litmus.expected-failure000066400000000000000000000001521475314470400302250ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64/A179.litmus": Illegal operation mask32 on p (User error) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A18.litmus000066400000000000000000000003061475314470400247110ustar00rootroot00000000000000AArch64 A18 (* Tests unscaled load, given a symbolic location, no offset*) { int64_t x; 0:X1=x; uint64_t 0:X0; } P0; LDUR X0, [X1]; exists (0:X0=0)(* Symbolic locations, we can't do much here*) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A18.litmus.expected000066400000000000000000000002431475314470400265110ustar00rootroot00000000000000Test A18 Allowed States 1 0:X0=0; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=0) Observation A18 Always 1 0 Hash=e6ce4739d55d064c5d0044696327554b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A180.litmus000066400000000000000000000002631475314470400247730ustar00rootroot00000000000000AArch64 A180 (* Test A176 + indirection, should work *) { uint64_t x = 0x0000000100000002; uint64_t *p = &x; 0:X2=p; } P0; LDR X2,[X2] ; LDR W0,[X2] ; forall (0:X0=2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A180.litmus.expected000066400000000000000000000002461475314470400265740ustar00rootroot00000000000000Test A180 Required States 1 0:X0=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=2) Observation A180 Always 1 0 Hash=2a5b695ffe83e16f770c91d384c0f8ba herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A181.litmus000066400000000000000000000004331475314470400247730ustar00rootroot00000000000000AArch64 A181 (* Test A176 + indirection, should work *) q { int y = 1; uint64_t x = 0x0000000100000002; uint64_t *p = &x; uint64_t *q = p; 0:X2=p; 1:X2=q; 1:X0=y; } P0 | P1 ; LDR X2,[X2] | LDR X4,[X2] ; LDR W0,[X2] | STR X0,[X4] ; exists (0:X0=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A181.litmus.expected000066400000000000000000000002601475314470400265710ustar00rootroot00000000000000Test A181 Allowed States 2 0:X0=1; 0:X0=2; Ok Witnesses Positive: 1 Negative: 1 Condition exists (0:X0=1) Observation A181 Sometimes 1 1 Hash=e6a2f1a84abc84eac6474de173a96510 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A182.litmus000066400000000000000000000005151475314470400247750ustar00rootroot00000000000000AArch64 A182 (* Complex indrect store/load, should work *) q { int x[2] = {1,1}; int *p = &x; 0:X2=p; 1:X2=p; 1:X4=x; 2:X2=p; } P0 | P1 | P2 ; LDR X2,[X2] | ADD X4,X4,#4 | LDR X2,[X2] ; MOV W0,#2 | STR X4,[X2] | LDR W0,[X2] ; STR W0,[X2] | | ; locations [x;2:X0;] herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A182.litmus.expected000066400000000000000000000003401475314470400265710ustar00rootroot00000000000000Test A182 Required States 4 2:X0=1; x={1,2}; 2:X0=1; x={2,1}; 2:X0=2; x={1,2}; 2:X0=2; x={2,1}; Ok Witnesses Positive: 6 Negative: 0 Condition forall (true) Observation A182 Always 6 0 Hash=fda1400634ecec2e31432cf26175326e herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A183.litmus000066400000000000000000000005421475314470400247760ustar00rootroot00000000000000AArch64 A183 (* Complex indrect store/load, should fail *) Variant=DontCheckMixed { int x[2] = {1,1}; int *p = &x; 0:X2=p; 1:X2=p; 1:X4=x; 2:X2=p; } P0 | P1 | P2 ; LDR X2,[X2] | ADD X4,X4,#4 | LDR X2,[X2] ; MOV W0,#2 | STR X4,[X2] | LDR W0,[X2] ; STR W0,[X2] | STR X2,[X2] | ; locations [x;2:X0;] herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A183.litmus.expected-failure000066400000000000000000000001521475314470400302200ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64/A183.litmus": Illegal operation mask32 on p (User error) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A184.litmus000066400000000000000000000003461475314470400250010ustar00rootroot00000000000000AArch64 A184 (* LDXR/STXR Loop, test partial execution, with warnong on stderr *) { int x=1; 0:X0=x; } P0 ; L0: ; LDXR W1,[X0] ; MOV W3,#2 ; STXR W4,W3,[X0] ; CBNZ W4,L0 ; forall (x=2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A184.litmus.expected000066400000000000000000000002511475314470400265740ustar00rootroot00000000000000Test A184 Required States 1 [x]=2; Loop Ok Witnesses Positive: 3 Negative: 0 Condition forall ([x]=2) Observation A184 Always 3 0 Hash=79c44439d71d498715a5ee40615de31c herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A184.litmus.expected-warn000066400000000000000000000001761475314470400275470ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64/A184.litmus": unrolling limit exceeded at L0, legal outcomes may be missing. herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A185.litmus000066400000000000000000000002251475314470400247760ustar00rootroot00000000000000AArch64 A185 (* Tests asr (immediate), negative initial value, right shift by 2 *) { int64_t 0:X0 = -256; } P0; ASR X0, X0, #2; exists (0:X0=-64) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A185.litmus.expected000066400000000000000000000002511475314470400265750ustar00rootroot00000000000000Test A185 Allowed States 1 0:X0=-64; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=-64) Observation A185 Always 1 0 Hash=7ca2b108bf266be0b0ed25d0887ebcd9 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A186.litmus000066400000000000000000000003331475314470400247770ustar00rootroot00000000000000AArch64 A186 (* B.cond instructions, relies on CMP *) { 0:X0=1; } P0; CMP W0, #2; B.GE foo; B.EQ foo; B.CS foo; B.PL foo; B.VS foo; B.HI foo; B.GT foo; ADD W0, W0, #1; foo: NOP; forall (0:X0=2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A186.litmus.expected000066400000000000000000000002461475314470400266020ustar00rootroot00000000000000Test A186 Required States 1 0:X0=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=2) Observation A186 Always 1 0 Hash=480dde633eea73f6af7eaff2d82b2de0 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A187.litmus000066400000000000000000000003331475314470400250000ustar00rootroot00000000000000AArch64 A187 (* B.cond instructions, relies on CMP *) { 0:X0=1; } P0; CMP W0, #1; B.NE foo; B.CC foo; B.MI foo; B.VS foo; B.HI foo; B.LT foo; B.GT foo; ADD W0, W0, #1; foo: NOP; forall (0:X0=2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A187.litmus.expected000066400000000000000000000002461475314470400266030ustar00rootroot00000000000000Test A187 Required States 1 0:X0=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=2) Observation A187 Always 1 0 Hash=7e584bb73f25ab8feda222a1ddbe9765 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A188.litmus000066400000000000000000000003321475314470400250000ustar00rootroot00000000000000AArch64 A188 (* B.cond instruction, relies on CMP *) { 0:X0=1; } P0; CMP W0, #0; B.LE foo; B.LT foo; B.EQ foo; B.CC foo; B.MI foo; B.VS foo; B.LS foo; ADD W0, W0, #1; foo: NOP; forall (0:X0=2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A188.litmus.expected000066400000000000000000000002461475314470400266040ustar00rootroot00000000000000Test A188 Required States 1 0:X0=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=2) Observation A188 Always 1 0 Hash=fe5b0b33332976945765ccb987f55ad6 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A189.litmus000066400000000000000000000004531475314470400250050ustar00rootroot00000000000000AArch64 A189 (* ADDS test, uses CSET *) { int64_t 0: X1 = 2; int64_t 0: X2 = 3; } P0 ; ADDS X0, X1, X2; CSET W3, MI; (* Fetch N *) CSET W4, EQ; (* Fetch Z *) CSET W5, CS; (* Fetch C *) CSET W6, VS; (* Fetch V *) forall ( 0: X3 = 0 /\ 0: X4 = 0 /\ 0: X5 = 0 /\ 0: X6 = 0 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A189.litmus.expected000066400000000000000000000003341475314470400266030ustar00rootroot00000000000000Test A189 Required States 1 0:X3=0; 0:X4=0; 0:X5=0; 0:X6=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=0 /\ 0:X4=0 /\ 0:X5=0 /\ 0:X6=0) Observation A189 Always 1 0 Hash=b14a5dc1bba5f47e11b5dc9a9b22468c herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A19.litmus000066400000000000000000000003241475314470400247120ustar00rootroot00000000000000AArch64 A19 (* Tests unscaled load, given a symbolic location, no offset*) { int64_t t[2] = {1,2}; 0:X1=t; uint64_t 0:X0; } P0; LDUR X0, [X1,#8]; forall (0:X0=2)(* Symbolic locations, we can't do much here*) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A19.litmus.expected000066400000000000000000000002441475314470400265130ustar00rootroot00000000000000Test A19 Required States 1 0:X0=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=2) Observation A19 Always 1 0 Hash=137ab50692552983823fd94b6906256f herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A190.litmus000066400000000000000000000004541475314470400247760ustar00rootroot00000000000000AArch64 A190 (* ADDS test, uses CSET *) { int64_t 0: X1 = -1; int64_t 0: X2 = 0; } P0 ; ADDS X0, X1, X2; CSET W3, MI; (* Fetch N *) CSET w4, EQ; (* Fetch Z *) CSET w5, CS; (* Fetch C *) CSET w6, VS; (* Fetch V *) forall ( 0: X3 = 1 /\ 0: X4 = 0 /\ 0: X5 = 0 /\ 0: X6 = 0 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A190.litmus.expected000066400000000000000000000003341475314470400265730ustar00rootroot00000000000000Test A190 Required States 1 0:X3=1; 0:X4=0; 0:X5=0; 0:X6=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=1 /\ 0:X4=0 /\ 0:X5=0 /\ 0:X6=0) Observation A190 Always 1 0 Hash=0b9bfcd9d641184b212b9bf079495682 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A191.litmus000066400000000000000000000004541475314470400247770ustar00rootroot00000000000000AArch64 A191 (* ADDS test, uses CSET *) { int64_t 0: X1 = 2; int64_t 0: X2 = -2; } P0 ; ADDS X0, X1, X2; CSET w3, MI; (* Fetch N *) CSET w4, EQ; (* Fetch Z *) CSET w5, CS; (* Fetch C *) CSET w6, VS; (* Fetch V *) forall ( 0: X3 = 0 /\ 0: X4 = 1 /\ 0: X5 = 1 /\ 0: X6 = 0 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A191.litmus.expected000066400000000000000000000003341475314470400265740ustar00rootroot00000000000000Test A191 Required States 1 0:X3=0; 0:X4=1; 0:X5=1; 0:X6=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=0 /\ 0:X4=1 /\ 0:X5=1 /\ 0:X6=0) Observation A191 Always 1 0 Hash=51addef3f39ba5a5aefec2ee96f894c7 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A192.litmus000066400000000000000000000004541475314470400250000ustar00rootroot00000000000000AArch64 A192 (* ADDS test, uses CSET *) { int64_t 0: X1 = -2; int64_t 0: X2 = 5; } P0 ; ADDS X0, X1, X2; CSET w3, MI; (* Fetch N *) CSET w4, EQ; (* Fetch Z *) CSET w5, CS; (* Fetch C *) CSET w6, VS; (* Fetch V *) forall ( 0: X3 = 0 /\ 0: X4 = 0 /\ 0: X5 = 1 /\ 0: X6 = 0 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A192.litmus.expected000066400000000000000000000003341475314470400265750ustar00rootroot00000000000000Test A192 Required States 1 0:X3=0; 0:X4=0; 0:X5=1; 0:X6=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=0 /\ 0:X4=0 /\ 0:X5=1 /\ 0:X6=0) Observation A192 Always 1 0 Hash=1e306d99bfb3ba37537fc889e6dae8b4 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A193.litmus000066400000000000000000000005541475314470400250020ustar00rootroot00000000000000AArch64 A193 (* ADDS test, uses CSET *) { int64_t 0: X1 = 2; int64_t 0: X2 = 9223372036854775807; (* biggest signed number, i.e. [2 ^ 63 - 1].*) } P0 ; ADDS X0, X1, X2; CSET w3, MI; (* Fetch N *) CSET w4, EQ; (* Fetch Z *) CSET w5, CS; (* Fetch C *) CSET w6, VS; (* Fetch V *) forall ( 0: X3 = 1 /\ 0: X4 = 0 /\ 0: X5 = 0 /\ 0: X6 = 1 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A193.litmus.expected000066400000000000000000000003341475314470400265760ustar00rootroot00000000000000Test A193 Required States 1 0:X3=1; 0:X4=0; 0:X5=0; 0:X6=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=1 /\ 0:X4=0 /\ 0:X5=0 /\ 0:X6=1) Observation A193 Always 1 0 Hash=2831fbaa74db14d6a5e3afe9874d68c7 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A194.litmus000066400000000000000000000005551475314470400250040ustar00rootroot00000000000000AArch64 A194 (* ADDS test, uses CSET *) { int64_t 0: X1 = -9223372036854775808; (* Smallest negative integer, i.e. [-2^63].*) int64_t 0: X2 = -3; } P0 ; ADDS X0, X1, X2; CSET w3, MI; (* Fetch N *) CSET w4, EQ; (* Fetch Z *) CSET w5, CS; (* Fetch C *) CSET w6, VS; (* Fetch V *) forall ( 0: X3 = 0 /\ 0: X4 = 0 /\ 0: X5 = 1 /\ 0: X6 = 1 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A194.litmus.expected000066400000000000000000000003341475314470400265770ustar00rootroot00000000000000Test A194 Required States 1 0:X3=0; 0:X4=0; 0:X5=1; 0:X6=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=0 /\ 0:X4=0 /\ 0:X5=1 /\ 0:X6=1) Observation A194 Always 1 0 Hash=0f0fee9398abbec89bd8eef4e0cbecc1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A195.litmus000066400000000000000000000004331475314470400250000ustar00rootroot00000000000000AArch64 A195 (* ADDS test, uses CSET *) { 0: X1 = 2; 0: X2 = 3; } P0 ; ADDS W0, W1, W2; CSET W3, MI; (* Fetch N *) CSET W4, EQ; (* Fetch Z *) CSET W5, CS; (* Fetch C *) CSET W6, VS; (* Fetch V *) forall ( 0: X3 = 0 /\ 0: X4 = 0 /\ 0: X5 = 0 /\ 0: X6 = 0 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A195.litmus.expected000066400000000000000000000003341475314470400266000ustar00rootroot00000000000000Test A195 Required States 1 0:X3=0; 0:X4=0; 0:X5=0; 0:X6=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=0 /\ 0:X4=0 /\ 0:X5=0 /\ 0:X6=0) Observation A195 Always 1 0 Hash=b23fd46a8f413b94e56193d6cfe0adde herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A196.litmus000066400000000000000000000004341475314470400250020ustar00rootroot00000000000000AArch64 A196 (* ADDS test, uses CSET *) { 0: X1 = -1; 0: X2 = 0; } P0 ; ADDS W0, W1, W2; CSET W3, MI; (* Fetch N *) CSET W4, EQ; (* Fetch Z *) CSET W5, CS; (* Fetch C *) CSET W6, VS; (* Fetch V *) forall ( 0: X3 = 1 /\ 0: X4 = 0 /\ 0: X5 = 0 /\ 0: X6 = 0 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A196.litmus.expected000066400000000000000000000003341475314470400266010ustar00rootroot00000000000000Test A196 Required States 1 0:X3=1; 0:X4=0; 0:X5=0; 0:X6=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=1 /\ 0:X4=0 /\ 0:X5=0 /\ 0:X6=0) Observation A196 Always 1 0 Hash=967be0c24bb946eb104c7357bae636c9 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A197.litmus000066400000000000000000000004341475314470400250030ustar00rootroot00000000000000AArch64 A197 (* ADDS test, uses CSET *) { 0: X1 = 2; 0: X2 = -2; } P0 ; ADDS W0, W1, W2; CSET W3, MI; (* Fetch N *) CSET W4, EQ; (* Fetch Z *) CSET W5, CS; (* Fetch C *) CSET W6, VS; (* Fetch V *) forall ( 0: X3 = 0 /\ 0: X4 = 1 /\ 0: X5 = 1 /\ 0: X6 = 0 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A197.litmus.expected000066400000000000000000000003341475314470400266020ustar00rootroot00000000000000Test A197 Required States 1 0:X3=0; 0:X4=1; 0:X5=1; 0:X6=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=0 /\ 0:X4=1 /\ 0:X5=1 /\ 0:X6=0) Observation A197 Always 1 0 Hash=0239fec961d719fcb1c05afb9eeead08 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A198.litmus000066400000000000000000000004341475314470400250040ustar00rootroot00000000000000AArch64 A198 (* ADDS test, uses CSET *) { 0: X1 = -2; 0: X2 = 5; } P0 ; ADDS W0, W1, W2; CSET W3, MI; (* Fetch N *) CSET W4, EQ; (* Fetch Z *) CSET W5, CS; (* Fetch C *) CSET W6, VS; (* Fetch V *) forall ( 0: X3 = 0 /\ 0: X4 = 0 /\ 0: X5 = 1 /\ 0: X6 = 0 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A198.litmus.expected000066400000000000000000000003341475314470400266030ustar00rootroot00000000000000Test A198 Required States 1 0:X3=0; 0:X4=0; 0:X5=1; 0:X6=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=0 /\ 0:X4=0 /\ 0:X5=1 /\ 0:X6=0) Observation A198 Always 1 0 Hash=0e5cf53b7abd4a5f512fa27b50688fb9 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A199.litmus000066400000000000000000000005231475314470400250040ustar00rootroot00000000000000AArch64 A199 (* ADDS test, uses CSET *) { 0: X1 = 2; 0: X2 = 2147483647; (* biggest signed number, i.e. [2 ^ 31 - 1].*) } P0 ; ADDS W0, W1, W2; CSET W3, MI; (* Fetch N *) CSET W4, EQ; (* Fetch Z *) CSET W5, CS; (* Fetch C *) CSET W6, VS; (* Fetch V *) forall ( 0: X3 = 1 /\ 0: X4 = 0 /\ 0: X5 = 0 /\ 0: X6 = 1 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A199.litmus.expected000066400000000000000000000003341475314470400266040ustar00rootroot00000000000000Test A199 Required States 1 0:X3=1; 0:X4=0; 0:X5=0; 0:X6=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=1 /\ 0:X4=0 /\ 0:X5=0 /\ 0:X6=1) Observation A199 Always 1 0 Hash=3f1c748c5d71ab0e1629d9797679157f herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A20.litmus000066400000000000000000000002461475314470400247050ustar00rootroot00000000000000AArch64 A20 (* Tests strh (register), UXTW - overflowing store*) { int16_t 0:X0 = 65537; 0:X1=x; uint64_t x; 0:X2=0; } P0; STRH W0, [X1, X2, SXTW]; exists (x=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A20.litmus.expected000066400000000000000000000002411475314470400265000ustar00rootroot00000000000000Test A20 Allowed States 1 [x]=1; Ok Witnesses Positive: 1 Negative: 0 Condition exists ([x]=1) Observation A20 Always 1 0 Hash=bf8d693e88edd762336e0fa1dea81fc7 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A200.litmus000066400000000000000000000005251475314470400247650ustar00rootroot00000000000000AArch64 A200 (* ADDS test, uses CSET *) { 0: X1 = -2147483648 ; (* Smallest negative integer, i.e. [-2^31].*) 0: X2 = -3; } P0 ; ADDS W0, W1, W2; CSET W3, MI; (* Fetch N *) CSET W4, EQ; (* Fetch Z *) CSET W5, CS; (* Fetch C *) CSET W6, VS; (* Fetch V *) forall ( 0: X3 = 0 /\ 0: X4 = 0 /\ 0: X5 = 1 /\ 0: X6 = 1 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A200.litmus.expected000066400000000000000000000003341475314470400265630ustar00rootroot00000000000000Test A200 Required States 1 0:X3=0; 0:X4=0; 0:X5=1; 0:X6=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=0 /\ 0:X4=0 /\ 0:X5=1 /\ 0:X6=1) Observation A200 Always 1 0 Hash=9945de536fe1529c136b70b07555a3d0 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A201.litmus000066400000000000000000000004331475314470400247640ustar00rootroot00000000000000AArch64 A201 (* ADDS test, uses CSET *) { 0: X1 = 2; 0: X2 = 3; } P0 ; ADDS W0, W1, W2; CSET W3, MI; (* Fetch N *) CSET W4, EQ; (* Fetch Z *) CSET W5, CS; (* Fetch C *) CSET W6, VS; (* Fetch V *) forall ( 0: X3 = 0 /\ 0: X4 = 0 /\ 0: X5 = 0 /\ 0: X6 = 0 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A201.litmus.expected000066400000000000000000000003341475314470400265640ustar00rootroot00000000000000Test A201 Required States 1 0:X3=0; 0:X4=0; 0:X5=0; 0:X6=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=0 /\ 0:X4=0 /\ 0:X5=0 /\ 0:X6=0) Observation A201 Always 1 0 Hash=b23fd46a8f413b94e56193d6cfe0adde herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A202.litmus000066400000000000000000000004711475314470400247670ustar00rootroot00000000000000AArch64 A202 (* Test ANDS instruction *) { int64_t 0: X1 = 3; int64_t 0: X2 = 0xFFFFFFFFFFFFFFFC; } P0 ; ANDS X0, X1, X2; CSET W3, MI; (* Fetch N *) CSET W4, EQ; (* Fetch Z *) CSET W5, CS; (* Fetch C *) CSET W6, VS; (* Fetch V *) forall ( 0: X3 = 0 /\ 0: X4 = 1 /\ 0: X5 = 0 /\ 0: X6 = 0 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A202.litmus.expected000066400000000000000000000003341475314470400265650ustar00rootroot00000000000000Test A202 Required States 1 0:X3=0; 0:X4=1; 0:X5=0; 0:X6=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=0 /\ 0:X4=1 /\ 0:X5=0 /\ 0:X6=0) Observation A202 Always 1 0 Hash=cdcb26024ce459dc21f1d0af4dde3568 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A203.litmus000066400000000000000000000004421475314470400247660ustar00rootroot00000000000000AArch64 A203 (* Test ANDS instruction *) { 0: X1 = -3; 0: X2 = 0xFFFFFFFF; } P0 ; ANDS W0, W1, W2; CSET W3, MI; (* Fetch N *) CSET W4, EQ; (* Fetch Z *) CSET W5, CS; (* Fetch C *) CSET W6, VS; (* Fetch V *) forall ( 0: X3 = 1 /\ 0: X4 = 0 /\ 0: X5 = 0 /\ 0: X6 = 0 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A203.litmus.expected000066400000000000000000000003341475314470400265660ustar00rootroot00000000000000Test A203 Required States 1 0:X3=1; 0:X4=0; 0:X5=0; 0:X6=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=1 /\ 0:X4=0 /\ 0:X5=0 /\ 0:X6=0) Observation A203 Always 1 0 Hash=340e3f43378a9cee86f00011aa926d94 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A204.litmus000066400000000000000000000004321475314470400247660ustar00rootroot00000000000000AArch64 A204 (* Test BICS instruction *) { 0: X1 = -3; 0: X2 = 10; } P0 ; BICS W0, W1, W2; CSET W3, MI; (* Fetch N *) CSET W4, EQ; (* Fetch Z *) CSET W5, CS; (* Fetch C *) CSET W6, VS; (* Fetch V *) forall ( 0: X3 = 1 /\ 0: X4 = 0 /\ 0: X5 = 0 /\ 0: X6 = 0 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A204.litmus.expected000066400000000000000000000003341475314470400265670ustar00rootroot00000000000000Test A204 Required States 1 0:X3=1; 0:X4=0; 0:X5=0; 0:X6=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=1 /\ 0:X4=0 /\ 0:X5=0 /\ 0:X6=0) Observation A204 Always 1 0 Hash=5f03d5d936a23c8a205432fdd979744a herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A205.litmus000066400000000000000000000004531475314470400247720ustar00rootroot00000000000000AArch64 A205 (* SUBS test, uses CSET *) { int64_t 0: X1 = 2; int64_t 0: X2 = 3; } P0 ; SUBS X0, X1, X2; CSET W3, MI; (* Fetch N *) CSET W4, EQ; (* Fetch Z *) CSET W5, CS; (* Fetch C *) CSET W6, VS; (* Fetch V *) forall ( 0: X3 = 1 /\ 0: X4 = 0 /\ 0: X5 = 0 /\ 0: X6 = 0 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A205.litmus.expected000066400000000000000000000003341475314470400265700ustar00rootroot00000000000000Test A205 Required States 1 0:X3=1; 0:X4=0; 0:X5=0; 0:X6=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=1 /\ 0:X4=0 /\ 0:X5=0 /\ 0:X6=0) Observation A205 Always 1 0 Hash=146bce0db3125e569fb65ae02e6eb162 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A206.litmus000066400000000000000000000004541475314470400247740ustar00rootroot00000000000000AArch64 A206 (* SUBS test, uses CSET *) { int64_t 0: X1 = -1; int64_t 0: X2 = 0; } P0 ; SUBS X0, X1, X2; CSET W3, MI; (* Fetch N *) CSET w4, EQ; (* Fetch Z *) CSET w5, CS; (* Fetch C *) CSET w6, VS; (* Fetch V *) forall ( 0: X3 = 1 /\ 0: X4 = 0 /\ 0: X5 = 1 /\ 0: X6 = 0 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A206.litmus.expected000066400000000000000000000003341475314470400265710ustar00rootroot00000000000000Test A206 Required States 1 0:X3=1; 0:X4=0; 0:X5=1; 0:X6=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=1 /\ 0:X4=0 /\ 0:X5=1 /\ 0:X6=0) Observation A206 Always 1 0 Hash=7149e91d28b94cd15090347fb76aaa4f herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A207.litmus000066400000000000000000000004531475314470400247740ustar00rootroot00000000000000AArch64 A207 (* SUBS test, uses CSET *) { int64_t 0: X1 = 2; int64_t 0: X2 = 2; } P0 ; SUBS X0, X1, X2; CSET w3, MI; (* Fetch N *) CSET w4, EQ; (* Fetch Z *) CSET w5, CS; (* Fetch C *) CSET w6, VS; (* Fetch V *) forall ( 0: X3 = 0 /\ 0: X4 = 1 /\ 0: X5 = 1 /\ 0: X6 = 0 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A207.litmus.expected000066400000000000000000000003341475314470400265720ustar00rootroot00000000000000Test A207 Required States 1 0:X3=0; 0:X4=1; 0:X5=1; 0:X6=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=0 /\ 0:X4=1 /\ 0:X5=1 /\ 0:X6=0) Observation A207 Always 1 0 Hash=70803363e18a67fafe6158e3965d55c0 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A208.litmus000066400000000000000000000004531475314470400247750ustar00rootroot00000000000000AArch64 A208 (* SUBS test, uses CSET *) { int64_t 0: X1 = 2; int64_t 0: X2 = 5; } P0 ; SUBS X0, X1, X2; CSET w3, MI; (* Fetch N *) CSET w4, EQ; (* Fetch Z *) CSET w5, CS; (* Fetch C *) CSET w6, VS; (* Fetch V *) forall ( 0: X3 = 1 /\ 0: X4 = 0 /\ 0: X5 = 0 /\ 0: X6 = 0 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A208.litmus.expected000066400000000000000000000003341475314470400265730ustar00rootroot00000000000000Test A208 Required States 1 0:X3=1; 0:X4=0; 0:X5=0; 0:X6=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=1 /\ 0:X4=0 /\ 0:X5=0 /\ 0:X6=0) Observation A208 Always 1 0 Hash=e2de5fca699dd15def9dca8df5e3bd6d herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A209.litmus000066400000000000000000000005551475314470400250010ustar00rootroot00000000000000AArch64 A209 (* SUBS test, uses CSET *) { int64_t 0: X1 = -2; int64_t 0: X2 = 0x7FFFFFFFFFFFFFFF ; (* biggest signed number, i.e. [2 ^ 63 - 1].*) } P0 ; SUBS X0, X1, X2; CSET w3, MI; (* Fetch N *) CSET w4, EQ; (* Fetch Z *) CSET w5, CS; (* Fetch C *) CSET w6, VS; (* Fetch V *) forall ( 0: X3 = 0 /\ 0: X4 = 0 /\ 0: X5 = 1 /\ 0: X6 = 1 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A209.litmus.expected000066400000000000000000000003341475314470400265740ustar00rootroot00000000000000Test A209 Required States 1 0:X3=0; 0:X4=0; 0:X5=1; 0:X6=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=0 /\ 0:X4=0 /\ 0:X5=1 /\ 0:X6=1) Observation A209 Always 1 0 Hash=716668781e5a48f340b8d23145c64675 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A21.litmus000066400000000000000000000002221475314470400247000ustar00rootroot00000000000000AArch64 A21 (* Tests strh (register), UXTW*) { int16_t 0:X0 = 65537; 0:X1=x; uint64_t x; 0:X2=0; } P0; STRH W0, [X1, X2, UXTW]; exists (x=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A21.litmus.expected000066400000000000000000000002411475314470400265010ustar00rootroot00000000000000Test A21 Allowed States 1 [x]=1; Ok Witnesses Positive: 1 Negative: 0 Condition exists ([x]=1) Observation A21 Always 1 0 Hash=8ed3e3f747c3d00608cfadbe8207e682 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A210.litmus000066400000000000000000000006131475314470400247640ustar00rootroot00000000000000AArch64 A210 (* SUBS test, uses CSET *) { (* Smallest negative integer, i.e. [-2^63], i.e. [0x8000000000000000].*) int64_t 0: X1 = -9223372036854775808; int64_t 0: X2 = 3; } P0 ; SUBS X0, X1, X2; CSET w3, MI; (* Fetch N *) CSET w4, EQ; (* Fetch Z *) CSET w5, CS; (* Fetch C *) CSET w6, VS; (* Fetch V *) forall ( 0: X3 = 0 /\ 0: X4 = 0 /\ 0: X5 = 1 /\ 0: X6 = 1 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A210.litmus.expected000066400000000000000000000003341475314470400265640ustar00rootroot00000000000000Test A210 Required States 1 0:X3=0; 0:X4=0; 0:X5=1; 0:X6=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=0 /\ 0:X4=0 /\ 0:X5=1 /\ 0:X6=1) Observation A210 Always 1 0 Hash=522b430fa53c711c7f1088de8f05e485 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A211.litmus000066400000000000000000000004331475314470400247650ustar00rootroot00000000000000AArch64 A211 (* SUBS test, uses CSET *) { 0: X1 = 2; 0: X2 = 3; } P0 ; SUBS W0, W1, W2; CSET W3, MI; (* Fetch N *) CSET W4, EQ; (* Fetch Z *) CSET W5, CS; (* Fetch C *) CSET W6, VS; (* Fetch V *) forall ( 0: X3 = 1 /\ 0: X4 = 0 /\ 0: X5 = 0 /\ 0: X6 = 0 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A211.litmus.expected000066400000000000000000000003341475314470400265650ustar00rootroot00000000000000Test A211 Required States 1 0:X3=1; 0:X4=0; 0:X5=0; 0:X6=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=1 /\ 0:X4=0 /\ 0:X5=0 /\ 0:X6=0) Observation A211 Always 1 0 Hash=06754ba9ef8921496dbbfcb5b2cdb62f herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A212.litmus000066400000000000000000000004341475314470400247670ustar00rootroot00000000000000AArch64 A212 (* SUBS test, uses CSET *) { 0: X1 = -1; 0: X2 = 0; } P0 ; SUBS W0, W1, W2; CSET W3, MI; (* Fetch N *) CSET W4, EQ; (* Fetch Z *) CSET W5, CS; (* Fetch C *) CSET W6, VS; (* Fetch V *) forall ( 0: X3 = 1 /\ 0: X4 = 0 /\ 0: X5 = 1 /\ 0: X6 = 0 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A212.litmus.expected000066400000000000000000000003341475314470400265660ustar00rootroot00000000000000Test A212 Required States 1 0:X3=1; 0:X4=0; 0:X5=1; 0:X6=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=1 /\ 0:X4=0 /\ 0:X5=1 /\ 0:X6=0) Observation A212 Always 1 0 Hash=aa7ed3c8cfbf1bc3aaae010e1f36886c herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A213.litmus000066400000000000000000000004331475314470400247670ustar00rootroot00000000000000AArch64 A213 (* SUBS test, uses CSET *) { 0: X1 = 2; 0: X2 = 2; } P0 ; SUBS W0, W1, W2; CSET W3, MI; (* Fetch N *) CSET W4, EQ; (* Fetch Z *) CSET W5, CS; (* Fetch C *) CSET W6, VS; (* Fetch V *) forall ( 0: X3 = 0 /\ 0: X4 = 1 /\ 0: X5 = 1 /\ 0: X6 = 0 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A213.litmus.expected000066400000000000000000000003341475314470400265670ustar00rootroot00000000000000Test A213 Required States 1 0:X3=0; 0:X4=1; 0:X5=1; 0:X6=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=0 /\ 0:X4=1 /\ 0:X5=1 /\ 0:X6=0) Observation A213 Always 1 0 Hash=072968b91d2e260c66dc1061be0d0e8c herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A214.litmus000066400000000000000000000004331475314470400247700ustar00rootroot00000000000000AArch64 A214 (* SUBS test, uses CSET *) { 0: X1 = 2; 0: X2 = 5; } P0 ; SUBS W0, W1, W2; CSET W3, MI; (* Fetch N *) CSET W4, EQ; (* Fetch Z *) CSET W5, CS; (* Fetch C *) CSET W6, VS; (* Fetch V *) forall ( 0: X3 = 1 /\ 0: X4 = 0 /\ 0: X5 = 0 /\ 0: X6 = 0 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A214.litmus.expected000066400000000000000000000003341475314470400265700ustar00rootroot00000000000000Test A214 Required States 1 0:X3=1; 0:X4=0; 0:X5=0; 0:X6=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=1 /\ 0:X4=0 /\ 0:X5=0 /\ 0:X6=0) Observation A214 Always 1 0 Hash=e63e7ea307ce9942e16422e9a890e82b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A215.litmus000066400000000000000000000005241475314470400247720ustar00rootroot00000000000000AArch64 A215 (* SUBS test, uses CSET *) { 0: X1 = 2147483647; (* biggest signed number, i.e. [2 ^ 31 - 1].*) 0: X2 = -2; } P0 ; SUBS W0, W1, W2; CSET W3, MI; (* Fetch N *) CSET W4, EQ; (* Fetch Z *) CSET W5, CS; (* Fetch C *) CSET W6, VS; (* Fetch V *) forall ( 0: X3 = 1 /\ 0: X4 = 0 /\ 0: X5 = 0 /\ 0: X6 = 1 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A215.litmus.expected000066400000000000000000000003341475314470400265710ustar00rootroot00000000000000Test A215 Required States 1 0:X3=1; 0:X4=0; 0:X5=0; 0:X6=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=1 /\ 0:X4=0 /\ 0:X5=0 /\ 0:X6=1) Observation A215 Always 1 0 Hash=789c9cf30ed853bd45089ea96da30faf herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A216.litmus000066400000000000000000000005241475314470400247730ustar00rootroot00000000000000AArch64 A216 (* SUBS test, uses CSET *) { 0: X1 = -2147483648 ; (* Smallest negative integer, i.e. [-2^31].*) 0: X2 = 3; } P0 ; SUBS W0, W1, W2; CSET W3, MI; (* Fetch N *) CSET W4, EQ; (* Fetch Z *) CSET W5, CS; (* Fetch C *) CSET W6, VS; (* Fetch V *) forall ( 0: X3 = 0 /\ 0: X4 = 0 /\ 0: X5 = 1 /\ 0: X6 = 1 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A216.litmus.expected000066400000000000000000000003341475314470400265720ustar00rootroot00000000000000Test A216 Required States 1 0:X3=0; 0:X4=0; 0:X5=1; 0:X6=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=0 /\ 0:X4=0 /\ 0:X5=1 /\ 0:X6=1) Observation A216 Always 1 0 Hash=16997fa8f66c088036e097a7011ba390 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A22.litmus000066400000000000000000000002171475314470400247050ustar00rootroot00000000000000AArch64 A22 (* Tests strh (register), LSL*) { int16_t 0:X0 = 1; 0:X1=x; uint64_t x; 0:X2=0; } P0; STRH W0, [X1, X2, LSL #0]; exists (x=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A22.litmus.expected000066400000000000000000000002411475314470400265020ustar00rootroot00000000000000Test A22 Allowed States 1 [x]=1; Ok Witnesses Positive: 1 Negative: 0 Condition exists ([x]=1) Observation A22 Always 1 0 Hash=b05a554a8a83be34e0e19b3ad771a156 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A228.litmus000066400000000000000000000007121475314470400247750ustar00rootroot00000000000000AArch64 A228 (* Same as 234 but using wregs*) (* Test UBFM/SBFM wreg*) { uint32_t 0:X20 = 0xFFFFFFFF; uint32_t 0:X21 = 0xFFFFFFFF; int32_t 0:X22 = 0x00000000; int32_t 0:X23 = 0x00000000; uint32_t 0:X19 = 0x55667788; int32_t 0:X18 = 0xAA998878; } P0; UBFM W20, W19, #4, #31; UBFM W21, W19, #24, #7; SBFM W22, W18, #4, #31; SBFM W23, W18, #24, #7; forall (0:X20 = 0x5566778 /\ 0:X21 = 0x8800 /\ 0:X22 = 0xFAA99887 /\ 0:X23 = 0x7800) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A228.litmus.expected000066400000000000000000000004231475314470400265740ustar00rootroot00000000000000Test A228 Required States 1 0:X20=89548664; 0:X21=34816; 0:X22=-89548665; 0:X23=30720; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X20=89548664 /\ 0:X21=34816 /\ 0:X22=4205418631 /\ 0:X23=30720) Observation A228 Always 1 0 Hash=b28bd59b4c9a6cfae818b049beba7d32 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A229.litmus000066400000000000000000000004351475314470400250000ustar00rootroot00000000000000AArch64 A229 { uint32_t 0:X0=0xF; uint32_t 0:X1; uint32_t 0:X2; uint64_t 0:X3=0xF; uint64_t 0:X4; uint64_t 0:X5; } P0 ; UBFM W1,W0,#0,#0 ; SBFM W2,W1,#0,#0 ; UBFM X4,X3,#0,#0 ; SBFM X5,X4,#0,#0 ; forall 0:X1=0x1 /\ 0:X2=0xffffffff /\ 0:X4=0x1 /\ 0:X5=0xffffffffffffffff herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A229.litmus.expected000066400000000000000000000004021475314470400265720ustar00rootroot00000000000000Test A229 Required States 1 0:X1=1; 0:X2=4294967295; 0:X4=1; 0:X5=18446744073709551615; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=1 /\ 0:X2=4294967295 /\ 0:X4=1 /\ 0:X5=-1) Observation A229 Always 1 0 Hash=a7d1ec3240ec4160e6ff6f2fae328eb1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A23.litmus000066400000000000000000000002451475314470400247070ustar00rootroot00000000000000AArch64 A23 (* Tests strh (register), LSL overflowing store*) { int16_t 0:X0 = 65537; 0:X1=x; uint64_t x; 0:X2=0; } P0; STRH W0, [X1, X2, LSL #0]; exists (x=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A23.litmus.expected000066400000000000000000000002411475314470400265030ustar00rootroot00000000000000Test A23 Allowed States 1 [x]=1; Ok Witnesses Positive: 1 Negative: 0 Condition exists ([x]=1) Observation A23 Always 1 0 Hash=51ab5c7fd4f8a2403c6a34edd07cf508 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A230.litmus000066400000000000000000000003041475314470400247630ustar00rootroot00000000000000AArch64 A230 (* Tests Store Post-indexed write*) { 0:X1 = 0; 0:X2 = x; int64_t x[2] ={1,2}; } P0; STR X1, [X2], #8; STR X1, [X2]; ADD X2, X2, #-8; forall (x[0] = 0 /\ x[1] = 0 /\ 0:X2=x) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A230.litmus.expected000066400000000000000000000003121475314470400265620ustar00rootroot00000000000000Test A230 Required States 1 0:X2=x; x[0]=0; x[1]=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (x[0]=0 /\ x[1]=0 /\ 0:X2=x) Observation A230 Always 1 0 Hash=b97224dfc2156753ba88d5648cfb3ab4 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A231.litmus000066400000000000000000000002501475314470400247640ustar00rootroot00000000000000AArch64 A231 (* Tests Store Post-indexed write*) { 0:X1 = 0; 0:X2 = x; int x[2] ={1,2}; } P0; STR W1,[X2],#4 ; ADD W1,W1,#1 ; STR W1,[X2],#4 ; forall x={0,1} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A231.litmus.expected000066400000000000000000000002501475314470400265640ustar00rootroot00000000000000Test A231 Required States 1 x={0,1}; Ok Witnesses Positive: 1 Negative: 0 Condition forall (x={0,1}) Observation A231 Always 1 0 Hash=f56333b7d77cb91353fa20ce0fe5a6f1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A232.litmus000066400000000000000000000002271475314470400247710ustar00rootroot00000000000000AArch64 A232 (* Tests Store Post-indexed write*) { 0:X1 = 3; 0:X2 = x; int x[2] ={1,2}; } P0; STR WZR,[X2],#0 ; STR W1,[X2], #0 ; forall x={3,2} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A232.litmus.expected000066400000000000000000000002501475314470400265650ustar00rootroot00000000000000Test A232 Required States 1 x={3,2}; Ok Witnesses Positive: 1 Negative: 0 Condition forall (x={3,2}) Observation A232 Always 1 0 Hash=2aa35c0ee79ddc793486c00dfbccac10 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A233.litmus000066400000000000000000000002351475314470400247710ustar00rootroot00000000000000AArch64 A233 { int t[2]={1,2}; 0:X1=t; } P0 ; LDR W0,[X1],#4 ; MOV W2,#3 ; STR W2,[X1],#4 ; ADD X1,X1,#-8 ; forall 0:X0=1 /\ t[1]=3 /\ 0:X1=t herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A233.litmus.expected000066400000000000000000000003121475314470400265650ustar00rootroot00000000000000Test A233 Required States 1 0:X0=1; 0:X1=t; t[1]=3; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=1 /\ t[1]=3 /\ 0:X1=t) Observation A233 Always 1 0 Hash=fbb5dd140043cc14ef81baadf7494ed7 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A234.litmus000066400000000000000000000007401475314470400247730ustar00rootroot00000000000000AArch64 A234 (* Test UBFM/SBFM Xreg*) { uint64_t 0:X20 = 0xFFFFFFFFFFFFFFFF; uint64_t 0:X21 = 0xFFFFFFFFFFFFFFFF; int64_t 0:X22 = 0x0000000000000000; int64_t 0:X23 = 0x0000000000000000; uint64_t 0:X19 = 0x1122334455667788; int64_t 0:X18 = 0xEEDDCCBBAA998878; } P0; UBFM X20, X19, #4, #32; UBFM X21, X19, #56, #7; SBFM X22, X18, #4, #32; SBFM X23, X18, #56, #7; forall (0:X20 = 0x5566778 /\ 0:X21 = 0x8800 /\ 0:X22 = 0xFFFFFFFFFAA99887 /\ 0:X23 = 0x7800) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A234.litmus.expected000066400000000000000000000004221475314470400265700ustar00rootroot00000000000000Test A234 Required States 1 0:X20=89548664; 0:X21=34816; 0:X22=-89548665; 0:X23=30720; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X20=89548664 /\ 0:X21=34816 /\ 0:X22=-89548665 /\ 0:X23=30720) Observation A234 Always 1 0 Hash=a39291334aea9e04d38c52075fc5081d herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A235.litmus000066400000000000000000000001401475314470400247660ustar00rootroot00000000000000AArch64 C Variant=morello { int x=1; 0:X1=x; } P0 ; STR WZR,[C1] ; forall [x]=0 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A235.litmus.expected000066400000000000000000000002351475314470400265730ustar00rootroot00000000000000Test C Required States 1 [x]=1; No Witnesses Positive: 0 Negative: 1 Condition forall ([x]=0) Observation C Never 0 1 Hash=63d39367a4fe571201587275c10c0941 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A236.litmus000066400000000000000000000003771475314470400250030ustar00rootroot00000000000000AArch64 A236 (* Tests MVN Register instruction *) (* Remember inverting 00 -> 11 which is 0 to -1 in 2s complement *) { int64_t 0:X1 = 0; int64_t 0:X2 = 1; int64_t 0:X0; int64_t 0:X3; } P0; MVN X0, X1; MVN X3, X2; forall (0:X0 = -1 /\ 0:X3 = -2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A236.litmus.expected000066400000000000000000000002741475314470400265770ustar00rootroot00000000000000Test A236 Required States 1 0:X0=-1; 0:X3=-2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=-1 /\ 0:X3=-2) Observation A236 Always 1 0 Hash=8205eb706c7f2a58368a8bdc3b855c37 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A237.litmus000066400000000000000000000003021475314470400247700ustar00rootroot00000000000000AArch64 237 (* Tests ORN Register instruction *) { int64_t 0:X1 = 0; int64_t 0:X2 = 1; int64_t 0:X0; int64_t 0:X3; } P0; ORN X0, X1, X1; ORN X3, X1, X2; forall (0:X0 = -1 /\ 0:X3 = -2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A237.litmus.expected000066400000000000000000000002721475314470400265760ustar00rootroot00000000000000Test 237 Required States 1 0:X0=-1; 0:X3=-2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=-1 /\ 0:X3=-2) Observation 237 Always 1 0 Hash=834e9eb108b922fdf090ff1bf5f7190c herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A238.litmus000066400000000000000000000001211475314470400247700ustar00rootroot00000000000000AArch64 238 { } P0; MOV X0, #-1; MOV X1, #-2; forall (0:X0=-1 /\ 0:X1=-2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A238.litmus.expected000066400000000000000000000002721475314470400265770ustar00rootroot00000000000000Test 238 Required States 1 0:X0=-1; 0:X1=-2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=-1 /\ 0:X1=-2) Observation 238 Always 1 0 Hash=8b86d7765222bf3ed08820a6afe93356 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A239.litmus000066400000000000000000000001551475314470400250000ustar00rootroot00000000000000AArch64 A239 { int64_t 0:X0; int64_t 0:X1 } P0; MOV X0, #-1; MOV X1, #-2; forall (0:X0=-1 /\ 0:X1=-2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A239.litmus.expected000066400000000000000000000002741475314470400266020ustar00rootroot00000000000000Test A239 Required States 1 0:X0=-1; 0:X1=-2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=-1 /\ 0:X1=-2) Observation A239 Always 1 0 Hash=c65f23e3f1dccdd03896721865e1e792 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A24.litmus000066400000000000000000000002571475314470400247130ustar00rootroot00000000000000AArch64 A24 (* Tests ldrsb instruction *) { int64_t 0:X0 =1; 0:X1 = x; int8_t x = 127; } P0; LDRSB X0, [X1]; MOV X2, #1; ADD X0, X0, X2; forall (0:X0=128 /\ [x]=127) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A24.litmus.expected000066400000000000000000000002741475314470400265120ustar00rootroot00000000000000Test A24 Required States 1 0:X0=128; [x]=127; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=128 /\ [x]=127) Observation A24 Always 1 0 Hash=0cc381c605cf2eb655154d31987318ae herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A240.litmus000066400000000000000000000003461475314470400247720ustar00rootroot00000000000000AArch64 A240 (* Tests Store pair Post-indexed write*) { int64_t 0:X1 = 5; int64_t 0:X2 = 6; int64_t *0:X3 = x; int64_t x[4] ={1,2,3,4}; } P0; STP X1, X2, [X3], #16; ADD X3, X3, #-16; forall (x[0] = 5 /\ x[1] = 6 /\ 0:X3=x) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A240.litmus.expected000066400000000000000000000003121475314470400265630ustar00rootroot00000000000000Test A240 Required States 1 0:X3=x; x[0]=5; x[1]=6; Ok Witnesses Positive: 1 Negative: 0 Condition forall (x[0]=5 /\ x[1]=6 /\ 0:X3=x) Observation A240 Always 1 0 Hash=0c20e0ef6bd6054f1b927d5e6905e910 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A241.litmus000066400000000000000000000003711475314470400247710ustar00rootroot00000000000000AArch64 A241 { int64_t t[4]={1,2,3,4}; int64_t *0:X2=t; int64_t 0:X0; int64_t 0:X1; } P0 ; LDP X0, X1, [X2],#16 ; MOV X3,#5 ; STR X3,[X2],#8 ; ADD X2,X2,#-24 ; forall (0:X0=1 /\ 0:X1=2 /\ t[2]=5 /\ 0:X2=t) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A241.litmus.expected000066400000000000000000000003341475314470400265700ustar00rootroot00000000000000Test A241 Required States 1 0:X0=1; 0:X1=2; 0:X2=t; t[2]=5; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=1 /\ 0:X1=2 /\ t[2]=5 /\ 0:X2=t) Observation A241 Always 1 0 Hash=142d1f1b5813a733f8c6a208059e5268 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A242.litmus000066400000000000000000000020641475314470400247730ustar00rootroot00000000000000AArch64 A242 (* Test CASP wreg and xreg*) Stable=X6,X7,X2,X3,X8,X9,X10,X11 { int x[2]={0,0}; uint64_t 0:X5=x; int 0:X6; int 0:X7; int 0:X2; int 0:X3; int 1:X6; int 1:X7; int 1:X2; int 1:X3; int64_t 0:X8; int64_t 0:X9; int64_t 0:X10; int64_t 0:X11; int64_t 1:X8; int64_t 1:X9; int64_t 1:X10; int64_t 1:X11; int y[2]={0,0}; uint64_t 1:X5=y; int64_t z[2]= {0,0}; uint64_t 0:X12=z; int64_t a[2] = {0,0}; uint64_t 1:X12=a; } P0 | P1 ; MOV W6,#1 | MOV W6,#0 ; MOV W7,#1 | MOV W7,#0 ; MOV W2,#2 | MOV W2,#2 ; MOV W3,#2 | MOV W3,#2 ; CASP W6,W7,W2,W3,[X5] | CASP W6,W7,W2,W3,[X5] ; MOV X10,#1 | MOV X10,#0 ; MOV X11,#1 | MOV X11,#0 ; MOV X8,#2 | MOV X8,#2 ; MOV X9,#2 | MOV X9,#2 ; CASP X10,X11,X8,X9,[X12] | CASP X10,X11,X8,X9,[X12]; forall (x[0]=0 /\ x[1]=0 /\ y[0]=2 /\ y[1]=2 /\ z[0] = 0 /\ z[1] = 0 /\ a[0]=2 /\ a[1]=2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A242.litmus.expected000066400000000000000000000004461475314470400265750ustar00rootroot00000000000000Test A242 Required States 1 a[0]=2; a[1]=2; x[0]=0; x[1]=0; y[0]=2; y[1]=2; z[0]=0; z[1]=0; Ok Witnesses Positive: 36 Negative: 0 Condition forall (x[0]=0 /\ x[1]=0 /\ y[0]=2 /\ y[1]=2 /\ z[0]=0 /\ z[1]=0 /\ a[0]=2 /\ a[1]=2) Observation A242 Always 36 0 Hash=a53545f0a258acc581288f0aa9b5c936 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A243.litmus000066400000000000000000000020761475314470400247770ustar00rootroot00000000000000AArch64 A243 (* Test CASPAL wreg and xreg*) Stable=X6,X7,X2,X3,X8,X9,X10,X11 { int x[2]={0,0}; uint64_t 0:X5=x; int 0:X6; int 0:X7; int 0:X2; int 0:X3; int 1:X6; int 1:X7; int 1:X2; int 1:X3; int64_t 0:X8; int64_t 0:X9; int64_t 0:X10; int64_t 0:X11; int64_t 1:X8; int64_t 1:X9; int64_t 1:X10; int64_t 1:X11; int y[2]={0,0}; uint64_t 1:X5=y; int64_t z[2]= {0,0}; uint64_t 0:X12=z; int64_t a[2] = {0,0}; uint64_t 1:X12=a; } P0 | P1 ; MOV W6,#1 | MOV W6,#0 ; MOV W7,#1 | MOV W7,#0 ; MOV W2,#2 | MOV W2,#2 ; MOV W3,#2 | MOV W3,#2 ; CASPAL W6,W7,W2,W3,[X5] | CASPAL W6,W7,W2,W3,[X5] ; MOV X10,#1 | MOV X10,#0 ; MOV X11,#1 | MOV X11,#0 ; MOV X8,#2 | MOV X8,#2 ; MOV X9,#2 | MOV X9,#2 ; CASPAL X10,X11,X8,X9,[X12] | CASPAL X10,X11,X8,X9,[X12]; forall (x[0]=0 /\ x[1]=0 /\ y[0]=2 /\ y[1]=2 /\ z[0] = 0 /\ z[1] = 0 /\ a[0]=2 /\ a[1]=2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A243.litmus.expected000066400000000000000000000004461475314470400265760ustar00rootroot00000000000000Test A243 Required States 1 a[0]=2; a[1]=2; x[0]=0; x[1]=0; y[0]=2; y[1]=2; z[0]=0; z[1]=0; Ok Witnesses Positive: 36 Negative: 0 Condition forall (x[0]=0 /\ x[1]=0 /\ y[0]=2 /\ y[1]=2 /\ z[0]=0 /\ z[1]=0 /\ a[0]=2 /\ a[1]=2) Observation A243 Always 36 0 Hash=450d6bea2cb06cb6a4eec6037dcb6802 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A244.litmus000066400000000000000000000020711475314470400247730ustar00rootroot00000000000000AArch64 A244 (* Test CASPL wreg and xreg*) Stable=X6,X7,X2,X3,X8,X9,X10,X11 { int x[2]={0,0}; uint64_t 0:X5=x; int 0:X6; int 0:X7; int 0:X2; int 0:X3; int 1:X6; int 1:X7; int 1:X2; int 1:X3; int64_t 0:X8; int64_t 0:X9; int64_t 0:X10; int64_t 0:X11; int64_t 1:X8; int64_t 1:X9; int64_t 1:X10; int64_t 1:X11; int y[2]={0,0}; uint64_t 1:X5=y; int64_t z[2]= {0,0}; uint64_t 0:X12=z; int64_t a[2] = {0,0}; uint64_t 1:X12=a; } P0 | P1 ; MOV W6,#1 | MOV W6,#0 ; MOV W7,#1 | MOV W7,#0 ; MOV W2,#2 | MOV W2,#2 ; MOV W3,#2 | MOV W3,#2 ; CASPL W6,W7,W2,W3,[X5] | CASPL W6,W7,W2,W3,[X5] ; MOV X10,#1 | MOV X10,#0 ; MOV X11,#1 | MOV X11,#0 ; MOV X8,#2 | MOV X8,#2 ; MOV X9,#2 | MOV X9,#2 ; CASPL X10,X11,X8,X9,[X12] | CASPL X10,X11,X8,X9,[X12]; forall (x[0]=0 /\ x[1]=0 /\ y[0]=2 /\ y[1]=2 /\ z[0] = 0 /\ z[1] = 0 /\ a[0]=2 /\ a[1]=2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A244.litmus.expected000066400000000000000000000004461475314470400265770ustar00rootroot00000000000000Test A244 Required States 1 a[0]=2; a[1]=2; x[0]=0; x[1]=0; y[0]=2; y[1]=2; z[0]=0; z[1]=0; Ok Witnesses Positive: 36 Negative: 0 Condition forall (x[0]=0 /\ x[1]=0 /\ y[0]=2 /\ y[1]=2 /\ z[0]=0 /\ z[1]=0 /\ a[0]=2 /\ a[1]=2) Observation A244 Always 36 0 Hash=f5f65af42b0b1c4ef91a867eb4c84a3c herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A245.litmus000066400000000000000000000020711475314470400247740ustar00rootroot00000000000000AArch64 A245 (* Test CASPA wreg and xreg*) Stable=X6,X7,X2,X3,X8,X9,X10,X11 { int x[2]={0,0}; uint64_t 0:X5=x; int 0:X6; int 0:X7; int 0:X2; int 0:X3; int 1:X6; int 1:X7; int 1:X2; int 1:X3; int64_t 0:X8; int64_t 0:X9; int64_t 0:X10; int64_t 0:X11; int64_t 1:X8; int64_t 1:X9; int64_t 1:X10; int64_t 1:X11; int y[2]={0,0}; uint64_t 1:X5=y; int64_t z[2]= {0,0}; uint64_t 0:X12=z; int64_t a[2] = {0,0}; uint64_t 1:X12=a; } P0 | P1 ; MOV W6,#1 | MOV W6,#0 ; MOV W7,#1 | MOV W7,#0 ; MOV W2,#2 | MOV W2,#2 ; MOV W3,#2 | MOV W3,#2 ; CASPA W6,W7,W2,W3,[X5] | CASPA W6,W7,W2,W3,[X5] ; MOV X10,#1 | MOV X10,#0 ; MOV X11,#1 | MOV X11,#0 ; MOV X8,#2 | MOV X8,#2 ; MOV X9,#2 | MOV X9,#2 ; CASPA X10,X11,X8,X9,[X12] | CASPA X10,X11,X8,X9,[X12]; forall (x[0]=0 /\ x[1]=0 /\ y[0]=2 /\ y[1]=2 /\ z[0] = 0 /\ z[1] = 0 /\ a[0]=2 /\ a[1]=2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A245.litmus.expected000066400000000000000000000004461475314470400266000ustar00rootroot00000000000000Test A245 Required States 1 a[0]=2; a[1]=2; x[0]=0; x[1]=0; y[0]=2; y[1]=2; z[0]=0; z[1]=0; Ok Witnesses Positive: 36 Negative: 0 Condition forall (x[0]=0 /\ x[1]=0 /\ y[0]=2 /\ y[1]=2 /\ z[0]=0 /\ z[1]=0 /\ a[0]=2 /\ a[1]=2) Observation A245 Always 36 0 Hash=51b29db6588f853cf4e04fe2a1242893 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A246.litmus000066400000000000000000000021251475314470400247750ustar00rootroot00000000000000AArch64 A246 (* Test CASP wreg and xreg - differing first and second reg*) Stable=X6,X7,X2,X3,X8,X9,X10,X11 { int x[2]={0,0}; uint64_t 0:X5=x; int 0:X6; int 0:X7; int 0:X2; int 0:X3; int 1:X6; int 1:X7; int 1:X2; int 1:X3; int64_t 0:X8; int64_t 0:X9; int64_t 0:X10; int64_t 0:X11; int64_t 1:X8; int64_t 1:X9; int64_t 1:X10; int64_t 1:X11; int y[2]={0,1}; uint64_t 1:X5=y; int64_t z[2]= {0,0}; uint64_t 0:X12=z; int64_t a[2] = {0,1}; uint64_t 1:X12=a; } P0 | P1 ; MOV W6,#1 | MOV W6,#0 ; MOV W7,#1 | MOV W7,#1 ; MOV W2,#2 | MOV W2,#2 ; MOV W3,#2 | MOV W3,#2 ; CASP W6,W7,W2,W3,[X5] | CASP W6,W7,W2,W3,[X5] ; MOV X10,#1 | MOV X10,#0 ; MOV X11,#1 | MOV X11,#1 ; MOV X8,#2 | MOV X8,#2 ; MOV X9,#2 | MOV X9,#2 ; CASP X10,X11,X8,X9,[X12] | CASP X10,X11,X8,X9,[X12]; forall (x[0]=0 /\ x[1]=0 /\ y[0]=2 /\ y[1]=2 /\ z[0] = 0 /\ z[1] = 0 /\ a[0]=2 /\ a[1]=2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A246.litmus.expected000066400000000000000000000004461475314470400266010ustar00rootroot00000000000000Test A246 Required States 1 a[0]=2; a[1]=2; x[0]=0; x[1]=0; y[0]=2; y[1]=2; z[0]=0; z[1]=0; Ok Witnesses Positive: 36 Negative: 0 Condition forall (x[0]=0 /\ x[1]=0 /\ y[0]=2 /\ y[1]=2 /\ z[0]=0 /\ z[1]=0 /\ a[0]=2 /\ a[1]=2) Observation A246 Always 36 0 Hash=dfcdd105748ed1fb63dad2657811b691 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A247.litmus000066400000000000000000000001671475314470400250020ustar00rootroot00000000000000AArch64 A247 Variant=fatal { } P0 ; L0: ; UDF #0 ; forall(Fault(P0:L0,UndefinedInstruction)) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A247.litmus.expected000066400000000000000000000003351475314470400265770ustar00rootroot00000000000000Test A247 Required States 1 Fault(P0:L0,UndefinedInstruction); Ok Witnesses Positive: 1 Negative: 0 Condition forall (fault(P0:L0,UndefinedInstruction)) Observation A247 Always 1 0 Hash=f175a0f32cc8e0defdfd4e1bdd656da4 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A248.litmus000066400000000000000000000003701475314470400247770ustar00rootroot00000000000000AArch64 A248 { 0:X0=P1:L0; 0:X2=instr:"B .+4"; ins_t 0:X1; } P0 | P1 ; LDR W1,[X0] | B end ; CMP W2,W1 | L0: ; B.NE Lend | B L1 ; MOV W3,#1 | L1: ; Lend: | end: ; locations [0:X1;0:X2] forall (0:X3=1)herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A248.litmus.expected000066400000000000000000000003161475314470400265770ustar00rootroot00000000000000Test A248 Required States 1 0:X1=instr:"B .+4"; 0:X2=instr:"B .+4"; 0:X3=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=1) Observation A248 Always 1 0 Hash=1ab162da020db5cac849d14050f1cd9d herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A249.litmus000066400000000000000000000004031475314470400247750ustar00rootroot00000000000000AArch64 A249 Stable=X0 { } P0 | P1 ; BL L1 | BL L1 ; | B L2 ; |L1: ; | MOV W0,#1 ; | RET ; |L2: ; locations [0:X0;1:X0;]herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A249.litmus.expected-failure000066400000000000000000000002271475314470400302260ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64/A249.litmus": P0 cannot refer to L1 defined by P1, use register with initial value P1:L1 (User error) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A25.litmus000066400000000000000000000002541475314470400247110ustar00rootroot00000000000000AArch64 A25 (* Tests ldrsh instruction *) { int64_t 0:X0 = 1; 0:X1 = x; int16_t x = 65535; } P0; LDRSH X0, [X1]; MOV X2, #1; ADD X0, X0, X2; exists (0:X0 = 65536) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A25.litmus.expected000066400000000000000000000002461475314470400265120ustar00rootroot00000000000000Test A25 Allowed States 1 0:X0=0; No Witnesses Positive: 0 Negative: 1 Condition exists (0:X0=65536) Observation A25 Never 0 1 Hash=9ec1aadd808402a3c54362081a9a7e21 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A250.litmus000066400000000000000000000004171475314470400247720ustar00rootroot00000000000000AArch64 A250 Stable=X0 { 0:X1=P1:L1; } P0 | P1 ; BLR X1 | BL L1 ; | B L2 ; |L1: ; | MOV W0,#1 ; | RET ; |L2: ; locations [0:X0;1:X0;]herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A250.litmus.expected000066400000000000000000000002541475314470400265710ustar00rootroot00000000000000Test A250 Required States 1 0:X0=1; 1:X0=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (true) Observation A250 Always 1 0 Hash=55cc1072298c3933993a6ebb45116ba8 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A251.litmus000066400000000000000000000004621475314470400247730ustar00rootroot00000000000000AArch64 A251 { 0:X8=P1:L0; 0:X9=P1:L1; ins_t 0:X1; ins_t 0:X2; } P0 | P1 ; LDR W1,[X8] | B L2 ; LDR W2,[X9] | L0: ; CMP W2,W1 | ADR X0,L1 ; B.NE Lend | L1: ; MOV W3,#1 | ADR X0,L2 ; Lend: | L2: ; locations [0:X1;0:X2] forall (0:X3=1)herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A251.litmus.expected000066400000000000000000000003301475314470400265650ustar00rootroot00000000000000Test A251 Required States 1 0:X1=instr:"ADR X0,.+4"; 0:X2=instr:"ADR X0,.+4"; 0:X3=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=1) Observation A251 Always 1 0 Hash=7d571cafde4d2f6e82704d4577fb87cd herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A252.litmus000066400000000000000000000003231475314470400247700ustar00rootroot00000000000000AArch64 A252 (* SUBS test, uses CSETM *) { 0: X1 = 2; 0: X2 = 3; } P0 ; SUBS W0, W1, W2 ; CSETM W3, MI ; (* Fetch N *) CSETM W4, EQ ; (* Fetch Z *) forall (0:X3 = -1 /\ 0:X4 = 0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A252.litmus.expected000066400000000000000000000002721475314470400265730ustar00rootroot00000000000000Test A252 Required States 1 0:X3=-1; 0:X4=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=-1 /\ 0:X4=0) Observation A252 Always 1 0 Hash=565b4de4a429ef6a6c183798a0040922 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A253.litmus000066400000000000000000000020231475314470400247700ustar00rootroot00000000000000AArch64 A253 Variant=telechat { [P1_r0]=0;[x]=0;[y]=0; uint64_t %P0_x=x; uint64_t %P0_y=y; uint64_t %P1_P1_r0=P1_r0; uint64_t %P1_x=x;uint64_t %P1_y=y } (*****************************************************************) (* Compiler: *) (* aarch64-linux-gnu-gcc -c -g -O2 -pthread --std=c11 -fno-section-anchors*) (* *) (*****************************************************************) P0 | P1 ; MOVZ W1,#2 | LDR W1,[X%P1_y] ; STLR W1,[X%P0_x] | CMP W1,#1 ; MOVZ W1,#1 | B.EQ L0x5c ; STR W1,[X%P0_y] | STR W1,[X%P1_P1_r0] ; RET | RET ; | L0x5c: ; | MOVZ W2,#1 ; | STLR W2,[X%P1_x] ; | STR W1,[X%P1_P1_r0] ; | RET ; exists ([x]=2 /\ P1_r0=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A253.litmus.expected000066400000000000000000000003421475314470400265720ustar00rootroot00000000000000Test A253 Allowed States 3 [P1_r0]=0; [x]=2; [P1_r0]=1; [x]=1; [P1_r0]=1; [x]=2; Ok Witnesses Positive: 1 Negative: 2 Condition exists ([x]=2 /\ [P1_r0]=1) Observation A253 Sometimes 1 2 Hash=9947775663b21929c5c41a619489515c herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A254.litmus000066400000000000000000000003161475314470400247740ustar00rootroot00000000000000AArch64 A254 Variant=NV2 { uint64_t nvmem[100]; 0:VNCR_EL2=nvmem; 1:X1=nvmem; } P0 | P1 ; MOV X0,#1 | LDR X0,[X1,560] ; MSR ELR_EL1,X0 | ; exists(1:X0=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A254.litmus.expected000066400000000000000000000002601475314470400265720ustar00rootroot00000000000000Test A254 Allowed States 2 1:X0=0; 1:X0=1; Ok Witnesses Positive: 1 Negative: 1 Condition exists (1:X0=1) Observation A254 Sometimes 1 1 Hash=297cf69b1db0a4bcf94195fb798aa3c4 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A255.litmus000066400000000000000000000003211475314470400247710ustar00rootroot00000000000000AArch64 A255 Variant=NV2 { uint64_t nvmem[100]; 0:X1=nvmem; 1:VNCR_EL2=nvmem; } P0 | P1 ; MOV X0,#1 | MRS X0,ELR_EL1 ; STR X0,[X1,560] | ; exists(1:X0=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A255.litmus.expected000066400000000000000000000002601475314470400265730ustar00rootroot00000000000000Test A255 Allowed States 2 1:X0=0; 1:X0=1; Ok Witnesses Positive: 1 Negative: 1 Condition exists (1:X0=1) Observation A255 Sometimes 1 1 Hash=816546a4a005c4130428e8d3a0100626 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A256.litmus000066400000000000000000000002611475314470400247750ustar00rootroot00000000000000AArch64 A256 Variant=NV2 { uint64_t nvmem[23]; 0:VNCR_EL2=nvmem; 0:X1=nvmem; } P0 ; MOV X0,#1 ; MSR VNCR_EL2,X0 ; LDR X0,[X1,#176] ; forall(0:X0=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A256.litmus.expected000066400000000000000000000002461475314470400266000ustar00rootroot00000000000000Test A256 Required States 1 0:X0=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=1) Observation A256 Always 1 0 Hash=f9b426b9e6788ff77f4451c2e136fe67 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A257.litmus000066400000000000000000000001151475314470400247740ustar00rootroot00000000000000AArch64 A257 Stable=X30 { } P0 ; BL L0 ; L0: ; locations[0:X30;] herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A257.litmus.expected000066400000000000000000000002611475314470400265760ustar00rootroot00000000000000Test A257 Required States 1 0:X30=label:"P0:L0"; Ok Witnesses Positive: 1 Negative: 0 Condition forall (true) Observation A257 Always 1 0 Hash=acdb36c81923f38d3d34a02996cbc81c herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A258.litmus000066400000000000000000000001221475314470400247730ustar00rootroot00000000000000AArch64 A258 { } P0 ; L0: ; ADR X0,L0 ; forall(0:X0=label:"0:L0") herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A258.litmus.expected000066400000000000000000000002761475314470400266050ustar00rootroot00000000000000Test A258 Required States 1 0:X0=label:"P0:L0"; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=label:"P0:L0") Observation A258 Always 1 0 Hash=e0cbeef721bbbb5cb7dd570a9b680cea herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A259.litmus000066400000000000000000000001721475314470400250010ustar00rootroot00000000000000AArch64 A259 Variant=fatal { } P0 ; L0: ; SVC #0 ; L1: ; forall(Fault(P0:L0,SupervisorCall))herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A259.litmus.expected000066400000000000000000000003211475314470400265750ustar00rootroot00000000000000Test A259 Required States 1 Fault(P0:L0,SupervisorCall); Ok Witnesses Positive: 1 Negative: 0 Condition forall (fault(P0:L0,SupervisorCall)) Observation A259 Always 1 0 Hash=4091dac82d97298f370a841c62bd669c herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A26.litmus000066400000000000000000000003271475314470400247130ustar00rootroot00000000000000AArch64 A26 { 0:X1 = x; int8_t x = -1; int64_t 0:X4; int64_t 0:X6; } P0; LDRSB W0,[X1] ; MOV X4,X0 ; LDRB W2,[X1] ; MOV X6,X2 ; forall (0:X0=-1 /\ 0:X2=255 /\ 0:X4=4294967295 /\ 0:X6=255) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A26.litmus.expected000066400000000000000000000003661475314470400265160ustar00rootroot00000000000000Test A26 Required States 1 0:X0=-1; 0:X2=255; 0:X4=4294967295; 0:X6=255; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=-1 /\ 0:X2=255 /\ 0:X4=4294967295 /\ 0:X6=255) Observation A26 Always 1 0 Hash=15ee72abb5d901119b6ff48bf8054b79 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A27.litmus000066400000000000000000000003341475314470400247120ustar00rootroot00000000000000AArch64 A27 { 0:X1 = x; int16_t x = -1; int64_t 0:X4; int64_t 0:X6; } P0; LDRSH W0,[X1] ; MOV X4,X0 ; LDRH W2,[X1] ; MOV X6,X2 ; forall (0:X0=-1 /\ 0:X2=65535 /\ 0:X4=4294967295 /\ 0:X6=65535) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A27.litmus.expected000066400000000000000000000003761475314470400265200ustar00rootroot00000000000000Test A27 Required States 1 0:X0=-1; 0:X2=65535; 0:X4=4294967295; 0:X6=65535; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=-1 /\ 0:X2=65535 /\ 0:X4=4294967295 /\ 0:X6=65535) Observation A27 Always 1 0 Hash=93cac7fe5e426154009293d2e2d87ea4 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A28.litmus000066400000000000000000000002321475314470400247100ustar00rootroot00000000000000AArch64 A28 (* Tests load exclusive register, symbolic location, no offset*) { 0:X1=x; int64_t x; int64_t 0:X0; } P0; LDXR X0, [X1]; forall (0:X0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A28.litmus.expected000066400000000000000000000002441475314470400265130ustar00rootroot00000000000000Test A28 Required States 1 0:X0=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=0) Observation A28 Always 1 0 Hash=20a4925d8aa6d710e2b27264e37f0cbc herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A29.litmus000066400000000000000000000002301475314470400247070ustar00rootroot00000000000000AArch64 A29 (* Tests load acquire register, symbolic location, no offset*) { 0:X1=x; int64_t x; int64_t 0:X0; } P0; LDAR X0, [X1]; exists (0:X0=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A29.litmus.expected000066400000000000000000000002431475314470400265130ustar00rootroot00000000000000Test A29 Allowed States 1 0:X0=0; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=0) Observation A29 Always 1 0 Hash=051301064723fe3c801c4b4b2ca2682e herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A39.litmus000066400000000000000000000002311475314470400247110ustar00rootroot00000000000000AArch64 A39 (* Tests test bit not zero *) { uint64_t 0:X0=1; uint64_t 0:X1; } P0; TBNZ X0, #0, foo; MOV X1, #1; foo:MOV X2, #1; exists (0:X1=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A39.litmus.expected000066400000000000000000000002431475314470400265140ustar00rootroot00000000000000Test A39 Allowed States 1 0:X1=0; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X1=0) Observation A39 Always 1 0 Hash=4bd8fb2ff2099d9ac1b411740c06fa1f herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A40.litmus000066400000000000000000000002311475314470400247010ustar00rootroot00000000000000AArch64 A40 (* Tests test bit not zero *) { uint64_t 0:X0=2; uint64_t 0:X1; } P0; TBNZ X0, #0, foo; MOV X1, #1; foo:MOV X2, #1; exists (0:X1=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A40.litmus.expected000066400000000000000000000002431475314470400265040ustar00rootroot00000000000000Test A40 Allowed States 1 0:X1=1; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X1=1) Observation A40 Always 1 0 Hash=4ec1daf6dc12c4faa20c0f6242b570d5 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A41.litmus000066400000000000000000000002311475314470400247020ustar00rootroot00000000000000AArch64 A41 (* Tests test bit not zero *) { uint64_t 0:X0=2; uint64_t 0:X1; } P0; TBNZ X0, #1, foo; MOV X1, #1; foo:MOV X2, #1; exists (0:X1=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A41.litmus.expected000066400000000000000000000002431475314470400265050ustar00rootroot00000000000000Test A41 Allowed States 1 0:X1=0; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X1=0) Observation A41 Always 1 0 Hash=253ac259d57c9ca9eb3b4a6d2466069b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A42.litmus000066400000000000000000000002311475314470400247030ustar00rootroot00000000000000AArch64 A42 (* Tests test bit not zero *) { uint64_t 0:X0=4; uint64_t 0:X1; } P0; TBNZ X0, #2, foo; MOV X1, #1; foo:MOV X2, #1; exists (0:X1=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A42.litmus.expected000066400000000000000000000002431475314470400265060ustar00rootroot00000000000000Test A42 Allowed States 1 0:X1=0; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X1=0) Observation A42 Always 1 0 Hash=c301122f41391d5d66581179ed7203a4 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A43.litmus000066400000000000000000000003161475314470400247100ustar00rootroot00000000000000AArch64 A43 (* Test load exclusive; Store exclusive, symbolic location *) { 0:X4=z; int64_t z=2 } P0; LDXR X0, [X4]; ADD X0, X0, #1; STXR W3, X0, [X4]; forall ((z=2 /\ 0:X3=1) \/ (z=3 /\ 0:X3=0)) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A43.litmus.expected000066400000000000000000000003261475314470400265110ustar00rootroot00000000000000Test A43 Required States 2 0:X3=0; [z]=3; 0:X3=1; [z]=2; Ok Witnesses Positive: 2 Negative: 0 Condition forall ([z]=2 /\ 0:X3=1 \/ [z]=3 /\ 0:X3=0) Observation A43 Always 2 0 Hash=0c9a68bee99067fc763ca3ee77fca8c6 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A44.litmus000066400000000000000000000004441475314470400247130ustar00rootroot00000000000000AArch64 A44 (* Test load exclusive; Store exclusive, symbolic location *) { 0:X4=z; int64_t z=2; int64_t 1:X5=5; 1:X6=z} P0 | P1; LDXR X0, [X4] | STR X5, [X6]; ADD X0, X0, #1 | ; STXR W3, X0, [X4] | ; forall not ((z=3 /\ 0:X3=1) \/ (z=6 /\ 0:X3=1)) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A44.litmus.expected000066400000000000000000000003531475314470400265120ustar00rootroot00000000000000Test A44 Required States 3 0:X3=0; [z]=5; 0:X3=0; [z]=6; 0:X3=1; [z]=5; Ok Witnesses Positive: 4 Negative: 0 Condition forall (not ([z]=3 /\ 0:X3=1 \/ [z]=6 /\ 0:X3=1)) Observation A44 Always 4 0 Hash=a642f170dc28a5298b2f8424ab1575d7 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A47.litmus000066400000000000000000000002241475314470400247120ustar00rootroot00000000000000AArch64 A47 (* Tests test bit zero *) { uint64_t 0:X0=0; uint64_t 0:X1; } P0; TBZ X0, #0, foo; MOV X1, #1; foo:MOV X2, #1; exists (0:X1=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A47.litmus.expected000066400000000000000000000002431475314470400265130ustar00rootroot00000000000000Test A47 Allowed States 1 0:X1=0; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X1=0) Observation A47 Always 1 0 Hash=02fa242a2e0a097204cd15de74ca593a herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A48.litmus000066400000000000000000000002251475314470400247140ustar00rootroot00000000000000AArch64 A48 (* Tests test bit zero *) { uint64_t 0:X0=1; uint64_t 0:X1; } P0; TBZ X0, #0, foo; MOV X1, #1; foo:MOV X2, #1; exists (0:X1=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A48.litmus.expected000066400000000000000000000002431475314470400265140ustar00rootroot00000000000000Test A48 Allowed States 1 0:X1=1; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X1=1) Observation A48 Always 1 0 Hash=b14e5b585865013b13db2d5e36a2a2e5 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A49.litmus000066400000000000000000000002251475314470400247150ustar00rootroot00000000000000AArch64 A49 (* Tests test bit zero *) { uint64_t 0:X0=1; uint64_t 0:X1; } P0; TBZ X0, #1, foo; MOV X1, #1; foo:MOV X2, #1; exists (0:X1=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A49.litmus.expected000066400000000000000000000002431475314470400265150ustar00rootroot00000000000000Test A49 Allowed States 1 0:X1=0; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X1=0) Observation A49 Always 1 0 Hash=e36e5aa56b22d79c612b8de3603a2095 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A50.litmus000066400000000000000000000002251475314470400247050ustar00rootroot00000000000000AArch64 A50 (* Tests test bit zero *) { uint64_t 0:X0=3; uint64_t 0:X1; } P0; TBZ X0, #2, foo; MOV X1, #1; foo:MOV X2, #1; exists (0:X1=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A50.litmus.expected000066400000000000000000000002431475314470400265050ustar00rootroot00000000000000Test A50 Allowed States 1 0:X1=0; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X1=0) Observation A50 Always 1 0 Hash=15b76a736449c7aa332d2a5c5c91c96b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A51.litmus000066400000000000000000000001411475314470400247030ustar00rootroot00000000000000AArch64 A51 (* Tests movz, 32-bit, no shift *) { 0:X0=0; } P0; MOVZ W0, #42; exists (0:X0=42) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A51.litmus.expected000066400000000000000000000002451475314470400265100ustar00rootroot00000000000000Test A51 Allowed States 1 0:X0=42; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=42) Observation A51 Always 1 0 Hash=1611ac52d31d484b8a8d216395caf808 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A52.litmus000066400000000000000000000001521475314470400247060ustar00rootroot00000000000000AArch64 A52 (* Tests movz, 64-bit, no shift *) { uint64_t 0:X0=0; } P0; MOVZ X0, #42; exists (0:X0=42) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A52.litmus.expected000066400000000000000000000002451475314470400265110ustar00rootroot00000000000000Test A52 Allowed States 1 0:X0=42; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=42) Observation A52 Always 1 0 Hash=2c1e88de0b5fc21d99c0c5a3c120b17b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A53.litmus000066400000000000000000000001551475314470400247120ustar00rootroot00000000000000AArch64 A53 (* Tests movz, 32-bit, LSL 0 (noop) *) { 0:X0=0; } P0; MOVZ W0, #42, LSL #0; exists (0:X0=42) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A53.litmus.expected000066400000000000000000000002451475314470400265120ustar00rootroot00000000000000Test A53 Allowed States 1 0:X0=42; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=42) Observation A53 Always 1 0 Hash=d8d50ee03150172d1e9afcc4b6da8d8a herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A54.litmus000066400000000000000000000001661475314470400247150ustar00rootroot00000000000000AArch64 A54 (* Tests movz, 64-bit, LSL 0 (noop) *) { uint64_t 0:X0=0; } P0; MOVZ X0, #42, LSL #0; exists (0:X0=42) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A54.litmus.expected000066400000000000000000000002451475314470400265130ustar00rootroot00000000000000Test A54 Allowed States 1 0:X0=42; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=42) Observation A54 Always 1 0 Hash=f87639eb3a43f119a6c5da45a2f9713a herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A55.litmus000066400000000000000000000001551475314470400247140ustar00rootroot00000000000000AArch64 A55 (* Tests movz, 32-bit, LSL 16 *) { 0:X0=0; } P0; MOVZ W0, #42, LSL #16; exists (0:X0=2752512) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A55.litmus.expected000066400000000000000000000002571475314470400265170ustar00rootroot00000000000000Test A55 Allowed States 1 0:X0=2752512; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=2752512) Observation A55 Always 1 0 Hash=e59e662963bc13a720b6862fb3066839 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A56.litmus000066400000000000000000000001661475314470400247170ustar00rootroot00000000000000AArch64 A56 (* Tests movz, 64-bit, LSL 16 *) { uint64_t 0:X0=0; } P0; MOVZ X0, #42, LSL #16; exists (0:X0=2752512) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A56.litmus.expected000066400000000000000000000002571475314470400265200ustar00rootroot00000000000000Test A56 Allowed States 1 0:X0=2752512; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=2752512) Observation A56 Always 1 0 Hash=95c00b4811cad97ec49224ec7e045dff herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A57.litmus000066400000000000000000000001731475314470400247160ustar00rootroot00000000000000AArch64 A57 (* Tests movz, 64-bit, LSL 32 *) { uint64_t 0:X0=0; } P0; MOVZ X0, #42, LSL #32; exists (0:X0=180388626432) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A57.litmus.expected000066400000000000000000000002711475314470400265150ustar00rootroot00000000000000Test A57 Allowed States 1 0:X0=180388626432; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=180388626432) Observation A57 Always 1 0 Hash=655f9f0e90a2032594375055552130cd herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A58.litmus000066400000000000000000000002001475314470400247060ustar00rootroot00000000000000AArch64 A58 (* Tests movz, 64-bit, LSL 48 *) { uint64_t 0:X0=0; } P0; MOVZ X0, #42, LSL #48; exists (0:X0=11821949021847552) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A58.litmus.expected000066400000000000000000000003031475314470400265120ustar00rootroot00000000000000Test A58 Allowed States 1 0:X0=11821949021847552; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=11821949021847552) Observation A58 Always 1 0 Hash=edb817a1eac1b52c99297743ff0b5137 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A63.litmus000066400000000000000000000001561475314470400247140ustar00rootroot00000000000000AArch64 A63 (* Tests asr (immediate), no shift *) { uint64_t 0:X0=1; } P0; ASR X0, X0, #0; exists (0:X0=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A63.litmus.expected000066400000000000000000000002431475314470400265110ustar00rootroot00000000000000Test A63 Allowed States 1 0:X0=1; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=1) Observation A63 Always 1 0 Hash=6a30bf25b8b96de01d0a3a4b854c9977 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A64.litmus000066400000000000000000000001701475314470400247110ustar00rootroot00000000000000AArch64 A64 (* Tests asr (immediate), right shift by 1 *) { uint64_t 0:X0=64; } P0; ASR X0, X0, #1; exists (0:X0=32) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A64.litmus.expected000066400000000000000000000002451475314470400265140ustar00rootroot00000000000000Test A64 Allowed States 1 0:X0=32; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=32) Observation A64 Always 1 0 Hash=6d62f41e70acb35b4f25be8deb4a9c66 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A65.litmus000066400000000000000000000002051475314470400247110ustar00rootroot00000000000000AArch64 A65 (* Tests asr (register), reg shift of 1 *) { int64_t 0:X0=64; uint64_t 0:X1=1; } P0; ASR X0, X0, X1; exists (0:X0=32) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A65.litmus.expected000066400000000000000000000002451475314470400265150ustar00rootroot00000000000000Test A65 Allowed States 1 0:X0=32; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=32) Observation A65 Always 1 0 Hash=37c5fd26f7225e5917b85e863778ac34 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A66.litmus000066400000000000000000000002021475314470400247070ustar00rootroot00000000000000AArch64 A66 (* Tests adds (immediate), zero immediate, no shift *) { uint64_t 0:X0=42; } P0; ADDS X0, X0, #0; exists (0:X0=42) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A66.litmus.expected000066400000000000000000000002451475314470400265160ustar00rootroot00000000000000Test A66 Allowed States 1 0:X0=42; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=42) Observation A66 Always 1 0 Hash=decd4d816f68b4d590c76ceae7725da9 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A67.litmus000066400000000000000000000001621475314470400247150ustar00rootroot00000000000000AArch64 A67 (* Tests adds (immediate), no shift *) { uint64_t 0:X0=42; } P0; ADDS X0, X0, #1; exists (0:X0=43) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A67.litmus.expected000066400000000000000000000002451475314470400265170ustar00rootroot00000000000000Test A67 Allowed States 1 0:X0=43; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=43) Observation A67 Always 1 0 Hash=56e537ca04fcf3ae5706e0fe97f53c99 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A68.litmus000066400000000000000000000002161475314470400247160ustar00rootroot00000000000000AArch64 A68 (* Tests adds (immediate), zero immediate, left shift 0 *) { uint64_t 0:X0=42; } P0; ADDS X0, X0, #0, lsl #0; exists (0:X0=42) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A68.litmus.expected000066400000000000000000000002451475314470400265200ustar00rootroot00000000000000Test A68 Allowed States 1 0:X0=42; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=42) Observation A68 Always 1 0 Hash=decd4d816f68b4d590c76ceae7725da9 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A69.litmus000066400000000000000000000002021475314470400247120ustar00rootroot00000000000000AArch64 A69 (* Tests adds (immediate), left shift 12 *) { uint64_t 0:X0=42; } P0; ADDS X0, X0, #1, lsl #12; exists (0:X0=4138) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A69.litmus.expected000066400000000000000000000002511475314470400265160ustar00rootroot00000000000000Test A69 Allowed States 1 0:X0=4138; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=4138) Observation A69 Always 1 0 Hash=2f51de3dcd647233f77732b51012a4ec herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A70.litmus000066400000000000000000000002121475314470400247030ustar00rootroot00000000000000AArch64 A70 (* Tests adds (shifted register), no shift *) { uint64_t 0:X0=42; uint64_t 0:X1=1; } P0; ADDS X0, X0, X1; exists (0:X0=43) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A70.litmus.expected000066400000000000000000000002451475314470400265110ustar00rootroot00000000000000Test A70 Allowed States 1 0:X0=43; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=43) Observation A70 Always 1 0 Hash=889ea123175d0bf4e436898756421219 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A71.litmus000066400000000000000000000002431475314470400247100ustar00rootroot00000000000000AArch64 A71 (* Tests adds (shifted register), left shift by zero (noop) *) { uint64_t 0:X0=42; uint64_t 0:X1=1; } P0; ADDS X0, X0, X1, lsl #0; exists (0:X0=43) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A71.litmus.expected000066400000000000000000000002451475314470400265120ustar00rootroot00000000000000Test A71 Allowed States 1 0:X0=43; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=43) Observation A71 Always 1 0 Hash=889ea123175d0bf4e436898756421219 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A72.litmus000066400000000000000000000002311475314470400247060ustar00rootroot00000000000000AArch64 A72 (* Tests adds (shifted register), left shift by 4 *) { uint64_t 0:X0=42; uint64_t 0:X1=1; } P0; ADDS X0, X0, X1, lsl #4; exists (0:X0=58) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A72.litmus.expected000066400000000000000000000002451475314470400265130ustar00rootroot00000000000000Test A72 Allowed States 1 0:X0=58; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=58) Observation A72 Always 1 0 Hash=8a6082446156fb119fa8614516392d34 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A73.litmus000066400000000000000000000002441475314470400247130ustar00rootroot00000000000000AArch64 A73 (* Tests adds (shifted register), right shift by zero (noop) *) { uint64_t 0:X0=42; unit64_t 0:X1=1; } P0; ADDS X0, X0, X1, lsr #0; exists (0:X0=43) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A73.litmus.expected000066400000000000000000000002451475314470400265140ustar00rootroot00000000000000Test A73 Allowed States 1 0:X0=43; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=43) Observation A73 Always 1 0 Hash=c6ead73e4b3ec6be7853e2c55a1af8ce herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A74.litmus000066400000000000000000000002331475314470400247120ustar00rootroot00000000000000AArch64 A74 (* Tests adds (shifted register), right shift by 2 *) { uint64_t 0:X0=42; uint64_t 0:X1=32; } P0; ADDS X0, X0, X1, lsr #2; exists (0:X0=50) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A74.litmus.expected000066400000000000000000000002451475314470400265150ustar00rootroot00000000000000Test A74 Allowed States 1 0:X0=50; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=50) Observation A74 Always 1 0 Hash=782d05e6bd1f3fda8d5c0f6ec92776c7 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A75.litmus000066400000000000000000000002471475314470400247200ustar00rootroot00000000000000AArch64 A75 (* Tests adds (shifted register), arith right shift by 0 (noop) *) { uint64_t 0:X0=42; uint64_t 0:X1=1; } P0; ADDS X0, X0, X1, asr #0; exists (0:X0=43) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A75.litmus.expected000066400000000000000000000002451475314470400265160ustar00rootroot00000000000000Test A75 Allowed States 1 0:X0=43; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=43) Observation A75 Always 1 0 Hash=889ea123175d0bf4e436898756421219 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A76.litmus000066400000000000000000000002411475314470400247130ustar00rootroot00000000000000AArch64 A76 (* Tests adds (shifted register), arith right shift by 2 *) { uint64_t 0:X0=42; uint64_t 0:X1=32; } P0; ADDS X0, X0, X1, asr #2; exists (0:X0=50) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A76.litmus.expected000066400000000000000000000002451475314470400265170ustar00rootroot00000000000000Test A76 Allowed States 1 0:X0=50; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=50) Observation A76 Always 1 0 Hash=f2e49d628d081932ecc01fc335c79283 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A77.litmus000066400000000000000000000002011475314470400247100ustar00rootroot00000000000000AArch64 A77 (* Tests add (immediate), zero immediate, no shift *) { uint64_t 0:X0=42; } P0; ADD X0, X0, #1; exists (0:X0=43) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A77.litmus.expected000066400000000000000000000002451475314470400265200ustar00rootroot00000000000000Test A77 Allowed States 1 0:X0=43; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=43) Observation A77 Always 1 0 Hash=5ad8918036519f85ad065ca48e2779db herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A78.litmus000066400000000000000000000002141475314470400247150ustar00rootroot00000000000000AArch64 A78 (* Tests add (immediate), zero immediate, left shift 0 *) { uint64_t 0:X0=42; } P0; ADD X0, X0, #0, lsl #0; exists (0:X0=42) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A78.litmus.expected000066400000000000000000000002451475314470400265210ustar00rootroot00000000000000Test A78 Allowed States 1 0:X0=42; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=42) Observation A78 Always 1 0 Hash=f02d584c80389c4dc2b66aad5e30c756 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A79.litmus000066400000000000000000000002201475314470400247130ustar00rootroot00000000000000AArch64 A79 (* Tests add (immediate), zero immediate, left shift 12 *) { uint64_t 0:X0=42; } P0; ADD X0, X0, #1, lsl #12; exists (0:X0=4138) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A79.litmus.expected000066400000000000000000000002511475314470400265170ustar00rootroot00000000000000Test A79 Allowed States 1 0:X0=4138; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=4138) Observation A79 Always 1 0 Hash=df7a3343333a94c3974142e56a37643b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A80.litmus000066400000000000000000000002101475314470400247020ustar00rootroot00000000000000AArch64 A80 (* Tests add (shifted register), no shift *) { uint64_t 0:X0=42; uint64_t 0:X1=1; } P0; ADD X0, X0, X1; exists (0:X0=43) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A80.litmus.expected000066400000000000000000000002451475314470400265120ustar00rootroot00000000000000Test A80 Allowed States 1 0:X0=43; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=43) Observation A80 Always 1 0 Hash=5c56ad67389766341228bc02d76f8a13 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A81.litmus000066400000000000000000000002411475314470400247070ustar00rootroot00000000000000AArch64 A81 (* Tests add (shifted register), left shift by zero (noop) *) { uint64_t 0:X0=42; uint64_t 0:X1=1; } P0; ADD X0, X0, X1, lsl #0; exists (0:X0=43) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A81.litmus.expected000066400000000000000000000002451475314470400265130ustar00rootroot00000000000000Test A81 Allowed States 1 0:X0=43; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=43) Observation A81 Always 1 0 Hash=5c56ad67389766341228bc02d76f8a13 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A82.litmus000066400000000000000000000002271475314470400247140ustar00rootroot00000000000000AArch64 A82 (* Tests add (shifted register), left shift by 4 *) { uint64_t 0:X0=42; uint64_t 0:X1=1; } P0; ADD X0, X0, X1, lsl #4; exists (0:X0=58) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A82.litmus.expected000066400000000000000000000002451475314470400265140ustar00rootroot00000000000000Test A82 Allowed States 1 0:X0=58; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=58) Observation A82 Always 1 0 Hash=0d6eb53f8686db1bbde1bc3e0c3a2323 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A83.litmus000066400000000000000000000002421475314470400247120ustar00rootroot00000000000000AArch64 A83 (* Tests add (shifted register), right shift by zero (noop) *) { uint64_t 0:X0=42; uint64_t 0:X1=1; } P0; ADD X0, X0, X1, lsr #0; exists (0:X0=43) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A83.litmus.expected000066400000000000000000000002451475314470400265150ustar00rootroot00000000000000Test A83 Allowed States 1 0:X0=43; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=43) Observation A83 Always 1 0 Hash=5c56ad67389766341228bc02d76f8a13 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A84.litmus000066400000000000000000000002311475314470400247110ustar00rootroot00000000000000AArch64 A84 (* Tests add (shifted register), right shift by 2 *) { uint64_t 0:X0=42; uint64_t 0:X1=32; } P0; ADD X0, X0, X1, lsr #2; exists (0:X0=50) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A84.litmus.expected000066400000000000000000000002451475314470400265160ustar00rootroot00000000000000Test A84 Allowed States 1 0:X0=50; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=50) Observation A84 Always 1 0 Hash=2079abfb122fe23176faad86cd9f6ec0 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A85.litmus000066400000000000000000000002451475314470400247170ustar00rootroot00000000000000AArch64 A85 (* Tests add (shifted register), arith right shift by 0 (noop) *) { uint64_t 0:X0=42; uint64_t 0:X1=1; } P0; ADD X0, X0, X1, asr #0; exists (0:X0=43) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A85.litmus.expected000066400000000000000000000002451475314470400265170ustar00rootroot00000000000000Test A85 Allowed States 1 0:X0=43; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=43) Observation A85 Always 1 0 Hash=5c56ad67389766341228bc02d76f8a13 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A86.litmus000066400000000000000000000002371475314470400247210ustar00rootroot00000000000000AArch64 A86 (* Tests add (shifted register), arith right shift by 2 *) { uint64_t 0:X0=42; uint64_t 0:X1=32; } P0; ADD X0, X0, X1, asr #2; exists (0:X0=50) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A86.litmus.expected000066400000000000000000000002451475314470400265200ustar00rootroot00000000000000Test A86 Allowed States 1 0:X0=50; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=50) Observation A86 Always 1 0 Hash=9906e3bec6a7fa9e664d74cdaa77c712 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A87.litmus000066400000000000000000000001471475314470400247220ustar00rootroot00000000000000AArch64 A87 (* Tests movk, 32-bit, no shift *) { 0:X0=65536; } P0; MOVK W0, #1; exists (0:X0=65537) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A87.litmus.expected000066400000000000000000000002531475314470400265200ustar00rootroot00000000000000Test A87 Allowed States 1 0:X0=65537; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=65537) Observation A87 Always 1 0 Hash=34718b0c49e9cca1437c3bd7e5dfb50c herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A88.litmus000066400000000000000000000001601475314470400247160ustar00rootroot00000000000000AArch64 A88 (* Tests movk, 64-bit, no shift *) { uint64_t 0:X0=65536; } P0; MOVK X0, #1; exists (0:X0=65537) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A88.litmus.expected000066400000000000000000000002531475314470400265210ustar00rootroot00000000000000Test A88 Allowed States 1 0:X0=65537; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=65537) Observation A88 Always 1 0 Hash=8a51e9286ceb23747d46e2e438816a62 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A89.litmus000066400000000000000000000001631475314470400247220ustar00rootroot00000000000000AArch64 A89 (* Tests movk, 32-bit, LSL 0 (noop) *) { 0:X0=65536; } P0; MOVK W0, #1, LSL #0; exists (0:X0=65537) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A89.litmus.expected000066400000000000000000000002531475314470400265220ustar00rootroot00000000000000Test A89 Allowed States 1 0:X0=65537; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=65537) Observation A89 Always 1 0 Hash=102431da97e38b17eaee34fcc2cf631c herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A90.litmus000066400000000000000000000001741475314470400247140ustar00rootroot00000000000000AArch64 A90 (* Tests movk, 64-bit, LSL 0 (noop) *) { uint64_t 0:X0=65536; } P0; MOVK X0, #1, LSL #0; exists (0:X0=65537) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A90.litmus.expected000066400000000000000000000002531475314470400265120ustar00rootroot00000000000000Test A90 Allowed States 1 0:X0=65537; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=65537) Observation A90 Always 1 0 Hash=86fd95e686b8d607ffbbe5c4575c58c9 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A91.litmus000066400000000000000000000004411475314470400247120ustar00rootroot00000000000000AArch64 A91 (* Tests movk 32 bits, all possible shift arguments *) { 0:X0=0x20002; } P0; MOV W1,W0 ; MOV W2,W0 ; MOVK W0, #1, LSL #0 ; MOVK W1, #1, LSL #16 ; MOVK W2, #1 ; locations [0:X0; 0:X1;0:X2;] exists (0:X0=0x20001 /\ 0:X1=0x10002 /\ 0:X2=0x20001) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A91.litmus.expected000066400000000000000000000003431475314470400265130ustar00rootroot00000000000000Test A91 Allowed States 1 0:X0=131073; 0:X1=65538; 0:X2=131073; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=131073 /\ 0:X1=65538 /\ 0:X2=131073) Observation A91 Always 1 0 Hash=2a1f402d26f9b2377e76c626e65d2456 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A92.litmus000066400000000000000000000002011475314470400247050ustar00rootroot00000000000000AArch64 A92 (* Tests movk, 64-bit, LSL 16 *) { uint64_t 0:X0=4294967296; } P0; MOVK X0, #1, LSL #16; exists (0:X0=4295032832) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A92.litmus.expected000066400000000000000000000002651475314470400265170ustar00rootroot00000000000000Test A92 Allowed States 1 0:X0=4295032832; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=4295032832) Observation A92 Always 1 0 Hash=8cf0fedc3afd433233fbcbb2b037383e herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A93.litmus000066400000000000000000000004321475314470400247140ustar00rootroot00000000000000AArch64 A93 (* Tests movk, 64-bit, LSL 32 *) { uint64_t 0:X0=0x2000200020002; uint64_t 0:X1;} P0; MOVK X0, #1 ; MOVK X0, #1, LSL #32; MOV X1,X0 ; MOVK X0, #1, LSL #16; MOVK X0, #1, LSL #48; locations [0:X1;] exists (0:X0=0x1000100010001 /\ 0:X1=0x2000100020001) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A93.litmus.expected000066400000000000000000000003551475314470400265200ustar00rootroot00000000000000Test A93 Allowed States 1 0:X0=281479271743489; 0:X1=562954248519681; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=281479271743489 /\ 0:X1=562954248519681) Observation A93 Always 1 0 Hash=9a54718529cc132f96e50096c66ccc39 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A94.litmus000066400000000000000000000001751475314470400247210ustar00rootroot00000000000000AArch64 A94 (* Tests movk, 64-bit, LSL 48 *) { uint64_t 0:X0=1; } P0; MOVK X0, #1, LSL #48; exists (0:X0=281474976710657) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A94.litmus.expected000066400000000000000000000002771475314470400265240ustar00rootroot00000000000000Test A94 Allowed States 1 0:X0=281474976710657; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=281474976710657) Observation A94 Always 1 0 Hash=22dba11ffb9160a9d7784b7ad52015e3 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A95.litmus000066400000000000000000000001731475314470400247200ustar00rootroot00000000000000AArch64 A95 (* Tests add (shifted register), left shift by 1 *) { 0:X0=1; } P0; ADD W1, W0, W0, lsl #1; forall (0:X1=3) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A95.litmus.expected000066400000000000000000000002441475314470400265170ustar00rootroot00000000000000Test A95 Required States 1 0:X1=3; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=3) Observation A95 Always 1 0 Hash=993a5ac27bc3548b67b13f7c2abec3b5 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A96.litmus000066400000000000000000000002241475314470400247160ustar00rootroot00000000000000AArch64 A96 (* Tests asr (immediate), negative initial value, right shift by 2 *) { int64_t 0:X0 = -256; } P0; ASR X0, X0, #2; exists (0:X0=-64) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/A96.litmus.expected000066400000000000000000000002471475314470400265230ustar00rootroot00000000000000Test A96 Allowed States 1 0:X0=-64; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=-64) Observation A96 Always 1 0 Hash=7ca2b108bf266be0b0ed25d0887ebcd9 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/AK001.litmus000066400000000000000000000005731475314470400251020ustar00rootroot00000000000000AArch64 AK001 (* LB+rel+br-ctrl *) { ins_t *y; 0:X2=x; 0:X4=y; 0:X3=P1:L0; 1:X2=x; 1:X4=y; } P0 |P1 ; LDR W1,[X2] | ADR X5,L1 ; STLR X3,[X4] | STR X5,[X4] ; | LDR X3,[X4] ; | BR X3 ; |L0: ; | MOV W0,#1 ; | STR W0,[X2] ; |L1: ; exists (0:X1=1 /\ 1:X0=1)herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/AK001.litmus.expected000066400000000000000000000003101475314470400266670ustar00rootroot00000000000000Test AK001 Allowed States 2 0:X1=0; 1:X0=0; 0:X1=0; 1:X0=1; No Witnesses Positive: 0 Negative: 3 Condition exists (0:X1=1 /\ 1:X0=1) Observation AK001 Never 0 3 Hash=7967e5120b4f97d2a96964ef4e3b026a herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/AK002.litmus000066400000000000000000000006371475314470400251040ustar00rootroot00000000000000AArch64 AK002 (* MP+rel+br-ctrlisb-1 *) { ins_t *y; 0:X2=x; 0:X4=y; 0:X3=P1:L0; 1:X2=x; 1:X4=y; } P0 | P1 ; MOV W1,#1 | ADR X5,L1 ; STR W1,[X2] | STR X5,[X4] ; STLR X3,[X4] | LDR X3,[X4] ; | BR X3 ; |L0: ; | ISB ; | MOV W0,#1 ; | LDR W1,[X2] ; |L1: ; exists (1:X0=1 /\ 1:X1=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/AK002.litmus.expected000066400000000000000000000003101475314470400266700ustar00rootroot00000000000000Test AK002 Allowed States 2 1:X0=0; 1:X1=0; 1:X0=1; 1:X1=1; No Witnesses Positive: 0 Negative: 3 Condition exists (1:X0=1 /\ 1:X1=0) Observation AK002 Never 0 3 Hash=c4340862f7579b543222fa925b3531ea herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/AK003.litmus000066400000000000000000000006361475314470400251040ustar00rootroot00000000000000AArch64 AK003 (* MP+rel+br-ctrlisb-2 *) { ins_t *y; 0:X2=x; 0:X4=y; 0:X3=P1:L0; 1:X2=x; 1:X4=y; } P0 | P1 ; MOV W1,#1 | ADR X5,L1 ; STR W1,[X2] | STR X5,[X4] ; STLR X3,[X4] | LDR X3,[X4] ; | BR X3 ; |L0: ; | ISB ; | MOV W0,#1 ; |L1: ; | LDR W1,[X2] ; exists (1:X0=1 /\ 1:X1=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/AK003.litmus.expected000066400000000000000000000003301475314470400266730ustar00rootroot00000000000000Test AK003 Allowed States 3 1:X0=0; 1:X1=0; 1:X0=0; 1:X1=1; 1:X0=1; 1:X1=1; No Witnesses Positive: 0 Negative: 5 Condition exists (1:X0=1 /\ 1:X1=0) Observation AK003 Never 0 5 Hash=f1ea3d37edb778d976084e71b2bbafc9 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/AK004.litmus000066400000000000000000000001171475314470400250770ustar00rootroot00000000000000AArch64 AK004 { 0:X5=P0:Lself00; } P0 ; MOV X4,X5 ; locations [0:X4]herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/AK004.litmus.expected-failure000066400000000000000000000002261475314470400303250ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64/AK004.litmus": Label Lself00 not found on P0, yet it is used in the initialization list (User error) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/AK005.litmus000066400000000000000000000002251475314470400251000ustar00rootroot00000000000000AArch64 AK005 { 0:X0=NOP; 0:X1=P0:Lself00; } P0 ; STR W0,[X1] ; Lself00: ; B Lself01 ; MOV X2,#1 ; Lself01: ; exists (0:X2=0)herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/AK005.litmus.expected-failure000066400000000000000000000003141475314470400303240ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64/AK005.litmus": Store to P0:Lself00 requires instruction fetch functionality. Please use `-variant self` as an argument to herd7 to enable it. (User error) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L000.litmus000066400000000000000000000002541475314470400247750ustar00rootroot00000000000000AArch64 L000 { 0:X2=x; } (* Regression on STR indexed syntax *) P0 ; MOV W0,#1 ; EOR W1,W0,W0 ; STR W0,[X2,W1,SXTW] ; forall (x=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L000.litmus.expected000066400000000000000000000002441475314470400265740ustar00rootroot00000000000000Test L000 Required States 1 [x]=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=1) Observation L000 Always 1 0 Hash=3c5726f58582737286d66b578b284edb herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L001.litmus000066400000000000000000000002721475314470400247760ustar00rootroot00000000000000AArch64 L001 { int x=0; int y=1; 0:X2=x; 0:X4=y; } (* Regression on LDR indexed syntax *) P0 ; LDR W0,[X2] ; LDR W1,[X4,W0,SXTW] ; forall 0:X0=0 /\ 0:X1=1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L001.litmus.expected000066400000000000000000000002701475314470400265740ustar00rootroot00000000000000Test L001 Required States 1 0:X0=0; 0:X1=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=0 /\ 0:X1=1) Observation L001 Always 1 0 Hash=4dd48694675a0dd892680418816e67fa herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L002.litmus000066400000000000000000000004521475314470400247770ustar00rootroot00000000000000AArch64 L002 Prefetch=0:x=F,0:y=W,1:y=F,1:x=T Com=Rf Fr { 0:X1=x; 0:X3=y; 1:X1=y; 1:X3=x; } P0 | P1 ; MOV W0,#1 | LDR W0,[X1] ; STR W0,[X1] | CBZ W0,LC00 ; DMB SY | ISB ; MOV W2,#1 | LDR W2,[X3] ; STR W2,[X3] |LC00: ; exists (1:X0=1 /\ 1:X2=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L002.litmus.expected000066400000000000000000000003061475314470400265750ustar00rootroot00000000000000Test L002 Allowed States 2 1:X0=0; 1:X2=0; 1:X0=1; 1:X2=1; No Witnesses Positive: 0 Negative: 2 Condition exists (1:X0=1 /\ 1:X2=0) Observation L002 Never 0 2 Hash=46b6dd93851ecaa429cdcdb54a03ca77 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L003.litmus000066400000000000000000000003001475314470400247700ustar00rootroot00000000000000AArch64 L003 (* Test CSINV *) { 0:X0=1; 0:X2=0; uint32_t 0:X1; uint32_t 0:X3; } P0 ; CMP W0,W0 ; CSINV W1,W0,W2,EQ ; CSINV W3,W0,W2,NE ; locations [0:X1; 0:X3;] herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L003.litmus.expected000066400000000000000000000002651475314470400266020ustar00rootroot00000000000000Test L003 Required States 1 0:X1=1; 0:X3=4294967295; Ok Witnesses Positive: 1 Negative: 0 Condition forall (true) Observation L003 Always 1 0 Hash=7dd566bd562eee46c4e50e833e382f10 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L004.litmus000066400000000000000000000003201475314470400247730ustar00rootroot00000000000000AArch64 L004 (* Tests CSNEG *) { int64_t 0:X0=1; int64_t 0:X2=2; int64_t 0:X1; int64_t 0:X3; } P0 ; CMP X0,X0 ; CSNEG X1,X0,X2,EQ ; CSNEG X3,X0,X2,NE ; locations [0:X1; 0:X3;] herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L004.litmus.expected000066400000000000000000000002551475314470400266020ustar00rootroot00000000000000Test L004 Required States 1 0:X1=1; 0:X3=-2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (true) Observation L004 Always 1 0 Hash=e776c867cc5bda05cab9872972a90854 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L005.litmus000066400000000000000000000001761475314470400250050ustar00rootroot00000000000000AArch64 L005 (* test checks if we can check for deliberate failure *) {} P0; fictional_instruction X0, X1; exists (1:X0=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L005.litmus.expected-failure000066400000000000000000000002001475314470400302160ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64/L005.litmus", line 7, characters 22-24: unexpected 'X0' (in prog) (User error) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L006.litmus000066400000000000000000000004041475314470400250000ustar00rootroot00000000000000AArch64 L006 { int x=2; int *p=&x; 0:X2=p; int64_t y=-1; int64_t *q=&y; 0:X6=q; int64_t 0:X1; (* This declaration commandes the printing of 0:X1 below *) } P0 ; LDR X4,[X2] ; LDR W0,[X4] ; LDR X4,[X6] ; LDR X1,[X4] ; forall (0:X0=2 /\ 0:X1=-1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L006.litmus.expected000066400000000000000000000002721475314470400266030ustar00rootroot00000000000000Test L006 Required States 1 0:X0=2; 0:X1=-1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=2 /\ 0:X1=-1) Observation L006 Always 1 0 Hash=474f64303d6a7e978395a5a56d2d6af9 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L007.litmus000066400000000000000000000003561475314470400250070ustar00rootroot00000000000000AArch64 L007 { int x=0; 0:X4=x; int y=0; 1:X4=y; } P0 | P1 ; MOV W3,#1 | MOV W3,#0 ; MOV W2,#2 | MOV W2,#2 ; CAS W3,W2,[X4] | CAS W3,W2,[X4] ; locations [0:X3;1:X3;] forall (x=0 /\ y=2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L007.litmus.expected000066400000000000000000000003041475314470400266000ustar00rootroot00000000000000Test L007 Required States 1 0:X3=0; 1:X3=0; [x]=0; [y]=2; Ok Witnesses Positive: 6 Negative: 0 Condition forall ([x]=0 /\ [y]=2) Observation L007 Always 6 0 Hash=dcd669f7a9ed4f2e408f12673d09b57f herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L008.litmus000066400000000000000000000002221475314470400250000ustar00rootroot00000000000000AArch64 L008 { 0:X2=v; int v[2]={1,2}; } P0 ; LDR W0,[X2] ; LDR W1,[X2,#4] ; locations [0:X0;0:X1;] forall (v[0]=1 /\ v[1]=2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L008.litmus.expected000066400000000000000000000003101475314470400265760ustar00rootroot00000000000000Test L008 Required States 1 0:X0=1; 0:X1=2; v[0]=1; v[1]=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (v[0]=1 /\ v[1]=2) Observation L008 Always 1 0 Hash=39b0e9b5900b379f00de10f3fb89fab7 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L009.litmus000066400000000000000000000003701475314470400250050ustar00rootroot00000000000000AArch64 L009 { 0:X2=v; int v[2]={1,2}; 1:X2=w; int64_t w[2]={1,2}; int64_t 1:X0; } P0 | P1 ; LDR W0, [X2] | LDR X0, [X2] ; STR W0, [X2,#4] | STR X0, [X2,#8] ; forall (0:X0 = 1 /\ 1:X0=1 /\ v[1]=1 /\ w[1]=1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L009.litmus.expected000066400000000000000000000003341475314470400266050ustar00rootroot00000000000000Test L009 Required States 1 0:X0=1; 1:X0=1; v[1]=1; w[1]=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=1 /\ 1:X0=1 /\ v[1]=1 /\ w[1]=1) Observation L009 Always 1 0 Hash=384b15af51c1ae2c061a489bc16fe6c9 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L010.litmus000066400000000000000000000002701475314470400247740ustar00rootroot00000000000000AArch64 L010 { x=1; 0:X2=x; int v[3]={1,2,3}; 1:X2=v;} P0 | P1 ; LDR W0, [X2] | ADD X2,X2,#8 ; | LDR W0,[X2] ; forall (0:X0 = 1 /\ 1:X0=3) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L010.litmus.expected000066400000000000000000000002701475314470400265740ustar00rootroot00000000000000Test L010 Required States 1 0:X0=1; 1:X0=3; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=1 /\ 1:X0=3) Observation L010 Always 1 0 Hash=db6d22d1ebfb355fa70eed16d4f46d6d herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L011.litmus000066400000000000000000000003241475314470400247750ustar00rootroot00000000000000AArch64 L011 { int8_t x=-1; int16_t y=-2; int32_t z=-16; 0:X2=x; int8_t 0:X1; 0:X4=y; int32_t 0:X3; 0:X6=z; int32_t 0:X5; } P0 ; LDRB W1,[X2] ; LDRH W3,[X4] ; LDR W5,[X6] ; locations [0:X1;0:X3;0:X5;] herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L011.litmus.expected000066400000000000000000000002731475314470400266000ustar00rootroot00000000000000Test L011 Required States 1 0:X1=-1; 0:X3=65534; 0:X5=-16; Ok Witnesses Positive: 1 Negative: 0 Condition forall (true) Observation L011 Always 1 0 Hash=caaab570971f758d0730f0cb4ab42d45 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L012.litmus000066400000000000000000000002111475314470400247710ustar00rootroot00000000000000AArch64 L012 { int v[3] = { 1,2,3 }; 0:X2=v; } P0 ; LDR W0,[X2] ; LDR W1,[X2,#8] ; STR W0,[X2,#8] ; STR W1,[X2] ; locations [v;] herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L012.litmus.expected000066400000000000000000000002471475314470400266020ustar00rootroot00000000000000Test L012 Required States 1 v={3,2,1}; Ok Witnesses Positive: 1 Negative: 0 Condition forall (true) Observation L012 Always 1 0 Hash=f0b0d81e632ea180c4605e1e7620937b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L013.litmus000066400000000000000000000002161475314470400247770ustar00rootroot00000000000000AArch64 L013 { int t[2]={1,2}; 0:X2=t; } P0 ; LDR W0,[X2,#0] ; LDR W1,[X2,#4] ; STR W0,[X2,#4] ; STR W1,[X2,#0] ; forall t={2,1} herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L013.litmus.expected000066400000000000000000000002501475314470400265750ustar00rootroot00000000000000Test L013 Required States 1 t={2,1}; Ok Witnesses Positive: 1 Negative: 0 Condition forall (t={2,1}) Observation L013 Always 1 0 Hash=7a6210acffbac9e1f9750c61aac8f1cb herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L014.litmus000066400000000000000000000004771475314470400250110ustar00rootroot00000000000000AArch64 L014 { x=0; 0:X2=x; int64_t 0:X4; int32_t u[2]={-1,-1}; uint8_t v[2]={-1,-1}; 0:X6=v; } P0 ; MOV W0,#1 ; SUB W0,WZR,W0 ; STR W0,[X2] ; SXTW X4,W0 ; MOV W3,#2 ; SUB W3,WZR,W3 ; STRB W3,[X6] ; locations [x;0:X0;0:X4;u;v[0]] forall (0:X4=-1 /\ x=-1 /\ u[0]=4294967295 /\ v[1]=-1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L014.litmus.expected000066400000000000000000000004111475314470400265750ustar00rootroot00000000000000Test L014 Required States 1 0:X0=-1; 0:X4=-1; u={-1,-1}; [x]=-1; u[0]=-1; v[0]=254; v[1]=255; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X4=-1 /\ [x]=-1 /\ u[0]=4294967295 /\ v[1]=-1) Observation L014 Always 1 0 Hash=721604cf560cb9a64aa4869cc869b054 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L015.litmus000066400000000000000000000002541475314470400250030ustar00rootroot00000000000000AArch64 L015 (* Tests STR barrel shifters - SXTW *) { uint64_t x; 0:x0=1; 0:x2=x; int32_t 0:x3=0;} P0 ; STR W0, [X2, W3, SXTW]; exists (x=0x1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L015.litmus.expected000066400000000000000000000002431475314470400266010ustar00rootroot00000000000000Test L015 Allowed States 1 [x]=1; Ok Witnesses Positive: 1 Negative: 0 Condition exists ([x]=1) Observation L015 Always 1 0 Hash=1e61a83b6f7566c8526ca4540c009b2f herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L016.litmus000066400000000000000000000002541475314470400250040ustar00rootroot00000000000000AArch64 L016 (* Tests STR barrel shifters - UXTW *) { uint64_t x; 0:x0=1; 0:x2=x; int32_t 0:x3=0;} P0 ; STR W0, [X2, W3, UXTW]; exists (x=0x1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L016.litmus.expected000066400000000000000000000002431475314470400266020ustar00rootroot00000000000000Test L016 Allowed States 1 [x]=1; Ok Witnesses Positive: 1 Negative: 0 Condition exists ([x]=1) Observation L016 Always 1 0 Hash=2c1dc0ae671fb6f35401c54bde5b7845 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L017.litmus000066400000000000000000000003651475314470400250100ustar00rootroot00000000000000AArch64 L017 (* Tests STR barrel shifters *) (* Same as M002 but using vectors so it works in non-mixed mode*) { uint32_t x[2] = {2,2}; 0:x0=1; 0:x2=x; int64_t 0:x3=1;} P0 ; STR W0, [X2, X3, LSL#2]; exists (x={2,1}) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L017.litmus.expected000066400000000000000000000002471475314470400266070ustar00rootroot00000000000000Test L017 Allowed States 1 x={2,1}; Ok Witnesses Positive: 1 Negative: 0 Condition exists (x={2,1}) Observation L017 Always 1 0 Hash=4d6e36211c150aee5ee2723464a442f6 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L018.litmus000066400000000000000000000003051475314470400250030ustar00rootroot00000000000000AArch64 L018 (* Tests STR barrel shifters *) (* Same as M006*) { uint32_t x[2] = {2,2}; 0:x0=1; 0:x2=x; int64_t 0:x3=1;} P0 ; STR W0, [X2, X3, LSL#2]; exists (x={2,1}) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L018.litmus.expected000066400000000000000000000002471475314470400266100ustar00rootroot00000000000000Test L018 Allowed States 1 x={2,1}; Ok Witnesses Positive: 1 Negative: 0 Condition exists (x={2,1}) Observation L018 Always 1 0 Hash=4d6e36211c150aee5ee2723464a442f6 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L019.litmus000066400000000000000000000002651475314470400250110ustar00rootroot00000000000000AArch64 L019 (* Successful LX/SX pair, can also fail *) { int x=1; 0:X0=x; } P0 ; MOV W3,#2 ; LDXR W1,[X0] ; STXR W4,W3,[X0] ; exists 0:X4<>0 /\ x=1; herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L019.litmus.expected000066400000000000000000000003151475314470400266050ustar00rootroot00000000000000Test L019 Allowed States 2 0:X4=0; [x]=2; 0:X4=1; [x]=1; Ok Witnesses Positive: 1 Negative: 1 Condition exists (not (0:X4=0) /\ [x]=1) Observation L019 Sometimes 1 1 Hash=af6b38c40bdc3f1f6f0dc714391a363e herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L020.litmus000066400000000000000000000004101475314470400247710ustar00rootroot00000000000000AArch64 L020 (* LX/SX with different address, success is Constrained Upredictable. Normaly excluded, appears with -variant CU *) { int x=1; int y=2; 0:X0=x; 0:X2=y; } P0 ; LDXR W1,[X0] ; MOV W3,#3 ; STXR W4,W3,[X2] ; ~exists y=3; herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L020.litmus.expected000066400000000000000000000002451475314470400265770ustar00rootroot00000000000000Test L020 Forbidden States 1 [y]=2; Ok Witnesses Positive: 1 Negative: 0 Condition ~exists ([y]=3) Observation L020 Never 0 1 Hash=a98a9e6b957012feb7f4c25cd4c01d69 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L021.litmus000066400000000000000000000003341475314470400247770ustar00rootroot00000000000000AArch64 L021 (* Second STXR cannot succeeed *) { int x=1; 0:X0=x; } P0 ; MOV W3,#2 ; MOV W5,#3 ; LDXR W1,[X0] ; STXR W4,W3,[X0] ; STXR W6,W5,[X0] ; ~exists 0:X4=1 /\ 0:X6=0 /\ x=3 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L021.litmus.expected000066400000000000000000000003401475314470400265740ustar00rootroot00000000000000Test L021 Forbidden States 2 0:X4=0; 0:X6=1; [x]=2; 0:X4=1; 0:X6=1; [x]=1; Ok Witnesses Positive: 2 Negative: 0 Condition ~exists (0:X4=1 /\ 0:X6=0 /\ [x]=3) Observation L021 Never 0 2 Hash=7a4f826210407ee264f41a4a24ae888c herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L022.litmus000066400000000000000000000006041475314470400250000ustar00rootroot00000000000000AArch64 L022 (* Intra-thread subroutine calls *) { } P0 | P1 ; MOV W0,#4 | ADR X1,Ldec ; BL Linc | MOV W0,#4 ; BL Linc | BLR X1 ; B Lzero | BLR X1 ; Linc: | B Lone ; ADD W0,W0,#1 |Ldec: ; RET | SUB W0,W0,#1 ; Lzero: | RET ; |Lone: ; forall 0:X0=6 /\ 1:X0=2 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L022.litmus.expected000066400000000000000000000002701475314470400265770ustar00rootroot00000000000000Test L022 Required States 1 0:X0=6; 1:X0=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=6 /\ 1:X0=2) Observation L022 Always 1 0 Hash=63978aad883ca6ecd3f15a9b500fce5f herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L023.litmus000066400000000000000000000006571475314470400250110ustar00rootroot00000000000000AArch64 L023 Stable=X9 (* Inter thread function calls *) { 0:X8=P1:Ldec; 1:X1=P0:Linc; } P0 | P1 ; MOV W9,#4 | MOV W9,#4 ; BLR X8 | BLR X1 ; BLR X8 | BLR X1 ; MOV W0,W9 | MOV W0,W9 ; B Lzero | B Lone ; Linc: |Ldec: ; ADD W9,W9,#1 | SUB W9,W9,#1 ; RET | RET ; Lzero: |Lone: ; forall 0:X0=2 /\ 1:X0=6 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L023.litmus.expected000066400000000000000000000002701475314470400266000ustar00rootroot00000000000000Test L023 Required States 1 0:X0=2; 1:X0=6; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=2 /\ 1:X0=6) Observation L023 Always 1 0 Hash=5c9551e3d56a302e74c189efe470b56c herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L024.litmus000066400000000000000000000007641475314470400250110ustar00rootroot00000000000000AArch64 L024 Stable=X9 (* Subroutine calls. Addresses as initial values *) { 0:X1=P0:Linc; 0:X3=P1:Ldec; 1:X1=P0:Linc; 1:X3=P1:Ldec; } P0 | P1 ; MOV W9,#4 | MOV W9,#4 ; BLR X1 | BLR X3 ; BLR X3 | BLR X1 ; BL Linc | BL Ldec ; B Lzero | B Lone ; Linc: |Ldec: ; ADD W9,W9,#1 | SUB W9,W9,#1 ; RET | RET ; Lzero: |Lone: ; MOV W0,W9 | MOV W0,W9 ; forall 0:X0=5 /\ 1:X0=3 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L024.litmus.expected000066400000000000000000000002701475314470400266010ustar00rootroot00000000000000Test L024 Required States 1 0:X0=5; 1:X0=3; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=5 /\ 1:X0=3) Observation L024 Always 1 0 Hash=e97b06e71c17210228fa37ec576438a1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L025.litmus000066400000000000000000000006041475314470400250030ustar00rootroot00000000000000AArch64 L025 Stable=X8,X9 { 0:X1=P1:L1; 1:X1=P0:L0; } P0 | P1 ; ADR X8,Ret0 | ADR X8,Ret1 ; MOV W9,#1 | MOV W9,#2 ; BR X1 | BR X1 ; Ret0: |Ret1: ; ADR X8,Out0 | ADR X8,Out1 ; L0: |L1: ; ADD W9,W9,#1 | ADD W9,W9,#2 ; BR X8 | BR X8 ; Out0: |Out1: ; forall 0:X9=4 /\ 1:X9=5herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L025.litmus.expected000066400000000000000000000002701475314470400266020ustar00rootroot00000000000000Test L025 Required States 1 0:X9=4; 1:X9=5; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X9=4 /\ 1:X9=5) Observation L025 Always 1 0 Hash=f7fcb4a949f25b60342d28cd60d4b4ad herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L026.litmus000066400000000000000000000003621475314470400250050ustar00rootroot00000000000000AArch64 L026 { 0:X1=x; 0:X3=y; 1:X1=x; 1:X3=y; } P0 | P1 ; MOV W0,#1 | LDR W0,[X3] ; STR W0,[X1] | CBZ W0,Lout ; DMB ST | LDR W2,[X1] ; STR W0,[X3] |Lout: ; exists 1:X0=1 /\ 1:X2=0 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L026.litmus.expected000066400000000000000000000003321475314470400266020ustar00rootroot00000000000000Test L026 Allowed States 3 1:X0=0; 1:X2=0; 1:X0=1; 1:X2=0; 1:X0=1; 1:X2=1; Ok Witnesses Positive: 1 Negative: 2 Condition exists (1:X0=1 /\ 1:X2=0) Observation L026 Sometimes 1 2 Hash=acd89e5742726dac250bdb0839c7d013 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L027.litmus000066400000000000000000000004041475314470400250030ustar00rootroot00000000000000AArch64 L027 { 0:X1=x; 0:X3=y; 1:X1=x; 1:X3=y; } P0 | P1 ; MOV W0,#1 | LDR W0,[X3] ; STR W0,[X1] | CBZ W0,Lout ; DMB ST | ISB ; STR W0,[X3] | LDR W2,[X1] ; |Lout: ; ~exists 1:X0=1 /\ 1:X2=0 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L027.litmus.expected000066400000000000000000000003111475314470400266000ustar00rootroot00000000000000Test L027 Forbidden States 2 1:X0=0; 1:X2=0; 1:X0=1; 1:X2=1; Ok Witnesses Positive: 2 Negative: 0 Condition ~exists (1:X0=1 /\ 1:X2=0) Observation L027 Never 0 2 Hash=db7dfd01d68a001374c2ab0b97fa30c4 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L028.litmus000066400000000000000000000004521475314470400250070ustar00rootroot00000000000000AArch64 L028 { (* Backward conditional branch on concrete value -> Complete loop unrolling for a cheap price. Good behaviour, to be kept as much as possible. *) } P0 ; MOV W0,#10 ; MOV W1,#0 ; L0: ; ADD W1,W1,#1 ; SUB W0,W0,#1 ; CBNZ W0,L0 ; forall 0:X1=10 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L028.litmus.expected000066400000000000000000000002501475314470400266030ustar00rootroot00000000000000Test L028 Required States 1 0:X1=10; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=10) Observation L028 Always 1 0 Hash=d9cf89f288c06952427657d9d317a82c herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L029.litmus000066400000000000000000000004421475314470400250070ustar00rootroot00000000000000AArch64 L029 (* Forward conditional branch on concrete values -> loop unrolling pruned. Overcome in future versions? *) { } P0 ; MOV W0,#10 ; MOV W1,#0 ; L1: ; ADD W1,W1,#1 ; SUB W0,W0,#1 ; CBZ W0,L0 ; B L1 ; L0: ; forall 0:X1=10 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L029.litmus.expected000066400000000000000000000002431475314470400266060ustar00rootroot00000000000000Test L029 Required States 0 Loop Ok Witnesses Positive: 0 Negative: 0 Condition forall (0:X1=10) Observation L029 Never 0 0 Hash=5ba53fe7075f2d05726628639d20b12f herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L029.litmus.expected-warn000066400000000000000000000001761475314470400275600ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64/L029.litmus": unrolling limit exceeded at L1, legal outcomes may be missing. herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L030.litmus000066400000000000000000000002721475314470400250000ustar00rootroot00000000000000AArch64 L030 { uint64_t t[2]; 0:X0=t; uint64_t 0:X3; uint64_t 0:X4; } P0 ; MOV X1,#1 ; MOV X2,#2 ; STP X1,X2,[X0] ; LDP X3,X4,[X0] ; forall 0:X3=1 /\ 0:X4=2; herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L030.litmus.expected000066400000000000000000000002701475314470400265760ustar00rootroot00000000000000Test L030 Required States 1 0:X3=1; 0:X4=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=1 /\ 0:X4=2) Observation L030 Always 1 0 Hash=f16872642c4227472a100d48ba699aaf herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L031.litmus000066400000000000000000000007341475314470400250040ustar00rootroot00000000000000AArch64 L031 { uint64_t t[2] ; 0:X2=t; 1:X2=t; uint64_t 0:X3; uint64_t 0:X4; uint64_t 1:X3; uint64_t 1:X4; } P0 | P1 ; MOV X0,#1 | MOV X0,#3 ; MOV X1,#2 | MOV X1,#4 ; LDXP X3,X4,[X2] | LDXP X3,X4,[X2] ; STXP W9,X0,X1,[X2] | STXP W9,X0,X1,[X2] ; forall (0:X9=0 /\ 1:X9=0) => ((1:X3=0 /\ 1:X4=0 /\ 0:X3=3 /\ 0:X4=4 /\ t[0]=1 /\ t[1]=2) \/ (1:X3=1 /\ 1:X4=2 /\ 0:X3=0 /\ 0:X4=0 /\ t[0]=3 /\ t[1]=4)) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L031.litmus.expected000066400000000000000000000013441475314470400266020ustar00rootroot00000000000000Test L031 Required States 7 0:X3=0; 0:X4=0; 0:X9=0; 1:X3=0; 1:X4=0; 1:X9=1; t[0]=1; t[1]=2; 0:X3=0; 0:X4=0; 0:X9=0; 1:X3=1; 1:X4=2; 1:X9=0; t[0]=3; t[1]=4; 0:X3=0; 0:X4=0; 0:X9=0; 1:X3=1; 1:X4=2; 1:X9=1; t[0]=1; t[1]=2; 0:X3=0; 0:X4=0; 0:X9=1; 1:X3=0; 1:X4=0; 1:X9=0; t[0]=3; t[1]=4; 0:X3=0; 0:X4=0; 0:X9=1; 1:X3=0; 1:X4=0; 1:X9=1; t[0]=0; t[1]=0; 0:X3=3; 0:X4=4; 0:X9=0; 1:X3=0; 1:X4=0; 1:X9=0; t[0]=1; t[1]=2; 0:X3=3; 0:X4=4; 0:X9=1; 1:X3=0; 1:X4=0; 1:X9=0; t[0]=3; t[1]=4; Ok Witnesses Positive: 7 Negative: 0 Condition forall ((0:X9=0 /\ 1:X9=0) => (1:X3=0 /\ 1:X4=0 /\ 0:X3=3 /\ 0:X4=4 /\ t[0]=1 /\ t[1]=2 \/ 1:X3=1 /\ 1:X4=2 /\ 0:X3=0 /\ 0:X4=0 /\ t[0]=3 /\ t[1]=4)) Observation L031 Always 7 0 Hash=b0e8865c54ba09fa14e60e342923db95 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L032.litmus000066400000000000000000000010321475314470400247750ustar00rootroot00000000000000AArch64 MP+STLXP+LDAXP { uint64_t x[2] ; uint64_t y[2] ; 0:X0=x; 0:X6=y; 1:X0=x; 1:X6=y; uint64_t 1:X1; uint64_t 1:X2; uint64_t 1:X3; uint64_t 1:X4; } P0 | P1 ; MOV X1,#1 | LDAXP X1,X2,[X6] ; MOV X2,#2 | STXP W9,X1,X2,[X6] ; STP X1,X2,[X0] | LDP X3,X4,[X0] ; MOV X5,#1 | ; LDXP X2,X3,[X6] | ; STLXP W9,X5,X5,[X6] | ; locations [1:X9;] exists (0:X9=0 /\ 1:X1=1 /\ 1:X2=1 /\ not (1:X3=1 /\ 1:X4=2))herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L032.litmus.expected000066400000000000000000000021011475314470400265730ustar00rootroot00000000000000Test MP+STLXP+LDAXP Allowed States 18 0:X9=0; 1:X1=0; 1:X2=0; 1:X3=0; 1:X4=0; 1:X9=0; 0:X9=0; 1:X1=0; 1:X2=0; 1:X3=0; 1:X4=0; 1:X9=1; 0:X9=0; 1:X1=0; 1:X2=0; 1:X3=0; 1:X4=2; 1:X9=0; 0:X9=0; 1:X1=0; 1:X2=0; 1:X3=0; 1:X4=2; 1:X9=1; 0:X9=0; 1:X1=0; 1:X2=0; 1:X3=1; 1:X4=0; 1:X9=0; 0:X9=0; 1:X1=0; 1:X2=0; 1:X3=1; 1:X4=0; 1:X9=1; 0:X9=0; 1:X1=0; 1:X2=0; 1:X3=1; 1:X4=2; 1:X9=0; 0:X9=0; 1:X1=0; 1:X2=0; 1:X3=1; 1:X4=2; 1:X9=1; 0:X9=0; 1:X1=1; 1:X2=1; 1:X3=1; 1:X4=2; 1:X9=0; 0:X9=0; 1:X1=1; 1:X2=1; 1:X3=1; 1:X4=2; 1:X9=1; 0:X9=1; 1:X1=0; 1:X2=0; 1:X3=0; 1:X4=0; 1:X9=0; 0:X9=1; 1:X1=0; 1:X2=0; 1:X3=0; 1:X4=0; 1:X9=1; 0:X9=1; 1:X1=0; 1:X2=0; 1:X3=0; 1:X4=2; 1:X9=0; 0:X9=1; 1:X1=0; 1:X2=0; 1:X3=0; 1:X4=2; 1:X9=1; 0:X9=1; 1:X1=0; 1:X2=0; 1:X3=1; 1:X4=0; 1:X9=0; 0:X9=1; 1:X1=0; 1:X2=0; 1:X3=1; 1:X4=0; 1:X9=1; 0:X9=1; 1:X1=0; 1:X2=0; 1:X3=1; 1:X4=2; 1:X9=0; 0:X9=1; 1:X1=0; 1:X2=0; 1:X3=1; 1:X4=2; 1:X9=1; No Witnesses Positive: 0 Negative: 22 Condition exists (0:X9=0 /\ 1:X1=1 /\ 1:X2=1 /\ not (1:X3=1 /\ 1:X4=2)) Observation MP+STLXP+LDAXP Never 0 22 Hash=cab4ae4b516254f733539ff24bc92380 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L033.litmus000066400000000000000000000002121475314470400247750ustar00rootroot00000000000000AArch64 L033 { int t[2] = {-1,-2}; 0:X2=t; int64_t 0:X0; int64_t 0:X1; } P0 ; LDPSW X0,X1,[X2] ; forall (0:X0=-1 /\ 0:X1=-2)herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L033.litmus.expected000066400000000000000000000002741475314470400266050ustar00rootroot00000000000000Test L033 Required States 1 0:X0=-1; 0:X1=-2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=-1 /\ 0:X1=-2) Observation L033 Always 1 0 Hash=3965f0341290b70d2cf947b46046dd57 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L034.litmus000066400000000000000000000002141475314470400250000ustar00rootroot00000000000000AArch64 L034 { int64_t t[2] = {-1,-2}; 0:X2=t; int64_t 0:X0; int64_t 0:X1; } P0 ; LDP X0,X1,[X2] ; forall (0:X0=-1 /\ 0:X1=-2)herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L034.litmus.expected000066400000000000000000000002741475314470400266060ustar00rootroot00000000000000Test L034 Required States 1 0:X0=-1; 0:X1=-2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=-1 /\ 0:X1=-2) Observation L034 Always 1 0 Hash=36b5e9a6b6768daa952dbf3142b17072 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L035.litmus000066400000000000000000000005731475314470400250110ustar00rootroot00000000000000AArch64 L035 { 0:X1=x; 0:X3=y; 1:X0=y; 1:X3=x; 1:X4=z; } P0 | P1 ; MOV W0,#2 | LDR W1,[X0] ; STR W0,[X1] | AND W2,W1,#2 ; DMB ST | ADD W2,W2,#1 ; MOV W2,#1 | SWP W2,W5,[X4] ; STR W2,[X3] | MOV W7,#1 ; | AND W6,W5,#2 ; | STR W7,[X3,W6,SXTW] ; exists (1:X1=1 /\ [x]=2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L035.litmus.expected000066400000000000000000000003451475314470400266060ustar00rootroot00000000000000Test L035 Allowed States 4 1:X1=0; [x]=1; 1:X1=0; [x]=2; 1:X1=1; [x]=1; 1:X1=1; [x]=2; Ok Witnesses Positive: 1 Negative: 3 Condition exists (1:X1=1 /\ [x]=2) Observation L035 Sometimes 1 3 Hash=8975a8afb190cd7edcfaa831305de569 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L036.litmus000066400000000000000000000005361475314470400250110ustar00rootroot00000000000000AArch64 L036 { 0:X1=x; 0:X3=y; 1:X0=y; 1:X3=x; 1:X4=z; } P0 | P1 ; MOV W0,#1 | LDR W1,[X0] ; STR W0,[X1] | AND W2,W1,#2 ; DMB ST | ADD W2,W2,#1 ; MOV W2,#1 | SWP W2,W5,[X4] ; STR W2,[X3] | CBNZ W5,L1 ; | LDR W7,[X3] ; |L1: ; exists (1:X1=1 /\ 1:X7=0 /\ 1:X5=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L036.litmus.expected000066400000000000000000000004241475314470400266050ustar00rootroot00000000000000Test L036 Allowed States 4 1:X1=0; 1:X5=0; 1:X7=0; 1:X1=0; 1:X5=0; 1:X7=1; 1:X1=1; 1:X5=0; 1:X7=0; 1:X1=1; 1:X5=0; 1:X7=1; Ok Witnesses Positive: 1 Negative: 3 Condition exists (1:X1=1 /\ 1:X7=0 /\ 1:X5=0) Observation L036 Sometimes 1 3 Hash=b9963926c60ad3d2fe7cd58b8527c456 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L037.litmus000066400000000000000000000005761475314470400250160ustar00rootroot00000000000000AArch64 L037 { 0:X1=x; 0:X3=y; 1:X0=y; 1:X3=x; 1:X4=z; } P0 | P1 ; MOV W0,#1 | LDR W1,[X0] ; STR W0,[X1] | AND W2,W1,#2 ; DMB ST | ADD W2,W2,#1 ; MOV W2,#1 | SWP W2,W5,[X4] ; STR W2,[X3] | CBNZ W5,L1 ; | ISB ; | LDR W7,[X3] ; |L1: ; exists (1:X1=1 /\ 1:X7=0 /\ 1:X5=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L037.litmus.expected000066400000000000000000000004241475314470400266060ustar00rootroot00000000000000Test L037 Allowed States 4 1:X1=0; 1:X5=0; 1:X7=0; 1:X1=0; 1:X5=0; 1:X7=1; 1:X1=1; 1:X5=0; 1:X7=0; 1:X1=1; 1:X5=0; 1:X7=1; Ok Witnesses Positive: 1 Negative: 3 Condition exists (1:X1=1 /\ 1:X7=0 /\ 1:X5=0) Observation L037 Sometimes 1 3 Hash=d36d2236545d29f0d2fd0edd2231a306 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L038.litmus000066400000000000000000000007031475314470400250070ustar00rootroot00000000000000AArch64 L038 (* To be compared with L035, SWP instruction as RMW on W2, stronger? *) { 0:X1=x; 0:X3=y; 1:X0=y; 1:X3=x; 1:X4=z; } P0 | P1 ; MOV W0,#2 | LDR W1,[X0] ; STR W0,[X1] | AND W2,W1,#2 ; DMB ST | ADD W2,W2,#1 ; MOV W2,#1 | SWP W2,W2,[X4] ; STR W2,[X3] | MOV W7,#1 ; | AND W6,W2,#2 ; | STR W7,[X3,W6,SXTW] ; exists (1:X1=1 /\ [x]=2) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L038.litmus.expected000066400000000000000000000003451475314470400266110ustar00rootroot00000000000000Test L038 Allowed States 4 1:X1=0; [x]=1; 1:X1=0; [x]=2; 1:X1=1; [x]=1; 1:X1=1; [x]=2; Ok Witnesses Positive: 1 Negative: 3 Condition exists (1:X1=1 /\ [x]=2) Observation L038 Sometimes 1 3 Hash=c3cc8c9b6c039efe45c1cf847ca493b5 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L039.litmus000066400000000000000000000006201475314470400250060ustar00rootroot00000000000000AArch64 L039 (* Cf. L036, here SWP operates on one register *) { 0:X1=x; 0:X3=y; 1:X0=y; 1:X3=x; 1:X4=z; } P0 | P1 ; MOV W0,#1 | LDR W1,[X0] ; STR W0,[X1] | AND W2,W1,#2 ; DMB ST | ADD W2,W2,#1 ; MOV W2,#1 | SWP W2,W2,[X4] ; STR W2,[X3] | CBNZ W2,L1 ; | LDR W7,[X3] ; |L1: ; exists (1:X1=1 /\ 1:X7=0 /\ 1:X2=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L039.litmus.expected000066400000000000000000000004241475314470400266100ustar00rootroot00000000000000Test L039 Allowed States 4 1:X1=0; 1:X2=0; 1:X7=0; 1:X1=0; 1:X2=0; 1:X7=1; 1:X1=1; 1:X2=0; 1:X7=0; 1:X1=1; 1:X2=0; 1:X7=1; Ok Witnesses Positive: 1 Negative: 3 Condition exists (1:X1=1 /\ 1:X7=0 /\ 1:X2=0) Observation L039 Sometimes 1 3 Hash=17499e4f8e6380837713b690253c707a herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L040.litmus000066400000000000000000000006731475314470400250060ustar00rootroot00000000000000AArch64 L040 (* Cf. L037, here SWP operates on one register, stronger? *) { 0:X1=x; 0:X3=y; 1:X0=y; 1:X3=x; 1:X4=z; } P0 | P1 ; MOV W0,#1 | LDR W1,[X0] ; STR W0,[X1] | AND W2,W1,#2 ; DMB ST | ADD W2,W2,#1 ; MOV W2,#1 | SWP W2,W2,[X4] ; STR W2,[X3] | CBNZ W2,L1 ; | ISB ; | LDR W7,[X3] ; |L1: ; exists (1:X1=1 /\ 1:X7=0 /\ 1:X2=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L040.litmus.expected000066400000000000000000000004241475314470400266000ustar00rootroot00000000000000Test L040 Allowed States 4 1:X1=0; 1:X2=0; 1:X7=0; 1:X1=0; 1:X2=0; 1:X7=1; 1:X1=1; 1:X2=0; 1:X7=0; 1:X1=1; 1:X2=0; 1:X7=1; Ok Witnesses Positive: 1 Negative: 3 Condition exists (1:X1=1 /\ 1:X7=0 /\ 1:X2=0) Observation L040 Sometimes 1 3 Hash=dd881259f50938615cb6e1bbd5a58350 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L041.litmus000066400000000000000000000003751475314470400250060ustar00rootroot00000000000000AArch64 L041 Orig=DSB.STdWR Fre DSB.STdWR Fre { 0:X1=x; 0:X2=y; 1:X1=y; 1:X2=x; } P0 | P1 ; MOV W0,#1 | MOV W0,#1 ; STR W0,[X1] | STR W0,[X1] ; DSB ST | DSB ST ; LDR W3,[X2] | LDR W3,[X2] ; exists (0:X3=0 /\ 1:X3=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L041.litmus.expected000066400000000000000000000003261475314470400266020ustar00rootroot00000000000000Test L041 Allowed States 3 0:X3=0; 1:X3=1; 0:X3=1; 1:X3=0; 0:X3=1; 1:X3=1; No Witnesses Positive: 0 Negative: 3 Condition exists (0:X3=0 /\ 1:X3=0) Observation L041 Never 0 3 Hash=b3943926fd253c62a988c8b6a25ddfdd herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L042.litmus000066400000000000000000000006051475314470400250030ustar00rootroot00000000000000AArch64 L042 Orig=PodWWPL RfeLP Amo.StAdd PodWR DpCtrlIsbdR Fre { 0:X1=x; 0:X3=y; 1:X0=y; 1:X2=z; 1:X4=x; } P0 | P1 ; MOV W0,#1 | MOV W1,#2 ; STR W0,[X1] | STADD W1,[X0] ; MOV W2,#1 | LDR W3,[X2] ; STLR W2,[X3] | CBNZ W3,LC00 ; | LC00: ; | ISB ; | LDR W5,[X4] ; exists ([y]=3 /\ 1:X5=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L042.litmus.expected000066400000000000000000000003451475314470400266040ustar00rootroot00000000000000Test L042 Allowed States 4 1:X5=0; [y]=1; 1:X5=0; [y]=3; 1:X5=1; [y]=1; 1:X5=1; [y]=3; Ok Witnesses Positive: 1 Negative: 3 Condition exists ([y]=3 /\ 1:X5=0) Observation L042 Sometimes 1 3 Hash=77ba8b7ac2e6669181b14fb41b16d743 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L043.litmus000066400000000000000000000006251475314470400250060ustar00rootroot00000000000000AArch64 L043 Orig=PodWWPL RfeLP Amo.Swp PodWR DpCtrlIsbdR Fre { 0:X1=x; 0:X3=y; 1:X0=y; 1:X3=z; 1:X5=x; } P0 | P1 ; MOV W0,#1 | MOV W2,#2 ; STR W0,[X1] | SWP W2,W1,[X0] ; MOV W2,#1 | LDR W4,[X3] ; STLR W2,[X3] | CBNZ W4,LC00 ; | LC00: ; | ISB ; | LDR W6,[X5] ; exists ([y]=2 /\ 1:X1=1 /\ 1:X6=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L043.litmus.expected000066400000000000000000000004171475314470400266050ustar00rootroot00000000000000Test L043 Allowed States 4 1:X1=0; 1:X6=0; [y]=1; 1:X1=0; 1:X6=1; [y]=1; 1:X1=1; 1:X6=0; [y]=2; 1:X1=1; 1:X6=1; [y]=2; Ok Witnesses Positive: 1 Negative: 3 Condition exists ([y]=2 /\ 1:X1=1 /\ 1:X6=0) Observation L043 Sometimes 1 3 Hash=9359b760dad505f9b96c16d567fce7b5 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L044.litmus000066400000000000000000000004571475314470400250120ustar00rootroot00000000000000AArch64 L044 Orig=DMB.SYdRW Rfe Amo.StAdd PodWR Amo.LdAdd Rfe { 0:X0=x; 0:X3=y; 1:X0=y; 1:X2=x; } P0 | P1 ; LDR W1,[X0] | MOV W1,#2 ; DMB SY | STADD W1,[X0] ; MOV W2,#1 | MOV W4,#1 ; STR W2,[X3] | LDADD W4,W3,[X2] ; exists ([y]=3 /\ 0:X1=1 /\ 1:X3=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L044.litmus.expected000066400000000000000000000004171475314470400266060ustar00rootroot00000000000000Test L044 Allowed States 4 0:X1=0; 1:X3=0; [y]=1; 0:X1=0; 1:X3=0; [y]=3; 0:X1=1; 1:X3=0; [y]=1; 0:X1=1; 1:X3=0; [y]=3; Ok Witnesses Positive: 1 Negative: 3 Condition exists ([y]=3 /\ 0:X1=1 /\ 1:X3=0) Observation L044 Sometimes 1 3 Hash=9ca718f5ba365c0e44825e7454237415 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L045.litmus000066400000000000000000000004671475314470400250140ustar00rootroot00000000000000AArch64 L045 Orig=DMB.SYdRW Rfe Amo.Swp PodWR Amo.LdAdd Rfe { 0:X0=x; 0:X3=y; 1:X0=y; 1:X3=x; } P0 | P1 ; LDR W1,[X0] | MOV W2,#2 ; DMB SY | SWP W2,W1,[X0] ; MOV W2,#1 | MOV W5,#1 ; STR W2,[X3] | LDADD W5,W4,[X3] ; exists ([y]=2 /\ 0:X1=1 /\ 1:X1=1 /\ 1:X4=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L045.litmus.expected000066400000000000000000000004711475314470400266070ustar00rootroot00000000000000Test L045 Allowed States 4 0:X1=0; 1:X1=0; 1:X4=0; [y]=1; 0:X1=0; 1:X1=1; 1:X4=0; [y]=2; 0:X1=1; 1:X1=0; 1:X4=0; [y]=1; 0:X1=1; 1:X1=1; 1:X4=0; [y]=2; Ok Witnesses Positive: 1 Negative: 3 Condition exists ([y]=2 /\ 0:X1=1 /\ 1:X1=1 /\ 1:X4=0) Observation L045 Sometimes 1 3 Hash=b554dbbcf6abfbb3161a8c7ca301e99b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L046.litmus000066400000000000000000000001401475314470400250010ustar00rootroot00000000000000AArch64 L046 { } P0 ; B .+8 ; MOV W0,#1 ; ADD W0,W0,#1 ; forall 0:X0=1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L046.litmus.expected000066400000000000000000000002461475314470400266100ustar00rootroot00000000000000Test L046 Required States 1 0:X0=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=1) Observation L046 Always 1 0 Hash=9e1b5c3876ae9522d0506d3041802ec8 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L047.litmus000066400000000000000000000002561475314470400250120ustar00rootroot00000000000000AArch64 L047 (* PC relative jump - calculates -8 bytes away from instr*) { 0:X0=2; } P0 ; ADD W1,W1,#2 ; SUBS W0,W0,#1 ; CBNZ W0,.-8 ; forall (0:X1=4) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L047.litmus.expected000066400000000000000000000002461475314470400266110ustar00rootroot00000000000000Test L047 Required States 1 0:X1=4; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=4) Observation L047 Always 1 0 Hash=892006658248b757256dcb5df65edcd0 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L048.litmus000066400000000000000000000001611475314470400250060ustar00rootroot00000000000000AArch64 L048 { 0:X0=2; } P0 ; ADD W1,W1,#2 ; SUBS W0,W0,#1 ; B.GT .-8 ; forall (0:X1=4) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L048.litmus.expected000066400000000000000000000002461475314470400266120ustar00rootroot00000000000000Test L048 Required States 1 0:X1=4; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=4) Observation L048 Always 1 0 Hash=3c033719fe90cd6141e3076e3a2db40b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L049.litmus000066400000000000000000000002111475314470400250030ustar00rootroot00000000000000AArch64 L049 { 0:X0=instr:"B.EQ .+8"; 0:X2=NOP; } P0 ; CMP W0,W2 ; CSET W4,NE ; forall 0:X4=1 /\ not (0:X0=instr:"B.EQ .+4") herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L049.litmus.expected000066400000000000000000000003341475314470400266110ustar00rootroot00000000000000Test L049 Required States 1 0:X0=instr:"B.EQ .+8"; 0:X4=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X4=1 /\ not (0:X0=instr:"B.EQ .+4")) Observation L049 Always 1 0 Hash=041819817e6401b5ace371c8e0fe2e4c herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L050.litmus000066400000000000000000000003261475314470400250020ustar00rootroot00000000000000AArch64 L050 { 0:X0=instr:"B.EQ .+8"; ins_t 0:X2; } P0 ; L0: ; B .+4 ; ADR X1,L0 ; LDR W2,[X1] ; CMP W0,W2 ; CSET W4,NE ; locations [0:X2;] forall 0:X4=1 /\ 0:X0=instr:"B.EQ .+8" herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L050.litmus.expected000066400000000000000000000003521475314470400266010ustar00rootroot00000000000000Test L050 Required States 1 0:X0=instr:"B.EQ .+8"; 0:X2=instr:"B .+4"; 0:X4=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X4=1 /\ 0:X0=instr:"B.EQ .+8") Observation L050 Always 1 0 Hash=52b3f65c042163d21640e8f0faff1d38 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L051.litmus000066400000000000000000000004061475314470400250020ustar00rootroot00000000000000AArch64 N0 (* ADR instruction constant only *) { } P0 ; ADR X1,L0 ; BLR X1 ; BLR X1 ; LDR W2,[X1] ; B L1 ; L0: ; ADD W0,W0,#1 ; RET ; L1: ; locations [0:X2 ins_t;] forall (0:X0=2)herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L051.litmus.expected000066400000000000000000000002751475314470400266060ustar00rootroot00000000000000Test N0 Required States 1 0:X0=2; 0:X2=instr:"ADD W0,W0,#1"; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=2) Observation N0 Always 1 0 Hash=3f02cb0d49f28c18bd60c866e0675e78 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L052.litmus000066400000000000000000000001531475314470400250020ustar00rootroot00000000000000AArch64 L052 { 0:X0=x; int64_t 0:X1=4; } P0 ; ADD X0,X0,#4 ; SUB X0,X0,X1 ; forall 0:X0=x; herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L052.litmus.expected000066400000000000000000000002461475314470400266050ustar00rootroot00000000000000Test L052 Required States 1 0:X0=x; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=x) Observation L052 Always 1 0 Hash=2782f5bd314578ff31d813b7e6d7ae21 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L053.litmus000066400000000000000000000001531475314470400250030ustar00rootroot00000000000000AArch64 L053 { uint64_t 0:X0; } P0 ; CMP W1,#0 ; MRS X0,NZCV ; LSR X0,X0,28 ; forall 0:X0=6 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L053.litmus.expected000066400000000000000000000002461475314470400266060ustar00rootroot00000000000000Test L053 Required States 1 0:X0=6; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=6) Observation L053 Always 1 0 Hash=5a3bec73cfa34fff8da1035d9efa1ad8 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L054.litmus000066400000000000000000000004351475314470400250070ustar00rootroot00000000000000AArch64 L054 { uint32_t 0:X0=0xE; uint32_t 0:X1; uint32_t 0:X2; uint64_t 0:X3=0xE; uint64_t 0:X4; uint64_t 0:X5; } P0 ; UBFM W1,W0,#0,#2 ; SBFM W2,W1,#0,#2 ; UBFM X4,X3,#0,#2 ; SBFM X5,X4,#0,#2 ; forall 0:X1=0x6 /\ 0:X2=0xfffffffe /\ 0:X4=0x6 /\ 0:X5=0xfffffffffffffffe herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L054.litmus.expected000066400000000000000000000004021475314470400266010ustar00rootroot00000000000000Test L054 Required States 1 0:X1=6; 0:X2=4294967294; 0:X4=6; 0:X5=18446744073709551614; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=6 /\ 0:X2=4294967294 /\ 0:X4=6 /\ 0:X5=-2) Observation L054 Always 1 0 Hash=98590e7e429ae3daba24ca030cd1c0a9 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L055.litmus000066400000000000000000000004661475314470400250140ustar00rootroot00000000000000AArch64 L055 { uint32_t 0:X0=0xFE; uint32_t 0:X1; uint32_t 0:X2; uint64_t 0:X3=0xFE; uint64_t 0:X4; uint64_t 0:X5; } P0 ; UBFM W1,W0,#4,#2 ; SBFM W2,W0,#4,#2 ; UBFM X4,X3,#4,#2 ; SBFM X5,X3,#4,#2 ; forall 0:X1=0x60000000 /\ 0:X2=0xe0000000 /\ 0:X4=0x6000000000000000 /\ 0:X5=0xe000000000000000 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L055.litmus.expected000066400000000000000000000005121475314470400266040ustar00rootroot00000000000000Test L055 Required States 1 0:X1=1610612736; 0:X2=3758096384; 0:X4=6917529027641081856; 0:X5=16140901064495857664; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=1610612736 /\ 0:X2=3758096384 /\ 0:X4=6917529027641081856 /\ 0:X5=-2305843009213693952) Observation L055 Always 1 0 Hash=0699193d9991a22e6eb2cc2e0387c4b7 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L056.litmus000066400000000000000000000005331475314470400250100ustar00rootroot00000000000000AArch64 L056 Stable=X0,X1,X2,X3 { int x[2]; 0:X4=x; 1:X4=x; } P0 | P1 ; MOV W1,#1 | MOV W0,#0 ; STR W1,[X4] | MOV W1,#0 ; | MOV W2,#2 ; | MOV W3,#2 ; | CASP W0,W1,W2,W3,[X4] ; locations [1:X0;1:X1;] forall (x={1,0} \/ x={1,2}) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L056.litmus.expected000066400000000000000000000003341475314470400266070ustar00rootroot00000000000000Test L056 Required States 2 1:X0=0; 1:X1=0; x={1,2}; 1:X0=1; 1:X1=0; x={1,0}; Ok Witnesses Positive: 6 Negative: 0 Condition forall (x={1,0} \/ x={1,2}) Observation L056 Always 6 0 Hash=56239ea29c96ee505c91efa59ac63a18 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L057.litmus000066400000000000000000000006211475314470400250070ustar00rootroot00000000000000AArch64 L057 Stable=X0,X1,X2,X3 { int x[2]; 0:X4=x; 1:X4=x; } P0 | P1 ; MOV W1,#1 | MOV W0,#0 ; STR W1,[X4,#4] | MOV W1,#0 ; | MOV W2,#2 ; | MOV W3,#2 ; | CASP W0,W1,W2,W3,[X4] ; locations [1:X0;1:X1;] forall (x={0,1} \/ x={2,1}) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L057.litmus.expected000066400000000000000000000003341475314470400266100ustar00rootroot00000000000000Test L057 Required States 2 1:X0=0; 1:X1=0; x={2,1}; 1:X0=0; 1:X1=1; x={0,1}; Ok Witnesses Positive: 6 Negative: 0 Condition forall (x={0,1} \/ x={2,1}) Observation L057 Always 6 0 Hash=57ac32621316eec60874e7e2c863b043 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L058.litmus000066400000000000000000000006251475314470400250140ustar00rootroot00000000000000AArch64 L058 { int64_t a[2]; int64_t b[2]; 0:X0=a; 0:X1=b; 1:X1=a; 1:X0=b; } P0 | P1 ; MOV X2,#1 | MOV X2,#3 ; MOV X3,#2 | MOV X3,#4 ; STP X2,X3,[X0],#16 | STP X2,X3,[X0],#16 ; LDP X4,X5,[X1],#16 | LDP X4,X5,[X1],#16 ; STP X4,X5,[X0,#-16]! | STP X4,X5,[X0,#-16]! ; exists a={3,4} /\ b={1,2} /\ 0:X0=a /\ 1:X0=b herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L058.litmus.expected000066400000000000000000000026131475314470400266130ustar00rootroot00000000000000Test L058 Allowed States 36 0:X0=a; 1:X0=b; a={0,0}; b={0,0}; 0:X0=a; 1:X0=b; a={0,0}; b={0,2}; 0:X0=a; 1:X0=b; a={0,0}; b={1,0}; 0:X0=a; 1:X0=b; a={0,0}; b={1,2}; 0:X0=a; 1:X0=b; a={0,2}; b={0,2}; 0:X0=a; 1:X0=b; a={0,2}; b={1,2}; 0:X0=a; 1:X0=b; a={0,4}; b={0,0}; 0:X0=a; 1:X0=b; a={0,4}; b={0,2}; 0:X0=a; 1:X0=b; a={0,4}; b={0,4}; 0:X0=a; 1:X0=b; a={0,4}; b={1,0}; 0:X0=a; 1:X0=b; a={0,4}; b={1,2}; 0:X0=a; 1:X0=b; a={0,4}; b={1,4}; 0:X0=a; 1:X0=b; a={1,0}; b={1,0}; 0:X0=a; 1:X0=b; a={1,0}; b={1,2}; 0:X0=a; 1:X0=b; a={1,2}; b={1,2}; 0:X0=a; 1:X0=b; a={1,4}; b={1,0}; 0:X0=a; 1:X0=b; a={1,4}; b={1,2}; 0:X0=a; 1:X0=b; a={1,4}; b={1,4}; 0:X0=a; 1:X0=b; a={3,0}; b={0,0}; 0:X0=a; 1:X0=b; a={3,0}; b={0,2}; 0:X0=a; 1:X0=b; a={3,0}; b={1,0}; 0:X0=a; 1:X0=b; a={3,0}; b={1,2}; 0:X0=a; 1:X0=b; a={3,0}; b={3,0}; 0:X0=a; 1:X0=b; a={3,0}; b={3,2}; 0:X0=a; 1:X0=b; a={3,2}; b={0,2}; 0:X0=a; 1:X0=b; a={3,2}; b={1,2}; 0:X0=a; 1:X0=b; a={3,2}; b={3,2}; 0:X0=a; 1:X0=b; a={3,4}; b={0,0}; 0:X0=a; 1:X0=b; a={3,4}; b={0,2}; 0:X0=a; 1:X0=b; a={3,4}; b={0,4}; 0:X0=a; 1:X0=b; a={3,4}; b={1,0}; 0:X0=a; 1:X0=b; a={3,4}; b={1,2}; 0:X0=a; 1:X0=b; a={3,4}; b={1,4}; 0:X0=a; 1:X0=b; a={3,4}; b={3,0}; 0:X0=a; 1:X0=b; a={3,4}; b={3,2}; 0:X0=a; 1:X0=b; a={3,4}; b={3,4}; Ok Witnesses Positive: 1 Negative: 63 Condition exists (a={3,4} /\ b={1,2} /\ 0:X0=a /\ 1:X0=b) Observation L058 Sometimes 1 63 Hash=fa78a40e853b537558278f3fa2a34538 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L059.litmus000066400000000000000000000002671475314470400250170ustar00rootroot00000000000000AArch64 L059 (* branch to instruction address with __DYNAMIC section name *) { 0:X0 = 1; } P0 ; B __DYNAMIC ; ADD X0, X0, #1; __DYNAMIC: NOP ; forall (0:X0 = 1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L059.litmus.expected000066400000000000000000000002461475314470400266140ustar00rootroot00000000000000Test L059 Required States 1 0:X0=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=1) Observation L059 Always 1 0 Hash=2395520d6f37fe762fc77b0c7a639309 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L061.litmus000066400000000000000000000002561475314470400250060ustar00rootroot00000000000000AArch64 L061 (* branch to instruction address with .section name *) { 0:X0 = 1; } P0 ; B .text ; ADD W0, W0, #1; .text: NOP ; forall (0:X0 = 1) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L061.litmus.expected000066400000000000000000000002461475314470400266050ustar00rootroot00000000000000Test L061 Required States 1 0:X0=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X0=1) Observation L061 Always 1 0 Hash=1e56e7a378d422667a5081fc63e22f1e herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L062.litmus000066400000000000000000000007771475314470400250170ustar00rootroot00000000000000AArch64 L062 { ins_t 0:X1=instr:"B .+4"; ins_t 1:X1=instr:"B .+8"; ins_t 0:X2; ins_t 1:X2; ins_t 1:X3; 1:X0=P0:L0; } P0 | P1 ; ADR X0,L0 | LDR W2,[X0] ; LDR W2,[X0] | CMP W2,W1 ; L0: | CSEL W3,W2,W1,NE ; B L1 | ; L1: | ; CMP W2,W1 | ; CSINC W3,WZR,WZR,EQ | ; locations [0:X2;1:X1;] forall 0:X3=0 /\ 1:X3=instr:"B .+4"herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L062.litmus.expected000066400000000000000000000003701475314470400266040ustar00rootroot00000000000000Test L062 Required States 1 0:X2=instr:"B .+4"; 0:X3=0; 1:X1=instr:"B .+8"; 1:X3=instr:"B .+4"; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=0 /\ 1:X3=instr:"B .+4") Observation L062 Always 1 0 Hash=7ddb135d6424c1b26ac694459671ebb1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L080.litmus000066400000000000000000000010461475314470400250050ustar00rootroot00000000000000AArch64 L080 "PodWWPaNPaI RfePaIPaN PodRRPaNPaI FrePaIPaN" Generator=diyone7 (version 7.56+03) Prefetch=0:x=F,0:y=W,1:y=F,1:x=T Com=Rf Fr Orig=PodWWPaNPaI RfePaIPaN PodRRPaNPaI FrePaIPaN { int y[2]; int x[2]; 0:X0=x; 0:X3=y; 1:X0=y; 1:X3=x; } P0 | P1 ; MOV W1,#2 | LDNP W1,W2,[X0] ; SUB W2,W1,#1 | ADD W1,W1,W2 ; STNP W2,W1,[X0] | LDIAPP W4,W5,[X3] ; MOV W4,#2 | ADD W4,W4,W5 ; SUB W5,W4,#1 | ; STILP W5,W4,[X3] | ; exists (1:X1=3 /\ 1:X4=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L080.litmus.expected000066400000000000000000000006551475314470400266120ustar00rootroot00000000000000Test L080 Allowed States 16 1:X1=0; 1:X4=0; 1:X1=0; 1:X4=1; 1:X1=0; 1:X4=2; 1:X1=0; 1:X4=3; 1:X1=1; 1:X4=0; 1:X1=1; 1:X4=1; 1:X1=1; 1:X4=2; 1:X1=1; 1:X4=3; 1:X1=2; 1:X4=0; 1:X1=2; 1:X4=1; 1:X1=2; 1:X4=2; 1:X1=2; 1:X4=3; 1:X1=3; 1:X4=0; 1:X1=3; 1:X4=1; 1:X1=3; 1:X4=2; 1:X1=3; 1:X4=3; Ok Witnesses Positive: 1 Negative: 15 Condition exists (1:X1=3 /\ 1:X4=0) Observation L080 Sometimes 1 15 Hash=51034c9713c5a6104731820626cf8099 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L081.litmus000066400000000000000000000010461475314470400250060ustar00rootroot00000000000000AArch64 L081 "PodWWPaNPaI RfePaIPaI PodRRPaIPaN FrePaNPaN" Generator=diyone7 (version 7.56+03) Prefetch=0:x=F,0:y=W,1:y=F,1:x=T Com=Rf Fr Orig=PodWWPaNPaI RfePaIPaI PodRRPaIPaN FrePaNPaN { int y[2]; int x[2]; 0:X0=x; 0:X3=y; 1:X0=y; 1:X3=x; } P0 | P1 ; MOV W1,#2 | LDIAPP W1,W2,[X0] ; SUB W2,W1,#1 | ADD W1,W1,W2 ; STNP W2,W1,[X0] | LDNP W4,W5,[X3] ; MOV W4,#2 | ADD W4,W4,W5 ; SUB W5,W4,#1 | ; STILP W5,W4,[X3] | ; exists (1:X1=3 /\ 1:X4=0) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L081.litmus.expected000066400000000000000000000004261475314470400266070ustar00rootroot00000000000000Test L081 Allowed States 7 1:X1=0; 1:X4=0; 1:X1=0; 1:X4=1; 1:X1=0; 1:X4=2; 1:X1=0; 1:X4=3; 1:X1=1; 1:X4=3; 1:X1=2; 1:X4=3; 1:X1=3; 1:X4=3; No Witnesses Positive: 0 Negative: 7 Condition exists (1:X1=3 /\ 1:X4=0) Observation L081 Never 0 7 Hash=ee7285dcf4dfd75a44762910de867369 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L082.litmus000066400000000000000000000005211475314470400250040ustar00rootroot00000000000000AArch64 L082 { int64_t x[2]; 0:X2=x; 1:X2=x; int64_t 1:X0; int64_t 1:X1; } P0 | P1 ; MOV X0,#1 | LDR X1,[X2,#8] ; MOV X1,#2 | DMB LD ; STILP X0,X1,[X2] | LDR X0,[X2] ; ~exists 1:X1=2 /\ 1:X0=0 (* Notice: forbiding this test, as it probabbly should be, requires a model change *) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L082.litmus.expected000066400000000000000000000003311475314470400266030ustar00rootroot00000000000000Test L082 Forbidden States 3 1:X0=0; 1:X1=0; 1:X0=1; 1:X1=0; 1:X0=1; 1:X1=2; Ok Witnesses Positive: 3 Negative: 0 Condition ~exists (1:X1=2 /\ 1:X0=0) Observation L082 Never 0 3 Hash=c5ef8bbff6896ff12c1dbbddb79110fd herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L083.litmus000066400000000000000000000006251475314470400250120ustar00rootroot00000000000000AArch64 L083 { int64_t x[2]; 0:X2=x; 1:X2=x; int64_t 1:X0; int64_t 1:X1; } P0 | P1 ; ADD X2,X2,#16 | LDR X1,[X2] ; MOV X0,#1 | DMB LD ; MOV X1,#2 | LDR X0,[X2,#8] ; STILP X0,X1,[X2,#-16]! | ; ~exists 1:X1=1 /\ 1:X0=0 (* Notice: forbiding this test, as it probabbly should be, requires a model change *) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L083.litmus.expected000066400000000000000000000003311475314470400266040ustar00rootroot00000000000000Test L083 Forbidden States 3 1:X0=0; 1:X1=0; 1:X0=2; 1:X1=0; 1:X0=2; 1:X1=1; Ok Witnesses Positive: 3 Negative: 0 Condition ~exists (1:X1=1 /\ 1:X0=0) Observation L083 Never 0 3 Hash=5372b405bdbf48d5292138b7cc35a730 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L084.litmus000066400000000000000000000006001475314470400250040ustar00rootroot00000000000000AArch64 L084 { int64_t x[2]; 0:X2=x; 1:X2=x; int64_t 1:X0; int64_t 1:X1; } P0 | P1 ; MOV X0,#1 | LDIAPP X0,X1,[X2] ; STR X0,[X2,#8] | ; MOV X1,#1 | ; STLR X1,[X2] | ; ~exists 1:X0=1 /\ 1:X1=0 (* Notice: forbiding this test, as it probabbly should be, requires a model change *) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L084.litmus.expected000066400000000000000000000003311475314470400266050ustar00rootroot00000000000000Test L084 Forbidden States 3 1:X0=0; 1:X1=0; 1:X0=0; 1:X1=1; 1:X0=1; 1:X1=1; Ok Witnesses Positive: 3 Negative: 0 Condition ~exists (1:X0=1 /\ 1:X1=0) Observation L084 Never 0 3 Hash=99bc791408474ea68745a344590291c2 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L085.litmus000066400000000000000000000001711475314470400250100ustar00rootroot00000000000000AArch64 L085 { ins_t 0:X0; } P0 ; L0: ; ADR X1,.+0 ; LDR W0,[X1] ; forall 0:X0=instr:"ADR X1,.+0" herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L085.litmus.expected-failure000066400000000000000000000001761475314470400302420ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/AArch64/L085.litmus": Replace offset by label in instruction ADR X1,.+0 (User error) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L086.litmus000066400000000000000000000003031475314470400250060ustar00rootroot00000000000000AArch64 L086 (* Allocate register X1 to X1 *) Stable=X1 { 0:X0=instr:"ADR X1,.+0"; } P0 ; L0: ; ADR X1,L0 ; LDR W2,[X1] ; CMP W0,W2 ; CSET W3,EQ ; forall 0:X3=1 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L086.litmus.expected000066400000000000000000000002461475314470400266140ustar00rootroot00000000000000Test L086 Required States 1 0:X3=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=1) Observation L086 Always 1 0 Hash=5e2daad1656881d22f1562e268ebe492 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L087.litmus000066400000000000000000000003361475314470400250150ustar00rootroot00000000000000AArch64 L087 { int t[2]={1,2}; 0:X0=t; } P0 ; MOV W1,#3 ; STR W1,[X0,#4]! ; LDR W2,[X0],#-4 ; ADD W1,W1,#1 ; STR W1,[X0],#4 ; LDR W3,[X0,#-4]! ; forall 0:X2=3 /\ 0:X3=4 /\ 0:X0=therd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L087.litmus.expected000066400000000000000000000003121475314470400266070ustar00rootroot00000000000000Test L087 Required States 1 0:X0=t; 0:X2=3; 0:X3=4; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=3 /\ 0:X3=4 /\ 0:X0=t) Observation L087 Always 1 0 Hash=f5225c8ddb9573d011287cb490e4d862 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L088.litmus000066400000000000000000000001771475314470400250210ustar00rootroot00000000000000AArch64 L088 { int64_t 0:X0=0; int64_t 0:X1=2; int 0:X2=255; } P0 ; ADD X0,X1,W2,SXTB 2 ; locations [0:X0;] herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L088.litmus.expected000066400000000000000000000002451475314470400266150ustar00rootroot00000000000000Test L088 Required States 1 0:X0=-2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (true) Observation L088 Always 1 0 Hash=4753bb3ba2b4f194e0768680e7bf13b4 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L089.litmus000066400000000000000000000007201475314470400250140ustar00rootroot00000000000000AArch64 L089 { 0:X1=255; uint64_t 0:X0=0xffff; uint64_t 0:X6; uint64_t 0:X7; uint64_t 0:X8; uint64_t 0:X9; } P0 ; ORR W2,WZR,W1,LSL 4 ; ORR W3,WZR,W1,LSR 4 ; ORR W4,WZR,W1,ROR 4 ; ORR W5,WZR,W4,ASR 4 ; ORR X6,XZR,X0,LSL 8 ; ORR X7,XZR,X0,LSR 8 ; ORR X8,XZR,X0,ROR 8 ; ORR X9,XZR,X8,ASR 8 ; forall 0:X2=0xff0 /\ 0:X3=0xf /\ 0:X4=0xf000000f /\ 0:X5=0xff000000 /\ 0:X6=0xffff00 /\ 0:X7=0xff /\ 0:X8=0xff000000000000ff /\ 0:X9=0xffff000000000000 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L089.litmus.expected000066400000000000000000000006471475314470400266240ustar00rootroot00000000000000Test L089 Required States 1 0:X2=4080; 0:X3=15; 0:X4=-268435441; 0:X5=-16777216; 0:X6=16776960; 0:X7=255; 0:X8=18374686479671623935; 0:X9=18446462598732840960; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=4080 /\ 0:X3=15 /\ 0:X4=4026531855 /\ 0:X5=4278190080 /\ 0:X6=16776960 /\ 0:X7=255 /\ 0:X8=-72057594037927681 /\ 0:X9=-281474976710656) Observation L089 Always 1 0 Hash=cdab64d166b5f8ceeb8c845f6c747e16 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L090.litmus000066400000000000000000000001251475314470400250030ustar00rootroot00000000000000AArch64 L090 { uint64_t 0:X0=42; } P0; ADDS X0, X0, #1, LSL #12; exists 0:X0=4138 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L090.litmus.expected000066400000000000000000000002531475314470400266050ustar00rootroot00000000000000Test L090 Allowed States 1 0:X0=4138; Ok Witnesses Positive: 1 Negative: 0 Condition exists (0:X0=4138) Observation L090 Always 1 0 Hash=2f51de3dcd647233f77732b51012a4ec herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L091.litmus000066400000000000000000000002211475314470400250010ustar00rootroot00000000000000AArch64 L091 { 0:X1=0x80000000;} P0 ; ABS W2,W1 ; MOV W3,#1 ; SUB W3,WZR,W3 ; ABS W4,W3 ; locations [0:X2;0:X3;0:X4;]herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L091.litmus.expected000066400000000000000000000002771475314470400266140ustar00rootroot00000000000000Test L091 Required States 1 0:X2=-2147483648; 0:X3=-1; 0:X4=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (true) Observation L091 Always 1 0 Hash=fe66543cddeef0354b07bed04c66085f herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L092.litmus000066400000000000000000000001611475314470400250050ustar00rootroot00000000000000AArch64 L092 { 0:X1=6; } P0 ; NEG W2,W1,LSL 2 ; ABS W3,W2 ; forall 0:X2=-24 /\ 0:X3=24 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L092.litmus.expected000066400000000000000000000002761475314470400266140ustar00rootroot00000000000000Test L092 Required States 1 0:X2=-24; 0:X3=24; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=-24 /\ 0:X3=24) Observation L092 Always 1 0 Hash=f1a80d976e83bde8a704e682d8c25f7e herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L093.litmus000066400000000000000000000002561475314470400250130ustar00rootroot00000000000000AArch64 L093 { 0:X1=0x87654321; uint64_t 0:X3=0xfedcba87654321; uint64_t 0:X4; } P0 ; RBIT W2,W1 ; RBIT X4,X3 ; forall 0:X2=0x84c2a6e1 /\ 0:X4=0x84c2a6e15d3b7f00 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L093.litmus.expected000066400000000000000000000003601475314470400266070ustar00rootroot00000000000000Test L093 Required States 1 0:X2=-2067618079; 0:X4=9566392045350387456; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=2227349217 /\ 0:X4=-8880352028359164160) Observation L093 Always 1 0 Hash=400965e8039d37c3c8d59a195edf7531 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L094.litmus000066400000000000000000000003031475314470400250050ustar00rootroot00000000000000AArch64 L094 { uint32_t 0:X1=0x87654321; uint32_t 0:X2; uint64_t 0:X3=0xfedcba87654321; uint64_t 0:X4; } P0 ; REV W2,W1 ; REV X4,X3 ; forall 0:X2=0x21436587 /\ 0:X4=0x21436587badcfe00 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L094.litmus.expected000066400000000000000000000003541475314470400266130ustar00rootroot00000000000000Test L094 Required States 1 0:X2=558065031; 0:X4=2396871060321271296; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=558065031 /\ 0:X4=2396871060321271296) Observation L094 Always 1 0 Hash=f55c35e3f34db34069f12a61d6abd1d3 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L095.litmus000066400000000000000000000003131475314470400250070ustar00rootroot00000000000000AArch64 L095 { uint32_t 0:X1=0x87654321; uint32_t 0:X2; uint64_t 0:X3=0xfedcba87654321; uint64_t 0:X4; } P0 ; REV16 W2,W1 ; REV16 X4,X3 ; forall 0:X2=0x65872143 /\ 0:X4=0xfe00badc65872143; herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L095.litmus.expected000066400000000000000000000003571475314470400266170ustar00rootroot00000000000000Test L095 Required States 1 0:X2=1703354691; 0:X4=18302834341392621891; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=1703354691 /\ 0:X4=-143909732316929725) Observation L095 Always 1 0 Hash=23b492a35abf95f36f070f9d77e32f08 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L096.litmus000066400000000000000000000001771475314470400250200ustar00rootroot00000000000000AArch64 L096 { uint64_t 0:X3=0xfedcba87654321; uint64_t 0:X4; } P0 ; REV32 X4,X3 ; forall 0:X4=0xbadcfe0021436587 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L096.litmus.expected000066400000000000000000000003141475314470400266110ustar00rootroot00000000000000Test L096 Required States 1 0:X4=13464916262442460551; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X4=-4981827811267091065) Observation L096 Always 1 0 Hash=fe0a2adb127e165e26778c56716e669d herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L097.litmus000066400000000000000000000001771475314470400250210ustar00rootroot00000000000000AArch64 L097 { uint64_t 0:X3=0xfedcba87654321; uint64_t 0:X4; } P0 ; REV64 X4,X3 ; forall 0:X4=0x21436587badcfe00 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L097.litmus.expected000066400000000000000000000003121475314470400266100ustar00rootroot00000000000000Test L097 Required States 1 0:X4=2396871060321271296; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X4=2396871060321271296) Observation L097 Always 1 0 Hash=46001174e70c8ea3c01326bf03d1c1b8 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L098.litmus000066400000000000000000000010131475314470400250100ustar00rootroot00000000000000AArch64 L098 { 0:X1=128; 0:X2=15; int64_t 0:X3; int64_t 0:X4; int64_t 0:X5; int64_t 0:X6; int64_t 0:X7; int64_t 0:X8; int64_t 0:X9; } P0 ; SMULL X3,W2,W1 ; SMADDL X3,W2,W1,X3 ; MOV W1,#-1 ; SMADDL X4,W2,W1,X3 ; SMNEGL X5,W1,W1 ; UMULL X6,W1,W1 ; SMSUBL X7,W2,W1,X3 ; ADD W1,W1,W1 ; MOV X10,1 ; UMSUBL X8,W1,W1,X10 ; SMSUBL X9,W1,W1,X10 ; forall 0:X3=3840 /\ 0:X4=3825 /\ 0:X5=-1 /\ 0:X6=-8589934591 /\ 0:X7=3855 /\ 0:X8=17179869181 /\ 0:X9=-3 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L098.litmus.expected000066400000000000000000000005201475314470400266120ustar00rootroot00000000000000Test L098 Required States 1 0:X3=3840; 0:X4=3825; 0:X5=-1; 0:X6=-8589934591; 0:X7=3855; 0:X8=17179869181; 0:X9=-3; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X3=3840 /\ 0:X4=3825 /\ 0:X5=-1 /\ 0:X6=-8589934591 /\ 0:X7=3855 /\ 0:X8=17179869181 /\ 0:X9=-3) Observation L098 Always 1 0 Hash=69c9422977f390fc9590d51103553311 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L099.litmus000066400000000000000000000005641475314470400250230ustar00rootroot00000000000000AArch64 L099 { int x=-7; 0:X0=x; int64_t 0:X5; int64_t 0:X2; int64_t 0:X6; int64_t 0:X4; 0:X9=0; } P0 ; LDR W1,[X0] ; ADD X5,X5,W1,UXTW ; LDRSW X2,[X0] ; LDR W3,[X0,W9,UXTW] ; ADD X6,X6,W3,UXTW ; LDRSW X4,[X0,W9,SXTW] ; locations [0:X5;0:X2;0:X6;0:X4;] forall 0:X2=-7 /\ 0:X4=-7 /\ 0:X5=4294967289 /\ 0:X6=4294967289 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L099.litmus.expected000066400000000000000000000004041475314470400266140ustar00rootroot00000000000000Test L099 Required States 1 0:X2=-7; 0:X4=-7; 0:X5=4294967289; 0:X6=4294967289; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=-7 /\ 0:X4=-7 /\ 0:X5=4294967289 /\ 0:X6=4294967289) Observation L099 Always 1 0 Hash=5615a168ee3d6a9bc72df5a2e1932833 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L100.litmus000066400000000000000000000001431475314470400247730ustar00rootroot00000000000000AArch64 L100 { int x=-7; 0:X0=x; int64_t 0:X1; } P0 ; LDRSW X1,[X0] ; forall 0:X1=-7 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L100.litmus.expected000066400000000000000000000002501475314470400265720ustar00rootroot00000000000000Test L100 Required States 1 0:X1=-7; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=-7) Observation L100 Always 1 0 Hash=73ed83cc72f02e2df95b5adc8205c25c herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L101.litmus000066400000000000000000000006041475314470400247760ustar00rootroot00000000000000AArch64 L101 { int64_t x=-7; int16_t y=-7; int8_t z[3]={-7,-5,-3}; 0:X0=x; 0:X8=y; 0:X9=z; int64_t 0:X2=0; int64_t 0:X1; int64_t 0:X3; int64_t 0:X4; int64_t 0:X5; } P0 ; LDRSW X1,[X0,X2,LSL 2] ; LDRSH W3,[X8,X2,LSL 1] ; LDRSB X4,[X9],#2 ; LDRSB X5,[X9,#-1]! ; locations [0:X1;0:X3;0:X4;0:X5;] forall 0:X1=-7 /\ 0:X3=4294967289 /\ 0:X4=-7 /\ 0:X5=-5 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L101.litmus.expected000066400000000000000000000003641475314470400266010ustar00rootroot00000000000000Test L101 Required States 1 0:X1=-7; 0:X3=4294967289; 0:X4=-7; 0:X5=-5; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=-7 /\ 0:X3=4294967289 /\ 0:X4=-7 /\ 0:X5=-5) Observation L101 Always 1 0 Hash=2a330e983837edea58b958262a92c30c herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L102.litmus000066400000000000000000000004331475314470400247770ustar00rootroot00000000000000AArch64 L102 { int x[4] = {-1,-2,-3,-2}; 0:X0=x; int64_t 0:X2; int64_t 0:X3; int64_t 0:X4; } P0 ; MOV W1,#-7 ; STR W1,[X0],#12 ; LDRSW X3,[X0],#4 ; LDRSW X4,[X0,X3,LSL 2] ; LDRSW X2,[X0,#-16]! ; forall 0:X2=-7 /\ 0:X3=-2 /\ 0:X4=-3 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L102.litmus.expected000066400000000000000000000003201475314470400265720ustar00rootroot00000000000000Test L102 Required States 1 0:X2=-7; 0:X3=-2; 0:X4=-3; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X2=-7 /\ 0:X3=-2 /\ 0:X4=-3) Observation L102 Always 1 0 Hash=f44678c331ca2a4a17b9d20f5a5aac42 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L103.litmus000066400000000000000000000004641475314470400250040ustar00rootroot00000000000000AArch64 L103 (* Test xor'ing symbolic addresses *) { int z = 1; int *p = z; int *q = z; int x = 2; int y = 2; 0:X0=p; 0:X1=q; 0:X2=x; 1:X0=p; 1:X1=q; 1:X2=y; } P0 | P1 ; LDR X3,[X0] | LDR X3,[X1] ; EOR X4,X3,X3 | STR X2,[X0] ; STR X2,[X1,X4] | ; exists 0:X3=y /\ 1:X3=x herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/L103.litmus.expected000066400000000000000000000003521475314470400266000ustar00rootroot00000000000000Test L103 Allowed States 4 0:X3=y; 1:X3=x; 0:X3=y; 1:X3=z; 0:X3=z; 1:X3=x; 0:X3=z; 1:X3=z; Ok Witnesses Positive: 1 Negative: 3 Condition exists (0:X3=y /\ 1:X3=x) Observation L103 Sometimes 1 3 Hash=ec81d74db1ff1e32cf72d50b1e0b4a38 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/M001.litmus000066400000000000000000000006101475314470400247730ustar00rootroot00000000000000AArch64 M001 (* Test elementary size computation (also scanning initialisations) *) (* This is a replica of M001 in the AArch64.mixed directory*) (* It is repeated here, with the `Variant=mixed` flag, to ensure the*) (* inline variant flag is specified*) Variant=mixed { uint8_t t[4]={ 0,0,0,0 }; 0:X2=t; } P0 ; MOV W0,#1 ; SUB W0,WZR,W0 ; STR W0,[X2] ; locations [t;] herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/M001.litmus.expected000066400000000000000000000002611475314470400265750ustar00rootroot00000000000000Test M001 Required States 1 t={255,255,255,255}; Ok Witnesses Positive: 1 Negative: 0 Condition forall (true) Observation M001 Always 1 0 Hash=192e33ccf5ce7ad96d47e0f528afd7e6 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/Y001.litmus000066400000000000000000000003361475314470400250140ustar00rootroot00000000000000AArch64 Y001 (* MADD *) { int64_t 0: X1 = 2; int64_t 0: X2 = 3; int64_t 0: X3 = 5; int64_t 0: X4; } P0 ; MADD X4, X1, X2, X3; forall ( 0: X1 = 2 /\ 0: X2 = 3 /\ 0: X3 = 5 /\ 0: X4 = 11 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/Y001.litmus.expected000066400000000000000000000003361475314470400266140ustar00rootroot00000000000000Test Y001 Required States 1 0:X1=2; 0:X2=3; 0:X3=5; 0:X4=11; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=2 /\ 0:X2=3 /\ 0:X3=5 /\ 0:X4=11) Observation Y001 Always 1 0 Hash=8e0874f28c5c0114d00e84182a875131 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/Y002.litmus000066400000000000000000000002571475314470400250170ustar00rootroot00000000000000AArch64 Y002 (* MUL *) { int64_t 0: X1 = 2; int64_t 0: X2 = 3; int64_t 0: X3; } P0 ; MUL X3, X1, X2; forall ( 0: X1 = 2 /\ 0: X2 = 3 /\ 0: X3 = 6 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/Y002.litmus.expected000066400000000000000000000003121475314470400266070ustar00rootroot00000000000000Test Y002 Required States 1 0:X1=2; 0:X2=3; 0:X3=6; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=2 /\ 0:X2=3 /\ 0:X3=6) Observation Y002 Always 1 0 Hash=6b40ca1774ad91a8a286ea49b06fd6a5 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/Y003.litmus000066400000000000000000000002141475314470400250110ustar00rootroot00000000000000AArch64 Y003 (* MUL *) { 0: X1 = 2; 0: X2 = 3; } P0 ; MUL W3, W1, W2; forall ( 0: X1 = 2 /\ 0: X2 = 3 /\ 0: X3 = 6 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/Y003.litmus.expected000066400000000000000000000003121475314470400266100ustar00rootroot00000000000000Test Y003 Required States 1 0:X1=2; 0:X2=3; 0:X3=6; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=2 /\ 0:X2=3 /\ 0:X3=6) Observation Y003 Always 1 0 Hash=7c6f007938f27a483b5b6ffa4f06c270 herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/Y004.litmus000066400000000000000000000002341475314470400250140ustar00rootroot00000000000000AArch64 Y004 (* MUL *) { 0: X1 = 65536; 0: X2 = 65536; } P0 ; MUL W3, W1, W2; forall ( 0: X1 = 65536 /\ 0: X2 = 65536 /\ 0: X3 = 0 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/Y004.litmus.expected000066400000000000000000000003321475314470400266130ustar00rootroot00000000000000Test Y004 Required States 1 0:X1=65536; 0:X2=65536; 0:X3=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=65536 /\ 0:X2=65536 /\ 0:X3=0) Observation Y004 Always 1 0 Hash=64af9f2820eb24f19b9bd2665872394e herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/Y005.litmus000066400000000000000000000002201475314470400250100ustar00rootroot00000000000000AArch64 Y005 (* MNEG *) { 0: X1 = -3; 0: X2 = 2; } P0 ; MNEG W3, W1, W2; forall ( 0: X1 = -3 /\ 0: X2 = 2 /\ 0: X3 = 6 ) herd-herdtools7-1ca343e/herd/tests/instructions/AArch64/Y005.litmus.expected000066400000000000000000000003141475314470400266140ustar00rootroot00000000000000Test Y005 Required States 1 0:X1=-3; 0:X2=2; 0:X3=6; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:X1=-3 /\ 0:X2=2 /\ 0:X3=6) Observation Y005 Always 1 0 Hash=f19c4b1b6a9d2c6634b0008b0c389728 herd-herdtools7-1ca343e/herd/tests/instructions/ARM/000077500000000000000000000000001475314470400224115ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A001.litmus000066400000000000000000000001261475314470400242500ustar00rootroot00000000000000ARM A001 { 0:R0=x; } P0 ; LDR R1,[R0] ; SUB R2,R1,#1 ; locations [0:R2;]herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A001.litmus.expected000066400000000000000000000002451475314470400260520ustar00rootroot00000000000000Test A001 Required States 1 0:R2=-1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (true) Observation A001 Always 1 0 Hash=4b873a6594a3fd7ae6137c1521bbb450 herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A002.litmus000066400000000000000000000004041475314470400242500ustar00rootroot00000000000000ARM A002 { 0:R0=x; int y=1; 1:R0=y; } P0 | P1 ; LDR R1,[R0] | LDR R1,[R0] ; SUBS R2,R1,#1 | SUBS R2,R1,#1 ; BEQ L0 | BNE L1 ; MOV R2,#2 | MOV R2,#2 ; L0: |L1: ; forall 0:R2=2 /\ 1:R2=2herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A002.litmus.expected000066400000000000000000000002701475314470400260510ustar00rootroot00000000000000Test A002 Required States 1 0:R2=2; 1:R2=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:R2=2 /\ 1:R2=2) Observation A002 Always 1 0 Hash=4fe306e505f6d8d0bab53d6c877d9f1b herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A003.litmus000066400000000000000000000004441475314470400242550ustar00rootroot00000000000000ARM A003 (* classic SB004 test, should not see final state in outcomes*) { 0:R2=x; 0:R3=y; 1:R2=y; 1:R3=x; } P0 | P1 ; MOV R0,#1 | MOV R0,#1 ; STR R0,[R2] | STR R0,[R2] ; DMB ISH | DMB ISH ; LDR R1,[R3] | LDR R1,[R3] ; ~exists (0:R1=0 /\ 1:R1=0) herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A003.litmus.expected000066400000000000000000000003311475314470400260500ustar00rootroot00000000000000Test A003 Forbidden States 3 0:R1=0; 1:R1=1; 0:R1=1; 1:R1=0; 0:R1=1; 1:R1=1; Ok Witnesses Positive: 3 Negative: 0 Condition ~exists (0:R1=0 /\ 1:R1=0) Observation A003 Never 0 3 Hash=8bd18640a71f5f8da4d4f2fe719284e3 herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A004.litmus000066400000000000000000000003171475314470400242550ustar00rootroot00000000000000ARM A004 (* Test ORR instruction arm*) { 0:R2 = 1; 0:R5 = 1; 0:R8 = 0; 0:R11= 0; } P0; ORR R1, R2, #1; ORR R4, R5, #0; ORR R7, R8, #1; ORR R10,R11,#0; forall (0:R1 = 1 /\ 0:R4 = 1 /\ 0:R7 = 1 /\ 0:R10=0) herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A004.litmus.expected000066400000000000000000000003361475314470400260560ustar00rootroot00000000000000Test A004 Required States 1 0:R1=1; 0:R4=1; 0:R7=1; 0:R10=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:R1=1 /\ 0:R4=1 /\ 0:R7=1 /\ 0:R10=0) Observation A004 Always 1 0 Hash=d39f5d16e08b32627e67fdebc98bc624 herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A005.litmus000066400000000000000000000002531475314470400242550ustar00rootroot00000000000000ARM A005 Stable=R2,R3,R4,R5 (*Test LDRD Instruction *) { int x[2] = {1,1}; 0:R1 = x } P0; LDRD R2,R3,[R1]; LDRD R4,[R1]; forall (0:R2=1 /\ 0:R3=1 /\ 0:R4=1 /\ 0:R5=1) herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A005.litmus.expected000066400000000000000000000003341475314470400260550ustar00rootroot00000000000000Test A005 Required States 1 0:R2=1; 0:R3=1; 0:R4=1; 0:R5=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:R2=1 /\ 0:R3=1 /\ 0:R4=1 /\ 0:R5=1) Observation A005 Always 1 0 Hash=7634bf6ce48a5ec0f06cfdcbe83bd2a2 herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A006.litmus000066400000000000000000000002231475314470400242530ustar00rootroot00000000000000ARM A006 (*Tests parsing of IP register - otherwise known as R12*) { 0:R12 = x; x=1} P0; LDR R1, [R12]; LDR R2, [IP]; forall (0:R1=1 /\ 0:R2=1) herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A006.litmus.expected000066400000000000000000000002701475314470400260550ustar00rootroot00000000000000Test A006 Required States 1 0:R1=1; 0:R2=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:R1=1 /\ 0:R2=1) Observation A006 Always 1 0 Hash=6df4dbc77a552cba2fdf46748d1e92d9 herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A007.litmus000066400000000000000000000002201475314470400242510ustar00rootroot00000000000000ARM A007 Stable=R1,R2 (* Tests LDM (2-reg variant) *) { int x[2] = {1,2}; 0:R0 = x} P0; LDM R0, { R1, R2 }; forall (0:R1 = 1 /\ 0:R2 = 2) herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A007.litmus.expected000066400000000000000000000002701475314470400260560ustar00rootroot00000000000000Test A007 Required States 1 0:R1=1; 0:R2=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:R1=1 /\ 0:R2=2) Observation A007 Always 1 0 Hash=399610b45809d8bab38135a3b19eb9df herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A008.litmus000066400000000000000000000002471475314470400242630ustar00rootroot00000000000000ARM A008 Stable=R0,R1,R2,R3 (* Tests LDM (3-reg variant) *) { int x[3] = {1,2,3}; 0:R0 = x} P0; LDM R0, { R1, R2, R3 }; forall (0:R1 = 1 /\ 0:R2 = 2 /\ 0:R3 = 3) herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A008.litmus.expected000066400000000000000000000003121475314470400260540ustar00rootroot00000000000000Test A008 Required States 1 0:R1=1; 0:R2=2; 0:R3=3; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:R1=1 /\ 0:R2=2 /\ 0:R3=3) Observation A008 Always 1 0 Hash=0e45af57c624e78be7cd0fd317d7e51b herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A009.litmus000066400000000000000000000002101475314470400242520ustar00rootroot00000000000000ARM A009 (* Tests LDM (2-reg variant IB) *) { int x[3] = {1,2,3}; 0:R0 = x} P0; LDMIB R0, { R1, R2 }; forall (0:R1 = 2/\ 0:R2 = 3) herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A009.litmus.expected000066400000000000000000000002701475314470400260600ustar00rootroot00000000000000Test A009 Required States 1 0:R1=2; 0:R2=3; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:R1=2 /\ 0:R2=3) Observation A009 Always 1 0 Hash=fe765959009fb1eacd7bee92c02fe8fb herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A010.litmus000066400000000000000000000001501475314470400242450ustar00rootroot00000000000000ARM A010 (* Test LDR Offset *) { int x[2] = {1,2}; 0:R0=x } P0; LDR R1, [R0,#4]; forall (0:R1 = 2) herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A010.litmus.expected000066400000000000000000000002461475314470400260530ustar00rootroot00000000000000Test A010 Required States 1 0:R1=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:R1=2) Observation A010 Always 1 0 Hash=81521a0db638f43dc567a84e7411beb8 herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A011.litmus000066400000000000000000000001661475314470400242550ustar00rootroot00000000000000ARM A011 (* Test MOVT Instr - simply moving 1 into upper bits *) { 0:R0 = 0 } P0; MOVT R0, #1; forall 0:R0=0x10000 herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A011.litmus.expected000066400000000000000000000002561475314470400260550ustar00rootroot00000000000000Test A011 Required States 1 0:R0=65536; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:R0=65536) Observation A011 Always 1 0 Hash=6c83921ab28398e13c6a9d52e8461687 herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A012.litmus000066400000000000000000000002261475314470400242530ustar00rootroot00000000000000ARM A012 (* Test MOVT Instr - simply moving 0 into upper bits *) (* should be idempotent - NOP *) { 0:R0 = 0} P0; MOVT R0, #0; forall 0:R0=0x00000 herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A012.litmus.expected000066400000000000000000000002461475314470400260550ustar00rootroot00000000000000Test A012 Required States 1 0:R0=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:R0=0) Observation A012 Always 1 0 Hash=741ae0900c1ec08d09c13e59fa1e17fe herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A013.litmus000066400000000000000000000001361475314470400242540ustar00rootroot00000000000000ARM A013 (* MOVT implementation *) { 0:R0 = 0} P0; MOVT R0, #48879; forall 0:R0=0xBEEF0000 herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A013.litmus.expected000066400000000000000000000002721475314470400260550ustar00rootroot00000000000000Test A013 Required States 1 0:R0=-1091633152; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:R0=-1091633152) Observation A013 Always 1 0 Hash=aaba0ae318cbd1d05439a68e1c7235f7 herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A015.litmus000066400000000000000000000001751475314470400242610ustar00rootroot00000000000000ARM A015 Stable=IP (* Test BX instruction *) { 0:R0 = P0:foo} P0; BX R0; MOV R1, #1; foo: ; forall (0:R1 = 0) herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A015.litmus.expected000066400000000000000000000002461475314470400260600ustar00rootroot00000000000000Test A015 Required States 1 0:R1=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:R1=0) Observation A015 Always 1 0 Hash=a9ec21f13bd133372402c68bc771bc63 herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A020.litmus000066400000000000000000000003121475314470400242460ustar00rootroot00000000000000ARM A020 (* TEST LDR/STR Barrel Shifters*) { int v[2] = {1,2}; 0:R1 = v; 0:R3 = 1; int y[2] = {0,0}; 0:R4 = y } P0; LDR R2, [R1, R3, lsl #2]; STR R2, [R4, R3, lsl #2]; forall (0:R2 = 2 /\ v[1] = 2) herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A020.litmus.expected000066400000000000000000000002701475314470400260510ustar00rootroot00000000000000Test A020 Required States 1 0:R2=2; v[1]=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:R2=2 /\ v[1]=2) Observation A020 Always 1 0 Hash=53b68e1cf3bc79ce492882ea4fe72ade herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A021.litmus000066400000000000000000000002451475314470400242540ustar00rootroot00000000000000ARM A021 (* Test MOVEQ/MOVTEQ instruction *) { int R1=0; int R2 = 0; 0:R3=1} P0; CMP R3, #1; MOVWEQ R1, #2; MOVTEQ R2, #2; forall (0:R1=2 /\ 0:R2=0x20000) herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A021.litmus.expected000066400000000000000000000003021475314470400260460ustar00rootroot00000000000000Test A021 Required States 1 0:R1=2; 0:R2=131072; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:R1=2 /\ 0:R2=131072) Observation A021 Always 1 0 Hash=1763ed3b82a8cec323ea12c101f0a09f herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A022.litmus000066400000000000000000000001651475314470400242560ustar00rootroot00000000000000ARM A022 (* Test ANDEQ *) { 0:R1 = 1 } P0; CMP R1, #1; ANDEQ R0, R0, R0; (*nop*) ANDEQ R2, R1, R1; forall 0:R2=1 herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A022.litmus.expected000066400000000000000000000002461475314470400260560ustar00rootroot00000000000000Test A022 Required States 1 0:R2=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:R2=1) Observation A022 Always 1 0 Hash=443e6e22e08983d431e8e9b0068c1a9c herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A023.litmus000066400000000000000000000001121475314470400242470ustar00rootroot00000000000000ARM A023 (*Parse Frame Pointer reg*) {} P0; MOV R0, FP; forall 0:R0=0 herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A023.litmus.expected000066400000000000000000000002461475314470400260570ustar00rootroot00000000000000Test A023 Required States 1 0:R0=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:R0=0) Observation A023 Always 1 0 Hash=a5d34ed41a70bbc7d0424aec76dd2ea5 herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A024.litmus000066400000000000000000000016331475314470400242610ustar00rootroot00000000000000ARM A024 Variant=telechat { [P1_r0]=0;[x]=0;[y]=0; %P0_x=x;%P0_y=y; %P1_P1_r0=P1_r0; %P1_x=x;%P1_y=y } (*****************************************************************) (* Compiler: *) (* arm-linux-gnueabi-gcc-10 -c -g -O2 -march=armv7-a --std=c11 -fno-section-anchors*) (*****************************************************************) P0 | P1 ; MOV R0,#2 | LDR R2,[%P1_y] ; MOV R1,#1 | CMP R2,#1 ; DMB ISH | BEQ L0x5c ; STR R0,[%P0_x] | L0x48: ; STR R1,[%P0_y] | STR R2,[%P1_P1_r0] ; BX LR | BX LR ; | L0x5c: ; | DMB ISH ; | STR R2,[%P1_x] ; | B L0x48 ; exists ([x]=2 /\ P1_r0=1) herd-herdtools7-1ca343e/herd/tests/instructions/ARM/A024.litmus.expected000066400000000000000000000003421475314470400260550ustar00rootroot00000000000000Test A024 Allowed States 3 [P1_r0]=0; [x]=2; [P1_r0]=1; [x]=1; [P1_r0]=1; [x]=2; Ok Witnesses Positive: 1 Negative: 2 Condition exists ([x]=2 /\ [P1_r0]=1) Observation A024 Sometimes 1 2 Hash=c8a63d379ba2a30b8fd50dffe39a7ebc herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/000077500000000000000000000000001475314470400246215ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/LB-02.litmus000066400000000000000000000007561475314470400266040ustar00rootroot00000000000000ASL LB-pseudo-arch { x = 0; y = 0; 0: X1= x; 0: X2= y; } constant one : bits(64) = 1[63:0]; func T0(x:bits(64), y: bits(64)) begin let x0 = UInt(read_memory{64}(x)); write_memory{64}(y, one); end; func T1(x:bits(64), y: bits(64)) begin let x1 = UInt(read_memory{64}(y)); write_memory{64}(x, one); end; func main() => integer begin let x = read_register(1); let y = read_register(2); T0(x, y); T1(x, y); return 0; end; exists (0: T0.0.x0 = 1 /\ 0: T1.0.x1 = 1) herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/LB-02.litmus.expected000066400000000000000000000004601475314470400303740ustar00rootroot00000000000000Test LB-pseudo-arch Allowed States 4 0:T0.0.x0=0; 0:T1.0.x1=0; 0:T0.0.x0=0; 0:T1.0.x1=1; 0:T0.0.x0=1; 0:T1.0.x1=0; 0:T0.0.x0=1; 0:T1.0.x1=1; Ok Witnesses Positive: 1 Negative: 3 Condition exists (0:T0.0.x0=1 /\ 0:T1.0.x1=1) Observation LB-pseudo-arch Sometimes 1 3 Hash=f8f935ebd24694eeff8bf4ac221b18c0 herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/LB-03.litmus000066400000000000000000000011401475314470400265710ustar00rootroot00000000000000ASL LB-pseudo-arch { x = 0; y = 0; 0: X1= x; 0: X2= y; } constant one : bits(64) = 1[63:0]; func T0(x:bits(64), y: bits(64)) begin let read = read_memory{64}(x); let x0 = UInt(read); let data = one OR (read XOR read); write_memory{64}(y, data); end; func T1(x:bits(64), y: bits(64)) begin let read = read_memory{64}(y); let x1 = UInt(read); let data = one OR (read XOR read); write_memory{64}(x, data); end; func main() => integer begin let x = read_register(1); let y = read_register(2); T0(x, y); T1(x, y); return 0; end; exists (0: T0.0.x0 = 1 /\ 0: T1.0.x1 = 1) herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/LB-03.litmus.expected000066400000000000000000000004221475314470400303730ustar00rootroot00000000000000Test LB-pseudo-arch Allowed States 3 0:T0.0.x0=0; 0:T1.0.x1=0; 0:T0.0.x0=0; 0:T1.0.x1=1; 0:T0.0.x0=1; 0:T1.0.x1=0; No Witnesses Positive: 0 Negative: 3 Condition exists (0:T0.0.x0=1 /\ 0:T1.0.x1=1) Observation LB-pseudo-arch Never 0 3 Hash=466e821ea60d973ab26752734da568af herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/LB-04.litmus000066400000000000000000000010471475314470400266000ustar00rootroot00000000000000ASL LB-pseudo-arch { x = 0; y = 0; 0: X1= x; 0: X2= y; } constant one : bits(64) = 1[63:0]; func T0(x:bits(64), y: bits(64)) begin let read = read_memory{64}(x); let x0 = UInt(read); let data = one OR (read XOR read); write_memory{64}(y, data); end; func T1(x:bits(64), y: bits(64)) begin let x1 = UInt(read_memory{64}(y)); write_memory{64}(x, one); end; func main() => integer begin let x = read_register(1); let y = read_register(2); T0(x, y); T1(x, y); return 0; end; exists (0: T0.0.x0 = 1 /\ 0: T1.0.x1 = 1) herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/LB-04.litmus.expected000066400000000000000000000004601475314470400303760ustar00rootroot00000000000000Test LB-pseudo-arch Allowed States 4 0:T0.0.x0=0; 0:T1.0.x1=0; 0:T0.0.x0=0; 0:T1.0.x1=1; 0:T0.0.x0=1; 0:T1.0.x1=0; 0:T0.0.x0=1; 0:T1.0.x1=1; Ok Witnesses Positive: 1 Negative: 3 Condition exists (0:T0.0.x0=1 /\ 0:T1.0.x1=1) Observation LB-pseudo-arch Sometimes 1 3 Hash=15df8cf323b245ce9ea8cda83f272459 herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/LB-05.litmus000066400000000000000000000012151475314470400265760ustar00rootroot00000000000000ASL LB-pseudo-arch { x = 0; y = 0; 0: X1= x; 0: X2= y; } constant one : bits(64) = 1[63:0]; func T0(x:bits(64), y: bits(64)) begin let read = read_memory{64}(x); let x0 = UInt(read); let data = one OR (read XOR read); write_memory{64}(y, data); end; func f(read:bits(64)) => bits(64) begin return one; end; func T1(x:bits(64), y: bits(64)) begin let read = read_memory{64}(y); let x1 = UInt(read); let data = f(read); write_memory{64}(x, data); end; func main() => integer begin let x = read_register(1); let y = read_register(2); T0(x, y); T1(x, y); return 0; end; exists (0: T0.0.x0 = 1 /\ 0: T1.0.x1 = 1) herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/LB-05.litmus.expected000066400000000000000000000004601475314470400303770ustar00rootroot00000000000000Test LB-pseudo-arch Allowed States 4 0:T0.0.x0=0; 0:T1.0.x1=0; 0:T0.0.x0=0; 0:T1.0.x1=1; 0:T0.0.x0=1; 0:T1.0.x1=0; 0:T0.0.x0=1; 0:T1.0.x1=1; Ok Witnesses Positive: 1 Negative: 3 Condition exists (0:T0.0.x0=1 /\ 0:T1.0.x1=1) Observation LB-pseudo-arch Sometimes 1 3 Hash=ebac45eb11ff7337abe24cad6fd7804f herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/LB-06.litmus000066400000000000000000000012331475314470400265770ustar00rootroot00000000000000ASL LB-pseudo-arch { x = 0; y = 0; 0: X1= x; 0: X2= y; } constant one : bits(64) = 1[63:0]; func T0(x:bits(64), y: bits(64)) begin let read = read_memory{64}(x); let x0 = UInt(read); let data = one OR (read XOR read); write_memory{64}(y, data); end; func f(read:bits(64)) => bits(64) begin return read[63:0] OR one; end; func T1(x:bits(64), y: bits(64)) begin let read = read_memory{64}(y); let x1 = UInt(read); let data = f(read); write_memory{64}(x, data); end; func main() => integer begin let x = read_register(1); let y = read_register(2); T0(x, y); T1(x, y); return 0; end; exists (0: T0.0.x0 = 1 /\ 0: T1.0.x1 = 1) herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/LB-06.litmus.expected000066400000000000000000000004221475314470400303760ustar00rootroot00000000000000Test LB-pseudo-arch Allowed States 3 0:T0.0.x0=0; 0:T1.0.x1=0; 0:T0.0.x0=0; 0:T1.0.x1=1; 0:T0.0.x0=1; 0:T1.0.x1=0; No Witnesses Positive: 0 Negative: 3 Condition exists (0:T0.0.x0=1 /\ 0:T1.0.x1=1) Observation LB-pseudo-arch Never 0 3 Hash=dcedec31e50a4dfb925736e0e762a814 herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/LB-07.litmus000066400000000000000000000012511475314470400266000ustar00rootroot00000000000000ASL LB-pseudo-arch { x = 0; y = 0; 0: X1= x; 0: X2= y; } constant one : bits(64) = 1[63:0]; func T0(x:bits(64), y: bits(64)) begin let read = read_memory{64}(x); let x0 = UInt(read); let data = one OR (read XOR read); write_memory{64}(y, data); end; func f(read:bits(64)) => bits(64) begin var t = read; t[0] = '1'; return t; end; func T1(x:bits(64), y: bits(64)) begin let read = read_memory{64}(y); let x1 = UInt(read); let data = f(read); write_memory{64}(x, data); end; func main() => integer begin let x = read_register(1); let y = read_register(2); T0(x, y); T1(x, y); return 0; end; exists (0: T0.0.x0 = 1 /\ 0: T1.0.x1 = 1) herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/LB-07.litmus.expected000066400000000000000000000004221475314470400303770ustar00rootroot00000000000000Test LB-pseudo-arch Allowed States 3 0:T0.0.x0=0; 0:T1.0.x1=0; 0:T0.0.x0=0; 0:T1.0.x1=1; 0:T0.0.x0=1; 0:T1.0.x1=0; No Witnesses Positive: 0 Negative: 3 Condition exists (0:T0.0.x0=1 /\ 0:T1.0.x1=1) Observation LB-pseudo-arch Never 0 3 Hash=9afeed12c63f5f24e9289cc2d020e781 herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/LB-08.litmus000066400000000000000000000011521475314470400266010ustar00rootroot00000000000000ASL LB-pseudo-arch { x = 0; y = 0; 0: X1= x; 0: X2= y; } constant one : bits(64) = 1[63:0]; func T0(x:bits(64), y: bits(64)) begin let read = read_memory{64}(x); let x0 = UInt(read); let data = one OR (read XOR read); write_memory{64}(y, data); end; func T1(x:bits(64), y: bits(64)) begin let read = read_memory{64}(y); let x1 = UInt(read); let data = if read == one then one else one; write_memory{64}(x, data); end; func main() => integer begin let x = read_register(1); let y = read_register(2); T0(x, y); T1(x, y); return 0; end; exists (0: T0.0.x0 = 1 /\ 0: T1.0.x1 = 1) herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/LB-08.litmus.expected000066400000000000000000000004221475314470400304000ustar00rootroot00000000000000Test LB-pseudo-arch Allowed States 3 0:T0.0.x0=0; 0:T1.0.x1=0; 0:T0.0.x0=0; 0:T1.0.x1=1; 0:T0.0.x0=1; 0:T1.0.x1=0; No Witnesses Positive: 0 Negative: 3 Condition exists (0:T0.0.x0=1 /\ 0:T1.0.x1=1) Observation LB-pseudo-arch Never 0 3 Hash=b8e27e922bc18f0973cc3106bb0dd632 herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/LB-09.litmus000066400000000000000000000011471475314470400266060ustar00rootroot00000000000000ASL LB-pseudo-arch { x = 0; y = 0; 0: X1= x; 0: X2= y; } constant one : bits(64) = 1[63:0]; func T0(x:bits(64), y: bits(64)) begin let read = read_memory{64}(x); let x0 = UInt(read); let data = one OR (read XOR read); write_memory{64}(y, data); end; func T1(x:bits(64), y: bits(64)) begin let x1 = UInt(read_memory{64}(y)); if x1 == 1 then write_memory{64}(x, one); else write_memory{64}(x, one); end; end; func main() => integer begin let x = read_register(1); let y = read_register(2); T0(x, y); T1(x, y); return 0; end; exists (0: T0.0.x0 = 1 /\ 0: T1.0.x1 = 1) herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/LB-09.litmus.expected000066400000000000000000000004221475314470400304010ustar00rootroot00000000000000Test LB-pseudo-arch Allowed States 3 0:T0.0.x0=0; 0:T1.0.x1=0; 0:T0.0.x0=0; 0:T1.0.x1=1; 0:T0.0.x0=1; 0:T1.0.x1=0; No Witnesses Positive: 0 Negative: 3 Condition exists (0:T0.0.x0=1 /\ 0:T1.0.x1=1) Observation LB-pseudo-arch Never 0 3 Hash=68d7efe1712d077db896e6ce5713ecc4 herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/LB-10.litmus000066400000000000000000000012261475314470400265740ustar00rootroot00000000000000ASL LB-pseudo-arch { x = 0; y = 0; 0: X1= x; 0: X2= y; } constant one : bits(64) = 1[63:0]; func T0(x:bits(64), y: bits(64)) begin let read = read_memory{64}(x); let x0 = UInt(read); let data = one OR (read XOR read); write_memory{64}(y, data); end; func T1(x:bits(64), y: bits(64)) begin let read = read_memory{64}(y); let x1 = UInt(read); var data : bits(64); if x1 == one then data = one; else data = one; end; write_memory{64}(x, data); end; func main() => integer begin let x = read_register(1); let y = read_register(2); T0(x, y); T1(x, y); return 0; end; exists (0: T0.0.x0 = 1 /\ 0: T1.0.x1 = 1) herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/LB-10.litmus.expected000066400000000000000000000004221475314470400303710ustar00rootroot00000000000000Test LB-pseudo-arch Allowed States 3 0:T0.0.x0=0; 0:T1.0.x1=0; 0:T0.0.x0=0; 0:T1.0.x1=1; 0:T0.0.x0=1; 0:T1.0.x1=0; No Witnesses Positive: 0 Negative: 3 Condition exists (0:T0.0.x0=1 /\ 0:T1.0.x1=1) Observation LB-pseudo-arch Never 0 3 Hash=8b0c8bd2dab15e33ae58f45a9f4dea57 herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/LB-11.litmus000066400000000000000000000011721475314470400265750ustar00rootroot00000000000000ASL LB-pseudo-arch { x = 0; y = 0; 0: X1= x; 0: X2= y; } constant one : bits(64) = 1[63:0]; func T0(x:bits(64), y: bits(64)) begin let read = read_memory{64}(x); let x0 = UInt(read); let data = one OR (read XOR read); write_memory{64}(y, data); end; var data_T1: bits(64); func T1(x:bits(64), y: bits(64)) begin let read = read_memory{64}(y); let x1 = UInt(read); data_T1 = one OR (read XOR read); write_memory{64}(x, data_T1); end; func main() => integer begin let x = read_register(1); let y = read_register(2); T0(x, y); T1(x, y); return 0; end; exists (0: T0.0.x0 = 1 /\ 0: T1.0.x1 = 1) herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/LB-11.litmus.expected000066400000000000000000000004221475314470400303720ustar00rootroot00000000000000Test LB-pseudo-arch Allowed States 3 0:T0.0.x0=0; 0:T1.0.x1=0; 0:T0.0.x0=0; 0:T1.0.x1=1; 0:T0.0.x0=1; 0:T1.0.x1=0; No Witnesses Positive: 0 Negative: 3 Condition exists (0:T0.0.x0=1 /\ 0:T1.0.x1=1) Observation LB-pseudo-arch Never 0 3 Hash=74a8227f37a93156a99e18e86daae33b herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/MP-01.litmus000066400000000000000000000007521475314470400266160ustar00rootroot00000000000000ASL MP-pseudo-arch { x = 0; y = 0; 0: X1= x; 0: X2= y; } constant one : bits(64) = 1[63:0]; func T0(x:bits(64), y: bits(64)) begin write_memory{64}(x, one); write_memory{64}(y, one); end; func T1(x:bits(64), y: bits(64)) begin let a = UInt(read_memory{64}(y)); let b = UInt(read_memory{64}(x)); end; func main() => integer begin let x = read_register(1); let y = read_register(2); T0(x, y); T1(x, y); return 0; end; exists (0: T1.0.a = 1 /\ 0: T1.0.b = 0) herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/MP-01.litmus.expected000066400000000000000000000004461475314470400304160ustar00rootroot00000000000000Test MP-pseudo-arch Allowed States 4 0:T1.0.a=0; 0:T1.0.b=0; 0:T1.0.a=0; 0:T1.0.b=1; 0:T1.0.a=1; 0:T1.0.b=0; 0:T1.0.a=1; 0:T1.0.b=1; Ok Witnesses Positive: 1 Negative: 3 Condition exists (0:T1.0.a=1 /\ 0:T1.0.b=0) Observation MP-pseudo-arch Sometimes 1 3 Hash=e4d9f8a971e26430ea558fcb187d603a herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/MP-02.litmus000066400000000000000000000007711475314470400266200ustar00rootroot00000000000000ASL MP-pseudo-arch { x = 0; y = 0; 0: X1= x; 0: X2= y; } constant one : bits(64) = 1[63:0]; func T0(x:bits(64), y: bits(64)) begin write_memory{64}(x, one); write_memory{64}(y, one); end; var a: integer; var b: integer; func T1(x:bits(64), y: bits(64)) begin a = UInt(read_memory{64}(y)); b = UInt(read_memory{64}(x)); end; func main() => integer begin let x = read_register(1); let y = read_register(2); T0(x, y); T1(x, y); return 0; end; exists (0: a = 1 /\ 0: b = 0) herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/MP-02.litmus.expected000066400000000000000000000003641475314470400304160ustar00rootroot00000000000000Test MP-pseudo-arch Allowed States 4 0:a=0; 0:b=0; 0:a=0; 0:b=1; 0:a=1; 0:b=0; 0:a=1; 0:b=1; Ok Witnesses Positive: 1 Negative: 3 Condition exists (0:a=1 /\ 0:b=0) Observation MP-pseudo-arch Sometimes 1 3 Hash=41cf9739fb59dfbb93b77168c09f4f5f herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/YL-01.litmus000066400000000000000000000003501475314470400266200ustar00rootroot00000000000000ASL YL-01 (* testing multiple XOR on bitvector slices *) { } func main() => integer begin constant x : bits(1) = '0'; constant y : bit = x[0] XOR '0' XOR '1'; let res = UInt(y); return 0; end; forall (0: main.0.res = 1) herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/YL-01.litmus.expected000066400000000000000000000002701475314470400304210ustar00rootroot00000000000000Test YL-01 Required States 1 0:main.0.res=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:main.0.res=1) Observation YL-01 Always 1 0 Hash=7e45428ead65a5e0d10ba711c60b5e2c herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/catch-exec-twice.litmus000066400000000000000000000005671475314470400312050ustar00rootroot00000000000000ASL catch-exec-twice (* * Ilustrate a bug: the catcher statement was executed twice. * As a consequence, the debug message was repeated. *) {} type Bonga of exception; func g() => integer begin try throw Bonga {}; catch when Bonga => let coucou = 11 ; println(coucou); end; return 0; end; func main() => integer begin return g(); end; herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/catch-exec-twice.litmus.expected000066400000000000000000000002701475314470400327740ustar00rootroot0000000000000011 Test catch-exec-twice Required States 1 Ok Witnesses Positive: 1 Negative: 0 Condition forall (true) Observation catch-exec-twice Always 1 0 Hash=374c8f16fe6155cd33b1be482ac852d0 herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/for-toofar.litmus000066400000000000000000000005771475314470400301470ustar00rootroot00000000000000ASL for-toofar { x = 0; 0:X1=x; } func T0(x:bits(64)) begin var s: integer = 0; let imax = UInt(read_memory{32}(x)); for i = 1 to imax do s = s + i; end; end; func T1(x:bits(64)) begin for k = 1 to 3 do write_memory{32}(x,k[31:0]); end; end; func main() => integer begin let x = read_register(1); T0(x); T1(x); return 0; end; locations [0:T0.0.s;] herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/for-toofar.litmus.expected000066400000000000000000000003211475314470400317320ustar00rootroot00000000000000Test for-toofar Required States 3 0:T0.0.s=0; 0:T0.0.s=1; 0:T0.0.s=3; Loop Ok Witnesses Positive: 3 Negative: 0 Condition forall (true) Observation for-toofar Always 3 0 Hash=2f2c3cc08f9ef4945df9607f2f204fdf herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/for-toofar.litmus.expected-warn000066400000000000000000000003631475314470400327050ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/ASL-pseudo-arch/for-toofar.litmus": unrolling limit exceeded at for loop at file "./herd/tests/instructions/ASL-pseudo-arch/for-toofar.litmus", line 13 to line 13 pruned, legal outcomes may be missing. herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/frozen-tuple-arg.litmus000066400000000000000000000007041475314470400312620ustar00rootroot00000000000000ASL frozen-tuple-arg (* * This tests was leading to a runtime error * because the pair construction failed. * This is no longer the case, as non-resolved * values such as the ones created by reading from * memory are now "frozen" when used as tuple arguments. *) { x=15; 0:X0=x; } func main() => integer begin let x = read_register(0); let (a,b) = (1,UInt(read_memory{32}(x))); let c = a+b; return 0; end; forall 0:main.0.c=16 herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/frozen-tuple-arg.litmus.expected000066400000000000000000000003141475314470400330570ustar00rootroot00000000000000Test frozen-tuple-arg Required States 1 0:main.0.c=16; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:main.0.c=16) Observation frozen-tuple-arg Always 1 0 Hash=588a4789c83564caa4527718a73d3d5d herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/non-deterministic-optimised.litmus000066400000000000000000000007721475314470400335140ustar00rootroot00000000000000ASL non-deterministic { x = 0; 0: X1= x; } // Always return 2, but this could create 2 executions that will turn out to // follow the same branch. To know if this creates two different executions // with the same end state, run herd with option -v. func g() => integer begin let x = read_register(1); let vx = UInt(read_memory{64}(x)); if (vx[0] == '0' && FALSE) then return 1; end; return 2; end; func main() => integer begin let z = g(); return 0; end; locations [0:main.0.z;] non-deterministic-optimised.litmus.expected000066400000000000000000000003041475314470400352240ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-archTest non-deterministic Required States 1 0:main.0.z=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (true) Observation non-deterministic Always 1 0 Hash=35f62616408094ca372b7b6260f3ffd3 herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/non-deterministic.litmus000066400000000000000000000004001475314470400315050ustar00rootroot00000000000000ASL non-deterministic { } // Non deterministically returns 1 or 2 func g() => integer begin let b = SomeBoolean(); if b then return 1; end; return 2; end; func main() => integer begin let z = g(); return 0; end; locations [0:main.0.z;] herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/non-deterministic.litmus.expected000066400000000000000000000003221475314470400333100ustar00rootroot00000000000000Test non-deterministic Required States 2 0:main.0.z=1; 0:main.0.z=2; Ok Witnesses Positive: 2 Negative: 0 Condition forall (true) Observation non-deterministic Always 2 0 Hash=ee9f71b97b098f6294dfbc3fccf06961 herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/pseudo-conf.cfg000066400000000000000000000000321475314470400275170ustar00rootroot00000000000000model asl-pseudo-arch.cat herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/repeat-toofar.litmus000066400000000000000000000006241475314470400306320ustar00rootroot00000000000000ASL repeat-toofar { x = 0; 0:X1=x; } func T0(x:bits(64)) begin var s: integer = 0; var i = UInt(read_memory{32}(x)); let j = i; repeat s = s + i; i = i-1; until i <= 0; end; func T1(x:bits(64)) begin for k = 1 to 3 do write_memory{32}(x,k[31:0]); end; end; func main() => integer begin let x = read_register(1); T0(x); T1(x); return 0; end; locations [0:T0.0.s;] herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/repeat-toofar.litmus.expected000066400000000000000000000003271475314470400324320ustar00rootroot00000000000000Test repeat-toofar Required States 3 0:T0.0.s=0; 0:T0.0.s=1; 0:T0.0.s=3; Loop Ok Witnesses Positive: 3 Negative: 0 Condition forall (true) Observation repeat-toofar Always 3 0 Hash=8b31a48972e9d53a1a48c9a48d93d7e8 herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/repeat-toofar.litmus.expected-warn000066400000000000000000000003741475314470400334010ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/ASL-pseudo-arch/repeat-toofar.litmus": unrolling limit exceeded at repeat loop at file "./herd/tests/instructions/ASL-pseudo-arch/repeat-toofar.litmus", line 13 to line 16 pruned, legal outcomes may be missing. herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/return-tuple.litmus000066400000000000000000000002701475314470400305250ustar00rootroot00000000000000ASL return-tuple { } func f() => (integer, integer) begin return (1,2); end; func main() => integer begin let (a,b) = f(); let c = a+b; return 0; end; forall 0:main.0.c=3 herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/return-tuple.litmus.expected000066400000000000000000000003021475314470400323210ustar00rootroot00000000000000Test return-tuple Required States 1 0:main.0.c=3; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:main.0.c=3) Observation return-tuple Always 1 0 Hash=2f551486a767d0027e5031e92c91fbbd herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/throw-assign.litmus000066400000000000000000000005571475314470400305140ustar00rootroot00000000000000ASL throw-assign (* * Catches bug, monad additional info was discarded * when exception is raised in assignment right hand side. * See PR #909. *) {} var z = 0; type Coucou of exception; func f() => integer begin z = 2; throw Coucou {}; end; func main() => integer begin try z = f(); catch when Coucou => return 0; end; end; forall 0:z=2 herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/throw-assign.litmus.expected000066400000000000000000000002641475314470400323070ustar00rootroot00000000000000Test throw-assign Required States 1 0:z=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:z=2) Observation throw-assign Always 1 0 Hash=27ff4e66750cd345f5ba805506d2e9ab herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/throw-propagate.litmus000066400000000000000000000015741475314470400312120ustar00rootroot00000000000000ASL throw-propagate (* * Test various control paths involving exceptions. *) {} var z = 0; var t = 2; var aa=1; type Coucou of exception; type Bonga of exception; func f() => integer begin z = 2; if SomeBoolean() then throw Coucou {}; else return 1; end; end; func g() => integer begin var a = 0; let b = SomeBoolean(); try a = f(); if b then throw Coucou {}; end; t = 2; if SomeBoolean() then throw Bonga {}; end; return a; catch when Coucou => if SomeBoolean() then a = 0; throw Coucou {}; end; when Bonga => if SomeBoolean() then a=0; throw Coucou {}; end; end; return a; end; func main() => integer begin var y = 0; try y = g(); return 0; catch when Coucou => return 0; end; end; locations [0:main.0.y;] forall 0:z=2 /\ 0:t=2 /\ ((0:g.0.a = 0 /\ 0:main.0.y = 0) \/ (0:g.0.a = 1 /\ 0:main.0.y = 1)) herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/throw-propagate.litmus.expected000066400000000000000000000005061475314470400330040ustar00rootroot00000000000000Test throw-propagate Required States 2 0:g.0.a=0; 0:t=2; 0:main.0.y=0; 0:z=2; 0:g.0.a=1; 0:t=2; 0:main.0.y=1; 0:z=2; Ok Witnesses Positive: 9 Negative: 0 Condition forall (0:z=2 /\ 0:t=2 /\ (0:g.0.a=0 /\ 0:main.0.y=0 \/ 0:g.0.a=1 /\ 0:main.0.y=1)) Observation throw-propagate Always 9 0 Hash=2671fa55986e76494683e69590408c27 herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/try-non-deterministic.litmus000066400000000000000000000005231475314470400323270ustar00rootroot00000000000000ASL try-non-deterministic { } type Coucou of exception {}; func g(a:integer) => integer begin try let b = SomeBoolean(); if b then throw Coucou {}; end; return a+1; catch when Coucou => return a+3; end; end; func main() => integer begin let x = g(0); return 0; end; locations [0:main.0.x;] try-non-deterministic.litmus.expected000066400000000000000000000003321475314470400340460ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-archTest try-non-deterministic Required States 2 0:main.0.x=1; 0:main.0.x=3; Ok Witnesses Positive: 2 Negative: 0 Condition forall (true) Observation try-non-deterministic Always 2 0 Hash=2dcc3ec62a279348fa075048307fdda4 herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/while-toofar.litmus000066400000000000000000000006221475314470400304600ustar00rootroot00000000000000ASL while-toofar { x = 0; 0:X1=x; } func T0(x:bits(64)) begin var s: integer = 0; var i = UInt(read_memory{32}(x)); let j = i; while i > 0 do s = s + i; i = i-1; end; end; func T1(x:bits(64)) begin for k = 1 to 3 do write_memory{32}(x,k[31:0]); end; end; func main() => integer begin let x = read_register(1); T0(x); T1(x); return 0; end; locations [0:T0.0.s;] herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/while-toofar.litmus.expected000066400000000000000000000003251475314470400322600ustar00rootroot00000000000000Test while-toofar Required States 3 0:T0.0.s=0; 0:T0.0.s=1; 0:T0.0.s=3; Loop Ok Witnesses Positive: 3 Negative: 0 Condition forall (true) Observation while-toofar Always 3 0 Hash=18af3c2d65d7c6d9c13ed93a21870763 herd-herdtools7-1ca343e/herd/tests/instructions/ASL-pseudo-arch/while-toofar.litmus.expected-warn000066400000000000000000000003711475314470400332260ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/ASL-pseudo-arch/while-toofar.litmus": unrolling limit exceeded at while loop at file "./herd/tests/instructions/ASL-pseudo-arch/while-toofar.litmus", line 13 to line 16 pruned, legal outcomes may be missing. herd-herdtools7-1ca343e/herd/tests/instructions/ASL/000077500000000000000000000000001475314470400224115ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/instructions/ASL/assign1.litmus000066400000000000000000000001611475314470400252130ustar00rootroot00000000000000ASL assign1 {} func main() => integer begin let x = 3; return 0; end; forall ( 0: main.0.x = 3 ) herd-herdtools7-1ca343e/herd/tests/instructions/ASL/assign1.litmus.expected000066400000000000000000000002701475314470400270140ustar00rootroot00000000000000Test assign1 Required States 1 0:main.0.x=3; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:main.0.x=3) Observation assign1 Always 1 0 Hash=239918d15065818c420ead18b4123575 herd-herdtools7-1ca343e/herd/tests/instructions/ASL/assign2.litmus000066400000000000000000000007021475314470400252150ustar00rootroot00000000000000ASL assign2 (* Tests global constants *) {} constant C1 : integer = 3; constant C2 : integer = C1 + 2; constant C3 : integer = C4 * C2; constant C4 : integer = C1; constant C5 : integer = - C2; func main() => integer begin let c1 = C1; let c2 = C2; let c3 = C3; let c4 = C4; let c5 = C5; return 0; end; forall ( 0: main.0.c1 = 3 /\ 0: main.0.c2 = 5 /\ 0: main.0.c3 = 15 /\ 0: main.0.c4 = 3 (* /\ 0: main.0.c5 = -5 *) ) herd-herdtools7-1ca343e/herd/tests/instructions/ASL/assign2.litmus.expected000066400000000000000000000004341475314470400270170ustar00rootroot00000000000000Test assign2 Required States 1 0:main.0.c1=3; 0:main.0.c2=5; 0:main.0.c3=15; 0:main.0.c4=3; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:main.0.c1=3 /\ 0:main.0.c2=5 /\ 0:main.0.c3=15 /\ 0:main.0.c4=3) Observation assign2 Always 1 0 Hash=98e2c8198685d716f084370c6d93dfe7 herd-herdtools7-1ca343e/herd/tests/instructions/ASL/assign3.litmus000066400000000000000000000017461475314470400252270ustar00rootroot00000000000000ASL assign3 (* Testing some slicing in constants *) {} constant CondEQ : bits(4) = 0x0[3:0]; constant CondNE : bits(4) = 0x1[3:0]; constant CondCS : bits(4) = 0x2[3:0]; constant CondCC : bits(4) = 0x3[3:0]; constant CondMI : bits(4) = 0x4[3:0]; constant CondPL : bits(4) = 0x5[3:0]; constant CondVS : bits(4) = 0x6[3:0]; constant CondVC : bits(4) = 0x7[3:0]; constant CondHI : bits(4) = 0x8[3:0]; constant CondLS : bits(4) = 0x9[3:0]; constant CondGE : bits(4) = 0xA[3:0]; constant CondLT : bits(4) = 0xB[3:0]; constant CondGT : bits(4) = 0xC[3:0]; constant CondLE : bits(4) = 0xD[3:0]; constant CondAL : bits(4) = 0xE[3:0]; constant CondNV : bits(4) = 0xF[3:0]; func main() => integer begin let eq = if CondEQ == '0000' then 1 else 0; let ne = if CondNE == '0001' then 1 else 0; let lt = if CondLT == '1011' then 1 else 0; let al = if CondAL == '1110' then 1 else 0; return 0; end; forall ( 0: main.0.eq = 1 /\ 0: main.0.ne = 1 /\ 0: main.0.lt = 1 /\ 0: main.0.al = 1 ) herd-herdtools7-1ca343e/herd/tests/instructions/ASL/assign3.litmus.expected000066400000000000000000000004321475314470400270160ustar00rootroot00000000000000Test assign3 Required States 1 0:main.0.al=1; 0:main.0.eq=1; 0:main.0.lt=1; 0:main.0.ne=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:main.0.eq=1 /\ 0:main.0.ne=1 /\ 0:main.0.lt=1 /\ 0:main.0.al=1) Observation assign3 Always 1 0 Hash=b403f3b0ce942458aa8e0a98b882c25e herd-herdtools7-1ca343e/herd/tests/instructions/ASL/bitfields1.litmus000066400000000000000000000011711475314470400256760ustar00rootroot00000000000000ASL bitfields1 {} type MyBits of bits(5) { [2:0] a, [3:1] b, [4:0] c, [4 ] e, }; func constructor(b: bits(5)) => MyBits begin return b; end; func get_b(b:MyBits) => bits(3) begin return b.b; end; func set_e(b:MyBits, e:bits(1)) => MyBits begin var b2 = b; b2.e = e; return b2; end; func main() => integer begin let a = constructor('10101'); let b = if get_b(a) == '010' then 1 else 0; let c = set_e(a, '0'); let c_c = c.c; let d = if c.e == '0' then 1 else 0; let e = if c.c == '00101' then 1 else 0; return 0; end; forall ( 0: main.0.b = 1 /\ 0: main.0.d = 1 /\ 0: main.0.e = 1 ) herd-herdtools7-1ca343e/herd/tests/instructions/ASL/bitfields1.litmus.expected000066400000000000000000000003721475314470400275000ustar00rootroot00000000000000Test bitfields1 Required States 1 0:main.0.b=1; 0:main.0.d=1; 0:main.0.e=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:main.0.b=1 /\ 0:main.0.d=1 /\ 0:main.0.e=1) Observation bitfields1 Always 1 0 Hash=f6bb584e083b68646159fb3791b28248 herd-herdtools7-1ca343e/herd/tests/instructions/ASL/case1.litmus000066400000000000000000000003761475314470400246520ustar00rootroot00000000000000ASL case1 {} func inv(i:integer) => integer begin case i of when 0 => return 1; when 1 => return 0; end; end; func main() => integer begin let a = inv(0); let b = inv(1); return 0; end; forall (0: main.0.a = 1 /\ 0: main.0.b = 0) herd-herdtools7-1ca343e/herd/tests/instructions/ASL/case1.litmus.expected000066400000000000000000000003221475314470400264410ustar00rootroot00000000000000Test case1 Required States 1 0:main.0.a=1; 0:main.0.b=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:main.0.a=1 /\ 0:main.0.b=0) Observation case1 Always 1 0 Hash=e5bb32d52148afa4e9154ccf882a1289 herd-herdtools7-1ca343e/herd/tests/instructions/ASL/concat.litmus000066400000000000000000000004131475314470400251150ustar00rootroot00000000000000ASL Concatenation { 0: X1 = x } func main () => integer begin let address = read_register (1); let data = read_memory{64}(address); write_register (1, '' :: data); write_register (2, data[0+:32] :: data[32+:32]); return 0; end; locations [ 0:X1; 0:X2]; herd-herdtools7-1ca343e/herd/tests/instructions/ASL/concat.litmus.expected000066400000000000000000000002761475314470400267240ustar00rootroot00000000000000Test Concatenation Required States 1 0:X1=0; 0:X2=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (true) Observation Concatenation Always 1 0 Hash=997fe11b177bc91173a4dfdf882b43e5 herd-herdtools7-1ca343e/herd/tests/instructions/ASL/data-return-01.litmus000066400000000000000000000002161475314470400263130ustar00rootroot00000000000000ASL no data return {} func f(x:integer) => integer begin return 3; end; func main() => integer begin let a = f (3); return 0; end; herd-herdtools7-1ca343e/herd/tests/instructions/ASL/data-return-01.litmus.expected000066400000000000000000000002311475314470400301100ustar00rootroot00000000000000Test no Required States 1 Ok Witnesses Positive: 1 Negative: 0 Condition forall (true) Observation no Always 1 0 Hash=baf58be4152af0fc668276b372af6b7b herd-herdtools7-1ca343e/herd/tests/instructions/ASL/data-return-02.litmus000066400000000000000000000002331475314470400263130ustar00rootroot00000000000000ASL no data return {} func f(x:integer) => integer begin let y = x; return 3; end; func main() => integer begin let a = f (3); return 0; end; herd-herdtools7-1ca343e/herd/tests/instructions/ASL/data-return-02.litmus.expected000066400000000000000000000002311475314470400301110ustar00rootroot00000000000000Test no Required States 1 Ok Witnesses Positive: 1 Negative: 0 Condition forall (true) Observation no Always 1 0 Hash=50d8bbf023547487542974b2cf857480 herd-herdtools7-1ca343e/herd/tests/instructions/ASL/double-load.litmus000066400000000000000000000004311475314470400260350ustar00rootroot00000000000000ASL double-load { int x = 3; int *y = x; 0: X1 = y; } func main() => integer begin let addr_y = read_register(1); let addr_x = read_memory{64}(addr_y); let data_x = read_memory{32}(addr_x); let three = UInt (data_x); return 0; end; forall (0: main.0.three = 3) herd-herdtools7-1ca343e/herd/tests/instructions/ASL/double-load.litmus.expected000066400000000000000000000003101475314470400276310ustar00rootroot00000000000000Test double-load Required States 1 0:main.0.three=3; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:main.0.three=3) Observation double-load Always 1 0 Hash=e6d7dfff400d582cb5789f1bf40d2b0b herd-herdtools7-1ca343e/herd/tests/instructions/ASL/enum-array.litmus000066400000000000000000000004361475314470400257330ustar00rootroot00000000000000ASL enum-arrays {} type Enum of enumeration {A, B, C}; type Arr of array[[Enum]] of integer; func main () => integer begin var arr: Arr; println(arr); arr[[A]] = 32; arr[[B]] = 64; arr[[C]] = 128; assert 2 * arr[[A]] + arr[[B]] == arr[[C]]; println(arr); return 0; end; herd-herdtools7-1ca343e/herd/tests/instructions/ASL/enum-array.litmus.expected000066400000000000000000000003151475314470400275270ustar00rootroot00000000000000{A:0,B:0,C:0,} {A:32,B:64,C:128,} Test enum-arrays Required States 1 Ok Witnesses Positive: 1 Negative: 0 Condition forall (true) Observation enum-arrays Always 1 0 Hash=be5ae986ade4b6f6e1a9fc497ec9008a herd-herdtools7-1ca343e/herd/tests/instructions/ASL/for1.litmus000066400000000000000000000003031475314470400245130ustar00rootroot00000000000000ASL for1 { } func main() => integer begin var s = 0; for i = 1 to 10 do s = s + i ; end; for i = 10 downto 1 do s = s + i ; end; return 0; end; forall (0: main.0.s = 110) herd-herdtools7-1ca343e/herd/tests/instructions/ASL/for1.litmus.expected000066400000000000000000000002661475314470400263230ustar00rootroot00000000000000Test for1 Required States 1 0:main.0.s=110; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:main.0.s=110) Observation for1 Always 1 0 Hash=bd45b66b820e45e40af86be6e26cee56 herd-herdtools7-1ca343e/herd/tests/instructions/ASL/func1.litmus000066400000000000000000000003201475314470400246570ustar00rootroot00000000000000ASL func1 {} func f(i:integer) => integer begin return i; end; func main() => integer begin let x = 3; let y = f(x); return 0; end; forall ( 0: main.0.x = 3 /\ 0: main.0.y = 3 ) herd-herdtools7-1ca343e/herd/tests/instructions/ASL/func1.litmus.expected000066400000000000000000000003221475314470400264610ustar00rootroot00000000000000Test func1 Required States 1 0:main.0.x=3; 0:main.0.y=3; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:main.0.x=3 /\ 0:main.0.y=3) Observation func1 Always 1 0 Hash=d9f68b63dd785d263d825c3b7f1144b0 herd-herdtools7-1ca343e/herd/tests/instructions/ASL/func2.litmus000066400000000000000000000005631475314470400246710ustar00rootroot00000000000000ASL func02 (* Some basic getters/setters *) {} getter X(i:integer) => integer begin return i; end; setter X(i:integer) = v:integer begin let internal_i = i; let internal_v = v; end; func main() => integer begin X(2) = 3; let x = X(4); return 0; end; forall ( 0: main.0.x = 4 /\ 0: X-1.0.internal_i = 2 /\ 0: X-1.0.internal_v = 3 ) herd-herdtools7-1ca343e/herd/tests/instructions/ASL/func2.litmus.expected000066400000000000000000000004221475314470400264630ustar00rootroot00000000000000Test func02 Required States 1 0:X-1.0.internal_i=2; 0:X-1.0.internal_v=3; 0:main.0.x=4; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:main.0.x=4 /\ 0:X-1.0.internal_i=2 /\ 0:X-1.0.internal_v=3) Observation func02 Always 1 0 Hash=c79fcc3a1e8aa899c9c67f2ee5534a46 herd-herdtools7-1ca343e/herd/tests/instructions/ASL/func3.litmus000066400000000000000000000016611475314470400246720ustar00rootroot00000000000000ASL func3 (* Test for getters setters. *) {} getter f1() => integer begin return 3; end; setter f1() = v : integer begin pass; // Hahaha, as if I was to do anything with the value end; getter f2(x:integer) => integer begin return f1() + x; end; setter f2(x:integer) = v : integer begin f1() = v + x; end; var f3_storage: integer = -1; var f4_storage: integer = -1; getter f3(x:integer) => integer begin return f3_storage; end; setter f3(x:integer) = v : integer begin f3_storage = x; end; getter f4(x:integer) => integer begin return f4_storage; end; setter f4(x:integer) = v : integer begin f4_storage = v; end; func main() => integer begin f1() = f1(); // f1 = f1; // Illegal let a = f1(); let b = f1(); let c = f2(4); f2(5) = 6; f3(12) = 13; f4(14) = 15; return 0; end; forall( 0: main.0.a = 3 /\ 0: main.0.b = 3 /\ 0: main.0.c = 7 /\ 0: f3_storage = 12 /\ 0: f4_storage = 15 ) herd-herdtools7-1ca343e/herd/tests/instructions/ASL/func3.litmus.expected000066400000000000000000000004701475314470400264670ustar00rootroot00000000000000Test func3 Required States 1 0:main.0.a=3; 0:main.0.b=3; 0:main.0.c=7; 0:f3_storage=12; 0:f4_storage=15; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:main.0.a=3 /\ 0:main.0.b=3 /\ 0:main.0.c=7 /\ 0:f3_storage=12 /\ 0:f4_storage=15) Observation func3 Always 1 0 Hash=30075d488e0fe6c178d31ab2f1a840f3 herd-herdtools7-1ca343e/herd/tests/instructions/ASL/func4.litmus000066400000000000000000000006231475314470400246700ustar00rootroot00000000000000ASL func4 (* Testing polymorphism on number of arguments. *) {} func f() => integer begin return 0; end; func f(x:integer) => integer begin return x; end; func f(x:integer, y:integer) => integer begin return x + y; end; func main() => integer begin let a = f(); let b = f(1); let c = f(2, 3); return 0; end; forall ( 0: main.0.a = 0 /\ 0: main.0.b = 1 /\ 0: main.0.c = 5 ) herd-herdtools7-1ca343e/herd/tests/instructions/ASL/func4.litmus.expected000066400000000000000000000003601475314470400264660ustar00rootroot00000000000000Test func4 Required States 1 0:main.0.a=0; 0:main.0.b=1; 0:main.0.c=5; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:main.0.a=0 /\ 0:main.0.b=1 /\ 0:main.0.c=5) Observation func4 Always 1 0 Hash=1725135c8954c6cee5841a83594eb5bf herd-herdtools7-1ca343e/herd/tests/instructions/ASL/globals.litmus000066400000000000000000000002471475314470400252760ustar00rootroot00000000000000ASL globals { } let b = '11' ; var x : integer = 2; func main() => integer begin assert (x == 2); x = 3; x = x+UInt(b); assert (x == 6); return 0 ; end;herd-herdtools7-1ca343e/herd/tests/instructions/ASL/globals.litmus.expected000066400000000000000000000002431475314470400270720ustar00rootroot00000000000000Test globals Required States 1 Ok Witnesses Positive: 1 Negative: 0 Condition forall (true) Observation globals Always 1 0 Hash=3e00d77ff2387cfd945f522c29c297f1 herd-herdtools7-1ca343e/herd/tests/instructions/ASL/no-main.litmus000066400000000000000000000001041475314470400252010ustar00rootroot00000000000000ASL no-main {} func blablabla() => integer begin return 3; end; herd-herdtools7-1ca343e/herd/tests/instructions/ASL/no-main.litmus.expected-failure000066400000000000000000000000611475314470400304300ustar00rootroot00000000000000Warning: ASL Error: Undefined identifier: 'main' herd-herdtools7-1ca343e/herd/tests/instructions/ASL/records.litmus000066400000000000000000000010131475314470400253040ustar00rootroot00000000000000ASL records {} type R of record { f1:integer, f2:boolean }; func constructor (a1:integer, a2:boolean) => R begin return R { f1 = a1, f2 = a2 }; end; func inv2 (r:R) => R begin r.f2 = !r.f2; return r; end; func read_f1 (r:R) => integer begin return r.f1; end; func read_f2 (r:R) => integer begin return r.f2; end; func main() => integer begin var r = constructor (3, TRUE); r = inv2(r); let x = read_f1(r); r = inv2(r); assert read_f2(r); return 0; end; forall (0: main.0.x = 3) herd-herdtools7-1ca343e/herd/tests/instructions/ASL/records.litmus.expected000066400000000000000000000002701475314470400271100ustar00rootroot00000000000000Test records Required States 1 0:main.0.x=3; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:main.0.x=3) Observation records Always 1 0 Hash=a525096870e854b910f1548037573a58 herd-herdtools7-1ca343e/herd/tests/instructions/ASL/unknown.litmus000066400000000000000000000004751475314470400253550ustar00rootroot00000000000000ASL Unknown variant = ASL (* Variant ASL to allow unresolved variables in result. *) {} func random_bool () => boolean begin return (ARBITRARY: boolean); end; func main () => integer begin var x: boolean; if random_bool () then x = 1; else x = 0; end; return 0; end; locations [0: main.0.x] herd-herdtools7-1ca343e/herd/tests/instructions/ASL/unknown.litmus.expected000066400000000000000000000002761475314470400271540ustar00rootroot00000000000000Test Unknown Required States 2 0:main.0.x=0; 0:main.0.x=1; Ok Witnesses Positive: 2 Negative: 0 Condition forall (true) Observation Unknown Always 2 0 Hash=4820ca8b37c442cde159de5fd3d5972e herd-herdtools7-1ca343e/herd/tests/instructions/ASL/while1.litmus000066400000000000000000000002771475314470400250470ustar00rootroot00000000000000ASL while1 { } func main() => integer begin var x = 3 ; var y = 0 ; while x > 0 do y = y + 2 ; x = x - 1 ; end; return 0; end; forall (0: main.0.y = 6 /\ 0: main.0.x=0) herd-herdtools7-1ca343e/herd/tests/instructions/ASL/while1.litmus.expected000066400000000000000000000003241475314470400266400ustar00rootroot00000000000000Test while1 Required States 1 0:main.0.x=0; 0:main.0.y=6; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:main.0.y=6 /\ 0:main.0.x=0) Observation while1 Always 1 0 Hash=af6eec1dc3e63f59fe6450e6ac6316bf herd-herdtools7-1ca343e/herd/tests/instructions/ASL/while2.litmus000066400000000000000000000003141475314470400250400ustar00rootroot00000000000000ASL while2 { } func main() => integer begin var x: integer; repeat while FALSE do let z = 2 ; end; x = 2; until x >= 2 ; return 0; end; forall (0:main.0.z=0 /\ 0:main.0.x=2) herd-herdtools7-1ca343e/herd/tests/instructions/ASL/while2.litmus.expected000066400000000000000000000003241475314470400266410ustar00rootroot00000000000000Test while2 Required States 1 0:main.0.x=2; 0:main.0.z=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:main.0.z=0 /\ 0:main.0.x=2) Observation while2 Always 1 0 Hash=d8cc7b9e128d32e53e4739fa5bf4ff73 herd-herdtools7-1ca343e/herd/tests/instructions/ASL/write_mem.litmus000066400000000000000000000003251475314470400256400ustar00rootroot00000000000000ASL write-mem { 0: X1 = x; 0: X2 = 3; x = 0 } func main() => integer begin let address = read_register (1); let data = read_register (2); write_memory{64}(address, data); return 0; end; forall (x = 3) herd-herdtools7-1ca343e/herd/tests/instructions/ASL/write_mem.litmus.expected000066400000000000000000000003561475314470400274440ustar00rootroot00000000000000Test write-mem Required States 1 [x]='0000000000000000000000000000000000000000000000000000000000000011'; No Witnesses Positive: 0 Negative: 1 Condition forall ([x]=3) Observation write-mem Never 0 1 Hash=e9513c0291b45e774106925af72a677e herd-herdtools7-1ca343e/herd/tests/instructions/C/000077500000000000000000000000001475314470400221545ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/instructions/C/C01.litmus000066400000000000000000000001111475314470400237270ustar00rootroot00000000000000C C01 { x = 1 } P0 (const int* x) { int r0 = *x; } forall (0:r0=1) herd-herdtools7-1ca343e/herd/tests/instructions/C/C01.litmus.expected000066400000000000000000000002501475314470400255330ustar00rootroot00000000000000Test C01 Required States 1 0:r0=0x1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:r0=0x1) Observation C01 Always 1 0 Hash=f26e77b9ef2528a6e6c9757a77f150a1 herd-herdtools7-1ca343e/herd/tests/instructions/C/C02.litmus000066400000000000000000000001421475314470400237340ustar00rootroot00000000000000C C02 {} P0 (const int* y,volatile int* x) { int r0 = *x; *y = 1; } forall (0:r0=1 /\ y=1) herd-herdtools7-1ca343e/herd/tests/instructions/C/C02.litmus.expected000066400000000000000000000002731475314470400255410ustar00rootroot00000000000000Test C02 Required States 1 0:r0=0x0; [y]=0x1; No Witnesses Positive: 0 Negative: 1 Condition forall (0:r0=0x1 /\ [y]=0x1) Observation C02 Never 0 1 Hash=d92b65c8b850301b8f1b811599b2f905 herd-herdtools7-1ca343e/herd/tests/instructions/C/C03.litmus000066400000000000000000000001361475314470400237400ustar00rootroot00000000000000C C03 {} P0 (int* y) { atomic_fetch_add_explicit(y,1,memory_order_seq_cst); } forall y=1 herd-herdtools7-1ca343e/herd/tests/instructions/C/C03.litmus.expected000066400000000000000000000002461475314470400255420ustar00rootroot00000000000000Test C03 Required States 1 [y]=0x1; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([y]=0x1) Observation C03 Always 1 0 Hash=71a98e010b15b2b87bfe01c34e457390 herd-herdtools7-1ca343e/herd/tests/instructions/C/C04.litmus000066400000000000000000000002321475314470400237360ustar00rootroot00000000000000C C04 (* Tests 128-bit types *) { } P0 (__int128_t *y, __uint128_t *a) { __int128_t r1 = *y; __uint128_t r3 = *a; } forall (0:r1 = 0 /\ 0:r3 = 0) herd-herdtools7-1ca343e/herd/tests/instructions/C/C04.litmus.expected000066400000000000000000000002761475314470400255460ustar00rootroot00000000000000Test C04 Required States 1 0:r1=0x0; 0:r3=0x0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:r1=0x0 /\ 0:r3=0x0) Observation C04 Always 1 0 Hash=8b9618e5572a22c7e8d1ced9c7b99fe8 herd-herdtools7-1ca343e/herd/tests/instructions/C/C05.litmus000066400000000000000000000001311475314470400237350ustar00rootroot00000000000000C C05 Variant=S128 { __int128_t x=1; } P0 (__int128_t *x) { *x = 0; } forall ([x]=0) herd-herdtools7-1ca343e/herd/tests/instructions/C/C05.litmus.expected000066400000000000000000000002461475314470400255440ustar00rootroot00000000000000Test C05 Required States 1 [x]=0x0; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=0x0) Observation C05 Always 1 0 Hash=db772c002d727bd43e0889f42282f9f6 herd-herdtools7-1ca343e/herd/tests/instructions/C/C06.litmus000066400000000000000000000001331475314470400237400ustar00rootroot00000000000000C C06 Variant=S128 { __uint128_t x; } P0 (__uint128_t *x) { *x = 1 ; } forall ([x]=1) herd-herdtools7-1ca343e/herd/tests/instructions/C/C06.litmus.expected000066400000000000000000000002461475314470400255450ustar00rootroot00000000000000Test C06 Required States 1 [x]=0x1; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=0x1) Observation C06 Always 1 0 Hash=b442457ce55409f351e7a43e7132dc03 herd-herdtools7-1ca343e/herd/tests/instructions/C/C07.litmus000066400000000000000000000001221475314470400237370ustar00rootroot00000000000000C C07 Variant=S128 {} P0 (int128_t *x) { int128_t r0 = *x; } forall 0:r0 = 0 herd-herdtools7-1ca343e/herd/tests/instructions/C/C07.litmus.expected-failure000066400000000000000000000001761475314470400271750ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/C/C07.litmus", line 6, characters 4-12: unexpected 'int128_t' (in prog) (User error) herd-herdtools7-1ca343e/herd/tests/instructions/C/C08.litmus000066400000000000000000000006011475314470400237420ustar00rootroot00000000000000C C08 (* Test to ensure diy generated tests are accepted by herd - int128*) {__int128 y; __int128 x;} P0 (volatile __int128* y,volatile __int128* x) { __int128 r0 = *x; atomic_thread_fence(memory_order_relaxed); *y = 1; } P1 (volatile __int128* y,volatile __int128* x) { __int128 r0 = *y; atomic_thread_fence(memory_order_relaxed); *x = 1; } exists (0:r0=1 /\ 1:r0=1) herd-herdtools7-1ca343e/herd/tests/instructions/C/C08.litmus.expected000066400000000000000000000003641475314470400255500ustar00rootroot00000000000000Test C08 Allowed States 3 0:r0=0x0; 1:r0=0x0; 0:r0=0x0; 1:r0=0x1; 0:r0=0x1; 1:r0=0x0; Undef Witnesses Positive: 0 Negative: 3 Flag *undef* Condition exists (0:r0=0x1 /\ 1:r0=0x1) Observation C08 Never 0 3 Hash=df8f2c22043bedfe26ba47135c84a3b0 herd-herdtools7-1ca343e/herd/tests/instructions/C/C11.litmus000066400000000000000000000006121475314470400237360ustar00rootroot00000000000000C C11 (* Test to ensure _Atomic __int128 x = 0; is parsed**) {__int128 y; __int128 x; _Atomic __int128 z = 0;} P0 (volatile __int128* y,volatile __int128* x) { __int128 r0 = *x; atomic_thread_fence(memory_order_relaxed); *y = 1; } P1 (volatile __int128* y,volatile __int128* x) { __int128 r0 = *y; atomic_thread_fence(memory_order_relaxed); *x = 1; } exists (0:r0=1 /\ 1:r0=1) herd-herdtools7-1ca343e/herd/tests/instructions/C/C11.litmus.expected000066400000000000000000000003641475314470400255420ustar00rootroot00000000000000Test C11 Allowed States 3 0:r0=0x0; 1:r0=0x0; 0:r0=0x0; 1:r0=0x1; 0:r0=0x1; 1:r0=0x0; Undef Witnesses Positive: 0 Negative: 3 Flag *undef* Condition exists (0:r0=0x1 /\ 1:r0=0x1) Observation C11 Never 0 3 Hash=fdb5bbc868eabfecbe24a5eeab655a7d herd-herdtools7-1ca343e/herd/tests/instructions/C/C12.litmus000066400000000000000000000001221475314470400237330ustar00rootroot00000000000000C C12 { int x = 0 } P0(int *x) { *x = 1; } regions: x:PROP forall ( x = 1 ) herd-herdtools7-1ca343e/herd/tests/instructions/C/C12.litmus.expected000066400000000000000000000002461475314470400255420ustar00rootroot00000000000000Test C12 Required States 1 [x]=0x1; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=0x1) Observation C12 Always 1 0 Hash=17c3538e1d8870eb1bb0ac35f89243af herd-herdtools7-1ca343e/herd/tests/instructions/C/C13.litmus000066400000000000000000000007161475314470400237450ustar00rootroot00000000000000C C13 (* Forbidden by rc11, allowed by most C11 models that tolerate oota *) { x = 0; y = 0; } P0(atomic_int *x, atomic_int *y) { int r1 = atomic_load_explicit(y, memory_order_relaxed); atomic_store_explicit(x, r1, memory_order_relaxed); int r2 = (r1^r1)+r1; } P1(atomic_int *x, atomic_int *y) { int r4 = atomic_load_explicit(x, memory_order_relaxed); atomic_store_explicit(y, r4, memory_order_relaxed); } locations [0:r2; 1:r4;] exists 0:r1 != 0 herd-herdtools7-1ca343e/herd/tests/instructions/C/C13.litmus.expected000066400000000000000000000003001475314470400255320ustar00rootroot00000000000000Test C13 Allowed States 1 0:r1=0x0; 0:r2=0x0; 1:r4=0x0; No Witnesses Positive: 0 Negative: 3 Condition exists (not (0:r1=0x0)) Observation C13 Never 0 3 Hash=45b06aedc4caf5ef4fdf494a986f8199 herd-herdtools7-1ca343e/herd/tests/instructions/C/c.cfg000066400000000000000000000000621475314470400230550ustar00rootroot00000000000000hexa true model herd/libdir/rc11.cat variant S128 herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/000077500000000000000000000000001475314470400225425ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/A000.litmus000066400000000000000000000001271475314470400244010ustar00rootroot00000000000000MIPS A000 (* Tests MIPS automatic testing *) {} P0; move $v0, $v1; forall 0:v0 = 0 herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/A000.litmus.expected000066400000000000000000000002461475314470400262030ustar00rootroot00000000000000Test A000 Required States 1 0:$2=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:$2=0) Observation A000 Always 1 0 Hash=1adc8fedc9a06151f8c5f9ace89ae992 herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/A001.litmus000066400000000000000000000001251475314470400244000ustar00rootroot00000000000000MIPS A001 (* Test MIPS Lui instruction *) {} P0; lui $a0,1; forall 0:a0 = 0x10000 herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/A001.litmus.expected000066400000000000000000000002561475314470400262050ustar00rootroot00000000000000Test A001 Required States 1 0:$4=65536; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:$4=65536) Observation A001 Always 1 0 Hash=0b5207526f2604aed1ba910c050cf274 herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/A002.litmus000066400000000000000000000006321475314470400244040ustar00rootroot00000000000000MIPS A002 (* Parse Non$ registers*) { 0:zero = 0; 0:at=0; 0:v0=0; 0:v1=0; 0:a0 = 0; 0:a1=0; 0:a2=0; 0:a3=0; 0:t0 = 0; 0:t1 = 0; 0:t2 = 0; 0:t3=0; 0:t4=0; 0:t5=0; 0:t6=0; 0:t7=0; 0:s0 = 0; 0:s1=0; 0:s2=0; 0:s3=0; 0:s4=0; 0:s5=0; 0:s6=0; 0:s7=0; 0:t8=0; 0:t9=0; 0:k0=0; 0:k1=0; 0:gp=0; 0:sp=0; 0:fp=0; 0:ra=0; 0:a4=0; 0:a5=0; 0:a6=0; 0:a7=0; } P0; move v0, v1; move $v0, $v1; forall 0:v0 = 0 herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/A002.litmus.expected000066400000000000000000000002461475314470400262050ustar00rootroot00000000000000Test A002 Required States 1 0:$2=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:$2=0) Observation A002 Always 1 0 Hash=eeb5d27692ab3f5a8ae4598467d43a23 herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/A003.litmus000066400000000000000000000001031475314470400243760ustar00rootroot00000000000000MIPS A003 (* Parse NOP instruction *) {} P0; nop; forall 0:a0=0 herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/A003.litmus.expected000066400000000000000000000002461475314470400262060ustar00rootroot00000000000000Test A003 Required States 1 0:$4=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:$4=0) Observation A003 Always 1 0 Hash=7dbd8e4fdafc2b299a8e4b02a379dcaa herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/A004.litmus000066400000000000000000000002011475314470400243760ustar00rootroot00000000000000MIPS A004 (* Test DADDU DADDIU instructions *) {} P0; daddu $v0, $v1, $a0; daddiu $v0, $v1, 2; forall (0:v0 = 2 /\ 0:v1 = 0) herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/A004.litmus.expected000066400000000000000000000002701475314470400262040ustar00rootroot00000000000000Test A004 Required States 1 0:$2=2; 0:$3=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:$2=2 /\ 0:$3=0) Observation A004 Always 1 0 Hash=d1f2e271118554bb2668dea9cf458795 herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/A005.litmus000066400000000000000000000001531475314470400244050ustar00rootroot00000000000000MIPS A005 (* test ld instruction *) { int64_t 0:a1 = x; int64_t x=1} P0; ld a0, 0(a1); forall 0:a0 = 1 herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/A005.litmus.expected000066400000000000000000000002461475314470400262100ustar00rootroot00000000000000Test A005 Required States 1 0:$4=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:$4=1) Observation A005 Always 1 0 Hash=d33fef1633282273cf65bd2cad3b64fb herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/A006.litmus000066400000000000000000000002301475314470400244020ustar00rootroot00000000000000MIPS A006 (* test JR instruction *) { 0:a0 = P0:L1; 0:a2 = 2; 0:a1 = 0} P0; b L2; nop; move $a1, $a2; L2: jr a0; nop; L1: nop; forall 0:a1=0 herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/A006.litmus.expected000066400000000000000000000002461475314470400262110ustar00rootroot00000000000000Test A006 Required States 1 0:$5=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:$5=0) Observation A006 Always 1 0 Hash=9cc430355a613356b27b40abfd69450d herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/A007.litmus000066400000000000000000000001401475314470400244030ustar00rootroot00000000000000MIPS A007 (* test Dext instr*) { 0:a0=0x10000; } P0; dext a1, a0, 16, 1; forall 0:a1 = 0x1 herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/A007.litmus.expected000066400000000000000000000002461475314470400262120ustar00rootroot00000000000000Test A007 Required States 1 0:$5=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:$5=1) Observation A007 Always 1 0 Hash=728146fd0b742578e9c74d0619cb9fdd herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/A008.litmus000066400000000000000000000001241475314470400244060ustar00rootroot00000000000000MIPS A008 (* test dsll instr *) { 0:a1=1} P0; dsll a0, a1, 1; forall 0:a0 = 2 herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/A008.litmus.expected000066400000000000000000000002461475314470400262130ustar00rootroot00000000000000Test A008 Required States 1 0:$4=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:$4=2) Observation A008 Always 1 0 Hash=aaf6db304595e21f10c724bd8f6e849b herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/A009.litmus000066400000000000000000000012501475314470400244100ustar00rootroot00000000000000MIPS A009 Variant=telechat { [P1_r0]=0;[x]=0;[y]=0; uint64_t %P0_x=x;uint64_t %P0_y=y; uint64_t %P1_P1_r0=P1_r0; uint64_t %P1_x=x;uint64_t %P1_y=y } P0 | P1 ; li $3,2 | li $3,1 ; sync | lw $2,0(%P1_y) ; sw $3,0(%P0_x) | beq $2,$3,L0x70 ; li $3,1 | sw $2,0(%P1_P1_r0) ; sw $3,0(%P0_y) | jr $31 ; jr $31 | L0x70: ; | sync ; | sw $3,0(%P1_x) ; | sw $2,0(%P1_P1_r0) ; | jr $31 ; exists ([x]=2 /\ P1_r0=1) herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/A009.litmus.expected000066400000000000000000000003421475314470400262110ustar00rootroot00000000000000Test A009 Allowed States 3 [P1_r0]=0; [x]=2; [P1_r0]=1; [x]=1; [P1_r0]=1; [x]=2; Ok Witnesses Positive: 1 Negative: 2 Condition exists ([x]=2 /\ [P1_r0]=1) Observation A009 Sometimes 1 2 Hash=c7da1d6192a66938223af0c2bfe1e304 herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/L00.litmus000066400000000000000000000002241475314470400243320ustar00rootroot00000000000000MIPS L00 { uint64_t 0:a0; uint64_t 0:a1; } P0 ; lui $a0,65535 ; li $a1,65535 ; locations [0:a1;] forall 0:a0 = -65536 /\ 0:a1=65535 herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/L00.litmus.expected000066400000000000000000000003261475314470400261350ustar00rootroot00000000000000Test L00 Required States 1 0:$4=18446744073709486080; 0:$5=65535; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:$4=-65536 /\ 0:$5=65535) Observation L00 Always 1 0 Hash=d74d5f511039a20800a02e7376b80115 herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/L01.litmus000066400000000000000000000003111475314470400243300ustar00rootroot00000000000000MIPS L01 { uint64_t 0:v0; int64_t 0:v1; uint64_t 0:t0; } P0 ; daddiu $v0,$v0,65535 ; daddiu $v1,$v1,65535 ; addiu $t0,$t0,65535 ; locations [0:v0; 0:v1; 0:t0; ] forall 0:v0 = -1 herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/L01.litmus.expected000066400000000000000000000003341475314470400261350ustar00rootroot00000000000000Test L01 Required States 1 0:$2=18446744073709551615; 0:$3=-1; 0:$8=18446744073709551615; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:$2=-1) Observation L01 Always 1 0 Hash=40f7c109822251a6a8575623897de3d2 herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/L02.litmus000066400000000000000000000002601475314470400243340ustar00rootroot00000000000000MIPS L02 { uint64_t x = 0xabcdef; 0:t0=x; uint64_t 0:t1; uint64_t 0:t2; } P0 ; ld $t1,0($t0) ; dext $t2,$t1,3,16 ; locations [0:t2;] forall 0:t2 = 31165 herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/L02.litmus.expected000066400000000000000000000002561475314470400261410ustar00rootroot00000000000000Test L02 Required States 1 0:$10=31165; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:$10=31165) Observation L02 Always 1 0 Hash=ca9e436c25620d6d8c605b2d77f627fd herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/L03.litmus000066400000000000000000000001361475314470400243370ustar00rootroot00000000000000MIPS L03 { int x=-1; 0:v0=x; int64_t 0:v1; } P0 ; lw $v1,0($v0) ; forall 0:v1=-1 herd-herdtools7-1ca343e/herd/tests/instructions/MIPS/L03.litmus.expected000066400000000000000000000002461475314470400261410ustar00rootroot00000000000000Test L03 Required States 1 0:$3=-1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:$3=-1) Observation L03 Always 1 0 Hash=03786784e438a0ca487e35071fb1d761 herd-herdtools7-1ca343e/herd/tests/instructions/PPC/000077500000000000000000000000001475314470400224145ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A000.litmus000066400000000000000000000000741475314470400242540ustar00rootroot00000000000000PPC A000 (* Test CI works *) {} P0; nop; forall 0:r0 = 0 herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A000.litmus.expected000066400000000000000000000002461475314470400260550ustar00rootroot00000000000000Test A000 Required States 1 0:r0=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:r0=0) Observation A000 Always 1 0 Hash=9697a8f62bb095c6209ec10f0eb77308 herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A001.litmus000066400000000000000000000001211475314470400242460ustar00rootroot00000000000000PPC A001 (* Test LIS instruction *) {} P0; lis r0, 1; forall 0:r0 = 0x10000 herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A001.litmus.expected000066400000000000000000000002561475314470400260570ustar00rootroot00000000000000Test A001 Required States 1 0:r0=65536; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:r0=65536) Observation A001 Always 1 0 Hash=505b36b29a59339a441f482c0294f18a herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A002.litmus000066400000000000000000000014411475314470400242550ustar00rootroot00000000000000PPC A002 (* test hwsync instr *) (*****************************************************************) (* Compiler: *) (* clang-11 -c -g -O3 -pthread --std=c11 --target=powerpc-linux-gnu*) (*****************************************************************) { [P0_r0]=0;[P1_r0]=0;[x]=0;[y]=0;uint64_t %P0_P0_r0=P0_r0;uint64_t %P0_x=x;uint64_t %P0_y=y;uint64_t %P1_P1_r0=P1_r0;uint64_t %P1_x=x;uint64_t %P1_y=y } P0 | P1 ; li r4,1 | li r4,1 ; stw r4,0(%P0_x) | stw r4,0(%P1_y) ; hwsync | hwsync ; lwz r3,0(%P0_y) | lwz r3,0(%P1_x) ; stw r3,0(%P0_P0_r0) | stw r3,0(%P1_P1_r0) ; exists (P0_r0=0 /\ P1_r0=0) herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A002.litmus.expected000066400000000000000000000003561475314470400260610ustar00rootroot00000000000000Test A002 Allowed States 3 [P0_r0]=0; [P1_r0]=1; [P0_r0]=1; [P1_r0]=0; [P0_r0]=1; [P1_r0]=1; No Witnesses Positive: 0 Negative: 3 Condition exists ([P0_r0]=0 /\ [P1_r0]=0) Observation A002 Never 0 3 Hash=d94e9aab81affd834e43c4085405e4c8 herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A003.litmus000066400000000000000000000001441475314470400242550ustar00rootroot00000000000000PPC A003 (* Test Addis instruction*) { int 0:r0 = 0 } P0; addis r0, r0, 1; forall 0:r0 = 65536 herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A003.litmus.expected000066400000000000000000000002561475314470400260610ustar00rootroot00000000000000Test A003 Required States 1 0:r0=65536; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:r0=65536) Observation A003 Always 1 0 Hash=2c504c6ee49f6d9ef53d909c6f02bb64 herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A004.litmus000066400000000000000000000000671475314470400242620ustar00rootroot00000000000000PPC A004 (* Test NOP *) {} P0; nop; forall 0:r0 = 0 herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A004.litmus.expected000066400000000000000000000002461475314470400260610ustar00rootroot00000000000000Test A004 Required States 1 0:r0=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:r0=0) Observation A004 Always 1 0 Hash=9697a8f62bb095c6209ec10f0eb77308 herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A005.litmus000066400000000000000000000002401475314470400242540ustar00rootroot00000000000000PPC A005 (* Test LWA *) { 0:r1 = x; x = -1; int64_t 0:r0; int64_t 0:r2; } P0; lwa r0, 0(r1) ; lwz r2, 0(r1) ; forall 0:r0 = -1 /\ 0:r2 <> -1 herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A005.litmus.expected000066400000000000000000000003121475314470400260540ustar00rootroot00000000000000Test A005 Required States 1 0:r0=-1; 0:r2=4294967295; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:r0=-1 /\ not (0:r2=-1)) Observation A005 Always 1 0 Hash=3277c7026d4d160c200e872073551105 herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A006.litmus000066400000000000000000000003101475314470400242530ustar00rootroot00000000000000PPC A006 (* Test LWAX instruction*) { 0:r0 = 0; 0:r1 = x; uint32_t x = 0xffffffff; int64_t 0:r2; int64_t 0:r3; } P0; lwax r2, r0, r1; lwzx r3, r0, r1; forall 0:r2 = -1 /\ 0:r3 = 0xffffffff herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A006.litmus.expected000066400000000000000000000003141475314470400260570ustar00rootroot00000000000000Test A006 Required States 1 0:r2=-1; 0:r3=4294967295; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:r2=-1 /\ 0:r3=4294967295) Observation A006 Always 1 0 Hash=110e6b64a73ded4540e9d15080165799 herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A007.litmus000066400000000000000000000024641475314470400242700ustar00rootroot00000000000000PPC A007 Variant=telechat (* test blr *) (*****************************************************************) (* Compiler: *) (* powerpc64le-linux-gnu-gcc-10 -c -g -O1 -pthread --std=c11 -ffreestanding -mabi=elfv1 -fno-section-anchors*) (*****************************************************************) { [P0_r0]=0;[P1_r0]=0;[x]=0;[y]=0; 0:r0 = x; 0:r1 = y; 0:r2 = P0_r0; 1:r0 = y; 1:r1 = x; 1:r2 = P1_r0; } P0 | P1 ; hwsync | hwsync ; lwz r9,0(r0) | lwz r9,0(r0) ; cmpw r9,r9 | cmpw r9,r9 ; b L0x18 | b L0x6c ; L0x18: isync | L0x6c: isync ; clrldi r9,r9,32 | extsw r10, r9 ; lwsync | cmpwi r9,1 ; hwsync | beq L0x8c ; li r8,1 | L0x7c: ; stw r8,0(r1) | stw r10,0(r2) ; stw r9,0(r2) | blr ; | L0x8c: ; | li r8,1 ; | stw r8,0(r1) ; | b L0x7c ; exists not (P0_r0=1 /\ P1_r0=1) herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A007.litmus.expected000066400000000000000000000003371475314470400260650ustar00rootroot00000000000000Test A007 Allowed States 2 [P0_r0]=0; [P1_r0]=0; [P0_r0]=0; [P1_r0]=1; Ok Witnesses Positive: 2 Negative: 0 Condition exists (not ([P0_r0]=1 /\ [P1_r0]=1)) Observation A007 Always 2 0 Hash=4bbfcab3f0e8578a8c6e2411b8ff4d44 herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A008.litmus000066400000000000000000000002161475314470400242620ustar00rootroot00000000000000PPC A008 (* test extsw *) { int x = -1 ; 0:r2=x; int64_t 0:r0 ; 0:r1 = -1 ; } P0; lwz r1,0(r2) ; extsw r0, r1 ; forall 0:r0 = -1 herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A008.litmus.expected000066400000000000000000000002501475314470400260600ustar00rootroot00000000000000Test A008 Required States 1 0:r0=-1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:r0=-1) Observation A008 Always 1 0 Hash=7b0b324d482e93f41e11de3342bea580 herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A009.litmus000066400000000000000000000002371475314470400242660ustar00rootroot00000000000000PPC A009 (* test CLRLDI instr *) { int 0:r11 = 0x0; int 0:r31 = 1; 0:r9 = 1 } P0; clrldi r11, r31, 32; clrldi r9, r9, 32; forall 0:r11 = 1 /\ 0:r9 = 1 herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A009.litmus.expected000066400000000000000000000002721475314470400260650ustar00rootroot00000000000000Test A009 Required States 1 0:r9=1; 0:r11=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:r11=1 /\ 0:r9=1) Observation A009 Always 1 0 Hash=9ef5fe48464d5cf42d6e263e7ef93ef6 herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A010.litmus000066400000000000000000000001701475314470400242520ustar00rootroot00000000000000PPC A010 (* Test Cmplwi instr *) { 0:r0 = 2 } P0; cmplwi r0, 2; beq L1; addi r0, r0, 1; L1: nop; forall 0:r0=2 herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A010.litmus.expected000066400000000000000000000002461475314470400260560ustar00rootroot00000000000000Test A010 Required States 1 0:r0=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:r0=2) Observation A010 Always 1 0 Hash=7805d6e30c2a9168bf4783dee83e383c herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A011.litmus000066400000000000000000000001501475314470400242510ustar00rootroot00000000000000PPC A011 (* Test rlwinm and wlwimi instructions *) {} P0; rlwinm r3, r4, 5, 0, 31; forall 0:r3 = 0 herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A011.litmus.expected000066400000000000000000000002461475314470400260570ustar00rootroot00000000000000Test A011 Required States 1 0:r3=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:r3=0) Observation A011 Always 1 0 Hash=a2b925fb3895cf50fe0e96ae5027f3b0 herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A013.litmus000066400000000000000000000003451475314470400242610ustar00rootroot00000000000000PPC A013 (* Test rlwinm and wlwimi instructions *) { uint64_t 0:r6; } P0; li r4,-1 ; rlwinm r3, r4, 4, 30, 31 ; rlwinm r5, r4, 0, 30, 31 ; rlwinm r6, r4, 16, 0, 15 ; forall 0:r3 = 3 /\ 0:r5=3 /\ 0:r6=0xffff0000 herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A013.litmus.expected000066400000000000000000000003341475314470400260570ustar00rootroot00000000000000Test A013 Required States 1 0:r3=3; 0:r5=3; 0:r6=4294901760; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:r3=3 /\ 0:r5=3 /\ 0:r6=4294901760) Observation A013 Always 1 0 Hash=a6da7ef7ad3e3bdd4024b9716a455478 herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A014.litmus000066400000000000000000000004031475314470400242550ustar00rootroot00000000000000PPC A014 (* Test ROT32 vs ROT64 *) { 0:r3=0xaaaaaaaaaaaaaaaa; 0:r5=0xaaaaaaaaaaaaaaaa; 0:r6=0xaaaaaaaaaaaaaaaa; } P0; li r4,-1 ; rlwimi r3, r4, 4, 30, 31 ; rlwimi r5, r4, 0, 30, 31 ; rlwimi r6, r4, 16, 0, 15 ; locations [0:r3; 0:r5; 0:r6;] herd-herdtools7-1ca343e/herd/tests/instructions/PPC/A014.litmus.expected000066400000000000000000000003151475314470400260570ustar00rootroot00000000000000Test A014 Required States 1 0:r3=-1431655765; 0:r5=-1431655765; 0:r6=-21846; Ok Witnesses Positive: 1 Negative: 0 Condition forall (true) Observation A014 Always 1 0 Hash=f5fd1f3a6656a0390699cb32c0ad1af0 herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/000077500000000000000000000000001475314470400226605ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A001.litmus000066400000000000000000000001001475314470400245070ustar00rootroot00000000000000RISCV A001 (*Test NOP instr *) { x=0 } P0; nop; forall (x=0) herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A001.litmus.expected000066400000000000000000000002441475314470400263200ustar00rootroot00000000000000Test A001 Required States 1 [x]=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=0) Observation A001 Always 1 0 Hash=c4a3be38342b6b819f0d792f2ec53119 herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A003.litmus000066400000000000000000000001321475314470400245160ustar00rootroot00000000000000RISCV A003 (* Test SRLI Instruction*) { 0:a0 = 4} P0; srli a0, a0, 1; forall 0:a0 = 2 herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A003.litmus.expected000066400000000000000000000002501475314470400263170ustar00rootroot00000000000000Test A003 Required States 1 0:x10=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:x10=2) Observation A003 Always 1 0 Hash=0f76c62e95e0af150e8776b7b0859e14 herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A004.litmus000066400000000000000000000001211475314470400245150ustar00rootroot00000000000000RISCV A004 (*test MV instruction*) { 0:a1 = 1 } P0; MV a0, a1; forall 0:a0=1 herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A004.litmus.expected000066400000000000000000000002501475314470400263200ustar00rootroot00000000000000Test A004 Required States 1 0:x10=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:x10=1) Observation A004 Always 1 0 Hash=e78e73fbb56c1ec96e58fdadbb61f9c0 herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A005.litmus000066400000000000000000000001031475314470400245160ustar00rootroot00000000000000RISCV A005 (* Test NOP instruction*) {} P0; NOP; forall 0:a0=0 herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A005.litmus.expected000066400000000000000000000002501475314470400263210ustar00rootroot00000000000000Test A005 Required States 1 0:x10=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:x10=0) Observation A005 Always 1 0 Hash=7dbd8e4fdafc2b299a8e4b02a379dcaa herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A006.litmus000066400000000000000000000001301475314470400245170ustar00rootroot00000000000000RISCV A006 (* Test sext.w instruction*) { 0:a1 = 2} P0; sext.w a0, a1; forall 0:a0=2 herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A006.litmus.expected000066400000000000000000000002501475314470400263220ustar00rootroot00000000000000Test A006 Required States 1 0:x10=2; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:x10=2) Observation A006 Always 1 0 Hash=b34f92984fa6bea21a79bed7c0a0765e herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A007.litmus000066400000000000000000000001701475314470400245240ustar00rootroot00000000000000RISCV A007 (* Test AUIPC Instr - not handled like ADRP in AArch64 - emit error *) {} P0; auipc a0, 2; forall 0:a0=1 herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A007.litmus.expected-failure000066400000000000000000000001521475314470400277510ustar00rootroot00000000000000Warning: File "./herd/tests/instructions/RISCV/A007.litmus": RISCV, instruction 'auipc x10,2' not handled herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A008.litmus000066400000000000000000000001261475314470400245260ustar00rootroot00000000000000RISCV A008 (* Test LUI instruction*) { 0:a0 = 0 } P0; lui a0, 1; forall 0:a0=4096 herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A008.litmus.expected000066400000000000000000000002561475314470400263320ustar00rootroot00000000000000Test A008 Required States 1 0:x10=4096; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:x10=4096) Observation A008 Always 1 0 Hash=cbbec4219a033fd342d02870f73a6390 herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A009.litmus000066400000000000000000000004001475314470400245220ustar00rootroot00000000000000RISCV A009 (* Tests IORW,OW fence args*) { 0:x6=x; 0:x8=y; 1:x6=y; 1:x8=x; } P0 | P1 ; ori x5,x0,1 | ori x5,x0,1 ; sw x5,0(x6) | sw x5,0(x6) ; fence iorw,ow | fence iorw,ow ; lw x7,0(x8) | lw x7,0(x8) ; exists (0:x7=0 /\ 1:x7=0) herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A009.litmus.expected000066400000000000000000000003521475314470400263300ustar00rootroot00000000000000Test A009 Allowed States 4 0:x7=0; 1:x7=0; 0:x7=0; 1:x7=1; 0:x7=1; 1:x7=0; 0:x7=1; 1:x7=1; Ok Witnesses Positive: 1 Negative: 3 Condition exists (0:x7=0 /\ 1:x7=0) Observation A009 Sometimes 1 3 Hash=f95aa1e052d096511627b0dade178336 herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A01.litmus000066400000000000000000000005271475314470400244440ustar00rootroot00000000000000RISCV A01 "PodWW Rfe PodRR Fre" Generator=diyone7 (version 7.56+03) Prefetch=0:x=F,0:y=W,1:y=F,1:x=T Com=Rf Fr Orig=PodWW Rfe PodRR Fre { 0:x6=x; 0:x8=y; 1:x6=y; 1:x8=x; } P0 | P1 ; ori x5,x0,1 | lw x5,0(x6) ; sw x5,0(x6) | lw x7,0(x8) ; ori x7,x0,1 | ; sw x7,0(x8) | ; exists (1:x5=1 /\ 1:x7=0) herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A01.litmus.expected000066400000000000000000000003501475314470400262360ustar00rootroot00000000000000Test A01 Allowed States 4 1:x5=0; 1:x7=0; 1:x5=0; 1:x7=1; 1:x5=1; 1:x7=0; 1:x5=1; 1:x7=1; Ok Witnesses Positive: 1 Negative: 3 Condition exists (1:x5=1 /\ 1:x7=0) Observation A01 Sometimes 1 3 Hash=ead7269b46fe5cd54a3f4b7aa162b214 herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A010.litmus000066400000000000000000000002221475314470400245140ustar00rootroot00000000000000RISCV A010 (* Test sext.w instruction*) { int64_t 0:a0; int64_t 0:a1 = 1; } P0; slli a1,a1,32 ; addi a1,a1,-1 ; sext.w a0, a1 ; forall 0:a0=-1 herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A010.litmus.expected000066400000000000000000000002521475314470400263170ustar00rootroot00000000000000Test A010 Required States 1 0:x10=-1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:x10=-1) Observation A010 Always 1 0 Hash=daf8cf7d6a66c3e89619f2a337c0b3dd herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A02.litmus000066400000000000000000000006301475314470400244400ustar00rootroot00000000000000RISCV A02 "Fence.rw.rwdWW Rfe Fence.rw.rwdRR Fre" Generator=diyone7 (version 7.56+03) Prefetch=0:x=F,0:y=W,1:y=F,1:x=T Com=Rf Fr Orig=Fence.rw.rwdWW Rfe Fence.rw.rwdRR Fre { 0:x6=x; 0:x8=y; 1:x6=y; 1:x8=x; } P0 | P1 ; ori x5,x0,1 | lw x5,0(x6) ; sw x5,0(x6) | fence rw,rw ; fence rw,rw | lw x7,0(x8) ; ori x7,x0,1 | ; sw x7,0(x8) | ; exists (1:x5=1 /\ 1:x7=0) herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A02.litmus.expected000066400000000000000000000003241475314470400262400ustar00rootroot00000000000000Test A02 Allowed States 3 1:x5=0; 1:x7=0; 1:x5=0; 1:x7=1; 1:x5=1; 1:x7=1; No Witnesses Positive: 0 Negative: 3 Condition exists (1:x5=1 /\ 1:x7=0) Observation A02 Never 0 3 Hash=f8d193cb78fa4ffe221ae4effc46d928 herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A03.litmus000066400000000000000000000006111475314470400244400ustar00rootroot00000000000000RISCV A03 "PodWWPRl RfeRlAq PodRRAqP Fre" Generator=diyone7 (version 7.56+03) Prefetch=0:x=F,0:y=W,1:y=F,1:x=T Com=Rf Fr Orig=PodWWPRl RfeRlAq PodRRAqP Fre { 0:x6=x; 0:x8=y; 1:x6=y; 1:x8=x; } P0 | P1 ; ori x5,x0,1 | lw.aq x5,0(x6) ; sw x5,0(x6) | lw x7,0(x8) ; ori x7,x0,1 | ; sw.rl x7,0(x8) | ; exists (1:x5=1 /\ 1:x7=0) herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A03.litmus.expected000066400000000000000000000003241475314470400262410ustar00rootroot00000000000000Test A03 Allowed States 3 1:x5=0; 1:x7=0; 1:x5=0; 1:x7=1; 1:x5=1; 1:x7=1; No Witnesses Positive: 0 Negative: 3 Condition exists (1:x5=1 /\ 1:x7=0) Observation A03 Never 0 3 Hash=824e55bb8bc1fcfac6078daadc7fb764 herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A04.litmus000066400000000000000000000003301475314470400244370ustar00rootroot00000000000000RISCV A04 { int x=0; 0:x6=x; 1:x6=x; } P0 | P1 ; ori x5,x0,1 | lw x5,0(x6) ; sw x5,0(x6) | beq x5,x0,LC00 ; | ori x1,x0,1 ; | LC00: ; exists (1:x1=1) herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A04.litmus.expected000066400000000000000000000002561475314470400262460ustar00rootroot00000000000000Test A04 Allowed States 2 1:x1=0; 1:x1=1; Ok Witnesses Positive: 1 Negative: 1 Condition exists (1:x1=1) Observation A04 Sometimes 1 1 Hash=c75ee04514d0ef3c2b9240089d2c6f30 herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A05.litmus000066400000000000000000000004161475314470400244450ustar00rootroot00000000000000RISCV A05 { 0:x6=x; 0:x8=y; 1:x6=y; 1:x8=x; } P0 | P1 ; ori x5,x0,2 | ori x5,x0,1 ; sw x5,0(x6) | sw x5,0(x6) ; fence iorw,iorw | fence w,w ; lw x7,0(x8) | ori x7,x0,1 ; | sw x7,0(x8) ; ~exists ([x]=2 /\ 0:x7=0) herd-herdtools7-1ca343e/herd/tests/instructions/RISCV/A05.litmus.expected000066400000000000000000000003231475314470400262420ustar00rootroot00000000000000Test A05 Forbidden States 3 0:x7=0; [x]=1; 0:x7=1; [x]=1; 0:x7=1; [x]=2; Ok Witnesses Positive: 3 Negative: 0 Condition ~exists ([x]=2 /\ 0:x7=0) Observation A05 Never 0 3 Hash=76889daed926cd74375244e972cf9638 herd-herdtools7-1ca343e/herd/tests/instructions/X86_64/000077500000000000000000000000001475314470400226705ustar00rootroot00000000000000herd-herdtools7-1ca343e/herd/tests/instructions/X86_64/A000.litmus000066400000000000000000000000771475314470400245330ustar00rootroot00000000000000X86_64 A000 (* Tests Nop *) {} P0; NOP; forall 0:rax = 0 herd-herdtools7-1ca343e/herd/tests/instructions/X86_64/A000.litmus.expected000066400000000000000000000002501475314470400263240ustar00rootroot00000000000000Test A000 Required States 1 0:rax=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:rax=0) Observation A000 Always 1 0 Hash=e7aa09c554ad7af2223102c50db5f77a herd-herdtools7-1ca343e/herd/tests/instructions/X86_64/A001.litmus000066400000000000000000000001241475314470400245250ustar00rootroot00000000000000X86_64 A001 (* Tests RIP register *) { 0:rip = 0 } P0; NOP; forall (0:rip = 0) herd-herdtools7-1ca343e/herd/tests/instructions/X86_64/A001.litmus.expected000066400000000000000000000002501475314470400263250ustar00rootroot00000000000000Test A001 Required States 1 0:rip=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:rip=0) Observation A001 Always 1 0 Hash=5586d6c213112d3683c915b4d7bb700a herd-herdtools7-1ca343e/herd/tests/instructions/X86_64/A002.litmus000066400000000000000000000001211475314470400245230ustar00rootroot00000000000000X86_64 A002 (* Tests CD register *) { 0:cs = 0 } P0; NOP; forall (0:cs = 0) herd-herdtools7-1ca343e/herd/tests/instructions/X86_64/A002.litmus.expected000066400000000000000000000002461475314470400263330ustar00rootroot00000000000000Test A002 Required States 1 0:cs=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:cs=0) Observation A002 Always 1 0 Hash=4be04e9b54f7908f2e734a3d82ed4d8b herd-herdtools7-1ca343e/herd/tests/instructions/X86_64/A003.litmus000066400000000000000000000001771475314470400245370ustar00rootroot00000000000000X86_64 A003 (* Tests parsing of the endbr64 instruction for herd this is a NOP *) { } P0; endbr64; forall 0:RAX = 0 herd-herdtools7-1ca343e/herd/tests/instructions/X86_64/A003.litmus.expected000066400000000000000000000002501475314470400263270ustar00rootroot00000000000000Test A003 Required States 1 0:rax=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:rax=0) Observation A003 Always 1 0 Hash=33e970980643a03ccf92e4989259cd01 herd-herdtools7-1ca343e/herd/tests/instructions/X86_64/A004.litmus000066400000000000000000000002021475314470400245250ustar00rootroot00000000000000X86_64 A004 (* Tests for nopl/nopw emmitted by LLVM *) {} P0; nopl 0(%rax,%eax,0); nopw 0(%rax,%eax,0); forall 0:RAX = 0 herd-herdtools7-1ca343e/herd/tests/instructions/X86_64/A004.litmus.expected000066400000000000000000000002501475314470400263300ustar00rootroot00000000000000Test A004 Required States 1 0:rax=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:rax=0) Observation A004 Always 1 0 Hash=1d377b1f6bfaa1897dfe7962885d908c herd-herdtools7-1ca343e/herd/tests/instructions/X86_64/A005.litmus000066400000000000000000000001511475314470400245310ustar00rootroot00000000000000X86_64 A005 (* tests %cs:0x0(%rd,%rs,k) syntax*) {} P0; NOPL %cs:0(%rax,%eax,0); forall (0:RAX = 0) herd-herdtools7-1ca343e/herd/tests/instructions/X86_64/A005.litmus.expected000066400000000000000000000002501475314470400263310ustar00rootroot00000000000000Test A005 Required States 1 0:rax=0; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:rax=0) Observation A005 Always 1 0 Hash=33e970980643a03ccf92e4989259cd01 herd-herdtools7-1ca343e/herd/tests/instructions/X86_64/A006.litmus000066400000000000000000000013741475314470400245420ustar00rootroot00000000000000X86_64 A006 Variant=telechat { [P1_r0]=0;[x]=0;[y]=0; } (*****************************************************************) (* Compiler: *) (* x86_64-linux-gnux32-gcc-10 -c -g -Og -pthread --std=c11 -march=x86-64*) (*****************************************************************) P0 | P1 ; movl $2,(x) | mov (y),%eax ; movl $1,(y) | cmp $1,%eax ; ret | je L0x3b ; | L0x31: ; | mov %eax,(P1_r0) ; | ret ; | L0x3b: ; | movl $1,(x) ; | jmp L0x31 ; exists ([x]=2 /\ P1_r0=1) herd-herdtools7-1ca343e/herd/tests/instructions/X86_64/A006.litmus.expected000066400000000000000000000003141475314470400263330ustar00rootroot00000000000000Test A006 Allowed States 2 [P1_r0]=0; [x]=2; [P1_r0]=1; [x]=1; No Witnesses Positive: 0 Negative: 2 Condition exists ([x]=2 /\ [P1_r0]=1) Observation A006 Never 0 2 Hash=129271caa23e144554d29606dbb498d0 herd-herdtools7-1ca343e/herd/tests/instructions/X86_64/A007.litmus000066400000000000000000000001161475314470400245340ustar00rootroot00000000000000X86_64 A007 (* Test SHL instr*) { 0:RAX=1} P0; shl 2,%eax; forall 0:RAX=4 herd-herdtools7-1ca343e/herd/tests/instructions/X86_64/A007.litmus.expected000066400000000000000000000002501475314470400263330ustar00rootroot00000000000000Test A007 Required States 1 0:rax=4; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:rax=4) Observation A007 Always 1 0 Hash=a335aafc9060d9b8c4320424ba909740 herd-herdtools7-1ca343e/herd/tests/instructions/X86_64/A008.litmus000066400000000000000000000001211475314470400245310ustar00rootroot00000000000000X86_64 A008 (* Test AND instr*) { 0:RAX=1} P0; and %eax,%eax; forall 0:RAX=1 herd-herdtools7-1ca343e/herd/tests/instructions/X86_64/A008.litmus.expected000066400000000000000000000002501475314470400263340ustar00rootroot00000000000000Test A008 Required States 1 0:rax=1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:rax=1) Observation A008 Always 1 0 Hash=0f619956115409bcfddfe64524121ac4 herd-herdtools7-1ca343e/herd/tests/instructions/X86_64/A009.litmus000066400000000000000000000002211475314470400245330ustar00rootroot00000000000000X86_64 A009 { int64_t t[2]={1,-1}; 0:rax=t; 0:rbx=1; int64_t 0:rcx; } P0 ; movq 0(%rax,%rbx,8),%rcx ; forall 0:rcx = -1 herd-herdtools7-1ca343e/herd/tests/instructions/X86_64/A009.litmus.expected000066400000000000000000000002521475314470400263370ustar00rootroot00000000000000Test A009 Required States 1 0:rcx=-1; Ok Witnesses Positive: 1 Negative: 0 Condition forall (0:rcx=-1) Observation A009 Always 1 0 Hash=7ca3c35015d75a877ccf509d75062e79 herd-herdtools7-1ca343e/herd/tests/instructions/X86_64/A010.litmus000066400000000000000000000002131475314470400245240ustar00rootroot00000000000000X86_64 A010 { uint64_t x; 0:RBX=0x202020202020202; } P0 ; MOVQ %RBX,(x) ; locations [x;] forall [x] = 0x202020202020202 herd-herdtools7-1ca343e/herd/tests/instructions/X86_64/A010.litmus.expected000066400000000000000000000003061475314470400263270ustar00rootroot00000000000000Test A010 Required States 1 [x]=144680345676153346; Ok Witnesses Positive: 1 Negative: 0 Condition forall ([x]=144680345676153346) Observation A010 Always 1 0 Hash=a4f2c7b46c9fe04acb695c7d4ca4630b herd-herdtools7-1ca343e/herd/top_herd.ml000066400000000000000000000443031475314470400202260ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc aranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2012-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Top level loop : execute test according to model *) module type CommonConfig = sig val timeout : float option val candidates : bool val show : PrettyConf.show val nshow : int option val restrict : Restrict.t val showkind : bool val shortlegend : bool val outcomereads : bool val outputdir : PrettyConf.outputdir_mode val suffix : string val dumpes : bool val badexecs : bool val badflag : string option val throughflag : string option include Mem.CommonConfig val statelessrc11 : bool val skipchecks : StringSet.t val dumpallfaults : bool end module type Config = sig include CommonConfig val byte : MachSize.sz val dirty : DirtyBit.t option end module Make(O:Config)(M:XXXMem.S) = struct open Printf module S = M.S module PC = S.O.PC module MC = Mem.Make(O)(S) module C = S.Cons module A = S.A module AM = A.Mixed(O) module T = Test_herd.Make(A) module W = Warn.Make(O) let memtag = O.variant Variant.MemTag let morello = O.variant Variant.Morello let showcutoff = O.variant Variant.CutOff let kvm = O.variant Variant.VMSA (* Utilities *) open Restrict let do_observed = match O.restrict with | Observed -> true | No|NonAmbiguous|CondOne -> false (* Location out printing *) let tr_out test = OutMapping.info_to_tr test.Test_herd.info (* Cond checking *) module CM = C.Mixed(O) let check_prop test = let c = T.find_our_constraint test in let p = ConstrGen.prop_of c in let senv = S.size_env test and tenv = S.type_env test in fun st -> CM.check_prop p tenv senv st let count_prop test = let c = T.find_our_constraint test in let p = ConstrGen.prop_of c in fun sts -> A.StateSet.fold (fun st n -> if CM.check_prop_rlocs p (S.type_env test) st then n+1 else n) sts 0 (* Test result *) type count = { states : A.StateSet.t; cfail : int ; cands : int ; (* NB: pos and neg are w.r.t. proposition *) pos : int ; neg : int ; (* flagged executions *) flagged : int list Flag.Map.t ; (* shown executions *) shown : int; (* registers that read memory *) reads : S.loc_set; (* Too much loop unrolling *) cutoff : string option; } let start = { states = A.StateSet.empty; cfail=0; cands=0; pos=0; neg=0; flagged=Flag.Map.empty; shown=0; reads = A.LocSet.empty; cutoff=None; } let kfail c = { c with cfail=c.cfail+1; } let bad_flag = match O.badflag with | None -> (function | Flag.Undef -> true | Flag.Flag _ -> false) | Some fbad -> (function | Flag.Undef -> true | Flag.Flag f -> String.compare f fbad = 0) let is_bad flags = Flag.Set.exists bad_flag flags let has_bad_execs c = Flag.Map.mem Flag.Undef c.flagged || (match O.badflag with | None -> false | Some f -> Flag.Map.mem (Flag.Flag f) c.flagged) (* Check condition *) open ConstrGen let check_cond test c = let cstr = T.find_our_constraint test in match cstr with | ExistsState _ -> c.pos > 0 | NotExistsState _-> c.pos = 0 | ForallStates _ -> c.neg = 0 let check_wit test c = let cstr = T.find_our_constraint test in match cstr with | ForallStates _ | ExistsState _ -> c.pos,c.neg | NotExistsState _-> c.neg,c.pos (* rfmap generation and processing, from pre-candidates *) let iter_rfms test rfms owls kont k = let kont = if O.verbose > 0 then fun conc k -> eprintf ".%!" ; let k = kont conc k in k else kont in let k = List.fold_left (fun res (_i,cs,es) -> MC.calculate_rf_with_cnstrnts test owls es cs kont res) k rfms in k (* Open a dot outfile or not *) let open_dot test = match O.outputdir with | PrettyConf.NoOutputdir -> begin match S.O.PC.view with | Some _ -> begin try let f,chan = Filename.open_temp_file "herd" ".dot" in Some (chan,f) with Sys_error msg -> W.warn "Cannot create temporary file: %s" msg ; None end | None -> None end | PrettyConf.StdoutOutput -> let fname = Test_herd.basename test in fprintf stdout "\nDOTBEGIN %s\n" fname; fprintf stdout "DOTCOM %s\n" (let module G = Show.Generator(PC) in G.generator) ; Some (stdout, fname) | PrettyConf.Outputdir d -> let base = Test_herd.basename test in let base = base ^ O.suffix in let f = Filename.concat d base ^ ".dot" in try Some (open_out f,f) with | Sys_error msg -> W.warn "Cannot create %s: %s" f msg ; None let close_dot = function | None -> () | Some (chan,fname) -> match O.outputdir with | PrettyConf.NoOutputdir | PrettyConf.Outputdir _ -> if S.O.PC.debug then eprintf "close %s\n" fname ; close_out chan | PrettyConf.StdoutOutput -> fprintf stdout "\nDOTEND %s\n" fname let my_remove name = try Sys.remove name with e -> W.warn "remove failed: %s" (Printexc.to_string e) let erase_dot = match S.O.PC.debug,O.outputdir with | false,PrettyConf.NoOutputdir -> (* Erase temp file *) (function Some (_,f) -> my_remove f | None -> ()) | (_,PrettyConf.Outputdir _)|(_,PrettyConf.StdoutOutput)|(true,PrettyConf.NoOutputdir) -> (function _ -> ()) exception Over of count (* internal use, to stop everything *) module PU = PrettyUtils.Make(S) let all_observed test conc = let es = conc.S.str in let obs = PU.observed test es and loads = S.E.mem_loads_of es.S.E.events in S.E.EventSet.subset loads obs (* Called by model simulator in case of success *) let model_kont ochan test do_restrict cstr = let check = check_prop test in fun conc (st,flts) (set_pp,vbpp) flags c -> if do_observed && not (all_observed test conc) then c else if match O.throughflag with | None -> false | Some flag -> not (Flag.Set.mem (Flag.Flag flag) flags) then c else let st = A.map_state A.V.printable st in let fsc = st,flts in let ok = check fsc in let show_exec = let open PrettyConf in match O.show with | ShowProp -> ok | ShowNeg -> not ok | ShowCond -> begin match cstr with | ExistsState _|ForallStates _-> ok | NotExistsState _ -> not ok end | ShowWit -> begin match cstr with | ExistsState _|NotExistsState _ -> ok | ForallStates _ -> not ok end | ShowAll -> true | ShowNone -> false | ShowFlag f -> Flag.Set.mem (Flag.Flag f) flags in begin match ochan with | Some (chan,_) when show_exec -> let legend = let pp_flag = match O.show with | PrettyConf.ShowFlag f -> sprintf ", flag %s" f | _ -> "" in let name = Test_herd.readable_name test in let pp_model = sprintf "%s" (Model.pp M.model) in if O.shortlegend then name else if O.showkind then if PC.texmacros then sprintf "\\mylegendkind{%s}{%s}{%s}" name (C.dump_as_kind cstr) pp_model else sprintf "Test %s%s%s%s" name (sprintf ": %s" (C.dump_as_kind cstr)) (match pp_model with | "" -> "" | _ -> sprintf " (%s)" pp_model) pp_flag else begin if PC.texmacros then sprintf "\\mylegend{%s}{%s}" name pp_model else sprintf "Test %s%s%s" name (match pp_model with | "" -> "" | _ -> sprintf ", %s" pp_model) pp_flag end in let module PP = Pretty.Make(S) in PP.dump_legend chan test legend conc ~sets:(Lazy.force set_pp) (Lazy.force vbpp) | _ -> () end ; let fsc = do_restrict test fsc in let r = { cands = c.cands+1; cfail = c.cfail; states = A.StateSet.add fsc c.states; pos = if ok then c.pos+1 else c.pos; neg = if ok then c.neg else c.neg+1; flagged = begin let add flag k = let old = Flag.Map.safe_find [] flag k in Flag.Map.add flag (c.cands::old) k in Flag.Set.fold add flags c.flagged; end; shown = if show_exec then c.shown+1 else c.shown; reads = if O.outcomereads then A.LocSet.union (PU.all_regs_that_read conc.S.str) c.reads else c.reads; cutoff = c.cutoff; } in if not O.badexecs && is_bad flags then raise (Over r) ; let r = match O.nshow with | None -> r | Some m -> if r.shown >= m then raise (Over r) else r in let stop_now = match O.speedcheck with | Speed.True|Speed.False -> false | Speed.Fast -> begin match cstr with | ExistsState _|NotExistsState _ -> ok | ForallStates _ -> not ok end in if stop_now then raise (Over r) else r (* Performed delayed checks and warnings *) let check_failed_model_kont cutoff cs ochan test do_restrict cstr conc (st,flts) (set_pp,vbpp) flags c = let open S.M.VC in match cs with | Some (Failed e) -> (* Perform error *) raise e | Some (Warn msg) -> (* Warn and ignore *) Warn.warn_always "%s, legal outcomes may be missing" msg ; c | Some (Assign _)|None -> if not showcutoff && Misc.is_some cutoff then c else model_kont ochan test do_restrict cstr conc (st,flts) (set_pp,vbpp) flags c (* Driver *) let run start_time test = let { MC.event_structures=rfms; MC.overwritable_labels=owls; },test = MC.glommed_event_structures test in let cstr = T.find_our_constraint test in let restrict_faults = if !Opts.dumpallfaults then Fun.id else if A.FaultAtomSet.is_empty test.Test_herd.ffaults then fun _ -> A.FaultSet.empty else A.FaultSet.filter (fun flt -> A.FaultAtomSet.exists (fun ((p,lab),loc,ftype) -> A.check_one_fatom flt ((p,lab),loc,ftype)) test.Test_herd.ffaults) in let final_state_restrict_locs test fsc = let dlocs = S.displayed_rlocations test and senv = S.size_env test and tenv = S.type_env test in let fsc,flts = fsc in AM.state_restrict_locs O.outcomereads dlocs tenv senv fsc, restrict_faults flts in (* Open *) let ochan = open_dot test in (* So small a race condition... *) Handler.push (fun () -> erase_dot ochan) ; (* Dump event structures ... *) if O.dumpes then begin match ochan with | None -> () | Some (chan,fname) -> let module PP = Pretty.Make(S) in List.iter (fun (_i,_cs,es) -> PP.dump_es chan test es) rfms ; close_dot ochan ; if Misc.is_some S.O.PC.view then begin let module SH = Show.Make(S.O.PC) in SH.show_file fname end ; erase_dot ochan ; Handler.pop () end else (* Thanks to the existence of check_test, XXMem modules apply their internal functors once *) let call_model conc ofail c = let check_test = M.check_event_structure test in (* Checked pruned executions before even calling model *) let cutoff = S.find_cutoff conc.S.str.S.E.events in let c = if Misc.is_some cutoff then { c with cutoff = cutoff; } else c in (* Discard pruned executions if not explicitely required *) check_test conc kfail (check_failed_model_kont cutoff ofail ochan test final_state_restrict_locs cstr) c in let c = if O.statelessrc11 then let module SL = Slrc11.Make(struct include MC let skipchecks = O.skipchecks end) in SL.check_event_structure test rfms kfail (fun _ c -> c) (model_kont ochan test final_state_restrict_locs cstr) start else try iter_rfms test rfms owls call_model start with | Over c -> c | e -> close_dot ochan ; (* Close *) raise e in (* Close *) close_dot ochan ; let do_show () = (* Show if something to show *) begin match ochan with | Some (_,fname) when c.shown > 0 -> let module SH = Show.Make(S.O.PC) in if S.O.PC.debug then eprintf "show %s file\n" fname ; SH.show_file fname | Some _|None -> () end ; (* Erase *) erase_dot ochan ; Handler.pop () in (* Reduce final states, so as to show relevant locations only *) let finals = if O.outcomereads then let do_restrict (st,flts) = let st = A.rstate_filter (fun rloc -> let loc = ConstrGen.loc_of_rloc rloc in match loc with | A.Location_global _ -> true | A.Location_reg _ -> A.LocSet.mem loc c.reads) st in st,flts in A.StateSet.map do_restrict c.states else c.states in let nfinals = A.StateSet.cardinal finals in match O.restrict with | Observed when c.cands = 0 -> do_show () | NonAmbiguous when c.cands <> nfinals -> do_show () | CondOne when c.pos <> count_prop test finals -> do_show () | _ -> try begin (* Header *) let tname = test.Test_herd.name.Name.name in let is_bad = has_bad_execs c in if not O.badexecs && is_bad then raise Exit ; (* START NOTWWW *) (* Stop interval timer *) Itimer.stop O.timeout ; (* END NOTWWW *) (* Now output *) printf "Test %s %s\n" tname (C.dump_as_kind cstr) ; (**********) (* States *) (**********) let tr_out = tr_out test in printf "States %i\n" nfinals ; A.StateSet.pp stdout "" (fun chan st -> fprintf chan "%s\n" (A.do_dump_final_state test.Test_herd.type_env test.Test_herd.ffaults tr_out st)) finals ; (* Condition result *) let ok = check_cond test c in printf "%s%s\n" (if Misc.is_some c.cutoff then "Loop " else "") (if is_bad then "Undef" else if ok then "Ok" else "No") ; let pos,neg = check_wit test c in printf "Witnesses\n" ; printf "Positive: %i Negative: %i\n" pos neg ; begin if O.verbose > 0 then Flag.Map.iter (fun flag execs -> printf "Flag %s: %s \n" (Flag.pp flag) (List.fold_right (fun i s -> s ^ (if s="" then "" else ",") ^ sprintf "%i" i) execs "")) c.flagged else Flag.Map.iter (fun flag _ -> printf "Flag %s\n" (Flag.pp flag)) c.flagged end ; printf "Condition %a\n" (C.do_dump_constraints tr_out) cstr ; printf "Observation %s %s %i %i\n%!" tname (if c.pos = 0 then "Never" else if c.neg = 0 then "Always" else "Sometimes") c.pos c.neg ; do_show () ; printf "Time %s %0.2f\n" tname (Sys.time () -. start_time) ; if O.candidates then printf "Candidates %s %i\n" tname (c.cfail+c.cands) ; (* Auto info or Hash only*) List.iter (fun (k,v) -> if Misc.string_eq k "Hash" then printf "%s=%s\n" k v) test.Test_herd.info ; print_newline () ; begin match c.cutoff with | Some msg -> Warn.warn_always "%a: unrolling limit exceeded at %s, legal outcomes may be missing." Pos.pp_pos0 test.Test_herd.name.Name.file msg | None -> () end end with Exit -> () ; () end herd-herdtools7-1ca343e/herd/valconstraint.ml000066400000000000000000000503331475314470400213110ustar00rootroot00000000000000(****************************************************************************) (* The diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** A simple constraint solver. The default solver * [solve_topo] proceeds by one pass by following dependencies, while * the previous solver [solve_std] proceeds by iterating substitution * and computation steps untill stabilisation. * Both solvers are invoked after a "normalisation" step that * identifies classes of equivant variables resulting from equations * of the form [x := y], see [normalise_vars] below. *) (* Constraints: v is any value: a constant cst or a variable S. Possible constraints are v1 := v2 v1 := v2 (op) v3 Solutions are S -> cst *) module type S = sig type atom type cst type location type state type arch_op type arch_op1 type expr = | Atom of atom | ReadInit of location * state | Unop of (arch_op1 Op.op1) * atom | Binop of (arch_op Op.op) * atom * atom | Terop of Op.op3 * atom * atom * atom type rvalue = expr type cnstrnt = | Assign of atom * rvalue | Failed of exn (* Delay exceptions *) | Warn of string type cnstrnts = cnstrnt list val pp_cnstrnts : cnstrnt list -> string type solution type answer = | NoSolns | Maybe of solution * cnstrnts val pp_answer : answer -> string (* Extract delayed exception, if present, or warning, if present. *) val get_failed : cnstrnts -> cnstrnt option val solve : cnstrnt list -> answer end module type Config = sig val hexa : bool val debug : Debug_herd.t val keep_failed_as_undetermined : bool val old_solver : bool end module Make (C:Config) (A:Arch_herd.S) : S with type atom = A.V.v and type cst = A.V.Cst.v and type arch_op = A.V.arch_op and type arch_op1 = A.V.arch_op1 and type solution = A.V.solution and type location = A.location and type state = A.state = struct let debug_solver = C.debug.Debug_herd.solver open Printf module V = A.V type atom = V.v type cst = V.Cst.v type location = A.location type state = A.state type arch_op = V.arch_op type arch_op1 = V.arch_op1 type expr = | Atom of atom | ReadInit of location * state | Unop of V.op1_t * atom | Binop of V.op_t * atom * atom | Terop of Op.op3 * atom * atom * atom let map_expr fv e = match e with | Atom v -> Atom (fv v) | ReadInit (loc,s) -> ReadInit (A.map_loc fv loc,s) | Unop (o,a1) -> Unop (o,fv a1) | Binop (o,a1,a2) -> Binop (o,fv a1, fv a2) | Terop (o,a1,a2,a3) -> Terop (o,fv a1, fv a2, fv a3) type rvalue = expr type cnstrnt = | Assign of V.v * rvalue | Failed of exn | Warn of string type cnstrnts = cnstrnt list let pp_atom a = V.pp C.hexa a let pp_expr e = match e with | Atom a -> pp_atom a | ReadInit(loc,_) -> A.dump_location loc ^ " in init" | Unop (o,a1) -> sprintf "%s(%s)" (Op.pp_op1 C.hexa V.pp_arch_op1 o) (pp_atom a1) | Binop (o,a1,a2) -> if Op.is_infix o then pp_atom a1 ^ Op.pp_op o V.pp_arch_op ^ pp_atom a2 else Printf.sprintf "%s(%s,%s)" (Op.pp_op o V.pp_arch_op) (pp_atom a1) (pp_atom a2) | Terop (op,a1,a2,a3) -> Op.pp_op3 op (pp_atom a1) (pp_atom a2) (pp_atom a3) let pp_rvalue e = pp_expr e let pp_cnstrnt cnstr = match cnstr with | Assign (v,rval) -> (V.pp C.hexa v) ^ ":=" ^(pp_rvalue rval) | Failed e -> sprintf "Failed %s" (Printexc.to_string e) | Warn e -> e let pp_cnstrnts lst = String.concat "\n" (List.map pp_cnstrnt lst) type solution = V.solution type answer = | NoSolns | Maybe of solution * cnstrnts let pp_answer = let pp_cns cns = match cns with | [] -> "" | _::_ -> "\nUnsolved equations:\n" ^ (pp_cnstrnts cns) in fun soln -> match soln with | NoSolns -> "No solutions" | Maybe (sol,cns) -> let sol_pped = let bds = V.Solution.fold (fun v i k -> (v,i)::k) sol [] in String.concat ", " (List.map (fun (v,i) -> V.pp_csym v ^ "<-" ^ V.pp C.hexa i) bds) in sol_pped ^ pp_cns cns (**************************************) (* Initial phase: normalize variables *) (**************************************) (* straightforward union-find. *) (* Collect all variables in partition *) module OV = struct type t = V.csym let compare = V.compare_csym end module Part = Partition.Make (OV) let fold_var f = function | V.Val _ -> Fun.id | V.Var x -> f x let fold_loc f loc = match A.undetermined_vars_in_loc_opt loc with | None -> Fun.id | Some v -> fold_var f v let fold_vars_expr f e t = match e with | Atom v -> fold_var f v t | ReadInit (loc,_) -> fold_loc f loc t | Unop (_,v) -> fold_var f v t | Binop (_,v1,v2) -> fold_var f v1 t |> fold_var f v2 | Terop (_,v1,v2,v3) -> fold_var f v1 t |> fold_var f v2 |> fold_var f v3 let add_vars_expr = fold_vars_expr Part.add and add_var = fold_var Part.add let add_vars_cn t cn = match cn with | Assign (v,e) -> add_var v t |> add_vars_expr e | Failed _ | Warn _ -> t let add_vars_cns cns = List.fold_left add_vars_cn (Part.create ()) cns (* Perform union-find *) let uf_cn t cn = match cn with | Assign (V.Var v,Atom (V.Var w)) -> Part.union t v w | _ -> () let uf_cns t cns = List.iter (uf_cn t) cns ; Part.as_solution t (* Simplify equations *) let subst_atom m v = V.map_csym (fun x -> try V.Var (Part.Sol.find x m) with Not_found -> V.Var x) v let subst_expr m = map_expr (subst_atom m) let subst_cn m cn k = match cn with | Assign (v,Atom w) -> let v = subst_atom m v and w = subst_atom m w in if V.compare v w = 0 then k else Assign (v,Atom w)::k | Assign (v,e) -> let v = subst_atom m v and e = subst_expr m e in Assign (v,e)::k | Failed _ | Warn _ -> cn::k let subst_cns soln cns = List.fold_right (subst_cn soln) cns [] (* All together *) (** [normalise cns], where [cns] is a list of equations, * that is, compute equivalence classes of variables and * replace variables by their representative. * The function returns a pair [(m,cns)], where cns collects * the new equations, with equations [x := y] removed and * variables replaced by representative. The mapping [m] * is from variables to representative. *) let normalize_vars cns = let t = add_vars_cns cns in let m = uf_cns t cns in let cns = subst_cns m cns in if debug_solver then begin eprintf "* Normalizes to *\n%s\n%!" (pp_cnstrnts cns) end ; m,cns (*****************) (* Solver proper *) (*****************) (* Solver proceeds by iterating three simple steps, could use a topological sorting, to be more efficient. Not needed at the moment. *) (* Phase 1: detection of contradictions and erasure of trivial equations *) exception Contradiction let mk_atom_from_expr e = try match e with | Atom _ -> e | ReadInit (loc,init) -> Atom (A.look_address_in_state init loc) | Unop (op,v1) -> Atom (V.op1 op v1) | Binop (op,v1,v2) -> Atom (V.op op v1 v2) | Terop (op,v1,v2,v3) -> Atom (V.op3 op v1 v2 v3) with (* [expr] still contains at least one undetermined sub-expression *) | A.LocUndetermined | V.Undetermined -> e let check_true_false cn k = match cn with | Assign (v,e) -> begin try let e = mk_atom_from_expr e in begin match e with | Atom w -> if V.is_var_determined v && V.is_var_determined w then if V.compare v w = 0 then k else raise Contradiction else Assign (v,e)::k | ReadInit _| Unop _|Binop _|Terop _ -> Assign (v,e)::k end (* Delay failure to preserve potential contradiction *) with | Contradiction|Misc.Timeout as e -> raise e | e -> if C.debug.Debug_herd.exc then raise e else if C.keep_failed_as_undetermined then cn :: k else let () = if debug_solver then begin eprintf "Solving %s\n" (pp_cnstrnt cn) ; eprintf "Delaying exception in solver: %s\n%!" (Printexc.to_string e) end in Failed e :: k end | Failed _ | Warn _ -> cn::k let check_true_false_constraints cns = List.fold_right check_true_false cns [] (* Phase 3, substitution *) let simplify_vars_in_var soln x = try V.Val (V.Solution.find x soln) with Not_found -> V.Var x let simplify_vars_in_atom soln v = V.map_csym (simplify_vars_in_var soln) v let simplify_vars_in_expr soln = map_expr (simplify_vars_in_atom soln) let simplify_vars_in_cnstrnt soln cn = match cn with | Assign (v,rval) -> let v = simplify_vars_in_atom soln v in let rval = simplify_vars_in_expr soln rval in Assign (v,rval) | Failed _ | Warn _ -> cn let simplify_vars_in_cnstrnts soln cs = List.map (simplify_vars_in_cnstrnt soln) cs (* Phase 2, "solving": just collect equations S := cst / cst := S *) let singleton v i = V.Solution.add v i V.Solution.empty and empty = V.Solution.empty let solve_cnstrnt cnstr = match cnstr with | Assign (V.Var v,Atom (V.Val i)) | Assign (V.Val i,Atom (V.Var v)) -> singleton v i | Assign (V.Val _,Atom (V.Val _)) -> (* By previous application of check_true_false *) assert false | Assign (V.Var _,Atom (V.Var _)) (* can occur in spite of variable normalization (ternary if) *) | Assign (_,(Unop _|Binop _|Terop _|ReadInit _)) -> empty | Failed _ | Warn _ -> empty (* merge of solutions, with consistency check *) let add_sol x cst sol = try let cst' = V.Solution.find x sol in if V.Cst.eq cst cst' then sol else raise Contradiction with | Not_found -> V.Solution.add x cst sol let merge sol1 sol2 = V.Solution.fold add_sol sol1 sol2 let solve_cnstrnts = List.fold_left (fun solns cnstr -> merge (solve_cnstrnt cnstr) solns) V.Solution.empty (************************) (* Raise exceptions now *) (************************) let get_failed cns = List.fold_left (fun r cn -> match cn,r with | Failed _,_ -> Some cn | Warn _,None -> Some cn | (Assign _,_)|(Warn _,Some _) -> r) None cns (*******************************) (* Iterate basic solving steps *) (*******************************) (* Just union since there are no variables in rhs of solutions *) let compose_sols sol1 sol2 = V.Solution.fold V.Solution.add sol1 sol2 let rec solve_step cns solns_final = (* Phase 1, check individual constraint validity *) let cns = check_true_false_constraints cns in (* Phase 2, orient constraints S := cst / cst := S *) let solns = solve_cnstrnts cns in if V.Solution.is_empty solns then begin solns_final,cns end else (* Phase 3, and iteration *) let cns = simplify_vars_in_cnstrnts solns cns and solns_final = compose_sols solns solns_final in solve_step cns solns_final let add_vars_solns m solns0 = Part.Sol.fold (fun x y solns -> try let cst = V.Solution.find y solns0 in V.Solution.add x (V.Val cst) solns with Not_found -> V.Solution.add x (V.Var y) solns) m (V.Solution.map (fun x -> V.Val x) solns0) let solve_std lst = if debug_solver then begin prerr_endline "** Solve **" ; eprintf "%s\n" (pp_cnstrnts lst) ; flush stderr end ; let m,lst = normalize_vars lst in let sol = try let solns,lst = solve_step lst V.Solution.empty in let solns = add_vars_solns m solns in Maybe (solns,lst) with Contradiction -> NoSolns in if debug_solver then begin eprintf "Solutions: %s\n" (pp_answer sol) ; flush stderr end ; sol (*********************************) (* Topological sort-based solver *) (*********************************) module OrderedEq = struct type t = cnstrnt let atom_compare = A.V.compare let atom2_compare p1 p2 = Misc.pair_compare atom_compare atom_compare p1 p2 let atom3_compare (e1,e2,e3) (f1,f2,f3) = Misc.pair_compare atom_compare atom2_compare (e1,(e2,e3)) (f1,(f2,f3)) let expr_compare e1 e2 = match e1,e2 with | Atom v1,Atom v2 -> atom_compare v1 v2 | ReadInit (loc1,_),ReadInit (loc2,_) -> A.location_compare loc1 loc2 (* second componant is fixed *) | Unop (op1,e1),Unop (op2,e2) -> Misc.pair_compare Misc.polymorphic_compare atom_compare (op1,e1) (op2,e2) | Binop (o,e1,e2),Binop (p,f1,f2) -> Misc.pair_compare Misc.polymorphic_compare atom2_compare (o,(e1,e2)) (p,(f1,f2)) | Terop (o,e1,e2,e3),Terop (p,f1,f2,f3) -> Misc.pair_compare Misc.polymorphic_compare atom3_compare (o,(e1,e2,e3)) (p,(f1,f2,f3)) | (Atom _,(ReadInit _|Unop _|Binop _|Terop _)) | (ReadInit _,(Unop _|Binop _|Terop _)) | (Unop _,(Binop _|Terop _)) | (Binop _,Terop _) -> -1 | ((ReadInit _|Unop _|Binop _|Terop _),Atom _) | ((Unop _|Binop _|Terop _),ReadInit _) | ((Binop _|Terop _),Unop _) | (Terop _,Binop _) -> 1 let compare c1 c2 = match c1,c2 with | Assign (v1,e1),Assign (v2,e2) -> Misc.pair_compare atom_compare expr_compare (v1,e1) (v2,e2) | Failed exn1,Failed exn2 -> Misc.polymorphic_compare exn1 exn2 | Warn w1,Warn w2 -> String.compare w1 w2 | (Assign _,(Failed _|Warn _)) | (Failed _,Warn _) -> -1 | ((Failed _|Warn _),Assign _) | (Warn _,Failed _) -> 1 end module EqSet = MySet.Make(OrderedEq) module VarEnv = A.V.Solution let env_find csym m = try VarEnv.find csym m with Not_found -> EqSet.empty let env_add csym c = VarEnv.update csym @@ function | None -> Some (EqSet.singleton c) | Some old -> Some (EqSet.add c old) let var2eq cs = (* Construct the map from x to all equations of the form [x = ] *) List.fold_left (fun m c -> match c with | Assign (V.Var csym,_) -> env_add csym c m | Assign (V.Val _,_)|Warn _|Failed _ -> m) VarEnv.empty cs module EqRel = InnerRel.Make(OrderedEq) let debug_topo chan ns r = EqRel.scc_kont (fun cs () -> Printf.fprintf chan "{%s}\n%!" (List.map pp_cnstrnt cs |> String.concat ", ")) () ns r let eq2g cs = let cs = List.map (fun c -> match c with | Assign (V.Val _ as c,Atom (V.Var _ as y)) -> Assign (y,Atom c) | _ -> c) cs in let m = var2eq cs in let add_rels eq0 e g = let add_rel csym g = let eqs = env_find csym m in EqSet.fold (fun eq g -> EqRel.add (eq0,eq) g) eqs g in fold_vars_expr add_rel e g in let rel = List.fold_left (fun rel c -> match c with | Assign (_,e) -> add_rels c e rel | Warn _|Failed _ -> rel) EqRel.empty cs in let cs = EqSet.of_list cs in cs,rel (** [solv_one c sol eqs], where c is an equation, [sol] is a solution * (map from variables to constants) and [eqs] is a list of equations, * evaluates the equation [c] w.r.t. to solution [sol] * and returns [(sol,eqs)] updated, with: * - [sol] updated to add all the variable affections found; * - [eqs] updated to add the unsolved equations. *) let solve_one c sol eqs = match c with | Warn _|Failed _ -> sol,c::eqs | Assign (v0,e) -> begin try let v = simplify_vars_in_atom sol v0 and e = simplify_vars_in_expr sol e |> mk_atom_from_expr in match v,e with | V.Var x,Atom (V.Val atom) -> add_sol x atom sol,eqs | V.Val c1,Atom (V.Val c2) -> if V.Cst.eq c1 c2 then sol,eqs else raise Contradiction (* Last case below can occur when called on a strongly connected component. *) | _,_ -> sol,Assign (v,e)::eqs with | Contradiction|Misc.Timeout as exn -> raise exn | exn -> if C.debug.Debug_herd.exc then raise exn ; (sol,Failed exn::eqs) end let topo_step cs (sol,eqs) = match cs with | [] -> assert false | [c] -> solve_one c sol eqs | scc -> (* Attempt to partial solve *) List.fold_left (fun (sol,scc) c -> solve_one c sol scc) (sol,eqs) scc (** [solve_top_step [cs] tries to solve the system [cs] by sorting [cs] * topologically, returns [(sol,cs,sccs)], where * - [sol] is the "solution" resulting from the propagation of * solved equations x = cst; * - [cs] are fake equations such as delayed warnings; * - [sccs] are unsolved recusive equations at the end. * Raises `Contradiction` in case solving equations results in * some contradictory equation cst = cst` *) let solve_topo_step cs = let ns,r = eq2g cs in if debug_solver then begin if false then begin prerr_endline "** Solve topo **" ; eprintf "%s\n%!" (pp_cnstrnts cs) ; prerr_endline "** Graph **" ; EqRel.pp stderr "" (fun chan (c1,c2) -> fprintf chan "(%s) <- (%s)\n" (pp_cnstrnt c1) (pp_cnstrnt c2)) r end ; eprintf "** Equations **\n%!" ; eprintf "%s\n" (pp_cnstrnts cs) ; flush stderr ; eprintf "** Equations ordered**\n%!" ; debug_topo stderr ns r end ; EqRel.scc_kont topo_step (V.Solution.empty,[]) ns r let solve_topo cs = (* Replace equivalent variables by a class representative *) let m,cs = normalize_vars cs in let sol = try (* Solve in one scan *) let sol,cs = solve_topo_step cs in (* Add solutions of the form x := y *) let sol = add_vars_solns m sol in Maybe (sol,cs) with | Contradiction -> NoSolns in if debug_solver then begin eprintf "Solutions: %s\n" (pp_answer sol) ; flush stderr end ; sol let solve cs = if C.old_solver then solve_std cs else solve_topo cs end herd-herdtools7-1ca343e/herd/variant.ml000066400000000000000000000271351475314470400200720ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2018-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Authors: *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* Hadrien Renaud, University College London, UK. *) (****************************************************************************) type t = | Success (* Riscv Model with explicit success dependency *) | Instr (* Define instr (or same-instance) relation *) | SpecialX0 (* Some events by AMO to or from x0 are not generated *) | NoRMW (* Riscv: Expand load acquire and store release as fences *) | AcqRelAsFence (* Backward compatibility *) | BackCompat | FullScDepend (* Complete dependencies for Store Conditinal *) | SplittedRMW (* Splitted RMW events for riscv *) | SwitchDepScWrite (* Switch dependency on sc mem write, riscv, aarch64 *) | SwitchDepScResult (* Switch dependency from address read to sc result register, aarch64 *) | LrScDiffOk (* Lr/Sc paired to <> addresses may succeed (!) *) | NotWeakPredicated (* NOT "Weak" predicated instructions, not performing non-selected events, aarch64 *) | LKMMVersion of [ `lkmmv1 (* Legacy mode, e.g., wrapp rmw[Mb] instructions with explicit Mb fences *) | `lkmmv2 (* Avoid wrapping rmw[Mb] instructions with explicit Mb fences and adding noreturn tags *) ] (* Mixed size *) | Mixed | Unaligned (* Do not check (and reject early) mixed size tests in non-mixed-size mode *) | DontCheckMixed (* Tags *) | MemTag | MTEPrecision of Precision.t (* MTE tag mismatch handling *) | FaultHandling of Fault.Handling.t (* Fault handling *) | CutOff | Morello | Neon | SVE (* Specify SVE *) | SVELength of int (* vector size in bits, must be multiple of 128 *) | SME | SMELength of int (* vector size in bits, must be multiple of 128 *) (* Branch speculation+ cat computation of dependencies *) | Deps | Instances (* Compute dependencies on instruction instances *) (*Replaces old KVM -> Virtual memory *) | VMSA (* AArch64: Enhanced Translation Synchronization - FEAT_ETS, FEAT_ETS2 *) | ETS (*Deprecated*) | ETS2 (*New feature introduced after deprecating ETS*) | ETS3 (*A feature further strengthening ETS2*) (* AArch64: Enhanced Exception Synchronization - FEAT_ExS *) | ExS | EIS | EOS (* Do not insert branching event between pte read and accesses *) | NoPteBranch (* Pte-Squared: all accesses through page table, including PT accesses *) | PTE2 (* Count maximal number of phantom updates by looking at loads *) | PhantomOnLoad (* Optimise Rf enumeration leading to rmw *) | OptRfRMW (* Allow some constrained unpredictable, behaviours. AArch64: LDXR / STXR of different size or address may succeed. *) | ConstrainedUnpredictable (* Perform experiment *) | Exp (* Instruction-fetch support (AKA "self-modifying code" mode) *) | Ifetch (* CacheType features *) | DIC | IDC (* Have cat interpreter to optimise generation of co's *) | CosOpt (* Test something *) | Test (* One hundred tests *) | T of int (* ASL processing *) | ASL | ASL_AArch64 | ASLVersion of [ `ASLv0 | `ASLv1 ] (* ASL Typing control *) | ASLType of [`Warn|`Silence|`TypeCheck] (* Activate ASL experimental mode *) | ASLExperimental (* UDF control in AArch64 mode *) | ASL_AArch64_UDF (* Signed Int128 types *) | S128 (* Strict interpretation of variant, e.g. -variant asl,strict *) | Strict (* Semi-strict interpretation of variant, e.g. -variant asl,warn *) | Warn (* Telechat variant - implements unconditional branches as exit, and any other optional quirks*) | Telechat | NV2 (* Old solver, replaced by substitution following toplogical sort *) | OldSolver (* Accept cyclic equation sets as being solvable *) | OOTA let tags = ["success";"instr";"specialx0";"normw";"acqrelasfence";"backcompat"; "fullscdepend";"splittedrmw";"switchdepscwrite";"switchdepscresult";"lrscdiffok"; "mixed";"dontcheckmixed";"weakpredicated"; "lkmmv1"; "lkmmv2"; "memtag";"vmsa";"kvm";]@ Precision.tags @ Fault.Handling.tags @ ["CutOff"; "deps"; "morello"; "instances"; "noptebranch"; "pte2"; "pte-squared"; "PhantomOnLoad"; "OptRfRMW"; "ConstrainedUnpredictable"; "exp"; "self"; "cos-opt"; "test"; "T[0-9][0-9]"; "asl"; "strict"; "warn"; "S128"; "ASLType+Warn"; "ASLType+Silence"; "ASLType+Check"; "ASL+Experimental"; "ASL+AArch64+UDF"; "telechat"; "OldSolver"; "oota";] let parse s = match Misc.lowercase s with | "success" -> Some Success | "instr" -> Some Instr | "specialx0"|"amox0"|"x0" -> Some SpecialX0 | "normw" -> Some NoRMW | "acqrelasfence" -> Some AcqRelAsFence | "backcompat"|"back" -> Some BackCompat | "fullscdepend"|"scdepend" -> Some FullScDepend | "splittedrmw" -> Some SplittedRMW | "switchdepscwrite" -> Some SwitchDepScWrite | "switchdepscresult" -> Some SwitchDepScResult | "lrscdiffok" -> Some LrScDiffOk | "mixed" -> Some Mixed | "unaligned" -> Some Unaligned | "dontcheckmixed" -> Some DontCheckMixed | "notweakpredicated"|"notweakpred" -> Some NotWeakPredicated | "lkmmv1" -> Some (LKMMVersion `lkmmv1) | "lkmmv2" -> Some (LKMMVersion `lkmmv2) | "tagmem"|"memtag"|"mte" -> Some MemTag | "cutoff" -> Some CutOff | "morello" -> Some Morello | "neon" -> Some Neon | "sve" -> Some SVE | "sme" -> Some SME | "deps" -> Some Deps | "instances"|"instance" -> Some Instances | "kvm" | "vmsa" -> Some VMSA | "ets" -> Some ETS | "ets2" -> Some ETS2 | "ets3" -> Some ETS3 | "exs" -> Some ExS | "eis" -> Some EIS | "eos" -> Some EOS | "noptebranch"|"nobranch" -> Some NoPteBranch | "pte2" | "pte-squared" -> Some PTE2 | "phantomonload" -> Some PhantomOnLoad | "optrfrmw" -> Some OptRfRMW | "constrainedunpredictable"|"cu" -> Some ConstrainedUnpredictable | "exp" -> Some Exp | "ifetch"|"self" -> Some Ifetch | "dic" -> None | "idc" -> None | "cos-opt" -> Some CosOpt | "test" -> Some Test | "asl" -> Some ASL | "asl_aarch64" | "aslaarch64" | "asl+aarch64" -> Some ASL_AArch64 | "aslv0" | "asl0" | "asl_0" -> Some (ASLVersion `ASLv0) | "aslv1" | "asl1" | "asl_1" -> Some (ASLVersion `ASLv1) | "asltype+warn" -> Some (ASLType `Warn) | "asltype+silence"-> Some (ASLType `Silence) | "asltype+check" -> Some (ASLType `TypeCheck) | "asl+experimental"|"asl+exp" -> Some ASLExperimental | "asl+aarch64+udf" -> Some ASL_AArch64_UDF | "s128" -> Some S128 | "strict" -> Some Strict | "warn" -> Some Warn | "telechat" -> Some Telechat | "nv2" | "NV2" -> Some NV2 | "oldsolver" -> Some OldSolver | "oota" -> Some OOTA | s -> let (>>=) o f = match o with | Some _ -> o | None -> f s in let (|>) f g = fun s -> match f s with | Some x -> Some (g x) | None -> None in ((Fault.Handling.parse |> (fun p -> FaultHandling p)) s) >>= (Precision.parse |> (fun p -> MTEPrecision p)) >>= (fun s -> if String.length s = 3 then match s.[0],s.[1],s.[2] with | 't', ('0'..'9' as c1),('0'..'9' as c2) -> let n = (Char.code c1 - Char.code '0')*10 + (Char.code c2 - Char.code '0') in Some (T n) | _ -> None else None) >>= (fun s -> if String.length s > 4 && String.sub s 0 4 = "sve:" then try Some (SVELength (int_of_string @@ String.sub s 4 (String.length s-4))) with _ -> None else None) >>= fun s -> if String.length s > 4 && String.sub s 0 4 = "sme:" then try Some (SMELength (int_of_string @@ String.sub s 4 (String.length s-4))) with _ -> None else None let pp = function | Success -> "success" | Instr -> "instr" | SpecialX0 -> "specialx0" | NoRMW -> "normw" | AcqRelAsFence -> "acqrelasfence" | BackCompat ->"backcompat" | FullScDepend -> "FullScDepend" | SplittedRMW -> "SplittedRWM" | SwitchDepScWrite -> "SwitchDepScWrite" | SwitchDepScResult -> "SwitchDepScResult" | LrScDiffOk -> " LrScDiffOk" | Mixed -> "mixed" | Unaligned -> "unaligned" | DontCheckMixed -> "DontCheckMixed" | NotWeakPredicated -> "NotWeakPredicated" | LKMMVersion `lkmmv1 -> "lkmmv1" | LKMMVersion `lkmmv2 -> "lkmmv2" | MemTag -> "memtag" | MTEPrecision p -> Precision.pp p | FaultHandling p -> Fault.Handling.pp p | CutOff -> "CutOff" | Morello -> "Morello" | Neon -> "Neon" | SVE -> "sve" | SVELength k -> Printf.sprintf "sve:%d" k | SME -> "sme" | SMELength k -> Printf.sprintf "sme:%d" k | Deps -> "Deps" | Instances -> "Instances" | VMSA -> "vmsa" | ETS -> "ets" | ETS2 -> "ets2" | ETS3 -> "ets3" | ExS -> "exs" | EIS -> "eis" | EOS -> "eos" | NoPteBranch -> "NoPteBranch" | PTE2 -> "pte-squared" | PhantomOnLoad -> "PhantomOnLoad" | OptRfRMW -> "OptRfRMW" | ConstrainedUnpredictable -> "ConstrainedUnpredictable" | Exp -> "exp" | Ifetch -> "ifetch" | DIC -> "dic" | IDC -> "idc" | CosOpt -> "cos-opt" | Test -> "test" | T n -> Printf.sprintf "T%02i" n | ASL -> "ASL" | ASL_AArch64 -> "ASL+AArch64" | ASLVersion `ASLv0 -> "ASLv0" | ASLVersion `ASLv1 -> "ASLv1" | S128 -> "S128" | Strict -> "strict" | Warn -> "warn" | ASLType `Warn -> "ASLType+Warn" | ASLType `Silence -> "ASLType+Silence" | ASLType `TypeCheck -> "ASLType+Check" | ASLExperimental -> "ASL+Experimental" | ASL_AArch64_UDF -> "ASL+AArch64+UDF" | Telechat -> "telechat" | NV2 -> "NV2" | OldSolver -> "OldSolver" | OOTA -> "oota" let compare = compare let equal v1 v2 = compare v1 v2 = 0 let get_default a v = try match v with | SwitchDepScWrite -> begin match a with | `RISCV(*|`AArch64*) -> true | _ -> false end | SwitchDepScResult -> begin match a with | `AArch64 -> false | _ -> true end | _ -> raise Exit with Exit -> Warn.fatal "No default for variant %s" (pp v) let get_switch a v f = let d = get_default a v in if f v then not d else d let set_fault_handling r = function | FaultHandling p -> r := p; true | _ -> false let set_mte_precision r = function | MTEPrecision p -> r := p; true | _ -> false let check_vector_length memo n = let () = if n < 128 || n > 2048 || n mod 128 <> 0 then Warn.fatal "Constant %d is not a valid %s vector length (multiple of 128 between 128 and 2048)" n memo in n let set_sve_length r = function | SVELength n -> let n = check_vector_length "SVE" n in r := n ; Some SVE | _ -> None let set_sme_length r = function | SMELength n -> let n = check_vector_length "SME" n in r := n ; Some SME | _ -> None let check_tag = function | ASLExperimental -> [ASL;ASLExperimental;] | ASL_AArch64_UDF -> [ASL;ASL_AArch64_UDF;] | tag -> [tag] herd-herdtools7-1ca343e/herd/variant.mli000066400000000000000000000135541475314470400202430ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2018-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Authors: *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* Hadrien Renaud, University College London, UK. *) (****************************************************************************) type t = | Success (* Riscv Model with explicit success dependency *) | Instr (* Define "instr" relation, ie generated by the same instruction instance *) | SpecialX0 (* Some events by AMO to or from x0 are not generated *) | NoRMW (* No RMW event for C *) | AcqRelAsFence (* Riscv: Expand load acquire and store release as fences *) | BackCompat (* Linux, Backward compatibility -> LISA *) | FullScDepend (* Complete dependencies for Store Conditinal *) | SplittedRMW (* Splitted RMW events for riscv *) | SwitchDepScWrite (* Switch dependency on sc mem write, riscv *) | SwitchDepScResult (* Switch dependency from address read to sc result write, riscv,aarch64 *) | LrScDiffOk (* Lr/Sc paired to <> addresses may succeed (!) *) | NotWeakPredicated (* NOT "Weak" predicated instructions, not performing non-selected events, aarch64 *) | LKMMVersion of [ `lkmmv1 (* Legacy mode (wrapp rmw[Mb] instructions with explicit Mb fences, add noreturn tags) *) | `lkmmv2 (* Avoid wrapping rmw[Mb] instructions with explicit Mb fences and adding noreturn tags *) ] (* Mixed size *) | Mixed | Unaligned (* Do not check (and reject early) mixed size tests in non-mixed-size mode *) | DontCheckMixed | MemTag (* Memory Tagging, synonym of MTE *) | MTEPrecision of Precision.t (* MTE tag mismatch handling *) | FaultHandling of Fault.Handling.t (* Fault handling *) | CutOff | Morello | Neon | SVE (* Specify SVE *) | SVELength of int (* vector size in bits, must be multiple of 128 *) | SME | SMELength of int (* vector size in bits, must be multiple of 128 *) (* Branch speculation+ cat computation of dependencies *) | Deps | Instances (* Compute dependencies on instruction instances *) (*Replaces old KVM -> Virtual memory *) | VMSA (* AArch64: Enhanced Translation Synchronization - FEAT_ETS, FEAT_ETS2, FEAT_ETS3 *) | ETS (*Deprecated*) | ETS2 (*New feature introduced after deprecating ETS*) | ETS3 (*A feature further strengthening ETS2*) (* AArch64: Enhanced Exception Synchronization - FEAT_ExS *) | ExS | EIS | EOS (* Do not insert branching event between pte read and accesses *) | NoPteBranch (* Pte-Squared: all accesses through page table, including PT accesses *) | PTE2 (* Generate extra spurious updates based upon load on pte. *) | PhantomOnLoad (* Optimise Rf enumeration leading to rmw *) | OptRfRMW (* Allow some constrained unpredictable, behaviours. AArch64: LDXR / STXR of different size or address may succeed. *) | ConstrainedUnpredictable (* Perform experiment *) | Exp (* Instruction-fetch support (AKA "self-modifying code" mode) *) | Ifetch (* CacheType features *) | DIC | IDC (* Have cat interpreter to optimise generation of co's *) | CosOpt (* Test something *) | Test (* One hundred tests *) | T of int (* ASL Processing *) (* In AArch64 arch, use ASL to interprete AArch64 instructions when possible. *) | ASL (* While interpreting ASL litmus test, include AArch64 shared pseudocode. *) | ASL_AArch64 (* When using aarch ASL, use ASL version v0 or v1 *) | ASLVersion of [ `ASLv0 | `ASLv1 ] (* ASL Typing control *) | ASLType of [`Warn|`Silence|`TypeCheck] (* Activate ASL experimental mode *) | ASLExperimental (* UDF control in ASL+AArch64 mode *) | ASL_AArch64_UDF (* Signed Int128 types *) | S128 (* Strict interpretation of variant, e.g. -variant asl,strict *) | Strict (* Semi-strict interpretation of variant, e.g. -variant asl,warn *) | Warn (* Telechat variant - implements unconditional branches as exit, and any other optional quirks*) | Telechat | NV2 (* Old solver, new solver proceeds by substitution following toplogical sort *) | OldSolver (* Accept cyclic equation sets as being solvable *) | OOTA val compare : t -> t -> int val equal : t -> t -> bool val tags : string list val parse : string -> t option val pp : t -> string (* switch variant that flips an arch-dependent, default value *) val get_default : Archs.t -> t -> bool (* Get value for switchable variant *) val get_switch : Archs.t -> t -> (t -> bool) -> bool val set_mte_precision : Precision.t ref -> t -> bool val set_fault_handling : Fault.Handling.t ref -> t -> bool val set_sve_length : int ref -> t -> t option val set_sme_length : int ref -> t -> t option val check_tag : t -> t list herd-herdtools7-1ca343e/herd/view.ml000066400000000000000000000027001475314470400173670ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2022-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) type t = GV | Evince | Preview let tags = ["gv"; "evince"; "preview"; ] let parse tag = match Misc.lowercase tag with | "gv" -> Some GV | "evince" -> Some Evince | "preview" -> Some Preview | _ -> None let pp = function | GV -> "gv" | Evince -> "evince" | Preview -> "preview" herd-herdtools7-1ca343e/herd/view.mli000066400000000000000000000024741475314470400175500ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2022-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** 'view' tags, command display of images *) type t = GV | Evince | Preview val tags : string list val parse : string -> t option val pp : t -> string herd-herdtools7-1ca343e/herdtools7.opam000066400000000000000000000020371475314470400201140ustar00rootroot00000000000000opam-version: "2.0" synopsis: "The herdtools suite for simulating and studying weak memory models" maintainer: "Luc Maranget " authors: [ "Luc Maranget " "Jade Alglave " ] homepage: "http://diy.inria.fr/" bug-reports: "http://github.com/herd/herdtools7/issues/" doc: "http://diy.inria.fr/doc/index.html" dev-repo: "git+https://github.com/herd/herdtools7.git" license: "CECILL-B" build: [make "just-build" "PREFIX=%{prefix}%"] install: [make "install" "PREFIX=%{prefix}%"] # @todo Add "build-doc" field # @todo Add "build-test" field depends: [ "ocaml" {>= "4.08.0"} "dune" {>= "2.7" } "menhir" {>= "20200123"} "zarith" {>= "1.13"} "conf-which" ] conflicts: ["ocaml-option-bytecode-only"] url { src: "https://github.com/herd/herdtools7/archive/refs/tags/7.57.tar.gz" checksum: [ "md5=94f321f138662ba84f519376b6a9ec44" "sha512=08c6d99e8bcd1774f40daed2965f286401404dbf42c4871246edd5b64ce4fd89ead1f36d2c6d7bfc534d769888cf61b0c8cd6decca9434272c32cbef1bcd29ba" ] } herd-herdtools7-1ca343e/index.mld000066400000000000000000000002521475314470400167460ustar00rootroot00000000000000{0 Herdtools7} Welcome! The documentation for herdtools7 is at {{: https://diy.inria.fr/}}. The sources of herdtools7 are at {{: https://github.com/herd/herdtools7}}. herd-herdtools7-1ca343e/internal/000077500000000000000000000000001475314470400167565ustar00rootroot00000000000000herd-herdtools7-1ca343e/internal/binaries_of_dune000077500000000000000000000054111475314470400222000ustar00rootroot00000000000000#!/usr/bin/env ocaml (****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) #use "lib/sexp.ml";; let string_of_atom sexp = match sexp with | Atom s -> s | _ -> failwith "expected Atom" let field_values name sexp = match sexp with | List (Atom name' :: values) -> if String.compare name name' = 0 then values else [] | _ -> [] let nested_field_values key subkey stanza = stanza |> field_values key |> List.map (field_values subkey) |> List.concat let binaries_of_dune key keys dune = match dune with | List stanzas -> let key_name = List.map (nested_field_values key "name") stanzas in let keys_names = List.map (nested_field_values keys "names") stanzas in let all_names = key_name @ keys_names in all_names |> List.concat |> List.map string_of_atom | _ -> failwith "expected List of stanzas" let usage = String.concat "\n" [ Printf.sprintf "Usage: %s (executables|tests) " Sys.argv.(0) ; "" ; " executables Prints executable names from a Dune file," ; " e.g. (executables (names ...)) or (executable (name ...))." ; "" ; " tests Prints test names from a Dune file," ; " e.g. (tests (names ...)) or (test (name ...))." ; ] let () = if Array.length Sys.argv <> 3 then begin Printf.printf "%s\n" usage ; exit 1 end ; let key, keys = match Sys.argv.(1) with | "tests" -> "test", "tests" | "executables" -> "executable", "executables" | s -> failwith (Printf.sprintf "unknown kind: %s" s) in let path = Sys.argv.(2) in let dune = of_dune_file path in dune |> binaries_of_dune key keys |> List.iter (Printf.printf "%s\n") herd-herdtools7-1ca343e/internal/dune000066400000000000000000000003101475314470400176260ustar00rootroot00000000000000(executables (names herd_catalogue_regression_test herd_diycross_regression_test herd_regression_test lint_shelves herd_redirect herd_test herd_promote) (libraries internal_lib) (modes native)) herd-herdtools7-1ca343e/internal/herd_catalogue_regression_test.ml000066400000000000000000000202631475314470400255600ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Fun = Base.Fun module Option = Base.Option exception Error of string (* Flags. *) type path = string type flags = { herd : path ; libdir : path ; shelf_path : path ; kinds_path : path ; variants : string list ; } (* Permutations. *) type permutation = { cat : string ; cfg : string option ; bell : string option ; } let string_of_permutation p = match p.bell with | None -> Printf.sprintf "cat = %S" p.cat | Some bell -> Printf.sprintf "cat = %S ; bell = %S" p.cat bell let some_head = function | None|Some [] -> None | Some (x::_) -> Some x let one_of_shelf shelf = let open Shelf in let cat = match shelf.cats with | cat::_ -> cat | [] -> raise (Error "no cat file") and bell = some_head shelf.bells and cfg = match shelf.configs with | [] -> None | x::_ -> Some x in { cat; bell; cfg; } let kinds_path_of_permutation kinds_dir p = let escape_filename n = String.map (fun c -> if c = '/' then '_' else c) n in let filename_of_permutation p = match p.bell with | None -> Printf.sprintf "kinds-cat=%s.txt" p.cat | Some bell -> Printf.sprintf "kinds-bell=%s&cat=%s.txt" bell p.cat in Filename.concat kinds_dir (escape_filename (filename_of_permutation p)) let herd_kinds_of_permutation ?j ?timeout flags shelf_dir litmuses p = let prepend path = Filename.concat shelf_dir path in let cmd = TestHerd.run_herd ~bell:(Option.map prepend p.bell) ~cat:(Some (prepend p.cat)) ~conf:(Base.Option.map prepend p.cfg) ~variants:flags.variants ~libdir:flags.libdir flags.herd ?j ?timeout in match cmd litmuses with | 0,stdout, [] -> let kind_of_log l = Log.(l.name, Option.get l.kind) in List.map kind_of_log (Log.of_string_list stdout) | _, _, stderr -> failwith (Printf.sprintf "Herd returned stderr: %s" (String.concat "\n" stderr)) (* Shelves. *) let first_of_shelf shelf_path = let shelf = Shelf.of_file shelf_path in let shelf_dir = Filename.dirname shelf_path in let tests = List.map (Filename.concat shelf_dir) shelf.Shelf.tests in one_of_shelf shelf, shelf_dir, tests (* Helpers. *) let exit_1_if_any_files_missing ~description paths = match List.filter (Fun.negate Sys.file_exists) paths with | [] -> () | missing -> List.iter (Printf.printf "Missing %s: %s\n" description) missing ; raise (Error "Some files are missing") (* Commands. *) let show_tests ?j ?timeout flags = let cat, shelf_dir, tests = first_of_shelf flags.shelf_path in let prepend path = Filename.concat shelf_dir path in let command_of_permutation p = let cmd = TestHerd.herd_command ~bell:(Option.map prepend p.bell) ~cat:(Some (prepend p.cat)) ~conf:(Base.Option.map prepend p.cfg) ~variants:flags.variants ~libdir:flags.libdir flags.herd ?j ?timeout in cmd tests in command_of_permutation cat |> Printf.printf "%s\n" let run_tests ?j ?timeout flags = let cat, shelf_dir, tests = first_of_shelf flags.shelf_path in exit_1_if_any_files_missing ~description:"test" tests ; exit_1_if_any_files_missing ~description:"kinds.txt file" [flags.kinds_path] ; let result_of_permutation kinds_path p = let expected = Kinds.of_file kinds_path in let actual = herd_kinds_of_permutation ?j ?timeout flags shelf_dir tests p in let diff,miss,excess = Kinds.check ~expected ~actual in if Misc.consp miss then begin let pf = match miss with | [_] -> Printf.eprintf "Warning: test %s is not in reference kind file %s\n" | _ -> Printf.eprintf "Warning: tests %s are not in reference kind file %s\n" in pf (String.concat "," miss) kinds_path end ; if Misc.consp excess then begin let pf = match excess with | [_] -> Printf.eprintf "Warning: test %s is not in test base\n" | _ -> Printf.eprintf "Warning: tests %s are not in test base\n" in pf (String.concat "," excess) end ; match diff with | [] -> true | rs -> let pp = List.map (fun (n,ke,ka) -> Printf.sprintf "%s: expected=%s, actual=%s" n (ConstrGen.pp_kind ke) (ConstrGen.pp_kind ka)) rs in Printf.printf "Kinds differs: kinds file = %s ; %s\n" kinds_path (string_of_permutation p) ; List.iter (Printf.printf "%s\n") pp ; false in let passed = result_of_permutation flags.kinds_path cat in if not passed then exit 1 let promote_tests ?j flags = let cat, shelf_dir, tests = first_of_shelf flags.shelf_path in exit_1_if_any_files_missing ~description:"tests" tests ; let kinds = herd_kinds_of_permutation ?j flags shelf_dir tests cat in Filesystem.write_file flags.kinds_path (fun o -> output_string o (Kinds.to_string kinds)) let usage = String.concat "\n" [ Printf.sprintf "Usage: %s [options] (show|test|promote)" (Filename.basename Sys.argv.(0)) ; "" ; "Commands:" ; " show Print the herd7 commands that would be run." ; " test Compare the output of running herd7 on Catalogue tests against kinds files." ; " promote Update kinds files to the output of herd7." ; "" ; "Options:" ; ] let () = (* Required arguments. *) let herd = ref "" in let libdir = ref "" in let shelf_path = ref "" in let kinds_path = ref "" in (* Optional arguments. *) let variants = ref [] in let j = ref None in let timeout = ref None in let anon_args = ref [] in let options = [ Args.npar j ; "-herd-timeout",Arg.Float (fun f -> timeout := Some f), " herd timeout"; Args.is_file ("-herd-path", Arg.Set_string herd, "path to herd binary") ; Args.is_dir ("-libdir-path", Arg.Set_string libdir, "path to herd libdir") ; Args.is_file ("-kinds-path", Arg.Set_string kinds_path, "path to directory of kinds files to test against") ; Args.is_file ("-shelf-path", Arg.Set_string shelf_path, "path to shelf.py to test") ; "-variant", Args.append_string variants, "variant to pass to herd7" ; ] in Arg.parse options (fun a -> anon_args := a :: !anon_args) usage ; let exit_with_error msg = Printf.printf "%s: %s.\n" Sys.argv.(0) msg ; Arg.usage options usage ; exit 2 in if !herd = "" then exit_with_error "Must set -herd-path" ; if !libdir = "" then exit_with_error "Must set -libdir-path" ; if !shelf_path = "" then exit_with_error "Must set -shelf-path" ; if !kinds_path = "" then exit_with_error "Must set -kinds-path" ; let flags = { herd = !herd ; libdir = !libdir ; shelf_path = !shelf_path ; kinds_path = !kinds_path ; variants = !variants ; } in try let j = !j in let timeout = !timeout in match !anon_args with | "show" :: [] -> show_tests ?j ?timeout flags | "test" :: [] -> run_tests ?j ?timeout flags | "promote" :: [] -> promote_tests ?j flags | _ -> exit_with_error "Must provide one command of: show, test, promote" with | Error msg -> Printf.printf "Fatal error: %s\n" msg herd-herdtools7-1ca343e/internal/herd_diycross_regression_test.ml000066400000000000000000000220251475314470400254510ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** A tool that generates regression tests for herd7 using diycross7, comparing * the output against .expected files. *) (* Flags. *) type path = string type flags = { herd : path ; herd_conf : path option ; libdir : path ; diycross : path ; diycross_args : string list ; expected_dir : path ; variants : string list ; nohash : bool ; } (* Utilities. *) let list_dir dir = List.sort String.compare (Array.to_list (Sys.readdir dir)) let concat_dir dir names = List.map (Filename.concat dir) names let without_members cutset xs = List.filter (fun x -> not (List.mem x cutset)) xs let common xs ys = List.filter (fun x -> List.mem x ys) xs let diycross_args flags out_dir = ["-o"; out_dir; "-set-libdir"; flags.libdir; ] @ flags.diycross_args (* Commands *) let run_diycross flags = let tmp_dir = Filesystem.new_temp_dir () in let args = diycross_args flags tmp_dir in Command.run flags.diycross args ; tmp_dir,List.filter TestHerd.is_litmus (list_dir tmp_dir) let show_tests ?j flags = let tmp_dir,litmuses = run_diycross flags in match j with | None -> let command_of_litmus litmus = TestHerd.herd_command ~bell:None ~cat:None ~variants:flags.variants ~conf:flags.herd_conf ~libdir:flags.libdir flags.herd [litmus] in let litmus_paths = concat_dir tmp_dir litmuses in Channel.write_lines stdout (List.map command_of_litmus litmus_paths) | Some j -> let index = Filename.concat tmp_dir "@all" in let args = TestHerd.herd_args ~bell:None ~cat:None ~variants:flags.variants ~conf:flags.herd_conf ~libdir:flags.libdir ~timeout:None in let herd_dir = Filename.dirname flags.herd in let mapply = Filename.concat herd_dir "mapply7" in let args = String.concat " " (TestHerd.apply_redirect_args flags.herd j args) in Channel.write_lines stdout [Printf.sprintf "%s %s %s" mapply args index;] let run_tests ?j flags = let tmp_dir,litmuses = run_diycross flags in let expecteds = List.filter TestHerd.is_expected (list_dir flags.expected_dir) in let expected_litmuses = List.map TestHerd.litmus_of_expected expecteds in let only_in_expected = without_members litmuses expected_litmuses in let only_in_got = without_members expected_litmuses litmuses in if List.length only_in_expected > 0 then begin Printf.printf "Missing files:\n" ; List.iter (fun f -> Printf.printf " %s\n" f) only_in_expected end ; if List.length only_in_got > 0 then begin Printf.printf "Extra files:\n" ; List.iter (fun f -> Printf.printf " %s\n" f) only_in_got end ; let in_both = common litmuses expected_litmuses in let litmus_paths = concat_dir tmp_dir in_both in let expected_paths = concat_dir flags.expected_dir (List.map TestHerd.expected_of_litmus in_both) in let results = let les = List.combine litmus_paths expected_paths in match j with | None -> List.map (fun (l, e) -> TestHerd.herd_output_matches_expected ~nohash:flags.nohash ~bell:None ~cat:None ~conf:flags.herd_conf ~variants:flags.variants ~libdir:flags.libdir flags.herd l e "" "") les | Some j -> ignore (TestHerd.run_herd_concurrent ~bell:None ~cat:None ~conf:flags.herd_conf ~variants:flags.variants ~libdir:flags.libdir flags.herd ~j:j litmus_paths) ; List.map (fun (l,e) -> TestHerd.output_matches_expected ~nohash:flags.nohash l e) les in let passed x = x in let ok = (List.length only_in_expected = 0) && (List.length only_in_got = 0) && (List.for_all passed results) in if ok then begin (* Clean up and exit cleanly. *) Filesystem.remove_recursive tmp_dir end else begin (* Don't clean up in case the user wants to inspect the errors. *) Printf.printf "Some tests had errors\n" ; exit 1 end let promote_tests ?j flags = (* Run diycross *) let tmp_dir,litmuses = run_diycross flags in (* Old reference files *) let old_paths = concat_dir flags.expected_dir (List.filter TestHerd.is_expected (list_dir flags.expected_dir))in List.iter Sys.remove old_paths ; (* New reference files *) let expecteds = List.map TestHerd.expected_of_litmus litmuses in let litmus_paths = concat_dir tmp_dir litmuses in let expected_paths = concat_dir flags.expected_dir expecteds in let outputs = match j with | None -> let output_of_litmus l = TestHerd.run_herd ~bell:None ~cat:None ~conf:flags.herd_conf ~variants:flags.variants ~libdir:flags.libdir flags.herd [l] in List.map (fun l -> output_of_litmus l) litmus_paths | Some j -> ignore (TestHerd.run_herd_concurrent ~bell:None ~cat:None ~conf:flags.herd_conf ~variants:flags.variants ~libdir:flags.libdir flags.herd ~j:j litmus_paths) ; List.map (fun l -> 0, TestHerd.read_file (TestHerd.outname l), TestHerd.read_file (TestHerd.errname l)) litmus_paths in let write_file (path, (_,lines,_)) = Filesystem.write_file path (fun o -> Channel.write_lines o lines) in List.combine expected_paths outputs |> List.iter write_file ; Filesystem.remove_recursive tmp_dir let usage = String.concat "\n" [ Printf.sprintf "Usage: %s [options] (show|test|promote)" (Filename.basename Sys.argv.(0)) ; "" ; "Commands:" ; " show Print the diycross7 and herd7 commands that would be run." ; " test Compare the output of running herd7 on generated diycross7 tests against .expected files." ; " promote Update .expected files to the output of herd7." ; "" ; "Options:" ; ] let () = (* Required arguments. *) let herd = ref "" in let libdir = ref "" in let diycross = ref "" in let expected_dir = ref "" in let diycross_args = ref [] in let variants = ref [] in (* Optional arguments. *) let conf = ref None in let j = ref None in let nohash = ref false in let anon_args = ref [] in let options = [ Args.is_file ("-herd-path", Arg.Set_string herd, "path to herd binary") ; Args.is_dir ("-libdir-path", Arg.Set_string libdir, "path to herd libdir") ; Args.is_file ("-diycross-path", Arg.Set_string diycross, "path to diycross binary") ; Args.is_dir ("-expected-dir", Arg.Set_string expected_dir, "path to directory of .expected files to test against") ; "-diycross-arg", Args.append_string diycross_args, "one argument for diycross (cumulative)" ; Args.is_file ("-conf", Args.set_string_option conf, "path to config file to pass to herd7") ; "-variant", Args.append_string variants, "variant to pass to herd7" ; Args.npar j ; Args.nohash nohash ; ] in Arg.parse options (fun a -> anon_args := a :: !anon_args) usage ; let exit_with_error msg = Printf.printf "%s: %s.\n" Sys.argv.(0) msg ; Arg.usage options usage ; exit 2 in if !herd = "" then exit_with_error "Must set -herd-path" ; if !libdir = "" then exit_with_error "Must set -libdir-path" ; if !diycross = "" then exit_with_error "Must set -diycross-path" ; if !expected_dir = "" then exit_with_error "Must set -expected-dir" ; let flags = { herd = !herd ; herd_conf = !conf ; libdir = !libdir ; diycross = !diycross ; diycross_args = !diycross_args ; expected_dir = !expected_dir ; variants = !variants ; nohash = !nohash ; } in let j = !j in match !anon_args with | "show" :: [] -> show_tests ?j flags | "test" :: [] -> run_tests ?j flags | "promote" :: [] -> promote_tests ?j flags | _ -> exit_with_error "Must provide one command of: show, test, promote" herd-herdtools7-1ca343e/internal/herd_promote.ml000066400000000000000000000032361475314470400220030ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** A tool that runs herd and promotes its output as reference *) let () = if false then let xs = Array.to_list Sys.argv in Printf.eprintf "%s\n%!" (String.concat " " xs) let litmus = Sys.argv.(Array.length Sys.argv -1) let rec to_list k = if k+1 >= Array.length Sys.argv then [] else Sys.argv.(k)::to_list (k+1) let com = Sys.argv.(1) let args = to_list 2 let () = let st = TestHerd.run_herd_args com args litmus in let ok = TestHerd.promote litmus st in exit (if ok then 0 else 1) herd-herdtools7-1ca343e/internal/herd_redirect.ml000066400000000000000000000040551475314470400221170ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** A tool that runs herd, redirecting stderr and stdout *) let litmus = Sys.argv.(Array.length Sys.argv -1) let rec to_list k = if k+1 >= Array.length Sys.argv then [] else Sys.argv.(k)::to_list (k+1) let com = Sys.argv.(1) let args = to_list 2 let out_name = TestHerd.outname litmus and err_name = TestHerd.errname litmus let cat p out_chan line = if p line then Printf.fprintf out_chan "%s\n" line let run out err = let stdout = cat TestHerd.is_stable out and stderr = cat (fun _ -> true) err and stdin = Base.Iter.of_list [litmus] in ignore (Command.NonBlock.run_status ~stdin ~stdout ~stderr com args) let rm_if_empty name = let st = Unix.stat name in if st.Unix.st_size = 0 then Sys.remove name let () = Base.Fun.open_out_protect (fun out -> Base.Fun.open_out_protect (run out) err_name) out_name ; rm_if_empty out_name ; rm_if_empty err_name ; () herd-herdtools7-1ca343e/internal/herd_regression_test.ml000066400000000000000000000206431475314470400235360ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** A tool that runs regression tests of herd7, against .expected files. *) module Fun = Base.Fun (* Flags. *) type path = string type flags = { herd : path ; libdir : path ; litmus_dir : path ; variants : string list ; conf : path option ; nohash : bool ; } (* Utilities. *) let litmuses_to_sort = 1000 (** [for_each_litmus_in_dir dir f] applies [f] to each .litmus file in [dir]. * It reads [litmuses_to_sort] entries first and sorts them before applying [f], * then applies [f] to entries in an undefined order after that. * This is to balance readability of test output in `make test`, * while allowing the tool to scale to arbitrarily large directories. *) let for_each_litmus_in_dir dir f = let handle = Unix.opendir dir in let readdir () = try Some (Unix.readdir handle) with End_of_file -> None in let rec next_litmus () = match readdir () with | Some name -> if TestHerd.is_litmus name then Some name else next_litmus () | None -> None in let rec first_n_litmuses n acc = if n = 0 then acc else match next_litmus () with | Some litmus -> first_n_litmuses (n-1) (litmus :: acc) | None -> acc in let rec for_each_remaining_litmus f = match next_litmus () with | Some litmus -> f (Filename.concat dir litmus) ; for_each_remaining_litmus f | None -> () in Fun.protect ~finally:(fun () -> Unix.closedir handle) (fun () -> first_n_litmuses litmuses_to_sort [] |> List.sort String.compare |> List.map (Filename.concat dir) |> List.iter f ; for_each_remaining_litmus f ) let read_litmus_dir litmus_dir = let litmuses = ref [] in let () = for_each_litmus_in_dir litmus_dir (fun litmus -> litmuses := litmus :: !litmuses) in List.rev !litmuses (* Commands. *) let show_tests_seq flags = let command_of_litmus l = TestHerd.herd_command ~bell:None ~cat:None ~conf:flags.conf ~variants:flags.variants ~libdir:flags.libdir flags.herd [l] in for_each_litmus_in_dir flags.litmus_dir (fun l -> command_of_litmus l |> print_string ; print_char '\n' ) let show_tests_par j flags = let herd = flags.herd and args = TestHerd.herd_args ~bell:None ~cat:None ~conf:flags.conf ~variants:flags.variants ~libdir:flags.libdir ~timeout:None in let herd_test = Filename.concat (Filename.dirname Sys.argv.(0)) "herd_test.exe" in let mapply = Filename.concat (Filename.dirname herd) "mapply7" in let args = "-exit"::"true"::TestHerd.apply_args herd_test j (herd::args) in let litmuses = read_litmus_dir flags.litmus_dir in let com = Command.command mapply (args @ litmuses) in Printf.printf "%s\n%!" com let show_tests ?j flags = match j with | None -> show_tests_seq flags | Some j -> show_tests_par j flags let run_tests_seq flags = let test_passes l = TestHerd.herd_output_matches_expected ~nohash:flags.nohash ~bell:None ~cat:None ~conf:flags.conf ~variants:flags.variants ~libdir:flags.libdir flags.herd l (TestHerd.expected_of_litmus l) (TestHerd.expected_failure_of_litmus l) (TestHerd.expected_warn_of_litmus l) in let everything_passed = ref true in for_each_litmus_in_dir flags.litmus_dir (fun l -> if not (test_passes l) then everything_passed := false ) ; if not !everything_passed then begin Printf.printf "Some tests had errors\n" ; exit 1 end let do_run_test_par wrapper j flags = let wrapper = Filename.concat (Filename.dirname Sys.argv.(0)) wrapper in let _dbg = false in let herd = flags.herd and args = TestHerd.herd_args ~bell:None ~cat:None ~conf:flags.conf ~variants:flags.variants ~libdir:flags.libdir ~timeout:None in let mapply = Filename.concat (Filename.dirname herd) "mapply7" in let args = "-exit"::"true"::TestHerd.apply_args wrapper j (herd::args) in let () = if _dbg then Printf.eprintf "Mapply arguments '%s'\n%!" (String.concat " " args) in let litmuses = read_litmus_dir flags.litmus_dir in let () = if _dbg then let com = Command.command mapply (args @ litmuses) in Printf.eprintf "Wil run: %s\n%!" com in let st = Command.run_status mapply (args @ litmuses) in if st <> 0 then begin Printf.printf "Some tests had errors\n" ; exit 1 end let run_test_par = do_run_test_par "herd_test.exe" let run_tests ?j flags = match j with | None -> run_tests_seq flags | Some j -> run_test_par j flags let promote_tests_seq flags = let output_of_litmus l = TestHerd.run_herd ~bell:None ~cat:None ~conf:flags.conf ~variants:flags.variants ~libdir:flags.libdir flags.herd [l] in let everything_ok = ref true in for_each_litmus_in_dir flags.litmus_dir (fun litmus -> let ok = TestHerd.promote litmus (output_of_litmus litmus) in if not ok then everything_ok := false) ; if not !everything_ok then begin Printf.printf "Some tests had errors\n" ; exit 1 end let promote_test_par = do_run_test_par "herd_promote.exe" let promote_tests ?j flags = match j with | None -> promote_tests_seq flags | Some j -> promote_test_par j flags let usage = String.concat "\n" [ Printf.sprintf "Usage: %s [options] (show|test|promote)" (Filename.basename Sys.argv.(0)) ; "" ; "Commands:" ; " show Print the herd7 commands that would be run." ; " test Compare the output of herd7 against .expected files." ; " promote Update .expected and .expected-failure files to the output of herd7." ; "" ; "Options:" ; ] let () = (* Required arguments. *) let herd = ref "" in let libdir = ref "" in let litmus_dir = ref "" in (* Optional arguments. *) let conf = ref None in let variants = ref [] in let j = ref None in let nohash = ref false in let anon_args = ref [] in let options = [ Args.npar j; Args.nohash nohash; Args.is_file ("-herd-path", Arg.Set_string herd, "path to herd binary") ; Args.is_dir ("-libdir-path", Arg.Set_string libdir, "path to herd libdir") ; Args.is_dir ("-litmus-dir", Arg.Set_string litmus_dir, "path to directory of .litmus files to test against") ; Args.is_file ("-conf", Args.set_string_option conf, "path to config file to pass to herd7") ; "-variant", Args.append_string variants, "variant to pass to herd7" ; ] in Arg.parse options (fun a -> anon_args := a :: !anon_args) usage ; let exit_with_error msg = Printf.printf "%s: %s.\n" Sys.argv.(0) msg ; Arg.usage options usage ; exit 2 in if !herd = "" then exit_with_error "Must set -herd-path" ; if !libdir = "" then exit_with_error "Must set -libdir-path" ; if !litmus_dir = "" then exit_with_error "Must set -litmus-dir" ; let flags = { herd = !herd ; libdir = !libdir ; litmus_dir = !litmus_dir ; conf = !conf ; variants = !variants ; nohash = !nohash ; } in let j = !j in match !anon_args with | "show" :: [] -> show_tests ?j flags | "test" :: [] -> run_tests ?j flags | "promote" :: [] -> promote_tests ?j flags | _ -> exit_with_error "Must provide one command of: show, test, promote" herd-herdtools7-1ca343e/internal/herd_test.ml000066400000000000000000000040131475314470400212670ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2023-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** A tool that runs herd and compares its output against reference files *) let () = if false then let xs = Array.to_list Sys.argv in Printf.eprintf "%s\n%!" (String.concat " " xs) let litmus = Sys.argv.(Array.length Sys.argv -1) let rec to_list k = if k+1 >= Array.length Sys.argv then [] else Sys.argv.(k)::to_list (k+1) let com = Sys.argv.(1) let args = to_list 2 let () = let expected = TestHerd.expected_of_litmus litmus and expected_failure = TestHerd.expected_failure_of_litmus litmus and expected_warn = TestHerd.expected_warn_of_litmus litmus in if TestHerd.herd_args_output_matches_expected com args litmus expected expected_failure expected_warn then exit 0 else begin let () = if false then Printf.printf "Test not ok: %s %s\n%!" (String.concat " " (com::args)) litmus in exit 1 end herd-herdtools7-1ca343e/internal/lib/000077500000000000000000000000001475314470400175245ustar00rootroot00000000000000herd-herdtools7-1ca343e/internal/lib/args.ml000066400000000000000000000043651475314470400210220ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Utilities for using the built-in Arg module. *) type spec = Arg.key * Arg.spec * Arg.doc (** Specs. *) let append_string r = Arg.String (fun v -> r := !r @ [v]) let set_string_option r = Arg.String (fun v -> r := Some v) (** Common options *) let npar j = "-j",Arg.Int (fun i -> j := Some (max i 1)), " concurrent run with at most instances" let nohash b = "-nohash",Arg.Unit (fun () -> b := true), "do not check hashes" (** Validators. *) let validate check msg (key, spec, doc) = let check_value v = if not (check v) then raise (Arg.Bad (Printf.sprintf "Invalid %s: %s" key msg)) in let spec = match spec with | Arg.String f -> Arg.String (fun v -> check_value v ; f v) | Arg.Set_string r -> Arg.String (fun v -> check_value v ; r := v) | _ -> failwith "Args.validate only accepts Arg.String or Arg.Set_string" in key, spec, doc let is_file = validate (fun v -> Sys.file_exists v && not (Sys.is_directory v)) "Must be a path to a file" let is_dir = validate Sys.is_directory "Must be a path to a directory" herd-herdtools7-1ca343e/internal/lib/args.mli000066400000000000000000000044341475314470400211700ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2013-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Utilities for using the built-in Arg module. *) type spec = Arg.key * Arg.spec * Arg.doc (* Specs. *) (** [append_string r] builds an Arg.spec that appends to the string list * referenced by [r]. *) val append_string : string list ref -> Arg.spec (** [set_string_option r] builds an Arg.spec that, for argument value [v], sets * the string option referenced by [r] to [Some v]. *) val set_string_option : string option ref -> Arg.spec (** Common options *) (** [npar j] Build an Arg.spec for setting j, with documentation as * setting the parallelism level. *) val npar : int option ref -> spec (** [nohash b] Build an Arg.spec for setting b to true, with documentation as not checking hashes *) val nohash : bool ref -> spec (** Validators. *) (** [is_file (k, s, d)] returns [k, s', d], where [s'] wraps [s] with an * Arg.spec that raises Arg.Bad if the argument is not a valid path to a file. *) val is_file : spec -> spec (** [is_dir (k, s, d)] returns [k, s', d], where [s'] wraps [s] with an * Arg.spec that raises Arg.Bad if the argument is not a valid path to a * directory. *) val is_dir : spec -> spec herd-herdtools7-1ca343e/internal/lib/base.ml000066400000000000000000000060131475314470400207700ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Extending built-in / base modules, either to port future features into * earlier versions of OCaml, or to add extra functionality. *) module Fun = struct exception Finally_raised of exn let negate f = fun a -> not (f a) let protect ~finally f = let finally' () = try finally () with e -> raise (Finally_raised e) in let ret = try f () with e -> begin finally' () ; raise e end in finally' () ; ret let open_out_protect f name = let out = open_out name in protect ~finally:(fun () -> close_out out) (fun () -> f out) end module List = struct include List let rec compare cf xs ys = match xs, ys with | [], [] -> 0 | [], _ -> -1 | _, [] -> 1 | x :: xs, y :: ys -> match cf x y with | 0 -> compare cf xs ys | n -> n let to_ocaml_string f xs = Printf.sprintf "[%s]" (String.concat "; " (List.map f xs)) end module Option = struct type 'a t = 'a option let get o = match o with | None -> invalid_arg "option is None" | Some v -> v let value o ~default = match o with | None -> default | Some v -> v let map f o = match o with | None -> None | Some v -> Some (f v) let is_none o = match o with | None -> true | Some _ -> false let compare cf a b = match a, b with | None, None -> 0 | Some _, None -> 1 | None, Some _ -> -1 | Some a, Some b -> cf a b let to_ocaml_string f o = match o with | None -> "None" | Some a -> Printf.sprintf "Some (%s)" (f a) end module String = struct include String let to_ocaml_string s = Printf.sprintf "%S" s end module Iter = struct type 'a t = unit -> 'a option let of_list xs = let r = ref xs in fun () -> match !r with | [] -> None | x::xs -> r := xs ; Some x end herd-herdtools7-1ca343e/internal/lib/base.mli000066400000000000000000000102441475314470400211420ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Extending built-in / base modules, either to port future features into * earlier versions of OCaml, or to add extra functionality. *) module Fun : sig (** [Finally_raised e] is raised by [protect ~finally f] if [~finally] raises * an exception [e], to disambiguate it from exceptions raised by [f]. * If [Finally_raised] is raised, it is either an unexpected exception (e.g. * [Out_of_memory]), or programmer error. *) exception Finally_raised of exn (** [negate f] negates the predicate function [f]. *) val negate : ('a -> bool) -> ('a -> bool) (** [protect ~finally f] calls [f], then calls [~finally]. If [f] raises an * exception [e], it calls [~finally] before re-raising [e]. If [~finally] * raises an exception [e], [e] is re-raised as [Finally_raised e]. * It is equivalent to [Fun.protect] from OCaml >= 4.08. *) val protect : finally:(unit -> unit) -> (unit -> 'a) -> 'a (** [open_out_protect f name] applies f to a channel * to file whose name is [name]. Close the file under all circumstances. *) val open_out_protect : (out_channel -> 'a) -> string -> 'a end module List : sig include module type of List (** [compare c xs ys] compares lists [xs] and [ys], first by length, then by * comparing each pair of elements of [xs] and [ys] with compare function [c] * until a pair differs. *) val compare : ('a -> 'a -> int) -> 'a list -> 'a list -> int (** [to_ocaml_string f xs] returns an OCaml syntax form of [xs], applying [f] * to each element of [xs]. For example, * [to_ocaml_string String.to_ocaml_string ["a"; "b"]] returns * "[\"a\"; \"b\"]". *) val to_ocaml_string : ('a -> string) -> 'a list -> string end module String : sig include module type of String (** [to_ocaml_string s] returns an OCaml syntax form of [s]. * For example, [to_ocaml_string "a"] returns ["\"a\""]. *) val to_ocaml_string : string -> string end module Option : sig type 'a t = 'a option (** [get o] is [v] if [o] is [Some v]. * It raises [Invalid_argument] if [o] is [None]. *) val get : 'a t -> 'a (** [value o ~default] is [v] if [o] is [Some v] and [default] otherwise. *) val value : 'a option -> default:'a -> 'a (** [map f o] is [None] if [o] is [None] and [Some (f v)] if [o] is [Some v]. *) val map : ('a -> 'b) -> 'a option -> 'b option (** [is_none o] is [true] iff [o] is [None]. *) val is_none : 'a option -> bool (** [compare c x y] compares [x] and [y]. [None] is smaller than [Some _]. If * they are both [Some _] their elements are compared with function [c]. *) val compare : ('a -> 'a -> int) -> 'a option -> 'a option -> int (** [to_ocaml_string f x] returns an OCaml syntax form of [x]. If [x] is * [Some x'], [f] is applied to the element [x']. * For example, [to_ocaml_string String.to_ocaml_string (Some "hello")] * returns ["Some (\"hello\")"]. *) val to_ocaml_string : ('a -> string) -> 'a option -> string end module Iter : sig type 'a t = unit -> 'a option val of_list : 'a list -> 'a t end herd-herdtools7-1ca343e/internal/lib/channel.ml000066400000000000000000000034621475314470400214730ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Utilities for handling in_channel and out_channel. *) (* in_channel utilities *) let iter_lines f chan = try let rec iter () = f (input_line chan) ; iter () in iter () with End_of_file -> () let map_lines f chan = let ret = ref [] in iter_lines (fun l -> ret := f l :: !ret) chan ; List.rev !ret let map_opt_lines f chan = let ret = ref [] in iter_lines (fun l -> match f l with | None -> () | Some r -> ret := r :: !ret) chan ; List.rev !ret let read_lines chan = map_lines (fun l -> l) chan (* out_channel utilities *) let write_lines chan lines = List.iter (fun l -> Printf.fprintf chan "%s\n" l) lines herd-herdtools7-1ca343e/internal/lib/channel.mli000066400000000000000000000043171475314470400216440ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Utilities for handling in_channel and out_channel. *) (* in_channel utilities *) (** [iter_lines f chan] applies function [f] in turn to each line of in_channel [chan]. *) val iter_lines : (string -> unit) -> in_channel -> unit (** [map_lines f chan] applies function [f] to each line of in_channel [chan], * and returns the list [f l1; ...; f ln]. *) val map_lines : (string -> 'a) -> in_channel -> 'a list (** [map_opt_lines f chan] applies function [f] to each line of in_channel [chan], * and returns the list [r1; ...; rm], where the [rj]'s are the successul * results of applying [f] to a line in channnel, _i.e._ [f li] returns * [Some rj]. Line order is preserved. *) val map_opt_lines : (string -> 'a option ) -> in_channel -> 'a list (** [read_lines chan] reads all of in_channel [chan] as lines into a string list. *) val read_lines : in_channel -> string list (* out_channel utilities *) (** [write_lines chan lines] writes every line in [lines] to out_channel [chan]. *) val write_lines : out_channel -> string list -> unit herd-herdtools7-1ca343e/internal/lib/command.ml000066400000000000000000000176121475314470400215030ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Utilities for running commands. *) module Fun = Base.Fun module Option = Base.Option type error = { binary : string ; args : string list ; status : Unix.process_status ; } exception Error of error let command bin args = match args with | [] -> (Filename.quote bin) | _ -> Printf.sprintf "%s %s" (Filename.quote bin) (String.concat " " (List.map Filename.quote args)) let string_of_process_status = function | Unix.WEXITED n -> Printf.sprintf "returned error code %i" n | Unix.WSIGNALED n -> Printf.sprintf "killed by signal %i" n | Unix.WSTOPPED n -> Printf.sprintf "stopped by signal %i" n let string_of_error { binary = bin ; args = args ; status = s } = Printf.sprintf "Process %s (command: %s)" (string_of_process_status s) (command bin args) let nop _ = () let in_pipe nonblock = let in_fd, out_fd = Unix.pipe ~cloexec:true () in if nonblock then Unix.set_nonblock in_fd ; out_fd, Unix.in_channel_of_descr in_fd let out_pipe nonblock = let in_fd, out_fd = Unix.pipe ~cloexec:true () in if nonblock then Unix.set_nonblock out_fd ; in_fd, Unix.out_channel_of_descr out_fd let do_run must_succeed ?stdin:in_f ?stdout:out_f ?stderr:err_f bin args = (* Notes: * - By default, the file descriptors are Unix.stdin, Unix.stdout, Unix.stderr, * and the {in,out,err}_f and close_{in,out,err}_pipe functions are all nops. * - If the user passed us a function, the corresponding file descriptor is * one side of a pipe, and the close_*_pipe function closes the other side. * - Communication pipes need to be marked ~cloexec:true. * - We need to close our side of each pipe once the subprocess has started. *) let in_fd, in_f, close_in_pipe = match in_f with | None -> Unix.stdin, nop, nop | Some f -> let fd, o = out_pipe false in fd, (fun _ -> Unix.close fd ; f o), (fun _ -> close_out o) in let out_fd, out_f, close_out_pipe = match out_f with | None -> Unix.stdout, nop, nop | Some f -> let fd, i = in_pipe false in fd, (fun _ -> Unix.close fd ; f i), (fun _ -> close_in i) in let err_fd, err_f, close_err_pipe = match err_f with | None -> Unix.stderr, nop, nop | Some f -> let fd, i = in_pipe false in fd, (fun _ -> Unix.close fd ; f i), (fun _ -> close_in i) in let () = if false then Printf.printf "Running %s %s\n%!" bin (String.concat " " args) in let pid = Fun.protect ~finally:(fun _ -> close_in_pipe () ; close_out_pipe () ; close_err_pipe ()) (fun _ -> let pid = Unix.create_process bin (Array.of_list (bin :: args)) in_fd out_fd err_fd in in_f () ; out_f () ; err_f () ; pid ) in let _, status = Unix.waitpid [] pid in match status with | Unix.WEXITED 0 -> 0 | Unix.WEXITED r when not must_succeed -> r | status -> raise (Error { binary = bin ; args = args ; status = status }) let run ?stdin ?stdout ?stderr bin args = ignore (do_run true ?stdin ?stdout ?stderr bin args) and run_status ?stdin ?stdout ?stderr bin args = do_run false ?stdin ?stdout ?stderr bin args module NonBlock = struct let output_line out line = try let line = line ^ "\n" in output_string out line ; true with Sys_blocked_io -> false let process_input fds_i i = match fds_i,i with | [],_ -> i | [_],Some (i,gen) -> let rec do_rec () = match gen () with | None -> close_out i ; None | Some line -> if output_line i line then do_rec () else Some (i,gen) in do_rec () | _ -> assert false let input_lines f chan = try while true do let () = f (input_line chan) in () done ; assert false with | End_of_file -> close_in chan ; None | Sys_blocked_io -> Some (chan,f) let process_output fds o = match o with | None -> o | Some (out,f) -> let fd = Unix.descr_of_in_channel out in if List.exists (fun x -> x = fd) fds then input_lines f out else o let process_outputs fds o e = match fds with | [] -> o,e | _::_ -> let o = process_output fds o and e = process_output fds e in o,e let rec loop i o e = let fds_i = match i with | None -> [] | Some (i,_) -> [Unix.descr_of_out_channel i] and fds_o = (match o with | None -> [] | Some (o,_) -> [Unix.descr_of_in_channel o]) @(match e with | None -> [] | Some (e,_) -> [Unix.descr_of_in_channel e]) in let fds_o,fds_i,_ = Unix.select fds_o fds_i [] (-1.0) in let i = process_input fds_i i in let o,e = process_outputs fds_o o e in match i,o,e with | None,None,None -> () | _,_,_ -> loop i o e let do_run must_succeed ?stdin:in_f ?stdout:out_f ?stderr:err_f bin args = (* Notes: * - By default, the file descriptors are Unix.stdin, Unix.stdout, Unix.stderr, * and the {in,out,err}_f and close_{in,out,err}_pipe functions are all nops. * - If the user passed us a function, the corresponding file descriptor is * one side of a pipe, and the close_*_pipe function closes the other side. * - Communication pipes need to be marked ~cloexec:true. * - We need to close our side of each pipe once the subprocess has started. *) let in_fd, in_f, close_in_pipe, i = match in_f with | None -> Unix.stdin, nop, nop, None | Some f -> let fd, o = out_pipe true in fd, (fun _ -> Unix.close fd), (fun _ -> close_out o),Some (o,f) in let out_fd, out_f, close_out_pipe, o = match out_f with | None -> Unix.stdout, nop, nop, None | Some f -> let fd, i = in_pipe true in fd, (fun _ -> Unix.close fd), (fun _ -> close_in i),Some (i,f) in let err_fd, err_f, close_err_pipe, e = match err_f with | None -> Unix.stderr, nop, nop, None | Some f -> let fd, i = in_pipe true in fd, (fun _ -> Unix.close fd), (fun _ -> close_in i), Some (i,f) in let pid = Fun.protect ~finally: (fun _ -> close_in_pipe () ; close_out_pipe () ; close_err_pipe ()) (fun _ -> let pid = Unix.create_process bin (Array.of_list (bin :: args)) in_fd out_fd err_fd in in_f () ; out_f () ; err_f () ; loop i o e ; pid) in let _, status = Unix.waitpid [] pid in match status with | Unix.WEXITED 0 -> 0 | Unix.WEXITED r when not must_succeed -> r | status -> raise (Error { binary = bin ; args = args ; status = status }) let run ?stdin ?stdout ?stderr bin args = ignore (do_run true ?stdin ?stdout ?stderr bin args) and run_status ?stdin ?stdout ?stderr bin args = do_run false ?stdin ?stdout ?stderr bin args end herd-herdtools7-1ca343e/internal/lib/command.mli000066400000000000000000000063421475314470400216520ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Utilities for running commands. *) type error = { binary : string ; args : string list ; status : Unix.process_status ; } exception Error of error (** [string_of_error e] returns a human-readable representation of an error * [e]. *) val string_of_error : error -> string (** [command bin args] returns a fully escaped command line for running the * binary [bin] with arguments [args]. *) val command : string -> string list -> string (** [run ~stdin ~stdout ~stderr bin args] runs the binary [bin] with arguments [args]. * The optional parameters [~stdin], [~stdout], and [~stderr] are functions * that are applied to the stdin, stdout, and stderr of the command, in that * order. * It raises [Error] on error or non-zero exit code. *) val run : ?stdin:(out_channel -> unit) -> ?stdout:(in_channel -> unit) -> ?stderr:(in_channel -> unit) -> string -> string list -> unit (** Same as [run] above, does not raise [Error] on non-zero exit * code. Returns exit code *) val run_status : ?stdin:(out_channel -> unit) -> ?stdout:(in_channel -> unit) -> ?stderr:(in_channel -> unit) -> string -> string list -> int module NonBlock : sig (** Non blocking execution of command: * input (stdin) and outputs (stdout and stderr) are seen as non-blocking * line-oriented channels. This assumes that the underlying stdlib * functions behave properly as regards their internal structures * when would-block conditions are met. *) (** [run ~stdin ~stdout ~stderr bin args] runs the binary [bin] with arguments [args]. * The optional parameters [~stdin], [~stdout], and [~stderr] are functions * that handle channels as suites of lines. * It raises [Error] on error or non-zero exit code. *) val run : ?stdin:(unit -> string option) -> ?stdout:(string -> unit) -> ?stderr:(string -> unit) -> string -> string list -> unit (** Same as [run] above, does not raise [Error] on non-zero exit * code. Returns exit code *) val run_status : ?stdin:(unit -> string option) -> ?stdout:(string -> unit) -> ?stderr:(string -> unit) -> string -> string list -> int end herd-herdtools7-1ca343e/internal/lib/compare.ml000066400000000000000000000024601475314470400215060ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Utilities for writing compare functions. *) let rec chain cs = match cs with | [] -> 0 | c :: cs -> if c <> 0 then c else chain cs herd-herdtools7-1ca343e/internal/lib/compare.mli000066400000000000000000000025341475314470400216610ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Utilities for writing compare functions. *) (** [chain cs] returns the first non-zero element of [cs], or zero if there are * no non-zero elements. *) val chain : int list -> int herd-herdtools7-1ca343e/internal/lib/dune000066400000000000000000000001401475314470400203750ustar00rootroot00000000000000(library (name internal_lib) (libraries herdtools str unix) (modes native) (wrapped false)) herd-herdtools7-1ca343e/internal/lib/filesystem.ml000066400000000000000000000037451475314470400222530ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Filesystem and file utilities. *) let read_file path f = let chan = open_in path in let ret = try f chan with e -> begin close_in chan ; raise e end in close_in chan ; ret let write_file path f = let chan = open_out path in let ret = try f chan with e -> begin close_out chan ; raise e end in close_out chan ; ret let rec remove_recursive path = if Sys.file_exists path then begin if Sys.is_directory path then begin let children = Array.to_list (Sys.readdir path) in let child_paths = List.map (Filename.concat path) children in List.iter remove_recursive child_paths ; Unix.rmdir path end else Sys.remove path end let new_temp_dir () = let path = ref "" in Command.run ~stdout:(fun c -> path := input_line c) "mktemp" ["-d"] ; !path herd-herdtools7-1ca343e/internal/lib/filesystem.mli000066400000000000000000000037411475314470400224200ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Filesystem and file utilities. *) (** [read_file path f] opens a file for reading at [path], and calls [f] on the * open channel. The file is closed after [f] returns. If an exception is * raised, the file is closed before re-raising the exception. *) val read_file : string -> (in_channel -> 'a) -> 'a (** [write_file path f] opens a file for writing at [path], and calls [f] on * the open channel. The file is closed after [f] returns. If an exception is * raised, the file is closed before re-raising the exception. *) val write_file : string -> (out_channel -> 'a) -> 'a (** [remove_recursive path] removes [path] and all of its children, a la `rm -rf`. *) val remove_recursive : string -> unit (** [new_temp_dir ()] creates a new temporary directory, and returns the path. *) val new_temp_dir : unit -> string herd-herdtools7-1ca343e/internal/lib/kinds.ml000066400000000000000000000056071475314470400211760ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Parse kinds.txt files. *) module Option = Base.Option exception ParseError of string type kind = ConstrGen.kind type t = (string * ConstrGen.kind) list let to_map = List.fold_left (fun m (ne,ke) -> StringMap.add ne ke m) StringMap.empty let check ~expected ~actual = let diff,miss = let m = to_map expected in List.fold_left (fun (ks,miss as b) (n,ka) -> try let ke = StringMap.find n m in if ConstrGen.compare_kind ka ke = 0 then b else begin (n,ke,ka)::ks,miss end with Not_found -> ks,n::miss) ([],[]) actual in let excess = let m = to_map actual in List.fold_left (fun e (n,_) -> if StringMap.mem n m then e else n::e) [] expected in diff,miss,excess let compare xs ys = let compare_pair (x_name, x_kind) (y_name, y_kind) = match String.compare x_name y_name with | 0 -> ConstrGen.compare_kind x_kind y_kind | n -> n in Base.List.compare compare_pair xs ys let to_string ks = let max a b = if a > b then a else b in let rec max_len ks acc = match ks with | [] -> acc | (name, _) :: ks -> max_len ks (max (String.length name) acc) in let padding = max_len ks 0 in let buf = Buffer.create 16 in let append (name, kind) = Buffer.add_string buf name ; Buffer.add_string buf (String.make (1 + padding - (String.length name)) ' ') ; Buffer.add_string buf (ConstrGen.pp_kind kind) ; Buffer.add_char buf '\n' in List.iter append ks ; Buffer.contents buf module LR = LexRename.Make(struct let verbose = 0 end) let of_file path = let tbl = LR.read_from_file path ConstrGen.parse_kind in TblRename.fold (fun name (kind,_) k -> (name,kind)::k) tbl [] herd-herdtools7-1ca343e/internal/lib/kinds.mli000066400000000000000000000033331475314470400213410ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Manage kinds.txt files. *) exception ParseError of string (** [t] is an association list of (name, kind). *) type kind = ConstrGen.kind type t = (string * kind) list (** Check actual kinds against reference. * Returns pair [diff,miss] where [diff] is a listt of * differences and [miss] a list of test names whose kinds * are not in reference *) val check : expected:t -> actual:t -> (string * kind * kind) list * string list * string list val compare : t -> t -> int (* Raises ParseError. *) val of_file : string -> t val to_string : t -> string herd-herdtools7-1ca343e/internal/lib/log.ml000066400000000000000000000051111475314470400206350ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Parse herd output logs. *) module Option = Base.Option type t = { name : string ; kind : ConstrGen.kind option ; } let to_ocaml_string l = OcamlString.record [ "name", Base.String.to_ocaml_string l.name ; "kind", Option.to_ocaml_string ConstrGen.pp_kind l.kind ; ] let compare a b = Compare.chain [ String.compare a.name b.name ; Option.compare ConstrGen.compare_kind a.kind b.kind ; ] let split = LexSplit.words let rec next_test k = function | [] -> List.rev k | line::lines -> match split line with | ["Test"; name ; ("Forbidden"|"Forbid"|"Allowed");] -> in_test k name true lines | ["Test"; name ; "Required";] -> in_test k name false lines | _ -> next_test k lines and in_test k name exists = function | [] -> List.rev k | line::lines -> match split line with | "Observation"::name2::r::_ -> if name <> name2 then next_test k lines else begin let kind = let open ConstrGen in match r with | "Always" -> if exists then Allow else Require | "Sometimes" -> Allow | "Never" -> Forbid | _ -> assert false in next_test ({ name; kind=Some kind; }::k) lines end | "Test"::_ -> next_test k (line::lines) | _ -> in_test k name exists lines let of_string_list ls = next_test [] ls herd-herdtools7-1ca343e/internal/lib/log.mli000066400000000000000000000025561475314470400210200ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Parse herd output logs. *) type t = { name : string ; kind : ConstrGen.kind option ; } val compare : t -> t -> int val of_string_list : string list -> t list val to_ocaml_string : t -> string herd-herdtools7-1ca343e/internal/lib/ocamlString.ml000066400000000000000000000026601475314470400223440ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Utilities for writing to_ocaml_string functions. *) let record fields = match fields with | [] -> "{}" | _ -> let print (field, value) = Printf.sprintf "%s = %s" field value in Printf.sprintf "{ %s }" (String.concat " ; " (List.map print fields)) herd-herdtools7-1ca343e/internal/lib/ocamlString.mli000066400000000000000000000026021475314470400225110ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Utilities for writing to_ocaml_string functions. *) (** [record fields] returns an OCaml representation of a record of a list of * (field, OCaml-representation) pairs. *) val record : (string * string) list -> string herd-herdtools7-1ca343e/internal/lib/sexp.ml000066400000000000000000000116171475314470400210430ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** An S-expression type, parser, and Dune-specific parser. *) (* NOTE: Because this is used by scripts run with the OCaml top-level, it MUST * NOT depend on any code from outside this file. *) exception ParseError of string type t = | Atom of string | List of t list let compare x y = let rec compare_sexp x y = match x, y with | Atom x, Atom y -> String.compare x y | Atom _, List _ -> -1 | List _, Atom _ -> 1 | List xs, List ys -> compare_sexp_list xs ys and compare_sexp_list xs ys = match xs, ys with | [], [] -> 0 | [], _ -> -1 | _, [] -> 1 | x :: xs, y :: ys -> match compare_sexp x y with | 0 -> compare_sexp_list xs ys | n -> n in compare_sexp x y let rec to_string sexp = match sexp with | Atom s -> s | List sexps -> let subexps = List.map to_string sexps in Printf.sprintf "(%s)" (String.concat " " subexps) (* Parser. *) (* Strean is deprecated, write our simple stream module *) module MyStream = struct type t = {chan:in_channel; mutable count: int; mutable nxt: char option; mutable eof:bool; } let of_channel chan = { chan; count=0; nxt=None; eof=false; } let read_next s = if s.eof then None else let r = try let r = Some (input_char s.chan) in s.count <- s.count+1 ; r with | End_of_file -> s.eof <- true ; close_in_noerr s.chan ; None | e -> close_in_noerr s.chan ; raise e in s.nxt <- r; r let peek s = match s.nxt with | Some _ as nxt -> nxt | None -> read_next s let junk s = s.nxt <- None let count s = s.count end let from_dune_channel chan = (* This parser is written by hand because this module is used by a script run * with the OCaml top-level, and so cannot have any compilation steps, and so * cannot use ocamllex/etc. *) let printable c = match c with | '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' | '_' | '-' | '+' | ':' | '.' | '/' | '*' | '\\' | '%' | '{' | '}' -> true | _ -> false in let stream = MyStream.of_channel chan in let junk () = MyStream.junk stream in let peek () = MyStream.peek stream in let unexpected_character c = ParseError (Printf.sprintf "Unexpected character %c at char %i" c (MyStream. count stream)) in let rec whitespace () = match peek () with | Some ' ' | Some '\t' | Some '\n' | Some '\r' -> junk () ; whitespace () | _ -> () in let rec comment () = match peek () with | Some '\n' -> junk () | Some _ -> junk () ; comment () | None -> () in let atom () = let buf = Buffer.create 16 in let rec atom' () = match peek () with | Some c when printable c -> junk () ; Buffer.add_char buf c ; atom' () | _ -> Atom (Buffer.contents buf) in atom' () in let rec list (acc : t list) = whitespace () ; match peek () with | None -> raise (ParseError "Unexpected end of input") | Some ';' -> comment () ; list acc | Some '(' -> junk () ; list ((list []) :: acc) | Some ')' -> junk () ; List (List.rev acc) | Some c when printable c -> list ((atom ()) :: acc) | Some c -> raise (unexpected_character c) in let rec dune_file (acc : t list) = whitespace () ; match peek () with | None -> List (List.rev acc) | Some ';' -> comment () ; dune_file acc | Some '(' -> junk () ; dune_file ((list []) :: acc) | Some c when printable c -> dune_file ((atom ()) :: acc) | Some c -> raise (unexpected_character c) in dune_file [] let of_dune_file path = let ch = open_in path in let dune = try from_dune_channel ch with e -> close_in ch ; raise e in close_in ch ; dune herd-herdtools7-1ca343e/internal/lib/sexp.mli000066400000000000000000000031401475314470400212040ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** An S-expression type, parser, and Dune-specific parser. *) exception ParseError of string type t = | Atom of string | List of t list val compare : t -> t -> int val to_string : t -> string (** [of_dune_file path] reads the Dune configuration file at [path]. * It is a special case of S-expression, because the Dune file itself is an * implicit [List]. * [of_dune_file] can raise [ParseError]. *) val of_dune_file : string -> t herd-herdtools7-1ca343e/internal/lib/shelf.ml000066400000000000000000000123541475314470400211640ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** An OCaml representation of a shelf.py file. *) module StringList = struct let compare = Base.List.compare String.compare let to_ocaml_string = Base.List.to_ocaml_string Base.String.to_ocaml_string end module StringListOption = struct let compare = Base.Option.compare StringList.compare let to_ocaml_string = Base.Option.to_ocaml_string StringList.to_ocaml_string end exception ParseError of string type t = { record : string ; cats : string list ; configs : string list ; tests : string list ; bells : string list option ; compatibilities : string list option ; } let compare a b = Compare.chain [ String.compare a.record b.record ; StringList.compare a.cats b.cats ; StringList.compare a.configs b.configs ; StringList.compare a.tests b.tests ; StringListOption.compare a.bells b.bells ; StringListOption.compare a.compatibilities b.compatibilities ; ] let to_ocaml_string shelf = OcamlString.record [ "record", Base.String.to_ocaml_string shelf.record ; "cats", StringList.to_ocaml_string shelf.cats ; "configs", StringList.to_ocaml_string shelf.configs ; "tests", StringList.to_ocaml_string shelf.tests ; "bells", StringListOption.to_ocaml_string shelf.bells ; "compatibilities", StringListOption.to_ocaml_string shelf.compatibilities ; ] let python = lazy begin let exists p = let dev_null ch = ignore (Channel.read_lines ch) in try Command.run ~stdout:dev_null ~stderr:dev_null p ["--version"] ; true with | Unix.Unix_error _ -> false | Command.Error _ -> false in match List.find_opt exists ["python"; "python3"] with | Some p -> p | None -> failwith "Could not find either python or python3" end let do_list_of_file sorted path key = (* Shelf files are executable Python code, so this Python script imports the * shelf.py file, then prints the given global variables. *) let script chan = Printf.fprintf chan "import os\n" ; Printf.fprintf chan "import sys\n" ; Printf.fprintf chan "os.chdir(%s)\n" (Filename.quote (Filename.dirname path)) ; Printf.fprintf chan "m = {}\n" ; Printf.fprintf chan "if sys.version_info >= (3, 0):\n" ; Printf.fprintf chan " exec(open(%s).read(), m)\n" (Filename.quote (Filename.basename path)) ; Printf.fprintf chan "else:\n" ; Printf.fprintf chan " execfile(%s, m)\n" (Filename.quote (Filename.basename path)) ; Printf.fprintf chan "try:\n" ; Printf.fprintf chan " v = m[%s]\n" (Filename.quote key) ; Printf.fprintf chan " if isinstance(v, str):\n" ; Printf.fprintf chan " print(v)\n" ; Printf.fprintf chan " else:\n" ; Printf.fprintf chan " for x in v:\n" ; Printf.fprintf chan " print(x)\n" ; Printf.fprintf chan "except:\n" ; Printf.fprintf chan " pass\n" ; close_out chan in let lines = ref [] in let read_lines c = lines := Channel.read_lines c in begin try Command.run ~stdin:script ~stdout:read_lines (Lazy.force python) [] with Command.Error e -> failwith (Command.string_of_error e) end ; if sorted then List.sort String.compare !lines else !lines let list_of_file = do_list_of_file false and list_of_file_sorted = do_list_of_file true let string_of_file path key = match list_of_file path key with | x :: [] -> x | [] -> raise (ParseError (Printf.sprintf "Missing value for key %s" key)) | xs -> raise (ParseError (Printf.sprintf "Expected single value for key %s, found %i" key (List.length xs))) let optional_list_of_file path key = match list_of_file path key with | [] -> None | xs -> Some xs let of_file path = { record = string_of_file path "record" ; cats = list_of_file path "cats" ; configs = list_of_file path "cfgs" ; tests = (match list_of_file_sorted path "illustrative_tests" with | [] -> list_of_file_sorted path "tests" | xs -> xs); bells = optional_list_of_file path "bells" ; compatibilities = optional_list_of_file path "compatibilities" ; } herd-herdtools7-1ca343e/internal/lib/shelf.mli000066400000000000000000000035041475314470400213320ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** An OCaml representation of a shelf.py file. *) type t = { record : string ; cats : string list ; configs : string list ; tests : string list ; bells : string list option ; compatibilities : string list option ; } val compare : t -> t -> int (** [to_ocaml_string s] returns a string of the OCaml literal representation of * a Shelf [s]. *) val to_ocaml_string : t -> string (** [of_file path] reads a Shelf from a shelf.py file. * It can raise [ParseError]. *) val of_file : string -> t (** For testing purposes, this is the name of a valid python progam name. This might fail at runtime if no such thing is found. *) val python : string Lazy.t herd-herdtools7-1ca343e/internal/lib/test.ml000066400000000000000000000046711475314470400210450ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Unit-testing utilities. *) exception AssertionFailure of string let run_test (name, test) = try test () ; true with | AssertionFailure msg -> Printf.printf "Failed: %s: %s\n" name msg ; false | e -> Printf.printf "Failed %s: raised exception\n" name ; raise e let run tests = let results = List.map run_test tests in let failed r = not r in if List.exists failed results then exit 1 let fail msg = raise (AssertionFailure msg) (* Pretty-printing for failure messages. *) let pp_list pp_x xs = Printf.sprintf "[%s]" (String.concat "; " (List.map pp_x xs)) let pp_int_list xs = pp_list (Printf.sprintf "%i") xs let pp_string_list xs = pp_list (Printf.sprintf "%S") xs (* Comparisons. *) let int_compare (x:int) (y:int) = compare x y let rec find_comparison cs = match cs with | [] -> 0 | c :: cs' -> if c <> 0 then c else (find_comparison cs') let list_compare c xs ys = let compared_length = int_compare (List.length xs) (List.length ys) in if compared_length = 0 then begin List.combine xs ys |> List.map (fun (x, y) -> c x y) |> find_comparison end else compared_length let string_list_compare xs ys = list_compare String.compare xs ys let int_list_compare xs ys = list_compare int_compare xs ys herd-herdtools7-1ca343e/internal/lib/test.mli000066400000000000000000000052421475314470400212110ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Unit-testing utilities. *) (** Raising [AssertionFailure msg] causes a test to fail, printing the reason * for failing [msg]. *) exception AssertionFailure of string (** [run tests] runs every named test in [tests], printing an error message if * a test fails. *) val run : (string * (unit -> unit)) list -> unit (** [fail msg] raises an AssertionFailure with error message [msg], causing * the test to fail. *) val fail : string -> unit (* Pretty-printing for failure messages. *) (** [pp_list f xs] prints a list [xs] as though OCaml syntax, applying [f] to * each member. *) val pp_list : ('a -> string) -> 'a list -> string (** [pp_int_list xs] prints a list [xs] of ints as though OCaml syntax. For * example, [pp_int_list [1; 2]] returns "[1; 2]". *) val pp_int_list : int list -> string (** [pp_string_list xs] prints a list [xs] of strings as though OCaml * syntax. For example, [pp_string_list ["a"; "b"]] returns * "[\"a\"; \"b\"]". *) val pp_string_list : string list -> string (* Comparisons. *) (** [list_compare c xs ys] compares lists [xs] and [ys], first by length, * comparing each pair of elements of [xs] and [ys] with compare function [c] * until a pair differs. *) val list_compare : ('a -> 'a -> int) -> 'a list -> 'a list -> int (** [int_list_compare xs ys] compares int lists [xs] and [ys]. *) val int_list_compare : int list -> int list -> int (** [string_list_compare xs ys] compares string lists [xs] and [ys]. *) val string_list_compare : string list -> string list -> int herd-herdtools7-1ca343e/internal/lib/testHerd.ml000066400000000000000000000257471475314470400216570ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Utilities for running Herd binaries in tests. *) let _dbg = true type path = string type stdout_lines = string list type stderr_lines = string list let outname l = l ^ ".out" and errname l = l ^ ".err" let read_file name = if Sys.file_exists name then Filesystem.read_file name Channel.read_lines else [] let time_re = Str.regexp "^Time " let is_stable line = not (Str.string_match time_re line 0) let without_unstable_lines lines = List.filter is_stable lines let hash_re = Str.regexp "^Hash=" let compare_lines nohash l1 l2 = (nohash && Str.string_match hash_re l1 0 && Str.string_match hash_re l2 0) || String.equal l1 l2 let rec log_equal nohash xs ys = match xs,ys with | [],[] -> true | x::xs,y::ys -> compare_lines nohash x y && log_equal nohash xs ys | ([],_::_)|(_::_,[]) -> false let log_diff nohash xs ys = not (log_equal nohash xs ys) let herd_args ~bell ~cat ~conf ~variants ~libdir ~timeout = let timeout = match timeout with | None -> [] | Some t -> ["-timeout"; Printf.sprintf "%.2f" t;] in let bells = match bell with | None -> [] | Some bell -> ["-bell"; bell] in let cats = match cat with | None -> [] | Some cat -> ["-cat"; cat; "-I"; Filename.dirname cat] in let confs = match conf with | None -> [] | Some conf -> ["-conf"; conf] in let variants = List.concat (List.map (fun v -> ["-variant"; v]) variants) in let libdirs = ["-set-libdir"; libdir] in List.concat [["-exit"; "true";]; libdirs; timeout; bells; cats; confs; variants;] let apply_args herd j herd_args = let herd_args = String.concat "," herd_args in ["-com"; herd; "-j" ; Printf.sprintf "%i" j; "-comargs"; herd_args;] let apply_redirect_args herd j herd_args = let redirect_args = String.concat "," (herd::herd_args) in let redirect = Filename.concat (Filename.dirname Sys.argv.(0)) "herd_redirect.exe" in ["-com"; redirect; "-j"; Printf.sprintf "%i" j; "-comargs"; redirect_args;] let herd_command ~bell ~cat ~conf ~variants ~libdir herd ?j ?timeout litmuses = let args = herd_args ~bell:bell ~cat:cat ~conf:conf ~variants:variants ~libdir:libdir ~timeout:timeout in match j with | None -> Command.command herd (args @ litmuses) | Some j -> let mapply = Filename.concat (Filename.dirname herd) "mapply7" in let args = apply_args herd j args in Command.command mapply (args @ litmuses) let do_run_herd_args herd args ?j litmuses = let litmuses = Base.Iter.of_list litmuses in (* * Record stdout and stderr to two sources if we need * to reason about them separately. *) let lines = ref [] in let err_lines = ref [] in let read_line line = lines := line :: !lines in let read_err_line line = err_lines := line :: !err_lines in let r = match j with | None -> Command.NonBlock.run_status ~stdin:litmuses ~stdout:read_line ~stderr:read_err_line herd args | Some j -> let j = max 2 j in let mapply = Filename.concat (Filename.dirname herd) "mapply7" in let args = apply_args herd j args in Command.NonBlock.run_status ~stdin:litmuses ~stdout:read_line ~stderr:read_err_line mapply args in (r,without_unstable_lines (List.rev !lines), (List.rev !err_lines)) let run_herd_args herd args litmus = do_run_herd_args herd args [litmus] let run_herd ~bell ~cat ~conf ~variants ~libdir herd ?j ?timeout litmuses = let args = herd_args ~bell:bell ~cat:cat ~conf:conf ~variants:variants ~libdir:libdir ~timeout:timeout in do_run_herd_args herd args ?j litmuses let run_herd_concurrent ~bell ~cat ~conf ~variants ~libdir herd ~j litmuses = let args = herd_args ~bell:bell ~cat:cat ~conf:conf ~variants:variants ~libdir:libdir ~timeout:None in let litmuses = Base.Iter.of_list litmuses in let j = max 2 j in let mapply = Filename.concat (Filename.dirname herd) "mapply7" in let args = apply_redirect_args herd j args in let r = Command.NonBlock.run_status ~stdin:litmuses mapply args in r let read_some_file litmus name = if name = "" then None else try Some (Filesystem.read_file name Channel.read_lines) with _ -> begin Printf.printf "Failed %s : Missing file '%s'\n" litmus name ; None end let do_check_output nohash litmus expected expected_failure expected_warn t = let () = let _,lines,_ = t in if false && lines <> [] then begin Printf.eprintf "Expected %s, Out of test:\n" expected ; List.iter prerr_endline lines end in match t with | 0,[],[] -> true (* Can occur in case of controlled timeout *) | _,[],[] -> Printf.printf "Failed %s : Herd finished but returned no output or errors\n" litmus ; false | 0,(_::_ as stdout), [] -> (* Herd finished without errors - normal *) begin match read_some_file litmus expected with | None -> false | Some expected_output -> if log_diff nohash stdout expected_output then begin Printf.printf "Failed %s : Logs do not match\n%!" litmus ; false end else true end | r,[], (_::_ as stderr) when r <> 0 -> (* Herd finished with errors - check expected failure *) begin match read_some_file litmus expected_failure with | None -> false | Some expected_failure_output -> if log_diff nohash stderr expected_failure_output then begin Printf.printf "Failed %s : Expected Failure Logs do not match\n" litmus ; false end else true end | 0,(_::_ as stdout),(_::_ as stderr) -> (* Herd returned both output and errors *) begin match read_some_file litmus expected with | None -> false | Some expected_output -> if log_diff nohash stdout expected_output then begin Printf.printf "Failed %s : Logs do not match\n" litmus ; false end else match read_some_file litmus expected_warn with | None -> if _dbg then begin Printf.eprintf "** Unexpected warning stderr for %s\n" (Filename.basename litmus) ; List.iter prerr_endline stderr end ; false | Some expected_warn -> if log_diff nohash stderr expected_warn then begin Printf.printf "Failed %s : Warning logs do not match\n" litmus ; false end else true end | r,stdout,stderr -> let some f = match f with | [] -> "no" | _::_ -> "some" in Printf.printf "Failed %s : unexpected exit code %i, %s output %s error.\n" litmus r (some stdout) (some stderr) ; if _dbg then begin let display tag = function | [] -> () | _::_ as lines -> Printf.printf "** %s %%\n" tag ; List.iter print_endline lines in display "stdout" stdout ; display "stderr" stderr end ; false let read_output_files litmus = let o = read_file (outname litmus) and e = read_file (errname litmus) in o,e let output_matches_expected ?(nohash=false) litmus expected = try let o,e = read_output_files litmus in do_check_output nohash litmus expected "" "" (0,o,e) with Command.Error e -> Printf.printf "Failed %s : %s \n" litmus (Command.string_of_error e) ; false let do_herd_output_matches_expected nohash do_run litmus expected expected_failure expected_warn = try let t = do_run litmus in do_check_output nohash litmus expected expected_failure expected_warn t with | Command.Error e -> Printf.printf "Failed %s : %s \n" litmus (Command.string_of_error e) ; false let herd_output_matches_expected ?(nohash=false) ~bell ~cat ~conf ~variants ~libdir herd litmus expected expected_failure expected_warn = do_herd_output_matches_expected nohash (fun litmus -> run_herd ~bell:bell ~cat:cat ~conf:conf ~variants:variants ~libdir:libdir herd [litmus]) litmus expected expected_failure expected_warn let herd_args_output_matches_expected ?(nohash=false) herd args litmus expected expected_failure expected_warn = do_herd_output_matches_expected nohash (run_herd_args herd args) litmus expected expected_failure expected_warn let is_litmus path = Filename.check_suffix path ".litmus" let is_expected path = Filename.check_suffix path ".litmus.expected" let expected_of_litmus litmus = litmus ^ ".expected" let litmus_of_expected expected = Filename.chop_suffix expected ".expected" let expected_failure_of_litmus litmus = litmus ^ ".expected-failure" let litmus_of_expected_failure expected = Filename.chop_suffix expected ".expected-failure" let expected_warn_of_litmus litmus = litmus ^ ".expected-warn" let remove_if_exists path = if Sys.file_exists path then Sys.remove path let write_file path lines = Filesystem.write_file path (fun o -> Channel.write_lines o lines) let promote litmus t = let expected = expected_of_litmus litmus in let expected_failure = expected_failure_of_litmus litmus in match t with | 0, [], [] -> Printf.printf "Failed %s : Returned neither stdout nor stderr\n" litmus ; false | 0, out, [] -> remove_if_exists expected_failure ; write_file expected out ; true | r, [], err when r <> 0 -> remove_if_exists expected ; write_file expected_failure err ; true | 0, out, err -> write_file expected out ; let expected_warn = expected_warn_of_litmus litmus in write_file expected_warn err ; true | r, _, _ -> Printf.printf "Failed %s : unexpected exit code %i\n" litmus r ; false herd-herdtools7-1ca343e/internal/lib/testHerd.mli000066400000000000000000000156671475314470400220300ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (* Utilities for running Herd binaries in tests. *) type path = string type stdout_lines = string list type stderr_lines = string list (** Systematic file names for standard output and standard error , from test file name *) val outname : string -> string val errname : string -> string (** [read_file name] returns the contents of file [name] as a list * of lines. Returns the empty list when file is absent *) val read_file : string -> string list (** [is_stable line] returns [true] when line from output is to be kept *) val is_stable : string -> bool (** Format herd command-line options as a list *) val herd_args : bell : path option -> cat : path option -> conf : path option -> variants : string list -> libdir : path -> timeout : float option -> string list (** [apply_args herd j args] Format mapply command-line options as a list, * where [herd] is path to herd command, [j] is concurrency leval and * [args] is the list of [herd] command-line options. *) val apply_args : string -> int -> string list -> string list (** Same as above, with additional redirection of output channels * to conventional files. *) val apply_redirect_args : string -> int -> string list -> string list (** [herd_command ~bell ~cat ~conf ~variants ~libdir herd ?j litmuses] returns the * command line that [run_herd] would run. *) val herd_command : bell : path option -> cat : path option -> conf : path option -> variants : string list -> libdir : path -> path -> ?j:int -> ?timeout:float -> path list -> string (** [run_herd ~bell ~cat ~conf ~variants ~libdir herd ?j litmuses] runs the * binary [herd] with a custom [libdir] on list of litmus files [litmuses], * and returns the stdout with unstable lines removed (e.g. Time) and stderr. * Paths to [cat], [bell], and [conf] files, as well as [variants], can also * be passed in. * If argument [j] is present, at most [j] tests are run concurrently *) val run_herd : bell : path option -> cat : path option -> conf : path option -> variants : string list -> libdir : path -> path -> ?j:int -> ?timeout:float -> path list -> int * string list * string list (** [run_herd_args herd args litmus] similar in functionality to * [run_herd] above but different as regards interface: * 1. Command-line options are given as a list of strings; * 2. One litmus test only is given as argument. *) val run_herd_args : path -> string list -> path -> int * string list * string list (** [run_herd_concurrent ~bell ~cat ~conf ~variants ~libdir herd j litmuses] * Similar to [run_herd] except that output is stored into files specific * to each test: [litmus].out and [litmus].err. *) val run_herd_concurrent : bell : path option -> cat : path option -> conf : path option -> variants : string list -> libdir : path -> path -> j:int-> path list -> int (** [herd_output_matches_expected nohash litmus expected] returns true when * the output file produced by running [litmus] matches reference * [expected]. If argument [nohash] is true, hashes are not compared. *) val output_matches_expected : ?nohash:bool -> path -> path -> bool (** [herd_output_matches_expected ~bell ~cat ~conf ~variants ~libdir herd * litmus expected expected_failure expected_warn] runs the binary * [herd] with a custom [libdir] on a [litmus] file, * and compares the output with an [expected] file. * If the run writes to stderr then we check [expected_failure]. If the * contents of [expected_failure] match then it is an expected failure, * otherwise it is an unexpected failure and will raise an Error. * If the run writes to both stdout and stderr, stdout is checked * against the [expected] file, while stderr is checked against * the [expected_warn] file. If any file is missing or differs, * an Error is raised. * Paths to [cat], [bell], and [conf] files, as well as [variants], can also * be passed in. *) val herd_output_matches_expected : ?nohash : bool -> bell : path option -> cat : path option -> conf : path option -> variants : string list -> libdir : path -> path -> path -> path -> path -> path -> bool (** [herd_args_output_mathes_expected herd args litmus * expected expected_failure expected_warn] has the same functionality * as [herd_output_matches_expected] above but a different interface, * as command line options are given as the list [args]. *) val herd_args_output_matches_expected : ?nohash:bool -> path -> string list -> path -> path -> path -> path -> bool (** [is_litmus filename] returns whether the [filename] is a .litmus file. *) val is_litmus : path -> bool (** [is_expected filename] returns whether [filename] is a .litmus.expected file. *) val is_expected : path -> bool (** [expected_of_litmus filename] returns the .litmus.expected name for a given .litmus [filename]. *) val expected_of_litmus : path -> path (** [litmus_of_expected filename] returns the .litmus name for a given .litmus.expected [filename]. *) val litmus_of_expected : path -> path (** [expected_failure_of_litmus filename] returns the .litmus.expected-failure name for a given .litmus [filename]. *) val expected_failure_of_litmus : path -> path (** [litmus_of_expected_failure filename] returns the .litmus name for a given .litmus.expected-failure [filename]. *) val litmus_of_expected_failure : path -> path (** [expected_warn_of_litmus filename] returns the .litmus.expected-warn name for a given .litmus [filename]. *) val expected_warn_of_litmus : path -> path (** [promote litmus result] it is assumed that result is the result of running the test [litmus]. * Promote [result] as the reference for test [litmus]. If anyrging is wrong, return [false]. *) val promote : path -> (int * string list * string list) -> bool herd-herdtools7-1ca343e/internal/lib/tests/000077500000000000000000000000001475314470400206665ustar00rootroot00000000000000herd-herdtools7-1ca343e/internal/lib/tests/base_test.ml000066400000000000000000000102111475314470400231640ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Tests for the Base modules. *) let tests = [ "Base.Fun.protect calls both f and finally", (fun () -> let called_f = ref false in let called_finally = ref false in Base.Fun.protect ~finally:(fun () -> called_finally := true) (fun () -> called_f := true) ; if not !called_f then Test.fail "did not call f" ; if not !called_finally then Test.fail "did not call finally" ); "Base.Fun.protect calls finally before re-raising exception", (fun () -> let called_finally = ref false in let raised_exception = try Base.Fun.protect ~finally:(fun () -> called_finally := true) (fun () -> if true then raise Not_found ; ()) ; false with Not_found -> true in if not raised_exception then Test.fail "did not re-raise exception" ; if not !called_finally then Test.fail "did not call finally" ); "Base.Fun.protect wraps exceptions raised by finally", (fun () -> let raised_exception = try Base.Fun.protect ~finally:(fun () -> raise Not_found) (fun () -> ()) ; false with Base.Fun.Finally_raised Not_found -> true in if not raised_exception then Test.fail "did not wrap & re-raise exception" ; ); "Base.List.compare", (fun () -> let tests = [ [], [], 0 ; ["a"], [], 1 ; [], ["a"], -1 ; ["a"], ["a"], 0 ; ["a"], ["b"], -1 ; ] in List.iteri (fun i (xs, ys, expected) -> let actual = Base.List.compare Base.String.compare xs ys in if actual <> expected then Test.fail (Printf.sprintf "[%i] expected %i, got %i" i expected actual) ) tests ); "Base.List.to_ocaml_string", (fun () -> let tests = [ [], "[]" ; ["a"], "[\"a\"]" ; ["a"; "b"], "[\"a\"; \"b\"]" ; ] in List.iter (fun (xs, expected) -> let actual = Base.List.to_ocaml_string Base.String.to_ocaml_string xs in if String.compare actual expected <> 0 then Test.fail (Printf.sprintf "expected %s, got %s" expected actual) ) tests ); "Base.Option.compare", (fun () -> let tests = [ None, None, 0 ; Some "a", None, 1 ; None, Some "a", -1 ; Some "a", Some "a", 0 ; Some "a", Some "b", -1 ; ] in List.iteri (fun i (xs, ys, expected) -> let actual = Base.Option.compare Base.String.compare xs ys in if actual <> expected then Test.fail (Printf.sprintf "[%i] expected %i, got %i" i expected actual) ) tests ); "Base.Option.to_ocaml_string", (fun () -> let tests = [ None, "None" ; Some "a", "Some (\"a\")" ; ] in List.iter (fun (xs, expected) -> let actual = Base.Option.to_ocaml_string Base.String.to_ocaml_string xs in if String.compare actual expected <> 0 then Test.fail (Printf.sprintf "expected %s, got %s" expected actual) ) tests ); ] let () = Test.run tests herd-herdtools7-1ca343e/internal/lib/tests/channel_test.ml000066400000000000000000000045451475314470400236770ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Tests for the Channel module. *) let pp_int_list = Test.pp_int_list let pp_string_list = Test.pp_string_list let tests = [ "Channel.read_lines and Channel.write_lines", (fun () -> let in_fd, out_fd = Unix.pipe () in let in_ch, out_ch = Unix.in_channel_of_descr in_fd, Unix.out_channel_of_descr out_fd in let lines = ["mew"; "purr"] in Channel.write_lines out_ch lines ; close_out out_ch ; let actual = Channel.read_lines in_ch in close_in in_ch ; if Test.string_list_compare lines actual <> 0 then Test.fail (Printf.sprintf "Expected %s, got %s" (pp_string_list lines) (pp_string_list actual)) ); "Channel.map_lines applies f", (fun () -> let in_fd, out_fd = Unix.pipe () in let in_ch, out_ch = Unix.in_channel_of_descr in_fd, Unix.out_channel_of_descr out_fd in let lines = ["mew"; "purr"] in Channel.write_lines out_ch lines ; close_out out_ch ; let expected = [3; 4] in let actual = Channel.map_lines String.length in_ch in close_in in_ch ; if Test.int_list_compare expected actual <> 0 then Test.fail (Printf.sprintf "Expected %s, got %s" (pp_int_list expected) (pp_int_list actual)) ); ] let () = Test.run tests herd-herdtools7-1ca343e/internal/lib/tests/command_test.ml000066400000000000000000000121551475314470400237010ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Tests for the Command module. *) module Option = Base.Option module StringList = struct let compare = Base.List.compare String.compare let to_ocaml_string = Base.List.to_ocaml_string Base.String.to_ocaml_string end let tests = [ "Command.command without args", (fun () -> let expected = "'foo'" in let actual = Command.command "foo" [] in if String.compare actual expected <> 0 then Test.fail (Printf.sprintf "Expected %s, got %s" expected actual) ); "Command.command with args", (fun () -> let expected = "'foo' '-bar' 'baz'" in let actual = Command.command "foo" ["-bar"; "baz"] in if String.compare actual expected <> 0 then Test.fail (Printf.sprintf "Expected %s, got %s" expected actual) ); "Command.command with escaping args", (fun () -> let expected = "'/bin/do foo' '-a flag' '~/foo'\\''s files/'" in let actual = Command.command "/bin/do foo" ["-a flag"; "~/foo's files/"] in if String.compare actual expected <> 0 then Test.fail (Printf.sprintf "Expected %s, got %s" expected actual) ); "Command.run runs cleanly", (fun () -> (* This test uses `touch`, because it is a command that produces a * side-effect, and so can be verified to have run. *) (* Create a random file path, by creating a random file and deleting it. *) let path = Filename.temp_file "" "" in Sys.remove path ; (* Recreate it with `touch`. *) Command.run "touch" [path] ; if not (Sys.file_exists path) then Test.fail "File doesn't exist after `touch`" else (* Cleanup. *) Sys.remove path ); "Command.run ~stdout", (fun () -> let tests = [ ("true", [], []); ("echo", ["foo"], ["foo"]); ("echo", ["foo\nbar"], ["foo"; "bar"]); ] in List.iter (fun (bin, args, expected) -> let actual = ref None in let read_lines i = actual := Some (Channel.read_lines i) in Command.run ~stdout:read_lines bin args ; let actual = Option.get !actual in if StringList.compare actual expected <> 0 then Test.fail (Printf.sprintf "Expected %s, got %s" (StringList.to_ocaml_string expected) (StringList.to_ocaml_string actual) ) ) tests ); "Command.run ~stdin ~stdout", (fun () -> let echo o = Printf.fprintf o "I am a line\n" ; Printf.fprintf o "so am I\n" ; close_out o in let expected = [ "I am a line" ; "so am I" ; ] in let actual = ref None in let read_lines i = actual := Some (Channel.read_lines i) in Command.run ~stdin:echo ~stdout:read_lines "cat" [] ; let actual = Option.get !actual in if StringList.compare actual expected <> 0 then Test.fail (Printf.sprintf "expected %s, got %s" (StringList.to_ocaml_string expected) (StringList.to_ocaml_string actual) ) ); "Command.run ~stdout ~stderr", (fun () -> let bin = Lazy.force Shelf.python in let args = [ "-c" ; "import sys; sys.stdout.write('mew\\n'); sys.stderr.write('purr\\n')" ; ] in let expected_stdout = [ "mew" ] in let expected_stderr = [ "purr" ] in let actual_stdout = ref None in let actual_stderr = ref None in let read r i = r := Some (Channel.read_lines i) in Command.run ~stdout:(read actual_stdout) ~stderr:(read actual_stderr) bin args ; let actual_stdout = Option.get !actual_stdout in let actual_stderr = Option.get !actual_stderr in if StringList.compare actual_stdout expected_stdout <> 0 then Test.fail (Printf.sprintf "stdout: expected %s, got %s" (StringList.to_ocaml_string expected_stdout) (StringList.to_ocaml_string actual_stdout) ) ; if StringList.compare actual_stderr expected_stderr <> 0 then Test.fail (Printf.sprintf "stderr: expected %s, got %s" (StringList.to_ocaml_string expected_stderr) (StringList.to_ocaml_string actual_stderr) ) ); ] let () = Test.run tests herd-herdtools7-1ca343e/internal/lib/tests/compare_test.ml000066400000000000000000000031511475314470400237050ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Tests for the Compare module. *) let tests = [ "Compare.chain", (fun () -> let tests = [ [], 0 ; [0; 0], 0 ; [1; 0], 1 ; [-1; 1; 0], -1 ; [0; -1; 1; 0], -1 ; ] in List.iter (fun (cs, expected) -> let actual = Compare.chain cs in if actual <> expected then Test.fail (Printf.sprintf "expected %i, got %i" expected actual) ) tests ); ] let () = Test.run tests herd-herdtools7-1ca343e/internal/lib/tests/dune000066400000000000000000000002751475314470400215500ustar00rootroot00000000000000(tests (names base_test channel_test command_test compare_test filesystem_test log_test ocamlString_test sexp_test shelf_test test_test) (libraries internal_lib unix) (modes native)) herd-herdtools7-1ca343e/internal/lib/tests/filesystem_test.ml000066400000000000000000000100271475314470400244430ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Filesystem and file utilities. *) let pp_string_list = Test.pp_string_list let tests = [ "Filesystem.read_file and Filesystem.write_file", (fun () -> let tests = [ [] ; ["foo"; "bar"] ; ] in List.iter (fun lines -> let path = Filename.temp_file "" "" in Filesystem.write_file path (fun o -> Channel.write_lines o lines) ; let actual = Filesystem.read_file path Channel.read_lines in (* Clean up. *) Sys.remove path ; if Test.string_list_compare lines actual <> 0 then Test.fail (Printf.sprintf "Expected %s, got %s" (pp_string_list lines) (pp_string_list actual)) ) tests ); "Filesystem.new_temp_dir creates directories", (fun () -> let path = Filesystem.new_temp_dir () in if not (Sys.is_directory path) then Test.fail (Printf.sprintf "path %s is not a directory" path) else (* Cleanup. *) Unix.rmdir path ); "Filesystem.new_temp_dir creates unique paths", (fun () -> let path1 = Filesystem.new_temp_dir () in let path2 = Filesystem.new_temp_dir () in if String.compare path1 path2 = 0 then Test.fail (Printf.sprintf "paths are the same (%s)" path1) else begin (* Cleanup. *) Unix.rmdir path1 ; Unix.rmdir path2 end ); "Filesystem.remove_recursive does not raise when removing nothing", (fun () -> (* Generate a random temporary name that does not exist. *) let tmp_file = Filename.temp_file "" "" in Sys.remove tmp_file ; Filesystem.remove_recursive tmp_file ); "Filesystem.remove_recursive removes a single file", (fun () -> let tmp_file = Filename.temp_file "" "" in Filesystem.remove_recursive tmp_file ; if Sys.file_exists tmp_file then Test.fail "File not removed" ); "Filesystem.remove_recursive removes an empty directory", (fun () -> let tmp_dir = Filesystem.new_temp_dir () in Filesystem.remove_recursive tmp_dir ; if Sys.file_exists tmp_dir then Test.fail "Directory not removed" ); "Filesystem.remove_recursive removes a directory of files", (fun () -> let tmp_dir = Filesystem.new_temp_dir () in let touch name = Filesystem.write_file (Filename.concat tmp_dir name) (fun _ -> ()) in touch "mew" ; touch "purr" ; Filesystem.remove_recursive tmp_dir ; if Sys.file_exists tmp_dir then Test.fail "Directory not removed" ); "Filesystem.remove_recursive removes nested a directory of files", (fun () -> let tmp_dir = Filesystem.new_temp_dir () in let mkdir name = Unix.mkdir (Filename.concat tmp_dir name) 0o700 in let touch name = Filesystem.write_file (Filename.concat tmp_dir name) (fun _ -> ()) in touch "mew" ; mkdir "purr" ; touch "purr/meow" ; Filesystem.remove_recursive tmp_dir ; if Sys.file_exists tmp_dir then Test.fail "Directory not removed" ); ] let () = Test.run tests herd-herdtools7-1ca343e/internal/lib/tests/log_test.ml000066400000000000000000000057361475314470400230530ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Tests for the Log module. *) module Fun = Base.Fun module LogList = struct let compare = Base.List.compare Log.compare let to_ocaml_string = Base.List.to_ocaml_string Log.to_ocaml_string end let tests = [ "Log.of_string_list", (fun () -> let tests = [ [ "Test A4 Allowed" ; "States 1" ; "0:X0=0;" ; "Ok" ; "Witnesses" ; "Positive: 1 Negative: 0" ; "Condition exists (0:X0=0)" ; "Observation A4 Always 1 0" ; "Time A4 0.00" ; "Hash=b0a348f458429140b16552cc100cdc7c" ; ], [ { Log.name = "A4" ; Log.kind = Some ConstrGen.Allow ; } ; ] ; [ "Test A4 Allowed" ; "States 1" ; "0:X0=0;" ; "Ok" ; "Witnesses" ; "Positive: 1 Negative: 0" ; "Condition exists (0:X0=0)" ; "Observation A4 Always 1 0" ; "Time A4 0.00" ; "Hash=b0a348f458429140b16552cc100cdc7c" ; "" ; "Test A8 Forbid" ; "States 1" ; "0:X0=0; 0:X1=x+44;" ; "Ok" ; "Witnesses" ; "Positive: 1 Negative: 0" ; "Condition exists (0:X0=0 /\ not (0:X1=x))" ; "Observation A8 Always 1 0" ; "Time A8 0.00" ; "Hash=d1591baf0ba882a97685e1fa37c64e74" ; ], [ { Log.name = "A4" ; Log.kind = Some ConstrGen.Allow ; } ; { Log.name = "A8" ; Log.kind = Some ConstrGen.Allow ; } ; ] ; ] in List.iteri (fun i (log, expected) -> let actual = Log.of_string_list log in if LogList.compare actual expected <> 0 then Test.fail (Printf.sprintf "[%i] expected %s, got %s" i (LogList.to_ocaml_string expected) (LogList.to_ocaml_string actual)) ) tests ); ] let () = Test.run tests herd-herdtools7-1ca343e/internal/lib/tests/ocamlString_test.ml000066400000000000000000000034131475314470400245420ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Tests for the OcamlString module. *) let tests = [ "OcamlString.record", (fun () -> let tests = [ [], "{}" ; ["a", Base.String.to_ocaml_string "b"], "{ a = \"b\" }" ; [ "a", Base.String.to_ocaml_string "b" ; "c", Base.String.to_ocaml_string "d" ; ], "{ a = \"b\" ; c = \"d\" }" ; ] in List.iter (fun (fields, expected) -> let actual = OcamlString.record fields in if String.compare actual expected <> 0 then Test.fail (Printf.sprintf "expected %s, got %s" expected actual) ) tests ); ] let () = Test.run tests herd-herdtools7-1ca343e/internal/lib/tests/sexp_test.ml000066400000000000000000000053311475314470400232400ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) let tests = [ "Sexp.of_dune_file", (fun () -> let dune o = Printf.fprintf o "; comment\n" ; Printf.fprintf o "(tests;comment\n" ; Printf.fprintf o " (names a_test b_test)\n" ; Printf.fprintf o " (libraries lib))\n" ; Printf.fprintf o "; trailing comment" ; close_out o in let expected = let open Sexp in List [ List [Atom "tests" ; List [Atom "names"; Atom "a_test"; Atom "b_test"] ; List [Atom "libraries"; Atom "lib"] ; ] ] in let tmp_file = Filename.temp_file "" "" in Filesystem.write_file tmp_file dune ; let actual = Sexp.of_dune_file tmp_file in Sys.remove tmp_file ; if Sexp.compare expected actual <> 0 then Test.fail (Printf.sprintf "expected %s, got %s" (Sexp.to_string expected) (Sexp.to_string actual) ) ); "Sexp_of_dune_file raises on bad input", (fun () -> let bad_dunes = [ (fun o -> Printf.fprintf o "(tests" ; close_out o ); (fun o -> Printf.fprintf o "tests)" ; close_out o ); ] in List.iteri (fun i bad_dune -> let tmp_file = Filename.temp_file "" "" in Filesystem.write_file tmp_file bad_dune ; let raised_exception = try ignore (Sexp.of_dune_file tmp_file); false with Sexp.ParseError _ -> true in Sys.remove tmp_file ; if not raised_exception then Test.fail (Printf.sprintf "[%i] expected exception, did not raise" i) ) bad_dunes ); ] let () = Test.run tests herd-herdtools7-1ca343e/internal/lib/tests/shelf_test.ml000066400000000000000000000136471475314470400233730ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Tests for the Shelf module. *) let tests = [ "Shelf.of_file reads simple valid files", (fun () -> let tmp_dir = Filesystem.new_temp_dir () in let shelf_path = Filename.concat tmp_dir "shelf.py" in let shelf_py o = Printf.fprintf o "record = 'AArch64'\n" ; Printf.fprintf o "cats = [ 'cats/sc.cat' ]\n" ; Printf.fprintf o "cfgs = [ 'cfgs/web.cfg' ]\n" ; Printf.fprintf o "bells = [ 'bells/tabby.bell' ]\n" ; Printf.fprintf o "illustrative_tests = [ \n" ; Printf.fprintf o " 'tests/meow.litmus',\n" ; Printf.fprintf o " 'tests/mew.litmus',\n" ; Printf.fprintf o "]\n" ; Printf.fprintf o "references = [ { 'title': 'Garfield' } ]\n" ; () in Filesystem.write_file shelf_path shelf_py ; let expected = let open Shelf in { record = "AArch64" ; cats = [ "cats/sc.cat" ] ; configs = [ "cfgs/web.cfg" ] ; tests = [ "tests/meow.litmus"; "tests/mew.litmus" ] ; bells = Some [ "bells/tabby.bell" ] ; compatibilities = None ; } in let actual = Shelf.of_file shelf_path in Filesystem.remove_recursive tmp_dir ; if Shelf.compare expected actual <> 0 then Test.fail (Printf.sprintf "expected %s, got %s" (Shelf.to_ocaml_string expected) (Shelf.to_ocaml_string actual) ) ); "Shelf.of_file reads valid files with non-standard names", (fun () -> let tmp_dir = Filesystem.new_temp_dir () in let shelf_path = Filename.concat tmp_dir "shlaf shelf.py" in let shelf_py o = Printf.fprintf o "record = 'AArch64'\n" ; Printf.fprintf o "cats = [ 'cats/sc.cat' ]\n" ; Printf.fprintf o "cfgs = [ 'cfgs/web.cfg' ]\n" ; Printf.fprintf o "illustrative_tests = [ \n" ; Printf.fprintf o " 'tests/meow.litmus',\n" ; Printf.fprintf o " 'tests/mew.litmus',\n" ; Printf.fprintf o "]\n" ; () in Filesystem.write_file shelf_path shelf_py ; let expected = let open Shelf in { record = "AArch64" ; cats = [ "cats/sc.cat" ] ; configs = [ "cfgs/web.cfg" ] ; tests = [ "tests/meow.litmus"; "tests/mew.litmus" ] ; bells = None ; compatibilities = None ; } in let actual = Shelf.of_file shelf_path in Filesystem.remove_recursive tmp_dir ; if Shelf.compare expected actual <> 0 then Test.fail (Printf.sprintf "expected %s, got %s" (Shelf.to_ocaml_string expected) (Shelf.to_ocaml_string actual) ) ); "Shelf.of_file sorts lists for stability", (fun () -> let tmp_dir = Filesystem.new_temp_dir () in let shelf_path = Filename.concat tmp_dir "shlaf shelf.py" in let shelf_py o = Printf.fprintf o "record = 'AArch64'\n" ; Printf.fprintf o "cats = [ 'cats/sc.cat' ]\n" ; Printf.fprintf o "cfgs = [ 'cfgs/web.cfg' ]\n" ; Printf.fprintf o "illustrative_tests = [ \n" ; Printf.fprintf o " 'tests/b.litmus',\n" ; Printf.fprintf o " 'tests/a.litmus',\n" ; Printf.fprintf o "]\n" ; () in Filesystem.write_file shelf_path shelf_py ; let expected = let open Shelf in { record = "AArch64" ; cats = [ "cats/sc.cat" ] ; configs = [ "cfgs/web.cfg" ] ; tests = [ "tests/a.litmus"; "tests/b.litmus" ] ; bells = None ; compatibilities = None ; } in let actual = Shelf.of_file shelf_path in Filesystem.remove_recursive tmp_dir ; if Shelf.compare expected actual <> 0 then Test.fail (Printf.sprintf "expected %s, got %s" (Shelf.to_ocaml_string expected) (Shelf.to_ocaml_string actual) ) ); "Shelf.of_file reads valid files with globs", (fun () -> let tmp_dir = Filesystem.new_temp_dir () in let shelf_path = Filename.concat tmp_dir "shelf.py" in let shelf_py o = Printf.fprintf o "import glob\n" ; Printf.fprintf o "record = 'AArch64'\n" ; Printf.fprintf o "cats = [ 'cats/sc.cat' ]\n" ; Printf.fprintf o "cfgs = [ 'cfgs/web.cfg' ]\n" ; Printf.fprintf o "illustrative_tests = glob.glob( '*.litmus' ) \n" ; () in Filesystem.write_file (Filename.concat tmp_dir "mew.litmus") (fun _ -> ()) ; Filesystem.write_file (Filename.concat tmp_dir "purr.litmus") (fun _ -> ()) ; Filesystem.write_file shelf_path shelf_py ; let expected = let open Shelf in { record = "AArch64" ; cats = [ "cats/sc.cat" ] ; configs = [ "cfgs/web.cfg" ] ; tests = [ "mew.litmus"; "purr.litmus" ] ; bells = None ; compatibilities = None ; } in let actual = Shelf.of_file shelf_path in Filesystem.remove_recursive tmp_dir ; if Shelf.compare expected actual <> 0 then Test.fail (Printf.sprintf "expected %s, got %s" (Shelf.to_ocaml_string expected) (Shelf.to_ocaml_string actual) ) ); ] let () = Test.run tests herd-herdtools7-1ca343e/internal/lib/tests/test_test.ml000066400000000000000000000056341475314470400232460ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Tests for the Test module. *) let pp_int_list = Test.pp_int_list let pp_string_list = Test.pp_string_list let tests = [ "Test.pp_int_list", (fun () -> let tests = [ [], "[]" ; [1], "[1]" ; [1; 2; 3], "[1; 2; 3]" ; ] in List.iter (fun (xs, expected) -> let actual = Test.pp_int_list xs in if String.compare actual expected <> 0 then Test.fail (Printf.sprintf "Expected %s, got %s" expected actual) ) tests ); "Test.pp_string_list", (fun () -> let tests = [ [], "[]" ; ["a"], "[\"a\"]" ; ["a"; "b"], "[\"a\"; \"b\"]" ; ] in List.iter (fun (xs, expected) -> let actual = Test.pp_string_list xs in if String.compare actual expected <> 0 then Test.fail (Printf.sprintf "Expected %s, got %s" expected actual) ) tests ); "Test.int_list_compare", (fun () -> let tests = [ [], [], 0 ; [1], [], 1 ; [], [1], -1 ; [1], [1], 0 ; [1], [2], -1 ; [1; 2], [12; 2], -1 ; ] in List.iter (fun (xs, ys, expected) -> let actual = Test.int_list_compare xs ys in if actual <> expected then Test.fail (Printf.sprintf "Expected %i, got %i" expected actual) ) tests ); "Test.string_list_compare", (fun () -> let tests = [ [], [], 0 ; ["a"], [], 1 ; [], ["a"], -1 ; ["a"], ["a"], 0 ; ["a"], ["b"], -1 ; ["a"; "b"], ["ab"; "b"], -1 ; ] in List.iter (fun (xs, ys, expected) -> let actual = Test.string_list_compare xs ys in if actual <> expected then Test.fail (Printf.sprintf "Expected %i, got %i" expected actual) ) tests ); ] let () = Test.run tests herd-herdtools7-1ca343e/internal/lint_shelves.ml000066400000000000000000000054411475314470400220130ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2010-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** A tool to lint the contents of one or more Catalogue Shelf files. *) module Option = Base.Option let flatten_fields fields = let flatten_field (name, values) = List.map (fun v -> name, v) values in List.map flatten_field fields |> List.concat let lint_shelf shelf_path = let shelf = Shelf.of_file shelf_path in let shelf_dir = Filename.dirname shelf_path in let file_fields = let open Shelf in [ "cat", shelf.cats ; "config", shelf.configs ; "illustrative test", shelf.tests ; "bell", Option.value shelf.bells ~default:[] ; ] in let file_missing p = not (Sys.file_exists (Filename.concat shelf_dir p)) in let missing_files = flatten_fields file_fields |> List.filter (fun (_name, path) -> file_missing path) in match missing_files with | [] -> Ok () | missing -> Error missing let usage = String.concat "\n" [ Printf.sprintf "Usage: %s [more paths ...]" Sys.argv.(0) ; "" ; "Synopsis: Lint the contents of one or more Catalogue Shelf files." ] let () = let shelves = ref [] in Arg.parse [] (fun s -> shelves := s :: !shelves) usage ; let shelves = List.rev !shelves in if List.length shelves = 0 then begin Printf.printf "%s\n" usage ; exit 1 end ; let ok = ref true in List.iter (fun shelf -> match lint_shelf shelf with | Ok () -> () | Error errors -> ok := false ; List.iter (fun (name, path) -> Printf.printf "Shelf %s: Missing %s: %s\n" shelf name path) errors ; ) shelves ; if !ok then begin if Unix.isatty Unix.stdout then Printf.printf "Shelves OK\n" end else exit 1 herd-herdtools7-1ca343e/internal/run_built_binary000077500000000000000000000040711475314470400222550ustar00rootroot00000000000000#!/usr/bin/env python """Run the most recently built .exe or .native under _build, with args.""" from __future__ import print_function from os import path import os import sys class NotFound(Exception): """Could not find a binary under the build directory.""" def __init__(self, binary, build_dir): msg = 'Could not find binary "{binary}" under {build_dir}'.format( binary=binary, build_dir=build_dir) Exception.__init__(self, msg) def get_build_dir(): """DUNE_BUILD_DIR if set, otherwise /_build.""" if os.getenv('DUNE_BUILD_DIR'): return os.getenv('DUNE_BUILD_DIR') internal = path.dirname(path.realpath(__file__)) project_root = path.dirname(internal) return path.join(project_root, '_build') def find_candidates(build_dir, binary): """Lists paths under build_dir called either .exe or .native.""" results = [] for root, _, files in os.walk(build_dir): for name in files: basename, ext = path.splitext(name) if basename == binary and ext in ['.exe', '.native']: results.append(path.join(root, name)) return results def find_and_run_most_recent_binary(build_dir, binary, args): """Find & run the most recently built binary under build_dir with args.""" candidates = find_candidates(build_dir, binary) if not candidates: raise NotFound(binary, build_dir) most_recent = max(candidates, key=path.getmtime) os.execv(most_recent, [most_recent] + args) def main(argv): this = path.basename(argv[0]) if len(argv) < 2: print('Usage: {this} [args]'.format(this=this)) print('') print('Summary: {doc}'.format(doc=__doc__)) sys.exit(1) binary = argv[1] args = argv[2:] build_dir = get_build_dir() try: find_and_run_most_recent_binary(build_dir, binary, args) except NotFound as error: print('{this}: {error}'.format(this=this, error=error)) sys.exit(1) if __name__ == '__main__': main(sys.argv) herd-herdtools7-1ca343e/jingle/000077500000000000000000000000001475314470400164125ustar00rootroot00000000000000herd-herdtools7-1ca343e/jingle/AArch64Arch_jingle.ml000066400000000000000000000515211475314470400222260ustar00rootroot00000000000000(****************************************************************************) (* The Diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) include Arch.MakeArch(struct open AArch64Base module A = struct include AArch64Base include MakePP(struct let is_morello = false end) end include Arch.MakeCommon(A) let match_k k k' subs = let open MetaConst in match k,k' with | Meta k,k' -> add_subs [Cst (k,k');] subs | Int k, k' when k=k' -> Some subs | _,_ -> None module Ext = struct open AArch64Base.Ext let match_sext e e' subs = match e,e' with | UXTB,UXTB | UXTH,UXTH | UXTW,UXTW | UXTX,UXTX | SXTB,SXTB | SXTH,SXTH | SXTW,SXTW | SXTX,SXTX -> Some subs | _,_ -> None let match_ext e e' subs = match e,e' with | (se,None),(se',None) -> match_sext se se' subs | (se,Some k),(se',Some k') -> match_sext se se' subs >>> match_k k k' | _ -> None end let match_mode m m' subs = let open AArch64Base in match m,m' with | (Idx,Idx) | (PreIdx,PreIdx) | (PostIdx,PostIdx) -> Some subs | _,_ -> None let match_idx (k,m) (k',m') subs = match_mode m m' subs >>> match_k k k' module MemExt = struct module E = AArch64Base.MemExt let match_rext e e' subs = let open E in match e,e' with | (UXTW,UXTW) | (LSL,LSL) | (SXTW,SXTW) | (SXTX,SXTX) -> Some subs | _,_ -> None let match_ext e e' subs = match e,e' with | E.Imm idx,E.Imm idx' -> match_idx idx idx' subs | E.Reg (_,r,e,k),E.Reg (_,r',e',k') -> match_rext e e' subs >>> match_k k k' >>> add_subs [Reg(sr_name r,r');] | _,_ -> None end module OpExt = struct let match_shift s s' subs = let open OpExt in match s,s' with | (LSL k,LSL k') | (LSR k,LSR k') | (ASR k,ASR k') | (ROR k,ROR k') -> match_k k k' subs | _ -> None let match_ext e e' subs = match e,e' with | OpExt.Imm (k1,k2),OpExt.Imm (k1',k2') -> match_k k1 k1' subs >>> match_k k2 k2' | OpExt.Reg (r,s),OpExt.Reg (r',s') -> match_shift s s' subs >>> add_subs [Reg(sr_name r,r')] | _,_ -> None end let match_kr subs kr kr' = match kr,kr' with | K k,K k' -> match_k k k' subs | RV(_,r),RV(_,r') -> add_subs [Reg(sr_name r,r')] subs | _ -> None let match_lbl lp li subs = let open BranchTarget in match lp,li with | Lbl lp,Lbl li -> add_subs [Lab(lp,li)] subs | Offset ip,Offset ii when Misc.int_eq ip ii -> Some subs | _,_ -> None let match_instr subs pattern instr = match pattern,instr with | I_NOP,I_NOP -> Some subs | I_FENCE fp,I_FENCE fi when fp = fi -> Some subs | I_B lp, I_B li -> match_lbl lp li subs | I_BC(cp,lp), I_BC(ci,li) when cp = ci -> match_lbl lp li subs | I_CBZ(_,r,lp),I_CBZ(_,r',li) | I_CBNZ(_,r,lp),I_CBNZ(_,r',li) -> match_lbl lp li subs >>> add_subs [Reg(sr_name r,r')] | I_MOV(_,r,kr),I_MOV(_,r',kr') -> match_kr subs kr kr' >>> add_subs [Reg(sr_name r,r');] | I_LDAR(_,tp,r1,r2),I_LDAR(_,ti,r1',r2') when tp = ti -> add_subs [Reg(sr_name r1,r1');Reg(sr_name r2,r2')] subs | I_STLR(_,r1,r2),I_STLR(_,r1',r2') | I_SXTW(r1,r2),I_SXTW(r1',r2') -> add_subs [Reg(sr_name r1,r1');Reg(sr_name r2,r2')] subs | I_STXR(_,tp,r1,r2,r3),I_STXR(_,ti,r1',r2',r3') when tp = ti -> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2'); Reg(sr_name r3,r3')] subs | I_UBFM(_,r1,r2,k1,k2),I_UBFM(_,r1',r2',k1',k2') | I_SBFM(_,r1,r2,k1,k2),I_SBFM(_,r1',r2',k1',k2') -> begin match (match_kr subs (K k1) (K k1'), match_kr subs (K k2) (K k2')) with | Some(x),Some(_) -> Some(x) | _ -> None end >>> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2')] | I_LDUR(_,r1,r2,k),I_LDUR(_,r1',r2',k') -> match_kr subs (K k) (K k') >>> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2')] | I_LDRSW (r1,r2,e),I_LDRSW (r1',r2',e') | I_LDRS((_,B),r1,r2,e),I_LDRS((_,B),r1',r2',e') | I_LDRS((_,H),r1,r2,e),I_LDRS((_,H),r1',r2',e') | I_LDR(_,r1,r2,e),I_LDR(_,r1',r2',e') | I_STR(_,r1,r2,e),I_STR(_,r1',r2',e') -> MemExt.match_ext e e' subs >>> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2')] | I_STRBH(_,r1,r2,e),I_STRBH(_,r1',r2',e') | I_LDRBH(_,r1,r2,e),I_LDRBH(_,r1',r2',e') -> MemExt.match_ext e e' subs >>> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2')] | I_LDP (t,a,r1,r2,r3,idx),I_LDP (t',a',r1',r2',r3',idx') | I_STP (t,a,r1,r2,r3,idx),I_STP (t',a',r1',r2',r3',idx') when t=t' && a=a' -> match_idx idx idx' subs >>> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2'); Reg (sr_name r3,r3')] | I_LDPSW (r1,r2,r3,idx),I_LDPSW (r1',r2',r3',idx') -> match_idx idx idx' subs >>> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2'); Reg (sr_name r3,r3')] | I_STG (r1,r2,idx),I_STG (r1',r2',idx') | I_STZG (r1,r2,idx),I_STZG (r1',r2',idx') -> match_idx idx idx' subs >>> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2')] | I_ADDSUBEXT(_,op,r1,r2,(_,r3),ext), I_ADDSUBEXT(_,op',r1',r2',(_,r3'),ext') when op = op' -> Ext.match_ext ext ext' subs >>> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2'); Reg (sr_name r3,r3');] | I_OP3(_,opp,r1,r2,ext),I_OP3(_,opi,r1',r2',ext') when opp=opi -> OpExt.match_ext ext ext' subs >>> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2')] | I_EXTR (_,r1,r2,r3,k),I_EXTR (_,r1',r2',r3',k') -> match_k k k' subs >>> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2'); Reg(sr_name r3,r3');] | _,_ -> None let expl_instr subs = let return x n = x,n in let conv_reg = conv_reg subs in let find_lab lbl = let open BranchTarget in match lbl with | Lbl lbl -> find_lab subs lbl >! fun lbl -> Lbl lbl | Offset _ as tgt -> unitT tgt in let find_cst = find_cst subs in let find_shift = function | S_LSL(n) -> find_cst n >! fun n -> S_LSL(n) | S_LSR(n) -> find_cst n >! fun n -> S_LSR(n) | S_MSL(n) -> find_cst n >! fun n -> S_MSL(n) | S_ASR(n) -> find_cst n >! fun n -> S_ASR(n) | S_NOEXT -> return S_NOEXT in let expl_kr = function | RV(a,r) -> conv_reg r >! fun r -> RV(a,r) | K k -> find_cst k >! fun k -> K k in let module Ext = struct let expl = function | (e,None) -> fun st -> (e,None),st | (e,Some k) -> find_cst k >! fun k -> (e,Some k) end in let conv_idx (k,m) = find_cst k >! fun k -> k,m in let module MemExt = struct module E = AArch64Base.MemExt let expl = function | E.Imm idx -> conv_idx idx >! fun idx -> E.Imm idx | E.Reg (v,r,e,k) -> find_cst k >> fun k -> conv_reg r >! fun r -> E.Reg (v,r,e,k) | _ -> assert false end in let module OpExt = struct module E = AArch64Base.OpExt let expl = function | E.Imm (k1,k2) -> find_cst k1 >> fun k1 -> find_cst k2 >! fun k2 -> E.Imm (k1,k2) | E.Reg (r,s) -> conv_reg r >> fun r -> (match s with | E.LSL k -> find_cst k >> fun k -> unitT (E.LSL k) | E.LSR k -> find_cst k >> fun k -> unitT (E.LSR k) | E.ASR k -> find_cst k >> fun k -> unitT (E.ASR k) | E.ROR k -> find_cst k >> fun k -> unitT (E.ROR k)) >! fun s -> E.Reg (r,s) end in function | (I_FENCE _|I_NOP|I_RET None|I_ERET|I_SVC _|I_UDF _) as i -> unitT i | I_B l -> find_lab l >! fun l -> I_B l | I_BR r -> conv_reg r >! fun r -> I_BR r | I_RET (Some r) -> conv_reg r >! fun r -> I_RET (Some r) | I_BL l -> find_lab l >! fun l -> I_BL l | I_BLR r -> conv_reg r >! fun r -> I_BLR r | I_BC(a,l) -> find_lab l >! fun l -> I_BC (a,l) | I_CBZ(a,r,l) -> conv_reg r >> fun r -> find_lab l >! fun l -> I_CBZ (a,r,l) | I_CBNZ(a,r,l) -> conv_reg r >> fun r -> find_lab l >! fun l -> I_CBNZ (a,r,l) | I_TBNZ(a,r,k,l) -> conv_reg r >> fun r -> find_cst k >> fun k -> find_lab l >! fun l -> I_TBNZ (a,r,k,l) | I_TBZ(a,r,k,l) -> conv_reg r >> fun r -> find_cst k >> fun k -> find_lab l >! fun l -> I_TBZ (a,r,k,l) | I_MOV(a,r,kr) -> conv_reg r >> fun r -> expl_kr kr >! fun kr -> I_MOV(a,r,kr) | I_MOVZ(a,r,k,s) -> conv_reg r >> fun r -> find_cst k >> fun k -> find_shift s >! fun s-> I_MOVZ(a,r,k,s) | I_MOVN(a,r,k,s) -> conv_reg r >> fun r -> find_cst k >> fun k -> find_shift s >! fun s-> I_MOVN(a,r,k,s) | I_MOVK(a,r,k,s) -> conv_reg r >> fun r -> find_cst k >> fun k -> find_shift s >! fun s-> I_MOVK(a,r,k,s) | I_ADR (r,lbl) -> conv_reg r >> fun r -> find_lab lbl >! fun lbl -> I_ADR (r,lbl) | I_RBIT (v,r1,r2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> I_RBIT (v,r1,r2) | I_ABS (v,r1,r2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> I_ABS (v,r1,r2) | I_REV (v,r1,r2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> I_REV (v,r1,r2) | I_EXTR (v,r1,r2,r3,k) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >> fun r3 -> find_cst k >! fun k -> I_EXTR (v,r1,r2,r3,k) | I_LDAR(a,b,r1,r2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> I_LDAR(a,b,r1,r2) | I_LDARBH(a,b,r1,r2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> I_LDARBH(a,b,r1,r2) | I_STLR(a,r1,r2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> I_STLR(a,r1,r2) | I_STLRBH(a,r1,r2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> I_STLRBH(a,r1,r2) | I_SXTW(r1,r2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> I_SXTW(r1,r2) | I_SBFM(a,r1,r2,k1,k2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> find_cst k1 >> fun k1 -> find_cst k2 >! fun k2 -> I_SBFM(a,r1,r2,k1,k2) | I_UBFM(a,r1,r2,k1,k2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> find_cst k1 >> fun k1 -> find_cst k2 >! fun k2 -> I_UBFM(a,r1,r2,k1,k2) | I_STXR(a,b,r1,r2,r3) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_STXR(a,b,r1,r2,r3) | I_STXRBH(a,b,r1,r2,r3) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_STXRBH(a,b,r1,r2,r3) | I_LDR(a,r1,r2,e) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> MemExt.expl e >! fun e -> I_LDR(a,r1,r2,e) | I_LDRSW(r1,r2,e) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> MemExt.expl e >! fun e -> I_LDRSW(r1,r2,e) | I_LDRS(v,r1,r2,e) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> MemExt.expl e >! fun e -> I_LDRS(v,r1,r2,e) | I_LDUR(a,r1,r2,k) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> find_cst k >! fun k -> I_LDUR(a,r1,r2,k) | I_LDP(t,a,r1,r2,r3,idx) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >> fun r3 -> conv_idx idx >! fun idx -> I_LDP (t,a,r1,r2,r3,idx) | I_LDPSW(r1,r2,r3,idx) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >> fun r3 -> conv_idx idx >! fun idx -> I_LDPSW(r1,r2,r3,idx) | I_LDXP(t,a,r1,r2,r3) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_LDXP(t,a,r1,r2,r3) | I_STP(t,a,r1,r2,r3,idx) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >> fun r3 -> conv_idx idx >! fun idx -> I_STP(t,a,r1,r2,r3,idx) | I_STXP (a,b,r1,r2,r3,r4) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >> fun r3 -> conv_reg r4 >! fun r4 -> I_STXP (a,b,r1,r2,r3,r4) | I_LDRBH(a,r1,r2,e) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> MemExt.expl e >! fun e -> I_LDRBH(a,r1,r2,e) | I_STR(a,r1,r2,e) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> MemExt.expl e >! fun e -> I_STR(a,r1,r2,e) | I_STRBH(a,r1,r2,e) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> MemExt.expl e >! fun e -> I_STRBH(a,r1,r2,e) | I_ADDSUBEXT (v1,op,r1,r2,(v3,r3),e) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >> fun r3 -> Ext.expl e >! fun e -> I_ADDSUBEXT (v1,op,r1,r2,(v3,r3),e) | I_MOPL (sop,r1,r2,r3,r4) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >> fun r3 -> conv_reg r4 >! fun r4 -> I_MOPL (sop,r1,r2,r3,r4) | I_MOP (op, v,r1,r2,r3,r4) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >> fun r3 -> conv_reg r4 >! fun r4 -> I_MOP (op,v,r1,r2,r3,r4) | I_OP3 (a,b,r1,r2,e) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> OpExt.expl e >! fun e -> I_OP3(a,b,r1,r2,e) | I_CSEL(v,r1,r2,r3,c,op) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_CSEL(v,r1,r2,r3,c,op) | I_CAS (v,a,r1,r2,r3) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_CAS(v,a,r1,r2,r3) | I_CASBH (v,a,r1,r2,r3) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_CASBH(v,a,r1,r2,r3) | I_CASP (v,a,r1,r2,r3,r4,r5) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >> fun r3 -> conv_reg r4 >> fun r4 -> conv_reg r5 >! fun r5 -> I_CASP(v,a,r1,r2,r3,r4,r5) | I_SWP (v,a,r1,r2,r3) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_SWP(v,a,r1,r2,r3) | I_SWPBH (v,a,r1,r2,r3) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_SWPBH(v,a,r1,r2,r3) | I_LDOP (op,v,rmw,r1,r2,r3) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_LDOP (op,v,rmw,r1,r2,r3) | I_LDOPBH (op,v,rmw,r1,r2,r3) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_LDOPBH (op,v,rmw,r1,r2,r3) | I_STOP (op,v,rmw,r1,r2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> I_STOP (op,v,rmw,r1,r2) | I_STOPBH (op,v,rmw,r1,r2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> I_STOPBH (op,v,rmw,r1,r2) | I_IC (op,r) -> conv_reg r >! fun r -> I_IC (op,r) | I_DC (op,r) -> conv_reg r >! fun r -> I_DC (op,r) | I_TLBI (op,r) -> conv_reg r >! fun r -> I_TLBI (op,r) | I_MRS (r,sr) -> conv_reg r >! fun r -> I_MRS (r,sr) | I_MSR (sr,r) -> conv_reg r >! fun r -> I_MSR (sr,r) | I_STG (r1,r2,idx) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_idx idx >! fun idx -> I_STG (r1,r2,idx) | I_STZG (r1,r2,idx) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_idx idx >! fun idx -> I_STZG (r1,r2,idx) | I_STZ2G (r1,r2,idx) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_idx idx >! fun idx -> I_STZ2G (r1,r2,idx) | I_LDG (r1,r2,k) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> find_cst k >! fun k -> I_LDG (r1,r2,k) | I_ALIGND(r1,r2,k) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> find_cst k >! fun k -> I_ALIGND(r1,r2,k) | I_ALIGNU(r1,r2,k) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> find_cst k >! fun k -> I_ALIGNU(r1,r2,k) | I_BUILD(r1,r2,r3) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_BUILD(r1,r2,r3) | I_CHKEQ(r1,r2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> I_CHKEQ(r1,r2) | I_CHKSLD(r1) -> conv_reg r1 >! fun r1 -> I_CHKSLD(r1) | I_CHKTGD(r1) -> conv_reg r1 >! fun r1 -> I_CHKTGD(r1) | I_CLRTAG(r1,r2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> I_CLRTAG(r1,r2) | I_CPYTYPE(r1,r2,r3) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_CPYTYPE(r1,r2,r3) | I_CPYVALUE(r1,r2,r3) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_CPYVALUE(r1,r2,r3) | I_CSEAL(r1,r2,r3) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_CSEAL(r1,r2,r3) | I_GC(op,r1,r2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> I_GC(op,r1,r2) | I_SC(op,r1,r2,r3) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_SC(op,r1,r2,r3) | I_SEAL(r1,r2,r3) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_SEAL(r1,r2,r3) | I_UNSEAL(r1,r2,r3) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_UNSEAL(r1,r2,r3) | I_LDCT(r1,r2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> I_LDCT(r1,r2) | I_STCT(r1,r2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> I_STCT(r1,r2) (* Neon Extension *) | I_LD1 _ | I_LD1M _ | I_LD1R _ | I_LDAP1 _ | I_LD2 _ | I_LD2M _ | I_LD2R _ | I_LD3 _ | I_LD3M _ | I_LD3R _ | I_LD4 _ | I_LD4M _ | I_LD4R _ | I_ST1 _ | I_ST1M _ | I_STL1 _ | I_ST2 _ | I_ST2M _ | I_ST3 _ | I_ST3M _ | I_ST4 _ | I_ST4M _ | I_LDP_SIMD _ | I_STP_SIMD _ | I_LDR_SIMD _ | I_STR_SIMD _ | I_LDUR_SIMD _ | I_LDAPUR_SIMD _ | I_STUR_SIMD _ | I_STLUR_SIMD _ | I_ADDV _ | I_DUP _ | I_FMOV_TG _ | I_MOV_V _ | I_MOV_VE _ | I_MOV_S _ | I_MOV_FG _ | I_MOV_TG _ | I_MOVI_V _ | I_MOVI_S _ | I_OP3_SIMD _ | I_ADD_SIMD _ | I_ADD_SIMD_S _ -> Warn.fatal "Neon instructions are not implemented yet" (* Scalable Vector Extension *) | I_WHILELT _ | I_WHILELE _ | I_WHILELO _ | I_WHILELS _ | I_UADDV _ | I_DUP_SV _ | I_ADD_SV _ | I_NEG_SV _ | I_MOVPRFX _ | I_OP3_SV _ | I_LD1SP _ | I_LD2SP _ | I_LD3SP _ | I_LD4SP _ | I_ST1SP _ | I_ST2SP _ | I_ST3SP _ | I_ST4SP _ | I_MOV_SV _ | I_PTRUE _ | I_INDEX_SI _ | I_INDEX_IS _ | I_INDEX_SS _ | I_INDEX_II _ | I_RDVL _ | I_ADDVL _ | I_CNT_INC_SVE _ -> Warn.fatal "SVE instructions are not implemented yet" | I_SMSTART _ | I_SMSTOP _ | I_LD1SPT _ | I_ST1SPT _ | I_MOVA_TV _ | I_MOVA_VT _ | I_ADDA _ -> Warn.fatal "SME instructions are not implemented yet" end) herd-herdtools7-1ca343e/jingle/ARMArch_jingle.ml000066400000000000000000000251761475314470400215240ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) include Arch.MakeArch(struct open ARMBase include Arch.MakeCommon(ARMBase) let match_instr subs pattern instr = match pattern,instr with | I_ADD(_,r1,r2,MetaConst.Meta m),I_ADD(_,r1',r2',i) | I_SUB(_,r1,r2,MetaConst.Meta m),I_SUB(_,r1',r2',i) | I_AND(_,r1,r2,MetaConst.Meta m),I_AND(_,r1',r2',i) -> add_subs [Cst(m,i); Reg(sr_name r1,r1'); Reg(sr_name r2,r2')] subs | I_ORR(_,r1,r2,MetaConst.Meta m),I_ORR(_,r1',r2',i) -> add_subs [Cst(m,i); Reg(sr_name r1,r1'); Reg(sr_name r2,r2')] subs | I_LDM2(r1,r2,r3,i),I_LDM2(r1',r2',r3',i') when i = i' -> add_subs [Reg(sr_name r1,r1');Reg(sr_name r2,r2');Reg(sr_name r3,r3')] subs | I_LDM3(r1,r2,r3,r4,i),I_LDM3(r1',r2',r3',r4',i') when i = i' -> add_subs [Reg(sr_name r1,r1');Reg(sr_name r2,r2'); Reg(sr_name r3,r3');Reg(sr_name r4,r4')] subs | I_ADD(_,r1,r2,MetaConst.Int i),I_ADD(_,r1',r2',i') | I_LDRO(r1,r2,MetaConst.Int i,_),I_LDRO(r1',r2',i',_) | I_SUB(_,r1,r2,MetaConst.Int i),I_SUB(_,r1',r2',i') | I_AND(_,r1,r2,MetaConst.Int i),I_AND(_,r1',r2',i') when i=i'-> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2')] subs | I_ORR(_,r1,r2,MetaConst.Int i),I_ORR(_,r1',r2',i') when i=i'-> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2')] subs | I_ANDC(_,r1,r2,r3), I_ANDC(_,r1',r2',r3') | I_ADD3(_,r1,r2,r3),I_ADD3(_,r1',r2',r3') | I_SUB3(_,r1,r2,r3),I_SUB3(_,r1',r2',r3') | I_XOR(_,r1,r2,r3),I_XOR(_,r1',r2',r3') -> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2'); Reg(sr_name r3,r3')] subs | I_LDRD(r1,r2,r3,Some (MetaConst.Int k)), I_LDRD(r1',r2',r3', Some k') when k = k' -> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2'); Reg(sr_name r3,r3')] subs | I_LDR3_S(r1,r2,r3,S_LSL (MetaConst.Int k),c), I_LDR3_S(r1',r2',r3',S_LSL k',c') | I_STR3_S(r1,r2,r3,S_LSL (MetaConst.Int k),c), I_STR3_S(r1',r2',r3',S_LSL k',c') when k = k' && c = c' -> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2'); Reg(sr_name r3,r3')] subs | I_B l,I_B l' | I_BEQ l,I_BEQ l' | I_BNE l,I_BNE l' -> add_subs [Lab(l,l')] subs | I_CB(b,r,l),I_CB(b',r',l') when b=b' -> add_subs [Lab(l,l');Reg(sr_name r,r')] subs | I_CMPI(r,MetaConst.Meta m),I_CMPI(r',i) -> add_subs [Reg(sr_name r,r');Cst(m,i)] subs | I_CMPI(r,MetaConst.Int i),I_CMPI(r',i') when i=i' -> add_subs [Reg(sr_name r,r')] subs | I_CMP(r1,r2),I_CMP(r1',r2') | I_LDA(r1,r2),I_LDA(r1',r2') | I_LDAEX(r1,r2),I_LDAEX(r1',r2') | I_LDREX(r1,r2),I_LDREX(r1',r2') -> add_subs [Reg(sr_name r1,r1');Reg(sr_name r2,r2')] subs | I_LDR(r1,r2,c),I_LDR(r1',r2',c') | I_STR(r1,r2,c),I_STR(r1',r2',c') | I_STL(r1,r2,c),I_STL(r1',r2',c') | I_MOV(r1,r2,c),I_MOV(r1',r2',c') when c=c' -> add_subs [Reg(sr_name r1,r1');Reg(sr_name r2,r2')] subs | I_LDR3(r1,r2,r3,c),I_LDR3(r1',r2',r3',c') | I_STR3(r1,r2,r3,c),I_STR3(r1',r2',r3',c') | I_STREX(r1,r2,r3,c),I_STREX(r1',r2',r3',c') when c=c' -> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2'); Reg(sr_name r3,r3')] subs | I_STLEX(r1,r2,r3),I_STLEX(r1',r2',r3') -> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2'); Reg(sr_name r3,r3')] subs | I_MOVI(r,MetaConst.Meta m,c),I_MOVI(r',i,c') when c=c' -> add_subs [Reg(sr_name r,r');Cst(m,i)] subs | I_MOVI(r,MetaConst.Int i,c),I_MOVI(r',i',c') when i=i' && c=c' -> add_subs [Reg(sr_name r,r')] subs | I_MOVW(r,MetaConst.Int i,c),I_MOVW(r',i',c') | I_MOVT(r,MetaConst.Int i,c),I_MOVT(r',i',c') when i=i' && c=c' -> add_subs [Reg(sr_name r,r')] subs | I_DMB b,I_DMB b' | I_DSB b,I_DSB b' when b = b' -> Some subs | I_ISB,I_ISB -> Some subs | I_SADD16(r1,r2,r3),I_SADD16(r1',r2',r3') | I_SEL(r1,r2,r3),I_SEL(r1',r2',r3') -> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2'); Reg(sr_name r3,r3')] subs | _,_ -> None let expl_instr subs = let conv_reg = conv_reg subs in let find_lab = find_lab subs in let find_cst = find_cst subs in function | I_ADD(f,r1,r2,v) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> find_cst v >! fun v -> I_ADD(f,r1,r2,v) | I_SUB(f,r1,r2,v) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> find_cst v >! fun v -> I_SUB(f,r1,r2,v) | I_AND(f,r1,r2,v) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> find_cst v >! fun v -> I_AND(f,r1,r2,v) | I_ANDC(c,r1,r2,r3) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_ANDC(c,r1,r2,r3) | I_ORR(f,r1,r2,v) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> find_cst v >! fun v -> I_ORR(f,r1,r2,v) | I_ADD3(f,r1,r2,r3) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_ADD3 (f,r1,r2,r3) | I_SUB3(f,r1,r2,r3) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_SUB3 (f,r1,r2,r3) | I_XOR(f,r1,r2,r3) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_SUB3 (f,r1,r2,r3) | I_B l -> find_lab l >! fun l -> I_B l | I_BEQ l -> find_lab l >! fun l ->I_BEQ l | I_BNE l -> find_lab l >! fun l -> I_BNE l | I_BX(r) -> conv_reg r >! fun r -> I_BX(r) | I_CB(b,r,l) -> conv_reg r >> fun r -> find_lab l >! fun l -> I_CB(b,r,l) | I_CMPI(r,v) -> conv_reg r >> fun r -> find_cst v >! fun v -> I_CMPI(r,v) | I_CMP(r1,r2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> I_CMP (r1,r2) | I_LDREX(r1,r2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> I_LDREX(r1,r2) | I_LDAEX(r1,r2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> I_LDAEX(r1,r2) | I_LDA(r1,r2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> I_LDA(r1,r2) | I_LDR(r1,r2,c) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> I_LDR(r1,r2,c) | I_LDM2(r1,r2,r3,i) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_LDM2(r1,r2,r3,i) | I_LDM3(r1,r2,r3,r4,i) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >> fun r3 -> conv_reg r4 >! fun r4 -> I_LDM3(r1,r2,r3,r4,i) | I_LDRO(r1,r2,v,c) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> find_cst v >! fun v -> I_LDRO(r1,r2,v,c) | I_LDRD(r1,r2,r3,Some v) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >> fun r3 -> find_cst v >! fun v -> I_LDRD(r1,r2,r3,Some v) | I_LDRD(r1,r2,r3,None) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_LDRD(r1,r2,r3,None) | I_STR(r1,r2,c) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> I_STR(r1,r2,c) | I_STL(r1,r2,c) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> I_STL(r1,r2,c) | I_MOV(r1,r2,c) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> I_MOV(r1,r2,c) | I_LDR3(r1,r2,r3,c) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_LDR3(r1,r2,r3,c) | I_STR3(r1,r2,r3,c) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_STR3(r1,r2,r3,c) | I_STR3_S(r1,r2,r3,S_LSL k,c) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >> fun r3 -> find_cst k >! fun k -> I_STR3_S(r1,r2,r3,S_LSL k,c) | I_LDR3_S(r1,r2,r3,S_LSL k,c) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >> fun r3 -> find_cst k >! fun k -> I_LDR3_S(r1,r2,r3,S_LSL k,c) | I_STREX(r1,r2,r3,c) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_STREX(r1,r2,r3,c) | I_STLEX(r1,r2,r3) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_STLEX(r1,r2,r3) | I_MOVI(r,v,c) -> conv_reg r >> fun r -> find_cst v >! fun v -> I_MOVI(r,v,c) | I_MOVW(r,v,c) -> conv_reg r >> fun r -> find_cst v >! fun v -> I_MOVW(r,v,c) | I_MOVT(r,v,c) -> conv_reg r >> fun r -> find_cst v >! fun v -> I_MOVT(r,v,c) | I_NOP | I_DMB _ | I_DSB _ | I_ISB as i -> unitT i | I_SADD16(r1,r2,r3) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_SADD16(r1,r2,r3) | I_SEL(r1,r2,r3) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> I_SEL(r1,r2,r3) end) herd-herdtools7-1ca343e/jingle/BellArch_jingle.ml000066400000000000000000000127411475314470400217550ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) include Arch.MakeArch(struct open BellBase include Arch.MakeCommon(BellBase) let rec annots_compare s s' = match s,s' with | [],[] -> true | x::s,y::s' when String.compare x y = 0 -> annots_compare s s' | _ -> false let match_reg_or_imm subs ri ri' = match ri,ri' with | Regi r,Regi r' -> add_subs [Reg(sr_name r,r')] subs | Imm (MetaConst.Meta m),Imm i -> add_subs [Cst(m,i)] subs | Imm (MetaConst.Int m),Imm i when m=i -> Some subs | _ -> None let match_reg_or_addr subs ra ra' = match ra,ra' with | Rega r,Rega r' -> add_subs [Reg(sr_name r,r')] subs | Abs x,Abs y -> add_subs [Addr(x,y)] subs | _,_ -> None let match_iar subs iar iar' = match iar,iar' with | IAR_roa ra,IAR_roa ra' -> match_reg_or_addr subs ra ra' | IAR_imm (MetaConst.Meta m), IAR_imm i -> add_subs [Cst(m,i)] subs | IAR_imm (MetaConst.Int v), IAR_imm i when v = i -> Some subs | _,_ -> None let match_op subs op op' = match op,op' with | OP (op,iar1,iar2),OP (op',iar1',iar2') when op=op' -> begin match (match_iar subs iar1 iar1') with | Some subs -> match_iar subs iar2 iar2' | None -> None end | RAI(iar),RAI(iar') -> match_iar subs iar iar' | _,_ -> None let match_addr_op subs ao ao' = match ao,ao' with | Addr_op_atom ra,Addr_op_atom ra' -> match_reg_or_addr subs ra ra' | Addr_op_add(ra,ri),Addr_op_add(ra',ri') -> match_reg_or_addr subs ra ra' >>> fun subs -> match_reg_or_imm subs ri ri' | _,_ -> None let match_instr subs pattern instr = match pattern,instr with | Pld(r,ao,s),Pld(r',ao',s') -> if annots_compare s s' then match_addr_op subs ao ao' >>> add_subs [Reg(sr_name r,r')] else None | Pst(ao,ri,s),Pst(ao',ri',s') -> if annots_compare s s' then match_addr_op subs ao ao' >>> fun subs -> match_reg_or_imm subs ri ri' else None | Prmw(r,op,ao,s),Prmw(r',op',ao',s') -> if annots_compare s s' then match_op subs op op' >>> fun subs -> match_addr_op subs ao ao' >>> add_subs [Reg(sr_name r,r')] else None | Pfence Fence(s,_), Pfence Fence(s',_) -> if annots_compare s s' then Some subs else None | Pbranch(None,lp,s), Pbranch(None,li,s') -> if annots_compare s s' then add_subs [Lab(lp,li)] subs else None | Pbranch(Some r,lp,s), Pbranch(Some r',li,s') -> if annots_compare s s' then add_subs [Reg(sr_name r,r');Lab(lp,li)] subs else None | Pmov(r,op),Pmov(r',op') -> match_op subs op op' >>> add_subs [Reg(sr_name r,r')] | _,_ -> None let expl_instr subs = let conv_reg = conv_reg subs and find_lab = find_lab subs and find_cst = find_cst subs in let rec expl i = match i with | Pld(r,ao,s) -> conv_reg r >> fun r -> expl_ao ao >! fun ao -> Pld (r,ao,s) | Pst(ao,ri,s) -> expl_ao ao >> fun ao -> expl_ri ri >! fun ri -> Pst (ao,ri,s) | Prmw(r,op,ao,s) -> conv_reg r >> fun r -> expl_op op >> fun op -> expl_ao ao >! fun ao -> Prmw(r,op,ao,s) | Pbranch(None,lab,b) -> find_lab lab >! fun lab -> Pbranch (None,lab,b) | Pbranch(Some r,lab,b) -> conv_reg r >> fun r -> find_lab lab >! fun lab -> Pbranch (Some r,lab,b) | Pmov(r,op) -> conv_reg r >> fun r -> expl_op op >! fun op -> Pmov (r,op) | i -> unitT i and expl_ao ao =match ao with | Addr_op_atom ra -> expl_ra ra >! fun ra -> Addr_op_atom ra | Addr_op_add(ra,ri) -> expl_ra ra >> fun ra -> expl_ri ri >! fun ri -> Addr_op_add (ra,ri) and expl_ri ri = match ri with | Regi r -> conv_reg r >! fun r -> Regi r | Imm k -> find_cst k >! fun k -> Imm k and expl_op = function | OP(op,iar1,iar2) -> expl_iar iar1 >> fun iar1 -> expl_iar iar2 >! fun iar2 -> OP (op,iar1,iar2) | RAI(iar) -> expl_iar iar >! fun iar -> RAI iar and expl_ra = function | Rega r -> conv_reg r >! fun r -> Rega r | abs -> unitT abs and expl_iar = function | IAR_roa ra -> expl_ra ra >! fun ra -> IAR_roa ra | IAR_imm k -> find_cst k >! fun k -> IAR_imm k in expl end) herd-herdtools7-1ca343e/jingle/CArch_jingle.ml000066400000000000000000000215731475314470400212640ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) include Arch.MakeArch(struct open Printf open CBase include Arch.MakeCommon(CBase) let debug = false let rec wrap_pseudo = function | [] -> [] | i::is -> (Instruction i)::(wrap_pseudo is) let rec unwrap_pseudo = function | [] -> [] | (Instruction i)::is -> i::(unwrap_pseudo is) | (Label(_,p))::is -> (unwrap_pseudo [p])@(unwrap_pseudo is) | Nop:: is -> unwrap_pseudo is | _ -> assert false let rec match_location subs pat instr = match_expr subs pat instr and match_expr subs pat instr = let open Constant in let r = match pat,instr with | Const(Symbolic (Virtual {name=s;_})),Const(Concrete c) -> let c = try int_of_string c with Failure _ -> Warn.user_error "Int expected" in add_subs [Cst(s, c)] subs | Const(Concrete s),Const(Concrete c) when c=s -> Some subs | LoadReg(l),LoadReg(l') -> (* Awful ack to encode address registers... *) let to_add = match symb_reg_name l with | None -> Reg (l,l') | Some s -> Reg (s,l') in add_subs [to_add] subs | LoadMem(l,mo),LoadMem(l',mo') when mo=mo' -> match_location subs l l' | Op(op,ex1,ex2),Op(op',ex1',ex2') when op=op' -> match_expr subs ex1 ex1' >>> fun subs -> match_expr subs ex2 ex2' | Exchange(l,ex,mo),Exchange(l',ex',mo') when mo=mo' -> match_location subs l l' >>> fun subs -> match_expr subs ex ex' | Fetch(l,op,ex,mo),Fetch(l',op',ex',mo') when mo=mo' && op=op' -> match_location subs l l' >>> fun subs -> match_expr subs ex ex' | ECall (f,es),ECall (g,fs) when f=g -> match_exprs subs es fs | _ -> None in if debug then eprintf "Match_expr pat=<%s> expr=<%s> -> %s\n" (CBase.dump_expr pat) (CBase.dump_expr instr) (match r with Some _ -> "ok" | None -> "no") ; r and match_exprs subs es fs = match es,fs with | [],[] -> Some subs | e::es,f::fs -> begin match match_expr subs e f with | None -> None | Some subs -> match_exprs subs es fs end | ([],_::_) | (_::_,[]) -> None let rec match_instr subs pattern instr = let r = match pattern,instr with | Fence b,Fence b' when b = b'-> Some subs | Seq (l,b), Seq (l',b') when b=b' -> let rec aux subs ips iis = match subs,ips,iis with | None,_,_ -> None | Some _ as subs,[],[] -> subs | Some subs,ip::ips,ii::iis -> aux (match_instr subs ip ii) ips iis | _ -> None in aux (Some subs) l l' | If(c,t,e),If(c',t',e') -> begin match match_expr subs c c' with | None -> None | Some subs -> match match_instr subs t t' with | None -> None | Some subs -> match e,e' with | None,None -> Some subs | Some e,Some e' -> match_instr subs e e' | _ -> None end | DeclReg (_t,r),DeclReg(_t',r') (* when t = t' *) -> add_subs [Reg (sr_name r,r')] subs | StoreReg (_ot,Some r,ex),StoreReg(_ot',Some r',ex') (* when ot = ot' *) -> add_subs [Reg (sr_name r,r')] subs >>> fun subs -> match_expr subs ex ex' | StoreReg (_ot,None,ex),StoreReg(_ot',None,ex') (* when ot = ot' *) -> match_expr subs ex ex' | StoreMem(l,ex,mo),StoreMem(l',ex',mo') when mo=mo' -> match_location subs l l' >>> fun subs -> match_expr subs ex ex' | Lock (l,MutexC11),Lock (l',MutexC11) -> match_location subs l l' | Lock (l,MutexLinux),Lock (l',MutexLinux) -> match_location subs l l' | Unlock (l,MutexC11),Unlock (l',MutexC11) -> match_location subs l l' | Unlock (l,MutexLinux),Unlock (l',MutexLinux) -> match_location subs l l' | PCall (f,es),PCall (g,fs) when f = g -> match_exprs subs es fs | Symb s,Seq (l,_) -> add_subs [Code(s,wrap_pseudo l)] subs | Symb s,ins -> add_subs [Code(s,wrap_pseudo [ins])] subs | _ -> None in if debug then eprintf "Match Instr <%s> <%s> -> %s\n" (dump_instruction pattern) (dump_instruction instr) (match r with Some _ -> "ok" | None -> "no") ; r let expl_instr subs = let conv_reg = conv_reg subs in let find_code s st = let rec aux = function | [] -> raise (Error("No conversion found for code "^s)) | Code(n,c)::_ when Misc.string_eq n s -> Seq (unwrap_pseudo c,true) | _::subs -> aux subs in aux subs,st in let find_cst s st = let rec aux = function | [] -> raise (Error("No conversion found for constant "^s)) | Cst(n,i)::_ when Misc.string_eq n s -> ParsedConstant.intToV i | _::subs -> aux subs in aux subs,st in let rec expl_expr = let open Constant in function | Const(Symbolic (Virtual {name=s;_})) -> find_cst s >! fun k -> Const k | Const (Concrete _|ConcreteVector _|Label _|ConcreteRecord _ |Tag _|Symbolic _|PteVal _ |Instruction _|Frozen _) as e -> unitT e | LoadReg r -> conv_reg r >! fun r -> LoadReg r | LoadMem (loc,mo) -> expl_expr loc >! fun loc -> LoadMem (loc,mo) | Op (op,e1,e2) -> expl_expr e1 >> fun e1 -> expl_expr e2 >! fun e2 -> Op (op,e1,e2) | Exchange(loc,e,mo) -> expl_expr loc >> fun loc -> expl_expr e >! fun e -> Exchange (loc,e,mo) | CmpExchange (loc,o,n,a) -> expl_expr loc >> fun loc -> expl_expr o >> fun o -> expl_expr n >! fun n -> CmpExchange(loc,o,n,a) | Fetch(loc,op,e,mo) -> expl_expr loc >> fun loc -> expl_expr e >! fun e -> Fetch(loc,op,e,mo) | ECall (f,es) -> mapT expl_expr es >! fun es -> ECall (f,es) | ECas (e1,e2,e3,mo1,mo2,st) -> expl_expr e1 >> fun e1 -> expl_expr e2 >> fun e2 -> expl_expr e3 >! fun e3 -> ECas (e1,e2,e3,mo1,mo2,st) | TryLock(e,m) -> expl_expr e >! fun e -> TryLock(e,m) | IsLocked(e,m) -> expl_expr e >! fun e -> IsLocked(e,m) | AtomicOpReturn (loc,op,e,ret,a) -> expl_expr loc >> fun loc -> expl_expr e >! fun e -> AtomicOpReturn (loc,op,e,ret,a) | AtomicAddUnless (loc,u,e,rb,a) -> expl_expr loc >> fun loc -> expl_expr u >> fun u -> expl_expr e >! fun e -> AtomicAddUnless (loc,u,e,rb,a) | ExpSRCU (e,a) -> expl_expr e >! fun e -> ExpSRCU (e,a) in let rec expl_instr = function | Fence _|DeclReg _ as i -> unitT i | Seq (is,b) -> mapT expl_instr is >! fun is -> Seq (is,b) | If(c,t,e) -> expl_expr c >> fun c -> expl_instr t >> fun t -> optT expl_instr e >! fun e -> If (c,t,e) | While (c,t,n) -> expl_expr c >> fun c -> expl_instr t >! fun t -> While (c,t,n) | CastExpr e -> expl_expr e >! fun e -> CastExpr e | StoreReg(ot,Some r,e) -> conv_reg r >> fun r -> expl_expr e >! fun e -> StoreReg (ot,Some r,e) | StoreReg(ot,None,e) -> expl_expr e >! fun e -> StoreReg (ot,None,e) | StoreMem(loc,e,mo) -> expl_expr loc >> fun loc -> expl_expr e >! fun e -> StoreMem(loc,e,mo) | Lock (l,k) -> expl_expr l >! fun l -> Lock(l,k) | Unlock (l,k) -> expl_expr l >! fun l -> Unlock(l,k) | Symb s -> find_code s | PCall (f,es) -> mapT expl_expr es >! fun es -> PCall (f,es) | AtomicOp(e1,op,e2,a) -> expl_expr e1 >> fun e1 -> expl_expr e2 >! fun e2 -> AtomicOp (e1,op,e2,a) | InstrSRCU (e,a,oe) -> expl_expr e >> fun e -> optT expl_expr oe >! fun oe -> InstrSRCU (e,a,oe) in expl_instr end) herd-herdtools7-1ca343e/jingle/PPCArch_jingle.ml000066400000000000000000000242061475314470400215200ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) include Arch.MakeArch(struct open PPCBase include Arch.MakeCommon(PPCBase) let match_const subs k k' = let open MetaConst in match k with | Int i -> if Misc.int_eq i k' then Some subs else None | Meta k -> add_subs [Cst(k,k');] subs let match_instr subs pattern instr = match pattern,instr with | Padd(s,r1,r2,r3),Padd(s',r1',r2',r3') | Psub(s,r1,r2,r3),Psub(s',r1',r2',r3') | Psubf(s,r1,r2,r3),Psubf(s',r1',r2',r3') | Por(s,r1,r2,r3),Por(s',r1',r2',r3') | Pand(s,r1,r2,r3),Pand(s',r1',r2',r3') | Pxor(s,r1,r2,r3),Pxor(s',r1',r2',r3') | Pmull(s,r1,r2,r3),Pmull(s',r1',r2',r3') | Pdiv(s,r1,r2,r3),Pdiv(s',r1',r2',r3') when s = s' -> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2'); Reg(sr_name r3,r3')] subs | Paddi(r1,r2,k),Paddi(r1',r2',k') | Pandi(r1,r2,k),Pandi(r1',r2',k') | Pori(r1,r2,k),Pori(r1',r2',k') | Pxori(r1,r2,k),Pxori(r1',r2',k') | Pmulli(r1,r2,k),Pmulli(r1',r2',k') | Plwzu(r1,k,r2),Plwzu(r1',k',r2') | Plwa(r1,k,r2),Plwa(r1',k',r2') | Pstwu(r1,k,r2),Pstwu(r1',k',r2') | Plmw(r1,k,r2),Plmw(r1',k',r2') | Pclrldi(r1,r2,k), Pclrldi (r1',r2',k') | Pstmw(r1,k,r2),Pstmw(r1',k',r2') -> match_const subs k k' >>> add_subs [Reg(sr_name r1,r1');Reg(sr_name r2,r2')] | Prlwimi(r1,r2,k1,k2,k3),Prlwimi(r1',r2',k1',k2',k3') | Prlwinm(r1,r2,k1,k2,k3),Prlwinm(r1',r2',k1',k2',k3') -> add_subs [Reg(sr_name r1,r1');Reg(sr_name r2,r2'); Cst(cv_name k1,k1'); Cst (cv_name k2,k2'); Cst(cv_name k3,k3')] subs | Pmr(r1,r2),Pmr(r1',r2') | Pextsw(r1,r2),Pextsw(r1',r2') | Pdcbf(r1,r2),Pdcbf(r1',r2') -> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2')] subs | Plwarx(r1,r2,r3),Plwarx(r1',r2',r3') | Pstwcx(r1,r2,r3),Pstwcx(r1',r2',r3') -> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2'); Reg(sr_name r3,r3')] subs | Pmtlr r,Pmtlr r' | Pmflr r,Pmflr r' -> add_subs [Reg(sr_name r,r')] subs | Pcmplwi(i,r,k),Pcmplwi(i',r',k') | Pcmpwi(i,r,k),Pcmpwi(i',r',k') when i = i' -> match_const subs k k' >>> add_subs [Reg(sr_name r,r')] | Pcmpw(i,r1,r2),Pcmpw(i',r1',r2') when i = i' -> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2');] subs | Pli(r,k),Pli(r',k') | Plis(r,k),Plis(r',k') -> match_const subs k k' >>> add_subs [Reg(sr_name r,r')] | Psync,Psync | Peieio,Peieio | Pisync,Pisync | Plwsync,Plwsync | Pblr,Pblr | Pcomment _,Pcomment _ -> Some subs | Pb l,Pb l' | Pbl l,Pbl l' -> add_subs [Lab(l,l')] subs | Pbcc(c,l),Pbcc(c',l') when c = c' -> add_subs [Lab(l,l')] subs | Pload(s,r1,k,r2),Pload(s',r1',k',r2') | Pstore(s,r1,k,r2),Pstore(s',r1',k',r2') when s = s' -> match_const subs k k' >>> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2')] | Ploadx(s,r1,r2,r3),Ploadx(s',r1',r2',r3') | Plwax(s,r1,r2,r3),Plwax(s',r1',r2',r3') | Pstorex(s,r1,r2,r3),Pstorex(s',r1',r2',r3') when s = s' -> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2'); Reg(sr_name r3,r3')] subs | Pneg(s,r1,r2),Pneg(s',r1',r2') when s = s' -> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2')] subs | Pnor(s,r1,r2,r3),Pnor(s',r1',r2',r3') | Pslw(s,r1,r2,r3),Pslw(s',r1',r2',r3') | Psraw(s,r1,r2,r3),Psraw(s',r1',r2',r3') when s = s' -> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2'); Reg(sr_name r3,r3')] subs | Psrawi(s,r1,r2,k),Psrawi(s',r1',r2',k') when s = s' -> match_const subs k k' >>> add_subs [Reg(sr_name r1,r1'); Reg(sr_name r2,r2')] | _,_ -> None let par2 f x y k = f x >> fun x -> f y >! k x let par3 f x y z k = f x >> fun x -> f y >> fun y -> f z >! k x y let par21 f x y g z k = f x >> fun x -> f y >> fun y -> g z >! k x y let expl_instr subs = let conv_reg = conv_reg subs and find_lab = find_lab subs and find_cst = find_cst subs in function | Padd(s,r1,r2,r3) -> par3 conv_reg r1 r2 r3 (fun r1 r2 r3 -> Padd (s,r1,r2,r3)) | Psub(s,r1,r2,r3) -> par3 conv_reg r1 r2 r3 (fun r1 r2 r3 -> Psub (s,r1,r2,r3)) | Psubf(s,r1,r2,r3) -> par3 conv_reg r1 r2 r3 (fun r1 r2 r3 -> Psubf (s,r1,r2,r3)) | Por(s,r1,r2,r3) -> par3 conv_reg r1 r2 r3 (fun r1 r2 r3 -> Por (s,r1,r2,r3)) | Pand(s,r1,r2,r3) -> par3 conv_reg r1 r2 r3 (fun r1 r2 r3 -> Pand (s,r1,r2,r3)) | Pxor(s,r1,r2,r3) -> par3 conv_reg r1 r2 r3 (fun r1 r2 r3 -> Pxor (s,r1,r2,r3)) | Pmull(s,r1,r2,r3) -> par3 conv_reg r1 r2 r3 (fun r1 r2 r3 -> Pmull (s,r1,r2,r3)) | Pdiv(s,r1,r2,r3) -> par3 conv_reg r1 r2 r3 (fun r1 r2 r3 -> Pdiv (s,r1,r2,r3)) | Paddi(r1,r2,k) -> par21 conv_reg r1 r2 find_cst k (fun r1 r2 k -> Paddi (r1,r2,k)) | Paddis(r1,r2,k) -> par21 conv_reg r1 r2 find_cst k (fun r1 r2 k -> Paddis (r1,r2,k)) | Prlwimi (r1,r2,k1,k2,k3) -> find_cst k1 >> fun k1 -> find_cst k2 >> fun k2 -> find_cst k3 >> fun k3 -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> Prlwimi (r1,r2,k1,k2,k3) | Prlwinm (r1,r2,k1,k2,k3) -> find_cst k1 >> fun k1 -> find_cst k2 >> fun k2 -> find_cst k3 >> fun k3 -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> Prlwinm (r1,r2,k1,k2,k3) | Pclrldi (r1,r2,k1) -> find_cst k1 >> fun k1 -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> Pclrldi (r1,r2,k1) | Pandi(r1,r2,k) -> par21 conv_reg r1 r2 find_cst k (fun r1 r2 k -> Pandi (r1,r2,k)) | Pori(r1,r2,k) -> par21 conv_reg r1 r2 find_cst k (fun r1 r2 k -> Pori (r1,r2,k)) | Pxori(r1,r2,k) -> par21 conv_reg r1 r2 find_cst k (fun r1 r2 k -> Pxori (r1,r2,k)) | Pmulli(r1,r2,k) -> par21 conv_reg r1 r2 find_cst k (fun r1 r2 k -> Pxori (r1,r2,k)) | Pli(r,k) -> conv_reg r >> fun r -> find_cst k >! fun k -> Pli (r,k) | Plis(r,k) -> conv_reg r >> fun r -> find_cst k >! fun k -> Plis (r,k) | Pb l -> find_lab l >! fun l -> Pb l | Pbcc(c,l) -> find_lab l >! fun l -> Pbcc (c, l) | Pcmpwi(i,r,k) -> conv_reg r >> fun r -> find_cst k >! fun k -> Pcmpwi (i,r,k) | Pcmplwi(i,r,k) -> conv_reg r >> fun r -> find_cst k >! fun k -> Pcmplwi (i,r,k) | Pcmpw(i,r1,r2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> Pcmpw (i,r1,r2) | Plwzu(r1,k,r2) -> par21 conv_reg r1 r2 find_cst k (fun r1 r2 k -> Plwzu(r1,k,r2)) | Plwa(r1,k,r2) -> par21 conv_reg r1 r2 find_cst k (fun r1 r2 k -> Plwa(r1,k,r2)) | Pmr(r1,r2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> Pmr(r1,r2) | Pextsw(r1,r2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> Pextsw(r1,r2) | Pstwu(r1,k,r2) -> par21 conv_reg r1 r2 find_cst k (fun r1 r2 k -> Pstwu (r1,k,r2)) | Plwarx(r1,r2,r3) -> par3 conv_reg r1 r2 r3 (fun r1 r2 r3 -> Plwarx(r1,r2,r3)) | Pstwcx(r1,r2,r3) -> par3 conv_reg r1 r2 r3 (fun r1 r2 r3 -> Pstwcx (r1,r2,r3)) | Pload(s,r1,k,r2) -> par21 conv_reg r1 r2 find_cst k (fun r1 r2 k -> Pload (s,r1,k,r2)) | Ploadx(s,r1,r2,r3) -> par3 conv_reg r1 r2 r3 (fun r1 r2 r3 -> Ploadx (s,r1,r2,r3)) | Plwax(s,r1,r2,r3) -> par3 conv_reg r1 r2 r3 (fun r1 r2 r3 -> Plwax (s,r1,r2,r3)) | Pstore(s,r1,k,r2) -> par21 conv_reg r1 r2 find_cst k (fun r1 r2 k -> Pstore (s,r1,k,r2)) | Pstorex(s,r1,r2,r3) -> par3 conv_reg r1 r2 r3 (fun r1 r2 r3 -> Pstorex (s,r1,r2,r3)) | Psync|Peieio|Pisync| Plwsync as i -> unitT i | Pdcbf(r1,r2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> Pdcbf(r1,r2) | Pnor(s,r1,r2,r3) -> par3 conv_reg r1 r2 r3 (fun r1 r2 r3 -> Pnor (s,r1,r2,r3)) | Pneg(s,r1,r2) -> par2 conv_reg r1 r2 (fun r1 r2 -> Pneg (s,r1,r2)) | Pslw(s,r1,r2,r3) -> par3 conv_reg r1 r2 r3 (fun r1 r2 r3 -> Pslw (s,r1,r2,r3)) | Psrawi(s,r1,r2,k) -> par21 conv_reg r1 r2 find_cst k (fun r1 r2 k -> Psrawi (s,r1,r2,k)) | Psraw(s,r1,r2,r3) -> par3 conv_reg r1 r2 r3 (fun r1 r2 r3 -> Psraw (s,r1,r2,r3)) | Pnop | Pbl _ | Pblr as i -> unitT i | Pmtlr r -> conv_reg r >! fun r -> Pmtlr r | Pmflr r -> conv_reg r >! fun r -> Pmflr r | Pmfcr r -> conv_reg r >! fun r -> Pmfcr r | Plmw(r1,k,r2) -> par21 conv_reg r1 r2 find_cst k (fun r1 r2 k -> Plmw (r1,k,r2)) | Pstmw(r1,k,r2) -> par21 conv_reg r1 r2 find_cst k (fun r1 r2 k -> Pstmw (r1,k,r2)) | Pcomment _ as i -> unitT i end) herd-herdtools7-1ca343e/jingle/RISCVArch_jingle.ml000066400000000000000000000132471475314470400217670ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2019-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) include Arch.MakeArch(struct open RISCVBase include Arch.MakeCommon(RISCVBase) let match_const k k' subs = match k with | MetaConst.Meta k -> add_subs [Cst (k,k')] subs | MetaConst.Int k -> if k=k' then Some subs else None let match_2r subs r1 r2 r1' r2' = match_reg r1 r1' subs >>> match_reg r2 r2' let match_const_2r subs k r1 r2 k' r1' r2' = match_const k k' subs >>> fun subs -> match_2r subs r1 r2 r1' r2' let match_3r subs r1 r2 r3 r1' r2' r3' = match_2r subs r1 r2 r1' r2' >>> match_reg r3 r3' let match_instr subs pattern instr = match pattern,instr with | OpI (op,r1,r2,k),OpI(op',r1',r2',k') when op=op' -> match_const_2r subs k r1 r2 k' r1' r2' | OpI2 (op,r1,k),OpI2(op',r1',k') when op=op' -> match_reg r1 r1' subs >>> match_const k k' | OpA (op,r1,lbl),OpA(op',r1',lbl') when op=op' -> add_subs [Lab (lbl,lbl'); Reg (sr_name r1, r1')] subs | OpIW (op,r1,r2,k),OpIW(op',r1',r2',k') when op=op' -> match_const_2r subs k r1 r2 k' r1' r2' | Op (op,r1,r2,r3),Op(op',r1',r2',r3') when op=op' -> match_3r subs r1 r2 r3 r1' r2' r3' | OpW (op,r1,r2,r3),OpW(op',r1',r2',r3') when op=op' -> match_3r subs r1 r2 r3 r1' r2' r3' | AUIPC (r1,k1), AUIPC (r1',k1') -> match_reg r1 r1' subs >>> match_const k1 k1' | J lbl,J lbl' -> add_subs [Lab (lbl,lbl')] subs | Bcc (c,r1,r2,lbl),Bcc (c',r1',r2',lbl') when c=c' -> add_subs [Lab (lbl,lbl'); Reg (sr_name r1,r1'); Reg (sr_name r2,r2');] subs | Load (w,s,m,r1,i,r2),Load (w',s',m',r1',i',r2') when w=w' && s=s' && m=m' && i=i' -> match_2r subs r1 r2 r1' r2' | Store (w,m,r1,i,r2),Store (w',m',r1',i',r2') when w=w' && m=m' && i=i' -> match_2r subs r1 r2 r1' r2' | LoadReserve (w,m,r1,r2),LoadReserve (w',m',r1',r2') when w=w' && m=m' -> match_2r subs r1 r2 r1' r2' | Ext (s,w,r1,r2),Ext (s',w',r1',r2') when s=s' && w=w' -> match_2r subs r1 r2 r1' r2' | StoreConditional (w,m,r1,r2,r3),StoreConditional (w',m',r1',r2',r3') when w=w' && m=m' -> match_3r subs r1 r2 r3 r1' r2' r3' | Amo (op,w,m,r1,r2,r3),Amo (op',w',m',r1',r2',r3') when op=op' && w=w' && m=m' -> match_3r subs r1 r2 r3 r1' r2' r3' | FenceIns b,FenceIns b' when b=b' -> Some subs | _,_ -> None let expl_instr subs = let conv_reg = conv_reg subs and find_lab = find_lab subs and find_cst = find_cst subs in function | OpI (op,r1,r2,k) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> find_cst k >! fun k -> OpI (op,r1,r2,k) | OpI2 (op,r1,k) -> conv_reg r1 >> fun r1 -> find_cst k >! fun k -> OpI2 (op,r1,k) | OpA (op,r1,lbl) -> conv_reg r1 >> fun r1 -> find_lab lbl >! fun lbl -> OpA (op,r1,lbl) | OpIW (op,r1,r2,k) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> find_cst k >! fun k -> OpIW (op,r1,r2,k) | Op (op,r1,r2,r3) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> Op (op,r1,r2,r3) | OpW (op,r1,r2,r3) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> OpW (op,r1,r2,r3) | Ext (s,w,r1,r2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> Ext (s,w,r1,r2) | J lbl-> find_lab lbl >! fun lbl -> J lbl | AUIPC (r1,k) -> conv_reg r1 >> fun r1 -> find_cst k >! fun k -> AUIPC (r1,k) | Bcc (c,r1,r2,lbl) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> find_lab lbl >! fun lbl -> Bcc (c,r1,r2,lbl) | Load (w,s,m,r1,i,r2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> Load (w,s,m,r1,i,r2) | Store (w,m,r1,i,r2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> Store (w,m,r1,i,r2) | LoadReserve (w,m,r1,r2) -> conv_reg r1 >> fun r1 -> conv_reg r2 >! fun r2 -> LoadReserve (w,m,r1,r2) | StoreConditional (w,m,r1,r2,r3) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> StoreConditional (w,m,r1,r2,r3) | Amo (op,w,m,r1,r2,r3) -> conv_reg r1 >> fun r1 -> conv_reg r2 >> fun r2 -> conv_reg r3 >! fun r3 -> Amo (op,w,m,r1,r2,r3) | INop|Ret|FenceIns _ as i -> unitT i end) herd-herdtools7-1ca343e/jingle/arch.ml000066400000000000000000000275111475314470400176670ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Printf module type Parser = sig include GenParser.S type parsedPseudo val instr_from_string : string -> parsedPseudo list end module type Dumper = sig type pseudo val dump_info : out_channel -> Name.t -> (MiscParser.state, (MiscParser.proc * pseudo list) list, MiscParser.prop, MiscParser.location,MiscParser.maybev,MiscParser.fault_type) MiscParser.result -> unit end module type Base = sig include ArchBase.S val dump_parsedInstruction : parsedInstruction -> string end module type Common = sig include Base type st = { free : reg list; reg_env : (string * reg) list; label_env : (string * string) list; } exception Error of string type substitution = | Reg of string * reg | Cst of string * int | Lab of string * string | Addr of string * string | Code of string * pseudo list val pp_subs : substitution list -> string val add_subs : substitution list -> substitution list -> substitution list option val sr_name : reg -> string val cv_name : MetaConst.k -> string val dump_pseudos : pseudo list -> string val debug_pseudos : pseudo list -> string val debug_pats : parsedInstruction kpseudo list -> string val conv_reg : substitution list -> reg -> st -> reg * st val find_lab : substitution list -> string -> st -> string * st val find_code : substitution list -> string -> st -> pseudo list * st val find_cst : substitution list -> MetaConst.k -> st -> MetaConst.k * st val (>>>) : 'a option -> ('a -> 'b option) -> 'b option end module type S = sig include Common val match_instruction : substitution list -> parsedPseudo -> pseudo -> substitution list option val instanciate_with : substitution list -> reg list -> parsedPseudo list -> pseudo list module Parser : Parser with type parsedPseudo = parsedPseudo and type pseudo = pseudo module Dumper : Dumper with type pseudo = pseudo end module MakeCommon(A:Base) = struct let debug = false include A type st = { free : reg list; reg_env : (string * reg) list; label_env : (string * string) list; } (* State monad *) let (>>) f g = fun st -> let r,st = f st in g r st let unitT r st = r,st let (>!) f g = fun st -> let r,st = f st in g r,st let (>!!) f g = fun st -> let rs,stt = List.split (List.map f st) in List.map g rs,stt let mapT f = let rec map_rec = function | [] -> unitT [] | x::xs -> f x >> fun y -> map_rec xs >! fun ys -> y::ys in map_rec let optT f = function | None -> unitT None | Some x -> f x >! fun y -> Some y (* Substitutions *) exception Error of string type substitution = | Reg of string * reg | Cst of string * int | Lab of string * string | Addr of string * string | Code of string * pseudo list let pp_sub = function | Reg (s,r) -> sprintf "Reg (%s,%s)" s (pp_reg r) | Cst (s,i) -> sprintf "Cst (%s,%i)" s i | Lab (l1,l2) -> sprintf "Lab (%s,%s)" l1 l2 | Addr (s,r) -> sprintf "Addr (%s,%s)" s r | Code (s,_) -> sprintf "Code (%s,...)" s let pp_subs subs = String.concat ";" (List.map pp_sub subs) let same_key b1 b2 = match b1,b2 with | (Reg (s1,_),Reg (s2,_)) | (Cst (s1,_),Cst (s2,_)) | (Lab (s1,_),Lab (s2,_)) | (Addr (s1,_),Addr (s2,_)) | (Code (s1,_),Code (s2,_)) -> Misc.string_eq s1 s2 | _ -> false let same_val b1 b2 = match b1,b2 with | (Reg (_,r1),Reg (_,r2)) -> A.reg_compare r1 r2 = 0 | (Cst (_,i1),Cst (_,i2)) -> Misc.int_eq i1 i2 | (Lab (_,s1),Lab (_,s2)) | (Addr (_,s1),Addr (_,s2)) -> Misc.string_eq s1 s2 | (Code (s,_),Code (_,_)) -> Warn.user_error "Code variable %s used non-linearily" s | _ -> false let rec find_prev b1 subs = match subs with | [] -> None | b2::subs -> if same_key b1 b2 then Some b2 else find_prev b1 subs let add_subs subs1 subs2 = try let k = List.fold_right (fun b1 k -> match find_prev b1 k with | None -> b1::k | Some b2 -> if same_val b1 b2 then k else raise Exit) subs1 subs2 in Some k with Exit -> None let sr_name r = match symb_reg_name r with | Some s -> s | None -> raise (Error "Not a symbolic register.") let match_reg r r' subs = match symb_reg_name r with | Some s -> add_subs [Reg (s,r')] subs | None -> if r = r' then Some subs else None let combine f x y g z t = match f x y with | None -> None | Some b -> match g z t with | None -> None | Some c -> Some (b@c) let cv_name = function | MetaConst.Meta s -> s | _ -> raise (Error "Not a constant variable.") let rec dump_pseudo di = function | Nop -> "*Nop*" | Label (lab,p) -> sprintf "%s: %s" lab (dump_pseudo di p) | Instruction i -> di i | Symbolic v -> "codevar:"^v | Macro _ -> assert false let rec dump_pseudos = function | [] -> "" | p::is -> dump_pseudo dump_instruction p ^";\n"^dump_pseudos is let rec do_debug_pseudos di k ps = match ps with | [] -> [] | p::ps -> if k <= 0 then ["..."] else dump_pseudo di p::do_debug_pseudos di (k-1) ps let debug_pseudos ps = String.concat "; " (do_debug_pseudos dump_instruction 3 ps) let debug_pats ps = String.concat "; " (do_debug_pseudos dump_parsedInstruction 3 ps) let alloc_reg st = match st.free with | r::free -> r,{ st with free=free; } | [] -> raise (Error "register free list exhausted") let conv_reg subs r st = let get_register = fun s -> try List.assoc s st.reg_env,st with | Not_found -> let r,st = alloc_reg st in r,{ st with reg_env = (s,r)::st.reg_env; } in let res = match symb_reg_name r with | Some s -> let rec aux = function | [] -> get_register s | Reg(n,r)::_ when Misc.string_eq n s -> r,st | Addr(n,r)::_ when Misc.string_eq n s -> get_register r | _::subs -> aux subs in aux subs | None -> r,st in if debug then begin let res,_ = res in eprintf "conv_reg subs=<%s> %s -> %s\n" (pp_subs subs) (pp_reg r) (pp_reg res) end ; res let fresh_lbl = let i = ref 0 in fun () -> incr i;"lbl"^(string_of_int !i) let find_lab subs lab st = let get_label = fun s -> try List.assoc s st.label_env,st with | Not_found -> let lab = fresh_lbl () in lab,{ st with label_env=(s,lab)::st.label_env; } in let rec aux = function | [] -> get_label lab | Lab(n,lbl)::_ when Misc.string_eq n lab -> lbl,st | _::subs -> aux subs in aux subs let find_code subs s st = let rec aux = function | [] -> raise (Error("No conversion found for code "^s)) | Code(n,c)::_ when Misc.string_eq n s -> c | _::subs -> aux subs in aux subs,st let find_cst subs k st = match k with | MetaConst.Meta s -> let rec aux = function | [] -> raise (Error("No conversion found for constant "^s)) | Cst(n,i)::_ when Misc.string_eq n s -> MetaConst.Int i | _::subs -> aux subs in aux subs,st | _ -> k,st let (>>>) v f = match v with | None -> None | Some v -> f v end module MakeParser (A:Base) (P:sig include GenParser.LexParse with type instruction = A.parsedPseudo val instr_parser : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> A.parsedPseudo list end) = struct include GenParser.Make(GenParser.DefaultConfig)(A)(P) type parsedPseudo = A.parsedPseudo let instr_from_string s = GenParserUtils.call_parser "themes" (Lexing.from_string s) P.lexer P.instr_parser end module MakeArch(I:sig include Common val match_instr : substitution list -> parsedInstruction -> instruction -> substitution list option val expl_instr : substitution list -> parsedInstruction -> st -> parsedInstruction * st end) = struct include I let rec match_instruction subs pattern instr = match pattern,instr with | Label(lp,insp),Label(li,insi) -> add_subs [Lab(lp,li)] subs >>> fun subs -> match_instruction subs insp insi | Label _, _ -> None | pattern, Label(_,instr) -> match_instruction subs pattern instr | Instruction ip, Instruction ii -> match_instr subs ip ii | Nop,Nop -> Some subs | _,_ -> assert false let instanciate_with subs free instrs = let expl_instr = expl_instr subs in let find_lab = find_lab subs in let find_code = find_code subs in let rec expl_pseudos = let rec aux p st = match p with | Nop -> [],st | Instruction ins -> let ins,st = expl_instr ins st in [pseudo_parsed_tr (Instruction ins)],st | Label (lbl,ins) -> begin let lbl,st = find_lab lbl st in let inss,st = aux ins st in let inss = match inss with | [] -> [pseudo_parsed_tr (Label (lbl, Nop))] | ins::inss -> Label(lbl,ins)::inss in inss,st end | Symbolic s -> find_code s st | Macro (_,_) -> assert false in fun is st -> match is with | [] -> [] | i::is -> let i,st = aux i st in let is = expl_pseudos is st in i@is in let st = { free; reg_env=[]; label_env=[];} in expl_pseudos instrs st end module DefaultDumper(A:ArchBase.S) = struct type pseudo = A.pseudo include SimpleDumper.Make(struct let compat = false end) (struct module A = A type v = ParsedConstant.v let dump_v = ParsedConstant.pp_v let dump_loc = MiscParser.dump_location let dump_state_atom a = MiscParser.dump_state_atom MiscParser.is_global dump_loc dump_v a type state = MiscParser.state let dump_state st = DumpUtils.dump_state dump_state_atom (MiscParser.env_for_pp st) type prop = MiscParser.prop let dump_atom a = ConstrGen.dump_atom dump_loc MiscParser.dump_location_brk ParsedConstant.pp_v MiscParser.dump_fault_type a let dump_prop = ConstrGen.prop_to_string dump_atom let dump_constr = ConstrGen.constraints_to_string dump_atom type location = MiscParser.location let dump_location = dump_loc type fault_type = MiscParser.fault_type let dump_fault_type = MiscParser.dump_fault_type end) end herd-herdtools7-1ca343e/jingle/cDumper.ml000066400000000000000000000135661475314470400203560ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open CBase open Printf type pseudo = CBase.pseudo let dump_loc = MiscParser.dump_location let dump_state_atom a = MiscParser.dump_state_atom MiscParser.is_global dump_loc ParsedConstant.pp_v a type state = MiscParser.state let dump_state st = String.concat " " (List.map (fun a -> sprintf "%s;" (dump_state_atom a)) st) type prop = MiscParser.prop type constr = MiscParser.constr let dump_atom a = ConstrGen.dump_atom dump_loc MiscParser.dump_location_brk ParsedConstant.pp_v MiscParser.dump_fault_type a let dump_prop = ConstrGen.prop_to_string dump_atom let dump_constr = ConstrGen.constraints_to_string dump_atom type location = MiscParser.location let dump_location = dump_loc let rec fmt_io io = match io with | Nop -> "" | Instruction ins -> dump_instruction ins | Label (lbl,io) -> lbl ^ ": " ^ fmt_io io | Symbolic s -> "codevar:"^s | Macro (f,regs) -> sprintf "%s(%s)" f (String.concat "," (List.map pp_reg regs)) let rec unwrap_pseudo = function | [] -> [] | (Instruction i)::is -> i::(unwrap_pseudo is) | (Label(_,p))::is -> (unwrap_pseudo [p])@(unwrap_pseudo is) | Nop:: is -> unwrap_pseudo is | _::is -> unwrap_pseudo is let list_loc prog = let module LocSet = Set.Make(struct type t = reg let compare = reg_compare end) in let rec loc s e = expr s e and expr s = function | Const _ -> s | LoadReg(r) -> LocSet.add r s | LoadMem(l,_) -> loc s l | AtomicOpReturn (e1,_,e2,_,_) | Op(_,e1,e2) -> expr (expr s e1) e2 | Exchange(l,e,_) -> loc (expr s e) l | Fetch(l,_,e,_) -> loc (expr s e) l | ECall (_,es) -> List.fold_left expr s es | AtomicAddUnless(e1,e2,e3,_,_) | CmpExchange (e1,e2,e3,_) | ECas (e1,e2,e3,_,_,_) -> expr (expr (expr s e1) e2) e3 | TryLock (e,_)|IsLocked (e,_)|ExpSRCU(e,_) -> expr s e in let rec ins s = function | Seq(l,_) -> List.fold_left ins s l | If(c,t,Some e) -> expr (ins (ins s e) t) c | If(c,t,None) -> expr (ins s t) c | While (e,i,_) -> expr (ins s i) e | DeclReg (_,r) -> LocSet.add r s | CastExpr e -> expr s e | StoreReg(_,Some r,e) -> LocSet.add r (expr s e) | StoreReg(_,None,e) -> expr s e | StoreMem(l,e,_) -> loc (expr s e) l | Lock (l,_) | Unlock (l,_) -> loc s l | PCall (_,es) -> List.fold_left expr s es | Fence _|Symb _ -> s | AtomicOp(e1,_,e2,_) -> expr (expr s e1) e2 | InstrSRCU(e,_,None) -> expr s e | InstrSRCU(e,_,Some f) -> expr (expr s f) e in LocSet.elements (List.fold_left ins LocSet.empty prog) let get_params init i = let open Constant in List.fold_left (fun a -> function | (MiscParser.Location_reg(p,_), (_,Symbolic (Virtual {name=s;_}))) when i = p -> { CAst.param_ty = CType.Volatile CType.word; CAst.param_name = s }::a | _ -> a ) [] init let extract_decl init i prog = let rec find_v s = function | [] -> None | (MiscParser.Location_reg(n,r),(_,v))::_ when String.compare s r = 0 && n = i -> Some (ParsedConstant.pp_v v) | _::init -> find_v s init in let to_decl = function | s -> let aff = match find_v s init with | None -> ";" | Some s -> " = "^s^";" in sprintf "int %s%s" s aff (* | Mem (Load (Reg s, MemOrderOrAnnot.AN [])) -> let aff = match find_v s init with | None -> ";" | Some s -> " = "^s^";" in sprintf "int* %s%s" s aff | _loc -> assert false *) in List.map to_decl (list_loc prog) let code init prog = let open CAst in List.map (fun ((i,_,_),p) -> let params = get_params init i in let decls = extract_decl init i (unwrap_pseudo p) in Test { proc = i; params = params; body = String.concat "\n" (decls@(List.map fmt_io p)) }) prog let prog = DumpCAst.print_prog let do_dump withinfo chan doc t = fprintf chan "%s %s\n" (Archs.pp arch) doc.Name.name ; begin match doc.Name.doc with | "" -> () | doc -> fprintf chan "\"%s\"\n" doc end ; if withinfo then begin List.iter (fun (k,i) -> fprintf chan "%s=%s\n" k i) t.MiscParser.info end ; fprintf chan "\n{%s}\n\n" (dump_state t.MiscParser.init) ; prog chan (code t.MiscParser.init t.MiscParser.prog) ; let locs = DumpUtils.dump_locations dump_location ParsedConstant.pp_v MiscParser.dump_fault_type t.MiscParser.locations in if locs <> "" then fprintf chan "%s\n" locs ; let extra = t.MiscParser.extra_data in begin List.iter (function | MiscParser.CExtra _ -> () | MiscParser.BellExtra bi -> fprintf chan "\n%s\n" (BellInfo.pp bi)) extra end ; fprintf chan "%s\n" (dump_constr t.MiscParser.condition) ; () let dump chan = do_dump false chan let dump_info chan = do_dump true chan herd-herdtools7-1ca343e/jingle/callMap.mll000066400000000000000000000045071475314470400204770ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Boqun Feng *) (* *) (* Copyright 2018-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) { exception Error of string type t = { source : Archs.t; conversions : (string * string * string) list } } let space = [' ' '\t' '\r'] let blank = (space | '\n') let archname = ([ '0'-'9' 'a'-'z' 'A'-'Z'])* let arrow = ("->" | "maps" space "to") rule main = parse | space* (archname as src) space* '\n' blank* { let convs = conv [] lexbuf in let src = match Archs.parse src with | Some s -> s | _ -> raise (Error "Source or target architecture unrecognized.") in { source = src; conversions = List.rev convs } } | "" {raise (Error "Source or target architecture unspecified.")} and conv l = parse | eof {l} | '"' ([^'"']* as left) '"' blank* arrow blank* '"' '@' ([^' ' '\t' '\r' '\n']* as func) blank+ ([^'"']* as arg) '"' blank* { conv ((String.trim left, String.trim func, String.trim arg)::l) lexbuf } | ("#"|"//") [^'\n']* '\n' { conv l lexbuf } | "" { let last = match l with | [] -> "*start*" | (func, left, right)::_ -> Printf.sprintf "\"%s\" : \"%s\" -> \"%s\"" func left right in let msg = Printf.sprintf "Bad syntax in conversion rule, after %s" last in raise (Error msg)} { let parse chin = main (Lexing.from_channel chin) } herd-herdtools7-1ca343e/jingle/dune000066400000000000000000000003161475314470400172700ustar00rootroot00000000000000(rule (copy ../Version.ml Version.ml)) (ocamllex callMap parseMap) (executables (names jingle gen_theme) (public_names jingle7 gen_theme7) (libraries herdtools str) (modules_without_implementation)) herd-herdtools7-1ca343e/jingle/gen_theme.ml000066400000000000000000000136041475314470400207030ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Boqun Feng *) (* *) (* Copyright 2018-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Printf let verbose = ref false let libdir = ref (Filename.concat Version.libdir "jingle") let includes = ref [] let map = ref None let call = ref None let outdir = ref None let loops = ref 5 let prog = if Array.length Sys.argv > 0 then Sys.argv.(0) else "gen_theme" exception Error of string let () = Arg.parse ["-version", Arg.Unit (fun () -> printf "%s, Rev: %s\n" Version.version Version.rev ; exit 0), " - show version number and exit" ; "-libdir", Arg.Unit (fun () -> print_endline !libdir; exit 0), " - show installation directory and exit"; "-set-libdir", Arg.String (fun s -> libdir := s), " set installation directory to "; "-v",Arg.Unit (fun () -> verbose := true), "- be verbose"; "-I", Arg.String (fun s -> includes := !includes @ [s]), " - add to search path"; "-map",Arg.String (fun s -> map := Some s), " - give the map file "; "-call",Arg.String (fun s -> call := Some s), " - give the call file "; "-o",Arg.String (fun s -> outdir := Some s), " - directory for output files"; "-n",Arg.Int (fun i -> loops := i), " - times re-apply the functions in call file with the update env"] (fun _ -> ()) (sprintf "Usage: %s [option]* -map -call -n " prog) let includes = !includes let map = !map let call = !call let verbose = !verbose let outdir = !outdir let loops = !loops let libfind = let module ML = MyLib.Make (struct let includes = includes let env = None let libdir = !libdir let debug = verbose end) in ML.find let parsed = match map with | None -> raise (Error "No map file provided.") | Some s -> let s = libfind s in try Misc.input_protect ParseMap.parse s with ParseMap.Error msg -> eprintf "File \"%s\": %s\n" s msg ; exit 1 let parsed_call = match call with | None -> raise (Error "No call file provided.") | Some s -> let s = libfind s in try Misc.input_protect CallMap.parse s with CallMap.Error msg -> eprintf "File \"%s\": %s\n" s msg ; exit 1 let pick_func f func_env = Misc.find_opt (fun (x, _) -> Misc.string_eq x f) func_env let remove_func f func_env = List.remove_assoc f func_env let pick_mapping e map_env = Misc.find_opt (fun (x, _) -> Misc.string_eq x e) map_env let rec apply f arg func_env = match pick_func f func_env with | None -> raise(Error ("no func for " ^ f ^ " for arg: " ^ arg ^ ".")) | Some(_, ParseMap.Appliable(d, c)) -> begin let re = Str.regexp d in try let _ = Str.search_forward re arg 0 in Str.replace_first re c arg with Not_found -> apply f arg (remove_func f func_env) end | Some(_, ParseMap.Sequence(fs)) -> begin (* If all functions in the sequence exist in 'func_env' *) if fs |> List.for_all (fun g -> Misc.is_some (pick_func g func_env)) then List.fold_left (fun a g -> apply g a func_env) arg fs else apply f arg (remove_func f func_env) end let rec expand call_list map_env func_env times = let callable = List.filter (fun (_, _, e) -> List.mem_assoc e map_env) call_list in let uncallable = List.filter (fun (_, _, e) -> not (List.mem_assoc e map_env)) call_list in let try_expand (l, f, a) = (pick_mapping a map_env) |> Misc.map_opt (fun (_, arg) -> let r = apply f arg func_env in (l, r)) in let res = callable |> List.map try_expand |> List.filter (fun x -> Misc.is_some x) |> List.map Misc.as_some in if times <= 1 then res else match uncallable with | [] -> res | (_, _, _) :: _ -> (expand uncallable (res @ map_env) func_env (times - 1)) @ res let () = if verbose then begin eprintf "Reading map file :\n"; List.iter (fun (s,t) -> eprintf "\"%s\" -> \"%s\"\n" s t) parsed.ParseMap.conversions; List.iter (fun (n, func) -> match func with | ParseMap.Appliable(f, a) -> eprintf "\"%s\" : \"@%s %s\"\n" n f a | ParseMap.Sequence(fs) -> eprintf "\"%s\" : %s\n" n (String.concat " | " fs)) parsed.ParseMap.funcs; eprintf "Reading call file :\n"; List.iter (fun (n, l, r) -> eprintf "\"%s\" : \"%s\" -> \" %s\"\n" n l r) parsed_call.CallMap.conversions; eprintf "End Reading.\n" end; let maps = parsed.ParseMap.conversions in let calls = parsed_call.CallMap.conversions in let funcs = parsed.ParseMap.funcs in Printf.printf "%s to %s\n\n" (Archs.pp parsed.ParseMap.source) (Archs.pp parsed.ParseMap.target); List.iter (fun (l, r) -> Printf.printf "\"%s\" -> \"%s\"\n" l r) maps; List.iter (fun (l, r) -> Printf.printf "\"%s\" -> \"%s\"\n" l r) (expand calls maps funcs loops) herd-herdtools7-1ca343e/jingle/jingle.ml000066400000000000000000000212501475314470400202140ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Printf let verbose = ref 0 let libdir = ref (Filename.concat Version.libdir "jingle") let includes = ref [] let map = ref None let outdir = ref None let args = ref [] let prog = if Array.length Sys.argv > 0 then Sys.argv.(0) else "jingle" exception Error of string let get_arch = let open Arch in function | `AArch64 -> let module AArch64LexParse = struct type instruction = AArch64Arch_jingle.parsedPseudo type token = AArch64Parser.token module Lexer = AArch64Lexer.Make (struct let debug = false let is_morello = false end) let lexer = Lexer.token let parser = (*MiscParser.mach2generic*) AArch64Parser.main let instr_parser = AArch64Parser.instr_option_seq end in (module struct include AArch64Arch_jingle module Parser = MakeParser(AArch64Arch_jingle)(AArch64LexParse) module Dumper = DefaultDumper(AArch64Arch_jingle) end : Arch.S) | `ARM -> let module ARMLexParse = struct type instruction = ARMArch_jingle.parsedPseudo type token = ARMParser.token module Lexer = ARMLexer.Make(struct let debug = false end) let lexer = Lexer.token let parser = MiscParser.mach2generic ARMParser.main let instr_parser = ARMParser.instr_option_seq end in (module struct include ARMArch_jingle module Parser = MakeParser(ARMArch_jingle)(ARMLexParse) module Dumper = DefaultDumper(ARMArch_jingle) end : S) | `LISA -> let module BellLexParse = struct type instruction = BellArch_jingle.parsedPseudo type token = LISAParser.token module Lexer = BellLexer.Make(struct let debug = false end) let lexer = Lexer.token let parser = LISAParser.main let instr_parser = LISAParser.instr_option_seq end in (module struct include BellArch_jingle module Parser = MakeParser(BellArch_jingle)(BellLexParse) module Dumper = DefaultDumper(BellArch_jingle) end : S) | `C -> let module CLexParse = struct type pseudo = CArch_jingle.parsedPseudo type token = CParser.token module Lexer = CLexer.Make(struct let debug = false end) let shallow_lexer = Lexer.token false let deep_lexer = Lexer.token true let shallow_parser = CParser.shallow_main let deep_parser = CParser.deep_main let instr_parser = CParser.pseudo_seq (* No macro.. *) type macro = unit let macros_parser _ _ = assert false let macros_expand _ i = i end in (module struct include CArch_jingle module Parser = struct include CGenParser_lib.Make(CGenParser_lib.DefaultConfig) (CArch_jingle)(CLexParse) type parsedPseudo = CArch_jingle.parsedPseudo let instr_from_string s = GenParserUtils.call_parser "themes" (Lexing.from_string s) CLexParse.deep_lexer CLexParse.instr_parser end module Dumper = CDumper end : S) | `PPC -> let module PPCLexParse = struct type instruction = PPCArch_jingle.parsedPseudo type token = PPCParser.token module Lexer = PPCLexer.Make(struct let debug = false end) let lexer = Lexer.token let parser = MiscParser.mach2generic PPCParser.main let instr_parser = PPCParser.instr_option_seq end in (module struct include PPCArch_jingle module Parser = MakeParser(PPCArch_jingle)(PPCLexParse) module Dumper = DefaultDumper(PPCArch_jingle) end : S) | `RISCV -> let module RISCVLexParse = struct type instruction = RISCVArch_jingle.parsedPseudo type token = RISCVParser.token module Lexer = RISCVLexer.Make(struct let debug = false end) let lexer = Lexer.token let parser = MiscParser.mach2generic RISCVParser.main let instr_parser = RISCVParser.instr_option_seq end in (module struct include RISCVArch_jingle module Parser = MakeParser(RISCVArch_jingle)(RISCVLexParse) module Dumper = DefaultDumper(RISCVArch_jingle) end : Arch.S) | a -> Warn.fatal "Arch %s is not implemented" (Archs.pp a) let () = Arg.parse ["-version", Arg.Unit (fun () -> printf "%s, Rev: %s\n" Version.version Version.rev ; exit 0), " show version number and exit" ; "-libdir", Arg.Unit (fun () -> print_endline !libdir; exit 0), " show installation directory and exit"; "-set-libdir", Arg.String (fun s -> libdir := s), " set installation directory to "; "-v",Arg.Unit (fun () -> incr verbose), " be verbose, repeat to increase verbosity"; "-I", Arg.String (fun s -> includes := !includes @ [s]), " add to search path"; "-theme",Arg.String (fun s -> map := Some s), " give the theme file "; "-o",Arg.String (fun s -> outdir := Some s), " directory for output files"] (fun s -> args := s :: !args) (sprintf "Usage: %s [option]* -theme [test]*" prog) let map = !map let includes = !includes let verbose = !verbose let outdir = !outdir let args = !args let libfind = let module ML = MyLib.Make (struct let includes = includes let env = None let libdir = !libdir let debug = verbose > 0 end) in ML.find let parsed = match map with | None -> raise (Error "No map file provided.") | Some s -> let s = libfind s in try Misc.input_protect ParseMap.parse s with ParseMap.Error msg -> eprintf "File \"%s\": %s\n" s msg ; exit 1 let () = if verbose > 1 then begin eprintf "Reading theme file :\n"; List.iter (fun (s,t) -> eprintf "\"%s\" -> \"%s\"\n" s t) parsed.ParseMap.conversions end module Source = (val get_arch parsed.ParseMap.source) module Target = (val get_arch parsed.ParseMap.target) module Trad = Mapping.Make (struct let verbose = verbose > 0 module Source = Source module Target = Target let conversions = parsed.ParseMap.conversions end) module Top(Out:OutTests.S) = struct let idx_out = Out.open_all () let do_trans file k = let fin chin = let sres = let module SP = Splitter.Make(Splitter.Default) in SP.split (Filename.basename file) chin in let tgt_test = try Trad.translate file chin sres with Mapping.Error msg -> Warn.fatal "File \"%s\": %s" file msg in let dump out = let out = Out.chan out in Target.Dumper.dump_info out sres.Splitter.name tgt_test in let base = Filename.basename file in let out = Out.open_file base in Misc.output_protect_close Out.close dump out ; Out.fprintf idx_out "%s\n" base in try Misc.input_protect fin file ; k+1 with | Misc.Exit -> k | Misc.Fatal msg -> if verbose > 0 then eprintf "%s\n" msg ; k let zyva () = let nout = Misc.fold_argv_or_stdin do_trans args 0 in Out.tar() ; eprintf "Generated %i tests\n" nout end let () = match outdir with | None -> let module X = Top(OutStd) in X.zyva() | Some _ -> let module Out = OutTar.Make (struct let verbose = 0 let outname = outdir end) in let module X = Top(Out) in X.zyva () herd-herdtools7-1ca343e/jingle/libdir/000077500000000000000000000000001475314470400176575ustar00rootroot00000000000000herd-herdtools7-1ca343e/jingle/libdir/AArch64toBell.theme000066400000000000000000000002101475314470400231660ustar00rootroot00000000000000AArch64 to Bell "MOV %x,&c; STR %x,[%y]" maps to: "w[] %y &c" "LDR %y,[%x]" maps to: "r[] %y %x" "STR %y,[%x]" maps to: "w[] %y %x" herd-herdtools7-1ca343e/jingle/libdir/BelltoAArch64.theme000066400000000000000000000006221475314470400231750ustar00rootroot00000000000000Bell to AArch64 "r[] %x %y" -> "LDR %x,[%y]" "r[] %x y" -> "LDR %x,[%y]" "r[acq] %x y" -> "LDAR %x,[%y]" "w[] %x &c" -> "MOV %tmp,&c; STR %tmp,[%x]" "w[] x &c" -> "MOV %tmp,&c; STR %tmp,[%x]" "w[] %x %y" -> "STR %x,[%y]" "w[rel] x &c" -> "MOV %tmp,&c; STLR %tmp,[%x]" "f[dmb,all,sy]" -> "DMB SY" "f[dmb,ld,sy]" -> "DMB LD" "f[dmb,st,sy]" -> "DMB ST" herd-herdtools7-1ca343e/jingle/libdir/BelltoARM.theme000066400000000000000000000006241475314470400224660ustar00rootroot00000000000000Bell to ARM "r[] %x %y" -> "LDR %x,[%y]" "r[] %x y" -> "LDR %x,[%y]" "w[] %x &c" -> "MOV %tmp,&c; STR %tmp,[%x]" "w[] x &c" -> "MOV %tmp,&c; STR %tmp,[%x]" "w[] %x %y" -> "STR %x,[%y]" "f[DMB,SY]" -> "DMB SY" "f[DMB,ST]" -> "DMB ST" "f[DSB,SY]" -> "DSB SY" "f[DSB,ST]" -> "DSB ST" "f[ISB]" -> "ISB" "mov %test (eq %r 0); b[] %test label" -> "CBZ %r,label" herd-herdtools7-1ca343e/jingle/libdir/BelltoC.theme000066400000000000000000000004551475314470400222330ustar00rootroot00000000000000Bell to C "r[] %x %y" -> "x = y;" "r[] %x y" -> "x = *y;" "r[acq] %x y" -> "x = atomic_load_explicit(y,memory_order_acquire);" "w[] %x &c" -> "x = constvar:c;" "w[] x &c" -> "*x = constvar:c;" "w[] %x %y" -> "x = y;" "w[rel] x &c" -> "atomic_store_explicit(x,constvar:c,memory_order_release);" herd-herdtools7-1ca343e/jingle/libdir/CtoAArch64.theme000066400000000000000000000023651475314470400225070ustar00rootroot00000000000000C to AArch64 "if(constvar:c == x) codevar:t;" -> "CMP %x,&c; B.NE else; codevar:t; else:" "%x = constvar:c;" -> "MOV %x,&c" "*%x = constvar:c;" -> "MOV %tmp,&c; STR %tmp,[%x]" "*%x = %y;" -> "STR %y,[%x]" "%x = *%y;" -> "LDR %x,[%y]" "%x = atomic_load(%y);" -> "LDAR %x,[%y]" "%x = atomic_load_explicit(%y,memory_order_relaxed);" -> "LDR %x,[%y]" "%x = atomic_load_explicit(%y,memory_order_consume);" -> "LDAR %x,[%y]" "%x = atomic_load_explicit(%y,memory_order_acquire);" -> "LDAR %x,[%y]" "atomic_store(%y,%x);" -> "STLR %x,[%y]" "atomic_store_explicit(%y,%x,memory_order_relaxed);" -> "STR %x,[%y]" "atomic_store_explicit(%y,%x,memory_order_release);" -> "STLR %x,[%y]" "atomic_store(%y,constvar:c);" -> "MOV %tmp,&c; STLR %tmp,[%y]" "atomic_store_explicit(%y,constvar:c,memory_order_relaxed);" -> "MOV %tmp,&c; STR %tmp,[%y]" "atomic_store_explicit(%y,constvar:c,memory_order_release);" -> "MOV %tmp,&c; STLR %tmp,[%y]" "atomic_thread_fence(memory_order_seq_cst);" -> "DMB SY" "atomic_thread_fence(memory_order_acq_rel);" -> "DMB SY" "atomic_thread_fence(memory_order_release);" -> "DMB SY" "atomic_thread_fence(memory_order_acquire);" -> "DMB LD" herd-herdtools7-1ca343e/jingle/libdir/Linux.call000066400000000000000000000024111475314470400216110ustar00rootroot00000000000000C "%x = smp_load_acquire(%y);" -> "@acquire %x = READ_ONCE(*%y);" "smp_store_release(%y, %x);" -> "@release WRITE_ONCE(*%y, %x);" "smp_store_release(%y, constvar:c);" -> "@release WRITE_ONCE(*%y, constvar:c);" "%x = rcu_dereference(*%y);" -> "@acquire %x = READ_ONCE(*%y);" "%r = xchg_acquire(%x, %y);" -> "@acquire %r = xchg_relaxed(%x, %y);" "%r = xchg_release(%x, %y);" -> "@release %r = xchg_relaxed(%x, %y);" "%r = xchg(%x, %y);" -> "@full %r = xchg_relaxed(%x, %y);" "%r = xchg_acquire(%x, constvar:c);" -> "@acquire %r = xchg_relaxed(%x, constvar:c);" "%r = atomic_xchg_acquire(%x, constvar:c);" -> "@id %r = xchg_acquire(%x, constvar:c);" "%r = cmpxchg_acquire(%x, constvar:c, constvar:d);" -> "@acquire %r = cmpxchg_relaxed(%x, constvar:c, constvar:d);" "%r = atomic_cmpxchg_acquire(%x, constvar:c, constvar:d);" -> "@id %r = cmpxchg_acquire(%x, constvar:c, constvar:d);" "%r = xchg_release(%x, constvar:c);" -> "@release %r = xchg_relaxed(%x, constvar:c);" "%r = atomic_xchg_release(%x, constvar:c);" -> "@id %r = xchg_release(%x, constvar:c);" "%r = xchg(%x, constvar:c);" -> "@full %r = xchg(%x, constvar:c);" "spin_lock(%x);" -> "@lock %r = cmpxchg_acquire(%x, constvar:c, constvar:d);" "spin_unlock(%y);" -> "@const_c_to_0 smp_store_release(%y, constvar:c);" herd-herdtools7-1ca343e/jingle/libdir/Linux2AArch64.map000066400000000000000000000067321475314470400226200ustar00rootroot00000000000000C to AArch64 "if(%x != constvar:c) codevar:t; else codevar:f;" -> "CMP %x,&c; B.EQ else; codevar:t; B end; else: codevar:f; end:" "if(%x) codevar:t; else codevar:f;" -> "CMP %x,#0; B.EQ else; codevar:t; B end; else: codevar:f; end:" "if(constvar:c == x) codevar:t;" -> "CMP %x,&c; B.NE else; codevar:t; else:" "if(x == constvar:c) codevar:t;" -> "CMP %x,&c; B.NE else; codevar:t; else:" "if(%x) codevar:t;" -> "CMP %x,#0; B.EQ else; codevar:t; else:" "%x = constvar:c;" -> "MOV %x,&c" "*%x = constvar:c;" -> "MOV %tmp,&c; STR %tmp,[%x]" "%x = %y;" -> "MOV %x,%y" "%x = %y == %z;" -> "CMP %y,%z; CSINC %x,XZR,XZR,NE" "%x = %y != %z;" -> "CMP %y,%z; CSINC %x,XZR,XZR,EQ" "%x = %y == constvar:c;" -> "CMP %y,&c; CSINC %x,XZR,XZR,NE" "%x = %y != constvar:c;" -> "CMP %y,&c; CSINC %x,XZR,XZR,EQ" "*%x = %y;" -> "STR %y,[%x]" "%x = *%y;" -> "LDR %x,[%y]" "%x = READ_ONCE(*%y);" -> "load:LDR %x,[%y]" "WRITE_ONCE(*%y, %x);" -> "store:STR %x,[%y]" "WRITE_ONCE(*%y, constvar:c);" -> "MOV %tmp,&c; store:STR %tmp,[%y]" "WRITE_ONCE(*%y, %x + constvar:c);" -> "MOV %tmp,&c; ADD %tmp, %tmp, %x; store:STR %tmp,[%y]" "%x = %t & constvar:c; %x = %x + constvar:d; WRITE_ONCE(*%y,%x);" -> "AND %x,%t,&c; ADD %x,%x,&d; store: STR %x,[%y]" "%t0 = %r & constvar:c; %t1 = %x + %t0; WRITE_ONCE(*%t1,constvar:d);" -> "AND %t0,%r,&c; ADD %t1,%x,%t0; MOV %t2,&d; store: STR %t2,[%t1]" "%x = %t & constvar:c; %x = %x + constvar:d; smp_store_release(%y,%x);" -> "AND %x,%t,&c; ADD %x,%x,&d; store: STLR %x,[%y]" "%t0 = %r & constvar:c; %t1 = %x + %t0; smp_store_release(%t1,constvar:d);" -> "AND %t0,%r,&c; ADD %t1,%x,%t0; MOV %t2,&d; store: STLR %t2,[%t1]" "%r = xchg_relaxed(%x, %y);" -> "loop:load:LDXR %r,[%x]; store:STXR w%wmp, %y,[%x]; CBNZ w%wmp, loop" "%r = cmpxchg_relaxed(%x, constvar:c, constvar:d);" -> "loop:MOV %tmp, &c; load:LDXR %r,[%x]; CMP %r, %tmp; B.NE out; MOV %tmp, &d; store:STXR w%wmp, %tmp, [%x]; CBNZ w%wmp, loop; out:" "%r = xchg_relaxed(%x, constvar:c);" -> "MOV %tmp,&c; loop:load:LDXR %r,[%x]; store:STXR w%wmp, %tmp,[%x]; CBNZ w%wmp, loop" "smp_mb();" -> "DMB ISH" "smp_rmb();" -> "DMB ISHLD" "smp_wmb();" -> "DMB ISHST" "atomic_inc(%x);" -> "MOV %tmp,#1; stadd %tmp, [%x]" "release" : "store:STR" -> "store:STLR" "release" : "store:STXR" -> "store:STLXR" "release" : "" -> "DMB ISH;" "acquire" : "load:LDR" -> "load:LDAR" "acquire" : "load:LDXR" -> "load:LDAXR" "acquire" : "\(\(.\|\n\)*\)" -> "\1;DMB ISH" "full_on_acq_rel" : "\([^;]$\)" -> "\1; DMB ISH" "full" : "acquire | release | full_on_acq_rel" "id" : "" -> "" "const_c_to_1" : "&c" -> "#1" "const_c_to_0" : "&c" -> "#0" "const_d_to_1" : "&d" -> "#1" "out_to_loop" : "B.NE out" -> "B.NE loop" "lock" : "const_c_to_0 | const_d_to_1 | out_to_loop" herd-herdtools7-1ca343e/jingle/libdir/Linux2PPC.map000066400000000000000000000071011475314470400221010ustar00rootroot00000000000000C to PPC "if(%x != constvar:c) codevar:t; else codevar:f;" -> "cmpwi %x,&c; beq else; codevar:t; b end; else: codevar:f; end:" "if(%x) codevar:t; else codevar:f;" -> "cmpwi %x,0; beq else; codevar:t; b end; else: codevar:f; end:" "if(constvar:c == x) codevar:t;" -> "cmpwi %x,&c; bne else; codevar:t; else:" "if(x == constvar:c) codevar:t;" -> "cmpwi %x,&c; bne else; codevar:t; else:" "if(%x) codevar:t;" -> "cmpwi %x,0; beq else; codevar:t; else:" "%x = constvar:c;" -> "li %x,&c" "*%x = constvar:c;" -> "li %tmp,&c; stw %tmp,0(%x)" "%x = %y;" -> "mr %x,%y" "%x = %y == %z;" -> "li %x,1; cmpw %y,%z; beq else; xor %x,%x,%x; else:" "%x = %y != %z;" -> "li %x,1; cmpw %y,%z; bne else; xor %x,%x,%x; else:" "%x = %y == constvar:c;" -> "li %x,1; cmpwi %y,&c; beq else; xor %x,%x,%x; else:" "%x = %y != constvar:c;" -> "li %x,1; cmpwi %y,&c; bne else; xor %x,%x,%x; else:" "*%x = %y;" -> "stw %y,0(%x)" "%x = *%y;" -> "lwz %x,0(%y)" "%x = READ_ONCE(*%y);" -> "load:lwz %x,0(%y)" "WRITE_ONCE(*%y, %x);" -> "store:stw %x,0(%y)" "WRITE_ONCE(*%y, constvar:c);" -> "li %tmp,&c; store:stw %tmp,0(%y)" "WRITE_ONCE(*%y, %x + constvar:c);" -> "li %tmp,&c; add %tmp, %tmp, %x; store:stw %tmp,0(%y)" "%x = %t & constvar:c; %x = %x + constvar:d; WRITE_ONCE(*%y,%x);" -> "andi. %x,%t,&c; addi %x,%x,&d; store: stw %x,0(%y)" "%t0 = %r & constvar:c; %t1 = %x + %t0; WRITE_ONCE(*%t1,constvar:d);" -> "andi. %t0,%r,&c; add %t1,%x,%t0; li %t2,&d; store: stw %t2,0(%t1)" "%x = %t & constvar:c; %x = %x + constvar:d; smp_store_release(%y,%x);" -> "andi. %x,%t,&c; addi %x,%x,&d; lwsync; store: stw %x,0(%y)" "%t0 = %r & constvar:c; %t1 = %x + %t0; smp_store_release(%t1,constvar:d);" -> "andi. %t0,%r,&c; add %t1,%x,%t0; li %t2,&d; lwsync; store: stw %t2,0(%t1)" "%r = xchg_relaxed(%x, %y);" -> "loop:load:lwarx %r,r0,%x; store:stwcx. %y,r0,%x; bne loop" "%r = cmpxchg_relaxed(%x, constvar:c, constvar:d);" -> "loop:li %tmp,&c; load:lwarx %r,r0,%x; cmpw %r,%tmp; bne out; li %tmp,&d; store:stwcx. %tmp,r0,%x; bne loop; out:" "%r = xchg_relaxed(%x, constvar:c);" -> "li %tmp,&c; loop:load:lwarx %r,r0,%x; store:stwcx. %tmp,r0,%x; bne loop" "smp_mb();" -> "sync" "smp_rmb();" -> "lwsync" "smp_wmb();" -> "lwsync" "release" : "" -> "lwsync;" "acquire" : "^\([^;]+\)$" -> "\1;lwsync" // this func will convert lwsync to stronger sync in the translation "harden_lwsync" : "lwsync" -> "sync" // On PPC, to convert a acq_rel into a fully-ordered primitive, // we need to harden lwsync twice: one for the release lwsync and // the other for the acquire lwsync "full_on_acq_rel" : "harden_lwsync | harden_lwsync" "full" : "acquire | release | full_on_acq_rel" "id" : "" -> "" "const_c_to_1" : "&c" -> "1" "const_c_to_0" : "&c" -> "0" "const_d_to_1" : "&d" -> "1" "out_to_loop" : "bne out" -> "bne loop" "lock" : "const_c_to_0 | const_d_to_1 | out_to_loop" herd-herdtools7-1ca343e/jingle/libdir/RISCV2AArch64.map000066400000000000000000000006351475314470400224030ustar00rootroot00000000000000RISCV to AArch64 "li %r,&c" -> "MOV %r,&c" "sw %r,0(%t)" -> "STR w%r,[%t]" "sw.rl %r,0(%t)" -> "STLR w%r,[%t]" "sd %r,0(%t)" -> "STR %r,[%t]" "sd.rl %r,0(%t)" -> "STLR %r,[%t]" "lw %r,0(%a)" -> "LDR w%r,[%t]" "lw.aq %r,0(%a)" -> "LDAR w%r,[%t]" "ld %r,0(%a)" -> "LDR %r,[%t]" "ld.aq %r,0(%a)" -> "LDAR %r,[%t]" "fence rw,rw" -> "DMB SY" "add %r,%t,%s" -> "ADD %r,%t,%s" "xor %r,%t,%s" -> "EOR %r,%t,%s" herd-herdtools7-1ca343e/jingle/libdir/test.theme000066400000000000000000000000201475314470400216520ustar00rootroot00000000000000AArch64 to Bell herd-herdtools7-1ca343e/jingle/mapping.ml000066400000000000000000000244411475314470400204040ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) open Printf exception Error of string module type Config = sig val verbose : bool module Source : Arch.S module Target : Arch.S val conversions : (string * string) list end module Make(C:Config) = struct let debug = 0 module Source = C.Source module Target = C.Target module Env = struct type sub = { reg : (Source.reg * Target.reg) list; addr: (string * Target.reg) list; lab : (string * string) list } let pp_sub {reg; addr; _} = sprintf "{reg=<%s>; addr=<%s>;}" (String.concat " " (List.map (fun (sr,tr) -> sprintf "%s->%s" (Source.pp_reg sr) (Target.pp_reg tr)) reg)) (String.concat " " (List.map (fun (sr,tr) -> sprintf "%s->%s" sr (Target.pp_reg tr)) addr)) type t = sub * Target.reg list let init = {reg = []; lab = []; addr = []},Target.allowed_for_symb let get_register_from_reg (binds,free) reg = try (List.assoc reg binds.reg,(binds,free)) with | Not_found -> match free with | [] -> raise (Error "No fresh register available.") | r::fs -> if debug > 1 then eprintf "Allocating %s->%s\n" (Source.pp_reg reg) (Target.pp_reg r) ; r,({binds with reg=(reg,r)::binds.reg},fs) let get_register_from_addr (binds,free) addr = try (List.assoc addr binds.addr,(binds,free)) with | Not_found -> match free with | [] -> raise (Error "No fresh register available.") | r::fs -> r,({binds with addr=(addr,r)::binds.addr},fs) let get_label = let fresh_label = let i = ref 0 in (fun () -> incr i;"label"^(string_of_int !i)) in fun (binds,free) l -> try (List.assoc l binds.lab,(binds,free)) with | Not_found -> let lbl = fresh_label () in lbl,({binds with lab=(l,lbl)::binds.lab},free) let get_lab_convs (binds,_) = List.map (fun (s,t) -> Target.Lab(s,t)) binds.lab let get_free_register (_,free) = free end let conversions = List.map (fun (s,t) -> let s = try Source.Parser.instr_from_string s with | e -> eprintf "Error while parsing instructions :\n\"%s\"\n" s; raise e in let t = try Target.Parser.instr_from_string t with | e -> eprintf "Error while parsing instructions :\n\"%s\"\n" t; raise e in (s,t) ) C.conversions let rec dig subs pat instr = match pat,instr with | [],_ -> Some (instr,[]) | _::_,[] -> None | p::ps,i::is -> match Source.match_instruction subs p i with | Some _ -> Some([],i::is) | None -> match dig subs (p::ps) is with | None -> None | Some(stash,rem) -> Some(i::stash,rem) let pp_pat_instr ps is = eprintf "[%s] vs. [%s]\n" (Source.debug_pats ps) (Source.debug_pseudos is) let pp_lab tag is = if false then let open Source in match is with | Label (_,_)::_ -> eprintf "*%s*\n" tag ; eprintf "%s" (dump_pseudos is) ; eprintf "------\n" ; () | _ -> () let rec find_pattern d tag pat instrs subs = if debug > 0 then begin eprintf "%s<%i>: " tag d ; pp_pat_instr pat instrs end ; let open Source in pp_lab (tag ^ "FIND") instrs ; match pat,instrs with | (pat,Nop::instrs) | (Nop::pat,instrs) -> find_pattern d tag pat instrs subs | [],Label(_,Nop)::[] -> Some ([],instrs,subs) | pat,Label(_,Nop)::[] -> find_pattern (d+1) tag pat [] subs | Symbolic s::pat,instrs -> begin match dig subs pat instrs with | None -> None | Some(stash,rem) -> find_pattern (d+1) "SYMB" pat rem (Code(s,stash)::subs) end | p::ps,i::is -> match_instruction subs p i >>> find_pattern (d+1) "REC" ps is >>> fun (is,rs,subs) -> Some (i::is,rs,subs) | [],rs -> Some([],rs,subs) | _,_ -> None let get_pattern_seq instrs = let rec aux instrs = pp_lab "AUX" instrs ; let rec find = function | [] -> begin match find_pattern 0 "EMPTY" [] instrs [] with | Some(is,[],[]) -> Some((is,[],[]),[]) | Some([],[Source.Label (lab,Source.Nop)],[]) -> Some ((instrs,[Target.Label(lab,Target.Nop)],[]),[]) | _ -> if C.verbose then eprintf "Unmatched instructions:\n%s" (Source.dump_pseudos instrs); None end | (p,conv)::ps -> match find_pattern 0 "LOC" p instrs [] with | None -> find ps | Some(is,rs,subs) -> match is,conv with | Source.Label(l,_)::_ as is,(Target.Instruction(_) as c)::cs -> Some((is,Target.Label(l,c)::cs,subs),rs) | _,_ -> Some((is,conv,subs),rs) in match find conversions with | None -> raise (Error "Cannot find conversion rule.") | Some(ins,[]) -> [ins] | Some(ins,rs) -> ins::(aux rs) in aux instrs let rec convert env instrs = let rec aux env l = match l with | [] -> [],env | (_src,tgt,subs)::ts -> let conv,env = List.fold_left (fun (cv,env) -> function | Source.Reg(s,c) -> let r,env = Env.get_register_from_reg env c in if debug > 1 then eprintf "From %s->%s we get %s->%s\n" s (Source.pp_reg c) s (Target.pp_reg r) ; (Target.Reg(s,r)::cv,env) | Source.Addr(s,a) -> let r,env = Env.get_register_from_addr env a in (Target.Reg(s,r)::cv,env) | Source.Cst(s,c) -> (Target.Cst(s,c)::cv,env) | Source.Lab(s,l) -> let lbl,env = Env.get_label env l in (Target.Lab(s,lbl)::cv,env) | Source.Code(s,c) -> let c,env = convert env c in (Target.Code(s,c)::cv,env) ) ([],env) subs in let flw,env = aux env ts in (tgt,(Env.get_lab_convs env)@conv)::flw,env in let chunks,env = aux env (get_pattern_seq instrs) in let chunks = List.map (fun (tgt,conv) -> Target.instanciate_with conv (Env.get_free_register env) tgt) chunks in let pseudo_p = List.flatten chunks in (pseudo_p,env) let reg_mapping = List.map (fun ((i,_,_),(b,_)) -> (i, (List.map (fun (sr,tr) -> (Source.pp_reg sr,Target.pp_reg tr)) b.Env.reg))) let addr_init = let open MiscParser in List.fold_left (fun acc ((i,_,_),(b,_)) -> acc@ (List.map (fun (sa,tr) -> (Location_reg(i,Target.pp_reg tr), (TestType.TyDef,ParsedConstant.nameToV sa))) b.Env.addr) ) [] let rec dump_map = let rec assocs i = function | [] -> "" | [sr,tr] -> (string_of_int i)^":"^tr^"="^sr | (sr,tr)::r -> (string_of_int i)^":"^tr^"="^sr^","^(assocs i r) in function | [] -> "" | [i,asc] -> assocs i asc | (i,asc)::r -> let s = assocs i asc in if String.compare s "" = 0 then dump_map r else s^","^(dump_map r) let conv_loc map = MiscParser.(function | Location_reg(i,r) -> let r' = try let asc = List.assoc i map in List.assoc r asc with Not_found -> let msg = sprintf "register %i:%s does not appear in code." i r in raise (Error msg) in Location_reg(i,r') | l -> l) let conv_rloc map = ConstrGen.map_rloc (conv_loc map) let translate name chin sres = let src = Source.Parser.parse chin sres in let open MiscParser in let prog = List.map (fun (i,p) -> let p,e = convert Env.init p in if debug > 1 then eprintf "Sub %s\n" (Env.pp_sub (fst e)) ; ((i,p),(i,e))) src.prog in let prog,convs = List.split prog in let map = reg_mapping convs in let init = addr_init convs @ List.fold_right (fun (l,r) k -> try let loc = conv_loc map l in (loc,r)::k with Error msg -> Warn.warn_always "File \"%s\": %s" name msg ; k) src.init [] in let map_lv_ll = ConstrGen.(function | LV(l,v) -> LV(conv_rloc map l,v) | LL(l1,l2) -> LL(conv_loc map l1,conv_loc map l2) | FF (_,None,_) as a -> a | FF (_,Some x,_) as a -> ignore (Constant.check_sym x) ; a) in let condition = ConstrGen.map_constr map_lv_ll src.condition and filter = Misc.app_opt (ConstrGen.map_prop map_lv_ll) src.filter in let locations = LocationsItem.map_locs (fun loc -> conv_loc map loc) src.locations in { info = (OutMapping.key,dump_map map)::src.info; init = init; prog = prog; filter = filter; condition = condition; locations = locations; extra_data = src.extra_data; } end herd-herdtools7-1ca343e/jingle/parseMap.mll000066400000000000000000000060451475314470400206750ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) { exception Error of string type func = | Appliable of string * string | Sequence of string list type t = { source : Archs.t; target : Archs.t; funcs : (string * func) list; conversions : (string * string) list } } let space = [' ' '\t' '\r'] let blank = (space | '\n') let archname = ([ '0'-'9' 'a'-'z' 'A'-'Z'])* let arrow = ("->" | "maps" space "to") let colon = [':'] rule main = parse | space* (archname as src) space+ "to" space+ (archname as tgt) space* '\n' blank* { let (l, f) = conv [] [] lexbuf in let (src,tgt) = match Archs.parse src,Archs.parse tgt with | Some s,Some t -> s,t | _ -> raise (Error "Source or target architecture unrecognized.") in { source = src; target = tgt; funcs = List.rev f; conversions = List.rev l } } | "" {raise (Error "Source or target architecture unspecified.")} and conv l f = parse | eof {(l,f)} | '"' ([^'"']* as left) '"' blank* arrow blank* '"' ([^'"']* as right) '"' blank* { conv ((String.trim left, String.trim right)::l) f lexbuf } | '"' ([^'"']* as func) '"' blank* colon blank* '"' ([^'"']* as left) '"' blank* arrow blank* '"' ([^'"']* as right) '"' blank* { conv l ((String.trim func, Appliable(String.trim left, String.trim right))::f) lexbuf } | '"' ([^'"']* as func) '"' blank* colon blank* '"' (([^'"']* blank* '|' blank*)* [^'"']* as seq) '"' blank* { conv l ((String.trim func, Sequence(List.map (fun s -> String.trim s) (Misc.split_on_char '|' seq)))::f) lexbuf } | ("#"|"//") [^'\n']* '\n' { conv l f lexbuf } | "" { let last = match l with | [] -> "*start*" | (left,right)::_ -> Printf.sprintf "\"%s\" -> \"%s\"" left right in let msg = Printf.sprintf "Bad syntax in conversion rule, after %s" last in raise (Error msg)} { let parse chin = main (Lexing.from_channel chin) } herd-herdtools7-1ca343e/lib/000077500000000000000000000000001475314470400157105ustar00rootroot00000000000000herd-herdtools7-1ca343e/lib/AArch64ASLValue.ml000066400000000000000000000035111475314470400207270ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2021-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) module Make (C : sig val is_morello : bool end) : Value.AArch64ASL = struct if C.is_morello then Warn.fatal "-variant asl and -variant morello are not conmpatible" ; module AArch64I = AArch64Instr.Make (C) module ASLScalar = struct include ASLScalar let printable = function | S_BitVector bv -> S_Int (Asllib.Bitvector.printable bv) | S_Bool b -> S_Int (if b then Z.one else Z.zero) | S_Int i -> S_Int (printable_z i) | S_Label _ as s -> s end module AArch64Cst = SymbConstant.Make (ASLScalar) (AArch64PteVal) (AArch64I) module AArch64Op = AArch64Op.Make(ASLScalar)(ASLOp) include SymbValue.Make (AArch64Cst) (AArch64Op) end herd-herdtools7-1ca343e/lib/AArch64Base.ml000066400000000000000000003433551475314470400202020ustar00rootroot00000000000000(****************************************************************************) (* the diy toolsuite *) (* *) (* Jade Alglave, University College London, UK. *) (* Luc Maranget, INRIA Paris-Rocquencourt, France. *) (* *) (* Copyright 2015-present Institut National de Recherche en Informatique et *) (* en Automatique, ARM Ltd and the authors. All rights reserved. *) (* *) (* This software is governed by the CeCILL-B license under French law and *) (* abiding by the rules of distribution of free software. You can use, *) (* modify and/ or redistribute the software under the terms of the CeCILL-B *) (* license as circulated by CEA, CNRS and INRIA at the following URL *) (* "http://www.cecill.info". We also give a copy in LICENSE.txt. *) (****************************************************************************) (** Simplified Arch64, for generators *) open Printf let arch = Archs.aarch64 let endian = Endian.Little let base_type = CType.Base "int" (*************) (* Registers *) (*************) type gpr = | R0 | R1 | R2 | R3 | R4 | R5 | R6 | R7 | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15 | R16 | R17 | R18 | R19 | R20 | R21 | R22 | R23 | R24 | R25 | R26 | R27 | R28 | R29 | R30 type vec_reg = | V0 | V1 | V2 | V3 | V4 | V5 | V6 | V7 | V8 | V9 | V10 | V11 | V12 | V13 | V14 | V15 | V16 | V17 | V18 | V19 | V20 | V21 | V22 | V23 | V24 | V25 | V26 | V27 | V28 | V29 | V30 | V31 type pred_reg = | P0 | P1 | P2 | P3 | P4 | P5 | P6 | P7 | P8 | P9 | P10 | P11 | P12 | P13 | P14 | P15 type pred_mode = | Zero | Merge let arrange_specifier = [ (1,64),".1D" ; (1,128),".1Q" ; (2,16),".2H" ; (2,32),".2S" ; (2,64),".2D"; (4,8),".4B" ; (4,16),".4H" ; (4,32),".4S"; (8,8),".8B" ; (8,16),".8H" ; (16, 8),".16B"; (0,8),".B" ; (0,16),".H" ; (0,32),".S" ; (0,64),".D"; ] let sve_arrange_specifier = [ 0,"";8,".B"; 16,".H"; 32,".S"; 64,".D"; 128,".Q"; ] let sve_pred_modifier = [ Zero,"/Z"; Merge,"/M"; ] type za_direction = | Vertical | Horizontal let za_arrange_specifier = [ 8,".B"; 16,".H"; 32,".S"; 64,".D"; 128,".Q"; ] let za_direction_specifier = [ Vertical,"V"; Horizontal,"H"; ] (********************) (* System registers *) (* (Some of...) *) (********************) type sysreg = CTR_EL0 | DCIZ_EL0 | MDCCSR_EL0 | DBGDTR_EL0 | DBGDTRRX_EL0 | DBGDTRTX_EL0 | ELR_EL1 | ESR_EL1 | SYS_NZCV | TFSR_ELx | VNCR_EL2 let sysregs = [ CTR_EL0, "CTR_EL0"; DCIZ_EL0, "DCIZ_EL0"; MDCCSR_EL0, "MDCCSR_EL0"; DBGDTR_EL0, "DBGDTR_EL0"; DBGDTRRX_EL0, "DBGDTRRX_EL0"; DBGDTRTX_EL0, "DBGDTRTX_EL0"; ELR_EL1, "ELR_EL1"; ESR_EL1, "ESR_EL1"; SYS_NZCV, "NZCV"; TFSR_ELx, "TFSR_ELx"; VNCR_EL2, "VNCR_EL2"; ] let sysregs_map = [ VNCR_EL2, 0xB0; ESR_EL1, 0x138; ELR_EL1, 0x230; ] let sysreg_nv2off sreg = List.assoc_opt sreg sysregs_map type reg = | ZR | Ireg of gpr | Tag of gpr | Vreg of (vec_reg * (int * int)) | SIMDreg of vec_reg | Zreg of (vec_reg * int) | Preg of (pred_reg * int) | PMreg of (pred_reg * pred_mode) | ZAreg of (int * za_direction option * int) | Symbolic_reg of string | Internal of int | NZCV | SM (* PSTATE.SM *) | ZA (* PSTATE.ZA *) | SP | PC | ResAddr | SysReg of sysreg (*************) (* Utilities *) (*************) type variant = V32 | V64 | V128 type rev_variant = RV16 of variant | RV32 | RV64 of variant let memo_of_rev = function | RV16 _ -> "REV16" | RV32 -> "REV32" | RV64 _ -> "REV" let variant_of_rev = function | RV16 v|RV64 v -> v | RV32 -> V64 type 'k kr = K of 'k | RV of variant * reg let k0 = K 0 let pp_label = let open BranchTarget in function | Lbl lbl -> Label.pp lbl | Offset o -> "." ^ BranchTarget.pp_offset o open PPMode let pp_hash m = match m with | Ascii | Dot -> "#" | Latex -> "\\#" | DotFig -> "\\\\#" let pp_k m v = pp_hash m ^ string_of_int v (* * The boolean `compat` specifies backward comparibility. * Backward compatibility is important for preserving hashes. *) type 'k basic_pp = { compat : bool; pp_k : 'k -> string; zerop : 'k -> bool; onep : 'k -> bool; k0 : 'k kr } let gprs = [ R0 ; R1 ; R2 ; R3 ; R4 ; R5 ; R6 ; R7 ; R8 ; R9 ; R10; R11 ; R12; R13; R14; R15 ; R16; R17; R18; R19 ; R20; R21; R22; R23 ; R24; R25; R26; R27 ; R28; R29; R30; ] let vec_regs = [ V0 ; V1 ; V2 ; V3 ; V4 ; V5 ; V6 ; V7 ; V8 ; V9 ; V10; V11; V12; V13; V14; V15; V16; V17; V18; V19; V20; V21; V22; V23; V24; V25; V26; V27; V28; V29; V30; V31; ] let vregs = List.map (fun v -> Vreg (v,(4,32))) vec_regs let zregs = List.map (fun z -> Zreg (z,32)) vec_regs let pred_regs = [ P0 ; P1; P2 ; P3; P4 ; P5; P6 ; P7; P8 ; P9; P10; P11; P12; P13; P14; P15; ] let pregs = List.map (fun p -> Preg (p,32)) pred_regs let zaslices = let tiles = List.init 4 (fun tile -> ZAreg (tile,None,32)) in let slices = List.init 4 Fun.id in List.concat (List.map (fun s -> List.map(fun r -> s,r) tiles ) slices) let linkreg = Ireg R30 let elr_el1 = SysReg ELR_EL1 let tfsr = SysReg TFSR_ELx let cgprs = [ R0,"C0" ; R1,"C1" ; R2,"C2" ; R3,"C3" ; R4,"C4" ; R5,"C5" ; R6,"C6" ; R7,"C7" ; R8,"C8" ; R9,"C9" ; R10,"C10" ; R11,"C11" ; R12,"C12" ; R13,"C13" ; R14,"C14" ; R15,"C15" ; R16,"C16" ; R17,"C17" ; R18,"C18" ; R19,"C19" ; R20,"C20" ; R21,"C21" ; R22,"C22" ; R23,"C23" ; R24,"C24" ; R25,"C25" ; R26,"C26" ; R27,"C27" ; R28,"C28" ; R29,"C29" ; R30,"C30" ; ] let cregs = (ZR,"CZR")::List.map (fun (r,s) -> Ireg r,s) cgprs let xgprs = [ R0,"X0" ; R1,"X1" ; R2,"X2" ; R3,"X3" ; R4,"X4" ; R5,"X5" ; R6,"X6" ; R7,"X7" ; R8,"X8" ; R9,"X9" ; R10,"X10" ; R11,"X11" ; R12,"X12" ; R13,"X13" ; R14,"X14" ; R15,"X15" ; R16,"X16" ; R17,"X17" ; R18,"X18" ; R19,"X19" ; R20,"X20" ; R21,"X21" ; R22,"X22" ; R23,"X23" ; R24,"X24" ; R25,"X25" ; R26,"X26" ; R27,"X27" ; R28,"X28" ; R29,"X29" ; R30,"X30" ; ] let xregs = (ZR,"XZR")::(SP,"SP")::List.map (fun (r,s) -> Ireg r,s) xgprs let regs = xregs let wgprs = [ R0,"W0" ; R1,"W1" ; R2,"W2" ; R3,"W3" ; R4,"W4" ; R5,"W5" ; R6,"W6" ; R7,"W7" ; R8,"W8" ; R9,"W9" ; R10,"W10" ; R11,"W11" ; R12,"W12" ; R13,"W13" ; R14,"W14" ; R15,"W15" ; R16,"W16" ; R17,"W17" ; R18,"W18" ; R19,"W19" ; R20,"W20" ; R21,"W21" ; R22,"W22" ; R23,"W23" ; R24,"W24" ; R25,"W25" ; R26,"W26" ; R27,"W27" ; R28,"W28" ; R29,"W29" ; R30,"W30" ; ] let wregs = (ZR,"WZR")::List.map (fun (r,s) -> Ireg r,s) wgprs let vvrs = [ V0,"V0" ; V1,"V1" ; V2,"V2" ; V3,"V3" ; V4,"V4" ; V5,"V5" ; V6,"V6" ; V7,"V7" ; V8,"V8" ; V9,"V9" ; V10,"V10" ; V11,"V11" ; V12,"V12" ; V13,"V13" ; V14,"V14" ; V15,"V15" ; V16,"V16" ; V17,"V17" ; V18,"V18" ; V19,"V19" ; V20,"V20" ; V21,"V21" ; V22,"V22" ; V23,"V23" ; V24,"V24" ; V25,"V25" ; V26,"V26" ; V27,"V27" ; V28,"V28" ; V29,"V29" ; V30,"V30" ; V31, "V31"; ] let bvrs = [ V0,"B0" ; V1,"B1" ; V2,"B2" ; V3,"B3" ; V4,"B4" ; V5,"B5" ; V6,"B6" ; V7,"B7" ; V8,"B8" ; V9,"B9" ; V10,"B10" ; V11,"B11" ; V12,"B12" ; V13,"B13" ; V14,"B14" ; V15,"B15" ; V16,"B16" ; V17,"B17" ; V18,"B18" ; V19,"B19" ; V20,"B20" ; V21,"B21" ; V22,"B22" ; V23,"B23" ; V24,"B24" ; V25,"B25" ; V26,"B26" ; V27,"B27" ; V28,"B28" ; V29,"B29" ; V30,"B30" ; V31, "B31"; ] let hvrs = [ V0,"H0" ; V1,"H1" ; V2,"H2" ; V3,"H3" ; V4,"H4" ; V5,"H5" ; V6,"H6" ; V7,"H7" ; V8,"H8" ; V9,"H9" ; V10,"H10" ; V11,"H11" ; V12,"H12" ; V13,"H13" ; V14,"H14" ; V15,"H15" ; V16,"H16" ; V17,"H17" ; V18,"H18" ; V19,"H19" ; V20,"H20" ; V21,"H21" ; V22,"H22" ; V23,"H23" ; V24,"H24" ; V25,"H25" ; V26,"H26" ; V27,"H27" ; V28,"H28" ; V29,"H29" ; V30,"H30" ; V31, "H31"; ] let svrs = [ V0,"S0" ; V1,"S1" ; V2,"S2" ; V3,"S3" ; V4,"S4" ; V5,"S5" ; V6,"S6" ; V7,"S7" ; V8,"S8" ; V9,"S9" ; V10,"S10" ; V11,"S11" ; V12,"S12" ; V13,"S13" ; V14,"S14" ; V15,"S15" ; V16,"S16" ; V17,"S17" ; V18,"S18" ; V19,"S19" ; V20,"S20" ; V21,"S21" ; V22,"S22" ; V23,"S23" ; V24,"S24" ; V25,"S25" ; V26,"S26" ; V27,"S27" ; V28,"S28" ; V29,"S29" ; V30,"S30" ; V31, "S31"; ] let dvrs = [ V0,"D0" ; V1,"D1" ; V2,"D2" ; V3,"D3" ; V4,"D4" ; V5,"D5" ; V6,"D6" ; V7,"D7" ; V8,"D8" ; V9,"D9" ; V10,"D10" ; V11,"D11" ; V12,"D12" ; V13,"D13" ; V14,"D14" ; V15,"D15" ; V16,"D16" ; V17,"D17" ; V18,"D18" ; V19,"D19" ; V20,"D20" ; V21,"D21" ; V22,"D22" ; V23,"D23" ; V24,"D24" ; V25,"D25" ; V26,"D26" ; V27,"D27" ; V28,"D28" ; V29,"D29" ; V30,"D30" ; V31, "D31"; ] let qvrs = [ V0,"Q0" ; V1,"Q1" ; V2,"Q2" ; V3,"Q3" ; V4,"Q4" ; V5,"Q5" ; V6,"Q6" ; V7,"Q7" ; V8,"Q8" ; V9,"Q9" ; V10,"Q10" ; V11,"Q11" ; V12,"Q12" ; V13,"Q13" ; V14,"Q14" ; V15,"Q15" ; V16,"Q16" ; V17,"Q17" ; V18,"Q18" ; V19,"Q19" ; V20,"Q20" ; V21,"Q21" ; V22,"Q22" ; V23,"Q23" ; V24,"Q24" ; V25,"Q25" ; V26,"Q26" ; V27,"Q27" ; V28,"Q28" ; V29,"Q29" ; V30,"Q30" ; V31, "Q31"; ] let zvrs = [ V0 ,"Z0"; V1 ,"Z1"; V2 ,"Z2"; V3 ,"Z3"; V4 ,"Z4"; V5 ,"Z5"; V6 ,"Z6"; V7 ,"Z7"; V8 ,"Z8"; V9 ,"Z9"; V10,"Z10"; V11,"Z11"; V12,"Z12"; V13,"Z13"; V14,"Z14"; V15,"Z15"; V16,"Z16"; V17,"Z17"; V18,"Z18"; V19,"Z19"; V20,"Z20"; V21,"Z21"; V22,"Z22"; V23,"Z23"; V24,"Z24"; V25,"Z25"; V26,"Z26"; V27,"Z27"; V28,"Z28"; V29,"Z29"; V30,"Z30"; V31,"Z31"; ] let pvrs = [ P0 ,"P0"; P1 ,"P1"; P2 ,"P2"; P3 ,"P3"; P4 ,"P4"; P5 ,"P5"; P6 ,"P6"; P7 ,"P7"; P8 ,"P8"; P9 ,"P9"; P10,"P10"; P11,"P11"; P12,"P12"; P13,"P13"; P14,"P14"; P15,"P15"; ] let zavrs = [ ZA ,"ZA0"; ZA ,"ZA1"; ZA ,"ZA2"; ZA ,"ZA3"; ZA ,"ZA4"; ZA ,"ZA5"; ZA ,"ZA6"; ZA ,"ZA7"; ZA ,"ZA8"; ZA ,"ZA9"; ZA ,"ZA10"; ZA ,"ZA11"; ZA ,"ZA12"; ZA ,"ZA13"; ZA ,"ZA14"; ZA ,"ZA15"; ] let simd_regs = let rs = bvrs @ hvrs @ svrs @ dvrs @ qvrs in List.map (fun (r,s) -> s,SIMDreg r) rs let parse_list rs = List.map (fun (r,s) -> s,r) rs let parse_some plist s = try let plist = List.map (fun (n,r) -> Misc.uppercase n,r) plist in let s = Misc.uppercase s in Some (List.assoc s plist) with Not_found -> None let make_parser rs = let plist = parse_list rs in parse_some plist let parse_sysreg = make_parser sysregs let parse_creg = make_parser cregs let parse_xreg = let plist = ("LR",Ireg R30)::parse_list regs in parse_some plist let parse_wreg = make_parser wregs let parse_vreg = let vplist = parse_list vvrs and arplist = parse_list arrange_specifier in fun s -> try let (g1, g2) = ignore (Str.search_forward (Str.regexp "\\(V[0-9]+\\)\\(\\.[0-9]*[B,D,Q,H,S]\\)") (Misc.uppercase s) 0); (Str.matched_group 1 s, Str.matched_group 2 s); in Some (Vreg (List.assoc g1 vplist, List.assoc g2 arplist)) with Not_found -> None let parse_simd_reg = parse_some simd_regs let parse_zreg = let zplist = parse_list zvrs and arplist = parse_list sve_arrange_specifier in fun s -> try let (g1, g2) = ignore (Str.search_forward (Str.regexp "\\(Z[0-9]+\\)\\(\\.[B,D,Q,H,S]\\)") (Misc.uppercase s) 0); (Str.matched_group 1 s, Str.matched_group 2 s); in Some (Zreg (List.assoc g1 zplist, List.assoc g2 arplist)) with Not_found -> None let parse_preg = let pplist = parse_list pvrs and splist = parse_list sve_arrange_specifier in fun s -> try let (g1, g2) = ignore (Str.search_forward (Str.regexp "\\(P[0-9]+\\)\\(\\.[B,D,Q,H,S]\\)?") (Misc.uppercase s) 0); let suffix = try Str.matched_group 2 s with Not_found -> "" in (Str.matched_group 1 s, suffix); in Some (Preg (List.assoc g1 pplist, List.assoc g2 splist)) with Not_found -> None let parse_pmreg = let pplist = parse_list pvrs and mplist = parse_list sve_pred_modifier in fun s -> try let (g1, g2) = ignore (Str.search_forward (Str.regexp "\\(P[0-9]+\\)\\(\\/[Z,M]\\)") (Misc.uppercase s) 0); (Str.matched_group 1 s, Str.matched_group 2 s); in Some (PMreg (List.assoc g1 pplist, List.assoc g2 mplist)) with Not_found -> None let parse_zareg = let arplist = parse_list za_arrange_specifier and dirplist = parse_list za_direction_specifier in fun s -> try let (g1,g2,g3) = ignore (Str.search_forward (Str.regexp "ZA\\([0-9]+\\)\\([V,H]\\)?\\(\\.[B,D,Q,H,S]\\)") (Misc.uppercase s) 0); let dir = try Some (Str.matched_group 2 s) with Not_found -> None in (Str.matched_group 1 s, dir, Str.matched_group 3 s); in let dir = match g2 with | Some d -> Some (List.assoc d dirplist) | None -> None in Some (ZAreg (int_of_string g1, dir, List.assoc g3 arplist)) with Not_found -> None let parse_reg s = match parse_vreg s with | Some v -> Some v | None -> begin match parse_xreg s with | Some v -> Some v | None -> Option.map (fun r -> (SysReg r)) (parse_sysreg s) end let pp_sysreg r = try List.assoc r sysregs with Not_found -> assert false let pp_creg r = match r with | Symbolic_reg r -> "C%" ^ r | Internal i -> Printf.sprintf "i%i" i | NZCV -> "NZCV" | ResAddr -> "Res" | _ -> try List.assoc r cregs with Not_found -> assert false let pp_xreg r = match r with | Symbolic_reg r -> "X%" ^ r | Internal i -> Printf.sprintf "i%i" i | NZCV -> "NZCV" | ResAddr -> "Res" | PC -> "PC" | SM -> "PSTATE.SM" | ZA -> "PSTATE.ZA" | SysReg sreg -> pp_sysreg sreg | _ -> try List.assoc r regs with Not_found -> assert false let pp_simd_vector_reg r = match r with | Vreg (r',s) -> (try List.assoc r' vvrs with Not_found -> assert false) ^ (try List.assoc s arrange_specifier with Not_found -> assert false) | _ -> assert false let pp_simd_scalar_reg rl r = match r with | SIMDreg r -> (try List.assoc r rl with Not_found -> assert false) | _ -> assert false let pp_sm = function | SM -> "SM" | ZA -> "ZA" | _ -> assert false let pp_sve_arrange_specifier s = try List.assoc s sve_arrange_specifier with Not_found -> assert false let pp_zreg r = match r with | Zreg (r',s) -> (try List.assoc r' zvrs with Not_found -> assert false) ^ pp_sve_arrange_specifier s | _ -> assert false let pp_preg_simple r = match r with | Preg (r',_) | PMreg (r',_) -> (try List.assoc r' pvrs with Not_found -> assert false) | _ -> assert false let pp_sve_pred_modifier m = try List.assoc m sve_pred_modifier with Not_found -> assert false let pp_preg r = match r with | Preg (r',s) -> (try List.assoc r' pvrs with Not_found -> assert false) ^ pp_sve_arrange_specifier s | PMreg (r',m) -> (try List.assoc r' pvrs with Not_found -> assert false) ^ pp_sve_pred_modifier m | _ -> assert false let pp_reg r = match r with | Vreg _ -> pp_simd_vector_reg r | SIMDreg _ -> pp_simd_scalar_reg vvrs r | Zreg _ -> pp_zreg r | Preg _ | PMreg _ -> pp_preg r | ZAreg _ -> "ZA" | _ -> pp_xreg r let pp_i n = match n with | 1 -> "instr:\"NOP\"" | 0 -> "instr:\"B .+12\"" | _ -> Warn.fatal "instruction currently not supported" let pp_wreg r = match r with | Symbolic_reg r -> "W%" ^ r | Internal i -> Printf.sprintf "i%i" i | NZCV -> "NZCV" | ResAddr -> "Res" | _ -> try List.assoc r wregs with Not_found -> assert false let pp_vreg v r = match v with | V32 -> pp_wreg r | V64 -> pp_xreg r | V128 -> pp_creg r let pp_za_arrange_specifier s = try List.assoc s za_arrange_specifier with Not_found -> assert false let pp_za_dirrection_specifier s = try List.assoc s za_direction_specifier with Not_found -> assert false let pp_zareg r = match r with | ZAreg (tile,dir,s) -> let dir = match dir with | Some d -> pp_za_dirrection_specifier d | None -> "" in "ZA" ^ (string_of_int tile) ^ dir ^ pp_za_arrange_specifier s | _ -> assert false let reg_compare r1 r2 = let strip_reg r = match r with | Vreg (v,_) -> SIMDreg v | Zreg (v,_) -> SIMDreg v | Preg (v,_) -> Preg (v,0) | PMreg (v,_) -> Preg (v,0) | ZAreg _ -> ZAreg (0,None,0) | _ -> r in compare (strip_reg r1) (strip_reg r2) let symb_reg_name = function | Symbolic_reg r -> Some r | _ -> None let symb_reg r = Symbolic_reg r let type_reg r = let open CType in match r with | Vreg (_,(n_elt,sz)) -> Array (TestType.tr_nbits sz,n_elt) | _ -> Base "int" (************) (* Barriers *) (************) type mBReqDomain = NSH | ISH | OSH | SY let mBReqDomain_list = [SY; OSH; ISH; NSH] let fold_domain f k = let k = f SY k in let k = f OSH k in let k = f ISH k in let k = f NSH k in k let pp_domain = function | NSH -> "NSH" | ISH -> "ISH" | OSH -> "OSH" | SY -> "SY" type mBReqTypes = LD | ST | FULL let fold_type f k = let k = f FULL k in let k = f ST k in let k = f LD k in k let pp_type = function | LD -> "LD" | ST -> "ST" | FULL -> "" type barrier = | DMB of mBReqDomain*mBReqTypes | DSB of mBReqDomain*mBReqTypes | ISB type syncType = | DC_CVAU | IC_IVAU type dirloc = | Next | Prev let fold_barrier_option kvm more f k = if more then fold_domain (fun d k -> fold_type (fun t k -> f d t k) k) k else let k = if kvm then fold_type (fun t k -> f ISH t k) k else k in fold_type (fun t k -> f SY t k) k let do_fold_dmb_dsb kvm more f k = fold_barrier_option kvm more (fun d t k -> f (DMB (d,t)) (f (DSB (d,t)) k)) k let fold_barrier kvm more f k = let k = do_fold_dmb_dsb kvm more f k in let k = f ISB k in k let pp_option d t = match d,t with | SY,FULL -> pp_domain d | SY,(LD|ST) -> pp_type t | _,_ -> pp_domain d ^ pp_type t let do_pp_barrier tag b = match b with | DMB (d,t) -> "DMB" ^ tag ^ pp_option d t | DSB (d,t) -> "DSB" ^ tag ^ pp_option d t | ISB -> "ISB" let pp_barrier b = do_pp_barrier " " b let pp_barrier_dot b = do_pp_barrier "." b let barrier_compare = compare (*********************) (* Cache maintenance *) (*********************) module IC = struct type funct = I let pp_funct = function I -> "I" let fold_funct f k = f I k type typ = ALL | VA let pp_typ = function | ALL -> "ALL" | VA -> "VA" let fold_typ f k = k |> f ALL |> f VA type point = U let pp_point = function U -> "U" let fold_point f k = f U k type domain = IS | NO let pp_domain = function IS -> "IS" | NO -> "" let fold_domain f k = k |> f IS |> f NO type op = { funct:funct; typ:typ; point:point; domain:domain; } let ivau = { funct=I; typ=VA; point=U; domain=NO; } let iallu = { funct=I; typ=ALL; point=U; domain=NO; } let fold_op f k = fold_funct (fun funct k -> fold_typ (fun typ k -> fold_point (fun point k -> fold_domain (fun domain k -> f {funct; typ; point; domain; } k) k) k) k) k let pp_op op = pp_funct op.funct ^ pp_typ op.typ ^ pp_point op.point ^ pp_domain op.domain let do_pp tag op = "IC" ^ tag ^ (pp_op op) let pp = do_pp " " let pp_dot = do_pp "." let all op = match op.typ with | VA -> false | ALL -> true let equal = ( = ) end module DC = struct type funct = I | C | CI | Z let pp_funct = function | I -> "I" | C -> "C" | CI -> "CI" | Z -> "Z" let fold_funct f k = k |> f I |> f C |> f CI |> f Z type typ = VA | SW let pp_typ = function VA -> "VA" | SW -> "SW" let fold_typ f k = k |> f VA |> f SW type point = CO | U let pp_point = function CO -> "C" | U -> "U" let fold_point f k = k |> f CO |> f U type op = { funct:funct; typ:typ; point:point; } let cvau = { funct=C; typ=VA; point=U; } let civac = { funct=CI; typ=VA; point=CO; } let pp_op op = pp_funct op.funct ^ pp_typ op.typ ^ pp_point op.point let do_pp tag op = "DC" ^ tag ^ (pp_op op) let pp = do_pp " " let pp_dot = do_pp "." let sw op = match op.typ with | SW -> true | _ -> false let ci op = match op.funct with | CI -> true | _ -> false let c op = match op.funct with | C -> true | _ -> false let i op = match op.funct with | I -> true | _ -> false let fold_op f k = fold_funct (fun funct k -> fold_typ (fun typ k -> fold_point (fun point k -> f {funct; typ; point; } k) k) k) k let equal = ( = ) end type level = |E0 |E1 |E2 |E3 let levels = [E0;E1;E2;E3;] let pp_level = function | E0 -> "E0" | E1 -> "E1" | E2 -> "E2" | E3 -> "E3" let fold_EL f k = let k = f E0 k in let k = f E1 k in let k = f E2 k in let k = f E3 k in k module TLBI = struct type typ = | ALL (*all translations at level *) | VMALL (*all stage 1 translations, current VMID *) | VMALLS12 (*all stage 1 & 2 translations, current VMID *) | ASID (*translations matching ASID *) | VA (*translations matching VA and ASID *) | VAL (*last-level translations matching VA and ASID *) | VAA (*translations matching VA, all ASIDs *) | VAAL (*last-level translations matching VA, all ASIDs *) | IPAS2 (*stage 2 translations matching IPA, current VMID *) | IPAS2L (*last-level stage 2 translations matching IPA, current VMID *) let pp_typ = function | ALL -> "ALL" | VMALL -> "VMALL" | VMALLS12 -> "VMALLS12" | ASID -> "ASID" | VA -> "VA" | VAL -> "VAL" | VAA -> "VAA" | VAAL -> "VAAL" | IPAS2 -> "IPAS2" | IPAS2L -> "IPAS2L" let fold_typ f k = let k = f ALL k in let k = f VMALL k in let k = f VMALLS12 k in let k = f ASID k in let k = f VA k in let k = f VAL k in let k = f VAA k in let k = f IPAS2 k in let k = f IPAS2L k in k type domain = | IS | No let pp_domain = function | IS -> "IS" | No -> "" let fold_domain f k = let k = f IS k in let k = f No k in k type op = { typ:typ; level:level; domain:domain; nXS:bool } let alle1is = { typ=ALL; level=E1; domain=IS; nXS=false; } let alle2is = { typ=ALL; level=E2; domain=IS; nXS=false; } let level_list = [ E0; E1; E2; E3 ] let typ_list = [ ALL; VMALL; VMALLS12; ASID; VA; VAL; VAA; VAAL; IPAS2; IPAS2L ] let domain_list = [ IS; No ] let rec fold_from_list xs f k = match xs with | [] -> k | x::xs -> fold_from_list xs f (f x k) let full_fold_op f k = fold_from_list typ_list (fun typ k -> fold_from_list level_list (fun level k -> fold_from_list domain_list (fun domain k -> fold_from_list [ false; true ] (fun nXS k -> f {typ; level; domain; nXS; } k ) k) k) k) k let fold_op f k = let k = f {typ=VMALL; level=E1; domain=IS; nXS=false } k in f {typ=VAA; level=E1; domain=IS; nXS=false } k let pp_op { typ; level; domain; nXS; } = sprintf "%s%s%s%s" (pp_typ typ) (pp_level level) (pp_domain domain) (if nXS then "NXS" else "") let short_pp_op = function | {typ=VMALL; level=E1; domain=IS; nXS=false } -> "VMALL" | {typ=VAA; level=E1; domain=IS; nXS=false } -> "" | op -> pp_op op let is_at_level lvl op = op.level = lvl let inv_all op = match op.typ with | ALL | VMALL | VMALLS12 -> true | ASID | VA | VAL | VAA | VAAL | IPAS2 | IPAS2L -> false let sets = [("TLBIIS", fun op->op.domain=IS); ("TLBInXS", (fun op -> op.nXS))] end (****************) (* Instructions *) (****************) type lbl = BranchTarget.t (* At type of writing, condition codes are specified in the ARM ARM, section C1.2.4, table C1-1 *) type condition = | EQ (** Equal *) | NE (** Non Equal *) | CS (** Carry Set or unsigned higher or same, or HS *) | CC (** Carry Clear or unsigned lower, or LO *) | MI (** Negative, MInus *) | PL (** Positive or zero, PLus *) | VS (** V Set, signed overflow *) | VC (** V Clear, no signed overflow *) | HI (** Unsigned HIgher *) | LS (** Unsigned Lower or Same *) | GE (** Signed Greater or Equal *) | LT (** Signed Less Than *) | GT (** Signed Greater Than *) | LE (** Signed Less or Equal *) | AL (** Always executed *) (* | NV (** Always executed *) *) let inverse_cond = function | NE -> EQ | EQ -> NE | LE -> GT | LT -> GE | GE -> GT | GT -> LE | CS -> CC | CC -> CS | MI -> PL | PL -> MI | VS -> VC | VC -> VS | HI -> LS | LS -> HI | AL -> AL (* Pattern specifier for scalable vector instructions *) type pattern = | POW2 | VL1 | VL2 | VL3 | VL4 | VL5 | VL6 | VL7 | VL8 | VL16 | VL32 | VL64 | VL128 | VL256 | MUL4 | MUL3 | ALL type cnt_inc_op = CNT | INC type op = | ADD | ADDS | SUB | SUBS | AND | ANDS | ORR | ORN | EOR | EON | ASR | LSR | LSL | ROR | BICS | BIC type gc = CFHI | GCFLGS | GCPERM | GCSEAL | GCTAG | GCTYPE | GCVALUE type sc = CLRPERM | CTHI | SCFLGS | SCTAG | SCVALUE type simd_variant = VSIMD8 | VSIMD16 | VSIMD32 | VSIMD64 | VSIMD128 type cnt_inc_op_variant = cnt_inc_op * simd_variant type adda_op_variant = za_direction module Ext = struct (* Arguments of extended ADD and SUB operations *) type op = ADD|ADDS|SUB|SUBS let pp_op = function | ADD -> "ADD" | ADDS -> "ADDS" | SUB -> "SUB" | SUBS -> "SUBS" type sext = | UXTB | UXTH | UXTW | UXTX | SXTB | SXTH | SXTW | SXTX let v2sext = function | V32 -> SXTW | V64 -> SXTX | V128 -> assert false let no_ext = UXTX,None type 'k ext = sext * 'k option let pp_sext = function | UXTB -> "UXTB" | UXTH -> "UXTH" | UXTW -> "UXTW" | UXTX -> "UXTX" | SXTB -> "SXTB" | SXTH -> "SXTH" | SXTW -> "SXTW" | SXTX -> "SXTX" let pp_ext m (e,ko) = sprintf "%s%s" (pp_sext e) (match ko with None -> "" | Some k -> " "^m.pp_k k) end type idx_mode = Idx | PreIdx | PostIdx type 'k idx = 'k * idx_mode module MemExt = struct (* Extensions for memory accesses *) (*********************) (* Register argument *) (*********************) type rext = | UXTW | LSL | SXTW | SXTX let v2sext = function | V32 -> SXTW | V64|V128 -> LSL let pp_sext = function | UXTW ->"UXTW" | LSL ->"LSL" | SXTW ->"SXTW" | SXTX ->"SXTX" type 'k ext = | Imm of 'k idx | Reg of variant * reg * rext * 'k | ZReg of reg * rext * 'k let v2idx_reg v r = match v with | V32 -> Reg (v,r,SXTW,0) | V64 -> Reg (v,r,LSL,0) | _ -> assert false let k2idx k = Imm (k,Idx) let zero = k2idx 0 end module OpExt = struct (* Third argumen tabnd extension of operations *) type 'k shift = | LSL of 'k | LSR of 'k | ASR of 'k | ROR of 'k let no_shift = LSL 0 let map_shift f = function | LSL k -> LSL (f k) | LSR k -> LSR (f k) | ASR k -> ASR (f k) | ROR k -> ROR (f k) let is_no_shift = function | LSL 0 | LSR 0 | ASR 0 | ROR 0 -> true | LSL _ | LSR _ | ASR _ | ROR _ -> false let pp_shift m = function | LSL k | LSR k | ASR k | ROR k when m.zerop k -> "" | LSL k -> sprintf ",LSL %s" (m.pp_k k) | LSR k -> sprintf ",LSR %s" (m.pp_k k) | ASR k -> sprintf ",ASR %s" (m.pp_k k) | ROR k -> sprintf ",ROR %s" (m.pp_k k) type 'k ext = | Imm of 'k * 'k (* second 'k is (left) shift *) | Reg of reg * 'k shift let zero = Imm (0,0) let pp_ext m v = function | Imm (k,s) when m.zerop s -> m.pp_k k | Imm (k,s) -> sprintf "%s,LSL %s" (m.pp_k k) (m.pp_k s) | Reg (r,s) -> sprintf "%s%s" (pp_vreg v r) (pp_shift m s) end module MOPLExt = struct type s = Signed|Unsigned type op = ADD | SUB type sop = s * op let memo sop = match sop with | Signed,ADD -> "SMADDL" | Signed,SUB -> "SMSUBL" | Unsigned,ADD -> "UMADDL" | Unsigned,SUB -> "UMSUBL" let memo_z sop = match sop with | Signed,ADD -> "SMULL" | Signed,SUB -> "SMNEGL" | Unsigned,ADD -> "UMULL" | Unsigned,SUB -> "UMNEGL" end module MOPExt = struct type op = ADD | SUB let memo op = match op with | ADD -> "MADD" | SUB -> "MSUB" let memo_z op = match op with | ADD -> "MUL" | SUB -> "MNEG" end let pp_variant = function | V32 -> "V32" | V64 -> "V64" | V128 -> "V128" let tr_variant = function | V32 -> MachSize.Word | V64 -> MachSize.Quad | V128 -> MachSize.S128 let container_size = function | RV16 _ -> MachSize.Short | RV32 -> MachSize.Word | RV64 v -> tr_variant v let tr_simd_variant = function | VSIMD8 -> MachSize.Byte | VSIMD16 -> MachSize.Short | VSIMD32 -> MachSize.Word | VSIMD64 -> MachSize.Quad | VSIMD128 -> MachSize.S128 let simd_variant_nbytes v = tr_simd_variant v |> MachSize.nbytes type temporal = TT | NT type pair_opt = Pa | PaN | PaI type ld_type = AA | XX | AX | AQ let ldr_memo = function | AA -> "LDAR" | XX -> "LDXR" | AX -> "LDAXR" | AQ -> "LDAPR" type ldxp_type = XP|AXP let ldxp_memo = function | XP -> "LDXP" | AXP -> "LDAXP" let ldp_memo = function | Pa -> "LDP" | PaN -> "LDNP" | PaI -> "LDIAPP" let stp_memo = function | Pa -> "STP" | PaN -> "STNP" | PaI -> "STILP" type st_type = YY | LY let str_memo = function | YY -> "STXR" | LY -> "STLXR" let stxp_memo = function | YY -> "STXP" | LY -> "STLXP" type rmw_type = RMW_P | RMW_A | RMW_L | RMW_AL type w_type = W_P | W_L let rmw_to_w = function | RMW_P -> W_P | RMW_L -> W_L | RMW_A|RMW_AL -> assert false let w_to_rmw = function | W_P -> RMW_P | W_L -> RMW_L let rmw_memo = function | RMW_P -> "" | RMW_A -> "A" | RMW_L -> "L" | RMW_AL -> "AL" let w_memo = function | W_P -> "" | W_L -> "L" let cas_memo rmw = sprintf "CAS%s" (rmw_memo rmw) let casp_memo rmw = sprintf "CASP%s" (rmw_memo rmw) and swp_memo rmw = sprintf "SWP%s" (rmw_memo rmw) type atomic_op = | A_ADD | A_EOR | A_SET | A_CLR | A_SMAX | A_SMIN | A_UMAX | A_UMIN let pp_aop = function | A_ADD -> "ADD" | A_EOR -> "EOR" | A_SET -> "SET" | A_CLR -> "CLR" | A_SMAX -> "SMAX" | A_SMIN -> "SMIN" | A_UMAX -> "UMAX" | A_UMIN -> "UMIN" let ldop_memo op rmw = sprintf "LD%s%s" (pp_aop op) (rmw_memo rmw) and stop_memo op w = sprintf "ST%s%s" (pp_aop op) (w_memo w) type bh = B | H (* Byte or Halfword *) let pp_bh = function | B -> "B" | H -> "H" let ldrs_memo bh = "LDRS" ^ pp_bh bh let bh_to_sz = function | B -> MachSize.Byte | H -> MachSize.Short let casbh_memo bh rmw = sprintf "%s%s" (cas_memo rmw) (pp_bh bh) and swpbh_memo bh rmw = sprintf "%s%s" (swp_memo rmw) (pp_bh bh) and ldopbh_memo op bh rmw = sprintf "%s%s" (ldop_memo op rmw) (pp_bh bh) and stopbh_memo op bh rmw = sprintf "%s%s" (stop_memo op rmw) (pp_bh bh) and ldrbh_memo bh t = sprintf "%s%s" (ldr_memo t) (pp_bh bh) and strbh_memo bh t = sprintf "%s%s" (str_memo t) (pp_bh bh) type opsel = Cpy | Inc | Inv | Neg let sel_memo = function | Cpy -> "CSEL" | Inc -> "CSINC" | Inv -> "CSINV" | Neg -> "CSNEG" (* Inline barrel shift and extenders - need to add all variants *) type 'k s = S_LSL of 'k | S_LSR of 'k | S_ASR of 'k | S_MSL of 'k | S_NOEXT let pp_barrel_shift sep s pp_k = match s with | S_LSL(k) -> sep ^ "LSL " ^ (pp_k k) | S_LSR(k) -> sep ^ "LSR " ^ (pp_k k) | S_ASR(k) -> sep ^ "ASR " ^ (pp_k k) | S_MSL(k) -> sep ^ "MSL " ^ (pp_k k) | S_NOEXT -> "" let pp_imm n = "#" ^ string_of_int n type 'k kinstruction = | I_NOP (* Branches *) | I_B of lbl | I_BR of reg | I_BC of condition * lbl | I_CBZ of variant * reg * lbl | I_CBNZ of variant * reg * lbl | I_TBNZ of variant * reg * 'k * lbl | I_TBZ of variant * reg * 'k * lbl | I_BL of lbl | I_BLR of reg | I_RET of reg option | I_ERET | I_SVC of 'k (* Load and Store *) | I_LDR of variant * reg * reg * 'k MemExt.ext | I_LDRSW of reg * reg * 'k MemExt.ext | I_LDUR of variant * reg * reg * 'k (* Neon Extension Load and Store*) | I_LD1 of reg list * int * reg * 'k kr | I_LDAP1 of reg list * int * reg * 'k kr | I_LD1M of reg list * reg * 'k kr | I_LD1R of reg list * reg * 'k kr | I_LD2 of reg list * int * reg * 'k kr | I_LD2M of reg list * reg * 'k kr | I_LD2R of reg list * reg * 'k kr | I_LD3 of reg list * int * reg * 'k kr | I_LD3M of reg list * reg * 'k kr | I_LD3R of reg list * reg * 'k kr | I_LD4 of reg list * int * reg * 'k kr | I_LD4M of reg list * reg * 'k kr | I_LD4R of reg list * reg * 'k kr | I_ST1 of reg list * int * reg * 'k kr | I_STL1 of reg list * int * reg * 'k kr | I_ST1M of reg list * reg * 'k kr | I_ST2 of reg list * int * reg * 'k kr | I_ST2M of reg list * reg * 'k kr | I_ST3 of reg list * int * reg * 'k kr | I_ST3M of reg list * reg * 'k kr | I_ST4 of reg list * int * reg * 'k kr | I_ST4M of reg list * reg * 'k kr | I_LDP_SIMD of temporal * simd_variant * reg * reg * reg * 'k idx | I_STP_SIMD of temporal * simd_variant * reg * reg * reg * 'k idx | I_LDR_SIMD of simd_variant * reg * reg * 'k MemExt.ext | I_STR_SIMD of simd_variant * reg * reg * 'k MemExt.ext | I_LDUR_SIMD of simd_variant * reg * reg * 'k | I_LDAPUR_SIMD of simd_variant * reg * reg * 'k | I_STUR_SIMD of simd_variant * reg * reg * 'k | I_STLUR_SIMD of simd_variant * reg * reg * 'k | I_ADDV of simd_variant * reg * reg | I_DUP of reg * variant * reg | I_FMOV_TG of variant * reg * simd_variant * reg | I_MOV_VE of reg * int * reg * int | I_MOV_V of reg * reg | I_MOV_TG of variant * reg * reg * int | I_MOV_FG of reg * int * variant * reg | I_MOV_S of simd_variant * reg * reg * int | I_MOVI_V of reg * 'k * 'k s | I_MOVI_S of simd_variant * reg * 'k | I_OP3_SIMD of op * reg * reg * reg | I_ADD_SIMD of reg * reg * reg | I_ADD_SIMD_S of reg * reg * reg (* More loads *) | I_LDP of pair_opt * variant * reg * reg * reg * 'k idx | I_LDPSW of reg * reg * reg * 'k idx | I_LDAR of variant * ld_type * reg * reg | I_LDXP of variant * ldxp_type * reg * reg * reg (* Stores *) | I_STR of variant * reg * reg * 'k MemExt.ext | I_STP of pair_opt * variant * reg * reg * reg * 'k idx | I_STLR of variant * reg * reg | I_STXR of variant * st_type * reg * reg * reg | I_STXP of variant * st_type * reg * reg * reg * reg (* Scalable Vector Extension*) (* PTRUE .{, } *) | I_PTRUE of reg * pattern (* WHILEL{LT,LE,LO,LS} ., , *) | I_WHILELT of reg * variant * reg * reg | I_WHILELE of reg * variant * reg * reg | I_WHILELO of reg * variant * reg * reg | I_WHILELS of reg * variant * reg * reg (* UADDV
, , . *) | I_UADDV of simd_variant * reg * reg * reg (* * LD1{B,H,W,D} (scalar plus scalar, single register) * * LD1B { . }, /Z, [, ] for T in D,S,H,B * LD1H { . }, /Z, [, , LSL #1] for T in D,S,H * LD1W { . }, /Z, [, , LSL #2] for T in D,S * LD1D { .D }, /Z, [, , LSL #3] * * LD1{B,H,W,D} (scalar plus immediate, single register) * * LD1B { . }, /Z, [{, #, MUL VL}] for T in D,S,H,B * LD1H { . }, /Z, [{, #, MUL VL}] for T in D,S,H * LD1W { .S }, /Z, [{, #, MUL VL}] for T in D,S * LD1D { .D }, /Z, [{, #, MUL VL}] * * LD1{B,H,W,D} (scalar plus vector) * * LD1B { .D }, /Z, [, .D, ] * LD1B { .S }, /Z, [, .S, ] * LD1B { .D }, /Z, [, .D] * LD1H { .S }, /Z, [, .S, #1] * LD1H { .D }, /Z, [, .D, #1] * LD1H { .D }, /Z, [, .D, ] * LD1H { .S }, /Z, [, .S, ] * LD1H { .D }, /Z, [, .D, LSL #1] * LD1H { .D }, /Z, [, .D] * LD1W { .S }, /Z, [, .S, #2] * LD1W { .D }, /Z, [, .D, #2] * LD1W { .D }, /Z, [, .D, ] * LD1W { .S }, /Z, [, .S, ] * LD1W { .D }, /Z, [, .D, LSL #2] * LD1W { .D }, /Z, [, .D] * LD1D { .D }, /Z, [, .D, #3] * LD1D { .D }, /Z, [, .D, ] * LD1D { .D }, /Z, [, .D, LSL #3] * LD1D { .D }, /Z, [, .D] *) | I_LD1SP of simd_variant * reg list * reg * reg * 'k MemExt.ext (* * LD2{B,H,W,D} (scalar plus scalar) * * LD2B { .B, .B }, /Z, [, ] * LD2H { .H, .H }, /Z, [, , LSL #1] * LD2W { .S, .S }, /Z, [, , LSL #2] * LD2D { .D, .D }, /Z, [, , LSL #3] * * LD2{B,H,W,D} (scalar plus immediate) * * LD2B { .B, .B }, /Z, [{, #, MUL VL}] * LD2H { .H, .H }, /Z, [{, #, MUL VL}] * LD2W { .S, .S }, /Z, [{, #, MUL VL}] * LD2D { .D, .D }, /Z, [{, #, MUL VL}] *) | I_LD2SP of simd_variant * reg list * reg * reg * 'k MemExt.ext (* * LD3{B,H,W,D} (scalar plus scalar) * * LD3B { .B, .B, .B }, /Z, [, ] * LD3H { .H, .H, .H }, /Z, [, , LSL #1] * LD3W { .S, .S, .S }, /Z, [, , LSL #2] * LD3D { .D, .D, .D }, /Z, [, , LSL #3] * * LD3{B,H,W,D} (scalar plus immediate) * * LD3B { .B, .B, .B }, /Z, [{, #, MUL VL}] * LD3H { .H, .H, .H }, /Z, [{, #, MUL VL}] * LD3W { .S, .S, .S }, /Z, [{, #, MUL VL}] * LD3D { .D, .D, .D }, /Z, [{, #, MUL VL}] *) | I_LD3SP of simd_variant * reg list * reg * reg * 'k MemExt.ext (* * LD4{B,H,W,D} (scalar plus scalar) * * LD4B { .B, .B, .B, .B }, /Z, [, ] * LD4H { .H, .H, .H, .H }, /Z, [, , LSL #1] * LD4W { .S, .S, .S, .S }, /Z, [, , LSL #2] * LD4D { .D, .D, .D, .D }, /Z, [, , LSL #3] * * LD4{B,H,W,D} (scalar plus immediate) * * LD4B { .B, .B, .B, .B }, /Z, [{, #, MUL VL}] * LD4H { .H, .H, .H, .H }, /Z, [{, #, MUL VL}] * LD4W { .S, .S, .S, .S }, /Z, [{, #, MUL VL}] *) | I_LD4SP of simd_variant * reg list * reg * reg * 'k MemExt.ext (* * ST1{B,H,W,D} (scalar plus scalar) * * ST1B { . }, , [, ] for T in D,S,H,B * ST1H { . }, , [, , LSL #1] for T in D,S,H * ST1W { . }, , [, , LSL #2] for T in D,S * ST1D { .D }, , [, , LSL #3] * * ST1{B,H,W,D} (scalar plus immediate) * * ST1B { . }, , [{, #, MUL VL}] for T in D,S,H,B * ST1H { . }, , [{, #, MUL VL}] for T in D,S,H * ST1W { . }, , [{, #, MUL VL}] for T in D,S * ST1D { .D }, , [{, #, MUL VL}] * * ST1{B,H,W,D} (scalar plus vector) * * ST1B { .D }, , [, .D, ] * ST1B { .S }, , [, .S, ] * ST1B { .D }, , [, .D] * ST1H { .S }, , [, .S, #1] * ST1H { .D }, , [, .D, #1] * ST1H { .D }, , [, .D, ] * ST1H { .S }, , [, .S, ] * ST1H { .D }, , [, .D, LSL #1] * ST1H { .D }, , [, .D] * ST1W { .S }, , [, .S, #2] * ST1W { .D }, , [, .D, #2] * ST1W { .D }, , [, .D, ] * ST1W { .S }, , [, .S, ] * ST1W { .D }, , [, .D, LSL #2] * ST1W { .D }, , [, .D] * ST1D { .D }, , [, .D, #3] * ST1D { .D }, , [, .D, ] * ST1D { .D }, , [, .D, LSL #3] * ST1D { .D }, , [, .D] *) | I_ST1SP of simd_variant * reg list * reg * reg * 'k MemExt.ext (* * ST2{B,H,W,D} (scalar plus scalar) * * ST2B { .B, .B }, , [, ] * ST2H { .H, .H }, , [, , LSL #1] * ST2W { .S, .S }, , [, , LSL #2] * ST2D { .D, .D }, , [, , LSL #3] * * ST2{B,H,W,D} (scalar plus immediate) * * ST2B { .B, .B }, , [{, #, MUL VL}] * ST2H { .H, .H }, , [{, #, MUL VL}] * ST2W { .S, .S }, , [{, #, MUL VL}] * ST2D { .D, .D }, , [{, #, MUL VL}] *) | I_ST2SP of simd_variant * reg list * reg * reg * 'k MemExt.ext (* * ST3{B,H,W,D} (scalar plus scalar) * * ST3B { .B, .B, .B }, , [, ] * ST3H { .H, .H, .H }, , [, , LSL #1] * ST3W { .S, .S, .S }, , [, , LSL #2] * ST3D { .D, .D, .D }, , [, , LSL #3] * * ST3{B,H,W,D} (scalar plus immediate) * * ST3B { .B, .B }, , [{, #, MUL VL}] * ST3H { .H, .H }, , [{, #, MUL VL}] * ST3W { .S, .S }, , [{, #, MUL VL}] * ST3D { .D, .D }, , [{, #, MUL VL}] *) | I_ST3SP of simd_variant * reg list * reg * reg * 'k MemExt.ext (* * ST4{B,H,W,D} (scalar plus scalar) * * ST4B { .B, .B, .B, .B }, , [, ] * ST4H { .H, .H, .H, .H }, , [, , LSL #1] * ST4W { .S, .S, .S, .S }, , [, , LSL #2] * ST4D { .D, .D, .D, .D }, , [, , LSL #3] * * ST4{B,H,W,D} (scalar plus immediate) * * ST4B { .B, .B }, , [{, #, MUL VL}] * ST4H { .H, .H }, , [{, #, MUL VL}] * ST4W { .S, .S }, , [{, #, MUL VL}] * ST4D { .D, .D }, , [{, #, MUL VL}] *) | I_ST4SP of simd_variant * reg list * reg * reg * 'k MemExt.ext (* MOV ., #{, } *) | I_MOV_SV of reg * 'k * 'k s (* DUP ., *) | I_DUP_SV of reg * variant * reg (* ADD ., ., . *) | I_ADD_SV of reg * reg * reg (* NEG ., /M, . *) | I_NEG_SV of reg * reg * reg (* MOVPRFX ., /, . *) | I_MOVPRFX of reg * reg * reg (* EOR .D, .D, .D, vectors, unpredicated *) | I_OP3_SV of op * reg * reg * reg (* INDEX ., , # *) | I_INDEX_SI of reg * variant * reg * 'k (* INDEX ., #, *) | I_INDEX_IS of reg * variant * 'k * reg (* INDEX ., , *) | I_INDEX_SS of reg * variant * reg * reg (* INDEX ., #, # *) | I_INDEX_II of reg * 'k * 'k (* RDVL , # *) | I_RDVL of reg * 'k (* ADDVL , , # *) | I_ADDVL of reg * reg * 'k (* {CNT,INC} {, pattern{, MULL #imm}} *) | I_CNT_INC_SVE of ( cnt_inc_op * simd_variant ) * reg * pattern * 'k (* Scalable Matrix Extension *) (* * LD1{B,H,W,D,Q} (scalar plus scalar, tile slice) * * LD1B { ZA0.B[, ] }, /Z, [{, }] * LD1H { .H[, ] }, /Z, [{, , LSL #1}] * LD1W { .S[, ] }, /Z, [{, , LSL #2}] * LD1D { .D[, ] }, /Z, [{, , LSL #3}] * LD1Q { .Q[, ] }, /Z, [{, , LSL #4}] *) | I_LD1SPT of simd_variant * reg * reg * 'k * reg * reg * 'k MemExt.ext (* * ST1{B,H,W,D,Q} (scalar plus scalar, tile slice) * * ST1B { ZA0.B[, ] }, , [{, }] * ST1H { .H[, ] }, , [{, , LSL #1}] * ST1W { .S[, ] }, , [{, , LSL #2}] * ST1D { .D[, ] }, , [{, , LSL #3}] * ST1Q { .Q[, ] }, , [{, , LSL #4}] *) | I_ST1SPT of simd_variant * reg * reg * 'k * reg * reg * 'k MemExt.ext (* * MOVA (vector to tile, single) * * MOVA ZA0.B[, ], /M, .B * MOVA .H[, ], /M, .H * MOVA .S[, ], /M, .S * MOVA .D[, ], /M, .D * MOVA .Q[, ], /M, .Q *) | I_MOVA_VT of reg * reg * 'k * reg * reg (* * MOVA (tile to vector, single) * * MOVA .B, /M, ZA0.B[, ] * MOVA .H, /M, .H[, ] * MOVA .S, /M, .S[, ] * MOVA .D, /M, .D[, ] * MOVA .Q, /M, .Q[, ] *) | I_MOVA_TV of reg * reg * reg * reg * 'k (* * ADDHA .S, /M, /M, .S * ADDVA .S, /M, /M, .S *) | I_ADDA of za_direction * reg * reg * reg * reg (* SMSTART {