accelerate-llvm 1.3.0.0 → 1.4.0.0
raw patch · 66 files changed
+8645/−894 lines, 66 filesdep +accelerate-llvmdep +formattingdep +hashabledep −llvm-hsdep −llvm-hs-puredep ~acceleratedep ~basedep ~containersnew-uploaderPVP ok
version bump matches the API change (PVP)
Dependencies added: accelerate-llvm, formatting, hashable, microlens, microlens-th, monadLib, parsec, pretty, process, syb, text, th-abstraction
Dependencies removed: llvm-hs, llvm-hs-pure
Dependency ranges changed: accelerate, base, containers, template-haskell
API changes (from Hackage documentation)
Files
- CHANGELOG.md +18/−0
- README.md +110/−151
- accelerate-llvm.cabal +100/−54
- llvm-pretty/src/Text/LLVM.hs +720/−0
- llvm-pretty/src/Text/LLVM/AST.hs +2224/−0
- llvm-pretty/src/Text/LLVM/DebugUtils.hs +516/−0
- llvm-pretty/src/Text/LLVM/Labels.hs +160/−0
- llvm-pretty/src/Text/LLVM/Labels/TH.hs +125/−0
- llvm-pretty/src/Text/LLVM/Lens.hs +57/−0
- llvm-pretty/src/Text/LLVM/PP.hs +1605/−0
- llvm-pretty/src/Text/LLVM/Parser.hs +142/−0
- llvm-pretty/src/Text/LLVM/Triple.hs +17/−0
- llvm-pretty/src/Text/LLVM/Triple/AST.hs +467/−0
- llvm-pretty/src/Text/LLVM/Triple/Parse.hs +294/−0
- llvm-pretty/src/Text/LLVM/Triple/Parse/ARM.hs +347/−0
- llvm-pretty/src/Text/LLVM/Triple/Parse/LookupTable.hs +77/−0
- llvm-pretty/src/Text/LLVM/Triple/Print.hs +229/−0
- llvm-pretty/src/Text/LLVM/Util.hs +18/−0
- src/Data/Array/Accelerate/LLVM/AST.hs +7/−1
- src/Data/Array/Accelerate/LLVM/Array/Data.hs +1/−0
- src/Data/Array/Accelerate/LLVM/CodeGen.hs +5/−2
- src/Data/Array/Accelerate/LLVM/CodeGen/Arithmetic.hs +19/−18
- src/Data/Array/Accelerate/LLVM/CodeGen/Array.hs +15/−12
- src/Data/Array/Accelerate/LLVM/CodeGen/Base.hs +37/−23
- src/Data/Array/Accelerate/LLVM/CodeGen/Environment.hs +4/−2
- src/Data/Array/Accelerate/LLVM/CodeGen/Exp.hs +5/−3
- src/Data/Array/Accelerate/LLVM/CodeGen/IR.hs +10/−8
- src/Data/Array/Accelerate/LLVM/CodeGen/Module.hs +4/−6
- src/Data/Array/Accelerate/LLVM/CodeGen/Monad.hs +132/−69
- src/Data/Array/Accelerate/LLVM/CodeGen/Monad.hs-boot +4/−1
- src/Data/Array/Accelerate/LLVM/CodeGen/Permute.hs +2/−2
- src/Data/Array/Accelerate/LLVM/CodeGen/Profile.hs +201/−0
- src/Data/Array/Accelerate/LLVM/CodeGen/Ptr.hs +4/−2
- src/Data/Array/Accelerate/LLVM/CodeGen/Stencil.hs +3/−1
- src/Data/Array/Accelerate/LLVM/CodeGen/Sugar.hs +1/−1
- src/Data/Array/Accelerate/LLVM/Compile.hs +19/−9
- src/Data/Array/Accelerate/LLVM/Compile/Cache.hs +7/−6
- src/Data/Array/Accelerate/LLVM/Embed.hs +34/−29
- src/Data/Array/Accelerate/LLVM/Execute.hs +9/−3
- src/Data/Array/Accelerate/LLVM/Execute/Async.hs +5/−3
- src/Data/Array/Accelerate/LLVM/Execute/Marshal.hs +31/−26
- src/Data/Array/Accelerate/LLVM/Extra.hs +1/−0
- src/Data/Array/Accelerate/LLVM/Link.hs +1/−0
- src/Data/Array/Accelerate/LLVM/Link/Cache.hs +4/−3
- src/Data/Array/Accelerate/LLVM/State.hs +46/−20
- src/Data/Array/Accelerate/LLVM/Target.hs +1/−1
- src/Data/Array/Accelerate/LLVM/Target/ClangInfo.hs +193/−0
- src/Data/Array/Accelerate/TH/Compat.hs +64/−0
- src/Data/ByteString/Short/Char8.hs +2/−2
- src/Data/ByteString/Short/Extra.hs +19/−14
- src/LLVM/AST/Type/AddrSpace.hs +0/−29
- src/LLVM/AST/Type/Constant.hs +41/−27
- src/LLVM/AST/Type/Downcast.hs +18/−15
- src/LLVM/AST/Type/Flags.hs +0/−50
- src/LLVM/AST/Type/Function.hs +26/−26
- src/LLVM/AST/Type/GetElementPtr.hs +58/−0
- src/LLVM/AST/Type/Global.hs +14/−13
- src/LLVM/AST/Type/InlineAssembly.hs +19/−8
- src/LLVM/AST/Type/Instruction.hs +186/−151
- src/LLVM/AST/Type/Instruction/Atomic.hs +10/−13
- src/LLVM/AST/Type/Instruction/RMW.hs +20/−22
- src/LLVM/AST/Type/Metadata.hs +11/−22
- src/LLVM/AST/Type/Name.hs +40/−9
- src/LLVM/AST/Type/Operand.hs +7/−7
- src/LLVM/AST/Type/Representation.hs +60/−19
- src/LLVM/AST/Type/Terminator.hs +19/−11
CHANGELOG.md view
@@ -6,6 +6,24 @@ project adheres to the [Haskell Package Versioning Policy (PVP)](https://pvp.haskell.org) +## [1.4.0.0] - ?+### Changed+ * Support for LLVM-15 to 22 (15 only on native backend, 16 and newer are supported on native and PTX).+ * Simplified installation by using clang via the command line instead of linking with LLVM. Clang should be on the PATH or (on Windows) installed in a standard location.+ * Updates for various new Accelerate features, including debugging functionality similar to Debug.Trace+ * Allow empty inputs in scanl1 and scanr1++### Contributors++Special thanks to those who contributed patches as part of this release:++ * Trevor L. McDonell (@tmcdonell)+ * Tom Smeding (@tomsmeding)+ * David van Balen (@dpvanbalen)+ * Ivo Gabe de Wolff (@ivogabe)+ * Robbert van der Helm (@robbert-vdh)+ * Noah Williams (@noahmartinwilliams)+ ## [1.3.0.0] - 2018-08-27 ### Added * Support for LLVM-9
README.md view
@@ -3,21 +3,16 @@ # LLVM backends for the Accelerate array language -[](https://github.com/tmcdonell/accelerate-llvm/actions)+[](https://github.com/AccelerateHS/accelerate-llvm/actions/workflows/ci.yml) [](https://gitter.im/AccelerateHS/Lobby)-<br>-[](https://stackage.org/lts/package/accelerate-llvm)-[](https://stackage.org/nightly/package/accelerate-llvm) [](https://hackage.haskell.org/package/accelerate-llvm)-<br>-[](https://hub.docker.com/r/tmcdonell/accelerate-llvm/)-[](https://microbadger.com/images/tmcdonell/accelerate-llvm) </div> This package compiles Accelerate code to LLVM IR, and executes that code on-multicore CPUs as well as NVIDIA GPUs. This avoids the need to go through `nvcc`-or `clang`. For details on Accelerate, refer to the [main repository][GitHub].+multicore CPUs as well as NVIDIA GPUs. This avoids the need to go through+`nvcc` or write C++ code. For details on Accelerate, refer to the [main+repository][GitHub]. We love all kinds of contributions, so feel free to open issues for missing features as well as report (or fix!) bugs on the [issue tracker][Issues].@@ -27,179 +22,143 @@ * [Dependencies](#dependencies)- * [Docker](#docker)- * [Installing LLVM](#installing-llvm)- * [Homebrew](#homebrew)+ * [macOS](#macos) * [Debian/Ubuntu](#debianubuntu)- * [Building from source](#building-from-source)- * [Installing Accelerate-LLVM](#installing-accelerate-llvm)- * [libNVVM](#libNVVM)+ * [Arch Linux](#archlinux)+ * [Windows](#windows) Dependencies ------------ -Haskell dependencies are available from Hackage, but there are several external+Haskell dependencies are available from Hackage, but there are some external library dependencies that you will need to install as well: - * [`LLVM`](http://llvm.org)- * [`libFFI`](http://sourceware.org/libffi/) (if using the `accelerate-llvm-native` backend for multicore CPUs)- * [`CUDA`](https://developer.nvidia.com/cuda-downloads) (if using the `accelerate-llvm-ptx` backend for NVIDIA GPUs)---Docker---------A [docker](https://www.docker.com) container is provided with this package-preinstalled (via stack) at `/opt/accelerate-llvm`. Note that if you wish to use-the `accelerate-llvm-ptx` GPU backend, you will need to install the [NVIDIA-docker](https://github.com/NVIDIA/nvidia-docker) plugin; see that page for more-information.--```sh-$ docker run -it tmcdonell/accelerate-llvm-```---Installing LLVM------------------When installing LLVM, make sure that it includes the `libLLVM` shared library.-If you want to use the GPU targeting `accelerate-llvm-ptx` backend, make sure-you install (or build) LLVM with the 'nvptx' target.+- if using `accelerate-llvm-native` for multicore CPU:+ [`libFFI`](http://sourceware.org/libffi/)+- if using `accelerate-llvm-ptx` for GPU:+ [`CUDA`](https://developer.nvidia.com/cuda-downloads);+ [Note that not all versions of CUDA support all NVIDIA GPUs](https://en.wikipedia.org/wiki/CUDA#GPUs_supported)+- [`clang`](https://clang.llvm.org/) (if using `accelerate-llvm-ptx`: version+ 16 or higher, built with support for the `nvptx` backend). `accelerate-llvm`+ uses the command-line tool as a way to be compatible with many different LLVM+ versions, not to compile C code. (Accelerate passes LLVM IR to `clang`.) -## Homebrew+Below are some OS-specific instructions. If anything here is wrong or out of+date, please file an issue. -Example using [Homebrew](http://brew.sh) on macOS:+## macOS -```sh-$ brew install llvm-hs/llvm/llvm-9-```+To get `libFFI`, run `brew install libffi`. `clang` is already provided with+macOS (you may need to `xcode-select --install`), and CUDA is not supported on+macOS. ## Debian/Ubuntu -For Debian/Ubuntu based Linux distributions, the LLVM.org website provides-binary distribution packages. Check [apt.llvm.org](http://apt.llvm.org) for-instructions for adding the correct package database for your OS version, and-then:--```sh-$ apt-get install llvm-9-dev-```--## Building from source--If your OS does not have an appropriate LLVM distribution available, you can also build from source. Detailed build instructions are available on the [LLVM.org website](http://releases.llvm.org/6.0.0/docs/CMake.html). Note that you will require at least [CMake 3.4.3](http://www.cmake.org/cmake/resources/software.html) and a recent C++ compiler; at least Clang 3.1, GCC 4.8, or Visual Studio 2015 (update 3).-- 1. Download and unpack the [LLVM-9 source code](https://github.com/llvm/llvm-project/releases/download/llvmorg-9.0.1/llvm-9.0.1.src.tar.xz). We'll refer to- the path that the source tree was unpacked to as `LLVM_SRC`. Only the main- LLVM source tree is required, but you can optionally add other components- such as the Clang compiler or Polly loop optimiser. See the [LLVM releases](http://releases.llvm.org/download.html#9.0.1)- page for the complete list.-- 2. Create a temporary build directory and `cd` into it, for example:- ```sh- $ mkdir /tmp/build- $ cd /tmp/build- ```-- 3. Execute the following to configure the build. Here `INSTALL_PREFIX` is- where LLVM is to be installed, for example `/usr/local` or- `$HOME/opt/llvm`:- ```sh- $ cmake $LLVM_SRC -DCMAKE_INSTALL_PREFIX=$INSTALL_PREFIX -DCMAKE_BUILD_TYPE=Release -DLLVM_ENABLE_ASSERTIONS=ON -DLLVM_BUILD_LLVM_DYLIB=ON -DLLVM_LINK_LLVM_DYLIB=ON- ```- See [options and variables](http://llvm.org/docs/CMake.html#options-and-variables)- for a list of additional build parameters you can specify.-- 4. Build and install:- ```sh- $ cmake --build .- $ cmake --build . --target install- ```-- 5. For macOS only, some additional steps are useful to work around issues related- to [System Integrity Protection](https://en.wikipedia.org/wiki/System_Integrity_Protection):- ```sh- cd $INSTALL_PREFIX/lib- ln -s libLLVM.dylib libLLVM-9.dylib- install_name_tool -id $PWD/libLTO.dylib libLTO.dylib- install_name_tool -id $PWD/libLLVM.dylib libLLVM.dylib- install_name_tool -change '@rpath/libLLVM.dylib' $PWD/libLLVM.dylib libLTO.dylib- ```-+For `clang`:+- On Ubuntu 24.04 (noble) / Debian trixie or higher: `sudo apt install clang`.+- Otherwise, if you need only the CPU backend (`accelerate-llvm-native`):+ `sudo apt install clang` will give you an old version of `clang`, but the CPU+ backend is likely to work fine.+- If you are on an older distro and need the GPU backend+ (`accelerate-llvm-ptx`): `clang` version 16 or higher is required.+ Add the apt source from [apt.llvm.org](https://apt.llvm.org/). The neatest+ way to do this is to create a file `/etc/apt/sources.list.d/llvm.list` (the+ precise file name does not matter) and put in it, for Ubuntu (change "jammy"+ as appropriate): -Installing Accelerate-LLVM---------------------------+ deb http://apt.llvm.org/jammy/ llvm-toolchain-jammy main+ deb-src http://apt.llvm.org/jammy/ llvm-toolchain-jammy main -Once the dependencies are installed, we are ready to install `accelerate-llvm`.+ or for Debian (change "bookworm" as appropriate): -For example, installation using [`stack`](http://docs.haskellstack.org/en/stable/README.html)-just requires you to point it to the appropriate configuration file:-```sh-$ ln -s stack-8.8.yaml stack.yaml-$ stack setup-$ stack install-```+ deb http://apt.llvm.org/bookworm/ llvm-toolchain-bookworm main+ deb-src http://apt.llvm.org/bookworm/ llvm-toolchain-bookworm main -Note that the version of [`llvm-hs`](https://hackage.haskell.org/package/llvm-hs)-used must match the installed version of LLVM, which is currently 9.0.+ and `sudo apt update; sudo apt install clang`. This gets you the latest+ version of `clang`; different sources are also available for specific+ versions (see [apt.llvm.org](https://apt.llvm.org)). +To use the CPU backend (`accelerate-llvm-native`), install `libFFI` using+`sudo apt install libffi-dev`. -## libNVVM+To use the GPU backend (`accelerate-llvm-ptx`), install CUDA from+[here](https://developer.nvidia.com/cuda-downloads?target_os=Linux)+("deb (network)" is smoother than the "deb (local)" option). -The `accelerate-llvm-ptx` backend can optionally be compiled to generate GPU-code using the `libNVVM` library, rather than LLVM's inbuilt NVPTX code-generator. `libNVVM` is a closed-source library distributed as part of the-NVIDIA CUDA toolkit, and is what the `nvcc` compiler itself uses internally when-compiling CUDA C code.+## Arch Linux -Using `libNVVM` _may_ improve GPU performance compared to the code generator-built in to LLVM. One difficulty with using it however is that since `libNVVM`-is also based on LLVM, and typically lags LLVM by several releases, you must-install `accelerate-llvm` with a "compatible" version of LLVM, which will depend-on the version of the CUDA toolkit you have installed. The following table shows-combinations which have been tested:+Run `sudo pacman -S clang`. To use the CPU backend (`accelerate-llvm-native`),+additionally run `sudo pacman -S libffi`. To use the GPU backend+(`accelerate-llvm-ptx`), additionally run `sudo pacman -S cuda`. -| | LLVM-3.3 | LLVM-3.4 | LLVM-3.5 | LLVM-3.8 | LLVM-3.9 | LLVM-4.0 | LLVM-5.0 | LLVM-6.0 | LLVM-7 | LLVM-8 | LLVM-9 |-| ------------- | :------: | :------: | :------: | :------: | :------: | :------: | :------: | :------: | :----: | :----: | :----: |-| **CUDA-7.0** | ⭕ | ❌ | | | | | | | | | |-| **CUDA-7.5** | | ⭕ | ⭕ | ❌ | | | | | | | |-| **CUDA-8.0** | | | ⭕ | ⭕ | ❌ | ❌ | | | | | |-| **CUDA-9.0** | | | | | | ❌ | ❌ | | | | |-| **CUDA-9.1** | | | | | | | | | | | |-| **CUDA-9.2** | | | | | | | | | | | |-| **CUDA-10.0** | | | | | | | | | | | |-| **CUDA-10.1** | | | | | | | | | | | |+## Windows -Where ⭕ = Works, and ❌ = Does not work.+We recommend WSL2 (not WSL1, WSL2!) and following the Ubuntu instructions+above. The remainder of this text attemps to give you a working system on+Windows native. -The above table is incomplete! If you try a particular combination and find that-it does or does not work, please let us know!+Install `clang`; you have two options:+1. Using+ [WinGet](https://learn.microsoft.com/en-us/windows/package-manager/winget/):+ `winget install LLVM.LLVM`+2. By downloading the installer directly (WinGet just runs the same installer)+ from [here](https://github.com/llvm/llvm-project/releases) (choose+ "LLVM-<version>-win64.exe" from the latest release; you may need to click+ "Show all 57 assets").+This will also give you `libFFI`. -Note that the above restrictions on CUDA and LLVM version exist _only_ if you-want to use the NVVM component. Otherwise, you should be free to use any-combination of CUDA and LLVM.+<details><summary>Optionally, add <code>clang</code> (and more) to your system path. Click to see how.</summary> -Also note that `accelerate-llvm-ptx` itself currently requires at least LLVM-4.0.+Accelerate should be able to find `clang` automatically even if you do not do+this. However, for easy access to `clang` and all other LLVM executables, add+`C:\Program Files\LLVM\bin` to the system path as follows:+1. Search for "environment variables" in the start menu+2. Click "Edit the system environment variables"+3. Click on "Environment Variables..."+4. Double-click on the user variable called "Path"+5. And add a new entry containing `C:\Program Files\LLVM\bin`. -Using `stack`, either edit the `stack.yaml` and add the following section:+Note that if you add an entry here manually, it is a good idea to clean it up+again if you uninstall LLVM/clang. (Leaving it there is not very harmful,+however.) -```yaml-flags:- accelerate-llvm-ptx:- nvvm: true-```+You may find that the LLVM/clang installer has already added the Path entry+automatically (it did not for us); if so, no need to add a second entry. -Or install using the following option on the command line:+——+</details> -```sh-$ stack install accelerate-llvm-ptx --flag accelerate-llvm-ptx:nvvm-```+You may additionally need the VS Build Tools, if you have not yet installed and+set up Visual Studio otherwise. You need this if `clang` complains that it is+`unable to find a Visual Studio installation; try running Clang from a developer command prompt`. -If installing via `cabal`:+1. If you already have the Visual Studio Installer on your system, open it and+ check if you already have Visual Studio (Community) installed. Note that+ this is completely unrelated to VS _Code_.+ - If you already have VS (Community): inside the Visual Studio Installer,+ click on "Modify" in the VS (Community) box. This should get you a screen+ with "workloads" you can select.+ - If you do not yet have VS (Community), install the VS Build Tools: go to+ https://visualstudio.microsoft.com/downloads, scroll down to "All+ Downloads", open "Tools for Visual Studio", and select "Build Tools for+ Visual Studio". If you run the installer, you should get a screen with+ "workloads" you can select.+2. Under the Workloads tab, choose the "Desktop development with C++" workload.+ If you want to save a bit of disk space (not much), keep only the following+ two options selected:+ - "MSVC v143 - VE 2022 C++ x64/x86 build tools (Latest)"+ - "Windows 11 SDK (…)" (choose the latest option). The attentive reader may+ note that the wizard also offers Clang; we recommend a separate Clang+ install for Accelerate because the one from VS somehow doesn’t seem to+ work properly with Accelerate. If you find out why, please let us know.+3. Install that. This takes a while. -```sh-$ cabal install accelerate-llvm-ptx -fnvvm-```+It turns out that having both Visual Studio and the Build Tools installed+results in Clang getting confused between the two (it appears that Visual+Studio is 64-bit (x64) and the Build Tools are 32-bit (x86)). If Clang+complains about the bit-ness of your system libraries, double-check that you+haven’t installed both simultaneously. +The GPU backend (`accelerate-llvm-ptx`) probably doesn't work on Windows; in+any case, it is untested.
accelerate-llvm.cabal view
@@ -1,65 +1,44 @@+cabal-version: 2.2+ name: accelerate-llvm-version: 1.3.0.0-cabal-version: >= 1.10-tested-with: GHC >= 8.6+version: 1.4.0.0+tested-with: GHC >= 9.4 build-type: Simple synopsis: Accelerate backend component generating LLVM IR description: This library implements direct LLVM IR generation for the /Accelerate/ language. For further information, refer to the main- <http://hackage.haskell.org/package/accelerate accelerate> package.+ <https://hackage.haskell.org/package/accelerate accelerate> package. As a+ user of Accelerate, you do not need to use this package; use+ @accelerate-llvm-native@ or @accelerate-llvm-ptx@ instead. . [/Dependencies/] . Haskell dependencies are available from Hackage. The following external- libraries are alse required:- .- * <http://llvm.org LLVM>- .- * <http://sourceware.org/libffi/ libFFI> (if using <http://hackage.haskell.org/package/accelerate-llvm-native accelerate-llvm-native>)- .- * <https://developer.nvidia.com/cuda-downloads CUDA> (if using <http://hackage.haskell.org/package/accelerate-llvm-ptx accelerate-llvm-ptx>)- .- [/Installing LLVM/]- .- /Homebrew/- .- Example using Homebrew on macOS:- .- > brew install llvm-hs/llvm/llvm-9- .- /Debian & Ubuntu/- .- For Debian/Ubuntu based Linux distributions, the LLVM.org website provides- binary distribution packages. Check <http://apt.llvm.org apt.llvm.org> for- instructions for adding the correct package database for your OS version,- and then:- .- > apt-get install llvm-9-dev- .- /Building from source/+ dependencies are also required: .- If your OS does not have an appropriate LLVM distribution available, you can- also build from source. Detailed build instructions are available on- <http://releases.llvm.org/8.0.0/docs/CMake.html LLVM.org>. Make sure to- include the cmake build options- @-DLLVM_BUILD_LLVM_DYLIB=ON -DLLVM_LINK_LLVM_DYLIB=ON@ so that the @libLLVM@- shared library will be built.+ * <https://clang.llvm.org/ clang> (not used to compile C code, but to compile generated LLVM IR via a mostly LLVM-version-independent interface)+ * <https://sourceware.org/libffi/ libFFI> (if using <https://hackage.haskell.org/package/accelerate-llvm-native accelerate-llvm-native>)+ * <https://developer.nvidia.com/cuda-downloads CUDA> (if using <https://hackage.haskell.org/package/accelerate-llvm-ptx accelerate-llvm-ptx>) .- If using the @accelerate-llvm-ptx@ backend, also ensure that the- @LLVM_TARGETS_TO_BUILD@ option includes the @NVPTX@ target (if not- specified, all targets are built).+ For installation instructions, see the <https://github.com/AccelerateHS/accelerate-llvm#readme README>. .+ This package includes (and exposes) a forked copy of+ <https://hackage.haskell.org/package/llvm-pretty llvm-pretty> due to some+ breaking changes needed to make accelerate-llvm work. Upstreaming these+ changes is planned. This code (under+ @Data.Array.Accelerate.LLVM.Internal.LLVMPretty@) is __not__ public API and+ may disappear or change at any time. -license: BSD3+license: BSD-3-Clause license-file: LICENSE author: Trevor L. McDonell maintainer: Trevor L. McDonell <trevor.mcdonell@gmail.com> bug-reports: https://github.com/AccelerateHS/accelerate/issues category: Accelerate, Compilers/Interpreters, Concurrency, Data, Parallelism -extra-source-files:+extra-doc-files: CHANGELOG.md README.md @@ -85,6 +64,7 @@ Data.Array.Accelerate.LLVM.CodeGen.Module Data.Array.Accelerate.LLVM.CodeGen.Monad Data.Array.Accelerate.LLVM.CodeGen.Permute+ Data.Array.Accelerate.LLVM.CodeGen.Profile Data.Array.Accelerate.LLVM.CodeGen.Ptr Data.Array.Accelerate.LLVM.CodeGen.Skeleton Data.Array.Accelerate.LLVM.CodeGen.Stencil@@ -103,13 +83,13 @@ Data.Array.Accelerate.LLVM.Link.Cache Data.Array.Accelerate.LLVM.State Data.Array.Accelerate.LLVM.Target+ Data.Array.Accelerate.LLVM.Target.ClangInfo -- LLVM code generation- LLVM.AST.Type.AddrSpace LLVM.AST.Type.Constant LLVM.AST.Type.Downcast- LLVM.AST.Type.Flags LLVM.AST.Type.Function+ LLVM.AST.Type.GetElementPtr LLVM.AST.Type.Global LLVM.AST.Type.InlineAssembly LLVM.AST.Type.Instruction@@ -124,32 +104,73 @@ LLVM.AST.Type.Terminator -- Extras+ Data.Array.Accelerate.TH.Compat Data.ByteString.Short.Char8 Data.ByteString.Short.Extra other-modules: Paths_accelerate_llvm + autogen-modules:+ Paths_accelerate_llvm+ build-depends: base >= 4.10 && < 5- , accelerate == 1.3.*+ , accelerate == 1.4.* , bytestring >= 0.10.4 , constraints >= 0.9- , containers >= 0.5+ , containers >= 0.5 && < 0.9 , data-default-class >= 0.0.1 , deepseq >= 1.3 , directory >= 1.2.3 , dlist >= 0.6 , exceptions >= 0.6 , filepath >= 1.0- , llvm-hs >= 4.1 && < 9.1- , llvm-hs-pure >= 4.1 && < 9.1+ , formatting >= 7.0+ , hashable >= 1.1+ -- , llvm-hs >= 4.1 && < 16+ -- , llvm-hs-pure >= 4.1 && < 16+ -- , llvm-pretty >= 0.12 , mtl >= 2.0 , primitive >= 0.6.4+ , process , template-haskell+ , text >= 1.2 , unordered-containers >= 0.2 , vector >= 0.10 + -- Expose the modules from the (forked and edited) llvm-pretty here under a+ -- namespace prefix. We need these modules in accelerate-llvm-native and+ -- accelerate-llvm-ptx, so we must expose them publically, unfortunately.+ build-depends: llvm-pretty-accfork+ reexported-modules:+ Data.Array.Accelerate.LLVM.Internal.LLVMPretty,+ Data.Array.Accelerate.LLVM.Internal.LLVMPretty.AST,+ Data.Array.Accelerate.LLVM.Internal.LLVMPretty.Labels,+ Data.Array.Accelerate.LLVM.Internal.LLVMPretty.Labels.TH,+ Data.Array.Accelerate.LLVM.Internal.LLVMPretty.Lens,+ Data.Array.Accelerate.LLVM.Internal.LLVMPretty.Parser,+ Data.Array.Accelerate.LLVM.Internal.LLVMPretty.PP,+ Data.Array.Accelerate.LLVM.Internal.LLVMPretty.DebugUtils,+ Data.Array.Accelerate.LLVM.Internal.LLVMPretty.Triple,+ Data.Array.Accelerate.LLVM.Internal.LLVMPretty.Triple.AST,+ Data.Array.Accelerate.LLVM.Internal.LLVMPretty.Triple.Parse,+ Data.Array.Accelerate.LLVM.Internal.LLVMPretty.Triple.Print+ mixins:+ llvm-pretty-accfork+ (Text.LLVM as Data.Array.Accelerate.LLVM.Internal.LLVMPretty,+ Text.LLVM.AST as Data.Array.Accelerate.LLVM.Internal.LLVMPretty.AST,+ Text.LLVM.Labels as Data.Array.Accelerate.LLVM.Internal.LLVMPretty.Labels,+ Text.LLVM.Labels.TH as Data.Array.Accelerate.LLVM.Internal.LLVMPretty.Labels.TH,+ Text.LLVM.Lens as Data.Array.Accelerate.LLVM.Internal.LLVMPretty.Lens,+ Text.LLVM.Parser as Data.Array.Accelerate.LLVM.Internal.LLVMPretty.Parser,+ Text.LLVM.PP as Data.Array.Accelerate.LLVM.Internal.LLVMPretty.PP,+ Text.LLVM.DebugUtils as Data.Array.Accelerate.LLVM.Internal.LLVMPretty.DebugUtils,+ Text.LLVM.Triple as Data.Array.Accelerate.LLVM.Internal.LLVMPretty.Triple,+ Text.LLVM.Triple.AST as Data.Array.Accelerate.LLVM.Internal.LLVMPretty.Triple.AST,+ Text.LLVM.Triple.Parse as Data.Array.Accelerate.LLVM.Internal.LLVMPretty.Triple.Parse,+ Text.LLVM.Triple.Print as Data.Array.Accelerate.LLVM.Internal.LLVMPretty.Triple.Print)+ hs-source-dirs: src @@ -161,21 +182,46 @@ -Wall -fwarn-tabs - ghc-prof-options:- -caf-all- -auto-all+-- Abridged from llvm-pretty.cabal+library llvm-pretty-accfork+ default-language: Haskell2010+ ghc-options: -Wall - if impl(ghc >= 8.0)- ghc-options:- -Wmissed-specialisations+ hs-source-dirs: llvm-pretty/src+ exposed-modules: Text.LLVM+ Text.LLVM.AST+ Text.LLVM.Labels+ Text.LLVM.Labels.TH+ Text.LLVM.Lens+ Text.LLVM.Parser+ Text.LLVM.PP+ Text.LLVM.DebugUtils+ Text.LLVM.Triple+ Text.LLVM.Triple.AST+ Text.LLVM.Triple.Parse+ Text.LLVM.Triple.Print+ other-modules: Text.LLVM.Triple.Parse.ARM+ Text.LLVM.Triple.Parse.LookupTable+ Text.LLVM.Util + build-depends: base >= 4.11 && < 5,+ containers >= 0.4,+ parsec >= 3,+ pretty >= 1.0.1,+ monadLib >= 3.6.1,+ microlens >= 0.4,+ microlens-th >= 0.4,+ syb >= 0.7,+ template-haskell >= 2.7,+ th-abstraction >= 0.3.1 && <0.8+ source-repository head type: git location: https://github.com/AccelerateHS/accelerate-llvm.git source-repository this type: git- tag: v1.3.0.0+ tag: v1.4.0.0 location: https://github.com/AccelerateHS/accelerate-llvm.git -- vim: nospell
+ llvm-pretty/src/Text/LLVM.hs view
@@ -0,0 +1,720 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Text.LLVM (+ -- * LLVM Monad+ LLVM()+ , runLLVM+ , emitTypeDecl+ , emitGlobal+ , emitDeclare+ , emitDefine++ -- * Alias Introduction+ , alias++ -- * Function Definition+ , freshSymbol+ , (:>)(..)+ , define, defineFresh, DefineArgs()+ , define'+ , declare+ , global+ , FunAttrs(..), emptyFunAttrs+ -- * Types+ , iT, ptrT, voidT, arrayT+ , (=:), (-:)++ -- * Values+ , IsValue(..)+ , int+ , integer+ , struct+ , array+ , string++ -- * Basic Blocks+ , BB()+ , runBB+ , freshLabel+ , label+ , comment+ , assign++ -- * Terminator Instructions+ , ret+ , retVoid+ , jump+ , br+ , unreachable+ , unwind++ -- * Binary Operations+ , add, fadd+ , sub, fsub+ , mul, fmul+ , udiv, sdiv, fdiv+ , urem, srem, frem++ -- * Bitwise Binary Operations+ , shl+ , lshr, ashr+ , band, bor, bxor++ -- * Conversion Operations+ , trunc+ , zext+ , sext+ , fptrunc+ , fpext+ , fptoui, fptosi+ , uitofp, sitofp+ , ptrtoint, inttoptr+ , bitcast++ -- * Aggregate Operations+ , extractValue+ , insertValue++ -- * Memory Access and Addressing Operations+ , alloca+ , load+ , store+ , getelementptr+ , nullPtr++ -- * Other Operations+ , icmp+ , fcmp+ , phi, PhiArg, from+ , select+ , call, call_+ , invoke+ , switch+ , shuffleVector++ -- * Re-exported+ , module Text.LLVM.AST+ ) where++import Text.LLVM.AST++import Control.Monad.Fix (MonadFix)+import Data.Char (ord)+import Data.Int (Int8,Int16,Int32,Int64)+import Data.Word (Word32, Word64)+import Data.Maybe (maybeToList)+import Data.String (IsString(..))+import MonadLib hiding (jump,Label)+import qualified Data.Foldable as F+import qualified Data.Sequence as Seq+import qualified Data.Map.Strict as Map+++-- Fresh Names -----------------------------------------------------------------++type Names = Map.Map String Int++-- | Avoid generating the provided name. When the name already exists, return+-- Nothing.+avoid :: String -> Names -> Maybe Names+avoid name ns =+ case Map.lookup name ns of+ Nothing -> Just (Map.insert name 0 ns)+ Just _ -> Nothing++nextName :: String -> Names -> (String,Names)+nextName pfx ns =+ case Map.lookup pfx ns of+ Nothing -> (fmt (0 :: Int), Map.insert pfx 1 ns)+ Just ix -> (fmt ix, Map.insert pfx (ix+1) ns)+ where+ fmt i = showString pfx (shows i "")+++-- LLVM Monad ------------------------------------------------------------------++newtype LLVM a = LLVM+ { unLLVM :: WriterT Module (StateT Names Id) a+ } deriving (Functor,Applicative,Monad,MonadFix)++freshNameLLVM :: String -> LLVM String+freshNameLLVM pfx = LLVM $ do+ ns <- get+ let (n,ns') = nextName pfx ns+ set ns'+ return n++runLLVM :: LLVM a -> (a,Module)+runLLVM = fst . runId . runStateT Map.empty . runWriterT . unLLVM++emitTypeDecl :: TypeDecl -> LLVM ()+emitTypeDecl td = LLVM (put emptyModule { modTypes = [td] })++emitGlobal :: Global -> LLVM (Typed Value)+emitGlobal g =+ do LLVM (put emptyModule { modGlobals = [g] })+ return (ptrT (globalType g) -: globalSym g)++emitDefine :: Define -> LLVM (Typed Value)+emitDefine d =+ do LLVM (put emptyModule { modDefines = [d] })+ return (defFunType d -: defName d)++emitDeclare :: Declare -> LLVM (Typed Value)+emitDeclare d =+ do LLVM (put emptyModule { modDeclares = [d] })+ return (decFunType d -: decName d)++alias :: Ident -> Type -> LLVM ()+alias i ty = emitTypeDecl (TypeDecl i ty)++freshSymbol :: LLVM Symbol+freshSymbol = Symbol `fmap` freshNameLLVM "f"++-- | Emit a declaration.+declare :: Type -> Symbol -> [Type] -> Bool -> LLVM (Typed Value)+declare rty sym tys va = emitDeclare Declare+ { decLinkage = Nothing+ , decVisibility = Nothing+ , decRetType = rty+ , decName = sym+ , decArgs = tys+ , decVarArgs = va+ , decAttrs = []+ , decComdat = Nothing+ }++-- | Emit a global declaration.+global :: GlobalAttrs -> Symbol -> Type -> Maybe Value -> LLVM (Typed Value)+global attrs sym ty mbVal = emitGlobal Global+ { globalSym = sym+ , globalType = ty+ , globalValue = toValue `fmap` mbVal+ , globalAttrs = attrs+ , globalAlign = Nothing+ , globalMetadata = Map.empty+ }++-- | Output a somewhat clunky representation for a string global, that deals+-- well with escaping in the haskell-source string.+string :: Symbol -> String -> LLVM (Typed Value)+string sym str =+ global emptyGlobalAttrs { gaConstant = True } sym (typedType val)+ (Just (typedValue val))+ where+ bytes = [ int (fromIntegral (ord c)) | c <- str ]+ val = array (iT 8) bytes+++-- Function Definition ---------------------------------------------------------++data FunAttrs = FunAttrs+ { funLinkage :: Maybe Linkage+ , funVisibility :: Maybe Visibility+ , funGC :: Maybe GC+ } deriving (Show)++emptyFunAttrs :: FunAttrs+emptyFunAttrs = FunAttrs+ { funLinkage = Nothing+ , funVisibility = Nothing+ , funGC = Nothing+ }+++-- XXX Do not export+freshArg :: Type -> LLVM (Typed Ident)+freshArg ty = (Typed ty . Ident) `fmap` freshNameLLVM "a"++infixr 0 :>+data a :> b = a :> b+ deriving Show++-- | Types that can be used to define the body of a function.+class DefineArgs a k | a -> k where+ defineBody :: [Typed Ident] -> a -> k -> LLVM ([Typed Ident], [BasicBlock])++instance DefineArgs () (BB ()) where+ defineBody tys () body = return $ runBB $ do+ body+ return (reverse tys)++instance DefineArgs as k => DefineArgs (Type :> as) (Typed Value -> k) where+ defineBody args (ty :> as) f = do+ arg <- freshArg ty+ defineBody (arg:args) as (f (toValue `fmap` arg))++-- helper instances for DefineArgs++instance DefineArgs Type (Typed Value -> BB ()) where+ defineBody tys ty body = defineBody tys (ty :> ()) body++instance DefineArgs (Type,Type) (Typed Value -> Typed Value -> BB ()) where+ defineBody tys (a,b) body = defineBody tys (a :> b :> ()) body++instance DefineArgs (Type,Type,Type)+ (Typed Value -> Typed Value -> Typed Value -> BB ()) where+ defineBody tys (a,b,c) body = defineBody tys (a :> b :> c :> ()) body++-- | Define a function.+define :: DefineArgs sig k => FunAttrs -> Type -> Symbol -> sig -> k+ -> LLVM (Typed Value)+define attrs rty fun sig k = do+ (args,body) <- defineBody [] sig k+ emitDefine Define+ { defLinkage = funLinkage attrs+ , defVisibility = funVisibility attrs+ , defName = fun+ , defRetType = rty+ , defArgs = args+ , defVarArgs = False+ , defAttrs = []+ , defSection = Nothing+ , defGC = funGC attrs+ , defBody = body+ , defMetadata = Map.empty+ , defComdat = Nothing+ }++-- | A combination of define and @freshSymbol@.+defineFresh :: DefineArgs sig k => FunAttrs -> Type -> sig -> k+ -> LLVM (Typed Value)+defineFresh attrs rty args body = do+ sym <- freshSymbol+ define attrs rty sym args body++-- | Function definition when the argument list isn't statically known. This is+-- useful when generating code.+define' :: FunAttrs -> Type -> Symbol -> [Type] -> Bool+ -> ([Typed Value] -> BB ())+ -> LLVM (Typed Value)+define' attrs rty sym sig va k = do+ args <- mapM freshArg sig+ emitDefine Define+ { defLinkage = funLinkage attrs+ , defVisibility = funVisibility attrs+ , defName = sym+ , defRetType = rty+ , defArgs = args+ , defVarArgs = va+ , defAttrs = []+ , defSection = Nothing+ , defGC = funGC attrs+ , defBody = snd (runBB (k (map (fmap toValue) args)))+ , defMetadata = Map.empty+ , defComdat = Nothing+ }++-- Basic Block Monad -----------------------------------------------------------++newtype BB a = BB+ { unBB :: WriterT [BasicBlock] (StateT RW Id) a+ } deriving (Functor,Applicative,Monad,MonadFix)++avoidName :: String -> BB ()+avoidName name = BB $ do+ rw <- get+ case avoid name (rwNames rw) of+ Just ns' -> set rw { rwNames = ns' }+ Nothing -> error ("avoidName: " ++ name ++ " already registered")++freshNameBB :: String -> BB String+freshNameBB pfx = BB $ do+ rw <- get+ let (n,ns') = nextName pfx (rwNames rw)+ set rw { rwNames = ns' }+ return n++runBB :: BB a -> (a,[BasicBlock])+runBB m =+ case runId (runStateT emptyRW (runWriterT (unBB body))) of+ ((a,bbs),_rw) -> (a,bbs)+ where+ -- make sure that the last block is terminated+ body = do+ res <- m+ terminateBasicBlock+ return res++data RW = RW+ { rwNames :: Names+ , rwLabel :: Maybe BlockLabel+ , rwStmts :: Seq.Seq Stmt+ } deriving Show++emptyRW :: RW+emptyRW = RW+ { rwNames = Map.empty+ , rwLabel = Nothing+ , rwStmts = Seq.empty+ }++rwBasicBlock :: RW -> (RW,Maybe BasicBlock)+rwBasicBlock rw+ | Seq.null (rwStmts rw) = (rw,Nothing)+ | otherwise =+ let rw' = rw { rwLabel = Nothing, rwStmts = Seq.empty }+ bb = BasicBlock (rwLabel rw) (F.toList (rwStmts rw))+ in (rw',Just bb)++emitStmt :: Stmt -> BB ()+emitStmt stmt = do+ BB $ do+ rw <- get+ set $! rw { rwStmts = rwStmts rw Seq.|> stmt }+ when (isTerminator (stmtInstr stmt)) terminateBasicBlock++effect :: Instr -> BB ()+effect i = emitStmt (Effect i mempty [])++observe :: Type -> Instr -> BB (Typed Value)+observe ty i = do+ name <- freshNameBB "r"+ let res = Ident name+ emitStmt (Result res i mempty [])+ return (Typed ty (ValIdent res))+++-- Basic Blocks ----------------------------------------------------------------++freshLabel :: BB Ident+freshLabel = Ident `fmap` freshNameBB "L"++-- | Force termination of the current basic block, and start a new one with the+-- given label. If the previous block had no instructions defined, it will just+-- be thrown away.+label :: Ident -> BB ()+label l = do+ terminateBasicBlock+ BB $ do+ rw <- get+ set $! rw { rwLabel = Just (Named l) }++instance IsString (BB a) where+ fromString l = do+ label (fromString l)+ return (error ("Label ``" ++ l ++ "'' has no value"))++terminateBasicBlock :: BB ()+terminateBasicBlock = BB $ do+ rw <- get+ let (rw',bb) = rwBasicBlock rw+ put (maybeToList bb)+ set rw'+++-- Type Helpers ----------------------------------------------------------------++iT :: Word32 -> Type+iT = PrimType . Integer++ptrT :: Type -> Type+ptrT = \ty -> PtrTo ty defaultAddrSpace++voidT :: Type+voidT = PrimType Void++arrayT :: Word64 -> Type -> Type+arrayT = Array+++-- Value Helpers ---------------------------------------------------------------++class IsValue a where+ toValue :: a -> Value++instance IsValue Value where+ toValue = id++instance IsValue a => IsValue (Typed a) where+ toValue = toValue . typedValue++instance IsValue Bool where+ toValue = ValBool++instance IsValue Integer where+ toValue = ValInteger++instance IsValue Int where+ toValue = ValInteger . toInteger++instance IsValue Int8 where+ toValue = ValInteger . toInteger++instance IsValue Int16 where+ toValue = ValInteger . toInteger++instance IsValue Int32 where+ toValue = ValInteger . toInteger++instance IsValue Int64 where+ toValue = ValInteger . toInteger++instance IsValue Float where+ toValue = ValFloat++instance IsValue Double where+ toValue = ValDouble++instance IsValue Ident where+ toValue = ValIdent++instance IsValue Symbol where+ toValue = ValSymbol++(-:) :: IsValue a => Type -> a -> Typed Value+ty -: a = ty =: toValue a++(=:) :: Type -> a -> Typed a+ty =: a = Typed+ { typedType = ty+ , typedValue = a+ }++int :: Int -> Value+int = toValue++integer :: Integer -> Value+integer = toValue++struct :: Bool -> [Typed Value] -> Typed Value+struct packed tvs+ | packed = PackedStruct (map typedType tvs) =: ValPackedStruct tvs+ | otherwise = Struct (map typedType tvs) =: ValStruct tvs++array :: Type -> [Value] -> Typed Value+array ty vs = Typed (Array (fromIntegral (length vs)) ty) (ValArray ty vs)+++-- Instructions ----------------------------------------------------------------++comment :: String -> BB ()+comment str = effect (Comment str)++-- | Emit an assignment that uses the given identifier to name the result of the+-- BB operation.+--+-- WARNING: this can throw errors.+assign :: IsValue a => Ident -> BB (Typed a) -> BB (Typed Value)+assign r@(Ident name) body = do+ avoidName name+ tv <- body+ rw <- BB get+ case Seq.viewr (rwStmts rw) of++ stmts Seq.:> Result _ i d m ->+ do BB (set rw { rwStmts = stmts Seq.|> Result r i d m })+ return (const (ValIdent r) `fmap` tv)++ _ -> error "assign: invalid argument"++-- | Emit the ``ret'' instruction and terminate the current basic block.+ret :: IsValue a => Typed a -> BB ()+ret tv = effect (Ret (toValue `fmap` tv))++-- | Emit ``ret void'' and terminate the current basic block.+retVoid :: BB ()+retVoid = effect RetVoid++jump :: Ident -> BB ()+jump l = effect (Jump (Named l))++br :: IsValue a => Typed a -> Ident -> Ident -> BB ()+br c t f = effect (Br (toValue `fmap` c) (Named t) (Named f))++unreachable :: BB ()+unreachable = effect Unreachable++unwind :: BB ()+unwind = effect Unwind++binop :: (IsValue a, IsValue b)+ => (Typed Value -> Value -> Instr) -> Typed a -> b -> BB (Typed Value)+binop k l r = observe (typedType l) (k (toValue `fmap` l) (toValue r))++add :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+add = binop (Arith (Add False False))++fadd :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+fadd = binop (Arith (FAdd []))++sub :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+sub = binop (Arith (Sub False False))++fsub :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+fsub = binop (Arith (FSub []))++mul :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+mul = binop (Arith (Mul False False))++fmul :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+fmul = binop (Arith (FMul []))++udiv :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+udiv = binop (Arith (UDiv False))++sdiv :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+sdiv = binop (Arith (SDiv False))++fdiv :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+fdiv = binop (Arith (FDiv []))++urem :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+urem = binop (Arith URem)++srem :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+srem = binop (Arith SRem)++frem :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+frem = binop (Arith (FRem []))++shl :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+shl = binop (Bit (Shl False False))++lshr :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+lshr = binop (Bit (Lshr False))++ashr :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+ashr = binop (Bit (Ashr False))++band :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+band = binop (Bit And)++bor :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+bor = binop (Bit Or)++bxor :: (IsValue a, IsValue b) => Typed a -> b -> BB (Typed Value)+bxor = binop (Bit Xor)++-- | Returns the value stored in the member field of an aggregate value.+extractValue :: IsValue a => Typed a -> Int32 -> BB (Typed Value)+extractValue ta i =+ let etp = case typedType ta of+ Struct fl -> fl !! fromIntegral i+ Array _l etp' -> etp'+ _ -> error "extractValue not given a struct or array."+ in observe etp (ExtractValue (toValue `fmap` ta) [i])++-- | Inserts a value into the member field of an aggregate value, and returns+-- the new value.+insertValue :: (IsValue a, IsValue b)+ => Typed a -> Typed b -> Int32 -> BB (Typed Value)+insertValue ta tv i =+ observe (typedType ta)+ (InsertValue (toValue `fmap` ta) (toValue `fmap` tv) [i])++shuffleVector :: (IsValue a, IsValue b, IsValue c)+ => Typed a -> b -> c -> BB (Typed Value)+shuffleVector vec1 vec2 mask =+ case typedType vec1 of+ Vector n _ -> observe (typedType vec1)+ $ ShuffleVector (toValue `fmap` vec1) (toValue vec2)+ $ Typed (Vector n (PrimType (Integer 32))) (toValue mask)+ _ -> error "shuffleVector not given a vector"++alloca :: Type -> Maybe (Typed Value) -> Maybe Int -> BB (Typed Value)+alloca ty mb align = observe (PtrTo ty defaultAddrSpace) (Alloca ty es align)+ where+ es = fmap toValue `fmap` mb++load :: IsValue a => Type -> Typed a -> Maybe Align -> BB (Typed Value)+load ty ptr ma = observe ty (Load False ty (toValue `fmap` ptr) Nothing ma)++store :: (IsValue a, IsValue b) => a -> Typed b -> Maybe Align -> BB ()+store a ptr ma =+ case typedType ptr of+ PtrTo ty _ -> effect (Store False (ty -: a) (toValue `fmap` ptr) Nothing ma)+ _ -> error "store not given a pointer"++nullPtr :: Type -> Typed Value+nullPtr ty = ptrT ty =: ValNull++convop :: IsValue a+ => (Typed Value -> Type -> Instr) -> Typed a -> Type -> BB (Typed Value)+convop k a ty = observe ty (k (toValue `fmap` a) ty)++trunc :: IsValue a => Typed a -> Type -> BB (Typed Value)+trunc = convop (Conv (Trunc False False))++zext :: IsValue a => Typed a -> Type -> BB (Typed Value)+zext = convop (Conv (ZExt False))++sext :: IsValue a => Typed a -> Type -> BB (Typed Value)+sext = convop (Conv SExt)++fptrunc :: IsValue a => Typed a -> Type -> BB (Typed Value)+fptrunc = convop (Conv FpTrunc)++fpext :: IsValue a => Typed a -> Type -> BB (Typed Value)+fpext = convop (Conv FpExt)++fptoui :: IsValue a => Typed a -> Type -> BB (Typed Value)+fptoui = convop (Conv FpToUi)++fptosi :: IsValue a => Typed a -> Type -> BB (Typed Value)+fptosi = convop (Conv FpToSi)++uitofp :: IsValue a => Typed a -> Type -> BB (Typed Value)+uitofp = convop (Conv (UiToFp False))++sitofp :: IsValue a => Typed a -> Type -> BB (Typed Value)+sitofp = convop (Conv SiToFp)++ptrtoint :: IsValue a => Typed a -> Type -> BB (Typed Value)+ptrtoint = convop (Conv PtrToInt)++inttoptr :: IsValue a => Typed a -> Type -> BB (Typed Value)+inttoptr = convop (Conv IntToPtr)++bitcast :: IsValue a => Typed a -> Type -> BB (Typed Value)+bitcast = convop (Conv BitCast)++icmp :: (IsValue a, IsValue b) => ICmpOp -> Typed a -> b -> BB (Typed Value)+icmp op l r = observe (iT 1) (ICmp False op (toValue `fmap` l) (toValue r))++fcmp :: (IsValue a, IsValue b) => FCmpOp -> Typed a -> b -> BB (Typed Value)+fcmp op l r = observe (iT 1) (FCmp [] op (toValue `fmap` l) (toValue r))++data PhiArg = PhiArg Value BlockLabel++from :: IsValue a => a -> BlockLabel -> PhiArg+from a = PhiArg (toValue a)++phi :: Type -> [PhiArg] -> BB (Typed Value)+phi ty vs = observe ty (Phi [] ty [ (v,l) | PhiArg v l <- vs ])++select :: (IsValue a, IsValue b, IsValue c)+ => Typed a -> Typed b -> Typed c -> BB (Typed Value)+select c t f = observe (typedType t)+ $ Select [] (toValue `fmap` c) (toValue `fmap` t) (toValue f)++getelementptr :: IsValue a+ => Type -> Typed a -> [Typed Value] -> BB (Typed Value)+getelementptr ty ptr ixs = observe ty (GEP [] ty (toValue `fmap` ptr) ixs)++-- | Emit a call instruction, and generate a new variable for its result.+call :: IsValue a => Typed a -> [Typed Value] -> BB (Typed Value)+call sym vs = case typedType sym of+ PtrTo ty@(FunTy rty _ _) _ -> observe rty (Call False [] ty (toValue sym) vs)+ _ -> error "invalid function type given to call"++-- | Emit a call instruction, but don't generate a new variable for its result.+call_ :: IsValue a => Typed a -> [Typed Value] -> BB ()+call_ sym vs = effect (Call False [] (typedType sym) (toValue sym) vs)++-- | Emit an invoke instruction, and generate a new variable for its result.+invoke :: IsValue a =>+ Type -> a -> [Typed Value] -> Ident -> Ident -> BB (Typed Value)+invoke rty sym vs to uw = observe rty+ $ Invoke rty (toValue sym) vs (Named to) (Named uw)++-- | Emit a call instruction, but don't generate a new variable for its result.+switch :: IsValue a => Typed a -> Ident -> [(Integer, Ident)] -> BB ()+switch idx def dests = effect (Switch (toValue `fmap` idx) (Named def)+ (map (\(n, l) -> (n, Named l)) dests))
+ llvm-pretty/src/Text/LLVM/AST.hs view
@@ -0,0 +1,2224 @@+{- |+Because this library supports many LLVM versions, it is possible to construct+an AST with the types in this module that only some LLVM versions will accept.+These cases are usually documented in the Haddocks for the relevant data types.+When trying to pretty-print constructions that are unsupported by the current+LLVM version, pretty-printing may 'error'.++At the same time, while the AST coverage is fairly extensive, it is also+incomplete: there are some values that new LLVM versions would accept but are+not yet represented here.+-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveGeneric #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}++module Text.LLVM.AST+ ( -- * Modules+ Module(..)+ , emptyModule+ -- * Named Metadata+ , NamedMd(..)+ -- * Unnamed Metadata+ , UnnamedMd(..)+ -- * Aliases+ , GlobalAlias(..)+ -- * Data Layout+ , DataLayout+ , LayoutSpec(..)+ , Alignment(..)+ , FunctionPointerAlignType(..)+ , Storage(..)+ , PointerSize(..)+ , AddressSpace+ , NumBits+ , Mangling(..)+ , parseDataLayout+ -- * Inline Assembly+ , InlineAsm+ -- * Comdat+ , SelectionKind(..)+ -- * Identifiers+ , Ident(..)+ -- * Symbols+ , Symbol(..)+ -- * Types+ , PrimType(..)+ , FloatType(..)+ , Type, Type'(..)+ , AddrSpace(..)+ , defaultAddrSpace+ , updateAliasesA, updateAliases+ , isFloatingPoint+ , isAlias+ , isPrimTypeOf+ , isLabel+ , isInteger+ , isVector+ , isVectorOf+ , isArray+ , isPointer+ , eqTypeModuloOpaquePtrs+ , cmpTypeModuloOpaquePtrs+ , fixupOpaquePtrs+ -- * Null values+ , NullResult(..)+ , primTypeNull+ , floatTypeNull+ , typeNull+ -- * Type Elimination+ , elimFunTy+ , elimAlias+ , elimPtrTo+ , elimVector+ , elimArray+ , elimFunPtr+ , elimPrimType+ , elimFloatType+ , elimSequentialType+ -- * Top-level Type Aliases+ , TypeDecl(..)+ -- * Globals+ , Global(..)+ , addGlobal+ , GlobalAttrs(..)+ , emptyGlobalAttrs+ -- * Declarations+ , Declare(..)+ , decFunType+ -- * Function Definitions+ , Define(..)+ , defFunType, addDefine+ -- * Function Attributes and attribute groups+ , FunAttr(..)+ -- * Basic Block Labels+ , BlockLabel(..)+ -- * Basic Blocks+ , BasicBlock'(..), BasicBlock+ , brTargets+ -- * Attributes+ , Linkage(..)+ , Visibility(..)+ , GC(..)+ -- * Typed Things+ , Typed(..)+ , mapMTyped+ -- * Instructions+ , ArithOp(..)+ , isIArith+ , isFArith+ , UnaryArithOp(..)+ , BitOp(..)+ , ConvOp(..)+ , AtomicRWOp(..)+ , AtomicOrdering(..)+ , Align+ , Instr'(..), Instr+ , Clause'(..), Clause+ , isTerminator+ , isComment+ , isPhi+ , ICmpOp(..)+ , FCmpOp(..)+ , FMF(..)+ -- * Values+ , Value'(..), Value+ , FP80Value(..)+ , ValMd'(..), ValMd+ , KindMd+ , FnMdAttachments+ , GlobalMdAttachments+ , DebugLoc'(..), DebugLoc+ , isConst+ -- * Value Elimination+ , elimValSymbol+ , elimValInteger+ -- * Statements+ , Stmt'(..), Stmt+ , stmtInstr+ , stmtMetadata+ , extendMetadata+ , addDebugRecord+ -- * Constant Expressions+ , ConstExpr'(..), ConstExpr+ , GEPAttr(..)+ , orderedGEPAttrs+ , RangeSpec(RangeIndex, Range)+ -- * DWARF Debug Info+ , DebugInfo'(..), DebugInfo+ , DILabel, DILabel'(..)+ , DIImportedEntity, DIImportedEntity'(..)+ , DITemplateTypeParameter, DITemplateTypeParameter'(..)+ , DITemplateValueParameter, DITemplateValueParameter'(..)+ , DINameSpace, DINameSpace'(..)+ , DwarfAttrEncoding+ , DwarfLang+ , DwarfTag+ , DwarfVirtuality+ , DIFlags+ , DIEmissionKind+ , DIBasicType'(..), DIBasicType+ , DICompileUnit'(..), DICompileUnit+ , DICompositeType'(..), DICompositeType+ , DIDerivedType'(..), DIDerivedType+ , DIExpression(..)+ , DIFile(..)+ , DIGlobalVariable'(..), DIGlobalVariable+ , DIGlobalVariableExpression'(..), DIGlobalVariableExpression+ , DILexicalBlock'(..), DILexicalBlock+ , DILexicalBlockFile'(..), DILexicalBlockFile+ , DILocalVariable'(..), DILocalVariable+ , DISubprogram'(..), DISubprogram+ , DISubrange'(..), DISubrange+ , DISubroutineType'(..), DISubroutineType+ , DIArgList'(..), DIArgList+ , dwarf_DW_APPLE_ENUM_KIND_invalid+ , DebugRecord, DebugRecord'(..)+ , DbgRecAssign, DbgRecAssign'(..)+ , DbgRecDeclare, DbgRecDeclare'(..)+ , DbgRecLabel, DbgRecLabel'(..)+ , DbgRecValueSimple, DbgRecValueSimple'(..)+ , DbgRecValue, DbgRecValue'(..)+ -- * Aggregate Utilities+ , IndexResult(..)+ , isInvalid+ , resolveGepFull+ , resolveGep+ , resolveGepBody+ , isGepIndex+ , isGepStructIndex+ , resolveValueIndex+ ) where++import Control.Monad (MonadPlus(mzero,mplus),(<=<),guard)+import Data.Bits ( complement )+import Data.Coerce (coerce)+import Data.Data (Data)+import Data.Functor.Identity (Identity(..))+import Data.Generics (everywhere, extQ, mkT, something)+import Data.Int (Int32,Int64)+import Data.List (genericIndex,genericLength)+import qualified Data.Map as Map+import Data.Maybe (isJust)+import Data.Semigroup as Sem+import Data.String (IsString(fromString))+import Data.Typeable (Typeable)+import Data.Word (Word8,Word16,Word32,Word64)+import GHC.Generics (Generic, Generic1)+import Language.Haskell.TH.Syntax (Lift)++import Text.Parsec+import Text.Parsec.String++import Text.LLVM.Triple.AST (TargetTriple)+++-- Modules ---------------------------------------------------------------------++data Module = Module+ { modSourceName :: Maybe String+ , modTriple :: TargetTriple -- ^ target triple+ , modDataLayout :: DataLayout -- ^ type size and alignment information+ , modTypes :: [TypeDecl] -- ^ top-level type aliases+ , modNamedMd :: [NamedMd]+ , modUnnamedMd :: [UnnamedMd]+ , modComdat :: Map.Map String SelectionKind+ , modGlobals :: [Global] -- ^ global value declarations+ , modDeclares :: [Declare] -- ^ external function declarations (without definitions)+ , modDefines :: [Define] -- ^ internal function declarations (with definitions)+ , modInlineAsm :: InlineAsm+ , modAliases :: [GlobalAlias]+ } deriving (Data, Eq, Ord, Generic, Show, Typeable)++-- | Combines fields pointwise.+instance Sem.Semigroup Module where+ m1 <> m2 = Module+ { modSourceName = modSourceName m1 `mplus` modSourceName m2+ , modTriple = modTriple m1 <> modTriple m2+ , modDataLayout = modDataLayout m1 <> modDataLayout m2+ , modTypes = modTypes m1 <> modTypes m2+ , modUnnamedMd = modUnnamedMd m1 <> modUnnamedMd m2+ , modNamedMd = modNamedMd m1 <> modNamedMd m2+ , modGlobals = modGlobals m1 <> modGlobals m2+ , modDeclares = modDeclares m1 <> modDeclares m2+ , modDefines = modDefines m1 <> modDefines m2+ , modInlineAsm = modInlineAsm m1 <> modInlineAsm m2+ , modAliases = modAliases m1 <> modAliases m2+ , modComdat = modComdat m1 <> modComdat m2+ }++instance Monoid Module where+ mempty = emptyModule+ mappend = (<>)++emptyModule :: Module+emptyModule = Module+ { modSourceName = mempty+ , modTriple = mempty+ , modDataLayout = mempty+ , modTypes = mempty+ , modNamedMd = mempty+ , modUnnamedMd = mempty+ , modGlobals = mempty+ , modDeclares = mempty+ , modDefines = mempty+ , modInlineAsm = mempty+ , modAliases = mempty+ , modComdat = mempty+ }+++-- Named Metadata --------------------------------------------------------------++data NamedMd = NamedMd+ { nmName :: String+ , nmValues :: [Int]+ } deriving (Data, Eq, Generic, Ord, Show, Typeable)+++-- Unnamed Metadata ------------------------------------------------------------++data UnnamedMd = UnnamedMd+ { umIndex :: !Int+ , umValues :: ValMd+ , umDistinct :: Bool+ } deriving (Data, Eq, Generic, Ord, Show, Typeable)+++-- Aliases ---------------------------------------------------------------------++data GlobalAlias = GlobalAlias+ { aliasLinkage :: Maybe Linkage+ , aliasVisibility :: Maybe Visibility+ , aliasName :: Symbol+ , aliasType :: Type+ , aliasTarget :: Value+ } deriving (Data, Eq, Generic, Ord, Show, Typeable)+++-- Data Layout -----------------------------------------------------------------+-- https://releases.llvm.org/19.1.0/docs/LangRef.html#data-layout++type DataLayout = [LayoutSpec]++data LayoutSpec+ = BigEndian+ | LittleEndian+ | PointerSize PointerSize+ | IntegerSize Storage+ | VectorSize Storage+ | FloatSize Storage+ | StackObjSize Storage+ | AggregateSize (Maybe Int) !Alignment -- n.b. first Int present pre-LLVM4+ | NativeIntSize [NumBits]+ | StackAlign !NumBits -- ^ size+ | ProgramAddrSpace !AddressSpace+ | GlobalAddrSpace !AddressSpace+ | AllocaAddrSpace !AddressSpace+ | FunctionPointerAlign !FunctionPointerAlignType !NumBits -- ^ type, abi+ | Mangling Mangling+ | NonIntegralPointerSpaces [AddressSpace]+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++data Alignment = Alignment+ { alignABI :: !NumBits+ , alignPreferred :: Maybe NumBits -- ^ default = alignABI+ }+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++-- | How should a function pointer be aligned?+data FunctionPointerAlignType+ = IndependentOfFunctionAlign+ -- ^ The alignment of function pointers is independent of the alignment of+ -- functions.+ | MultipleOfFunctionAlign+ -- ^ The alignment of function pointers is a multiple of the explicit+ -- alignment specified on the function.+ deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable)++data Storage = Storage+ { storageSize :: !NumBits -- ^ valid range [1,2^24)+ , storageAlignment :: Alignment+ }+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++data PointerSize = PtrSize+ { ptrAddrSpace :: !AddressSpace+ , ptrStorage :: Storage+ , ptrAddrIndexSize :: Maybe NumBits -- ^ m.b. <= ptrSize, default = ptrSize+ }+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++type AddressSpace = Int+type NumBits = Int++data Mangling = ElfMangling+ | GoffMangling+ | MipsMangling+ | MachOMangling+ | WindowsCoffMangling+ | WindowsX86CoffMangling+ | XCoffMangling+ deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable)++-- | Parse the data layout string.+parseDataLayout :: MonadPlus m => String -> m DataLayout+parseDataLayout str =+ case parse (pDataLayout <* eof) "<internal>" str of+ Left _err -> {- debugging: trace (show err) -} mzero+ Right specs -> return specs+ where+ pDataLayout :: Parser DataLayout+ pDataLayout = sepBy pLayoutSpec (char '-')++ pLayoutSpec :: Parser LayoutSpec+ pLayoutSpec =+ do c <- letter+ case c of+ 'E' -> return BigEndian+ 'e' -> return LittleEndian+ 'S' -> StackAlign <$> pInt+ 'P' -> ProgramAddrSpace <$> pInt -- Added in LLVM7+ 'G' -> GlobalAddrSpace <$> pInt -- Added in LLVM11+ 'A' -> AllocaAddrSpace <$> pInt -- Added in LLVM11+ 'p' -> do as <- pInt <|> return 0+ st <- char ':' >> pStorage+ idx <- pCOInt -- Added in LLVM7+ return $ PointerSize $ PtrSize as st idx+ 'i' -> IntegerSize <$> pStorage+ 'v' -> VectorSize <$> pStorage+ 'f' -> FloatSize <$> pStorage+ -- Note that the data layout specified in the LLVM+ -- BC/IR file is not a directive to the backend, but+ -- is instead an indication of what the particular+ -- backend chosen expects to receive. The actual+ -- floating point size and alignment is specified as+ -- zero or more "fSZ:A1:A2" portions of the+ -- datawidth, where SZ is the size, A1 is the ABI+ -- alignment, and A2 is the preferred alignment+ -- (defaulting to A1 if not specified). Not+ -- included in the data layout is the actual width,+ -- alignment, and format for implementation. See+ -- (for example) references to LongDoubleWidth and+ -- LongDoubleFormat in+ -- https://github.com/llvm/llvm-project/blob/release_60/clang/lib/Basic/Targets/X86.h+ 's' -> StackObjSize <$> pStorage -- Obsoleted in LLVM4+ 'a' -> alphaNum >>= \case+ ':' -> AggregateSize Nothing <$> pAlignment+ d -> AggregateSize <$> (Just <$> pIntWithFirstDigit d)+ <* char ':' <*> pAlignment+ 'F' -> FunctionPointerAlign <$> pFunctionPointerAlignType <*> pInt -- Added in LLVM9+ 'm' -> Mangling <$ char ':' <*> pMangling+ 'n' -> alphaNum >>= \case+ 'i' -> char ':'+ >> (NonIntegralPointerSpaces <$> sepBy pInt (char ':'))+ d -> do fs <- pIntWithFirstDigit d+ ss <- char ':' *> sepBy pInt (char ':')+ return $ NativeIntSize $ fs : ss+ _ -> mzero++ pFunctionPointerAlignType :: Parser FunctionPointerAlignType+ pFunctionPointerAlignType =+ do c <- letter+ case c of+ 'i' -> return IndependentOfFunctionAlign+ 'n' -> return MultipleOfFunctionAlign+ _ -> mzero++ pMangling :: Parser Mangling+ pMangling =+ do c <- letter+ case c of+ 'e' -> return ElfMangling+ 'l' -> return GoffMangling+ 'm' -> return MipsMangling+ 'o' -> return MachOMangling+ 'w' -> return WindowsCoffMangling+ 'x' -> return WindowsX86CoffMangling+ 'a' -> return XCoffMangling+ _ -> mzero++ pAlignment :: Parser Alignment+ pAlignment = Alignment <$> pInt <*> pCOInt++ pStorage :: Parser Storage+ pStorage = Storage <$> pInt <* char ':' <*> pAlignment++ pInt :: Parser Int+ pInt = read <$> many1 digit++ pIntWithFirstDigit :: Char -> Parser Int+ pIntWithFirstDigit d0 = read . (d0:) <$> many digit++ pCInt :: Parser Int+ pCInt = char ':' >> pInt++ pCOInt :: Parser (Maybe Int)+ pCOInt = optionMaybe pCInt++-- Inline Assembly -------------------------------------------------------------++type InlineAsm = [String]++-- Comdat ----------------------------------------------------------------------++data SelectionKind = ComdatAny+ | ComdatExactMatch+ | ComdatLargest+ | ComdatNoDuplicates+ | ComdatSameSize+ deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable)++-- Identifiers -----------------------------------------------------------------++newtype Ident = Ident String+ deriving (Data, Eq, Generic, Ord, Show, Typeable, Lift)++instance IsString Ident where+ fromString = Ident++-- Symbols ---------------------------------------------------------------------++newtype Symbol = Symbol String+ deriving (Data, Eq, Generic, Ord, Show, Typeable, Lift)++instance Sem.Semigroup Symbol where+ Symbol a <> Symbol b = Symbol (a <> b)++instance Monoid Symbol where+ mappend = (<>)+ mempty = Symbol mempty++instance IsString Symbol where+ fromString = Symbol++-- Types -----------------------------------------------------------------------++data PrimType+ = Label+ | Void+ | Integer Word32+ | FloatType FloatType+ | X86mmx+ | Metadata+ deriving (Data, Eq, Generic, Ord, Show, Typeable, Lift)++data FloatType+ = Half+ | Float+ | Double+ | Fp128+ | X86_fp80+ | PPC_fp128+ deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable, Lift)++type Type = Type' Ident++data Type' ident+ = PrimType PrimType+ | Alias ident+ | Array Word64 (Type' ident)+ | FunTy (Type' ident) [Type' ident] Bool+ | PtrTo (Type' ident) AddrSpace+ -- ^ A pointer to a memory location of a particular type. See also+ -- 'PtrOpaque', which represents a pointer without a pointee type.+ | PtrOpaque AddrSpace+ -- ^ A pointer to a memory location. Unlike 'PtrTo', a 'PtrOpaque' does not+ -- have a pointee type. Instead, instructions interacting through opaque+ -- pointers specify the type of the underlying memory they are interacting+ -- with.+ --+ -- 'PtrOpaque' should not be confused with 'Opaque', which is a completely+ -- separate type with a similar-sounding name.+ | Struct [Type' ident]+ | PackedStruct [Type' ident]+ | Vector Word64 (Type' ident)+ | Opaque+ -- ^ An opaque structure type, used to represent structure types that do not+ -- have a body specified. This is similar to C's notion of a+ -- forward-declared structure.+ --+ -- 'Opaque' should not be confused with 'PtrOpaque', which is a completely+ -- separate type with a similar-sounding name.+ deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++data AddrSpace = AddrSpace Word32+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++defaultAddrSpace :: AddrSpace+defaultAddrSpace = AddrSpace 0++-- | Applicatively traverse a type, updating or removing aliases.+updateAliasesA :: (Applicative f) => (a -> f (Type' b)) -> Type' a -> f (Type' b)+updateAliasesA f = loop+ where+ loop ty = case ty of+ Array len ety -> Array len <$> (loop ety)+ FunTy res ps var -> FunTy <$> (loop res) <*> (traverse loop ps) <*> pure var+ PtrTo pty addr -> PtrTo <$> (loop pty) <*> pure addr+ PtrOpaque addr -> pure (PtrOpaque addr)+ Struct fs -> Struct <$> (traverse loop fs)+ PackedStruct fs -> PackedStruct <$> (traverse loop fs)+ Vector len ety -> Vector <$> pure len <*> (loop ety)+ PrimType pty -> pure $ PrimType pty+ Opaque -> pure $ Opaque+ Alias lab -> f lab++-- | Traverse a type, updating or removing aliases.+updateAliases :: (a -> Type' b) -> Type' a -> Type' b+updateAliases f = coerce $ updateAliasesA (Identity . f)++isFloatingPoint :: PrimType -> Bool+isFloatingPoint (FloatType _) = True+isFloatingPoint _ = False++isAlias :: Type' ident -> Bool+isAlias Alias{} = True+isAlias _ = False++isPrimTypeOf :: (PrimType -> Bool) -> Type' ident -> Bool+isPrimTypeOf p (PrimType pt) = p pt+isPrimTypeOf _ _ = False++isLabel :: PrimType -> Bool+isLabel Label = True+isLabel _ = False++isInteger :: PrimType -> Bool+isInteger Integer{} = True+isInteger _ = False++isVector :: Type' ident -> Bool+isVector Vector{} = True+isVector _ = False++isVectorOf :: (Type' ident -> Bool) -> Type' ident -> Bool+isVectorOf p (Vector _ e) = p e+isVectorOf _ _ = False++isArray :: Type' ident -> Bool+isArray ty = case ty of+ Array _ _ -> True+ _ -> False++isPointer :: Type' ident -> Bool+isPointer PtrTo{} = True+isPointer PtrOpaque{} = True+isPointer _ = False+++-- | Like `Type'`, but where the 'PtrTo' and 'PtrOpaque' constructors have been+-- collapsed into a single 'PtrView' constructor. This provides a coarser notion+-- of type equality than what `Type'` provides, which distinguishes the two+-- types of pointers.+--+-- `TypeView'` is not used directly in any of the other AST types. Instead, it+-- is used only as an internal data type to power the 'eqTypeModuloOpaquePtrs'+-- and 'cmpTypeModuloOpaquePtrs' functions.+data TypeView' ident+ = PrimTypeView PrimType+ | AliasView ident+ | ArrayView Word64 (TypeView' ident)+ | FunTyView (TypeView' ident) [TypeView' ident] Bool+ | PtrView+ -- ^ The sole pointer type. Both 'PtrTo' and 'PtrOpaque' are mapped to+ -- 'PtrView'.+ | StructView [TypeView' ident]+ | PackedStructView [TypeView' ident]+ | VectorView Word64 (TypeView' ident)+ | OpaqueView+ -- ^ An opaque structure type, used to represent structure types that do not+ -- forward-declared structure.+ --+ -- 'OpaqueView' should not be confused with opaque pointers, which are+ -- mapped to 'PtrView'.+ deriving (Eq, Ord)++-- | Convert a `Type'` value to a `TypeView'` value.+typeView :: Type' ident -> TypeView' ident+-- The two most important cases. Both forms of pointers are mapped to PtrView.+typeView PtrTo{} = PtrView+typeView PtrOpaque{} = PtrView+-- All other cases are straightforward.+typeView (PrimType pt) = PrimTypeView pt+typeView (Alias lab) = AliasView lab+typeView (Array len et) = ArrayView len (typeView et)+typeView (FunTy ret args va) = FunTyView (typeView ret) (map typeView args) va+typeView (Struct fs) = StructView (map typeView fs)+typeView (PackedStruct fs) = PackedStructView (map typeView fs)+typeView (Vector len et) = VectorView len (typeView et)+typeView Opaque = OpaqueView++-- | Check two 'Type's for equality, but treat 'PtrOpaque' types as being equal+-- to @'PtrTo' ty@ types (for any type @ty@). This is a coarser notion of+-- equality than what is provided by the 'Eq' instance for 'Type'.+eqTypeModuloOpaquePtrs :: Eq ident => Type' ident -> Type' ident -> Bool+eqTypeModuloOpaquePtrs x y = typeView x == typeView y++-- | Compare two 'Type's, but treat 'PtrOpaque' types as being equal to+-- @'PtrTo' ty@ types (for any type @ty@). This is a coarser notion of ordering+-- than what is provided by the 'Ord' instance for 'Type'.+cmpTypeModuloOpaquePtrs :: Ord ident => Type' ident -> Type' ident -> Ordering+cmpTypeModuloOpaquePtrs x y = typeView x `compare` typeView y++-- | Ensure that if there are any occurrences of opaque pointers, then all+-- non-opaque pointers are converted to opaque ones.+--+-- This is useful because LLVM tools like @llvm-as@ are stricter than+-- @llvm-pretty@ in that the former forbids mixing opaque and non-opaque+-- pointers, whereas the latter allows this. As a result, the result of+-- pretty-printing an @llvm-pretty@ AST might not be suitable for @llvm-as@'s+-- needs unless you first call this function to ensure that the two types of+-- pointers are not intermixed.+--+-- This is implemented using "Data.Data" combinators under the hood, which could+-- potentially require a full traversal of the AST. Because of the performance+-- implications of this, we do not call 'fixupOpaquePtrs' in @llvm-pretty@'s+-- pretty-printer. If you wish to combine opaque and non-opaque pointers in your+-- AST, the burden is on you to call this function before pretty-printing.+fixupOpaquePtrs :: Data a => a -> a+fixupOpaquePtrs m+ | isJust (gfind isOpaquePtr m)+ = everywhere (mkT opaquifyPtr) m+ | otherwise+ = m+ where+ isOpaquePtr :: Type -> Bool+ isOpaquePtr PtrOpaque{} = True+ isOpaquePtr _ = False++ opaquifyPtr :: Type -> Type+ opaquifyPtr (PtrTo _ addr) = PtrOpaque addr+ opaquifyPtr t = t++ -- Find the first occurrence of a @b@ value within the @a@ value that+ -- satisfies the predicate and return it with 'Just'. Return 'Nothing' if there+ -- are no such occurrences.+ gfind :: (Data a, Typeable b) => (b -> Bool) -> a -> Maybe b+ gfind p = something (const Nothing `extQ` \x -> if p x then Just x else Nothing)++-- Null Values -----------------------------------------------------------------++data NullResult lab+ = HasNull (Value' lab)+ | ResolveNull Ident+ deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++primTypeNull :: PrimType -> Value' lab+primTypeNull (Integer 1) = ValBool False+primTypeNull (Integer _) = ValInteger 0+primTypeNull (FloatType ft) = floatTypeNull ft+primTypeNull _ = ValZeroInit++floatTypeNull :: FloatType -> Value' lab+floatTypeNull Float = ValFloat 0+floatTypeNull Double = ValDouble 0 -- XXX not sure about this+floatTypeNull X86_fp80 = ValFP80 $ FP80_LongDouble 0 0+floatTypeNull _ = error "must be a float type"++typeNull :: Type -> NullResult lab+typeNull (PrimType pt) = HasNull (primTypeNull pt)+typeNull PtrTo{} = HasNull ValNull+typeNull PtrOpaque{} = HasNull ValNull+typeNull (Alias i) = ResolveNull i+typeNull _ = HasNull ValZeroInit++-- Type Elimination ------------------------------------------------------------++elimFunTy :: MonadPlus m => Type -> m (Type,[Type],Bool)+elimFunTy (FunTy ret args va) = return (ret,args,va)+elimFunTy _ = mzero++elimAlias :: MonadPlus m => Type -> m Ident+elimAlias (Alias i) = return i+elimAlias _ = mzero++elimPtrTo :: MonadPlus m => Type -> m Type+elimPtrTo (PtrTo ty _) = return ty+elimPtrTo _ = mzero++elimVector :: MonadPlus m => Type -> m (Word64,Type)+elimVector (Vector n pty) = return (n,pty)+elimVector _ = mzero++elimArray :: MonadPlus m => Type -> m (Word64, Type)+elimArray (Array n ety) = return (n, ety)+elimArray _ = mzero++elimFunPtr :: MonadPlus m => Type -> m (Type,[Type],Bool)+elimFunPtr = elimFunTy <=< elimPtrTo++elimPrimType :: MonadPlus m => Type -> m PrimType+elimPrimType (PrimType pt) = return pt+elimPrimType _ = mzero++elimFloatType :: MonadPlus m => PrimType -> m FloatType+elimFloatType (FloatType ft) = return ft+elimFloatType _ = mzero++-- | Eliminator for array, pointer and vector types.+elimSequentialType :: MonadPlus m => Type -> m Type+elimSequentialType ty = case ty of+ Array _ elTy -> return elTy+ PtrTo elTy _ -> return elTy+ Vector _ pty -> return pty+ _ -> mzero+++-- Top-level Type Aliases ------------------------------------------------------++data TypeDecl = TypeDecl+ { typeName :: Ident+ , typeValue :: Type+ } deriving (Data, Eq, Generic, Ord, Show, Typeable)+++-- Globals ---------------------------------------------------------------------++data Global = Global+ { globalSym :: Symbol+ , globalAttrs :: GlobalAttrs+ , globalType :: Type+ , globalValue :: Maybe Value+ , globalAlign :: Maybe Align+ , globalMetadata :: GlobalMdAttachments+ } deriving (Data, Eq, Generic, Ord, Show, Typeable)++addGlobal :: Global -> Module -> Module+addGlobal g m = m { modGlobals = g : modGlobals m }++data GlobalAttrs = GlobalAttrs+ { gaLinkage :: Maybe Linkage+ , gaVisibility :: Maybe Visibility+ , gaAddrSpace :: AddrSpace+ , gaConstant :: Bool+ } deriving (Data, Eq, Generic, Ord, Show, Typeable)++emptyGlobalAttrs :: GlobalAttrs+emptyGlobalAttrs = GlobalAttrs+ { gaLinkage = Nothing+ , gaVisibility = Nothing+ , gaAddrSpace = defaultAddrSpace+ , gaConstant = False+ }+++-- Declarations ----------------------------------------------------------------++data Declare = Declare+ { decLinkage :: Maybe Linkage+ , decVisibility :: Maybe Visibility+ , decRetType :: Type+ , decName :: Symbol+ , decArgs :: [Type]+ , decVarArgs :: Bool+ , decAttrs :: [FunAttr]+ , decComdat :: Maybe String+ } deriving (Data, Eq, Generic, Ord, Show, Typeable)++-- | The function type of this declaration+decFunType :: Declare -> Type+decFunType Declare { .. } = PtrTo (FunTy decRetType decArgs decVarArgs) defaultAddrSpace+++-- Function Definitions --------------------------------------------------------++data Define = Define+ { defLinkage :: Maybe Linkage+ , defVisibility :: Maybe Visibility+ , defRetType :: Type+ , defName :: Symbol+ , defArgs :: [Typed Ident]+ , defVarArgs :: Bool+ , defAttrs :: [FunAttr]+ , defSection :: Maybe String+ , defGC :: Maybe GC+ , defBody :: [BasicBlock]+ , defMetadata :: FnMdAttachments+ , defComdat :: Maybe String+ } deriving (Data, Eq, Generic, Ord, Show, Typeable)++defFunType :: Define -> Type+defFunType Define { .. } =+ PtrTo (FunTy defRetType (map typedType defArgs) defVarArgs) defaultAddrSpace++addDefine :: Define -> Module -> Module+addDefine d m = m { modDefines = d : modDefines m }++-- Function Attributes and attribute groups ------------------------------------+++data FunAttr+ = AlignStack Int+ | Alwaysinline+ | Builtin+ | Cold+ | Convergent -- ^ Introduced in LLVM 3.7+ | InaccessibleMemOnly -- ^ Introduced in LLVM 3.8+ | Inlinehint+ | Jumptable+ | Minsize+ | Naked+ | Nobuiltin+ | Noduplicate+ | Noimplicitfloat+ | Noinline+ | Nonlazybind+ | Noredzone+ | Noreturn+ | Nounwind+ | Optnone+ | Optsize+ | Readnone+ | Readonly+ | ReturnsTwice+ | SanitizeAddress+ | SanitizeMemory+ | SanitizeThread+ | SSP+ | SSPreq+ | SSPstrong+ | UWTable+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++-- Basic Block Labels ----------------------------------------------------------++data BlockLabel+ = Named Ident+ | Anon Int+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++instance IsString BlockLabel where+ fromString str = Named (fromString str)++-- Basic Blocks ----------------------------------------------------------------++data BasicBlock' lab = BasicBlock+ { bbLabel :: Maybe lab+ , bbStmts :: [Stmt' lab]+ } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type BasicBlock = BasicBlock' BlockLabel++brTargets :: BasicBlock' lab -> [lab]+brTargets (BasicBlock _ stmts) =+ case stmtInstr (last stmts) of+ Br _ t1 t2 -> [t1, t2]+ Invoke _ _ _ to uw -> [to, uw]+ Jump t -> [t]+ Switch _ l ls -> l : map snd ls+ IndirectBr _ ls -> ls+ _ -> []++-- Attributes ------------------------------------------------------------------++-- | Symbol Linkage+data Linkage+ = Private+ | LinkerPrivate+ | LinkerPrivateWeak+ | LinkerPrivateWeakDefAuto+ | Internal+ | AvailableExternally+ | Linkonce+ | Weak+ | Common+ | Appending+ | ExternWeak+ | LinkonceODR+ | WeakODR+ | External+ | DLLImport+ | DLLExport+ deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable)++data Visibility = DefaultVisibility+ | HiddenVisibility+ | ProtectedVisibility+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++newtype GC = GC+ { getGC :: String+ } deriving (Data, Eq, Generic, Ord, Show, Typeable)++-- Typed Things ----------------------------------------------------------------++data Typed a = Typed+ { typedType :: Type+ , typedValue :: a+ } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++instance Foldable Typed where+ foldMap f t = f (typedValue t)++instance Traversable Typed where+ sequenceA t = mk `fmap` typedValue t+ where+ mk b = t { typedValue = b }++mapMTyped :: Monad m => (a -> m b) -> Typed a -> m (Typed b)+mapMTyped f t = do+ b <- f (typedValue t)+ return t { typedValue = b }++-- Instructions ----------------------------------------------------------------++data ArithOp+ = Add Bool Bool+ {- ^ * Integral addition.+ * First boolean flag: check for unsigned overflow.+ * Second boolean flag: check for signed overflow.+ * If the checks fail, then the result is poisoned. -}+ | FAdd [FMF]+ -- ^ Floating point addition.++ | Sub Bool Bool+ {- ^ * Integral subtraction.+ * First boolean flag: check for unsigned overflow.+ * Second boolean flag: check for signed overflow.+ * If the checks fail, then the result is poisoned. -}++ | FSub [FMF]+ -- ^ Floating point subtraction.++ | Mul Bool Bool+ {- ^ * Integral multiplication.+ * First boolean flag: check for unsigned overflow.+ * Second boolean flag: check for signed overflow.+ * If the checks fail, then the result is poisoned. -}++ | FMul [FMF]+ -- ^ Floating point multiplication.++ | UDiv Bool+ {- ^ * Integral unsigned division.+ * Boolean flag: check for exact result.+ * If the check fails, then the result is poisoned. -}++ | SDiv Bool+ {- ^ * Integral signed division.+ * Boolean flag: check for exact result.+ * If the check fails, then the result is poisoned. -}++ | FDiv [FMF]+ -- ^ Floating point division.++ | URem+ -- ^ Integral unsigned reminder resulting from unsigned division.+ -- Division by 0 is undefined.++ | SRem+ -- ^ * Integral signded reminder resulting from signed division.+ -- * The sign of the reminder matches the divident (first parameter).+ -- * Division by 0 is undefined.++ | FRem [FMF]+ -- ^ * Floating point reminder resulting from floating point division.+ -- * The reminder has the same sign as the divident (first parameter).++ deriving (Data, Eq, Generic, Ord, Show, Typeable)++isIArith :: ArithOp -> Bool+isIArith Add{} = True+isIArith Sub{} = True+isIArith Mul{} = True+isIArith UDiv{} = True+isIArith SDiv{} = True+isIArith URem = True+isIArith SRem = True+isIArith _ = False++isFArith :: ArithOp -> Bool+isFArith = not . isIArith++data UnaryArithOp+ = FNeg [FMF]+ -- ^ Floating point negation.+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++-- | Binary bitwise operators.+data BitOp+ = Shl Bool Bool+ {- ^ * Shift left.+ * First bool flag: check for unsigned overflow (i.e., shifted out a 1).+ * Second bool flag: check for signed overflow+ (i.e., shifted out something that does not match the sign bit)++ If a check fails, then the result is poisoned.++ The value of the second parameter must be strictly less than the+ number of bits in the first parameter,+ otherwise the result is undefined. -}++ | Lshr Bool+ {- ^ * Logical shift right.+ * The boolean is for exact check: poison the result,+ if we shift out a 1 bit (i.e., had to round).++ The value of the second parameter must be strictly less than the+ number of bits in the first parameter, otherwise the result is undefined.+ -}++ | Ashr Bool+ {- ^ * Arithmetic shift right.+ * The boolean is for exact check: poison the result,+ if we shift out a 1 bit (i.e., had to round).++ The value of the second parameter must be strictly less than the+ number of bits in the first parameter, otherwise the result is undefined.+ -}++ | And+ | Or+ | Xor+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++-- | Conversions from one type to another.+data ConvOp+ = Trunc Bool Bool+ -- ^ Truncate an integer value to a smaller integer type.+ --+ -- The 'Bool' fields (added in in LLVM 20) encode whether to perform+ -- overflow-related checks:+ --+ -- * First 'Bool': check for unsigned overflow.+ -- * Second 'Bool': check for signed overflow.+ --+ -- If the checks fail, then the result is poisoned.+ --+ -- These fields can only ever 'True' in 'Conv' instructions in LLVM 20 or+ -- later. These fields are always 'False' in 'ConstConv' constant+ -- expressions or if the LLVM version is older than 20.+ | ZExt Bool+ -- ^ Zero extension.+ --+ -- The 'Bool' field (added in LLVM 18) encodes whether to enforce that the+ -- argument is non-negative. If the 'Bool' is 'True' and the argument is+ -- negative, then the result is poisoned.+ --+ -- This field can only ever 'True' in 'Conv' instructions in LLVM 18 or+ -- later. This field is always 'False' in 'ConstConv' constant expressions+ -- or if the LLVM version is older than 18.+ | SExt+ | FpTrunc+ | FpExt+ | FpToUi+ | FpToSi+ | UiToFp Bool+ -- ^ Convert the argument from an unsigned integer to a floating-point+ -- value.+ --+ -- The 'Bool' field (added in LLVM 19) encodes whether to enforce that the+ -- argument is non-negative. If the 'Bool' is 'True' and the argument is+ -- negative, then the result is poisoned.+ --+ -- This field can only ever 'True' in 'Conv' instructions in LLVM 19 or+ -- later. This field is always 'False' in 'ConstConv' constant expressions+ -- or if the LLVM version is older than 19.+ | SiToFp+ | PtrToInt+ | IntToPtr+ | BitCast+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++data AtomicRWOp+ = AtomicXchg+ | AtomicAdd+ | AtomicSub+ | AtomicAnd+ | AtomicNand+ | AtomicOr+ | AtomicXor+ | AtomicMax+ | AtomicMin+ | AtomicUMax+ | AtomicUMin+ | AtomicFAdd -- ^ Introduced in LLVM 9+ | AtomicFSub -- ^ Introduced in LLVM 9+ | AtomicFMax -- ^ Introduced in LLVM 15+ | AtomicFMin -- ^ Introduced in LLVM 15+ | AtomicUIncWrap -- ^ Introduced in LLVM 16+ | AtomicUDecWrap -- ^ Introduced in LLVM 16+ deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable)++data AtomicOrdering+ = Unordered+ | Monotonic+ | Acquire+ | Release+ | AcqRel+ | SeqCst+ deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable)++type Align = Int++data Instr' lab+ = Ret (Typed (Value' lab))+ {- ^ * Return from function with the given value.+ * Ends basic block. -}++ | RetVoid+ {- ^ * Return from function.+ * Ends basic block. -}++ | Arith ArithOp (Typed (Value' lab)) (Value' lab)+ {- ^ * Binary arithmetic operation, both operands have the same type.+ * Middle of basic block.+ * The result is the same as parameters. -}++ | UnaryArith UnaryArithOp (Typed (Value' lab))+ {- ^ * Unary arithmetic operation.+ * Middle of basic block.+ * The result is the same as the parameter. -}++ | Bit BitOp (Typed (Value' lab)) (Value' lab)+ {- ^ * Binary bit-vector operation, both operands have the same type.+ * Middle of basic block.+ * The result is the same as parameters. -}++ | Conv ConvOp (Typed (Value' lab)) Type+ {- ^ * Convert a value from one type to another.+ * Middle of basic block.+ * The result matches the 3rd parameter.+ Note: fptrunc and fpext allow fast-math flags in LLVM, but this is not represented yet. -}++ | Call Bool [FMF] Type (Value' lab) [Typed (Value' lab)]+ {- ^ * Call a function.+ The boolean is tail-call hint (XXX: needs to be updated)+ * Middle of basic block.+ * The result is as indicated by the provided type.+ * Fast-math flags are only allowed if the type is a floating-point type; see LLVM documentation. -}++ | CallBr Type (Value' lab) [Typed (Value' lab)] lab [lab]+ {- ^ * Call a function in asm-goto style:+ return type;+ function operand;+ arguments;+ default basic block destination;+ other basic block destinations.+ * Middle of basic block.+ * The result is as indicated by the provided type.+ * Introduced in LLVM 9. -}++ | Alloca Type (Maybe (Typed (Value' lab))) (Maybe Int)+ {- ^ * Allocated space on the stack:+ type of elements;+ how many elements (1 if 'Nothing');+ required alignment.+ * Middle of basic block.+ * Returns a pointer to hold the given number of elements. -}++ | Load Bool Type (Typed (Value' lab)) (Maybe AtomicOrdering) (Maybe Align)+ {- ^ * Read a value from the given address:+ whether the load is volatile;+ type being loaded;+ address to read from;+ atomic ordering;+ assumptions about alignment of the given pointer.+ * Middle of basic block.+ * Returns a value of type matching the pointer. -}++ | Store Bool (Typed (Value' lab)) (Typed (Value' lab)) (Maybe AtomicOrdering) (Maybe Align)+ {- ^ * Write a value to memory:+ whether the store is volatile;+ value to store;+ pointer to location where to store;+ atomic ordering;+ assumptions about the alignment of the given pointer.+ * Middle of basic block.+ * Effect. -}+++ | Fence (Maybe String) AtomicOrdering+ {- ^ * Introduce a happens-before relationship between operations:+ synchronization scope;+ type of ordering.+ * Middle of basic block. -}++ | CmpXchg Bool Bool (Typed (Value' lab)) (Typed (Value' lab)) (Typed (Value' lab)) (Maybe String) AtomicOrdering AtomicOrdering+ {- ^ * Atomically compare and maybe exchange values in memory:+ whether the exchange is weak;+ whether the exchange is volatile;+ pointer to read;+ value to compare it with;+ new value to write if the two prior values are equal;+ synchronization scope;+ synchronization ordering on success;+ synchronization ordering on failure.+ * Returns a pair of the original value and whether an exchange occurred.+ * Middle of basic block.+ * Effect. -}++ | AtomicRW Bool AtomicRWOp (Typed (Value' lab)) (Typed (Value' lab)) (Maybe String) AtomicOrdering+ {- ^ * Perform an atomic load, operation, and store:+ whether the operation is volatile;+ operation to apply to the read value and the provided value;+ pointer to read;+ value to combine it with, using the given operation;+ synchronization scope;+ synchronization ordering.+ * Returns the original value at the given location.+ * Middle of basic block.+ * Effect. -}++ | ICmp Bool ICmpOp (Typed (Value' lab)) (Value' lab)+ {- ^ * Compare two integral values.+ * Middle of basic block.+ * Returns a boolean value.+ * The 'Bool' field (added in LLVM 20) encodes whether to enforce that+ the arguments have the same sign. If the 'Bool' is 'True' and the+ arguments have mismatched signs, then the result is poisoned. This+ field is always 'False' if the LLVM version is older than 20. -}++ | FCmp [FMF] FCmpOp (Typed (Value' lab)) (Value' lab)+ {- ^ * Compare two floating point values.+ * Middle of basic block.+ * Returns a boolean value. -}++ | Phi [FMF] Type [(Value' lab,lab)]+ {- ^ * Join point for an SSA value: we get one value per predecessor+ basic block.+ * Middle of basic block.+ * Returns a value of the specified type.+ * Fast-math flags are only allowed if the type is a floating-point type; see LLVM documentation. -}++ | GEP [GEPAttr] Type (Typed (Value' lab)) [Typed (Value' lab)]+ {- ^ * "Get element pointer",+ compute the address of a field in a structure:+ inbounds check attr (value poisoned if this fails);+ type to use as a basis for calculations;+ pointer to parent structure;+ path to a sub-component of a structure.+ * Middle of basic block.+ * Returns the address of the requested member.++ It's recommended that the GEPAttr list should be normalized (i.e. only one of+ each entry).++ The types in path are the types of the index, not the fields.++ The indexes are in units of fields (i.e., the first element in+ a struct is field 0, the next one is 1, etc., regardless of the size+ of the fields in bytes). -}++ | Select [FMF] (Typed (Value' lab)) (Typed (Value' lab)) (Value' lab)+ {- ^ * Local if-then-else; the first argument is boolean, if+ true pick the 2nd argument, otherwise evaluate to the 3rd.+ * Middle of basic block.+ * Returns either the 2nd or the 3rd argument.+ * Fast-math flags are only allowed if the type is a floating-point type; see LLVM documentation.-}++ | ExtractValue (Typed (Value' lab)) [Int32]+ {- ^ * Get the value of a member of an aggregate value:+ the first argument is an aggregate value (not a pointer!),+ the second is a path of indexes, similar to the one in 'GEP'.+ * Middle of basic block.+ * Returns the given member of the aggregate value. -}++ | InsertValue (Typed (Value' lab)) (Typed (Value' lab)) [Int32]+ {- ^ * Set the value for a member of an aggregate value:+ the first argument is the value to insert, the second is the+ aggreagate value to be modified.+ * Middle of basic block.+ * Returns an updated aggregate value. -}++ | ExtractElt (Typed (Value' lab)) (Value' lab)+ {- ^ * Get an element from a vector: the first argument is a vector,+ the second an index.+ * Middle of basic block.+ * Returns the element at the given position. -}++ | InsertElt (Typed (Value' lab)) (Typed (Value' lab)) (Value' lab)+ {- ^ * Modify an element of a vector: the first argument is the vector,+ the second the value to be inserted, the third is the index where+ to insert the value.+ * Middle of basic block.+ * Returns an updated vector. -}+++ | ShuffleVector (Typed (Value' lab)) (Value' lab) (Typed (Value' lab))+ {- ^ * Constructs a fixed permutation of two input vectors: the first+ and second arguments are input vectors, and the third argument+ is the mask.+ * Middle of basic block.+ * Returns the permuted vector. For each element, the mask selects+ an element from one of the input vectors to copy to the result:+ * non-negative mask values represent an index into the concatenated+ pair of input vectors, and+ * -1 mask value indicates that the output element is poison.+ -}++ | Jump lab+ {- ^ * Jump to the given basic block.+ * Ends basic block. -}++ | Br (Typed (Value' lab)) lab lab+ {- ^ * Conditional jump: if the value is true jump to the first basic+ block, otherwise jump to the second.+ * Ends basic block. -}++ | Invoke Type (Value' lab) [Typed (Value' lab)] lab lab+ {- ^ * Calls the specified target function, then branches to the success+ label. If an exception occurs during the call, the exception unwind+ handling branches to the second label.+ * Arguments:+ 1. The function's return type+ 2. The function target itself (to be called)+ 3. arguments to the function+ 4. successful return target label+ 5. on-exception unwind target label+ * Ends basic block. -}++ | Comment String+ -- ^ Comment++ | Unreachable+ -- ^ No defined sematics, we should not get to here.++ | Unwind+ | VaArg (Typed (Value' lab)) Type+ -- ^ Accesses arguments passed through \"varargs\" areas of a function call.+ -- The argument is a @va_list*@; this instruction returns the value of the+ -- specified type located at the target and increments the pointer.++ | IndirectBr (Typed (Value' lab)) [lab]+ -- ^ Branch via pointer indirection. The argument is the address of the+ -- label to jump to. (All) Possible destination targets are provided.++ | Switch (Typed (Value' lab)) lab [(Integer,lab)]+ {- ^ * Multi-way branch: the first value determines the target index+ for the jump, which is looked up in the third argument table+ (key values are unique). The second argument is the default+ destination if the target is not found in the table.+ * Ends basic block. -}++ | LandingPad Type (Maybe (Typed (Value' lab))) Bool [Clause' lab]+ {- ^ Target of an exception (from the 'Invoke' instruction).+ * Arguments:+ 1. The result type (the values set by the personality function+ on re-entry to the function).+ 2. The second argument may be the personality function, which defines+ values on re-entry. This is used in older LLVM versions and is+ not supplied for recent LLVM versions.+ 3. True if this block is a "cleanup".+ 4. The list of clauses to handle the exception; the clauses are+ used to match the exception thrown.+ * If no clause matches and cleanup not set, continue unwinding up+ the stack (see 'Resume').+ * If cleanup is false, there must be at least one clause+ -}++ | Resume (Typed (Value' lab))+ {- ^ Resumes propagation of an in-flight exception whose unwinding was+ interrupted by a 'LandingPad' instruction.+ * Argument: the value of the exception to propagate.+ -}++ | Freeze (Typed (Value' lab))+ {- ^ * Used to stop propagation of @undef@ and @poison@ values.+ * If the argument is @undef@ or @poison@, returns an arbitrary+ (but fixed) value of that type instead, otherwise a no-op and+ returns its argument.+ * Middle of basic block. -}++ deriving (Data, Eq, Functor, Generic, Ord, Show, Typeable)++type Instr = Instr' BlockLabel++data Clause' lab+ = Catch (Typed (Value' lab))+ | Filter (Typed (Value' lab))+ deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type Clause = Clause' BlockLabel+++isTerminator :: Instr' lab -> Bool+isTerminator instr = case instr of+ Ret{} -> True+ RetVoid -> True+ Jump{} -> True+ CallBr{} -> True+ Br{} -> True+ Unreachable -> True+ Unwind -> True+ Invoke{} -> True+ IndirectBr{} -> True+ Switch{} -> True+ Resume{} -> True+ _ -> False++isComment :: Instr' lab -> Bool+isComment Comment{} = True+isComment _ = False++isPhi :: Instr' lab -> Bool+isPhi Phi{} = True+isPhi _ = False++-- | Integer comparison operators.+data ICmpOp = Ieq | Ine | Iugt | Iuge | Iult | Iule | Isgt | Isge | Islt | Isle+ deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable)++-- | Floating-point comparison operators.+data FCmpOp = Ffalse | Foeq | Fogt | Foge | Folt | Fole | Fone+ | Ford | Fueq | Fugt | Fuge | Fult | Fule | Fune+ | Funo | Ftrue+ deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable)++-- | Fast-math flags. <https://llvm.org/docs/LangRef.html#fast-math-flags>+data FMF+ = Ffast -- ^ Short-hand for all other flags combined+ | Fnnan -- ^ No NaNs+ | Fninf -- ^ No infs+ | Fnsz -- ^ No signed zeros+ | Farcp -- ^ Allow reciprocal (a / b == a * (1.0 / b))+ | Fcontract -- ^ Allow contraction (e.g. fused multiply-add)+ | Fafn -- ^ Approximate functions (for sqrt, sin, log, etc.)+ | Freassoc -- ^ Reassociation (important for e.g. vectorisation of horizontal sums)+ deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable)+++-- Debug Instructions ----------------------------------------------------------++-- | Debug Instructions+--+-- In LLVM 19, debug instructions were added as a replacement for the intrinsic+-- functions previously used. This addition is described in+-- llvm-project/llvm/docs/RemoveDIsDebugInfo.md in the LLVM repository.+data DebugRecord' lab+ = DebugRecordValue (DbgRecValue' lab)+ | DebugRecordDeclare (DbgRecDeclare' lab)+ | DebugRecordAssign (DbgRecAssign' lab)+ | DebugRecordValueSimple (DbgRecValueSimple' lab)+ | DebugRecordLabel (DbgRecLabel' lab)+ deriving (Data, Eq, Functor, Generic, Ord, Show, Typeable)++type DebugRecord = DebugRecord' BlockLabel++data DbgRecValue' lab = DbgRecValue+ {+ drvLocation :: ValMd' lab -- ^ Expected to be a DILocation+ , drvLocalVariable :: ValMd' lab -- ^ Expected to be a DILocalVariable+ , drvExpression :: ValMd' lab -- ^ Expected to be a DIExpression+ , drvValAsMetadata :: ValMd' lab+ }+ deriving (Data, Eq, Functor, Generic, Ord, Show, Typeable)++type DbgRecValue = DbgRecValue' BlockLabel++data DbgRecValueSimple' lab = DbgRecValueSimple+ {+ drvsLocation :: ValMd' lab -- ^ Expected to be a DILocation+ , drvsLocalVariable :: ValMd' lab -- ^ Expected to be a DILocalVariable+ , drvsExpression :: ValMd' lab -- ^ Expected to be a DIExpression+ , drvsValue :: Typed (Value' lab)+ }+ deriving (Data, Eq, Functor, Generic, Ord, Show, Typeable)++type DbgRecValueSimple = DbgRecValueSimple' BlockLabel++data DbgRecDeclare' lab = DbgRecDeclare+ {+ drdLocation :: ValMd' lab -- ^ Expected to be a DILocation+ , drdLocalVariable :: ValMd' lab -- ^ Expected to be a DILocalVariable+ , drdExpression :: ValMd' lab -- ^ Expected to be a DIExpression+ , drdValAsMetadata :: ValMd' lab+ }+ deriving (Data, Eq, Functor, Generic, Ord, Show, Typeable)++type DbgRecDeclare = DbgRecDeclare' BlockLabel++data DbgRecAssign' lab = DbgRecAssign+ {+ draLocation :: ValMd' lab -- ^ Expected to be a DILocation+ , draLocalVariable :: ValMd' lab -- ^ Expected to be a DILocalVariable+ , draExpression :: ValMd' lab -- ^ Expected to be a DIExpression+ , draValAsMetadata :: ValMd' lab+ , draAssignID :: ValMd' lab -- ^ Expected to be a DIAssignID+ , draExpressionAddr :: ValMd' lab -- ^ Expected to be a DIExpression+ , draValAsMetadataAddr :: ValMd' lab+ }+ deriving (Data, Eq, Functor, Generic, Ord, Show, Typeable)++type DbgRecAssign = DbgRecAssign' BlockLabel++data DbgRecLabel' lab = DbgRecLabel+ {+ drlLocation :: ValMd' lab -- ^ Expected to be a DILocation+ , drlLabel :: ValMd' lab -- ^ Expected to be a DILabel+ }+ deriving (Data, Eq, Functor, Generic, Ord, Show, Typeable)++type DbgRecLabel = DbgRecLabel' BlockLabel+++-- Values ----------------------------------------------------------------------++data Value' lab+ = ValInteger Integer+ | ValBool Bool+ | ValFloat Float+ | ValDouble Double+ | ValFP80 FP80Value+ | ValIdent Ident+ | ValSymbol Symbol+ | ValNull+ | ValArray Type [Value' lab]+ | ValVector Type [Value' lab]+ | ValStruct [Typed (Value' lab)]+ | ValPackedStruct [Typed (Value' lab)]+ | ValString [Word8]+ | ValConstExpr (ConstExpr' lab)+ | ValUndef+ | ValLabel lab+ | ValZeroInit+ | ValAsm Bool Bool String String+ | ValMd (ValMd' lab)+ | ValPoison+ deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type Value = Value' BlockLabel++data FP80Value = FP80_LongDouble Word16 Word64+ deriving (Data, Eq, Ord, Generic, Show, Typeable)++data ValMd' lab+ = ValMdString String+ | ValMdValue (Typed (Value' lab))+ | ValMdRef Int+ | ValMdNode [Maybe (ValMd' lab)]+ | ValMdLoc (DebugLoc' lab)+ | ValMdDebugInfo (DebugInfo' lab)+ deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type ValMd = ValMd' BlockLabel++type KindMd = String+type FnMdAttachments = Map.Map KindMd ValMd+type GlobalMdAttachments = Map.Map KindMd ValMd++data DebugLoc' lab = DebugLoc+ { dlLine :: Word32+ , dlCol :: Word32+ , dlScope :: ValMd' lab+ , dlIA :: Maybe (ValMd' lab)+ , dlImplicit :: Bool+ , dlAtomGroup :: Word64 -- ^ Introduced in LLVM 21+ , dlAtomRank :: Word64 -- ^ Introduced in LLVM 21+ } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type DebugLoc = DebugLoc' BlockLabel++isConst :: Value' lab -> Bool+isConst ValInteger{} = True+isConst ValBool{} = True+isConst ValFloat{} = True+isConst ValDouble{} = True+isConst ValFP80{} = True+isConst ValConstExpr{} = True+isConst ValZeroInit = True+isConst ValNull = True+isConst _ = False++-- Value Elimination -----------------------------------------------------------++elimValSymbol :: MonadPlus m => Value' lab -> m Symbol+elimValSymbol (ValSymbol sym) = return sym+elimValSymbol _ = mzero++elimValInteger :: MonadPlus m => Value' lab -> m Integer+elimValInteger (ValInteger i) = return i+elimValInteger _ = mzero++-- Statements ------------------------------------------------------------------++-- | Each statement, which can return a value (`Result`) referenced by the+-- `Ident` or else it has no return value (`Effect`). The statement has a single+-- Instruction, followed by any Debug Records or associated metadata.+--+-- See llvm-project/llvm/docs/RemoveDIsDebugInfo.md for discussion on the+-- [DebugRecord] fields. Note that DebugRecords and debug intrinsics may not be+-- mixed in a module; the former is new and preferred over the latter.+--+-- Technically, DebugRecords are attached to Instructions, but since there's a+-- 1:1 correspondence between Stmt and Instr, it is cleaner to attach the+-- DebugRecords to the Stmt to keep the Instrs from getting additional+-- complications.+--+-- Each statement may have both Debug Records (2nd-to-last field) and a list of+-- metadata attributes (last field). As noted above, bitcode file should not mix+-- Debug Records and intrinsics; if Debug Records are used, the metadata+-- attribute list should not contain intrinsics (although it may contain other+-- metadata associated with this statement).++data Stmt' lab+ = Result Ident (Instr' lab) [DebugRecord' lab] [(String, ValMd' lab)]+ | Effect (Instr' lab) [DebugRecord' lab] [(String, ValMd' lab)]+ deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type Stmt = Stmt' BlockLabel++stmtMetadata :: Stmt' lab -> [(String, ValMd' lab)]+stmtMetadata = \case+ Result _ _ _ mds -> mds+ Effect _ _ mds -> mds++stmtInstr :: Stmt' lab -> Instr' lab+stmtInstr (Result _ i _ _) = i+stmtInstr (Effect i _ _) = i++extendMetadata :: Show lab => (String, ValMd' lab) -> Stmt' lab -> Stmt' lab+extendMetadata md stmt = case stmt of+ Result r i [] mds -> Result r i [] (md:mds)+ Result _ _ _ _ -> error $ "Adding MD " <> show md <> " after DebugRecord"+ Effect i drs mds -> Effect i drs (md:mds)++addDebugRecord :: DebugRecord' lab -> Stmt' lab -> Stmt' lab+addDebugRecord dr = \case+ Result r i drs mds -> Result r i (snoc dr drs) mds+ Effect i drs mds -> Effect i (snoc dr drs) mds+ where+ snoc e ls = ls <> [e]++-- Constant Expressions --------------------------------------------------------++data ConstExpr' lab+ = ConstGEP [GEPAttr] (Maybe RangeSpec) Type (Typed (Value' lab)) [Typed (Value' lab)]+ -- ^ Since LLVM 3.7, constant @getelementptr@ expressions include an explicit+ -- type to use as a basis for calculations. For older versions of LLVM, this+ -- type can be reconstructed by inspecting the pointee type of the parent+ -- pointer value.+ --+ -- Since LLVM 19, the bool "inbounds" is now [GEPAttr] and range is via+ -- RangeSpec instead of just Word64. It's recommended that the GEPAttr list+ -- should be normalized (i.e. only one of each entry).+ | ConstConv ConvOp (Typed (Value' lab)) Type+ | ConstSelect (Typed (Value' lab)) (Typed (Value' lab)) (Typed (Value' lab))+ | ConstBlockAddr (Typed (Value' lab)) lab+ | ConstFCmp FCmpOp (Typed (Value' lab)) (Typed (Value' lab))+ | ConstICmp ICmpOp (Typed (Value' lab)) (Typed (Value' lab))+ | ConstArith ArithOp (Typed (Value' lab)) (Value' lab)+ | ConstUnaryArith UnaryArithOp (Typed (Value' lab))+ | ConstBit BitOp (Typed (Value' lab)) (Value' lab)+ deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type ConstExpr = ConstExpr' BlockLabel++-- | Attributes imposing rules on the GEP; violating any rule results in a poison+-- value. If the base is a vector of pointers, the attributes apply to each+-- computation element-wise. See+-- https://llvm.org/docs/LangRef.html#getelementptr-instruction for more+-- information.+data GEPAttr+ = GEP_Inbounds+ -- ^ Rules:+ -- * Base pointer has an inbounds (but not necessarily live) address of the+ -- allocated object it is based on (i.e. points into that allocation or to+ -- its end. Size for a growable allocated object is the max size, not the+ -- current size.+ -- * Pointer must remain inbounds at all times when adding the offsets+ -- * Implies 'GEP_NUSW'+ | GEP_NUSW+ -- ^ No unsigned signed wrap.+ -- Rules:+ -- * If type of index is larger than ptr index type, truncation preserves+ -- the signed value.+ -- * Multiplication of an index by the type size does not wrap in a+ -- signed sense.+ -- * Offset additions (excluding base address) does not wrap in a+ -- signed sense+ -- * Addition of the current address (as unsigned, truncated to ptr+ -- index type) and each offset (as signed) does not wrap the ptr+ -- index type.+ | GEP_NUW+ -- ^ No unsigned wrap+ -- Rules:+ -- * If type of index is larger than ptr index type, truncation preserves+ -- the unsigned value.+ -- * Multiplication of an index by the type size does not wrap in an+ -- unsigned sense.+ -- * Offset additions (excluding base address) does not wrap in an+ -- unsigned sense+ -- * Addition of the current address (as unsigned, truncated to ptr+ -- index type) and each offset (as unsigned) does not wrap the ptr+ -- index type.+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++orderedGEPAttrs :: [GEPAttr]+orderedGEPAttrs = [GEP_Inbounds, GEP_NUSW, GEP_NUW] -- bit0, bit1, ...++data RangeSpec+ = RangeIndex Word64+ -- ^ index of valid range as used in pre-LLVM19 for when "inbounds" as a+ -- boolean was True. Deprecated.+ | Range Int Integer Integer+ -- ^ width of arbitrary-precision integer (in bits) and lower and upper+ -- arbitrary-precision integer bounds of that size as [lower, upper).+ deriving (Data, Eq, Generic, Ord, Show, Typeable)+++-- DWARF Debug Info ------------------------------------------------------------++data DebugInfo' lab+ = DebugInfoBasicType (DIBasicType' lab)+ | DebugInfoCompileUnit (DICompileUnit' lab)+ | DebugInfoCompositeType (DICompositeType' lab)+ | DebugInfoDerivedType (DIDerivedType' lab)+ | DebugInfoEnumerator String !Integer Bool+ -- ^ The 'Bool' field represents @isUnsigned@, introduced in LLVM 7.+ | DebugInfoExpression DIExpression+ | DebugInfoFile DIFile+ | DebugInfoGlobalVariable (DIGlobalVariable' lab)+ | DebugInfoGlobalVariableExpression (DIGlobalVariableExpression' lab)+ | DebugInfoLexicalBlock (DILexicalBlock' lab)+ | DebugInfoLexicalBlockFile (DILexicalBlockFile' lab)+ | DebugInfoLocalVariable (DILocalVariable' lab)+ | DebugInfoSubprogram (DISubprogram' lab)+ | DebugInfoSubrange (DISubrange' lab)+ | DebugInfoSubroutineType (DISubroutineType' lab)+ | DebugInfoNameSpace (DINameSpace' lab)+ | DebugInfoTemplateTypeParameter (DITemplateTypeParameter' lab)+ | DebugInfoTemplateValueParameter (DITemplateValueParameter' lab)+ | DebugInfoImportedEntity (DIImportedEntity' lab)+ | DebugInfoLabel (DILabel' lab)+ | DebugInfoArgList (DIArgList' lab)+ | DebugInfoAssignID -- ^ Introduced in LLVM 17.+ deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type DebugInfo = DebugInfo' BlockLabel++type DILabel = DILabel' BlockLabel+data DILabel' lab = DILabel+ { dilScope :: Maybe (ValMd' lab)+ , dilName :: String+ , dilFile :: Maybe (ValMd' lab)+ , dilLine :: Word32+ , dilColumn :: Word32 -- ^ Introduced in LLVM 21.+ , dilIsArtificial :: Bool -- ^ Introduced in LLVM 21.+ , dilCoroSuspendIdx :: Maybe Word32 -- ^ Introduced in LLVM 21.+ } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type DIImportedEntity = DIImportedEntity' BlockLabel+data DIImportedEntity' lab = DIImportedEntity+ { diieTag :: DwarfTag+ , diieScope :: Maybe (ValMd' lab)+ , diieEntity :: Maybe (ValMd' lab)+ , diieFile :: Maybe (ValMd' lab)+ , diieLine :: Word32+ , diieName :: Maybe String+ } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type DITemplateTypeParameter = DITemplateTypeParameter' BlockLabel+data DITemplateTypeParameter' lab = DITemplateTypeParameter+ { dittpName :: Maybe String+ , dittpType :: Maybe (ValMd' lab)+ , dittpIsDefault :: Maybe Bool -- since LLVM 11+ } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type DITemplateValueParameter = DITemplateValueParameter' BlockLabel+data DITemplateValueParameter' lab = DITemplateValueParameter+ { ditvpTag :: DwarfTag+ , ditvpName :: Maybe String+ , ditvpType :: Maybe (ValMd' lab)+ , ditvpIsDefault :: Maybe Bool -- since LLVM 11+ , ditvpValue :: ValMd' lab+ } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type DINameSpace = DINameSpace' BlockLabel+data DINameSpace' lab = DINameSpace+ { dinsName :: Maybe String+ , dinsScope :: ValMd' lab+ , dinsFile :: ValMd' lab+ , dinsLine :: Word32+ } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++-- TODO: Turn these into sum types+-- See https://github.com/llvm-mirror/llvm/blob/release_38/include/llvm/Support/Dwarf.def+type DwarfAttrEncoding = Word16+type DwarfLang = Word16+type DwarfTag = Word16+type DwarfVirtuality = Word8+-- See https://github.com/llvm-mirror/llvm/blob/release_38/include/llvm/IR/DebugInfoMetadata.h#L175+type DIFlags = Word32+-- This seems to be defined internally as a small enum, and defined+-- differently across versions. Maybe turn this into a sum type once+-- it stabilizes.+type DIEmissionKind = Word8++-- See https://github.com/llvm/llvm-project/commit/eb8901bda11fd55deeecd067fc4c9dcc0fb89984+dwarf_DW_APPLE_ENUM_KIND_invalid :: Word32+dwarf_DW_APPLE_ENUM_KIND_invalid = complement (0 :: Word32) -- ~ LLVM 19++data DIBasicType' lab = DIBasicType+ { dibtTag :: DwarfTag+ , dibtName :: String+ , dibtSize :: Maybe (ValMd' lab)+ -- ^ If using LLVM 20 or older, this will always be @Just@ an 'ValMdValue',+ -- where the underlying value is a 64-bit 'ValInteger'. If using LLVM 21 or+ -- later, this can also be a null reference (i.e., 'Nothing'), a variable+ -- (i.e., @Just@ a 'DIGlobalVariable' or 'DILocalVariable'), or an+ -- expression (i.e., @Just@ a 'DIExpression').+ , dibtAlign :: Word64+ , dibtEncoding :: DwarfAttrEncoding+ , dibtFlags :: Maybe DIFlags+ , dibtNumExtraInhabitants :: Word64 -- ^ added in LLVM 20.+ } deriving (Data, Eq, Functor, Generic, Ord, Show, Typeable)++type DIBasicType = DIBasicType' BlockLabel++data DICompileUnit' lab = DICompileUnit+ { dicuLanguage :: DwarfLang+ , dicuFile :: Maybe (ValMd' lab)+ , dicuProducer :: Maybe String+ , dicuIsOptimized :: Bool+ , dicuFlags :: Maybe String+ , dicuRuntimeVersion :: Word16+ , dicuSplitDebugFilename :: Maybe FilePath+ , dicuEmissionKind :: DIEmissionKind+ , dicuEnums :: Maybe (ValMd' lab)+ , dicuRetainedTypes :: Maybe (ValMd' lab)+ , dicuSubprograms :: Maybe (ValMd' lab)+ , dicuGlobals :: Maybe (ValMd' lab)+ , dicuImports :: Maybe (ValMd' lab)+ , dicuMacros :: Maybe (ValMd' lab)+ , dicuDWOId :: Word64+ , dicuSplitDebugInlining :: Bool+ , dicuDebugInfoForProf :: Bool+ , dicuNameTableKind :: Word64+ -- added in LLVM 11: dicuRangesBaseAddress, dicuSysRoot, and dicuSDK+ , dicuRangesBaseAddress :: Bool+ , dicuSysRoot :: Maybe String+ , dicuSDK :: Maybe String+ } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type DICompileUnit = DICompileUnit' BlockLabel++data DICompositeType' lab = DICompositeType+ { dictTag :: DwarfTag+ , dictName :: Maybe String+ , dictFile :: Maybe (ValMd' lab)+ , dictLine :: Word32+ , dictScope :: Maybe (ValMd' lab)+ , dictBaseType :: Maybe (ValMd' lab)+ , dictSize :: Maybe (ValMd' lab)+ -- ^ If using LLVM 20 or older, this will always be @Just@ an 'ValMdValue',+ -- where the underlying value is a 64-bit 'ValInteger'. If using LLVM 21 or+ -- later, this can also be a null reference (i.e., 'Nothing'), a variable+ -- (i.e., @Just@ a 'DIGlobalVariable' or 'DILocalVariable'), or an+ -- expression (i.e., @Just@ a 'DIExpression').+ , dictAlign :: Word64+ , dictOffset :: Maybe (ValMd' lab)+ -- ^ If using LLVM 20 or older, this will always be @Just@ an 'ValMdValue',+ -- where the underlying value is a 64-bit 'ValInteger'. If using LLVM 21 or+ -- later, this can also be a null reference (i.e., 'Nothing'), a variable+ -- (i.e., @Just@ a 'DIGlobalVariable' or 'DILocalVariable'), or an+ -- expression (i.e., @Just@ a 'DIExpression').+ , dictFlags :: DIFlags+ , dictElements :: Maybe (ValMd' lab)+ , dictRuntimeLang :: DwarfLang+ , dictVTableHolder :: Maybe (ValMd' lab)+ , dictTemplateParams :: Maybe (ValMd' lab)+ , dictIdentifier :: Maybe String+ , dictDiscriminator :: Maybe (ValMd' lab)+ , dictDataLocation :: Maybe (ValMd' lab)+ , dictAssociated :: Maybe (ValMd' lab)+ , dictAllocated :: Maybe (ValMd' lab)+ , dictRank :: Maybe (ValMd' lab)+ , dictAnnotations :: Maybe (ValMd' lab) -- ^ Introduced in LLVM 14.+ , dictNumExtraInhabitants :: Word64 -- ^ added in LLVM 20.+ , dictSpecification :: Maybe (ValMd' lab) -- ^ added in LLVM 20.+ , dictEnumKind :: Maybe Word32 -- ^ added in LLVM 20.+ , dictBitStride :: Maybe (ValMd' lab) -- ^ added in LLVM 20.+ } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type DICompositeType = DICompositeType' BlockLabel++data DIDerivedType' lab = DIDerivedType+ { didtTag :: DwarfTag+ , didtName :: Maybe String+ , didtFile :: Maybe (ValMd' lab)+ , didtLine :: Word32+ , didtScope :: Maybe (ValMd' lab)+ , didtBaseType :: Maybe (ValMd' lab)+ , didtSize :: Maybe (ValMd' lab)+ -- ^ If using LLVM 20 or older, this will always be @Just@ an 'ValMdValue',+ -- where the underlying value is a 64-bit 'ValInteger'. If using LLVM 21 or+ -- later, this can also be a null reference (i.e., 'Nothing'), a variable+ -- (i.e., @Just@ a 'DIGlobalVariable' or 'DILocalVariable'), or an+ -- expression (i.e., @Just@ a 'DIExpression').+ , didtAlign :: Word64+ , didtOffset :: Maybe (ValMd' lab)+ -- ^ If using LLVM 20 or older, this will always be @Just@ an 'ValMdValue',+ -- where the underlying value is a 64-bit 'ValInteger'. If using LLVM 21 or+ -- later, this can also be a null reference (i.e., 'Nothing'), a variable+ -- (i.e., @Just@ a 'DIGlobalVariable' or 'DILocalVariable'), or an+ -- expression (i.e., @Just@ a 'DIExpression').+ , didtFlags :: DIFlags+ , didtExtraData :: Maybe (ValMd' lab)+ , didtDwarfAddressSpace :: Maybe Word32+ -- ^ Introduced in LLVM 5.+ --+ -- The 'Maybe' encodes the possibility that there is no associated address+ -- space (in LLVM, the sentinel value @0@ is used for this).+ , didtAnnotations :: Maybe (ValMd' lab)+ -- ^ Introduced in LLVM 14+ } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type DIDerivedType = DIDerivedType' BlockLabel++data DIExpression = DIExpression+ { dieElements :: [Word64]+ } deriving (Data, Eq, Generic, Ord, Show, Typeable)++data DIFile = DIFile+ { difFilename :: FilePath+ , difDirectory :: FilePath+ } deriving (Data, Eq, Generic, Ord, Show, Typeable)++data DIGlobalVariable' lab = DIGlobalVariable+ { digvScope :: Maybe (ValMd' lab)+ , digvName :: Maybe String+ , digvLinkageName :: Maybe String+ , digvFile :: Maybe (ValMd' lab)+ , digvLine :: Word32+ , digvType :: Maybe (ValMd' lab)+ , digvIsLocal :: Bool+ , digvIsDefinition :: Bool+ , digvVariable :: Maybe (ValMd' lab)+ , digvDeclaration :: Maybe (ValMd' lab)+ , digvAlignment :: Maybe Word32+ , digvAnnotations :: Maybe (ValMd' lab)+ -- ^ Introduced in LLVM 14.+ } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type DIGlobalVariable = DIGlobalVariable' BlockLabel++data DIGlobalVariableExpression' lab = DIGlobalVariableExpression+ { digveVariable :: Maybe (ValMd' lab)+ , digveExpression :: Maybe (ValMd' lab)+ } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type DIGlobalVariableExpression = DIGlobalVariableExpression' BlockLabel++data DILexicalBlock' lab = DILexicalBlock+ { dilbScope :: Maybe (ValMd' lab)+ , dilbFile :: Maybe (ValMd' lab)+ , dilbLine :: Word32+ , dilbColumn :: Word16+ } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type DILexicalBlock = DILexicalBlock' BlockLabel++data DILexicalBlockFile' lab = DILexicalBlockFile+ { dilbfScope :: ValMd' lab+ , dilbfFile :: Maybe (ValMd' lab)+ , dilbfDiscriminator :: Word32+ } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type DILexicalBlockFile = DILexicalBlockFile' BlockLabel++data DILocalVariable' lab = DILocalVariable+ { dilvScope :: Maybe (ValMd' lab)+ , dilvName :: Maybe String+ , dilvFile :: Maybe (ValMd' lab)+ , dilvLine :: Word32+ , dilvType :: Maybe (ValMd' lab)+ , dilvArg :: Word16+ , dilvFlags :: DIFlags+ , dilvAlignment :: Maybe Word32+ -- ^ Introduced in LLVM 4.+ , dilvAnnotations :: Maybe (ValMd' lab)+ -- ^ Introduced in LLVM 14.+ } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type DILocalVariable = DILocalVariable' BlockLabel++data DISubprogram' lab = DISubprogram+ { dispScope :: Maybe (ValMd' lab)+ , dispName :: Maybe String+ , dispLinkageName :: Maybe String+ , dispFile :: Maybe (ValMd' lab)+ , dispLine :: Word32+ , dispType :: Maybe (ValMd' lab)+ , dispIsLocal :: Bool+ , dispIsDefinition :: Bool+ , dispScopeLine :: Word32+ , dispContainingType :: Maybe (ValMd' lab)+ , dispVirtuality :: DwarfVirtuality+ , dispVirtualIndex :: Word32+ , dispThisAdjustment :: Int64+ , dispFlags :: DIFlags+ , dispIsOptimized :: Bool+ , dispUnit :: Maybe (ValMd' lab)+ , dispTemplateParams :: Maybe (ValMd' lab)+ , dispDeclaration :: Maybe (ValMd' lab)+ , dispRetainedNodes :: Maybe (ValMd' lab)+ , dispThrownTypes :: Maybe (ValMd' lab)+ , dispAnnotations :: Maybe (ValMd' lab)+ -- ^ Introduced in LLVM 14.+ } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type DISubprogram = DISubprogram' BlockLabel++-- | The DISubrange is a Value subrange specification, usually associated with+-- arrays or enumerations.+--+-- * Early LLVM: only 'disrCount' and 'disrLowerBound' were present, where both+-- were a direct signed 64-bit value. This corresponds to "format 0" in the+-- bitcode encoding (see reference below).+--+-- * LLVM 7: 'disrCount' changed to metadata representation ('ValMd'). The+-- metadata representation should only be a signed 64-bit integer, a Variable,+-- or an Expression. This corresponds to "format 1" in the bitcode encoding.+--+-- * LLVM 11: 'disrLowerBound' was changed to a metadata representation and+-- 'disrUpperBound' and 'disrStride' were added (primarily driven by the+-- addition of Fortran support in llvm). All three should only be represented+-- as a signed 64-bit integer, a Variable, or an Expression. This corresponds+-- to "format 2" in the bitcode encoding. See+-- https://github.com/llvm/llvm-project/commit/d20bf5a for this change.+--+-- Also see+-- https://github.com/llvm/llvm-project/blob/bbe8cd1/llvm/lib/Bitcode/Reader/MetadataLoader.cpp#L1435-L1461+-- for how this is read from the bitcode encoding and the use of the format+-- values mentioned above.++data DISubrange' lab = DISubrange+ { disrCount :: Maybe (ValMd' lab)+ , disrLowerBound :: Maybe (ValMd' lab)+ , disrUpperBound :: Maybe (ValMd' lab)+ , disrStride :: Maybe (ValMd' lab)+ } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type DISubrange = DISubrange' BlockLabel++data DISubroutineType' lab = DISubroutineType+ { distFlags :: DIFlags+ , distTypeArray :: Maybe (ValMd' lab)+ } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type DISubroutineType = DISubroutineType' BlockLabel++-- | See <https://releases.llvm.org/13.0.0/docs/LangRef.html#diarglist>.+newtype DIArgList' lab = DIArgList+ { dialArgs :: [ValMd' lab]+ } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type DIArgList = DIArgList' BlockLabel++-- Aggregate Utilities ---------------------------------------------------------++data IndexResult+ = Invalid -- ^ An invalid use of GEP+ | HasType Type -- ^ A resolved type+ | Resolve Ident (Type -> IndexResult) -- ^ Continue, after resolving an alias+ deriving (Generic, Typeable)++isInvalid :: IndexResult -> Bool+isInvalid ir = case ir of+ Invalid -> True+ _ -> False++-- | Resolves the type of a GEP instruction. Type aliases are resolved+-- using the given function. An invalid use of GEP or one relying+-- on unknown type aliases will return 'Nothing'+resolveGepFull ::+ (Ident -> Maybe Type) {- ^ Type alias resolution -} ->+ Type {- ^ Base type used for calculations -} ->+ Typed (Value' lab) {- ^ Pointer value -} ->+ [Typed (Value' lab)] {- ^ Path -} ->+ Maybe Type {- ^ Type of result -}+resolveGepFull env baseTy tv ixs = go (resolveGep baseTy tv ixs)+ where+ go Invalid = Nothing+ go (HasType result) = Just result+ go (Resolve ident resume) = go . resume =<< env ident+++-- | Resolve the type of a GEP instruction. Note that the type produced is the+-- type of the result, not necessarily a pointer.+resolveGep :: Type -> Typed (Value' lab) -> [Typed (Value' lab)] -> IndexResult+resolveGep baseTy tv ixs =+ case ixs of+ v:ixs0+ | -- If headed by a pointer and the first index value has a valid GEP+ -- index type, proceed to resolve the body of the GEP instruction.+ isPointer t+ , isGepIndex v+ -> resolveGepBody baseTy ixs0++ | -- If headed by a pointer and the first index has an alias type,+ -- resolve the alias and try again.+ isPointer t+ , Just i <- elimAlias (typedType v)+ -> Resolve i (\ty' -> resolveGep baseTy tv (Typed ty' (typedValue v):ixs0))++ _ | -- If headed by a value with an alias type, resolve the alias and+ -- try again.+ Alias i <- t+ -> Resolve i (\ty' -> resolveGep baseTy (Typed ty' (typedValue tv)) ixs)++ | -- Otherwise, the GEP instruction is invalid.+ otherwise+ -> Invalid+ where+ t = typedType tv++-- | Resolve the type of a GEP instruction. This assumes that the input has+-- already been processed as a pointer.+resolveGepBody :: Type -> [Typed (Value' lab)] -> IndexResult+resolveGepBody (Struct fs) (v:ixs)+ | Just i <- isGepStructIndex v, genericLength fs > i =+ resolveGepBody (genericIndex fs i) ixs+resolveGepBody (PackedStruct fs) (v:ixs)+ | Just i <- isGepStructIndex v, genericLength fs > i =+ resolveGepBody (genericIndex fs i) ixs+resolveGepBody (Alias name) is+ | not (null is) =+ Resolve name (\ty' -> resolveGepBody ty' is)+resolveGepBody (Array _ ty') (v:ixs)+ | isGepIndex v =+ resolveGepBody ty' ixs+resolveGepBody (Vector _ tp) [val]+ | isGepIndex val =+ HasType tp+resolveGepBody ty (v:ixs)+ | Just i <- elimAlias (typedType v) =+ Resolve i (\ty' -> resolveGepBody ty (Typed ty' (typedValue v):ixs))+resolveGepBody ty [] =+ HasType ty+resolveGepBody _ _ =+ Invalid++isGepIndex :: Typed (Value' lab) -> Bool+isGepIndex tv =+ isPrimTypeOf isInteger (typedType tv) ||+ isVectorOf (isPrimTypeOf isInteger) (typedType tv)++isGepStructIndex :: Typed (Value' lab) -> Maybe Integer+isGepStructIndex tv = do+ guard (isGepIndex tv)+ elimValInteger (typedValue tv)++resolveValueIndex :: Type -> [Int32] -> IndexResult+resolveValueIndex ty is@(ix:ixs) = case ty of+ Struct fs | genericLength fs > ix+ -> resolveValueIndex (genericIndex fs ix) ixs++ PackedStruct fs | genericLength fs > ix+ -> resolveValueIndex (genericIndex fs ix) ixs++ Array n ty' | fromIntegral ix < n+ -> resolveValueIndex ty' ixs++ Alias name+ -> Resolve name (\ty' -> resolveValueIndex ty' is)++ _ -> Invalid+resolveValueIndex ty [] = HasType ty
+ llvm-pretty/src/Text/LLVM/DebugUtils.hs view
@@ -0,0 +1,516 @@+{-# Language TransformListComp, MonadComprehensions #-}+{- |+Module : Text.LLVM.DebugUtils+Description : This module interprets the DWARF information associated+ with a function's argument and return types in order to+ interpret field name references.+License : BSD3+Stability : provisional+Maintainer : emertens@galois.com+-}+module Text.LLVM.DebugUtils+ ( -- * Definition type analyzer+ Info(..), StructFieldInfo(..), BitfieldInfo(..), UnionFieldInfo(..)+ , computeFunctionTypes, valMdToInfo+ , localVariableNameDeclarations++ -- * Metadata lookup+ , mkMdMap++ -- * Type structure dereference+ , derefInfo+ , fieldIndexByPosition+ , fieldIndexByName++ -- * Info hueristics+ , guessAliasInfo+ , guessTypeInfo++ -- * Function arguments+ , debugInfoArgNames++ -- * Line numbers of definitions+ , debugInfoGlobalLines+ , debugInfoDefineLines+ ) where++import Control.Applicative ((<|>))+import Control.Monad ((<=<))+import Data.Bits (Bits(..))+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.List (elemIndex, tails, stripPrefix)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe, listToMaybe, maybeToList, mapMaybe)+import Data.Word (Word16, Word64)+import Text.LLVM.AST++dbgKind :: String+dbgKind = "dbg"++llvmDbgCuKey :: String+llvmDbgCuKey = "llvm.dbg.cu"++dwarfPointer, dwarfStruct, dwarfTypedef, dwarfUnion, dwarfBasetype,+ dwarfConst, dwarfArray :: Word16+dwarfPointer = 0x0f+dwarfStruct = 0x13+dwarfTypedef = 0x16+dwarfArray = 0x01+dwarfUnion = 0x17+dwarfBasetype = 0x24+dwarfConst = 0x26++type MdMap = IntMap ValMd++data Info+ = Pointer Info+ | Structure (Maybe String) [StructFieldInfo]+ | Union (Maybe String) [UnionFieldInfo]+ | Typedef String Info+ | ArrInfo Info+ | BaseType String DIBasicType+ | Unknown+ deriving Show++-- | Record debug information about a field in a struct type.+data StructFieldInfo = StructFieldInfo+ { sfiName :: String+ -- ^ The field name.+ , sfiOffset :: Word64+ -- ^ The field's offset (in bits) from the start of the struct.+ , sfiBitfield :: Maybe BitfieldInfo+ -- ^ If this field resides within a bitfield, this is+ -- @'Just' bitfieldInfo@. Otherwise, this is 'Nothing'.+ , sfiInfo :: Info+ -- ^ The debug 'Info' associated with the field's type.+ } deriving Show++-- | Record debug information about a field within a bitfield. For example,+-- the following C struct:+--+-- @+-- struct s {+-- int32_t w;+-- uint8_t x1:1;+-- uint8_t x2:2;+-- uint8_t y:1;+-- int32_t z;+-- };+-- @+--+-- Corresponds to the following 'Info':+--+-- @+-- 'Structure'+-- [ 'StructFieldInfo' { 'sfiName' = \"w\"+-- , 'sfiOffset' = 0+-- , 'sfiBitfield' = Nothing+-- , 'sfiInfo' = 'BaseType' \"int32_t\"+-- }+-- , 'StructFieldInfo' { 'sfiName' = \"x1\"+-- , 'sfiOffset' = 32+-- , 'sfiBitfield' = Just ('BitfieldInfo' { 'biFieldSize' = 1+-- , 'biBitfieldOffset' = 32+-- })+-- , 'sfiInfo' = 'BaseType' \"uint8_t\"+-- }+-- , 'StructFieldInfo' { 'sfiName' = \"x2\"+-- , 'sfiOffset' = 33+-- , 'sfiBitfield' = Just ('BitfieldInfo' { 'biFieldSize' = 2+-- , 'biBitfieldOffset' = 32+-- })+-- , 'sfiInfo' = BaseType \"uint8_t\"+-- }+-- , 'StructFieldInfo' { 'sfiName' = \"y\"+-- , 'sfiOffset' = 35+-- , 'sfiBitfield' = Just ('BitfieldInfo' { 'biFieldSize' = 1+-- , 'biBitfieldOffset' = 32+-- })+-- , 'sfiInfo' = 'BaseType' \"uint8_t\"+-- }+-- , 'StructFieldInfo' { 'sfiName' = \"z\"+-- , 'sfiOffset' = 64+-- , 'sfiBitfield' = Nothing+-- , 'sfiInfo' = BaseType \"int32_t\"+-- }+-- ]+-- @+--+-- Notice that only @x1@, @x2@, and @y@ have 'BitfieldInfo's, as they are the+-- only fields that were declared with bitfield syntax.+data BitfieldInfo = BitfieldInfo+ { biFieldSize :: Word64+ -- ^ The field's size (in bits) within the bitfield. This should not be+ -- confused with the size of the field's declared type. For example, the+ -- 'biFieldSize' of the @x1@ field is @1@, despite the fact that its+ -- declared type, @uint8_t@, is otherwise 8 bits in size.+ , biBitfieldOffset :: Word64+ -- ^ The bitfield's offset (in bits) from the start of the struct. Note+ -- that for a given field within a bitfield, its 'sfiOffset' is equal to+ -- the 'biBitfieldOffset' plus the 'biFieldSize'.+ } deriving Show++-- | Record debug information about a field in a union type.+data UnionFieldInfo = UnionFieldInfo+ { ufiName :: String+ -- ^ The field name.+ , ufiInfo :: Info+ -- ^ The debug 'Info' associated with the field's type.+ } deriving Show++-- | Compute an 'IntMap' of the unnamed metadata in a module+mkMdMap :: Module -> IntMap ValMd+mkMdMap m = IntMap.fromList [ (umIndex md, umValues md) | md <- modUnnamedMd m ]++------------------------------------------------------------------------++getDebugInfo :: MdMap -> ValMd -> Maybe DebugInfo+getDebugInfo mdMap (ValMdRef i) = getDebugInfo mdMap =<< IntMap.lookup i mdMap+getDebugInfo _ (ValMdDebugInfo di) = Just di+getDebugInfo _ _ = Nothing++getInteger :: MdMap -> ValMd -> Maybe Integer+getInteger mdMap (ValMdRef i) = getInteger mdMap =<< IntMap.lookup i mdMap+getInteger _ (ValMdValue (Typed _ (ValInteger i))) = Just i+getInteger _ _ = Nothing++getList :: MdMap -> ValMd -> Maybe [Maybe ValMd]+getList mdMap (ValMdRef i) = getList mdMap =<< IntMap.lookup i mdMap+getList _ (ValMdNode di) = Just di+getList _ _ = Nothing++------------------------------------------------------------------------++valMdToInfo :: MdMap -> ValMd -> Info+valMdToInfo mdMap val =+ maybe Unknown (debugInfoToInfo mdMap) (getDebugInfo mdMap val)+++valMdToInfo' :: MdMap -> Maybe ValMd -> Info+valMdToInfo' = maybe Unknown . valMdToInfo+++debugInfoToInfo :: MdMap -> DebugInfo -> Info+debugInfoToInfo mdMap (DebugInfoDerivedType dt)+ | didtTag dt == dwarfPointer = Pointer (valMdToInfo' mdMap (didtBaseType dt))+ | didtTag dt == dwarfTypedef = case didtName dt of+ Nothing -> valMdToInfo' mdMap (didtBaseType dt)+ Just nm -> Typedef nm (valMdToInfo' mdMap (didtBaseType dt))+ | didtTag dt == dwarfConst = valMdToInfo' mdMap (didtBaseType dt)+debugInfoToInfo _ (DebugInfoBasicType bt)+ | dibtTag bt == dwarfBasetype = BaseType (dibtName bt) bt+debugInfoToInfo mdMap (DebugInfoCompositeType ct)+ | dictTag ct == dwarfStruct = maybe Unknown (Structure (dictName ct)) (getStructFields mdMap ct)+ | dictTag ct == dwarfUnion = maybe Unknown (Union (dictName ct)) (getUnionFields mdMap ct)+ | dictTag ct == dwarfArray = ArrInfo (valMdToInfo' mdMap (dictBaseType ct))+debugInfoToInfo _ _ = Unknown+++getFieldDIs :: MdMap -> DICompositeType -> Maybe [DebugInfo]+getFieldDIs mdMap =+ traverse (getDebugInfo mdMap) <=< sequence <=< getList mdMap <=< dictElements++getStructFields :: MdMap -> DICompositeType -> Maybe [StructFieldInfo]+getStructFields mdMap = traverse (debugInfoToStructField mdMap) <=< getFieldDIs mdMap++debugInfoToStructField :: MdMap -> DebugInfo -> Maybe StructFieldInfo+debugInfoToStructField mdMap di =+ do DebugInfoDerivedType dt <- Just di+ fieldName <- didtName dt+ -- We check if a struct field resides within a bitfield by checking its+ -- `flags` field sets `BitField`, which has a numeric value of 19.+ -- (https://github.com/llvm/llvm-project/blob/1bebc31c617d1a0773f1d561f02dd17c5e83b23b/llvm/include/llvm/IR/DebugInfoFlags.def#L51)+ --+ -- If so, the `size` field records the size in bits, and the `extraData`+ -- field records the offset of the overall bitfield from the start of the+ -- struct.+ -- (https://github.com/llvm/llvm-project/blob/ee7652569854af567ba83e5255d70e80cc8619a1/llvm/lib/CodeGen/AsmPrinter/CodeViewDebug.cpp#L2489-L2508)+ let bitfield | testBit (didtFlags dt) 19+ , Just extraData <- didtExtraData dt+ , Just bitfieldOffset <- getInteger mdMap extraData+ = do size <- getSizeOrOffset (didtSize dt)+ Just $ BitfieldInfo { biFieldSize = size+ , biBitfieldOffset = fromInteger bitfieldOffset+ }+ | otherwise+ = Nothing+ offset <- getSizeOrOffset (didtOffset dt)+ Just (StructFieldInfo { sfiName = fieldName+ , sfiOffset = offset+ , sfiBitfield = bitfield+ , sfiInfo = valMdToInfo' mdMap (didtBaseType dt)+ })+ where+ -- TODO: Currently, this only recognizes bare integer (i.e., 'ValInteger')+ -- sizes and offsets. This is likely good enough for Clang-derived LLVM, but+ -- Ada-derived LLVM may contain more complex metadata values that this+ -- currently doesn't handle.+ getSizeOrOffset :: Maybe ValMd -> Maybe Word64+ getSizeOrOffset (Just (ValMdValue tv))+ | ValInteger i <- typedValue tv+ = Just (fromInteger i)+ getSizeOrOffset _ = Nothing+++getUnionFields :: MdMap -> DICompositeType -> Maybe [UnionFieldInfo]+getUnionFields mdMap = traverse (debugInfoToUnionField mdMap) <=< getFieldDIs mdMap+++debugInfoToUnionField :: MdMap -> DebugInfo -> Maybe UnionFieldInfo+debugInfoToUnionField mdMap di =+ do DebugInfoDerivedType dt <- Just di+ fieldName <- didtName dt+ Just (UnionFieldInfo { ufiName = fieldName+ , ufiInfo = valMdToInfo' mdMap (didtBaseType dt)+ })++++-- | Compute the structures of a function's return and argument types+-- using DWARF information metadata of the LLVM module. Different+-- versions of LLVM make this information available via different+-- paths. This function attempts to support the variations.+computeFunctionTypes ::+ Module {- ^ module to search -} ->+ Symbol {- ^ function symbol -} ->+ Maybe [Maybe Info] {- ^ return and argument type information -}+computeFunctionTypes m sym =+ [ fmap (valMdToInfo mdMap) <$> types+ | let mdMap = mkMdMap m+ , sp <- findSubprogramViaDefine mdMap m sym+ <|> findSubprogramViaCu mdMap m sym+ , DebugInfoSubroutineType st <- getDebugInfo mdMap =<< dispType sp+ , types <- getList mdMap =<< distTypeArray st+ ]+++-- | This method of computing argument type information works on at least LLVM 3.8+findSubprogramViaDefine ::+ IntMap ValMd {- ^ unnamed metadata -} ->+ Module {- ^ module to search -} ->+ Symbol {- ^ function symbol to find -} ->+ Maybe DISubprogram {- ^ debug information related to function symbol -}+findSubprogramViaDefine mdMap m sym =+ [ sp+ | def <- modDefines m+ , defName def == sym+ , then listToMaybe ----- commits to a choice -----+ , dbgMd <- Map.lookup dbgKind (defMetadata def)+ , DebugInfoSubprogram sp <- getDebugInfo mdMap dbgMd+ ]+++-- | This method of computing function debugging information works on LLVM 3.7+findSubprogramViaCu ::+ MdMap {- ^ map of unnamed metadata -} ->+ Module {- ^ module to search -} ->+ Symbol {- ^ function symbol to search for -} ->+ Maybe DISubprogram {- ^ debugging information for given symbol -}+findSubprogramViaCu mdMap m (Symbol sym) = listToMaybe+ [ sp+ | md <- modNamedMd m+ , nmName md == llvmDbgCuKey+ , ref <- nmValues md+ , DebugInfoCompileUnit cu <- maybeToList $ getDebugInfo mdMap $ ValMdRef ref+ , Just entry <- fromMaybe [] $ getList mdMap =<< dicuSubprograms cu+ , DebugInfoSubprogram sp <- maybeToList $ getDebugInfo mdMap entry+ , dispName sp == Just sym+ ]+++------------------------------------------------------------------------++-- | If the argument describes a pointer, return the information for the+-- type that it points do. If the argument describes an array, return+-- information about the element type.+derefInfo ::+ Info {- ^ pointer type information -} ->+ Info {- ^ type information of pointer's base type -}+derefInfo (Pointer x) = x+derefInfo (ArrInfo x) = x+derefInfo _ = Unknown++-- | If the argument describes a composite type, returns the type of the+-- field by zero-based index into the list of fields.+fieldIndexByPosition ::+ Int {- ^ zero-based field index -} ->+ Info {- ^ composite type information -} ->+ Info {- ^ type information for specified field -}+fieldIndexByPosition i info =+ case info of+ Typedef _ info' -> fieldIndexByPosition i info'+ Structure _ xs -> go [ x | StructFieldInfo{sfiInfo = x} <- xs ]+ Union _ xs -> go [ x | UnionFieldInfo{ufiInfo = x} <- xs ]+ _ -> Unknown+ where+ go xs = case drop i xs of+ [] -> Unknown+ x:_ -> x++-- | If the argument describes a composite type, return the first, zero-based+-- index of the field in that type that matches the given name.+fieldIndexByName ::+ String {- ^ field name -} ->+ Info {- ^ composite type info -} ->+ Maybe Int {- ^ zero-based index of field matching the name -}+fieldIndexByName n info =+ case info of+ Typedef _ info' -> fieldIndexByName n info'+ Structure _ xs -> go [ x | StructFieldInfo{sfiName = x} <- xs ]+ Union _ xs -> go [ x | UnionFieldInfo{ufiName = x} <- xs ]+ _ -> Nothing+ where+ go = elemIndex n++------------------------------------------------------------------------++localVariableNameDeclarations ::+ IntMap ValMd {- ^ unnamed metadata -} ->+ Define {- ^ function definition -} ->+ Map Ident Ident {- ^ raw name, actual name -}+localVariableNameDeclarations mdMap def =+ case defBody def of+ blk1 : _ -> foldr aux Map.empty (tails (bbStmts blk1))+ _ -> Map.empty+ where++ aux :: [Stmt] -> Map Ident Ident -> Map Ident Ident+ aux ( Effect (Store False src dst _ _) _ _+ : Effect (Call _ _ _ (ValSymbol (Symbol what)) [var,md,_]) _ _+ : _) sofar+ | what == "llvm.dbg.declare" -- pre-LLVM19: intrinsic declaration match+ , Just dstIdent <- extractIdent dst+ , Just srcIdent <- extractIdent src+ , Just varIdent <- extractIdent var+ , dstIdent == varIdent+ , Just name <- extractLvName md+ = Map.insert name srcIdent sofar++ aux ( Effect (Call _ _ _ (ValSymbol (Symbol what)) [var,_,md,_]) _ _+ : _) sofar+ | what == "llvm.dbg.value" -- pre-LLVM19: intrinsic declaration match+ , Just key <- extractIdent var+ , Just name <- extractLvName md+ = Map.insert name key sofar++ aux _ sofar = sofar++ extractIdent :: Typed Value -> Maybe Ident+ extractIdent (Typed _ (ValIdent i)) = Just i+ extractIdent _ = Nothing++ extractLvName :: Typed Value -> Maybe Ident+ extractLvName mdArg =+ do ValMd md <- Just (typedValue mdArg)+ DebugInfoLocalVariable dilv <- getDebugInfo mdMap md+ Ident <$> dilvName dilv++------------------------------------------------------------------------++-- | Search the metadata for debug info corresponding+-- to a given type alias. This is considered a heuristic+-- because there's no direct mapping between type aliases+-- and debug info. The debug information must be search+-- for a textual match.+--+-- Compared to @guessTypeInfo@, this function first tries+-- to strip the \"struct.\" and \"union.\" prefixes that are+-- commonly added by clang before searching for the type information.+guessAliasInfo ::+ IntMap ValMd {- ^ unnamed metadata -} ->+ Ident {- ^ alias -} ->+ Info+guessAliasInfo mdMap (Ident name)+ | Just pfx <- stripPrefix "struct." name = guessTypeInfo mdMap pfx+ | Just pfx <- stripPrefix "union." name = guessTypeInfo mdMap pfx+ | otherwise = guessTypeInfo mdMap name++-- | Search the metadata for debug info corresponding+-- to a given type alias. This is considered a heuristic+-- because there's no direct mapping between type aliases+-- and debug info. The debug information must be search+-- for a textual match.+guessTypeInfo ::+ IntMap ValMd {- ^ unnamed metadata -} ->+ String {- ^ struct alias -} ->+ Info+guessTypeInfo mdMap name =+ case mapMaybe (go <=< getDebugInfo mdMap) (IntMap.elems mdMap) of+ [] -> Unknown+ x:_ -> x++ where+ go di | DebugInfoDerivedType didt <- di+ , Just name == didtName didt+ = Just (debugInfoToInfo mdMap di)++ go di | DebugInfoCompositeType dict <- di+ , Just name == dictName dict+ = Just (debugInfoToInfo mdMap di)++ go _ = Nothing++------------------------------------------------------------------------++-- | Find source-level names of function arguments+debugInfoArgNames :: Module -> Define -> IntMap String+debugInfoArgNames m d =+ case Map.lookup dbgKind $ defMetadata d of+ Just (ValMdRef s) -> scopeArgs s+ _ -> IntMap.empty+ where+ scopeArgs :: Int -> IntMap String+ scopeArgs s = IntMap.fromList . mapMaybe go $ modUnnamedMd m+ where+ go :: UnnamedMd -> Maybe (Int, String)+ go+ ( UnnamedMd+ { umValues =+ ValMdDebugInfo+ ( DebugInfoLocalVariable+ DILocalVariable+ { dilvScope = Just (ValMdRef s'),+ dilvArg = a,+ dilvName = Just n+ }+ )+ }) =+ if s == s'+ then Just (fromIntegral a - 1, n)+ else Nothing+ go _ = Nothing++------------------------------------------------------------------------++-- | Map global variable names to the line on which the global is defined+debugInfoGlobalLines :: Module -> Map String Int+debugInfoGlobalLines = Map.fromList . mapMaybe go . modUnnamedMd+ where+ go :: UnnamedMd -> Maybe (String, Int)+ go (UnnamedMd+ { umValues = ValMdDebugInfo+ (DebugInfoGlobalVariable DIGlobalVariable+ { digvName = Just n+ , digvLine = l+ }+ )+ }) = Just (n, (fromIntegral l))+ go _ = Nothing++-- | Map function names to the line on which the function is defined+debugInfoDefineLines :: Module -> Map String Int+debugInfoDefineLines = Map.fromList . mapMaybe go . modUnnamedMd+ where+ go :: UnnamedMd -> Maybe (String, Int)+ go (UnnamedMd+ { umValues = ValMdDebugInfo+ (DebugInfoSubprogram DISubprogram+ { dispName = Just n+ , dispIsDefinition = True+ , dispLine = l+ }+ )+ }) = Just (n, (fromIntegral l))+ go _ = Nothing
+ llvm-pretty/src/Text/LLVM/Labels.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE EmptyCase, TypeOperators, FlexibleContexts #-}+module Text.LLVM.Labels where++import Text.LLVM.AST+import Text.LLVM.Labels.TH++class Functor f => HasLabel f where+ -- | Given a function for resolving labels, where the presence of a symbol+ -- denotes a label in a different function, rename all labels in a function.+ relabel :: Applicative m => (Maybe Symbol -> a -> m b) -> f a -> m (f b)++instance HasLabel Instr' where+ relabel _ RetVoid = pure RetVoid+ relabel _ Unreachable = pure Unreachable+ relabel _ Unwind = pure Unwind+ relabel _ (Comment str) = pure (Comment str)+ relabel f (Ret tv) = Ret <$> traverse (relabel f) tv+ relabel f (Arith op l r) = Arith op+ <$> traverse (relabel f) l+ <*> relabel f r+ relabel f (UnaryArith op a) = UnaryArith op+ <$> traverse (relabel f) a+ relabel f (Bit op l r) = Bit op+ <$> traverse (relabel f) l+ <*> relabel f r+ relabel f (Conv op l r) = Conv op <$> traverse (relabel f) l <*> pure r+ relabel f (Call t fmf r n as) = Call t fmf r+ <$> relabel f n+ <*> traverse (traverse (relabel f)) as+ relabel f (CallBr r n as u es) = CallBr r+ <$> relabel f n+ <*> traverse (traverse (relabel f)) as+ <*> f Nothing u+ <*> traverse (f Nothing) es+ relabel f (Alloca t n a) = Alloca t+ <$> traverse (traverse (relabel f)) n+ <*> pure a+ relabel f (Load vol t a mo ma) = Load vol t+ <$> traverse (relabel f) a+ <*> pure mo+ <*> pure ma+ relabel f (Store vol d v mo ma) = Store vol+ <$> traverse (relabel f) d+ <*> traverse (relabel f) v+ <*> pure mo+ <*> pure ma+ relabel _ (Fence s o) = pure (Fence s o)+ relabel f (CmpXchg w v p a n s o o')+ = CmpXchg w v+ <$> traverse (relabel f) p+ <*> traverse (relabel f) a+ <*> traverse (relabel f) n+ <*> pure s+ <*> pure o+ <*> pure o'+ relabel f (AtomicRW v op p a s o)+ = AtomicRW v op+ <$> traverse (relabel f) p+ <*> traverse (relabel f) a+ <*> pure s+ <*> pure o+ relabel f (ICmp samesign op l r)+ = ICmp samesign op+ <$> traverse (relabel f) l+ <*> relabel f r+ relabel f (FCmp op fmf l r) = FCmp op fmf+ <$> traverse (relabel f) l+ <*> relabel f r+ relabel f (GEP ib t a is) = GEP ib t+ <$> traverse (relabel f) a+ <*> traverse (traverse (relabel f)) is+ relabel f (Select fmf c l r) = Select fmf+ <$> traverse (relabel f) c+ <*> traverse (relabel f) l <*> relabel f r+ relabel f (ExtractValue a is) = ExtractValue+ <$> traverse (relabel f) a+ <*> pure is+ relabel f (InsertValue a i is) = InsertValue+ <$> traverse (relabel f) a+ <*> traverse (relabel f) i+ <*> pure is+ relabel f (ShuffleVector a b m) = ShuffleVector+ <$> traverse (relabel f) a+ <*> relabel f b+ <*> traverse (relabel f) m+ relabel f (Jump lab) = Jump <$> f Nothing lab+ relabel f (Br c l r) = Br+ <$> traverse (relabel f) c+ <*> f Nothing l+ <*> f Nothing r+ relabel f (Invoke r s as u e) = Invoke r+ <$> relabel f s+ <*> traverse (traverse (relabel f)) as+ <*> f Nothing u+ <*> f Nothing e+ relabel f (VaArg al t) = VaArg+ <$> traverse (relabel f) al+ <*> pure t+ relabel f (ExtractElt v i) = ExtractElt+ <$> traverse (relabel f) v+ <*> relabel f i+ relabel f (InsertElt v e i) = InsertElt+ <$> traverse (relabel f) v+ <*> traverse (relabel f) e+ <*> relabel f i+ relabel f (IndirectBr d ls) = IndirectBr+ <$> traverse (relabel f) d+ <*> traverse (f Nothing) ls+ relabel f (Switch c d ls) =+ let step (n,i) = (\l -> (n,l)) <$> f Nothing i+ in Switch <$> traverse (relabel f) c <*> f Nothing d <*> traverse step ls+ relabel f (Phi fmf t ls) =+ let step (a,l) = (,) <$> relabel f a <*> f Nothing l+ in Phi fmf t <$> traverse step ls++ relabel f (LandingPad ty fn c cs) = LandingPad ty+ <$> traverse (traverse (relabel f)) fn+ <*> pure c+ <*> traverse (relabel f) cs++ relabel f (Resume tv) = Resume <$> traverse (relabel f) tv+ relabel f (Freeze tv) = Freeze <$> traverse (relabel f) tv++instance HasLabel Stmt' where relabel = $(generateRelabel 'relabel ''Stmt')+instance HasLabel Clause' where relabel = $(generateRelabel 'relabel ''Clause')+instance HasLabel Value' where relabel = $(generateRelabel 'relabel ''Value')+instance HasLabel ValMd' where relabel = $(generateRelabel 'relabel ''ValMd')+instance HasLabel DebugRecord' where relabel = $(generateRelabel 'relabel ''DebugRecord')+instance HasLabel DbgRecAssign' where relabel = $(generateRelabel 'relabel ''DbgRecAssign')+instance HasLabel DbgRecDeclare' where relabel = $(generateRelabel 'relabel ''DbgRecDeclare')+instance HasLabel DbgRecLabel' where relabel = $(generateRelabel 'relabel ''DbgRecLabel')+instance HasLabel DbgRecValueSimple' where relabel = $(generateRelabel 'relabel ''DbgRecValueSimple')+instance HasLabel DbgRecValue' where relabel = $(generateRelabel 'relabel ''DbgRecValue')+instance HasLabel DILabel' where relabel = $(generateRelabel 'relabel ''DILabel')+instance HasLabel DebugLoc' where relabel = $(generateRelabel 'relabel ''DebugLoc')+instance HasLabel DebugInfo' where relabel = $(generateRelabel 'relabel ''DebugInfo')+instance HasLabel DIBasicType' where relabel = $(generateRelabel 'relabel ''DIBasicType')+instance HasLabel DIDerivedType' where relabel = $(generateRelabel 'relabel ''DIDerivedType')+instance HasLabel DISubroutineType' where relabel = $(generateRelabel 'relabel ''DISubroutineType')+instance HasLabel DISubrange' where relabel = $(generateRelabel 'relabel ''DISubrange')+instance HasLabel DIGlobalVariable' where relabel = $(generateRelabel 'relabel ''DIGlobalVariable')+instance HasLabel DIGlobalVariableExpression' where relabel = $(generateRelabel 'relabel ''DIGlobalVariableExpression')+instance HasLabel DILocalVariable' where relabel = $(generateRelabel 'relabel ''DILocalVariable')+instance HasLabel DISubprogram' where relabel = $(generateRelabel 'relabel ''DISubprogram')+instance HasLabel DICompositeType' where relabel = $(generateRelabel 'relabel ''DICompositeType')+instance HasLabel DILexicalBlock' where relabel = $(generateRelabel 'relabel ''DILexicalBlock')+instance HasLabel DICompileUnit' where relabel = $(generateRelabel 'relabel ''DICompileUnit')+instance HasLabel DILexicalBlockFile' where relabel = $(generateRelabel 'relabel ''DILexicalBlockFile')+instance HasLabel DINameSpace' where relabel = $(generateRelabel 'relabel ''DINameSpace')+instance HasLabel DITemplateTypeParameter' where relabel = $(generateRelabel 'relabel ''DITemplateTypeParameter')+instance HasLabel DITemplateValueParameter' where relabel = $(generateRelabel 'relabel ''DITemplateValueParameter')+instance HasLabel DIImportedEntity' where relabel = $(generateRelabel 'relabel ''DIImportedEntity')+instance HasLabel DIArgList' where relabel = $(generateRelabel 'relabel ''DIArgList')++-- | Clever instance that actually uses the block name+instance HasLabel ConstExpr' where+ relabel f (ConstBlockAddr t@(Typed { typedValue = ValSymbol s }) l) =+ ConstBlockAddr <$> traverse (relabel f) t <*> f (Just s) l+ relabel f x = $(generateRelabel 'relabel ''ConstExpr') f x
+ llvm-pretty/src/Text/LLVM/Labels/TH.hs view
@@ -0,0 +1,125 @@+{-# Language TemplateHaskell #-}+module Text.LLVM.Labels.TH (generateRelabel) where++import Control.Monad (zipWithM)+import Language.Haskell.TH+import Language.Haskell.TH.Datatype++generateRelabel :: Name -> Name -> ExpQ+generateRelabel relabel dataCon =+ do di <- reifyDatatype dataCon+ generateRelabelData di (varE relabel)++generateRelabelData :: DatatypeInfo -> ExpQ -> ExpQ+generateRelabelData di relabelE =+ [| \f x -> $(caseE [| x |] (mkMatch [| f |] <$> cons)) |]+ where+ mkMatch = generateRelabelCon lastArg relabelE+ lastArg = tvName (last (datatypeVars di))+ cons = datatypeCons di++-- | Generates the case arm for the given constructor that+-- relabels values using this constructor given a relabeling+-- function.+generateRelabelCon ::+ Name {- ^ last type parameter -} ->+ ExpQ {- ^ recusive relabel expression -} ->+ ExpQ {- ^ function expression -} ->+ ConstructorInfo {- ^ current constructor -} ->+ MatchQ {- ^ match arm for this constructor -}+generateRelabelCon lastArg relabelE fE ci =+ do names <- nameThings "x" (constructorFields ci)+ match+ (conP cn (map (varP . fst) names))+ (normalB (bodyExp cn (map gen names)))+ []+ where+ cn = constructorName ci++ -- Give a field name and type returns:+ -- Left for a pure field+ -- Right for a field using the Applicative instance+ gen :: (Name, Type) -> Either ExpQ ExpQ+ gen (n,t) =+ let nE = varE n in+ case generateRelabelField lastArg fE relabelE t of+ Just f -> Right [| $f $nE |]+ Nothing -> Left nE++-- | Given a constructor and a list of pure and updated fields,+-- build syntax that rebuilds the expression.+bodyExp ::+ Name {- ^ constructor -} ->+ [Either ExpQ ExpQ] {- ^ list of pure and applicative fields -} ->+ ExpQ {- ^ applicative result -}+bodyExp conname fields = liftAE conLike updates+ where+ updates = [r | Right r <- fields]++ -- Builds a value suitable to be the argument to liftAE that can+ -- combine all of the updated field values+ conLike =+ do names <- map fst <$> nameThings "y" updates+ lamE+ (map varP names)+ (appsE (conE conname : replaceRights (map varE names) fields))++-- | Replaces all of the 'Right' values in the given list with elements+-- from the first list. The number of replacements must exactly match+-- the number of 'Right' values.+replaceRights ::+ [a] {- ^ replacements -} ->+ [Either a b] {- ^ source list -} ->+ [a] {- ^ replaced list -}+replaceRights xs (Left y : ys) = y : replaceRights xs ys+replaceRights (x:xs) (Right _ : ys) = x : replaceRights xs ys+replaceRights [] [] = []+replaceRights _ _ = error "Text.LLVM.Labels.TH.replaceRights: PANIC"++-- | Generate the applicative update value for a field if it+-- has an appropriate type otherwise return nothing if it+-- should be left unchagned.+generateRelabelField ::+ Name {- ^ last type parameter -} ->+ ExpQ {- ^ function expression -} ->+ ExpQ {- ^ relabel expression -} ->+ Type {- ^ field type -} ->+ Maybe ExpQ {- ^ applicative update function -}+generateRelabelField lastArg fE relabelE t =+ case typeDepth t of+ (n, VarT tn) | tn == lastArg -> Just (exprs !! n)+ _ -> Nothing+ where+ exprs = [| $fE Nothing |] : iterate traverseE [| $relabelE $fE |]++-- | Figure out the depth of the outer type applications and+-- return the type at the bottom of the stack+typeDepth ::+ Type {- ^ target type -} ->+ (Int, Type) {- ^ number of type applications and right-most type -}+typeDepth = go 0+ where+ go i (AppT _ x) = go (i+1) x+ go i t = (i, t)++-- | Associate each element in a list of things with a unique name+-- derived from a given name stem.+nameThings ::+ String {- ^ base name -} ->+ [a] {- ^ things to name -} ->+ Q [(Name, a)] {- ^ things paired with unique names -}+nameThings base xs = zipWithM nameThing [0 :: Int ..] xs+ where+ nameThing i x = do n <- newName (base ++ show i); return (n,x)++-- | Apply 'traverse' to an expression+traverseE ::+ ExpQ {- ^ f -} ->+ ExpQ {- ^ traverse f -}+traverseE e = [| traverse $e |]++-- Applies a pure value to zero or more applicative things to be combined+-- with (<$>) and (<*>)+liftAE :: ExpQ -> [ExpQ] -> ExpQ+liftAE c [] = [| pure $c |]+liftAE c (x:xs) = foldl (\f e -> [| $f <*> $e |]) [| $c <$> $x |] xs
+ llvm-pretty/src/Text/LLVM/Lens.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE TemplateHaskell #-}+module Text.LLVM.Lens where++import Text.LLVM+import Lens.Micro.TH+import Lens.Micro+import Language.Haskell.TH.Syntax (mkName, nameBase)++concat <$> mapM (makeLensesWith (lensRules & lensField .~ (\_ _ n -> [TopName $ mkName $ nameBase n ++ "Lens"])))+ [ ''Module+ , ''LayoutSpec+ , ''TypeDecl+ , ''GlobalAlias+ , ''ConstExpr'+ , ''Type'+ , ''Mangling+ , ''NamedMd+ , ''Value'+ , ''BlockLabel+ , ''UnnamedMd+ , ''Typed+ , ''Global+ , ''Declare+ , ''Clause'+ , ''FunAttr+ , ''GlobalAttrs+ , ''BasicBlock'+ , ''Stmt'+ , ''Linkage+ , ''DebugLoc'+ , ''DebugInfo'+ , ''DIFile+ , ''DISubrange'+ , ''DIBasicType'+ , ''DIExpression+ , ''DISubprogram'+ , ''DISubroutineType'+ , ''DILocalVariable'+ , ''DIGlobalVariableExpression'+ , ''DIGlobalVariable'+ , ''DICompileUnit'+ , ''DICompositeType'+ , ''DIDerivedType'+ , ''DILexicalBlock'+ , ''DILexicalBlockFile'+ , ''DIArgList'+ , ''Instr'+ , ''ValMd'+ , ''ConvOp+ , ''BitOp+ , ''ArithOp+ , ''FCmpOp+ , ''ICmpOp+ , ''GC+ , ''Define+ , ''PrimType+ ]
+ llvm-pretty/src/Text/LLVM/PP.hs view
@@ -0,0 +1,1605 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}++-- |+-- Module : Text.LLVM.PP+-- Copyright : Trevor Elliott 2011-2016+-- License : BSD3+--+-- Maintainer : awesomelyawesome@gmail.com+-- Stability : experimental+-- Portability : unknown+--+-- This is the pretty-printer for llvm assembly versions 3.6 and lower.+--+module Text.LLVM.PP where++import Text.LLVM.AST+import Text.LLVM.Triple.AST (TargetTriple)+import Text.LLVM.Triple.Print (printTriple)++import Control.Applicative ((<|>))+import Data.Bits ( shiftR, (.&.) )+import Data.Char (isAlphaNum,isAscii,isDigit,isPrint,ord,toUpper)+import Data.List ( intersperse, nub )+import qualified Data.Map as Map+import Data.Maybe (catMaybes,fromMaybe,isJust)+import GHC.Float (castDoubleToWord64, float2Double)+import Numeric (showHex)+import Text.PrettyPrint.HughesPJ+import Data.Int+import Prelude hiding ((<>))+++-- Pretty-printer Config -------------------------------------------------------+++-- | The value used to specify the LLVM major version. The LLVM text format+-- (i.e. assembly code) changes with different versions of LLVM, so this value is+-- used to select the version the output should be generated for.+--+-- At the current time, changes primarily occur when the LLVM major version+-- changes, and this is expected to be the case going forward, so it is+-- sufficient to reference the LLVM version by the single major version number.+-- There is one exception and one possible future exception to this approach:+--+-- 1. During LLVM v3, there were changes in 3.5, 3.6, 3.7, and 3.8. There are+-- explicit @ppLLVMnn@ function entry points for those versions, but in the+-- event that a numerical value is needed, we note the serendipitous fact+-- that prior to LLVM 4, there are exactly 4 versions we need to+-- differentiate and can therefore assign the values of 0, 1, 2, and 3 to+-- those versions (and we have no intention of supporting any other pre-4.0+-- versions at this point).+--+-- 2. If at some future date, there are text format changes associated with a+-- minor version, then the LLVM version designation here will need to be+-- enhanced and made more sophisticated. At the present time, the likelihood+-- of that is small enough that the current simple implementation is a+-- benefit over a more complex mechanism that might not be needed.+--+type LLVMVer = Int++-- | Helpers for specifying the LLVM versions prior to v4+llvmV3_5, llvmV3_6, llvmV3_7, llvmV3_8 :: LLVMVer+llvmV3_5 = 0+llvmV3_6 = 1+llvmV3_7 = 2+llvmV3_8 = 3++-- | This value should be updated when support is added for new LLVM versions;+-- this is used for defaulting and otherwise reporting the maximum LLVM version+-- known to be supported.+llvmVlatest :: LLVMVer+llvmVlatest = 19+++-- | The differences between various versions of the llvm textual AST.+newtype Config = Config { cfgVer :: LLVMVer }++withConfig :: Config -> ((?config :: Config) => a) -> a+withConfig cfg body = let ?config = cfg in body+++ppLLVM :: LLVMVer -> ((?config :: Config) => a) -> a+ppLLVM llvmver = withConfig Config { cfgVer = llvmver }++ppLLVM35, ppLLVM36, ppLLVM37, ppLLVM38 :: ((?config :: Config) => a) -> a++ppLLVM35 = withConfig Config { cfgVer = llvmV3_5 }+ppLLVM36 = withConfig Config { cfgVer = llvmV3_6 }+ppLLVM37 = withConfig Config { cfgVer = llvmV3_7 }+ppLLVM38 = withConfig Config { cfgVer = llvmV3_8 }++llvmVer :: (?config :: Config) => LLVMVer+llvmVer = cfgVer ?config++llvmVerToString :: LLVMVer -> String+llvmVerToString 0 = "3.5"+llvmVerToString 1 = "3.6"+llvmVerToString 2 = "3.7"+llvmVerToString 3 = "3.8"+llvmVerToString n+ | n >= 4 = show n+ | otherwise = error $ "Invalid LLVMVer: " ++ show n++-- | This is a helper function for when a list of parameters is gated by a+-- condition (usually the llvmVer value).+when' :: Monoid a => Bool -> a -> a+when' c l = if c then l else mempty+++-- | This type encapsulates the ability to convert an object into Doc+-- format. Using this abstraction allows for a consolidated representation of the+-- declaration. Most pretty-printing for LLVM elements will have a @'Fmt' a@+-- function signature for that element.+type Fmt a = (?config :: Config) => a -> Doc+++-- | The LLVMPretty class has instances for most AST elements. It allows the+-- conversion of an AST element (and its sub-elements) into a Doc assembly format+-- by simply using the 'llvmPP' method rather than needing to explicitly invoke+-- the specific pretty-printing function for that element.+class LLVMPretty a where llvmPP :: Fmt a++instance LLVMPretty Module where llvmPP = ppModule+instance LLVMPretty Symbol where llvmPP = ppSymbol+instance LLVMPretty Ident where llvmPP = ppIdent+++-- Modules ---------------------------------------------------------------------++ppModule :: Fmt Module+ppModule m = foldr ($+$) empty+ $ ppSourceName (modSourceName m)+ : ppTargetTriple (modTriple m)+ : ppDataLayout (modDataLayout m)+ : ppInlineAsm (modInlineAsm m)+ : concat [ map ppTypeDecl (modTypes m)+ , map ppGlobal (modGlobals m)+ , map ppGlobalAlias (modAliases m)+ , map ppDeclare (modDeclares m)+ , map ppDefine (modDefines m)+ , map ppNamedMd (modNamedMd m)+ , map ppUnnamedMd (modUnnamedMd m)+ , map ppComdat (Map.toList (modComdat m))+ ]+++-- Source filename -------------------------------------------------------------++ppSourceName :: Fmt (Maybe String)+ppSourceName Nothing = empty+ppSourceName (Just sn) = "source_filename" <+> char '=' <+> doubleQuotes (text sn)++-- Metadata --------------------------------------------------------------------++ppNamedMd :: Fmt NamedMd+ppNamedMd nm =+ sep [ ppMetadata (text (nmName nm)) <+> char '='+ , ppMetadata (braces (commas (map (ppMetadata . int) (nmValues nm)))) ]++ppUnnamedMd :: Fmt UnnamedMd+ppUnnamedMd um =+ sep [ ppMetadata (int (umIndex um)) <+> char '='+ , distinct <+> ppValMd (umValues um) ]+ where+ distinct | umDistinct um = "distinct"+ | otherwise = empty+++-- Aliases ---------------------------------------------------------------------++ppGlobalAlias :: Fmt GlobalAlias+ppGlobalAlias g = ppSymbol (aliasName g)+ <+> char '='+ <+> ppMaybe ppLinkage (aliasLinkage g)+ <+> ppMaybe ppVisibility (aliasVisibility g)+ <+> body+ where+ val = aliasTarget g+ body = case val of+ ValSymbol _sym -> ppType (aliasType g) <+> ppValue val+ _ -> ppValue val+++-- Target triple ---------------------------------------------------------------++-- | Pretty print a 'TargetTriple'+ppTargetTriple :: Fmt TargetTriple+ppTargetTriple triple = "target" <+> "triple" <+> char '='+ <+> doubleQuotes (text (printTriple triple))++-- Data Layout -----------------------------------------------------------------++-- | Pretty print a data layout specification.+ppDataLayout :: Fmt DataLayout+ppDataLayout [] = empty+ppDataLayout ls = "target" <+> "datalayout" <+> char '='+ <+> doubleQuotes (hcat (intersperse (char '-') (map ppLayoutSpec ls)))++-- | Pretty print a single layout specification.+ppLayoutSpec :: Fmt LayoutSpec+ppLayoutSpec ls =+ case ls of+ BigEndian -> char 'E'+ LittleEndian -> char 'e'+ PointerSize ps -> char 'p' <> ppPointerSize ps+ IntegerSize sz -> char 'i' <> ppStorage sz+ VectorSize sz -> char 'v' <> ppStorage sz+ FloatSize sz -> char 'f' <> ppStorage sz+ StackObjSize sz -> char 's' <> ppStorage sz+ AggregateSize Nothing a -> char 'a' <> char ':' <> ppAlignment a+ AggregateSize (Just s) a -> char 'a' <> int s <> char ':' <> ppAlignment a+ NativeIntSize szs ->+ char 'n' <> hcat (punctuate (char ':') (map int szs))+ StackAlign a -> char 'S' <> int a+ ProgramAddrSpace as -> char 'P' <> int as+ GlobalAddrSpace as -> char 'G' <> int as+ AllocaAddrSpace as -> char 'A' <> int as+ FunctionPointerAlign ty abi ->+ char 'F' <> ppFunctionPointerAlignType ty <> int abi+ Mangling m -> char 'm' <> char ':' <> ppMangling m+ NonIntegralPointerSpaces asl ->+ "ni:" <> hcat (punctuate (char ':') (map int asl))++ppPointerSize :: Fmt PointerSize+ppPointerSize ps =+ if ptrAddrSpace ps == 0+ then char ':' <> ppStorage (ptrStorage ps)+ <> ppOptColonInt (ptrAddrIndexSize ps)+ else int (ptrAddrSpace ps) <> char ':' <> ppStorage (ptrStorage ps)+ <> ppOptColonInt (ptrAddrIndexSize ps)++ppStorage :: Fmt Storage+ppStorage s = int (storageSize s) <> char ':'+ <> ppAlignment (storageAlignment s)++ppAlignment :: Fmt Alignment+ppAlignment a = int (alignABI a) <> ppOptColonInt (alignPreferred a)++ppOptColonInt :: Fmt (Maybe Int)+ppOptColonInt = \case+ Nothing -> empty+ Just i -> char ':' <> int i++ppFunctionPointerAlignType :: Fmt FunctionPointerAlignType+ppFunctionPointerAlignType ty =+ case ty of+ IndependentOfFunctionAlign -> char 'i'+ MultipleOfFunctionAlign -> char 'n'++ppMangling :: Fmt Mangling+ppMangling ElfMangling = char 'e'+ppMangling GoffMangling = char 'l'+ppMangling MipsMangling = char 'm'+ppMangling MachOMangling = char 'o'+ppMangling WindowsCoffMangling = char 'w'+ppMangling WindowsX86CoffMangling = char 'x'+ppMangling XCoffMangling = char 'a'+++-- Inline Assembly -------------------------------------------------------------++-- | Pretty-print the inline assembly block.+ppInlineAsm :: Fmt InlineAsm+ppInlineAsm = foldr ($+$) empty . map ppLine+ where+ ppLine l = "module asm" <+> doubleQuotes (text l)+++-- Identifiers -----------------------------------------------------------------++ppIdent :: Fmt Ident+ppIdent (Ident n)+ | validIdentifier n = char '%' <> text n+ | otherwise = char '%' <> ppStringLiteral n++-- | According to the LLVM Language Reference Manual, the regular+-- expression for LLVM identifiers is "[-a-zA-Z$._][-a-zA-Z$._0-9]".+-- Identifiers may also be strings of one or more decimal digits.+validIdentifier :: String -> Bool+validIdentifier [] = False+validIdentifier s@(c0 : cs)+ | isDigit c0 = all isDigit cs+ | otherwise = all isIdentChar s+ where+ isIdentChar :: Char -> Bool+ isIdentChar c = isAlphaNum c || c `elem` ("-$._" :: [Char])+++-- Symbols ---------------------------------------------------------------------++ppSymbol :: Fmt Symbol+ppSymbol (Symbol n)+ | validIdentifier n = char '@' <> text n+ | otherwise = char '@' <> ppStringLiteral n+++-- Types -----------------------------------------------------------------------++ppPrimType :: Fmt PrimType+ppPrimType Label = "label"+ppPrimType Void = "void"+ppPrimType (Integer i) = char 'i' <> integer (toInteger i)+ppPrimType (FloatType ft) = ppFloatType ft+ppPrimType X86mmx = "x86mmx"+ppPrimType Metadata = "metadata"++ppFloatType :: Fmt FloatType+ppFloatType Half = "half"+ppFloatType Float = "float"+ppFloatType Double = "double"+ppFloatType Fp128 = "fp128"+ppFloatType X86_fp80 = "x86_fp80"+ppFloatType PPC_fp128 = "ppc_fp128"++ppType :: Fmt Type+ppType (PrimType pt) = ppPrimType pt+ppType (Alias i) = ppIdent i+ppType (Array len ty) = brackets (integral len <+> char 'x' <+> ppType ty)+ppType (PtrTo ty addr) = ppType ty <+> ppAddrSpace addr <> char '*'+ppType (PtrOpaque addr) = "ptr" <+> ppAddrSpace addr+ppType (Struct ts) = structBraces (commas (map ppType ts))+ppType (PackedStruct ts) = angles (structBraces (commas (map ppType ts)))+ppType (FunTy r as va) = ppType r <> ppArgList va (map ppType as)+ppType (Vector len pt) = angles (integral len <+> char 'x' <+> ppType pt)+ppType Opaque = "opaque"++-- | If the address space is default (0), print nothing; otherwise, print+-- @addrspace(n)@.+ppAddrSpace :: Fmt AddrSpace+ppAddrSpace (AddrSpace 0) = empty+ppAddrSpace (AddrSpace n) = "addrspace(" <> integer (toInteger n) <> ")"++ppTypeDecl :: Fmt TypeDecl+ppTypeDecl td = ppIdent (typeName td) <+> char '='+ <+> "type" <+> ppType (typeValue td)+++-- Declarations ----------------------------------------------------------------++ppGlobal :: Fmt Global+ppGlobal g = ppSymbol (globalSym g) <+> char '='+ <+> ppGlobalAttrs (isJust $ globalValue g) (globalAttrs g)+ <+> ppType (globalType g) <+> ppMaybe ppValue (globalValue g)+ <> ppAlign (globalAlign g)+ <> ppGlobalMetadata (Map.toList (globalMetadata g))++ppGlobalMetadata :: Fmt [(String, ValMd' BlockLabel)]+ppGlobalMetadata mds+ | null mds = empty+ | otherwise = comma <+> commas (map step mds)+ where+ step (l,md) = ppMetadata (text l) <+> ppValMd md++-- | Pretty-print Global Attributes (usually associated with a global variable+-- declaration). The first argument to ppGlobalAttrs indicates whether there is a+-- value associated with this global declaration: a global declaration with a+-- value should not be identified as \"external\" and \"default\" visibility,+-- whereas one without a value may have those attributes.++ppGlobalAttrs :: Bool -> Fmt GlobalAttrs+ppGlobalAttrs hasValue ga+ -- LLVM 3.8 does not emit or parse linkage information w/ hidden visibility+ | llvmVer <= llvmV3_8+ , Just HiddenVisibility <- gaVisibility ga =+ ppVisibility HiddenVisibility <+> constant+ | Just External <- gaLinkage ga+ , Just DefaultVisibility <- gaVisibility ga+ , hasValue =+ -- Just show the value, no "external" or "default". This is based on+ -- empirical testing as described in the comment above (testing the+ -- following 6 configurations:+ -- * uninitialized scalar+ -- * uninitialized structure+ -- * initialized scalar+ -- * initialized structure+ -- * external scalar+ -- * external structure+ constant+ | otherwise = ppMaybe ppLinkage (gaLinkage ga)+ <+> ppAddrSpace (gaAddrSpace ga)+ <+> ppMaybe ppVisibility (gaVisibility ga)+ <+> constant+ where+ constant | gaConstant ga = "constant"+ | otherwise = "global"++ppDeclare :: Fmt Declare+ppDeclare d = "declare"+ <+> ppMaybe ppLinkage (decLinkage d)+ <+> ppMaybe ppVisibility (decVisibility d)+ <+> ppType (decRetType d)+ <+> ppSymbol (decName d)+ <> ppArgList (decVarArgs d) (map ppType (decArgs d))+ <+> hsep (ppFunAttr <$> decAttrs d)+ <> maybe empty ((char ' ' <>) . ppComdatName) (decComdat d)++ppComdatName :: Fmt String+ppComdatName s = "comdat" <> parens (char '$' <> text s)++ppComdat :: Fmt (String,SelectionKind)+ppComdat (n,k) = ppComdatName n <+> char '=' <+> text "comdat" <+> ppSelectionKind k++ppSelectionKind :: Fmt SelectionKind+ppSelectionKind k =+ case k of+ ComdatAny -> "any"+ ComdatExactMatch -> "exactmatch"+ ComdatLargest -> "largest"+ ComdatNoDuplicates -> "noduplicates"+ ComdatSameSize -> "samesize"++ppDefine :: Fmt Define+ppDefine d = "define"+ <+> ppMaybe ppLinkage (defLinkage d)+ <+> ppMaybe ppVisibility (defVisibility d)+ <+> ppType (defRetType d)+ <+> ppSymbol (defName d)+ <> ppArgList (defVarArgs d) (map (ppTyped ppIdent) (defArgs d))+ <+> hsep (ppFunAttr <$> defAttrs d)+ <+> ppMaybe (\s -> "section" <+> doubleQuotes (text s)) (defSection d)+ <+> ppMaybe (\gc -> "gc" <+> ppGC gc) (defGC d)+ <+> ppMds (defMetadata d)+ <+> char '{'+ $+$ vcat (map ppBasicBlock (defBody d))+ $+$ char '}'+ where+ ppMds mdm =+ case Map.toList mdm of+ [] -> empty+ mds -> hsep [ "!" <> text k <+> ppValMd md | (k, md) <- mds ]++-- FunAttr ---------------------------------------------------------------------++ppFunAttr :: Fmt FunAttr+ppFunAttr a =+ case a of+ AlignStack w -> text "alignstack" <> parens (int w)+ Alwaysinline -> text "alwaysinline"+ Builtin -> text "builtin"+ Cold -> text "cold"+ Convergent -> onlyOnLLVM llvmV3_7 "Convergent" "convergent"+ InaccessibleMemOnly -> onlyOnLLVM llvmV3_8 "InaccessibleMemOnly" "inaccessiblememonly"+ Inlinehint -> text "inlinehint"+ Jumptable -> text "jumptable"+ Minsize -> text "minsize"+ Naked -> text "naked"+ Nobuiltin -> text "nobuiltin"+ Noduplicate -> text "noduplicate"+ Noimplicitfloat -> text "noimplicitfloat"+ Noinline -> text "noinline"+ Nonlazybind -> text "nonlazybind"+ Noredzone -> text "noredzone"+ Noreturn -> text "noreturn"+ Nounwind -> text "nounwind"+ Optnone -> text "optnone"+ Optsize -> text "optsize"+ Readnone -> text "readnone"+ Readonly -> text "readonly"+ ReturnsTwice -> text "returns_twice"+ SanitizeAddress -> text "sanitize_address"+ SanitizeMemory -> text "sanitize_memory"+ SanitizeThread -> text "sanitize_thread"+ SSP -> text "ssp"+ SSPreq -> text "sspreq"+ SSPstrong -> text "sspstrong"+ UWTable -> text "uwtable"++-- Basic Blocks ----------------------------------------------------------------++ppLabelDef :: Fmt BlockLabel+ppLabelDef (Named (Ident l)) = text l <> char ':'+ppLabelDef (Anon i) = char ';' <+> "<label>:" <+> int i++ppLabel :: Fmt BlockLabel+ppLabel (Named l) = ppIdent l+ppLabel (Anon i) = char '%' <> int i++ppBasicBlock :: Fmt BasicBlock+ppBasicBlock bb = ppMaybe ppLabelDef (bbLabel bb)+ $+$ nest 2 (vcat (map ppStmt (bbStmts bb)))+++-- Statements ------------------------------------------------------------------++ppStmt :: Fmt Stmt+ppStmt stmt = case stmt of+ Result var i drs mds -> ppDebugRecords drs (ppIdent var <+> char '='+ <+> ppInstr i+ <> ppAttachedMetadata mds)+ Effect i drs mds -> ppDebugRecords drs (ppInstr i+ <> ppAttachedMetadata mds)++ppAttachedMetadata :: Fmt [(String,ValMd)]+ppAttachedMetadata mds+ | null mds = empty+ | otherwise = comma <+> commas (map step mds)+ where+ step (l,md) = ppMetadata (text l) <+> ppValMd md+++-- Linkage ---------------------------------------------------------------------++ppLinkage :: Fmt Linkage+ppLinkage linkage = case linkage of+ Private -> "private"+ LinkerPrivate -> "linker_private"+ LinkerPrivateWeak -> "linker_private_weak"+ LinkerPrivateWeakDefAuto -> "linker_private_weak_def_auto"+ Internal -> "internal"+ AvailableExternally -> "available_externally"+ Linkonce -> "linkonce"+ Weak -> "weak"+ Common -> "common"+ Appending -> "appending"+ ExternWeak -> "extern_weak"+ LinkonceODR -> "linkonce_ddr"+ WeakODR -> "weak_odr"+ External -> "external"+ DLLImport -> "dllimport"+ DLLExport -> "dllexport"++ppVisibility :: Fmt Visibility+ppVisibility v = case v of+ DefaultVisibility -> "default"+ HiddenVisibility -> "hidden"+ ProtectedVisibility -> "protected"++ppGC :: Fmt GC+ppGC = doubleQuotes . text . getGC+++-- Expressions -----------------------------------------------------------------++ppTyped :: Fmt a -> Fmt (Typed a)+ppTyped fmt ty = ppType (typedType ty) <+> fmt (typedValue ty)++ppSignBits :: Bool -> Fmt Bool+ppSignBits nuw nsw = opt nuw "nuw" <+> opt nsw "nsw"++ppFMF1 :: Fmt FMF+ppFMF1 Ffast = "fast"+ppFMF1 Fnnan = "nnan"+ppFMF1 Fninf = "ninf"+ppFMF1 Fnsz = "nsz"+ppFMF1 Farcp = "arcp"+ppFMF1 Fcontract = "contract"+ppFMF1 Fafn = "afn"+ppFMF1 Freassoc = "reassoc"++ppFMF :: Fmt [FMF]+ppFMF = hsep . map ppFMF1++ppExact :: Fmt Bool+ppExact e = opt e "exact"++ppArithOp :: Fmt ArithOp+ppArithOp (Add nuw nsw) = "add" <+> ppSignBits nuw nsw+ppArithOp (FAdd fmf) = "fadd" <+> ppFMF fmf+ppArithOp (Sub nuw nsw) = "sub" <+> ppSignBits nuw nsw+ppArithOp (FSub fmf) = "fsub" <+> ppFMF fmf+ppArithOp (Mul nuw nsw) = "mul" <+> ppSignBits nuw nsw+ppArithOp (FMul fmf) = "fmul" <+> ppFMF fmf+ppArithOp (UDiv e) = "udiv" <+> ppExact e+ppArithOp (SDiv e) = "sdiv" <+> ppExact e+ppArithOp (FDiv fmf) = "fdiv" <+> ppFMF fmf+ppArithOp URem = "urem"+ppArithOp SRem = "srem"+ppArithOp (FRem fmf) = "frem" <+> ppFMF fmf++ppUnaryArithOp :: Fmt UnaryArithOp+ppUnaryArithOp (FNeg fmf) = "fneg" <+> ppFMF fmf++ppBitOp :: Fmt BitOp+ppBitOp (Shl nuw nsw) = "shl" <+> ppSignBits nuw nsw+ppBitOp (Lshr e) = "lshr" <+> ppExact e+ppBitOp (Ashr e) = "ashr" <+> ppExact e+ppBitOp And = "and"+ppBitOp Or = "or"+ppBitOp Xor = "xor"++ppConvOp :: Fmt ConvOp+ppConvOp (Trunc nuw nsw) = "trunc" <+> ppSignBits nuw nsw+ppConvOp (ZExt nneg) = "zext" <+> opt nneg "nneg"+ppConvOp SExt = "sext"+ppConvOp FpTrunc = "fptrunc"+ppConvOp FpExt = "fpext"+ppConvOp FpToUi = "fptoui"+ppConvOp FpToSi = "fptosi"+ppConvOp (UiToFp nneg) = "uitofp" <+> opt nneg "nneg"+ppConvOp SiToFp = "sitofp"+ppConvOp PtrToInt = "ptrtoint"+ppConvOp IntToPtr = "inttoptr"+ppConvOp BitCast = "bitcast"++ppAtomicOrdering :: Fmt AtomicOrdering+ppAtomicOrdering Unordered = text "unordered"+ppAtomicOrdering Monotonic = text "monotonic"+ppAtomicOrdering Acquire = text "acquire"+ppAtomicOrdering Release = text "release"+ppAtomicOrdering AcqRel = text "acq_rel"+ppAtomicOrdering SeqCst = text "seq_cst"++ppAtomicOp :: Fmt AtomicRWOp+ppAtomicOp AtomicXchg = "xchg"+ppAtomicOp AtomicAdd = "add"+ppAtomicOp AtomicSub = "sub"+ppAtomicOp AtomicAnd = "and"+ppAtomicOp AtomicNand = "nand"+ppAtomicOp AtomicOr = "or"+ppAtomicOp AtomicXor = "xor"+ppAtomicOp AtomicMax = "max"+ppAtomicOp AtomicMin = "min"+ppAtomicOp AtomicUMax = "umax"+ppAtomicOp AtomicUMin = "umin"+ppAtomicOp AtomicFAdd = onlyOnLLVM 9 "AtomicFAdd" "fadd"+ppAtomicOp AtomicFSub = onlyOnLLVM 9 "AtomicFSub" "fsub"+ppAtomicOp AtomicFMax = onlyOnLLVM 15 "AtomicFMax" "fmax"+ppAtomicOp AtomicFMin = onlyOnLLVM 15 "AtomicFMin" "fmin"+ppAtomicOp AtomicUIncWrap = onlyOnLLVM 16 "AtomicUIncWrap" "uinc_wrap"+ppAtomicOp AtomicUDecWrap = onlyOnLLVM 16 "AtomicUDecWrap" "udec_wrap"++ppScope :: Fmt (Maybe String)+ppScope Nothing = empty+ppScope (Just s) = "syncscope" <> parens (doubleQuotes (text s))++ppInstr :: Fmt Instr+ppInstr instr = case instr of+ Ret tv -> "ret" <+> ppTyped ppValue tv+ RetVoid -> "ret void"+ Arith op l r -> ppArithOp op <+> ppTyped ppValue l+ <> comma <+> ppValue r+ UnaryArith op a -> ppUnaryArithOp op <+> ppTyped ppValue a+ Bit op l r -> ppBitOp op <+> ppTyped ppValue l+ <> comma <+> ppValue r+ Conv op a ty -> ppConvOp op <+> ppTyped ppValue a+ <+> "to" <+> ppType ty+ Call tc fmf ty f args -> ppCall tc fmf ty f args+ CallBr ty f args u es -> ppCallBr ty f args u es+ Alloca ty len align -> ppAlloca ty len align+ Load vol ty ptr mo ma -> ppLoad vol ty ptr mo ma+ Store vol a ptr mo ma -> ppStore vol a ptr mo ma+ Fence scope order -> "fence" <+> ppScope scope <+> ppAtomicOrdering order+ CmpXchg w v p a n s o o' -> "cmpxchg" <+> opt w "weak"+ <+> opt v "volatile"+ <+> ppTyped ppValue p+ <> comma <+> ppTyped ppValue a+ <> comma <+> ppTyped ppValue n+ <+> ppScope s+ <+> ppAtomicOrdering o+ <+> ppAtomicOrdering o'+ AtomicRW v op p a s o -> "atomicrmw"+ <+> opt v "volatile"+ <+> ppAtomicOp op+ <+> ppTyped ppValue p+ <> comma <+> ppTyped ppValue a+ <+> ppScope s+ <+> ppAtomicOrdering o+ ICmp samesign op l r -> "icmp" <+> opt samesign "samesign" <+> ppICmpOp op+ <+> ppTyped ppValue l <> comma <+> ppValue r+ FCmp fmf op l r -> "fcmp" <+> ppFMF fmf <+> ppFCmpOp op+ <+> ppTyped ppValue l <> comma <+> ppValue r+ Phi fmf ty vls -> "phi" <+> ppFMF fmf <+> ppType ty+ <+> commas (map ppPhiArg vls)+ Select fmf c t f -> "select" <+> ppFMF fmf <+> ppTyped ppValue c+ <> comma <+> ppTyped ppValue t+ <> comma <+> ppTyped ppValue (f <$ t)+ ExtractValue v is -> "extractvalue" <+> ppTyped ppValue v+ <> comma <+> (commas (map integral is))+ InsertValue a v is -> "insertvalue" <+> ppTyped ppValue a+ <> comma <+> ppTyped ppValue v+ <> comma <+> commas (map integral is)+ ShuffleVector a b m -> "shufflevector" <+> ppTyped ppValue a+ <> comma <+> ppTyped ppValue (b <$ a)+ <> comma <+> ppTyped ppValue m+ GEP gf ty ptr ixs -> ppGEP gf ty ptr ixs+ Comment str -> char ';' <+> text str+ Jump i -> "br"+ <+> ppTypedLabel i+ Br c t f -> "br" <+> ppTyped ppValue c+ <> comma <+> ppType (PrimType Label)+ <+> ppLabel t+ <> comma <+> ppType (PrimType Label)+ <+> ppLabel f+ Invoke ty f args to uw -> ppInvoke ty f args to uw+ Unreachable -> "unreachable"+ Unwind -> "unwind"+ VaArg al t -> "va_arg" <+> ppTyped ppValue al+ <> comma <+> ppType t+ ExtractElt v i -> "extractelement"+ <+> ppTyped ppValue v+ <> comma <+> ppVectorIndex i+ InsertElt v e i -> "insertelement"+ <+> ppTyped ppValue v+ <> comma <+> ppTyped ppValue e+ <> comma <+> ppVectorIndex i+ IndirectBr d ls -> "indirectbr"+ <+> ppTyped ppValue d+ <> comma+ <+> char '['+ <+> commas (map ppTypedLabel ls)+ <+> char ']'+ Switch c d ls -> "switch"+ <+> ppTyped ppValue c+ <> comma <+> ppTypedLabel d+ <+> char '['+ $$ nest 2 (vcat (map (ppSwitchEntry (typedType c)) ls))+ $$ char ']'+ LandingPad ty mfn c cs ->+ case mfn of+ Just fn -> "landingpad"+ <+> ppType ty+ <+> "personality"+ <+> ppTyped ppValue fn+ $$ nest 2 (ppClauses c cs)+ Nothing -> "landingpad"+ <+> ppType ty+ $$ nest 2 (ppClauses c cs)+ Resume tv -> "resume" <+> ppTyped ppValue tv+ Freeze tv -> "freeze" <+> ppTyped ppValue tv++ppLoad :: Bool+ -> Type+ -> Typed (Value' BlockLabel)+ -> Maybe AtomicOrdering+ -> Fmt (Maybe Align)+ppLoad volatile ty ptr mo ma =+ "load" <+> (if volatile then "volatile" else empty)+ <+> (if isAtomic then "atomic" else empty)+ <+> (if isExplicit then explicit else empty)+ <+> ppTyped ppValue ptr+ <+> ordering+ <> ppAlign ma++ where+ isAtomic = isJust mo++ isExplicit = llvmVer >= llvmV3_7++ ordering =+ case mo of+ Just ao -> ppAtomicOrdering ao+ _ -> empty++ explicit = ppType ty <> comma++ppStore :: Bool+ -> Typed (Value' BlockLabel)+ -> Typed (Value' BlockLabel)+ -> Maybe AtomicOrdering+ -> Fmt (Maybe Align)+ppStore volatile ptr val mo ma =+ "store" <+> (if volatile then "volatile" else empty)+ <+> (if isJust mo then "atomic" else empty)+ <+> ppTyped ppValue ptr <> comma+ <+> ppTyped ppValue val+ <+> case mo of+ Just ao -> ppAtomicOrdering ao+ _ -> empty+ <> ppAlign ma+++ppClauses :: Bool -> Fmt [Clause]+ppClauses isCleanup cs = vcat (cleanup : map ppClause cs)+ where+ cleanup | isCleanup = "cleanup"+ | otherwise = empty++ppClause :: Fmt Clause+ppClause c = case c of+ Catch tv -> "catch" <+> ppTyped ppValue tv+ Filter tv -> "filter" <+> ppTyped ppValue tv+++ppTypedLabel :: Fmt BlockLabel+ppTypedLabel i = ppType (PrimType Label) <+> ppLabel i++ppSwitchEntry :: Type -> Fmt (Integer,BlockLabel)+ppSwitchEntry ty (i,l) = ppType ty <+> integer i <> comma <+> ppTypedLabel l++ppVectorIndex :: Fmt Value+ppVectorIndex i = ppType (PrimType (Integer 32)) <+> ppValue i++ppAlign :: Fmt (Maybe Align)+ppAlign Nothing = empty+ppAlign (Just align) = comma <+> "align" <+> int align++ppAlloca :: Type -> Maybe (Typed Value) -> Fmt (Maybe Int)+ppAlloca ty mbLen mbAlign = "alloca" <+> ppType ty <> len <> align+ where+ len = fromMaybe empty $ do+ l <- mbLen+ return (comma <+> ppTyped ppValue l)+ align = fromMaybe empty $ do+ a <- mbAlign+ return (comma <+> "align" <+> int a)++ppCall :: Bool -> [FMF] -> Type -> Value -> Fmt [Typed Value]+ppCall tc fmf ty f args+ | tc = "tail" <+> body+ | otherwise = body+ where+ body = "call" <+> ppFMF fmf <+> ppCallSym ty f+ <> parens (commas (map (ppTyped ppValue) args))++-- | Note that the textual syntax changed in LLVM 10 (@callbr@ was introduced in+-- LLVM 9).+ppCallBr :: Type -> Value -> [Typed Value] -> BlockLabel -> Fmt [BlockLabel]+ppCallBr ty f args to indirectDests =+ "callbr"+ <+> ppCallSym ty f <> parens (commas (map (ppTyped ppValue) args))+ <+> "to" <+> ppLab to <+> brackets (commas (map ppLab indirectDests))+ where+ ppLab l = ppType (PrimType Label) <+> ppLabel l++-- | Print out the @<ty>|<fnty> <fnptrval>@ portion of a @call@, @callbr@, or+-- @invoke@ instruction, where:+--+-- * @<ty>@ is the return type.+--+-- * @<fnty>@ is the overall function type.+--+-- * @<fnptrval>@ is a pointer value, where the memory it points to is treated+-- as a value of type @<fnty>@.+--+-- The LLVM Language Reference Manual indicates that either @<ty>@ or @<fnty>@+-- can be used, but in practice, @<ty>@ is typically preferred unless the+-- function type involves varargs. We adopt the same convention here.+ppCallSym :: Type -> Fmt Value+ppCallSym ty val = pp_ty <+> ppValue val+ where+ pp_ty =+ case ty of+ FunTy res args va+ | va+ -> ppType res <+> ppArgList va (map ppType args)+ | otherwise+ -> ppType res+ _ -> ppType ty++ppGEP :: [GEPAttr] -> Type -> Typed Value -> Fmt [Typed Value]+ppGEP gf ty ptr ixs =+ "getelementptr"+ <+> (if inlineIsBool+ then (if GEP_Inbounds `elem` gf then "inbounds" else empty)+ else ppGepFlags gf)+ <+> (if isExplicit then explicit else empty)+ <+> commas (map (ppTyped ppValue) (ptr:ixs))+ where+ isExplicit = llvmVer >= llvmV3_7+ inlineIsBool = llvmVer < 19++ explicit = ppType ty <> comma++ppInvoke :: Type -> Value -> [Typed Value] -> BlockLabel -> Fmt BlockLabel+ppInvoke ty f args to uw = body+ where+ body = "invoke" <+> ppCallSym ty f+ <> parens (commas (map (ppTyped ppValue) args))+ <+> "to" <+> ppType (PrimType Label) <+> ppLabel to+ <+> "unwind" <+> ppType (PrimType Label) <+> ppLabel uw++ppPhiArg :: Fmt (Value,BlockLabel)+ppPhiArg (v,l) = char '[' <+> ppValue v <> comma <+> ppLabel l <+> char ']'++ppICmpOp :: Fmt ICmpOp+ppICmpOp Ieq = "eq"+ppICmpOp Ine = "ne"+ppICmpOp Iugt = "ugt"+ppICmpOp Iuge = "uge"+ppICmpOp Iult = "ult"+ppICmpOp Iule = "ule"+ppICmpOp Isgt = "sgt"+ppICmpOp Isge = "sge"+ppICmpOp Islt = "slt"+ppICmpOp Isle = "sle"++ppFCmpOp :: Fmt FCmpOp+ppFCmpOp Ffalse = "false"+ppFCmpOp Foeq = "oeq"+ppFCmpOp Fogt = "ogt"+ppFCmpOp Foge = "oge"+ppFCmpOp Folt = "olt"+ppFCmpOp Fole = "ole"+ppFCmpOp Fone = "one"+ppFCmpOp Ford = "ord"+ppFCmpOp Fueq = "ueq"+ppFCmpOp Fugt = "ugt"+ppFCmpOp Fuge = "uge"+ppFCmpOp Fult = "ult"+ppFCmpOp Fule = "ule"+ppFCmpOp Fune = "une"+ppFCmpOp Funo = "uno"+ppFCmpOp Ftrue = "true"++ppValue' :: Fmt i -> Fmt (Value' i)+ppValue' pp val = case val of+ ValInteger i -> integer i+ ValBool b -> ppBool b+ -- Note: for +Inf/-Inf/NaNs, we want to output the bit-correct sequence+ ValFloat f ->+ -- WARNING: You should **not** use `castFloatToWord32` or `float` here. LLVM IR does not+ -- support 32-bit floating point constants, instead it wants to see 32-bit compatible 64-bit+ -- constants. We want to preserve the exact mantissa (zero-extended to the right from 23 to+ -- 52 bits), which happens to be the behavior of `float2Double`.+ text "0x" <> text (showHex (castDoubleToWord64 (float2Double f)) "")+ ValDouble d ->+ if isInfinite d || isNaN d+ then text "0x" <> text (showHex (castDoubleToWord64 d) "")+ else double d+ ValFP80 (FP80_LongDouble e s) ->+ -- shown as 0xK<<20-hex-digits>>, per+ -- https://llvm.org/docs/LangRef.html#simple-constants+ let pad n | n < 0x10 = shows (0::Int) . showHex n+ | otherwise = showHex n+ fld v i = pad ((v `shiftR` (i * 8)) .&. 0xff)+ in "0xK" <> text (foldr (fld e) (foldr (fld s) "" $ reverse [0..7::Int]) [1, 0])+ ValIdent i -> ppIdent i+ ValSymbol s -> ppSymbol s+ ValNull -> "null"+ ValArray ty es -> brackets+ $ commas (map (ppTyped (ppValue' pp) . Typed ty) es)+ ValVector ty es -> angles $ commas+ $ map (ppTyped (ppValue' pp) . Typed ty) es+ ValStruct fs -> structBraces (commas (map (ppTyped (ppValue' pp)) fs))+ ValPackedStruct fs -> angles+ $ structBraces (commas (map (ppTyped (ppValue' pp)) fs))+ ValString s -> char 'c' <> ppStringLiteral (map (toEnum . fromIntegral) s)+ ValConstExpr ce -> ppConstExpr' pp ce+ ValUndef -> "undef"+ ValLabel l -> pp l+ ValZeroInit -> "zeroinitializer"+ ValAsm s a i c -> ppAsm s a i c+ ValMd m -> ppValMd' pp m+ ValPoison -> "poison"++ppValue :: Fmt Value+ppValue = ppValue' ppLabel++ppValMd' :: Fmt i -> Fmt (ValMd' i)+ppValMd' pp m = case m of+ ValMdString str -> ppMetadata (ppStringLiteral str)+ ValMdValue tv -> ppTyped (ppValue' pp) tv+ ValMdRef i -> ppMetadata (int i)+ ValMdNode vs -> ppMetadataNode' pp vs+ ValMdLoc l -> ppDebugLoc' pp l+ ValMdDebugInfo di -> ppDebugInfo' pp di++ppValMd :: Fmt ValMd+ppValMd = ppValMd' ppLabel++ppDebugLoc' :: Fmt i -> Fmt (DebugLoc' i)+ppDebugLoc' pp dl = (if llvmVer >= llvmV3_7 then "!DILocation"+ else "!MDLocation")+ <> parens (commas [ "line:" <+> integral (dlLine dl)+ , "column:" <+> integral (dlCol dl)+ , "scope:" <+> ppValMd' pp (dlScope dl)+ ] <> mbIA <> mbImplicit <>+ when' (llvmVer >= 21) (mbAtomGroup <> mbAtomRank))++ where+ mbIA = case dlIA dl of+ Just md -> comma <+> "inlinedAt:" <+> ppValMd' pp md+ Nothing -> empty+ mbImplicit = if dlImplicit dl then comma <+> "implicit" else empty+ mbAtomGroup = if dlAtomGroup dl > 0+ then comma <+> "atomGroup:" <+> integral (dlAtomGroup dl)+ else empty+ mbAtomRank = if dlAtomRank dl > 0+ then comma <+> "atomRank:" <+> integral (dlAtomRank dl)+ else empty++ppDebugLoc :: Fmt DebugLoc+ppDebugLoc = ppDebugLoc' ppLabel++ppTypedValMd :: Fmt ValMd+ppTypedValMd = ppTyped ppValMd . Typed (PrimType Metadata)++ppMetadata :: Fmt Doc+ppMetadata body = char '!' <> body++ppMetadataNode' :: Fmt i -> Fmt [Maybe (ValMd' i)]+ppMetadataNode' pp vs = ppMetadata (braces (commas (map arg vs)))+ where arg = maybe ("null") (ppValMd' pp)++ppMetadataNode :: Fmt [Maybe ValMd]+ppMetadataNode = ppMetadataNode' ppLabel++ppStringLiteral :: Fmt String+ppStringLiteral = doubleQuotes . text . concatMap escape+ where+ escape c | c == '"' || c == '\\' = '\\' : showHex (fromEnum c) ""+ | isAscii c && isPrint c = [c]+ | otherwise = '\\' : pad (ord c)++ pad n | n < 0x10 = '0' : map toUpper (showHex n "")+ | otherwise = map toUpper (showHex n "")++ppAsm :: Bool -> Bool -> String -> Fmt String+ppAsm s a i c =+ "asm" <+> sideeffect <+> alignstack+ <+> ppStringLiteral i <> comma <+> ppStringLiteral c+ where+ sideeffect | s = "sideeffect"+ | otherwise = empty++ alignstack | a = "alignstack"+ | otherwise = empty+++ppConstExpr' :: Fmt i -> Fmt (ConstExpr' i)+ppConstExpr' pp expr =+ case expr of+ ConstGEP optflgs mrng ty ptr ixs ->+ "getelementptr"+ <+> ppGepFlags optflgs+ <+> ppRange mrng+ <+> parens (commas (+ let argIndices = 0 : [0..] -- rval, ptr, then ixs indices+ in reverse -- ppTyp's pushes entries to the listg head+ $ foldl (ppTyp's mrng) [ppType ty]+ $ zip argIndices (ptr:ixs)))+ ConstConv op tv t ->+ let droppedIn18 = case op of+ -- https://github.com/llvm/llvm-project commit e4a4122 dropped ZExt and SExt+ ZExt _ -> True+ SExt -> True+ -- https://github.com/llvm/llvm-project commit 17764d2 dropped FpTrunc through SiToFP+ FpTrunc -> True+ FpExt -> True+ FpToUi -> True+ FpToSi -> True+ UiToFp _ -> True+ SiToFp -> True+ _ -> False+ ppConstConv = ppConvOp op <+> parens (ppTyp' tv <+> "to" <+> ppType t)+ in if droppedIn18+ then droppedInLLVM 18 "fptrunc/fpext/fptoui/fptosi/uitofp/sitofp constexprs" ppConstConv+ else ppConstConv+ ConstSelect c l r ->+ droppedInLLVM 17 "select constexpr" -- https://github.com/llvm/llvm-project commit bbfb13a++ $ "select" <+> parens (commas [ ppTyp' c, ppTyp' l , ppTyp' r])+ ConstBlockAddr t l -> "blockaddress" <+> parens (ppVal' (typedValue t) <> comma <+> pp l)+ ConstFCmp op a b -> droppedInLLVM 19 "fcmp constexprs"+ $ "fcmp" <+> ppFCmpOp op <+> ppTupleT a b+ ConstICmp op a b -> droppedInLLVM 19 "icmp constexprs"+ $ "icmp" <+> ppICmpOp op <+> ppTupleT a b+ ConstArith op a b -> ppArithOp op <+> ppTuple a b+ ConstUnaryArith op a -> ppUnaryArithOp op <+> ppTyp' a+ ConstBit op@(Shl _ _) a b -> droppedInLLVM 19 "shl constexprs"+ $ ppBitOp op <+> ppTuple a b+ ConstBit Xor a b -> ppBitOp Xor <+> ppTuple a b+ ConstBit op a b -> droppedInLLVM 18 "and/or/lshr/ashr constexprs"+ $ ppBitOp op <+> ppTuple a b+ where ppTuple a b = parens $ ppTyped ppVal' a <> comma <+> ppVal' b+ ppTupleT a b = parens $ ppTyped ppVal' a <> comma <+> ppTyp' b+ ppVal' = ppValue' pp+ ppTyp' = ppTyped ppVal'+ ppTyp's mrng a (i,t) =+ let inrangeMark = if Just (RangeIndex i) == mrng then "inrange" else empty+ in (inrangeMark <+> ppTyp' t) : a+ ppRange =+ let ppR = \case+ RangeIndex _i -> empty -- handled in ppTyp's+ Range _ l u ->+ "inrange(" <> integral l <> ", " <> integral u <> ")"+ in maybe empty ppR++ppGepFlags :: Fmt [GEPAttr]+ppGepFlags s =+ let fltr = if GEP_Inbounds `elem` s+ then+ -- inbounds implies nusw, but LLVM stipulates that if+ -- inbounds is present, nusw is not also printed.+ filter (/= GEP_NUSW)+ else id+ ppF = \case+ GEP_Inbounds -> "inbounds"+ GEP_NUSW -> "nusw"+ GEP_NUW -> "nuw"+ in foldl (\o f -> o <+> ppF f) empty $ fltr $ nub s++ppConstExpr :: Fmt ConstExpr+ppConstExpr = ppConstExpr' ppLabel++-- DWARF Debug Info ------------------------------------------------------------++ppDebugInfo' :: Fmt i -> Fmt (DebugInfo' i)+ppDebugInfo' pp di = case di of+ DebugInfoBasicType bt -> ppDIBasicType' pp bt+ DebugInfoCompileUnit cu -> ppDICompileUnit' pp cu+ DebugInfoCompositeType ct -> ppDICompositeType' pp ct+ DebugInfoDerivedType dt -> ppDIDerivedType' pp dt+ DebugInfoEnumerator nm v u -> ppDIEnumerator nm v u+ DebugInfoExpression e -> ppDIExpression e+ DebugInfoFile f -> ppDIFile f+ DebugInfoGlobalVariable gv -> ppDIGlobalVariable' pp gv+ DebugInfoGlobalVariableExpression gv -> ppDIGlobalVariableExpression' pp gv+ DebugInfoLexicalBlock lb -> ppDILexicalBlock' pp lb+ DebugInfoLexicalBlockFile lbf -> ppDILexicalBlockFile' pp lbf+ DebugInfoLocalVariable lv -> ppDILocalVariable' pp lv+ DebugInfoSubprogram sp -> ppDISubprogram' pp sp+ DebugInfoSubrange sr -> ppDISubrange' pp sr+ DebugInfoSubroutineType st -> ppDISubroutineType' pp st+ DebugInfoNameSpace ns -> ppDINameSpace' pp ns+ DebugInfoTemplateTypeParameter dttp -> ppDITemplateTypeParameter' pp dttp+ DebugInfoTemplateValueParameter dtvp -> ppDITemplateValueParameter' pp dtvp+ DebugInfoImportedEntity diip -> ppDIImportedEntity' pp diip+ DebugInfoLabel dil -> ppDILabel' pp dil+ DebugInfoArgList args -> ppDIArgList' pp args+ DebugInfoAssignID -> "!DIAssignID()"+ -- DebugRecordDeclare drd -> ppDbgRecDeclare' pp drd++-- Prints DebugRecords (introduced in LLVM 19) which replace debug intrinsics and+-- unlike the intrinsics that follow the instruction, the debug records *precede*+-- the Instruction they affect.+ppDebugRecords :: [DebugRecord' BlockLabel] -> Fmt Doc+ppDebugRecords [] = id+ppDebugRecords drs = ((nest 2 $ vcat (ppDebugRecord' ppLabel <$> drs)) $$)++ppDebugRecord' :: Fmt lab -> Fmt (DebugRecord' lab)+ppDebugRecord' pl = \case+ DebugRecordValue drv -> ppDbgRecValue' pl drv+ DebugRecordDeclare drd -> ppDbgRecDeclare' pl drd+ DebugRecordAssign dra -> ppDbgRecAssign' pl dra+ DebugRecordValueSimple dvs -> ppDbgRecValueSimple' pl dvs+ DebugRecordLabel drl -> ppDbgRecLabel' pl drl++ppDbgRecValue' :: Fmt lab -> Fmt (DbgRecValue' lab)+ppDbgRecValue' pl dr =+ "#dbg_value"+ <> parens (commas [ ppValMd' pl $ drvValAsMetadata dr+ , ppValMd' pl $ drvLocalVariable dr+ , ppValMd' pl $ drvExpression dr+ , ppValMd' pl $ drvLocation dr+ ])++ppDbgRecDeclare' :: Fmt lab -> Fmt (DbgRecDeclare' lab)+ppDbgRecDeclare' pl dr =+ "#dbg_declare"+ <> parens (commas [ ppValMd' pl $ drdValAsMetadata dr+ , ppValMd' pl $ drdLocalVariable dr+ , ppValMd' pl $ drdExpression dr+ , ppValMd' pl $ drdLocation dr+ ])++ppDbgRecAssign' :: Fmt lab -> Fmt (DbgRecAssign' lab)+ppDbgRecAssign' pl dr =+ "#dbg_assign"+ <> parens (commas [ ppValMd' pl $ draValAsMetadata dr+ , ppValMd' pl $ draLocalVariable dr+ , ppValMd' pl $ draExpression dr+ , ppValMd' pl $ draAssignID dr+ , ppValMd' pl $ draValAsMetadataAddr dr+ , ppValMd' pl $ draExpressionAddr dr+ , ppValMd' pl $ draLocation dr+ ])++ppDbgRecValueSimple' :: Fmt lab -> Fmt (DbgRecValueSimple' lab)+ppDbgRecValueSimple' pl dr =+ "#dbg_value"+ <> parens (commas [ ppTyped (ppValue' pl) $ drvsValue dr+ , ppValMd' pl $ drvsLocalVariable dr+ , ppValMd' pl $ drvsExpression dr+ , ppValMd' pl $ drvsLocation dr+ ])++ppDbgRecLabel' :: Fmt lab -> Fmt (DbgRecLabel' lab)+ppDbgRecLabel' pl dr =+ "#dbg_label"+ <> parens (commas [ ppValMd' pl $ drlLabel dr+ , ppValMd' pl $ drlLocation dr+ ])++ppDebugInfo :: Fmt DebugInfo+ppDebugInfo = ppDebugInfo' ppLabel++ppDIImportedEntity' :: Fmt i -> Fmt (DIImportedEntity' i)+ppDIImportedEntity' pp ie = "!DIImportedEntity"+ <> parens (mcommas [ pure ("tag:" <+> integral (diieTag ie))+ , (("scope:" <+>) . ppValMd' pp) <$> diieScope ie+ , (("entity:" <+>) . ppValMd' pp) <$> diieEntity ie+ , (("file:" <+>) . ppValMd' pp) <$> diieFile ie+ , pure ("line:" <+> integral (diieLine ie))+ , (("name:" <+>) . text) <$> diieName ie+ ])++ppDIImportedEntity :: Fmt DIImportedEntity+ppDIImportedEntity = ppDIImportedEntity' ppLabel++ppDILabel' :: Fmt i -> Fmt (DILabel' i)+ppDILabel' pp ie = "!DILabel"+ <> parens (mcommas $+ [ (("scope:" <+>) . ppValMd' pp) <$> dilScope ie+ , pure ("name:" <+> ppStringLiteral (dilName ie))+ , (("file:" <+>) . ppValMd' pp) <$> dilFile ie+ , pure ("line:" <+> integral (dilLine ie))+ ] +++ when' (llvmVer >= 21)+ [ pure ("column:" <+> integral (dilColumn ie))+ , pure ("isArtificial:" <+> ppBool (dilIsArtificial ie))+ , (("coroSuspendIdx:" <+>) . integral) <$> dilCoroSuspendIdx ie+ ])++ppDILabel :: Fmt DILabel+ppDILabel = ppDILabel' ppLabel++ppDINameSpace' :: Fmt i -> Fmt (DINameSpace' i)+ppDINameSpace' pp ns = "!DINameSpace"+ <> parens (mcommas [ ("name:" <+>) . text <$> (dinsName ns)+ , pure ("scope:" <+> ppValMd' pp (dinsScope ns))+ , pure ("file:" <+> ppValMd' pp (dinsFile ns))+ , pure ("line:" <+> integral (dinsLine ns))+ ])++ppDINameSpace :: Fmt DINameSpace+ppDINameSpace = ppDINameSpace' ppLabel++ppDITemplateTypeParameter' :: Fmt i -> Fmt (DITemplateTypeParameter' i)+ppDITemplateTypeParameter' pp tp = "!DITemplateTypeParameter"+ <> parens (mcommas [ ("name:" <+>) . text <$> dittpName tp+ , ("type:" <+>) . ppValMd' pp <$> dittpType tp+ ])++ppDITemplateTypeParameter :: Fmt DITemplateTypeParameter+ppDITemplateTypeParameter = ppDITemplateTypeParameter' ppLabel++ppDITemplateValueParameter' :: Fmt i -> Fmt (DITemplateValueParameter' i)+ppDITemplateValueParameter' pp vp = "!DITemplateValueParameter"+ <> parens (mcommas [ pure ("tag:" <+> integral (ditvpTag vp))+ , ("name:" <+>) . text <$> ditvpName vp+ , ("type:" <+>) . ppValMd' pp <$> ditvpType vp+ , pure ("value:" <+> ppValMd' pp (ditvpValue vp))+ ])++ppDITemplateValueParameter :: Fmt DITemplateValueParameter+ppDITemplateValueParameter = ppDITemplateValueParameter' ppLabel++ppDIBasicType' :: Fmt i -> Fmt (DIBasicType' i)+ppDIBasicType' pp bt = "!DIBasicType"+ <> parens (mcommas+ [ pure ("tag:" <+> integral (dibtTag bt))+ , pure ("name:" <+> doubleQuotes (text (dibtName bt)))+ , (("size:" <+>) . ppSizeOrOffsetValMd' pp) <$> dibtSize bt+ , pure ("align:" <+> integral (dibtAlign bt))+ , pure ("encoding:" <+> integral (dibtEncoding bt))+ , (("flags:" <+>) . integral)+ <$> dibtFlags bt+ , if dibtNumExtraInhabitants bt > 0+ then pure ("numExtraInhabitants:" <+> integral (dibtNumExtraInhabitants bt))+ else Nothing+ ])++ppDICompileUnit' :: Fmt i -> Fmt (DICompileUnit' i)+ppDICompileUnit' pp cu = "!DICompileUnit"+ <> parens (mcommas $+ [ pure ("language:" <+> integral (dicuLanguage cu))+ , (("file:" <+>) . ppValMd' pp) <$> (dicuFile cu)+ , (("producer:" <+>) . doubleQuotes . text)+ <$> (dicuProducer cu)+ , pure ("isOptimized:" <+> ppBool (dicuIsOptimized cu))+ , pure ("flags:" <+> ppFlags (dicuFlags cu))+ , pure ("runtimeVersion:" <+> integral (dicuRuntimeVersion cu))+ , (("splitDebugFilename:" <+>) . doubleQuotes . text)+ <$> (dicuSplitDebugFilename cu)+ , pure ("emissionKind:" <+> integral (dicuEmissionKind cu))+ , (("enums:" <+>) . ppValMd' pp) <$> (dicuEnums cu)+ , (("retainedTypes:" <+>) . ppValMd' pp) <$> (dicuRetainedTypes cu)+ , (("subprograms:" <+>) . ppValMd' pp) <$> (dicuSubprograms cu)+ , (("globals:" <+>) . ppValMd' pp) <$> (dicuGlobals cu)+ , (("imports:" <+>) . ppValMd' pp) <$> (dicuImports cu)+ , (("macros:" <+>) . ppValMd' pp) <$> (dicuMacros cu)+ , pure ("dwoId:" <+> integral (dicuDWOId cu))+ , pure ("splitDebugInlining:" <+> ppBool (dicuSplitDebugInlining cu))+ , pure ("debugInfoForProfiling:" <+> ppBool (dicuDebugInfoForProf cu))+ , pure ("nameTableKind:" <+> integral (dicuNameTableKind cu))+ ]+ +++ when' (llvmVer >= 11)+ [ pure ("rangesBaseAddress:" <+> ppBool (dicuRangesBaseAddress cu))+ , (("sysroot:" <+>) . doubleQuotes . text)+ <$> (dicuSysRoot cu)+ , (("sdk:" <+>) . doubleQuotes . text)+ <$> (dicuSDK cu)+ ]+ )+++ppDICompileUnit :: Fmt DICompileUnit+ppDICompileUnit = ppDICompileUnit' ppLabel++ppFlags :: Fmt (Maybe String)+ppFlags mb = doubleQuotes (maybe empty text mb)++ppDICompositeType' :: Fmt i -> Fmt (DICompositeType' i)+ppDICompositeType' pp ct = "!DICompositeType"+ <> parens (mcommas+ [ pure ("tag:" <+> integral (dictTag ct))+ , (("name:" <+>) . doubleQuotes . text) <$> (dictName ct)+ , (("file:" <+>) . ppValMd' pp) <$> (dictFile ct)+ , pure ("line:" <+> integral (dictLine ct))+ , (("baseType:" <+>) . ppValMd' pp) <$> (dictBaseType ct)+ , (("size:" <+>) . ppSizeOrOffsetValMd' pp) <$> dictSize ct+ , pure ("align:" <+> integral (dictAlign ct))+ , (("offset:" <+>) . ppSizeOrOffsetValMd' pp) <$> dictOffset ct+ , pure ("flags:" <+> integral (dictFlags ct))+ , (("elements:" <+>) . ppValMd' pp) <$> (dictElements ct)+ , pure ("runtimeLang:" <+> integral (dictRuntimeLang ct))+ , (("vtableHolder:" <+>) . ppValMd' pp) <$> (dictVTableHolder ct)+ , (("templateParams:" <+>) . ppValMd' pp) <$> (dictTemplateParams ct)+ , (("identifier:" <+>) . doubleQuotes . text)+ <$> (dictIdentifier ct)+ , (("discriminator:" <+>) . ppValMd' pp) <$> (dictDiscriminator ct)+ , (("associated:" <+>) . ppValMd' pp) <$> (dictAssociated ct)+ , (("allocated:" <+>) . ppValMd' pp) <$> (dictAllocated ct)+ , (("rank:" <+>) . ppValMd' pp) <$> (dictRank ct)+ , (("annotations:" <+>) . ppValMd' pp) <$> (dictAnnotations ct)+ , if dictNumExtraInhabitants ct > 0+ then pure ("numExtraInhabitants:" <+> integral (dictNumExtraInhabitants ct))+ else Nothing+ , (("specification:" <+>) . ppValMd' pp) <$> (dictSpecification ct)+ , (("enumKind:" <+>) . integral) <$> (dictEnumKind ct)+ , (("bitStride:" <+>) . ppValMd' pp) <$> (dictBitStride ct)+ ])++ppDICompositeType :: Fmt DICompositeType+ppDICompositeType = ppDICompositeType' ppLabel++ppDIDerivedType' :: Fmt i -> Fmt (DIDerivedType' i)+ppDIDerivedType' pp dt = "!DIDerivedType"+ <> parens (mcommas+ [ pure ("tag:" <+> integral (didtTag dt))+ , (("name:" <+>) . doubleQuotes . text) <$> (didtName dt)+ , (("file:" <+>) . ppValMd' pp) <$> (didtFile dt)+ , pure ("line:" <+> integral (didtLine dt))+ , (("scope:" <+>) . ppValMd' pp) <$> (didtScope dt)+ , ("baseType:" <+>) <$> (ppValMd' pp <$> didtBaseType dt <|> Just "null")+ , (("size:" <+>) . ppSizeOrOffsetValMd' pp) <$> didtSize dt+ , pure ("align:" <+> integral (didtAlign dt))+ , (("offset:" <+>) . ppSizeOrOffsetValMd' pp) <$> didtOffset dt+ , pure ("flags:" <+> integral (didtFlags dt))+ , (("extraData:" <+>) . ppValMd' pp) <$> (didtExtraData dt)+ , (("dwarfAddressSpace:" <+>) . integral) <$> didtDwarfAddressSpace dt+ , (("annotations:" <+>) . ppValMd' pp) <$> (didtAnnotations dt)+ ])++ppDIDerivedType :: Fmt DIDerivedType+ppDIDerivedType = ppDIDerivedType' ppLabel++ppDIEnumerator :: String -> Integer -> Fmt Bool+ppDIEnumerator n v u = "!DIEnumerator"+ <> parens (commas [ "name:" <+> doubleQuotes (text n)+ , "value:" <+> integral v+ , "isUnsigned:" <+> ppBool u+ ])++ppDIExpression :: Fmt DIExpression+ppDIExpression e = "!DIExpression"+ <> parens (commas (map integral (dieElements e)))++ppDIFile :: Fmt DIFile+ppDIFile f = "!DIFile"+ <> parens (commas [ "filename:" <+> doubleQuotes (text (difFilename f))+ , "directory:" <+> doubleQuotes (text (difDirectory f))+ ])++ppDIGlobalVariable' :: Fmt i -> Fmt (DIGlobalVariable' i)+ppDIGlobalVariable' pp gv = "!DIGlobalVariable"+ <> parens (mcommas+ [ (("scope:" <+>) . ppValMd' pp) <$> (digvScope gv)+ , (("name:" <+>) . doubleQuotes . text) <$> (digvName gv)+ , (("linkageName:" <+>) . doubleQuotes . text)+ <$> (digvLinkageName gv)+ , (("file:" <+>) . ppValMd' pp) <$> (digvFile gv)+ , pure ("line:" <+> integral (digvLine gv))+ , (("type:" <+>) . ppValMd' pp) <$> (digvType gv)+ , pure ("isLocal:" <+> ppBool (digvIsLocal gv))+ , pure ("isDefinition:" <+> ppBool (digvIsDefinition gv))+ , (("variable:" <+>) . ppValMd' pp) <$> (digvVariable gv)+ , (("declaration:" <+>) . ppValMd' pp) <$> (digvDeclaration gv)+ , (("align:" <+>) . integral) <$> digvAlignment gv+ , (("annotations:" <+>) . ppValMd' pp) <$> (digvAnnotations gv)+ ])++ppDIGlobalVariable :: Fmt DIGlobalVariable+ppDIGlobalVariable = ppDIGlobalVariable' ppLabel++ppDIGlobalVariableExpression' :: Fmt i -> Fmt (DIGlobalVariableExpression' i)+ppDIGlobalVariableExpression' pp gve = "!DIGlobalVariableExpression"+ <> parens (mcommas+ [ (("var:" <+>) . ppValMd' pp) <$> (digveVariable gve)+ , (("expr:" <+>) . ppValMd' pp) <$> (digveExpression gve)+ ])++ppDIGlobalVariableExpression :: Fmt DIGlobalVariableExpression+ppDIGlobalVariableExpression = ppDIGlobalVariableExpression' ppLabel++ppDILexicalBlock' :: Fmt i -> Fmt (DILexicalBlock' i)+ppDILexicalBlock' pp ct = "!DILexicalBlock"+ <> parens (mcommas+ [ (("scope:" <+>) . ppValMd' pp) <$> (dilbScope ct)+ , (("file:" <+>) . ppValMd' pp) <$> (dilbFile ct)+ , pure ("line:" <+> integral (dilbLine ct))+ , pure ("column:" <+> integral (dilbColumn ct))+ ])++ppDILexicalBlock :: Fmt DILexicalBlock+ppDILexicalBlock = ppDILexicalBlock' ppLabel++ppDILexicalBlockFile' :: Fmt i -> Fmt (DILexicalBlockFile' i)+ppDILexicalBlockFile' pp lbf = "!DILexicalBlockFile"+ <> parens (mcommas+ [ pure ("scope:" <+> ppValMd' pp (dilbfScope lbf))+ , (("file:" <+>) . ppValMd' pp) <$> (dilbfFile lbf)+ , pure ("discriminator:" <+> integral (dilbfDiscriminator lbf))+ ])++ppDILexicalBlockFile :: Fmt DILexicalBlockFile+ppDILexicalBlockFile = ppDILexicalBlockFile' ppLabel++ppDILocalVariable' :: Fmt i -> Fmt (DILocalVariable' i)+ppDILocalVariable' pp lv = "!DILocalVariable"+ <> parens (mcommas+ [ (("scope:" <+>) . ppValMd' pp) <$> (dilvScope lv)+ , (("name:" <+>) . doubleQuotes . text) <$> (dilvName lv)+ , (("file:" <+>) . ppValMd' pp) <$> (dilvFile lv)+ , pure ("line:" <+> integral (dilvLine lv))+ , (("type:" <+>) . ppValMd' pp) <$> (dilvType lv)+ , pure ("arg:" <+> integral (dilvArg lv))+ , pure ("flags:" <+> integral (dilvFlags lv))+ , (("align:" <+>) . integral) <$> dilvAlignment lv+ , (("annotations:" <+>) . ppValMd' pp) <$> (dilvAnnotations lv)+ ])++ppDILocalVariable :: Fmt DILocalVariable+ppDILocalVariable = ppDILocalVariable' ppLabel++-- | See @writeDISubprogram@ in the LLVM source, in the file @AsmWriter.cpp@+--+-- Note that the textual syntax changed in LLVM 7, as the @retainedNodes@ field+-- was called @variables@ in previous LLVM versions.+ppDISubprogram' :: Fmt i -> Fmt (DISubprogram' i)+ppDISubprogram' pp sp = "!DISubprogram"+ <> parens (mcommas+ [ (("scope:" <+>) . ppValMd' pp) <$> (dispScope sp)+ , (("name:" <+>) . doubleQuotes . text) <$> (dispName sp)+ , (("linkageName:" <+>) . doubleQuotes . text)+ <$> (dispLinkageName sp)+ , (("file:" <+>) . ppValMd' pp) <$> (dispFile sp)+ , pure ("line:" <+> integral (dispLine sp))+ , (("type:" <+>) . ppValMd' pp) <$> (dispType sp)+ , pure ("isLocal:" <+> ppBool (dispIsLocal sp))+ , pure ("isDefinition:" <+> ppBool (dispIsDefinition sp))+ , pure ("scopeLine:" <+> integral (dispScopeLine sp))+ , (("containingType:" <+>) . ppValMd' pp) <$> (dispContainingType sp)+ , pure ("virtuality:" <+> integral (dispVirtuality sp))+ , pure ("virtualIndex:" <+> integral (dispVirtualIndex sp))+ , pure ("flags:" <+> integral (dispFlags sp))+ , pure ("isOptimized:" <+> ppBool (dispIsOptimized sp))+ , (("unit:" <+>) . ppValMd' pp) <$> (dispUnit sp)+ , (("templateParams:" <+>) . ppValMd' pp) <$> (dispTemplateParams sp)+ , (("declaration:" <+>) . ppValMd' pp) <$> (dispDeclaration sp)+ , (("retainedNodes:" <+>) . ppValMd' pp) <$> (dispRetainedNodes sp)+ , (("thrownTypes:" <+>) . ppValMd' pp) <$> (dispThrownTypes sp)+ , (("annotations:" <+>) . ppValMd' pp) <$> (dispAnnotations sp)+ ])++ppDISubprogram :: Fmt DISubprogram+ppDISubprogram = ppDISubprogram' ppLabel++ppDISubrange' :: Fmt i -> Fmt (DISubrange' i)+ppDISubrange' pp sr =+ "!DISubrange"+ <> parens+ (mcommas+ -- LLVM < 7: count and lowerBound as signed int 64+ -- LLVM < 11: count as ValMd, lowerBound as signed in 64+ -- LLVM >= 11: ValMd of count, lowerBound, upperBound, and stride+ -- Valid through LLVM 17.+ -- See AST.hs description for more details on the structure.+ -- See https://github.com/llvm/llvm-project/blob/431969e/llvm/lib/IR/AsmWriter.cpp#L1888-L1927+ -- for more details on output generation.+ [+ (("count:" <+>) . ppInt64ValMd' (llvmVer >= 7) pp) <$> disrCount sr+ , (("lowerBound:" <+>) . ppInt64ValMd' (llvmVer >= 11) pp) <$> disrLowerBound sr+ , when' (llvmVer >= 11)+ $ (("upperBound:" <+>) . ppInt64ValMd' True pp) <$> disrUpperBound sr+ , when' (llvmVer >= 11)+ $ (("stride:" <+>) . ppInt64ValMd' True pp) <$> disrStride sr+ ])++ppDISubrange :: Fmt DISubrange+ppDISubrange = ppDISubrange' ppLabel++ppDISubroutineType' :: Fmt i -> Fmt (DISubroutineType' i)+ppDISubroutineType' pp st = "!DISubroutineType"+ <> parens (commas+ [ "flags:" <+> integral (distFlags st)+ , "types:" <+> fromMaybe "null" (ppValMd' pp <$> (distTypeArray st))+ ])++ppDISubroutineType :: Fmt DISubroutineType+ppDISubroutineType = ppDISubroutineType' ppLabel++ppDIArgList' :: Fmt i -> Fmt (DIArgList' i)+ppDIArgList' pp args = "!DIArgList"+ <> parens (commas (map (ppValMd' pp) (dialArgs args)))++ppDIArgList :: Fmt DIArgList+ppDIArgList = ppDIArgList' ppLabel++-- Utilities -------------------------------------------------------------------++ppBool :: Fmt Bool+ppBool b | b = "true"+ | otherwise = "false"++-- | Build a variable-argument argument list.+ppArgList :: Bool -> Fmt [Doc]+ppArgList True ds = parens (commas (ds ++ ["..."]))+ppArgList False ds = parens (commas ds)++integral :: Integral i => Fmt i+integral = integer . fromIntegral++hex :: (Integral i, Show i) => Fmt i+hex i = text (showHex i "0x")++opt :: Bool -> Fmt Doc+opt True = id+opt False = const empty++-- | Print a ValMd' value as a plain signed integer (Int64) if possible. If the+-- ValMd' is not representable as an Int64, defer to ValMd' printing (if+-- canFallBack is True) or print nothing (for when a ValMd is not a valid+-- representation).++ppInt64ValMd' :: Bool -> Fmt i -> Fmt (ValMd' i)+ppInt64ValMd' canFallBack pp = go+ where go = \case+ ValMdValue tv+ | PrimType (Integer _) <- typedType tv+ , ValInteger i <- typedValue tv+ -> integer i -- 64 bits is the largest Int, so no conversion needed+ o@(ValMdDebugInfo (DebugInfoGlobalVariable gv)) ->+ case digvVariable gv of+ Nothing -> when' canFallBack $ ppValMd' pp o+ Just v -> go v+ o@(ValMdDebugInfo (DebugInfoGlobalVariableExpression expr)) ->+ case digveExpression expr of+ Nothing -> when' canFallBack $ ppValMd' pp o+ Just e -> go e+ ValMdDebugInfo (DebugInfoLocalVariable lv) ->+ integer $ fromIntegral $ dilvArg lv -- ??+ -- ValMdRef _idx -> mempty -- no table here to look this up...+ o -> when' canFallBack $ ppValMd' pp o++-- | Print the size or offset of a type-related metadata node. This value can+-- either be an integer literal (in which case the bare literal is printed), or+-- in LLVM 21 or later, it can be a more complicated metadata expression (in+-- which case the metadata is pretty-printed).+ppSizeOrOffsetValMd' :: Fmt i -> Fmt (ValMd' i)+ppSizeOrOffsetValMd' pp = \case+ ValMdValue tv+ | ValInteger i <- typedValue tv+ -> integer i+ o -> when' (llvmVer >= 21) $ ppValMd' pp o+++commas :: Fmt [Doc]+commas = fsep . punctuate comma++-- | Helpful for all of the optional fields that appear in the+-- metadata values+mcommas :: Fmt [Maybe Doc]+mcommas = commas . catMaybes++angles :: Fmt Doc+angles d = char '<' <> d <> char '>'++structBraces :: Fmt Doc+structBraces body = char '{' <+> body <+> char '}'++ppMaybe :: Fmt a -> Fmt (Maybe a)+ppMaybe = maybe empty++-- | Throw an error if the @?config@ version is older than the given version. The+-- String indicates which constructor is unavailable in the error message.+onlyOnLLVM :: (?config :: Config) => LLVMVer -> String -> a -> a+onlyOnLLVM fromVer name+ | llvmVer >= fromVer = id+ | otherwise = error $ name ++ " is supported only on LLVM >= "+ ++ llvmVerToString fromVer++-- | Throw an error if the @?config@ version is older than the given version. The+-- String indicates which constructor is unavailable in the error message.+droppedInLLVM :: (?config :: Config) => LLVMVer -> String -> a -> a+droppedInLLVM fromVer name+ | llvmVer >= fromVer = error $ name ++ " is supported only up to LLVM >= "+ ++ llvmVerToString fromVer+ | otherwise = id
+ llvm-pretty/src/Text/LLVM/Parser.hs view
@@ -0,0 +1,142 @@+module Text.LLVM.Parser where++import Text.LLVM.AST++import Data.Char (chr)+import Data.Word (Word32, Word64)+import Text.Parsec+import Text.Parsec.String+++-- Identifiers and Symbols -----------------------------------------------------++pNameChar :: Parser Char+pNameChar = letter <|> digit <|> oneOf "-$._"++pHexEscape :: Parser Char+pHexEscape =+ do _ <- char '\\'+ a <- hexDigit+ b <- hexDigit+ return (chr (read ("0x" ++ [a, b])))++pStringChar :: Parser Char+pStringChar = noneOf "\"\\" <|> pHexEscape++pName :: Parser String+pName = many1 pNameChar <|> quotes (many1 pStringChar)++pIdent :: Parser Ident+pIdent = Ident <$> (char '%' >> pName)++pSymbol :: Parser Symbol+pSymbol = Symbol <$> (char '@' >> pName)+++-- Types -----------------------------------------------------------------------++pWord32 :: Parser Word32+pWord32 = read <$> many1 digit++pWord64 :: Parser Word64+pWord64 = read <$> many1 digit++pPrimType :: Parser PrimType+pPrimType = choice+ [ Integer <$> try (char 'i' >> pWord32)+ , FloatType <$> try pFloatType+ , try (string "label") >> return Label+ , try (string "void") >> return Void+ , try (string "x86mmx") >> return X86mmx+ , try (string "metadata") >> return Metadata+ ]++pFloatType :: Parser FloatType+pFloatType = choice+ [ try (string "half") >> return Half+ , try (string "float") >> return Float+ , try (string "double") >> return Double+ , try (string "fp128") >> return Fp128+ , try (string "x86_fp80") >> return X86_fp80+ , try (string "ppc_fp128") >> return PPC_fp128+ ]++pType :: Parser Type+pType = pType0 >>= pFunPtr+ where+ pType0 :: Parser Type+ pType0 =+ choice+ [ Alias <$> pIdent+ , brackets (pNumType Array)+ , braces (Struct <$> pTypeList)+ , angles (braces (PackedStruct <$> pTypeList) <|> spaced (pNumType Vector))+ , string "opaque" >> return Opaque+ , PrimType <$> pPrimType+ , pOpaquePtr+ ]++ pTypeList :: Parser [Type]+ pTypeList = sepBy (spaced pType) (char ',')++ pNumType :: (Word64 -> Type -> Type) -> Parser Type+ pNumType f =+ do n <- pWord64+ spaces >> char 'x' >> spaces+ t <- pType+ return (f n t)++ pArgList :: Type -> Parser Type+ pArgList t0 = spaces >> (p1 [] <|> return (FunTy t0 [] False))+ where+ p1 ts =+ (string "..." >> spaces >> return (FunTy t0 (reverse ts) True))+ <|> (pType >>= \t -> (spaces >> p2 (t : ts)))+ p2 ts =+ (char ',' >> spaces >> p1 ts)+ <|> return (FunTy t0 (reverse ts) False)++ pOpaquePtr :: Parser Type+ pOpaquePtr = do+ _ <- string "ptr"+ PtrOpaque <$> option defaultAddrSpace (spaces >> pAddrSpace)++ pFunPtr :: Type -> Parser Type+ pFunPtr t0 = pFun <|> pPtr <|> return t0+ where+ pFun = parens (pArgList t0) >>= pFunPtr+ pPtr = do+ addr <- option defaultAddrSpace (spaces >> pAddrSpace)+ _ <- char '*'+ pFunPtr (PtrTo t0 addr)++ pAddrSpace :: Parser AddrSpace+ pAddrSpace = do+ _ <- string "addrspace("+ n <- pWord32+ _ <- string ")"+ return (AddrSpace n)++parseType :: String -> Either ParseError Type+parseType = parse (pType <* eof) "<internal>"+++-- Utilities -------------------------------------------------------------------++angles :: Parser a -> Parser a+angles body = char '<' *> body <* char '>'++braces :: Parser a -> Parser a+braces body = char '{' *> body <* char '}'++brackets :: Parser a -> Parser a+brackets body = char '[' *> body <* char ']'++parens :: Parser a -> Parser a+parens body = char '(' *> body <* char ')'++quotes :: Parser a -> Parser a+quotes body = char '"' *> body <* char '"'++spaced :: Parser a -> Parser a+spaced body = spaces *> body <* spaces
+ llvm-pretty/src/Text/LLVM/Triple.hs view
@@ -0,0 +1,17 @@+{- |+Module : Text.LLVM.Triple+Description : AST, parsing, and printing of LLVM target triples.+License : BSD3+Maintainer : Langston Barrett+Stability : experimental+-}++module Text.LLVM.Triple+ ( module Text.LLVM.Triple.AST+ , module Text.LLVM.Triple.Parse+ , module Text.LLVM.Triple.Print+ ) where++import Text.LLVM.Triple.AST+import Text.LLVM.Triple.Parse+import Text.LLVM.Triple.Print
+ llvm-pretty/src/Text/LLVM/Triple/AST.hs view
@@ -0,0 +1,467 @@+{- |+Module : Text.LLVM.Triple.AST+Description : AST of LLVM target triples.+License : BSD3+Maintainer : Langston Barrett+Stability : experimental+-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE StrictData #-}++module Text.LLVM.Triple.AST+ ( Arch(..)+ , SubArch(..)+ , Vendor(..)+ , OS(..)+ , Environment(..)+ , ObjectFormat(..)+ , TargetTriple(..)+ ) where++import Data.Data (Data)+import Data.Typeable (Typeable)+import GHC.Generics (Generic)++-- | The constructors of this type exactly mirror the LLVM @enum ArchType@,+-- including inconsistent labeling of endianness. Capitalization is taken from+-- the LLVM comments, which are reproduced below.+--+-- Last updated: LLVM 15.0.1:+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/include/llvm/ADT/Triple.h#L46+data Arch+ = UnknownArch+ -- | ARM (little endian): arm armv.* xscale+ | ARM+ -- | ARM (big endian): armeb+ | ARMEB+ -- | AArch64 (little endian): aarch64+ | AArch64+ -- | AArch64 (big endian): aarch64_be+ | AArch64_BE+ -- | AArch64 (little endian) ILP32: aarch64_32+ | AArch64_32+ -- | ARC: Synopsys ARC+ | ARC+ -- | AVR: Atmel AVR microcontroller+ | AVR+ -- | eBPF or extended BPF or 64-bit BPF (little endian)+ | BPFEL+ -- | eBPF or extended BPF or 64-bit BPF (big endian)+ | BPFEB+ -- | CSKY: csky+ | CSKY+ -- | DXIL 32-bit DirectX bytecode+ | DXIL+ -- | Hexagon: hexagon+ | Hexagon+ -- | LoongArch (32-bit): loongarch32+ | LoongArch32+ -- | LoongArch (64-bit): loongarch64+ | LoongArch64+ -- | M68k: Motorola 680x0 family+ | M68k+ -- | MIPS: mips mipsallegrex mipsr6+ | MIPS+ -- | MIPSEL: mipsel mipsallegrexe mipsr6el+ | MIPSEL+ -- | MIPS64: mips64 mips64r6 mipsn32 mipsn32r6+ | MIPS64+ -- | MIPS64EL: mips64el mips64r6el mipsn32el mipsn32r6el+ | MIPS64EL+ -- | MSP430: msp430+ | MSP430+ -- | PPC: powerpc+ | PPC+ -- | PPCLE: powerpc (little endian)+ | PPCLE+ -- | PPC64: powerpc64 ppu+ | PPC64+ -- | PPC64LE: powerpc64le+ | PPC64LE+ -- | R600: AMD GPUs HD2XXX - HD6XXX+ | R600+ -- | AMDGCN: AMD GCN GPUs+ | AMDGCN+ -- | RISC-V (32-bit): riscv32+ | RISCV32+ -- | RISC-V (64-bit): riscv64+ | RISCV64+ -- | Sparc: sparc+ | Sparc+ -- | Sparcv9: Sparcv9+ | Sparcv9+ -- | Sparc: (endianness = little). NB: 'Sparcle' is a CPU variant+ | SparcEL+ -- | SystemZ: s390x+ | SystemZ+ -- | TCE (http://tce.cs.tut.fi/): tce+ | TCE+ -- | TCE little endian (http://tce.cs.tut.fi/): tcele+ | TCELE+ -- | Thumb (little endian): thumb thumbv.*+ | Thumb+ -- | Thumb (big endian): thumbeb+ | ThumbEB+ -- | X86: i[3-9]86+ | X86+ -- | X86-64: amd64 x86_64+ | X86_64+ -- | XCore: xcore+ | XCore+ -- | NVPTX: 32-bit+ | NVPTX+ -- | NVPTX: 64-bit+ | NVPTX64+ -- | le32: generic little-endian 32-bit CPU (PNaCl)+ | Le32+ -- | le64: generic little-endian 64-bit CPU (PNaCl)+ | Le64+ -- | AMDIL+ | AMDIL+ -- | AMDIL with 64-bit pointers+ | AMDIL64+ -- | AMD HSAIL+ | HSAIL+ -- | AMD HSAIL with 64-bit pointers+ | HSAIL64+ -- | SPIR: standard portable IR for OpenCL 32-bit version+ | SPIR+ -- | SPIR: standard portable IR for OpenCL 64-bit version+ | SPIR64+ -- | SPIR-V with 32-bit pointers+ | SPIRV32+ -- | SPIR-V with 64-bit pointers+ | SPIRV64+ -- | Kalimba: generic kalimba+ | Kalimba+ -- | SHAVE: Movidius vector VLIW processors+ | SHAVE+ -- | Lanai: Lanai 32-bit+ | Lanai+ -- | WebAssembly with 32-bit pointers+ | Wasm32+ -- | WebAssembly with 64-bit pointers+ | Wasm64+ -- | 32-bit RenderScript+ | RenderScript32 -- 32-bit RenderScript+ -- | 64-bit RenderScript+ | RenderScript64+ -- | NEC SX-Aurora Vector Engine+ | VE+ deriving (Bounded, Data, Eq, Enum, Generic, Ord, Read, Show, Typeable)++-- | A 'First'-like semigroup instance that simply drops the RHS, unless the LHS+-- is 'UnknownArch'.+instance Semigroup Arch where+ a <> UnknownArch{} = a+ UnknownArch{} <> b = b+ a <> _ = a++-- | @'mempty' == 'UnknownArch'@+instance Monoid Arch where+ mempty = UnknownArch++-- | The constructors of this type exactly mirror the LLVM @enum SubArchType@.+--+-- Last updated: LLVM 15.0.1:+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/include/llvm/ADT/Triple.h#L110+data SubArch+ = NoSubArch+ | ARMSubArch_v9_3a+ | ARMSubArch_v9_2a+ | ARMSubArch_v9_1a+ | ARMSubArch_v9+ | ARMSubArch_v8_8a+ | ARMSubArch_v8_7a+ | ARMSubArch_v8_6a+ | ARMSubArch_v8_5a+ | ARMSubArch_v8_4a+ | ARMSubArch_v8_3a+ | ARMSubArch_v8_2a+ | ARMSubArch_v8_1a+ | ARMSubArch_v8+ | ARMSubArch_v8r+ | ARMSubArch_v8m_baseline+ | ARMSubArch_v8m_mainline+ | ARMSubArch_v8_1m_mainline+ | ARMSubArch_v7+ | ARMSubArch_v7em+ | ARMSubArch_v7m+ | ARMSubArch_v7s+ | ARMSubArch_v7k+ | ARMSubArch_v7ve+ | ARMSubArch_v6+ | ARMSubArch_v6m+ | ARMSubArch_v6k+ | ARMSubArch_v6t2+ | ARMSubArch_v5+ | ARMSubArch_v5te+ | ARMSubArch_v4t++ | AArch64SubArch_arm64e++ | KalimbaSubArch_v3+ | KalimbaSubArch_v4+ | KalimbaSubArch_v5++ | MipsSubArch_r6++ | PPCSubArch_spe++ | SPIRVSubArch_v10+ | SPIRVSubArch_v11+ | SPIRVSubArch_v12+ | SPIRVSubArch_v13+ | SPIRVSubArch_v14+ | SPIRVSubArch_v15+ deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable)++-- | A 'First'-like semigroup instance that simply drops the RHS, unless the LHS+-- is 'NoSubArch'.+instance Semigroup SubArch where+ a <> NoSubArch{} = a+ NoSubArch{} <> b = b+ a <> _ = a++-- | @'mempty' == 'NoSubArch'@+instance Monoid SubArch where+ mempty = NoSubArch++-- | The constructors of this type exactly mirror the LLVM @enum VendorType@,+-- including ordering and grouping.+--+-- Last updated: LLVM 15.0.1:+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/include/llvm/ADT/Triple.h#L162+data Vendor+ = UnknownVendor+ | Apple+ | PC+ | SCEI+ | Freescale+ | IBM+ | ImaginationTechnologies+ | MipsTechnologies+ | NVIDIA+ | CSR+ | Myriad+ | AMD+ | Mesa+ | SUSE+ | OpenEmbedded+ deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable)++-- | A 'First'-like semigroup instance that simply drops the RHS, unless the LHS+-- is 'UnknownVendor'.+instance Semigroup Vendor where+ a <> UnknownVendor{} = a+ UnknownVendor{} <> b = b+ a <> _ = a++-- | @'mempty' == 'UnknownVendor'@+instance Monoid Vendor where+ mempty = UnknownVendor++-- | The constructors of this type exactly mirror the LLVM @enum OSType@,+-- including ordering and grouping.+--+-- End-of-line comments from LLVM are reproduced as constructor comments.+--+-- Last updated: LLVM 15.0.1:+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/include/llvm/ADT/Triple.h#L181+data OS+ = UnknownOS+ | Ananas+ | CloudABI+ | Darwin+ | DragonFly+ | FreeBSD+ | Fuchsia+ | IOS+ | KFreeBSD+ | Linux+ -- | PS3+ | Lv2+ | MacOSX+ | NetBSD+ | OpenBSD+ | Solaris+ | Win32+ | ZOS+ | Haiku+ | Minix+ | RTEMS+ -- | Native Client+ | NaCl+ | AIX+ -- | NVIDIA CUDA+ | CUDA+ -- | NVIDIA OpenCL+ | NVCL+ -- | AMD HSA Runtime+ | AMDHSA+ | PS4+ | PS5+ | ELFIAMCU+ -- | Apple tvOS+ | TvOS+ -- | Apple watchOS+ | WatchOS+ -- | Apple DriverKit+ | DriverKit+ | Mesa3D+ | Contiki+ -- | AMD PAL Runtime+ | AMDPAL+ -- | HermitCore Unikernel/Multikernel+ | HermitCore+ -- | GNU/Hurd+ | Hurd+ -- | Experimental WebAssembly OS+ | WASI+ | Emscripten+ -- | DirectX ShaderModel+ | ShaderModel+ deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable)++-- | A 'First'-like semigroup instance that simply drops the RHS, unless the LHS+-- is 'UnknownOS'.+instance Semigroup OS where+ a <> UnknownOS{} = a+ UnknownOS{} <> b = b+ a <> _ = a++-- | @'mempty' == 'UnknownOS'@+instance Monoid OS where+ mempty = UnknownOS++-- | The constructors of this type exactly mirror the LLVM @enum+-- EnvironmentType@, including ordering and grouping.+--+-- End-of-line comments from LLVM are reproduced as constructor comments.+--+-- Last updated: LLVM 15.0.1:+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/include/llvm/ADT/Triple.h#L224+data Environment+ = UnknownEnvironment++ | GNU+ | GNUABIN32+ | GNUABI64+ | GNUEABI+ | GNUEABIHF+ | GNUX32+ | GNUILP32+ | CODE16+ | EABI+ | EABIHF+ | Android+ | Musl+ | MuslEABI+ | MuslEABIHF+ | MuslX32++ | MSVC+ | Itanium+ | Cygnus+ | CoreCLR+ -- | Simulator variants of other systems e.g. Apple's iOS+ | Simulator+ -- | Mac Catalyst variant of Apple's iOS deployment target.+ | MacABI++ | Pixel+ | Vertex+ | Geometry+ | Hull+ | Domain+ | Compute+ | Library+ | RayGeneration+ | Intersection+ | AnyHit+ | ClosestHit+ | Miss+ | Callable+ | Mesh+ | Amplification+ deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable)++-- | A 'First'-like semigroup instance that simply drops the RHS, unless the LHS+-- is 'UnknownEnvironment'.+instance Semigroup Environment where+ a <> UnknownEnvironment{} = a+ UnknownEnvironment{} <> b = b+ a <> _ = a++-- | @'mempty' == 'UnknownEnvironment'@+instance Monoid Environment where+ mempty = UnknownEnvironment++-- | The constructors of this type exactly mirror the LLVM @enum+-- ObjectFormatType@, including ordering.+--+-- Last updated: LLVM 15.0.1:+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/include/llvm/ADT/Triple.h#L269+data ObjectFormat+ = UnknownObjectFormat+ | COFF+ | DXContainer+ | ELF+ | GOFF+ | MachO+ | SPIRV+ | Wasm+ | XCOFF+ deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable)++-- | A 'First'-like semigroup instance that simply drops the RHS, unless the LHS+-- is 'UnknownObjectFormat'.+instance Semigroup ObjectFormat where+ a <> UnknownObjectFormat{} = a+ UnknownObjectFormat{} <> b = b+ a <> _ = a++-- | @'mempty' == 'UnknownObjectFormat'@+instance Monoid ObjectFormat where+ mempty = UnknownObjectFormat++-- | More like a sextuple than a triple, if you think about it.+--+-- The LLVM version of this holds onto the un-normalized string representation.+-- We discard it.+data TargetTriple+ = TargetTriple+ { ttArch :: Arch+ , ttSubArch :: SubArch+ , ttVendor :: Vendor+ , ttOS :: OS+ , ttEnv :: Environment+ , ttObjFmt :: ObjectFormat+ }+ deriving (Bounded, Data, Eq, Generic, Ord, Read, Show, Typeable)++-- | Combines fields pointwise.+instance Semigroup TargetTriple where+ tt <> tt' =+ TargetTriple+ { ttArch = ttArch tt <> ttArch tt'+ , ttSubArch = ttSubArch tt <> ttSubArch tt'+ , ttVendor = ttVendor tt <> ttVendor tt'+ , ttOS = ttOS tt <> ttOS tt'+ , ttEnv = ttEnv tt <> ttEnv tt'+ , ttObjFmt = ttObjFmt tt <> ttObjFmt tt'+ }++-- | Pointwise 'mempty'.+instance Monoid TargetTriple where+ mempty =+ TargetTriple+ { ttArch = mempty+ , ttSubArch = mempty+ , ttVendor = mempty+ , ttOS = mempty+ , ttEnv = mempty+ , ttObjFmt = mempty+ }
+ llvm-pretty/src/Text/LLVM/Triple/Parse.hs view
@@ -0,0 +1,294 @@+{- |+Module : Text.LLVM.Triple.Parse+Description : Parsing of LLVM target triples.+License : BSD3+Maintainer : Langston Barrett+Stability : experimental++The declarations appear in this module in the same order as in the LLVM source.+-}++{- Note [Implementation]++The very simplest parsing functions are implemented with the 'LookupTable'+structure. For anything more complex, we endeavor to closely mirror the+structure of LLVM's implementation. This will make the code more maintainable+when updating to newer versions of LLVM.++-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}++module Text.LLVM.Triple.Parse+ ( parseArch+ , parseVendor+ , parseOS+ , parseEnv+ , parseObjFmt+ , parseSubArch+ , parseTriple+ ) where++import qualified Data.List as List++import qualified MonadLib as M+import qualified MonadLib.Monads as M++import Text.LLVM.Triple.AST+import qualified Text.LLVM.Triple.Print as Print+import Text.LLVM.Triple.Parse.LookupTable+import qualified Text.LLVM.Triple.Parse.ARM as ARM++-- | @llvm::parseArch@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/lib/Support/Triple.cpp#L442+parseArch :: String -> Arch+parseArch s =+ let mArch =+ -- See Note [Implementation] for the reasoning behind the strange structure.+ --+ -- It would be easy to forget to add patterns here when adding a new+ -- constructor to Arch, but we have exhaustive print-then-parse+ -- roundtrip tests to mitigate this risk.+ if | cases ["i386", "i486", "i586", "i686"] -> X86+ | cases ["i786", "i886", "i986"] -> X86+ | cases ["amd64", "x86_64", "x86_64h"] -> X86_64+ | cases ["powerpc", "powerpcspe", "ppc", "ppc32"] -> PPC+ | cases ["powerpcle", "ppcle", "ppc32le"] -> PPCLE+ | cases ["powerpc64", "ppu", "ppc64"] -> PPC64+ | cases ["powerpc64le", "ppc64le"] -> PPC64LE+ | cases ["xscale"] -> ARM+ | cases ["xscaleeb"] -> ARMEB+ | cases ["aarch64"] -> AArch64+ | cases ["aarch64_be"] -> AArch64_BE+ | cases ["aarch64_32"] -> AArch64_32+ | cases ["arc"] -> ARC+ | cases ["arm64"] -> AArch64+ | cases ["arm64_32"] -> AArch64_32+ | cases ["arm64e"] -> AArch64+ | cases ["arm"] -> ARM+ | cases ["armeb"] -> ARMEB+ | cases ["thumb"] -> Thumb+ | cases ["thumbeb"] -> ThumbEB+ | cases ["avr"] -> AVR+ | cases ["m68k"] -> M68k+ | cases ["msp430"] -> MSP430+ | cases ["mips", "mipseb", "mipsallegrex", "mipsisa32r6"+ , "mipsr6"] -> MIPS+ | cases ["mipsel", "mipsallegrexel", "mipsisa32r6el", "mipsr6el"] -> MIPSEL+ | cases ["mips64", "mips64eb", "mipsn32", "mipsisa64r6"+ , "mips64r6", "mipsn32r6"] -> MIPS64+ | cases ["mips64el", "mipsn32el", "mipsisa64r6el", "mips64r6el"+ , "mipsn32r6el"] -> MIPS64EL+ | cases ["r600"] -> R600+ | cases ["amdgcn"] -> AMDGCN+ | cases ["riscv32"] -> RISCV32+ | cases ["riscv64"] -> RISCV64+ | cases ["hexagon"] -> Hexagon+ | cases ["s390x", "systemz"] -> SystemZ+ | cases ["sparc"] -> Sparc+ | cases ["sparcel"] -> SparcEL+ | cases ["sparcv9", "sparc64"] -> Sparcv9+ | cases ["tce"] -> TCE+ | cases ["tcele"] -> TCELE+ | cases ["xcore"] -> XCore+ | cases ["nvptx"] -> NVPTX+ | cases ["nvptx64"] -> NVPTX64+ | cases ["le32"] -> Le32+ | cases ["le64"] -> Le64+ | cases ["amdil"] -> AMDIL+ | cases ["amdil64"] -> AMDIL64+ | cases ["hsail"] -> HSAIL+ | cases ["hsail64"] -> HSAIL64+ | cases ["spir"] -> SPIR+ | cases ["spir64"] -> SPIR64+ | cases ["spirv32", "spirv32v1.0", "spirv32v1.1", "spirv32v1.2"+ , "spirv32v1.3", "spirv32v1.4", "spirv32v1.5"] -> SPIRV32+ | cases ["spirv64", "spirv64v1.0", "spirv64v1.1", "spirv64v1.2"+ , "spirv64v1.3", "spirv64v1.4", "spirv64v1.5"] -> SPIRV64+ | archPfx Kalimba -> Kalimba+ | cases ["lanai"] -> Lanai+ | cases ["renderscript32"] -> RenderScript32+ | cases ["renderscript64"] -> RenderScript64+ | cases ["shave"] -> SHAVE+ | cases ["ve"] -> VE+ | cases ["wasm32"] -> Wasm32+ | cases ["wasm64"] -> Wasm64+ | cases ["csky"] -> CSKY+ | cases ["loongarch32"] -> LoongArch32+ | cases ["loongarch64"] -> LoongArch64+ | cases ["dxil"] -> DXIL+ | otherwise -> UnknownArch+ in case mArch of+ UnknownArch ->+ if | archPfx ARM || archPfx Thumb || archPfx AArch64 ->+ ARM.parseARMArch (ARM.ArchName s)+ | "bpf" `List.isPrefixOf` s -> parseBPFArch s+ | otherwise -> UnknownArch+ arch -> arch+ where+ cases = any (== s)+ archPfx arch = Print.archName arch `List.isPrefixOf` s++ -- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/lib/Support/Triple.cpp#L292+ parseBPFArch arch =+ if arch == "bpf"+ -- The way that LLVM parses the arch for BPF depends on the endianness of+ -- the host in this case, which feels deeply wrong. We don't do that, not+ -- least since we're not in IO. We default to little-endian instead.+ then BPFEL+ else if | arch == "bpf_be" || arch == "bpfeb" -> BPFEB+ | arch == "bpf_le" || arch == "bpfel" -> BPFEL+ | otherwise -> UnknownArch++-- | @llvm::parseVendor@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/lib/Support/Triple.cpp#L529+parseVendor :: String -> Vendor+parseVendor = lookupWithDefault table UnknownVendor+ where table = enumTable Print.vendorName++-- | @llvm::parseOS@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/lib/Support/Triple.cpp#L549+parseOS :: String -> OS+parseOS = lookupByPrefixWithDefault table UnknownOS+ where table = enumTable Print.osName++-- | @llvm::parseEnvironment@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/lib/Support/Triple.cpp#L593+parseEnv :: String -> Environment+parseEnv = lookupByPrefixWithDefault table UnknownEnvironment+ where table = enumTable Print.envName++-- | @llvm::parseFormat@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/lib/Support/Triple.cpp#L634+parseObjFmt :: String -> ObjectFormat+parseObjFmt = lookupBySuffixWithDefault table UnknownObjectFormat+ where table = enumTable Print.objFmtName++-- | @llvm::parseSubArch@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/lib/Support/Triple.cpp#L648+parseSubArch :: String -> SubArch+parseSubArch subArchName =+ if | startsWith "mips" && (endsWith "r6el" || endsWith "r6") -> MipsSubArch_r6++ | subArchName == "powerpcspe" -> PPCSubArch_spe++ | subArchName == "arm64e" -> AArch64SubArch_arm64e++ | startsWith "arm64e" -> AArch64SubArch_arm64e++ | startsWith "spirv" ->+ if | endsWith "v1.0" -> SPIRVSubArch_v10+ | endsWith "v1.1" -> SPIRVSubArch_v11+ | endsWith "v1.2" -> SPIRVSubArch_v12+ | endsWith "v1.3" -> SPIRVSubArch_v13+ | endsWith "v1.4" -> SPIRVSubArch_v14+ | endsWith "v1.5" -> SPIRVSubArch_v15+ | otherwise -> NoSubArch+ | otherwise ->+ case ARM.parseArch <$> armSubArch of+ Nothing ->+ if | endsWith "kalimba3" -> KalimbaSubArch_v3+ | endsWith "kalimba4" -> KalimbaSubArch_v4+ | endsWith "kalimba5" -> KalimbaSubArch_v5+ | otherwise -> NoSubArch+ Just armArch ->+ if | armArch == ARM.ARMV4 -> NoSubArch+ | armArch == ARM.ARMV4T -> ARMSubArch_v4t+ | armArch == ARM.ARMV5T -> ARMSubArch_v5+ | armArch == ARM.ARMV5TE ||+ armArch == ARM.IWMMXT ||+ armArch == ARM.IWMMXT2 ||+ armArch == ARM.XSCALE ||+ armArch == ARM.ARMV5TEJ -> ARMSubArch_v5te+ | armArch == ARM.ARMV6 -> ARMSubArch_v6+ | armArch == ARM.ARMV6K ||+ armArch == ARM.ARMV6KZ -> ARMSubArch_v6k+ | armArch == ARM.ARMV6T2 -> ARMSubArch_v6t2+ | armArch == ARM.ARMV6M -> ARMSubArch_v6m+ | armArch == ARM.ARMV7A ||+ armArch == ARM.ARMV7R -> ARMSubArch_v7+ | armArch == ARM.ARMV7VE -> ARMSubArch_v7ve+ | armArch == ARM.ARMV7K -> ARMSubArch_v7k+ | armArch == ARM.ARMV7M -> ARMSubArch_v7m+ | armArch == ARM.ARMV7S -> ARMSubArch_v7s+ | armArch == ARM.ARMV7EM -> ARMSubArch_v7em+ | armArch == ARM.ARMV8A -> ARMSubArch_v8+ | armArch == ARM.ARMV8_1A -> ARMSubArch_v8_1a+ | armArch == ARM.ARMV8_2A -> ARMSubArch_v8_2a+ | armArch == ARM.ARMV8_3A -> ARMSubArch_v8_3a+ | armArch == ARM.ARMV8_4A -> ARMSubArch_v8_4a+ | armArch == ARM.ARMV8_5A -> ARMSubArch_v8_5a+ | armArch == ARM.ARMV8_6A -> ARMSubArch_v8_6a+ | armArch == ARM.ARMV8_7A -> ARMSubArch_v8_7a+ | armArch == ARM.ARMV8_8A -> ARMSubArch_v8_8a+ | armArch == ARM.ARMV9A -> ARMSubArch_v9+ | armArch == ARM.ARMV9_1A -> ARMSubArch_v9_1a+ | armArch == ARM.ARMV9_2A -> ARMSubArch_v9_2a+ | armArch == ARM.ARMV9_3A -> ARMSubArch_v9_3a+ | armArch == ARM.ARMV8R -> ARMSubArch_v8r+ | armArch == ARM.ARMV8MBaseline -> ARMSubArch_v8m_baseline+ | armArch == ARM.ARMV8MMainline -> ARMSubArch_v8m_mainline+ | armArch == ARM.ARMV8_1MMainline -> ARMSubArch_v8_1m_mainline+ | otherwise -> NoSubArch+ where+ startsWith = (`List.isPrefixOf` subArchName)+ endsWith = (`List.isSuffixOf` subArchName)+ armSubArch = ARM.getCanonicalArchName (ARM.ArchName subArchName)++-- | @llvm::Triple::getDefaultFormat@+--+-- TODO(#97): Implement me!+defaultObjFmt :: TargetTriple -> ObjectFormat+defaultObjFmt _tt = UnknownObjectFormat++-- | @llvm::Triple::Triple@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/lib/Support/Triple.cpp#L869+parseTriple :: String -> TargetTriple+parseTriple str =+ execState (split '-' str) $ do+ let pop def f =+ M.sets $+ \case+ (hd:rest) -> (f hd, rest)+ [] -> (def, [])+ (arch, subArch) <-+ pop (UnknownArch, NoSubArch) (\s -> (parseArch s, parseSubArch s))+ vendor <- pop UnknownVendor parseVendor+ os <- pop UnknownOS parseOS+ (env, objFmt) <-+ pop (UnknownEnvironment, UnknownObjectFormat) (\s -> (parseEnv s, parseObjFmt s))+ let tt =+ TargetTriple+ { ttArch = arch+ , ttSubArch = subArch+ , ttVendor = vendor+ , ttOS = os+ , ttEnv = env+ , ttObjFmt = objFmt+ }+ return (tt { ttObjFmt =+ if ttObjFmt tt == UnknownObjectFormat+ then defaultObjFmt tt+ else ttObjFmt tt+ })+ where++ -- > split '-' "foo-bar" == ["foo", "bar"]+ split :: Char -> String -> [String]+ split splitter =+ foldr (\c strs -> if c == splitter then ([]:strs) else push c strs) [[]]+ where+ push c [] = [[c]]+ push c (s:strs) = (c:s):strs++ -- Not in MonadLib...+ execState s = fst . M.runState s
+ llvm-pretty/src/Text/LLVM/Triple/Parse/ARM.hs view
@@ -0,0 +1,347 @@+{- |+Module : Text.LLVM.Triple.Parse.ARM+Description : ARM utilities used in target triple parsing.+License : BSD3+Maintainer : Langston Barrett+Stability : experimental++This module is not exposed as part of the library API.+-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE StrictData #-}++module Text.LLVM.Triple.Parse.ARM+ ( ArchName(..)+ -- * Endianness+ , EndianKind(..)+ , parseEndianKind+ -- * ISA+ , ISAKind(..)+ , parseISAKind+ -- * Arch+ , getCanonicalArchName+ , parseARMArch+ , ARMArch(..)+ , armArchName+ , parseArch+ ) where++import qualified Data.Char as Char+import Control.Monad (liftM2, when)+import qualified MonadLib as M+import qualified MonadLib.Monads as M+import qualified Data.List as List++import Text.LLVM.Triple.AST+import qualified Text.LLVM.Triple.Parse.LookupTable as Lookup++-- | The "arch" portion of a target triple+newtype ArchName = ArchName { getArchName :: String }++--------------------------------------------------------------------------------+-- Endianness++-- | @llvm::EndianKind@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/include/llvm/Support/ARMTargetParser.h#L166+data EndianKind+ = Little+ | Big+ deriving (Bounded, Enum, Eq, Ord)++-- | @llvm::ARM::parseArchEndian@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/lib/Support/ARMTargetParser.cpp#L248+parseEndianKind :: ArchName -> Maybe EndianKind+parseEndianKind (ArchName arch) =+ if | hasPfx "armeb" || hasPfx "thumbeb" || hasPfx "aarch64_be" -> Just Big+ | hasPfx "arm" || hasPfx "thumb" ->+ if hasSfx "eb"+ then Just Big+ else Just Little+ | hasPfx "aarch64" || hasPfx "aarch64_32" -> Just Little+ | otherwise -> Nothing+ where+ hasPfx = (`List.isPrefixOf` arch)+ hasSfx = (`List.isSuffixOf` arch)++--------------------------------------------------------------------------------+-- ISA++-- | @llvm::ISAKind@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/include/llvm/Support/ARMTargetParser.h#L162+data ISAKind+ = ISAArm+ | ISAThumb+ | ISAAArch64+ deriving (Bounded, Enum, Eq, Ord)++-- | @llvm::ARM::parseArchISA@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/lib/Support/ARMTargetParser.cpp#L267+parseISAKind :: ArchName -> Maybe ISAKind+parseISAKind (ArchName arch) = Lookup.lookupByPrefix arch table+ where+ table =+ Lookup.makeTable+ [ ("aarch64", ISAAArch64)+ , ("arm64", ISAAArch64)+ , ("thumb", ISAThumb)+ , ("arm", ISAArm)+ ]++--------------------------------------------------------------------------------+-- Arch++-- | @llvm::ARM::getArchSynonym@+getArchSynonym :: ArchName -> ArchName+getArchSynonym (ArchName arch) =+ ArchName $+ if | cases ["v5"] -> "v5t"+ | cases ["v5e"] -> "v5te"+ | cases ["v6j"] -> "v6"+ | cases ["v6hl"] -> "v6k"+ | cases ["v6m", "v6sm", "v6s-m"] -> "v6-m"+ | cases ["v6z", "v6zk"] -> "v6kz"+ | cases ["v7", "v7a", "v7hl", "v7l"] -> "v7-a"+ | cases ["v7r"] -> "v7-r"+ | cases ["v7m"] -> "v7-m"+ | cases ["v7em"] -> "v7e-m"+ | cases ["v8", "v8a", "v8l", "aarch64", "arm64"] -> "v8-a"+ | cases ["v8.1a"] -> "v8.1-a"+ | cases ["v8.2a"] -> "v8.2-a"+ | cases ["v8.3a"] -> "v8.3-a"+ | cases ["v8.4a"] -> "v8.4-a"+ | cases ["v8.5a"] -> "v8.5-a"+ | cases ["v8.6a"] -> "v8.6-a"+ | cases ["v8.7a"] -> "v8.7-a"+ | cases ["v8.8a"] -> "v8.8-a"+ | cases ["v8r"] -> "v8-r"+ | cases ["v9", "v9a"] -> "v9-a"+ | cases ["v9.1a"] -> "v9.1-a"+ | cases ["v9.2a"] -> "v9.2-a"+ | cases ["v9.3a"] -> "v9.3-a"+ | cases ["v8m.base"] -> "v8-m.base"+ | cases ["v8m.main"] -> "v8-m.main"+ | cases ["v8.1m.main"] -> "v8.1-m.main"+ | otherwise -> arch+ where+ cases = any (== arch)++data CanonicalArchNameState+ = CanonicalArchNameState+ { offset :: Int+ , archStr :: String -- ^ @A@ in the LLVM+ }++-- | @llvm::ARM::getCanonicalArchName@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/lib/Support/ARMTargetParser.cpp#L295+getCanonicalArchName :: ArchName -> Maybe ArchName+getCanonicalArchName (ArchName arch) =+ -- See Note [Implementation] for the reasoning behind the strange structure.+ --+ -- Could probably be translated even more directly using ContT, but that feels+ -- like a bit much.+ execState (CanonicalArchNameState 0 arch) $ do+ ifM (liftM2 (&&) (startsWith "aarch64") (contains "eb")) (return Nothing) $ do+ whenM (startsWith "arm64_32") $+ setOffset 8+ whenM (startsWith "arm64e") $+ setOffset 6+ whenM (startsWith "arm64") $+ setOffset 5+ whenM (startsWith "aarch64_32") $+ setOffset 10+ whenM (startsWith "arm") $+ setOffset 3+ whenM (startsWith "thumb") $+ setOffset 5+ whenM (startsWith "aarch64") $ do+ setOffset 7+ whenM ((== "_be") <$> archOffSubstr 3) $+ addOffset 3++ off <- offset <$> M.get+ sub <- archOffSubstr 2+ when (off /= npos && sub == "eb") $+ addOffset 2+ whenM (endsWith "eb") $ do+ changeArch (\arch' -> substr 0 (length arch' - 2) arch')+ off' <- offset <$> M.get+ when (off' /= npos) $+ changeArch (drop off')++ arch' <- archStr <$> M.get+ if | length arch' == 0 -> return Nothing+ | off' /= npos && length arch' > 2 &&+ (take 1 arch' /= "v" || not (all Char.isDigit (substr 1 1 arch'))) ->+ return Nothing+ | off' /= npos && "eb" `List.isInfixOf` arch' -> return Nothing+ | otherwise -> return (Just (ArchName arch'))+ where+ npos = 0++ ifM b thn els = b >>= \b' -> if b' then thn else els+ whenM b k = ifM b k (return ())+ startsWith pfx = (pfx `List.isPrefixOf`) . archStr <$> M.get+ endsWith sfx = (sfx `List.isSuffixOf`) . archStr <$> M.get+ contains ifx = (ifx `List.isInfixOf`) . archStr <$> M.get++ substr start sz = take sz . drop start+ archSubstr begin sz = substr begin sz . archStr <$> M.get+ archOffSubstr sz = do+ off <- offset <$> M.get+ archSubstr off sz++ changeOffset f = do+ s <- M.get+ M.set (s { offset = f (offset s) })+ addOffset n = changeOffset (n+)+ setOffset n = changeOffset (const n)++ changeArch f = M.set . (\s -> s { archStr = f (archStr s) }) =<< M.get++ -- Not in MonadLib...+ execState s = fst . M.runState s++-- | @llvm::parseARMArch@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/lib/Support/Triple.cpp#L377+parseARMArch :: ArchName -> Arch+parseARMArch archName =+ let+ isa = parseISAKind archName+ endian = parseEndianKind archName+ arch =+ case endian of+ Just Little ->+ case isa of+ Just ISAArm -> ARM+ Just ISAThumb -> Thumb+ Just ISAAArch64 -> AArch64+ Nothing -> UnknownArch+ Just Big ->+ case isa of+ Just ISAArm -> ARMEB+ Just ISAThumb -> ThumbEB+ Just ISAAArch64 -> AArch64_BE+ Nothing -> UnknownArch+ Nothing -> UnknownArch+ mArchName = getCanonicalArchName archName+ in case mArchName of+ Nothing -> UnknownArch+ Just (ArchName archNm) ->+ if | isa == Just ISAThumb &&+ ("v2" `List.isPrefixOf` archNm || "v3" `List.isPrefixOf` archNm) -> UnknownArch+ -- TODO(#98): LLVM has one more check here involving the "arch+ -- profile" that's not yet implemented here... Probably not a big+ -- deal because this case is only executed when the target arch+ -- doesn't match the "canonical" versions like "arm", "thumb", and+ -- "aarch64".+ | otherwise -> arch++-- | See LLVM's @ARMTargetParser.def@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/include/llvm/Support/ARMTargetParser.def#L48+data ARMArch+ = ARMArchInvalid+ | ARMV2+ | ARMV2A+ | ARMV3+ | ARMV3M+ | ARMV4+ | ARMV4T+ | ARMV5T+ | ARMV5TE+ | ARMV5TEJ+ | ARMV6+ | ARMV6K+ | ARMV6T2+ | ARMV6KZ+ | ARMV6M+ | ARMV7A+ | ARMV7VE+ | ARMV7R+ | ARMV7M+ | ARMV7EM+ | ARMV8A+ | ARMV8_1A+ | ARMV8_2A+ | ARMV8_3A+ | ARMV8_4A+ | ARMV8_5A+ | ARMV8_6A+ | ARMV8_7A+ | ARMV8_8A+ | ARMV9A+ | ARMV9_1A+ | ARMV9_2A+ | ARMV9_3A+ | ARMV8R+ | ARMV8MBaseline+ | ARMV8MMainline+ | ARMV8_1MMainline+ | IWMMXT+ | IWMMXT2+ | XSCALE+ | ARMV7S+ | ARMV7K+ deriving (Bounded, Enum, Eq, Ord)++armArchName :: ARMArch -> String+armArchName =+ \case+ ARMArchInvalid -> "invalid"+ ARMV2 -> "armv2"+ ARMV2A -> "armv2a"+ ARMV3 -> "armv3"+ ARMV3M -> "armv3m"+ ARMV4 -> "armv4"+ ARMV4T -> "armv4t"+ ARMV5T -> "armv5t"+ ARMV5TE -> "armv5te"+ ARMV5TEJ -> "armv5tej"+ ARMV6 -> "armv6"+ ARMV6K -> "armv6k"+ ARMV6T2 -> "armv6t2"+ ARMV6KZ -> "armv6kz"+ ARMV6M -> "armv6-m"+ ARMV7A -> "armv7-a"+ ARMV7VE -> "armv7ve"+ ARMV7R -> "armv7-r"+ ARMV7M -> "armv7-m"+ ARMV7EM -> "armv7e-m"+ ARMV8A -> "armv8-a"+ ARMV8_1A -> "armv8.1-a"+ ARMV8_2A -> "armv8.2-a"+ ARMV8_3A -> "armv8.3-a"+ ARMV8_4A -> "armv8.4-a"+ ARMV8_5A -> "armv8.5-a"+ ARMV8_6A -> "armv8.6-a"+ ARMV8_7A -> "armv8.7-a"+ ARMV8_8A -> "armv8.8-a"+ ARMV9A -> "armv9-a"+ ARMV9_1A -> "armv9.1-a"+ ARMV9_2A -> "armv9.2-a"+ ARMV9_3A -> "armv9.3-a"+ ARMV8R -> "armv8-r"+ ARMV8MBaseline -> "armv8-m.base"+ ARMV8MMainline -> "armv8-m.main"+ ARMV8_1MMainline -> "armv8.1-m.main"+ IWMMXT -> "iwmmxt"+ IWMMXT2 -> "iwmmxt2"+ XSCALE -> "xscale"+ ARMV7S -> "armv7s"+ ARMV7K -> "armv7k"++-- | @llvm::ARM::parseArch@+parseArch :: ArchName -> ARMArch+parseArch arch =+ let ArchName syn = getArchSynonym arch+ table = Lookup.enumTable armArchName+ in Lookup.lookupBySuffixWithDefault table ARMArchInvalid syn
+ llvm-pretty/src/Text/LLVM/Triple/Parse/LookupTable.hs view
@@ -0,0 +1,77 @@+{- |+Module : Text.LLVM.Triple.Parse.LookupTable+Description : Helpers for parsing a finite set of strings.+License : BSD3+Maintainer : Langston Barrett+Stability : experimental++This module is not exposed as part of the library API.+-}++{-# LANGUAGE TupleSections #-}++module Text.LLVM.Triple.Parse.LookupTable+ ( -- * Construction+ LookupTable+ , makeTable+ , enumTable+ , enumTableVariants+ -- * Queries+ , lookupBy+ , lookup+ , lookupByPrefix+ , lookupByWithDefault+ , lookupWithDefault+ , lookupByPrefixWithDefault+ , lookupBySuffixWithDefault+ ) where++import Prelude hiding (lookup)+import qualified Data.Maybe as Maybe+import qualified Data.List as List++--------------------------------------------------------------------------------+-- Construction++-- | A table from constrant strings to values, to be used in parsing a finite+-- set of possibilities. Could be replaced by a fancier data structure, but+-- there's only one target triple per module, after all.+--+-- Hopefully, GHC is smart enough to construct these at compile-time.+newtype LookupTable a = LookupTable { getLookupTable :: [(String, a)] }++makeTable :: [(String, a)] -> LookupTable a+makeTable = LookupTable++enumTable :: Bounded a => Enum a => (a -> String) -> LookupTable a+enumTable prnt = makeTable [(prnt a, a) | a <- enumFrom minBound]++enumTableVariants :: Bounded a => Enum a => (a -> [String]) -> LookupTable a+enumTableVariants prnt =+ makeTable (concatMap (\a -> map (,a) (prnt a)) (enumFrom minBound))++--------------------------------------------------------------------------------+-- Queries++lookupBy :: (String -> Bool) -> LookupTable a -> Maybe a+lookupBy p = Maybe.listToMaybe . map snd . filter (p . fst) . getLookupTable++lookup :: String -> LookupTable a -> Maybe a+lookup s = lookupBy (== s)++lookupByPrefix :: String -> LookupTable a -> Maybe a+lookupByPrefix pfx = lookupBy (pfx `List.isPrefixOf`)++lookupByWithDefault :: a -> (String -> Bool) -> LookupTable a -> a+lookupByWithDefault def p = Maybe.fromMaybe def . lookupBy p++lookupWithDefault :: LookupTable a -> a -> String -> a+lookupWithDefault table def val = lookupByWithDefault def (== val) table++lookupByPrefixWithDefault :: LookupTable a -> a -> String -> a+lookupByPrefixWithDefault table def pfx =+ lookupByWithDefault def (pfx `List.isPrefixOf`) table++lookupBySuffixWithDefault :: LookupTable a -> a -> String -> a+lookupBySuffixWithDefault table def sfx =+ lookupByWithDefault def (sfx `List.isSuffixOf`) table
+ llvm-pretty/src/Text/LLVM/Triple/Print.hs view
@@ -0,0 +1,229 @@+{- |+Module : Text.LLVM.Triple.Print+Description : Printing of LLVM target triples.+License : BSD3+Maintainer : Langston Barrett+Stability : experimental+-}++{-# LANGUAGE LambdaCase #-}++module Text.LLVM.Triple.Print+ ( archName+ , vendorName+ , osName+ , envName+ , objFmtName+ , printTriple+ ) where++import qualified Data.List as List++import Text.LLVM.Triple.AST++-- | @llvm::Triple::getArchTypeName@.+--+-- Retained in the order in which they appear in the LLVM source, rather than an+-- order consistent with the constructors of 'Arch'.+archName :: Arch -> String+archName =+ \case+ UnknownArch -> "unknown"+ AArch64 -> "aarch64"+ AArch64_32 -> "aarch64_32"+ AArch64_BE -> "aarch64_be"+ AMDGCN -> "amdgcn"+ AMDIL64 -> "amdil64"+ AMDIL -> "amdil"+ ARC -> "arc"+ ARM -> "arm"+ ARMEB -> "armeb"+ AVR -> "avr"+ BPFEB -> "bpfeb"+ BPFEL -> "bpfel"+ CSKY -> "csky"+ DXIL -> "dxil"+ Hexagon -> "hexagon"+ HSAIL64 -> "hsail64"+ HSAIL -> "hsail"+ Kalimba -> "kalimba"+ Lanai -> "lanai"+ Le32 -> "le32"+ Le64 -> "le64"+ LoongArch32 -> "loongarch32"+ LoongArch64 -> "loongarch64"+ M68k -> "m68k"+ MIPS64 -> "mips64"+ MIPS64EL -> "mips64el"+ MIPS -> "mips"+ MIPSEL -> "mipsel"+ MSP430 -> "msp430"+ NVPTX64 -> "nvptx64"+ NVPTX -> "nvptx"+ PPC64 -> "powerpc64"+ PPC64LE -> "powerpc64le"+ PPC -> "powerpc"+ PPCLE -> "powerpcle"+ R600 -> "r600"+ RenderScript32 -> "renderscript32"+ RenderScript64 -> "renderscript64"+ RISCV32 -> "riscv32"+ RISCV64 -> "riscv64"+ SHAVE -> "shave"+ Sparc -> "sparc"+ SparcEL -> "sparcel"+ Sparcv9 -> "sparcv9"+ SPIR64 -> "spir64"+ SPIR -> "spir"+ SPIRV32 -> "spirv32"+ SPIRV64 -> "spirv64"+ SystemZ -> "s390x"+ TCE -> "tce"+ TCELE -> "tcele"+ Thumb -> "thumb"+ ThumbEB -> "thumbeb"+ VE -> "ve"+ Wasm32 -> "wasm32"+ Wasm64 -> "wasm64"+ X86 -> "i386"+ X86_64 -> "x86_64"+ XCore -> "xcore"++-- | @llvm::Triple::getVendorTypeName@.+--+-- Retained in the order in which they appear in the LLVM source.+vendorName :: Vendor -> String+vendorName =+ \case+ UnknownVendor -> "unknown"+ AMD -> "amd"+ Apple -> "apple"+ CSR -> "csr"+ Freescale -> "fsl"+ IBM -> "ibm"+ ImaginationTechnologies -> "img"+ Mesa -> "mesa"+ MipsTechnologies -> "mti"+ Myriad -> "myriad"+ NVIDIA -> "nvidia"+ OpenEmbedded -> "oe"+ PC -> "pc"+ SCEI -> "scei"+ SUSE -> "suse"++-- | @llvm::Triple::getOSTypeName@.+--+-- Retained in the order in which they appear in the LLVM source.+osName :: OS -> String+osName =+ \case+ UnknownOS -> "unknown"+ AIX -> "aix"+ AMDHSA -> "amdhsa"+ AMDPAL -> "amdpal"+ Ananas -> "ananas"+ CUDA -> "cuda"+ CloudABI -> "cloudabi"+ Contiki -> "contiki"+ Darwin -> "darwin"+ DragonFly -> "dragonfly"+ DriverKit -> "driverkit"+ ELFIAMCU -> "elfiamcu"+ Emscripten -> "emscripten"+ FreeBSD -> "freebsd"+ Fuchsia -> "fuchsia"+ Haiku -> "haiku"+ HermitCore -> "hermit"+ Hurd -> "hurd"+ IOS -> "ios"+ KFreeBSD -> "kfreebsd"+ Linux -> "linux"+ Lv2 -> "lv2"+ MacOSX -> "macosx"+ Mesa3D -> "mesa3d"+ Minix -> "minix"+ NVCL -> "nvcl"+ NaCl -> "nacl"+ NetBSD -> "netbsd"+ OpenBSD -> "openbsd"+ PS4 -> "ps4"+ PS5 -> "ps5"+ RTEMS -> "rtems"+ Solaris -> "solaris"+ TvOS -> "tvos"+ WASI -> "wasi"+ WatchOS -> "watchos"+ Win32 -> "windows"+ ZOS -> "zos"+ ShaderModel -> "shadermodel"++-- | @llvm::Triple::getEnvironmentName@.+--+-- Retained in the order in which they appear in the LLVM source.+envName :: Environment -> String+envName =+ \case+ UnknownEnvironment -> "unknown"+ Android -> "android"+ CODE16 -> "code16"+ CoreCLR -> "coreclr"+ Cygnus -> "cygnus"+ EABI -> "eabi"+ EABIHF -> "eabihf"+ GNU -> "gnu"+ GNUABI64 -> "gnuabi64"+ GNUABIN32 -> "gnuabin32"+ GNUEABI -> "gnueabi"+ GNUEABIHF -> "gnueabihf"+ GNUX32 -> "gnux32"+ GNUILP32 -> "gnu_ilp32"+ Itanium -> "itanium"+ MSVC -> "msvc"+ MacABI -> "macabi"+ Musl -> "musl"+ MuslEABI -> "musleabi"+ MuslEABIHF -> "musleabihf"+ MuslX32 -> "muslx32"+ Simulator -> "simulator"+ Pixel -> "pixel"+ Vertex -> "vertex"+ Geometry -> "geometry"+ Hull -> "hull"+ Domain -> "domain"+ Compute -> "compute"+ Library -> "library"+ RayGeneration -> "raygeneration"+ Intersection -> "intersection"+ AnyHit -> "anyhit"+ ClosestHit -> "closesthit"+ Miss -> "miss"+ Callable -> "callable"+ Mesh -> "mesh"+ Amplification -> "amplification"++-- | @llvm::Triple::getObjectFormatTypeName@+--+-- Retained in the order in which they appear in the LLVM source.+objFmtName :: ObjectFormat -> String+objFmtName =+ \case+ UnknownObjectFormat -> "" -- NB: Not "unknown"+ COFF -> "coff"+ ELF -> "elf"+ GOFF -> "goff"+ MachO -> "macho"+ Wasm -> "wasm"+ XCOFF -> "xcoff"+ DXContainer -> "dxcontainer"+ SPIRV -> "spirv"++printTriple :: TargetTriple -> String+printTriple tt =+ List.intercalate+ "-"+ [ archName (ttArch tt)+ , vendorName (ttVendor tt)+ , osName (ttOS tt)+ , envName (ttEnv tt)+ , objFmtName (ttObjFmt tt)+ ]
+ llvm-pretty/src/Text/LLVM/Util.hs view
@@ -0,0 +1,18 @@+module Text.LLVM.Util where++import Control.Monad (MonadPlus,mzero)+import Data.List (unfoldr)+++breaks :: (a -> Bool) -> [a] -> [[a]]+breaks p = unfoldr step+ where+ step [] = Nothing+ step xs = case break p xs of+ (as,_:bs) -> Just (as,bs)+ (as, []) -> Just (as,[])++uncons :: MonadPlus m => [a] -> m (a,[a])+uncons (a:as) = return (a,as)+uncons _ = mzero+
src/Data/Array/Accelerate/LLVM/AST.hs view
@@ -25,7 +25,7 @@ import Data.Array.Accelerate.LLVM.Execute.Async -import Data.Array.Accelerate.AST ( PreOpenAfun(..), HasArraysR(..), ArrayVar, ALeftHandSide, Exp, Direction, PrimBool, arrayR )+import Data.Array.Accelerate.AST ( PreOpenAfun(..), HasArraysR(..), ArrayVar, ALeftHandSide, Exp, Direction, Message, PrimBool, arrayR ) import Data.Array.Accelerate.AST.Idx import Data.Array.Accelerate.AST.Var import Data.Array.Accelerate.Representation.Array@@ -65,6 +65,11 @@ Anil :: PreOpenAccCommand acc arch aenv () + Atrace :: Message arrs1+ -> acc arch aenv arrs1+ -> acc arch aenv arrs2+ -> PreOpenAccCommand acc arch aenv arrs2+ Apply :: ArraysR bs -> PreOpenAfun (acc arch) aenv (as -> bs) -> acc arch aenv as@@ -194,6 +199,7 @@ arraysR (Unit tp _) = TupRsingle $ ArrayR ShapeRz tp arraysR (Apair a1 a2) = arraysR a1 `TupRpair` arraysR a2 arraysR Anil = TupRunit+ arraysR (Atrace _ _ a2) = arraysR a2 arraysR (Apply repr _ _) = repr arraysR (Aforeign repr _ _ _) = repr arraysR (Acond _ a1 _) = arraysR a1
src/Data/Array/Accelerate/LLVM/Array/Data.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_HADDOCK hide #-} -- |
src/Data/Array/Accelerate/LLVM/CodeGen.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}@@ -46,6 +47,7 @@ import Data.Array.Accelerate.LLVM.Foreign import Data.Array.Accelerate.LLVM.State +import Formatting import Prelude hiding ( map, scanl, scanl1, scanr, scanr1 ) @@ -83,6 +85,7 @@ Awhile{} -> unexpectedError Apair{} -> unexpectedError Anil -> unexpectedError+ Atrace{} -> unexpectedError Use{} -> unexpectedError Unit{} -> unexpectedError Aforeign{} -> unexpectedError@@ -122,6 +125,6 @@ -- sadness fusionError, unexpectedError :: error- fusionError = internalError $ "unexpected fusible material: " ++ showPreAccOp pacc- unexpectedError = internalError $ "unexpected array primitive: " ++ showPreAccOp pacc+ fusionError = internalError ("unexpected fusible material: " % formatPreAccOp) pacc+ unexpectedError = internalError ("unexpected array primitive: " % formatPreAccOp) pacc
src/Data/Array/Accelerate/LLVM/CodeGen/Arithmetic.hs view
@@ -79,12 +79,11 @@ IntegralNumType i | unsigned i -> return x | IntegralDict <- integralDict i ->- let p = ScalarPrimType (SingleScalarType (NumSingleType n))- t = PrimType p+ let p = ScalarPrimType (SingleScalarType (NumSingleType n))+ t = PrimType p+ fn = fromString $ printf "llvm.abs.i%d" (finiteBitSize (undefined::a)) in- case finiteBitSize (undefined :: a) of- 64 -> call (Lam p (op n x) (Body t Nothing "llabs")) [NoUnwind, ReadNone]- _ -> call (Lam p (op n x) (Body t Nothing "abs")) [NoUnwind, ReadNone]+ call (Lam p (op n x) (Lam primType (boolean False) (Body t Nothing fn))) [NoUnwind, ReadNone] signum :: forall arch a. NumType a -> Operands a -> CodeGen arch (Operands a) signum t x =@@ -262,20 +261,22 @@ rotateL :: forall arch a. IntegralType a -> Operands a -> Operands Int -> CodeGen arch (Operands a) rotateL t x i | IntegralDict <- integralDict t- = do let wsib = finiteBitSize (undefined::a)- i1 <- band integralType i (ir integralType (integral integralType (wsib P.- 1)))- i2 <- sub numType (ir numType (integral integralType wsib)) i1- --- a <- shiftL t x i1- b <- shiftRL t x i2- c <- bor t a b- return c+ = do let fshl = fromString $ printf "llvm.fshl.i%d" (finiteBitSize (undefined::a))+ p = ScalarPrimType (SingleScalarType (NumSingleType (IntegralNumType t)))+ x' = op t x+ i' <- fromIntegral integralType (IntegralNumType t) i+ r <- call (Lam p x' (Lam p x' (Lam p (op t i') (Body (PrimType p) Nothing fshl)))) [NoUnwind, ReadNone]+ return r -rotateR :: IntegralType a -> Operands a -> Operands Int -> CodeGen arch (Operands a)-rotateR t x i = do- i' <- negate numType i- r <- rotateL t x i'- return r+rotateR :: forall arch a. IntegralType a -> Operands a -> Operands Int -> CodeGen arch (Operands a)+rotateR t x i+ | IntegralDict <- integralDict t+ = do let fshr = fromString $ printf "llvm.fshr.i%d" (finiteBitSize (undefined::a))+ p = ScalarPrimType (SingleScalarType (NumSingleType (IntegralNumType t)))+ x' = op t x+ i' <- fromIntegral integralType (IntegralNumType t) i+ r <- call (Lam p x' (Lam p x' (Lam p (op t i') (Body (PrimType p) Nothing fshr)))) [NoUnwind, ReadNone]+ return r popCount :: forall arch a. IntegralType a -> Operands a -> CodeGen arch (Operands Int) popCount i x
src/Data/Array/Accelerate/LLVM/CodeGen/Array.hs view
@@ -24,7 +24,7 @@ import Prelude hiding ( read ) import Data.Bits -import LLVM.AST.Type.AddrSpace+import LLVM.AST.Type.GetElementPtr import LLVM.AST.Type.Instruction import LLVM.AST.Type.Instruction.Volatile import LLVM.AST.Type.Operand@@ -133,19 +133,22 @@ -> Operand (Ptr e) -> Operand int -> CodeGen arch (Operand (Ptr e))-getElementPtr _ SingleScalarType{} _ arr ix = instr' $ GetElementPtr arr [ix]-getElementPtr a (VectorScalarType v) i arr ix- | VectorType n _ <- v- , IntegralDict <- integralDict i+getElementPtr _ t@(SingleScalarType{}) _ arr ix = instr' $ GetElementPtr $ GEP1 t arr ix+getElementPtr a t@(VectorScalarType v) i arr ix+ | VectorType n eltty <- v+ , IntegralDict <- integralDict i = if popCount n == 1- then instr' $ GetElementPtr arr [ix]+ then instr' $ GetElementPtr $ GEP1 t arr ix else do -- Note the initial zero into to the GEP instruction. It is not -- really recommended to use GEP to index into vector elements, but- -- is not forcefully disallowed (at this time)- ix' <- instr' $ Mul (IntegralNumType i) ix (integral i (fromIntegral n))- p' <- instr' $ GetElementPtr arr [integral i 0, ix']- p <- instr' $ PtrCast (PtrPrimType (ScalarPrimType (VectorScalarType v)) a) p'+ -- is not forcefully disallowed (at this time).+ -- Cast the <n x t>* to a t*, do a scaled GEP, and cast the resulting+ -- t* back to an <n x t>*.+ ix' <- instr' $ Mul (IntegralNumType i) ix (integral i (fromIntegral n))+ pPlain <- instr' $ PtrCast (PtrPrimType (ScalarPrimType (SingleScalarType eltty)) a) arr+ p' <- instr' $ GetElementPtr $ GEP1 (SingleScalarType eltty) pPlain ix'+ p <- instr' $ PtrCast (PtrPrimType (ScalarPrimType (VectorScalarType v)) a) p' return p @@ -182,7 +185,7 @@ let go i w | i >= m = return w | otherwise = do- q <- instr' $ GetElementPtr p' [integral integralType i]+ q <- instr' $ GetElementPtr $ GEP1 (SingleScalarType base) p' (integral integralType i) r <- instr' $ Load (SingleScalarType base) v q w' <- instr' $ InsertElement i w r go (i+1) w'@@ -215,7 +218,7 @@ | i >= m = return () | otherwise = do x <- instr' $ ExtractElement i v- q <- instr' $ GetElementPtr p' [integral integralType i]+ q <- instr' $ GetElementPtr $ GEP1 (SingleScalarType base) p' (integral integralType i) _ <- instr' $ Store volatility q x go (i+1) go 0
src/Data/Array/Accelerate/LLVM/CodeGen/Base.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}@@ -34,7 +35,6 @@ ) where -import LLVM.AST.Type.AddrSpace import LLVM.AST.Type.Constant import LLVM.AST.Type.Downcast import LLVM.AST.Type.Function@@ -46,6 +46,7 @@ import LLVM.AST.Type.Operand import LLVM.AST.Type.Representation +import Data.Array.Accelerate.Error import Data.Array.Accelerate.LLVM.CodeGen.Environment import Data.Array.Accelerate.LLVM.CodeGen.IR import Data.Array.Accelerate.LLVM.CodeGen.Monad@@ -55,7 +56,7 @@ import Data.Array.Accelerate.Representation.Type import {-# SOURCE #-} Data.Array.Accelerate.LLVM.CodeGen.Exp -import qualified LLVM.AST.Global as LLVM+import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty as LP import Data.Monoid import Data.String@@ -117,7 +118,7 @@ mutableArray :: ArrayR (Array sh e) -> Name (Array sh e)- -> (IRArray (Array sh e), [LLVM.Parameter])+ -> (IRArray (Array sh e), [LP.Typed LP.Ident]) mutableArray repr name = ( irArray repr name , arrayParam repr name )@@ -129,7 +130,7 @@ delayedArray :: Name (Array sh e) -> MIRDelayed arch aenv (Array sh e)- -> (IRDelayed arch aenv (Array sh e), [LLVM.Parameter])+ -> (IRDelayed arch aenv (Array sh e), [LP.Typed LP.Ident]) delayedArray name = \case IRDelayedJust a -> (a, []) IRDelayedNothing repr ->@@ -197,29 +198,45 @@ -- Function parameters -- ------------------- --- | Call a global function. The function declaration is inserted into the--- symbol table.+-- | Call a global function. --+-- If the function being called has a special prefix (see 'labelIsAccPrelude'),+-- the call instruction is generated as-is; otherwise (the common case), a+-- function declaration is also inserted into the symbol table, resulting in a+-- 'declare' statement in the LLVM module. A special prelude function is+-- currently not allowed to have any function attributes.+--+-- TODO: The original llvm-hs code put function attributes both on the external+-- function declaration and on the call instruction; this code puts them only+-- on the declaration. We should compare LLVM IR / benchmark to see if this is+-- an issue (@llvm-pretty@ does not yet support function attributes on call+-- instructions).+-- call :: GlobalFunction args t -> [FunctionAttribute] -> CodeGen arch (Operands t) call f attrs = do- let decl = (downcast f) { LLVM.functionAttributes = downcast attrs' }- attrs' = map Right attrs+ let decl = (downcast f) { LP.decAttrs = downcast attrs } --- go :: GlobalFunction args t -> Function (Either InlineAssembly Label) args t- go (Body t k l) = Body t k (Right l)- go (Lam t x l) = Lam t x (go l)+ go :: GlobalFunction args t -> (Label, Function (Either InlineAssembly Label) args t)+ go (Body t k l) = (l, Body t k (Right l))+ go (Lam t x l) = Lam t x <$> go l --- declare decl- instr (Call (go f) attrs')+ let (lab, f') = go f+ if labelIsAccPrelude lab+ then case attrs of+ [] -> return ()+ _ -> internalError "Function attributes passed to a call to an acc prelude LLVM function"+ else declareExternFunc decl + instr (Call f') -parameter :: TypeR t -> Name t -> [LLVM.Parameter]-parameter tp n = travTypeToList tp (\s i -> scalarParameter s (rename n i)) -scalarParameter :: ScalarType t -> Name t -> LLVM.Parameter+parameter :: TypeR t -> Name t -> [LP.Typed LP.Ident]+parameter tp n = travTypeToList tp (\s i -> LP.Typed (downcast s) (nameToPrettyI (rename n i)))++scalarParameter :: ScalarType t -> Name t -> LP.Typed LP.Ident scalarParameter t x = downcast (Parameter (ScalarPrimType t) x) -ptrParameter :: ScalarType t -> Name (Ptr t) -> LLVM.Parameter+ptrParameter :: ScalarType t -> Name (Ptr t) -> LP.Typed LP.Ident ptrParameter t x = downcast (Parameter (PtrPrimType (ScalarPrimType t) defaultAddrSpace) x) @@ -227,11 +244,8 @@ -- The environment here refers only to the actual free array variables that are -- accessed by the function. ---envParam :: forall aenv. Gamma aenv -> [LLVM.Parameter]-envParam aenv = concatMap (\(Label n, Idx' repr _) -> toParam repr (Name n)) (IM.elems aenv)- where- toParam :: ArrayR (Array sh e) -> Name (Array sh e) -> [LLVM.Parameter]- toParam repr name = arrayParam repr name+envParam :: forall aenv. Gamma aenv -> [LP.Typed LP.Ident]+envParam aenv = concatMap (\(Label n, Idx' repr _) -> arrayParam repr (Name n)) (IM.elems aenv) -- | Generate function parameters for an Array with given base name.@@ -240,7 +254,7 @@ arrayParam :: ArrayR (Array sh e) -> Name (Array sh e)- -> [LLVM.Parameter]+ -> [LP.Typed LP.Ident] arrayParam (ArrayR shr tp) name = ad ++ sh where ad = travTypeToList tp (\t i -> ptrParameter t (arrayName name i))
src/Data/Array/Accelerate/LLVM/CodeGen/Environment.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE GADTs #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.CodeGen.Environment@@ -19,7 +21,7 @@ import qualified Data.IntMap as IM import Data.Array.Accelerate.AST ( ArrayVar )-import Data.Array.Accelerate.AST.Idx ( Idx(..), idxToInt )+import Data.Array.Accelerate.AST.Idx ( Idx, pattern ZeroIdx, pattern SuccIdx, idxToInt ) import Data.Array.Accelerate.AST.Var ( Var(..) ) import Data.Array.Accelerate.Error ( internalError ) import Data.Array.Accelerate.Representation.Array ( Array, ArrayR(..) )
src/Data/Array/Accelerate/LLVM/CodeGen/Exp.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}@@ -104,7 +105,7 @@ llvmOfOpenExp body (env `pushE` (lhs, x)) aenv Evar (Var _ ix) -> return $ prj ix env Const tp c -> return $ ir tp $ scalar tp c- PrimConst c -> let tp = (SingleScalarType $ primConstType c)+ PrimConst c -> let tp = SingleScalarType (primConstType c) in return $ ir tp $ scalar tp $ primConst c PrimApp f x -> primFun f x Undef tp -> return $ ir tp $ undef tp@@ -113,7 +114,8 @@ VecPack vecr e -> vecPack vecr =<< cvtE e VecUnpack vecr e -> vecUnpack vecr =<< cvtE e Foreign tp asm f x -> foreignE tp asm f =<< cvtE x- Case tag xs mx -> A.caseof (expType (snd (head xs))) (cvtE tag) [(t,cvtE e) | (t,e) <- xs] (fmap cvtE mx)+ Case _ [] _ -> internalError "Empty Case"+ Case tag xs@((_, e1):_) mx -> A.caseof (expType e1) (cvtE tag) [(t,cvtE e) | (t,e) <- xs] (fmap cvtE mx) Cond c t e -> cond (expType t) (cvtE c) (cvtE t) (cvtE e) IndexSlice slice slix sh -> indexSlice slice <$> cvtE slix <*> cvtE sh IndexFull slice slix sh -> indexFull slice <$> cvtE slix <*> cvtE sh@@ -224,7 +226,7 @@ foreignE :: A.Foreign asm => TypeR b- -> asm (a -> b)+ -> asm (a -> b) -> Fun () (a -> b) -> Operands a -> IRExp arch () b
src/Data/Array/Accelerate/LLVM/CodeGen/IR.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.CodeGen.IR@@ -27,6 +28,7 @@ import Data.Array.Accelerate.Error import Data.Primitive.Vec+import Formatting import qualified Data.ByteString.Short as B @@ -35,7 +37,7 @@ -- representing a single Accelerate type. Using a data family rather than a type -- family means that Operands is bijective. ---data family Operands e :: *+data family Operands e data instance Operands () = OP_Unit data instance Operands Int = OP_Int (Operand Int) data instance Operands Int8 = OP_Int8 (Operand Int8)@@ -72,10 +74,10 @@ instance IROP PrimType where op (ScalarPrimType t) = op t op BoolPrimType = \case OP_Bool x -> x- op t = internalError ("unhandled type: " ++ show t)+ op t = internalError ("unhandled type: " % formatPrimType) t ir (ScalarPrimType t) = ir t ir BoolPrimType = OP_Bool- ir t = internalError ("unhandled type: " ++ show t)+ ir t = internalError ("unhandled type: " % formatPrimType) t instance IROP ScalarType where op (SingleScalarType t) = op t
src/Data/Array/Accelerate/LLVM/CodeGen/Module.hs view
@@ -13,11 +13,9 @@ module Data.Array.Accelerate.LLVM.CodeGen.Module where --- llvm-hs-import qualified LLVM.AST as LLVM+import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty as LLVM --- standard library-import Data.Map ( Map )+import Data.Map.Strict ( Map ) -- | A compiled module consists of a number of global functions (kernels). The@@ -26,14 +24,14 @@ -- data Module arch aenv a = Module { unModule :: LLVM.Module- , moduleMetadata :: Map LLVM.Name (KernelMetadata arch)+ , moduleMetadata :: Map LLVM.Symbol (KernelMetadata arch) } -- | A fully-instantiated skeleton is a [collection of] kernel(s) that can be compiled -- by LLVM into a global function that we can execute. -- data Kernel arch aenv a- = Kernel { unKernel :: LLVM.Global+ = Kernel { unKernel :: LLVM.Define , kernelMetadata :: KernelMetadata arch }
src/Data/Array/Accelerate/LLVM/CodeGen/Monad.hs view
@@ -22,9 +22,14 @@ evalCodeGen, liftCodeGen, + -- codegen context+ getLLVMversion,+ -- declarations- fresh, freshName,- declare,+ fresh, freshLocalName, freshGlobalName,+ declareGlobalVar,+ declareExternFunc,+ typedef, intrinsic, -- basic blocks@@ -45,11 +50,11 @@ import Data.Array.Accelerate.LLVM.CodeGen.Intrinsic import Data.Array.Accelerate.LLVM.CodeGen.Module import Data.Array.Accelerate.LLVM.CodeGen.Sugar ( IROpenAcc(..) )-import Data.Array.Accelerate.LLVM.State ( LLVM )+import Data.Array.Accelerate.LLVM.State ( LLVM, getLLVMVer ) import Data.Array.Accelerate.LLVM.Target import Data.Array.Accelerate.Representation.Tag import Data.Array.Accelerate.Representation.Type-import qualified Data.Array.Accelerate.Debug as Debug+import qualified Data.Array.Accelerate.Debug.Internal as Debug import LLVM.AST.Type.Constant import LLVM.AST.Type.Downcast@@ -59,22 +64,26 @@ import LLVM.AST.Type.Operand import LLVM.AST.Type.Representation import LLVM.AST.Type.Terminator-import qualified LLVM.AST as LLVM-import qualified LLVM.AST.Global as LLVM+import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty as LP+import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty.PP as LP+import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty.Triple.Parse as LP import Control.Applicative+import Control.Monad+import Control.Monad.Reader ( ReaderT, MonadReader, runReaderT, asks ) import Control.Monad.State import Data.ByteString.Short ( ShortByteString )+import qualified Data.ByteString.Short.Char8 as SBS8 import Data.Function import Data.HashMap.Strict ( HashMap )-import Data.Map ( Map ) import Data.Sequence ( Seq ) import Data.String+import Data.Text.Lazy.Builder ( Builder )+import Formatting import Prelude-import Text.Printf import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HashMap-import qualified Data.Map as Map+import qualified Data.Map.Strict as Map import qualified Data.Sequence as Seq import qualified Data.ByteString.Short as B @@ -89,59 +98,84 @@ -- data CodeGenState = CodeGenState { blockChain :: Seq Block -- blocks for this function- , symbolTable :: Map Label LLVM.Global -- global (external) function declarations+ , globalvarTable :: HashMap Label LP.Global -- global variable definitions+ , fundeclTable :: HashMap Label LP.Declare -- global (external) function declarations+ , typedefTable :: HashMap Label LP.Type -- global type definitions , metadataTable :: HashMap ShortByteString (Seq [Maybe Metadata]) -- module metadata to be collected , intrinsicTable :: HashMap ShortByteString Label -- standard math intrinsic functions- , next :: {-# UNPACK #-} !Word -- a name supply+ , local :: {-# UNPACK #-} !Word -- a name supply+ , global :: {-# UNPACK #-} !Word -- a name supply for global variables } data Block = Block- { blockLabel :: {-# UNPACK #-} !Label -- block label- , instructions :: Seq (LLVM.Named LLVM.Instruction) -- stack of instructions- , terminator :: LLVM.Terminator -- block terminator+ { blockLabel :: {-# UNPACK #-} !Label -- block label+ , instructions :: Seq LP.Stmt -- stack of instructions+ , terminator :: LP.Stmt -- block terminator } -newtype CodeGen target a = CodeGen { runCodeGen :: StateT CodeGenState (LLVM target) a }- deriving (Functor, Applicative, Monad, MonadState CodeGenState)+-- | Code generation context: read-only additional context of the compilation.+--+-- This contains the LLVM version.+data CodeGenContext = CodeGenContext+ { codegenLLVMversion :: LP.LLVMVer } +newtype CodeGen target a = CodeGen+ { runCodeGen :: ReaderT CodeGenContext (StateT CodeGenState (LLVM target)) a }+ deriving (Functor, Applicative, Monad, MonadReader CodeGenContext, MonadState CodeGenState)+ liftCodeGen :: LLVM arch a -> CodeGen arch a-liftCodeGen = CodeGen . lift+liftCodeGen = CodeGen . lift . lift +getLLVMversion :: CodeGen arch LP.LLVMVer+getLLVMversion = asks codegenLLVMversion + {-# INLINEABLE evalCodeGen #-} evalCodeGen :: forall arch aenv a. (HasCallStack, Target arch, Intrinsic arch) => CodeGen arch (IROpenAcc arch aenv a) -> LLVM arch (Module arch aenv a) evalCodeGen ll = do- (IROpenAcc ks, st) <- runStateT (runCodeGen ll)+ llvmver <- getLLVMVer+ let context = CodeGenContext+ { codegenLLVMversion = llvmver }+ (IROpenAcc ks, st) <- runStateT (runReaderT (runCodeGen ll) context) $ CodeGenState { blockChain = initBlockChain- , symbolTable = Map.empty+ , globalvarTable = HashMap.empty+ , fundeclTable = HashMap.empty+ , typedefTable = HashMap.empty , metadataTable = HashMap.empty , intrinsicTable = intrinsicForTarget @arch- , next = 0+ , local = 0+ , global = 0 } - let (kernels, md) = let (fs, as) = unzip [ (f , (LLVM.name f, a)) | Kernel f a <- ks ]+ let (kernels, md) = let (fs, as) = unzip [ (f , (LP.defName f, a)) | Kernel f a <- ks ] in (fs, Map.fromList as) - definitions = map LLVM.GlobalDefinition (kernels ++ Map.elems (symbolTable st))- ++ createMetadata (metadataTable st)+ createTypedefs = map (\(n,t) -> LP.TypeDecl (labelToPrettyI n) t) . HashMap.toList - name | x:_ <- kernels- , f@LLVM.Function{} <- x- , LLVM.Name s <- LLVM.name f = s- | otherwise = "<undefined>"+ (namedMd, unnamedMd) = createMetadata (metadataTable st) return $ Module { moduleMetadata = md- , unModule = LLVM.Module- { LLVM.moduleName = name- , LLVM.moduleSourceFileName = B.empty- , LLVM.moduleDataLayout = targetDataLayout @arch- , LLVM.moduleTargetTriple = targetTriple @arch- , LLVM.moduleDefinitions = definitions+ , unModule = LP.Module+ { LP.modSourceName = Nothing+ , LP.modDataLayout = [] -- TODO: targetDataLayout @arch; this will be important for PTX+ , LP.modTriple =+ case targetTriple @arch of+ Just s -> LP.parseTriple (SBS8.unpack s)+ Nothing -> error "TODO: module target triple"+ , LP.modTypes = createTypedefs (typedefTable st)+ , LP.modNamedMd = namedMd+ , LP.modUnnamedMd = unnamedMd+ , LP.modComdat = mempty+ , LP.modGlobals = HashMap.elems (globalvarTable st)+ , LP.modDeclares = HashMap.elems (fundeclTable st)+ , LP.modDefines = kernels+ , LP.modInlineAsm = []+ , LP.modAliases = [] } } @@ -189,7 +223,7 @@ let idx = Seq.length (blockChain s) label = let (h,t) = break (== '.') nm in (h ++ shows idx t) next = Block (fromString label) Seq.empty err- err = internalError (printf "block `%s' has no terminator" label)+ err = internalError ("block `" % string % "' has no terminator") label in ( next, s ) @@ -216,18 +250,18 @@ -- body. The block stream is re-initialised, but module-level state such as the -- global symbol table is left intact. ---createBlocks :: HasCallStack => CodeGen arch [LLVM.BasicBlock]+createBlocks :: HasCallStack => CodeGen arch [LP.BasicBlock] createBlocks = state- $ \s -> let s' = s { blockChain = initBlockChain, next = 0 }+ $ \s -> let s' = s { blockChain = initBlockChain, local = 0 } blocks = makeBlock `fmap` blockChain s m = Seq.length (blockChain s) n = F.foldl' (\i b -> i + Seq.length (instructions b)) 0 (blockChain s) in- trace (printf "generated %d instructions in %d blocks" (n+m) m) ( F.toList blocks , s' )+ trace (bformat ("generated " % int % " instructions in " % int % " blocks") (n+m) m) ( F.toList blocks , s' ) where makeBlock Block{..} =- LLVM.BasicBlock (downcast blockLabel) (F.toList instructions) (LLVM.Do terminator)+ LP.BasicBlock (Just (labelToPrettyBL blockLabel)) (F.toList instructions ++ [terminator]) -- Instructions@@ -238,14 +272,19 @@ fresh :: TypeR a -> CodeGen arch (Operands a) fresh TupRunit = return OP_Unit fresh (TupRpair t2 t1) = OP_Pair <$> fresh t2 <*> fresh t1-fresh (TupRsingle t) = ir t . LocalReference (PrimType (ScalarPrimType t)) <$> freshName+fresh (TupRsingle t) = ir t . LocalReference (PrimType (ScalarPrimType t)) <$> freshLocalName --- | Generate a fresh (un)name.+-- | Generate a fresh local (un)name ---freshName :: CodeGen arch (Name a)-freshName = state $ \s@CodeGenState{..} -> ( UnName next, s { next = next + 1 } )+freshLocalName :: CodeGen arch (Name a)+freshLocalName = state $ \s@CodeGenState{..} -> ( UnName local, s { local = local + 1 } ) +-- | Generate a fresh global (un)name+--+freshGlobalName :: CodeGen arch (Name a)+freshGlobalName = state $ \s@CodeGenState{..} -> ( UnName global, s { global = global + 1 } ) + -- | Add an instruction to the state of the currently active block so that it is -- computed, and return the operand (LocalReference) that can be used to later -- refer to it.@@ -262,18 +301,18 @@ return $ LocalReference VoidType (Name B.empty) -- ty -> do- name <- freshName- instr_ $ downcast (name := ins)+ name <- freshLocalName+ instr_ $ LP.Result (nameToPrettyI name) (downcast ins) [] [] return $ LocalReference ty name -- | Execute an unnamed instruction -- do_ :: HasCallStack => Instruction () -> CodeGen arch ()-do_ ins = instr_ $ downcast (Do ins)+do_ ins = instr_ $ LP.Effect (downcast ins) [] [] -- | Add raw assembly instructions to the execution stream ---instr_ :: HasCallStack => LLVM.Named LLVM.Instruction -> CodeGen arch ()+instr_ :: HasCallStack => LP.Stmt -> CodeGen arch () instr_ ins = modify $ \s -> case Seq.viewr (blockChain s) of@@ -335,7 +374,7 @@ phi1 :: HasCallStack => Block -> Name a -> [(Operand a, Block)] -> CodeGen arch (Operand a) phi1 target crit incoming = let cmp = (==) `on` blockLabel- update b = b { instructions = downcast (crit := Phi t [ (p,blockLabel) | (p,Block{..}) <- incoming ]) Seq.<| instructions b }+ update b = b { instructions = LP.Result (nameToPrettyI crit) (downcast $ Phi t [ (p,blockLabel) | (p,Block{..}) <- incoming ]) [] [] Seq.<| instructions b } t = case incoming of [] -> internalError "no incoming values specified" (o,_):_ -> case typeOf o of@@ -357,24 +396,48 @@ state $ \s -> case Seq.viewr (blockChain s) of Seq.EmptyR -> internalError "empty block chain"- bs Seq.:> b -> ( b, s { blockChain = bs Seq.|> b { terminator = downcast term } } )+ bs Seq.:> b -> ( b, s { blockChain = bs Seq.|> b { terminator = LP.Effect (downcast term) [] [] } } ) --- | Add a global declaration to the symbol table+-- | Add a global variable declaration to the module ---declare :: HasCallStack => LLVM.Global -> CodeGen arch ()-declare g =+declareGlobalVar :: HasCallStack => LP.Global -> CodeGen arch ()+declareGlobalVar g = let unique (Just q) | g /= q = internalError "duplicate symbol" | otherwise = Just g unique _ = Just g - name = case LLVM.name g of- LLVM.Name n -> Label n- LLVM.UnName n -> Label (fromString (show n))+ name = case LP.globalSym g of+ LP.Symbol n -> Label (fromString n) in- modify (\s -> s { symbolTable = Map.alter unique name (symbolTable s) })+ modify (\s -> s { globalvarTable = HashMap.alter unique name (globalvarTable s) }) +-- | Add an external function declaration to the module+--+declareExternFunc :: HasCallStack => LP.Declare -> CodeGen arch ()+declareExternFunc g =+ let unique (Just q) | g /= q = internalError "duplicate symbol"+ | otherwise = Just g+ unique _ = Just g++ name = case LP.decName g of+ LP.Symbol n -> Label (fromString n)+ in+ modify (\s -> s { fundeclTable = HashMap.alter unique name (fundeclTable s) })+++-- | Add a global type definition+--+typedef :: HasCallStack => Label -> LP.Type -> CodeGen arch ()+typedef name t =+ let unique (Just s) | t /= s = internalError "duplicate typedef"+ | otherwise = Just t+ unique _ = Just t+ in+ modify (\s -> s { typedefTable = HashMap.alter unique name (typedefTable s) })++ -- | Get name of the corresponding intrinsic function implementing a given C -- function. If there is no mapping, the C function name is used. --@@ -402,24 +465,24 @@ -- represent the metadata node definitions that will be attached to that -- definition. ---createMetadata :: HashMap ShortByteString (Seq [Maybe Metadata]) -> [LLVM.Definition]-createMetadata md = build (HashMap.toList md) (Seq.empty, Seq.empty)+createMetadata :: HashMap ShortByteString (Seq [Maybe Metadata]) -> ([LP.NamedMd], [LP.UnnamedMd])+createMetadata md = go (HashMap.toList md) (Seq.empty, Seq.empty) where- build :: [(ShortByteString, Seq [Maybe Metadata])]- -> (Seq LLVM.Definition, Seq LLVM.Definition) -- accumulator of (names, metadata)- -> [LLVM.Definition]- build [] (k,d) = F.toList (k Seq.>< d)- build (x:xs) (k,d) =+ go :: [(ShortByteString, Seq [Maybe Metadata])]+ -> (Seq LP.NamedMd, Seq LP.UnnamedMd) -- accumulator of (names, metadata)+ -> ([LP.NamedMd], [LP.UnnamedMd])+ go [] (k,d) = (F.toList k, F.toList d)+ go (x:xs) (k,d) = let (k',d') = meta (Seq.length d) x- in build xs (k Seq.|> k', d Seq.>< d')+ in go xs (k Seq.|> k', d Seq.>< d') meta :: Int -- number of metadata node definitions so far -> (ShortByteString, Seq [Maybe Metadata]) -- current assoc of the metadata map- -> (LLVM.Definition, Seq LLVM.Definition)+ -> (LP.NamedMd, Seq LP.UnnamedMd) meta n (key, vals)- = let node i = LLVM.MetadataNodeID (fromIntegral (i+n))- nodes = Seq.mapWithIndex (\i x -> LLVM.MetadataNodeDefinition (node i) (downcast (F.toList x))) vals- name = LLVM.NamedMetadataDefinition key [ node i | i <- [0 .. Seq.length vals - 1] ]+ = let node i = i + n+ nodes = Seq.mapWithIndex (\i x -> LP.UnnamedMd (node i) (LP.ValMdNode (downcast (F.toList x))) False) vals+ name = LP.NamedMd (SBS8.unpack key) [ node i | i <- [0 .. Seq.length vals - 1] ] in (name, nodes) @@ -428,6 +491,6 @@ -- ===== {-# INLINE trace #-}-trace :: String -> a -> a-trace msg = Debug.trace Debug.dump_cc ("llvm: " ++ msg)+trace :: Builder -> a -> a+trace msg = Debug.trace Debug.dump_cc ("llvm: " <> msg)
src/Data/Array/Accelerate/LLVM/CodeGen/Monad.hs-boot view
@@ -11,9 +11,12 @@ module Data.Array.Accelerate.LLVM.CodeGen.Monad ( CodeGen ) where +import Control.Monad.Reader import Control.Monad.State import Data.Array.Accelerate.LLVM.State data CodeGenState-newtype CodeGen target a = CodeGen { runCodeGen :: StateT CodeGenState (LLVM target) a }+data CodeGenContext+newtype CodeGen target a = CodeGen+ { runCodeGen :: ReaderT CodeGenContext (StateT CodeGenState (LLVM target)) a }
src/Data/Array/Accelerate/LLVM/CodeGen/Permute.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}@@ -29,7 +30,7 @@ import Data.Array.Accelerate.AST.Idx import Data.Array.Accelerate.AST.LeftHandSide import Data.Array.Accelerate.AST.Var-import Data.Array.Accelerate.Debug+import Data.Array.Accelerate.Debug.Internal import Data.Array.Accelerate.Error import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Trafo.Substitution@@ -43,7 +44,6 @@ import Data.Array.Accelerate.LLVM.CodeGen.Type import Data.Array.Accelerate.LLVM.Foreign -import LLVM.AST.Type.AddrSpace import LLVM.AST.Type.Instruction import LLVM.AST.Type.Instruction.Atomic import LLVM.AST.Type.Instruction.RMW as RMW
+ src/Data/Array/Accelerate/LLVM/CodeGen/Profile.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.CodeGen.Profile+-- Copyright : [2015..2020] The Accelerate Team+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.CodeGen.Profile (++ zone_begin, zone_begin_alloc,+ zone_end,++) where++import LLVM.AST.Type.Constant+import LLVM.AST.Type.Downcast+import LLVM.AST.Type.Function+import LLVM.AST.Type.GetElementPtr+import LLVM.AST.Type.Global+import LLVM.AST.Type.Name+import LLVM.AST.Type.Operand+import LLVM.AST.Type.Representation+import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty as LP++import Data.Array.Accelerate.LLVM.CodeGen.Base+import Data.Array.Accelerate.LLVM.CodeGen.Constant+import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.LLVM.CodeGen.Monad++import Data.Array.Accelerate.Sugar.Elt+import Data.Array.Accelerate.Debug.Internal ( tracyIsEnabled, SrcLoc, Zone )++import Control.Monad+import Data.Char+++call' :: GlobalFunction args t -> CodeGen arch (Operands t)+call' f = call f [NoUnwind, NoDuplicate]++global_string :: String -> CodeGen arch (Name (Ptr (LLArray Word8)), Word64)+global_string str = do+ let str0 = str ++ "\0"+ l = fromIntegral (length str0)+ --+ nm <- freshGlobalName+ _ <- declareGlobalVar $ LP.Global+ { LP.globalSym = nameToPrettyS nm+ , LP.globalAttrs = LP.GlobalAttrs+ { LP.gaLinkage = Just LP.Private+ , LP.gaVisibility = Nothing+ , LP.gaAddrSpace = LP.defaultAddrSpace+ , LP.gaConstant = True }+ , LP.globalType = LP.Array l (LP.PrimType (LP.Integer 8))+ , LP.globalValue = Just $ LP.ValArray (LP.PrimType (LP.Integer 8)) [ LP.ValInteger (toInteger (ord c)) | c <- str0 ]+ , LP.globalAlign = Nothing+ , LP.globalMetadata = mempty+ }+ return (nm, l)++derefGlobalString :: Word64 -> Name (Ptr (LLArray Word8)) -> Constant (Ptr Word8)+derefGlobalString slen sname =+ -- Global references are _pointers_ to their values. A string is an+ -- [_ x i8], hence the global reference is an [_ x i8]*. The GEP needs+ -- to index the outer pointer (with a 0) and index the array (at index+ -- 0) to address the first i8 in the string; GEP then returns a pointer+ -- to this i8.+ ConstantGetElementPtr $ GEP+ (PrimType (ArrayPrimType slen scalarType))+ (GlobalReference (PrimType (PtrPrimType (ArrayPrimType slen scalarType) defaultAddrSpace)) sname)+ (ScalarConstant scalarType 0 :: Constant Int32)+ (GEPArray (ScalarConstant scalarType 0 :: Constant Int32) (GEPEmpty primType))+++-- struct ___tracy_source_location_data+-- {+-- const char* name;+-- const char* function;+-- const char* file;+-- uint32_t line;+-- uint32_t color;+-- };+--+source_location_data :: String -> String -> String -> Int -> Word32 -> CodeGen arch (Name a)+source_location_data nm fun src line colour = do+ let i8ptr_t = LP.PtrTo (LP.PrimType (LP.Integer 8)) defaultAddrSpace+ i32_t = LP.PrimType (LP.Integer 32)+ _ <- typedef "___tracy_source_location_data" $ LP.Struct [ i8ptr_t, i8ptr_t, i8ptr_t, i32_t, i32_t ]+ (s, sl) <- global_string src+ (f, fl) <- global_string fun+ (n, nl) <- global_string nm+ let+ source = if null src then NullPtrConstant type' else derefGlobalString sl s+ function = if null fun then NullPtrConstant type' else derefGlobalString fl f+ name = if null nm then NullPtrConstant type' else derefGlobalString nl n+ --+ v <- freshGlobalName+ _ <- declareGlobalVar $ LP.Global+ { LP.globalSym = nameToPrettyS v+ , LP.globalAttrs = LP.GlobalAttrs+ { LP.gaLinkage = Just LP.Internal+ , LP.gaVisibility = Nothing+ , LP.gaAddrSpace = LP.defaultAddrSpace+ , LP.gaConstant = True }+ , LP.globalType = LP.Alias (LP.Ident "___tracy_source_location_data")+ , LP.globalValue = Just $+ LP.ValStruct+ [ downcast name+ , downcast function+ , downcast source+ , LP.Typed (LP.PrimType (LP.Integer 32)) (LP.ValInteger (toInteger line))+ , LP.Typed (LP.PrimType (LP.Integer 32)) (LP.ValInteger (toInteger colour))+ ]+ , LP.globalAlign = Just 8+ , LP.globalMetadata = mempty+ }+ return v+++alloc_srcloc_name+ :: Int -- line+ -> String -- source file+ -> String -- function+ -> String -- name+ -> CodeGen arch (Operands SrcLoc)+alloc_srcloc_name l src fun nm+ | not tracyIsEnabled = return (constant (eltR @SrcLoc) 0)+ | otherwise = do+ (s, sl) <- global_string src+ (f, fl) <- global_string fun+ (n, nl) <- global_string nm+ let+ line = ConstantOperand $ ScalarConstant scalarType (fromIntegral l :: Word32)+ source = ConstantOperand $ if null src then NullPtrConstant type' else derefGlobalString sl s+ function = ConstantOperand $ if null fun then NullPtrConstant type' else derefGlobalString fl f+ name = ConstantOperand $ if null nm then NullPtrConstant type' else derefGlobalString nl n+ sourceSz = ConstantOperand $ ScalarConstant scalarType (sl-1) -- null+ functionSz = ConstantOperand $ ScalarConstant scalarType (fl-1) -- null+ nameSz = ConstantOperand $ ScalarConstant scalarType (nl-1) -- null+ --+ call' $ Lam primType line+ $ Lam primType source+ $ Lam primType sourceSz+ $ Lam primType function+ $ Lam primType functionSz+ $ Lam primType name+ $ Lam primType nameSz+ $ Body (type' @SrcLoc) (Just Tail) "___tracy_alloc_srcloc_name"++zone_begin+ :: Int -- line+ -> String -- source file+ -> String -- function+ -> String -- name+ -> Word32 -- colour+ -> CodeGen arch (Operands Zone)+zone_begin line src fun name colour+ | not tracyIsEnabled = return (constant (eltR @SrcLoc) 0)+ | otherwise = do+ srcloc <- source_location_data name fun src line colour+ let srcloc_ty = PtrPrimType (NamedPrimType "___tracy_source_location_data") defaultAddrSpace+ --+ call' $ Lam srcloc_ty (ConstantOperand (GlobalReference (PrimType srcloc_ty) srcloc))+ $ Lam primType (ConstantOperand (ScalarConstant scalarType (1 :: Int32)))+ $ Body (type' @SrcLoc) (Just Tail) "___tracy_emit_zone_begin"++zone_begin_alloc+ :: Int -- line+ -> String -- source file+ -> String -- function+ -> String -- name+ -> Word32 -- colour+ -> CodeGen arch (Operands Zone)+zone_begin_alloc line src fun name colour+ | not tracyIsEnabled = return (constant (eltR @Zone) 0)+ | otherwise = do+ srcloc <- alloc_srcloc_name line src fun name+ zone <- call' $ Lam primType (op primType srcloc)+ $ Lam primType (ConstantOperand (ScalarConstant scalarType (1 :: Int32)))+ $ Body (type' @SrcLoc) (Just Tail) "___tracy_emit_zone_begin_alloc"+ when (colour /= 0) $+ void . call' $ Lam primType (op primType zone)+ $ Lam primType (ConstantOperand (ScalarConstant scalarType colour))+ $ Body VoidType (Just Tail) "___tracy_emit_zone_color"+ return zone++zone_end+ :: Operands Zone+ -> CodeGen arch ()+zone_end zone+ | not tracyIsEnabled = return ()+ | otherwise =+ void . call' $ Lam primType (op primType zone)+ $ Body VoidType (Just Tail) "___tracy_emit_zone_end"+
src/Data/Array/Accelerate/LLVM/CodeGen/Ptr.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE GADTs #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.CodeGen.Ptr@@ -13,7 +14,6 @@ module Data.Array.Accelerate.LLVM.CodeGen.Ptr where -import LLVM.AST.Type.AddrSpace import LLVM.AST.Type.Constant import LLVM.AST.Type.Name import LLVM.AST.Type.Operand@@ -60,5 +60,7 @@ LocalReference t n -> LocalReference (retype t) (rename n) ConstantOperand (GlobalReference t n) -> ConstantOperand (GlobalReference (retype t) (rename n)) ConstantOperand (UndefConstant t) -> ConstantOperand (UndefConstant (retype t))+ ConstantOperand NullPtrConstant{} -> internalError "unexpected null pointer constant" ConstantOperand ScalarConstant{} -> internalError "unexpected scalar constant"+ ConstantOperand _ -> internalError "unexpected constant operand"
src/Data/Array/Accelerate/LLVM/CodeGen/Stencil.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -34,6 +35,7 @@ import qualified Data.Array.Accelerate.LLVM.CodeGen.Arithmetic as A import Control.Applicative+import Data.String import Prelude @@ -270,7 +272,7 @@ nb <- br ifExit setBlock ifExit- crit <- freshName+ crit <- freshLocalName r <- phi1 ifExit crit [(boolean False, eb), (A.unbool nv, nb)] return (OP_Bool r)
src/Data/Array/Accelerate/LLVM/CodeGen/Sugar.hs view
@@ -24,8 +24,8 @@ ) where -import LLVM.AST.Type.AddrSpace import LLVM.AST.Type.Instruction.Volatile+import LLVM.AST.Type.Representation ( AddrSpace ) import Data.Array.Accelerate.Representation.Array
src/Data/Array/Accelerate/LLVM/Compile.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}@@ -51,6 +51,7 @@ import qualified Data.Array.Accelerate.LLVM.AST as AST import Data.IntMap ( IntMap )+import Formatting ( (%) ) import Control.Applicative hiding ( Const ) import Prelude hiding ( map, unzip, zipWith, scanl, scanl1, scanr, scanr1, exp ) import qualified Data.IntMap as IntMap@@ -149,6 +150,7 @@ Acond p t e -> plain =<< liftA3 AST.Acond <$> travE p <*> travA t <*> travA e Apair a1 a2 -> plain =<< liftA2 AST.Apair <$> travA a1 <*> travA a2 Anil -> plain $ pure AST.Anil+ Atrace msg a1 a2 -> plain =<< liftA2 (AST.Atrace msg) <$> travA a1 <*> travA a2 -- Foreign arrays operations Aforeign repr ff afun a -> foreignA repr ff afun a@@ -164,12 +166,16 @@ Map _ f a | Just (t,x) <- unzip f a -> plain $ pure (AST.Unzip t x) - -- Skeleton operations resulting in compiled code+ -- Skeleton operations resulting in compiled code.+ -- Important: AST fragments that accelerate:DAA.Analysis.Hash ignores,+ -- must also be ignored here! Otherwise kernels with different aenvs+ -- get the same hash. These fragments are ignored using ignoreE.+ -- Producers Map tp f a -> build =<< liftA2 (map tp) <$> travF f <*> travA a- Generate r sh f -> build =<< liftA2 (generate r) <$> travE sh <*> travF f- Transform r sh p f a -> build =<< liftA4 (transform r) <$> travE sh <*> travF p <*> travF f <*> travA a- Backpermute shr sh f a -> build =<< liftA3 (backpermute shr) <$> travE sh <*> travF f <*> travA a+ Generate r sh f -> build =<< liftA2 (generate r) <$> ignoreE sh <*> travF f+ Transform r sh p f a -> build =<< liftA4 (transform r) <$> ignoreE sh <*> travF p <*> travF f <*> travA a+ Backpermute shr sh f a -> build =<< liftA3 (backpermute shr) <$> ignoreE sh <*> travF f <*> travA a -- Consumers Fold f z a -> build =<< liftA3 fold <$> travF f <*> travME z <*> travD a@@ -219,7 +225,7 @@ (_, h2) = stencilHalo s2 fusionError :: error- fusionError = internalError $ "unexpected fusible material: " ++ showPreAccOp pacc+ fusionError = internalError ("unexpected fusible material: " % formatPreAccOp) pacc travA :: HasCallStack => DelayedOpenAcc aenv a@@ -265,6 +271,11 @@ travB (Constant c) = return $ pure (Constant c) travB (Function f) = liftA Function <$> travF f + ignoreE :: HasCallStack+ => OpenExp env aenv e+ -> LLVM arch (IntMap (Idx' aenv), OpenExp env aenv e)+ ignoreE exp = return $ pure exp+ build :: (IntMap (Idx' aenv), AST.PreOpenAccSkeleton CompiledOpenAcc arch aenv arrs) -> LLVM arch (CompiledOpenAcc arch aenv arrs) build (aenv, eacc) = do@@ -323,8 +334,7 @@ go (TupRpair v1 v2) = AST.UnzipPair (go v1) (go v2) go (TupRsingle (Var _ ix)) = case lookupVar lhs ix of Right u -> u- Left ix' -> case ix' of {}- -- Left branch is unreachable, as `Idx () y` is an empty type+ Left _ -> internalError "Left branch is unreachable as `Idx () y` is an empty type" lookupVar :: ELeftHandSide x env1 env2 -> Idx env2 y -> Either (Idx env1 y) (AST.UnzipIdx x y) lookupVar (LeftHandSideWildcard _) ix = Left ix@@ -334,7 +344,7 @@ lookupVar (LeftHandSidePair l1 l2) ix = case lookupVar l2 ix of Right u -> Right $ AST.UnzipPrj PairIdxRight u Left ix' -> case lookupVar l1 ix' of- Right u -> Right $ AST.UnzipPrj PairIdxLeft u+ Right u -> Right $ AST.UnzipPrj PairIdxLeft u Left ix'' -> Left ix'' -- Is there a foreign version available for this backend? If so, take
src/Data/Array/Accelerate/LLVM/Compile/Cache.hs view
@@ -20,7 +20,7 @@ import Data.Array.Accelerate.AST import Data.Array.Accelerate.Analysis.Hash-import Data.Array.Accelerate.Debug+import Data.Array.Accelerate.Debug.Internal import Data.Array.Accelerate.Trafo.Delayed import Data.Array.Accelerate.LLVM.State@@ -75,19 +75,20 @@ => UID -> LLVM arch FilePath cacheOfUID uid = do- dbg <- liftIO $ if debuggingIsEnabled then getFlag debug else return False- appdir <- liftIO $ getXdgDirectory XdgCache "accelerate"- template <- targetCacheTemplate+ appdir <- liftIO $ getXdgDirectory XdgCache "accelerate"+ template <- targetCacheTemplate let (base, file) = splitFileName template (name, ext) = splitExtensions file --- cachepath = appdir </> "accelerate-llvm-" ++ showVersion version </> base </> if dbg then "dbg" else "rel"+ tag | tracyIsEnabled = "tracy"+ | debuggingIsEnabled = "dbg"+ | otherwise = "rel"+ cachepath = appdir </> "accelerate-llvm-" ++ showVersion version </> base </> tag cachefile = cachepath </> printf "%s%s" name (show uid) <.> ext -- liftIO $ createDirectoryIfMissing True cachepath return cachefile- -- | Remove the cache directory --
src/Data/Array/Accelerate/LLVM/Embed.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -26,7 +27,7 @@ import LLVM.AST.Type.Name -import Data.Array.Accelerate.AST ( PreOpenAfun(..), ArrayVar, Direction(..), Exp, liftALeftHandSide, liftOpenExp, arrayR )+import Data.Array.Accelerate.AST ( PreOpenAfun(..), ArrayVar, Direction(..), Exp, liftALeftHandSide, liftOpenExp, liftMessage, arraysR, arrayR ) import Data.Array.Accelerate.AST.Idx import Data.Array.Accelerate.AST.Var import Data.Array.Accelerate.Error@@ -43,11 +44,10 @@ import Data.ByteString.Short ( ShortByteString ) import GHC.Ptr ( Ptr(..) )-import Language.Haskell.TH ( Q, TExp )+import Data.Array.Accelerate.TH.Compat ( CodeQ ) import System.IO.Unsafe import qualified Data.ByteString.Short.Internal as BS-import qualified Language.Haskell.TH as TH-import qualified Language.Haskell.TH.Syntax as TH+import qualified Data.Array.Accelerate.TH.Compat as TH #if MIN_VERSION_containers(0,5,9) import qualified Data.IntMap.Internal as IM@@ -67,7 +67,7 @@ embedForTarget :: arch -> ObjectR arch- -> Q (TExp (ExecutableR arch))+ -> CodeQ (ExecutableR arch) -- | Embed the compiled array function into a TemplateHaskell expression,@@ -78,7 +78,7 @@ :: Embed arch => arch -> CompiledAfun arch f- -> Q (TExp (ExecAfun arch f))+ -> CodeQ (ExecAfun arch f) embedAfun = embedOpenAfun {-# INLINEABLE embedOpenAfun #-}@@ -86,7 +86,7 @@ :: (HasCallStack, Embed arch) => arch -> CompiledOpenAfun arch aenv f- -> Q (TExp (ExecOpenAfun arch aenv f))+ -> CodeQ (ExecOpenAfun arch aenv f) embedOpenAfun arch (Alam lhs l) = [|| Alam $$(liftALeftHandSide lhs) $$(embedOpenAfun arch l) ||] embedOpenAfun arch (Abody b) = [|| Abody $$(embedOpenAcc arch b) ||] @@ -95,39 +95,43 @@ :: forall arch aenv arrs. (HasCallStack, Embed arch) => arch -> CompiledOpenAcc arch aenv arrs- -> Q (TExp (ExecOpenAcc arch aenv arrs))+ -> CodeQ (ExecOpenAcc arch aenv arrs) embedOpenAcc arch = liftA where- liftA :: CompiledOpenAcc arch aenv' arrs' -> Q (TExp (ExecOpenAcc arch aenv' arrs'))+ liftA :: CompiledOpenAcc arch aenv' arrs' -> CodeQ (ExecOpenAcc arch aenv' arrs') liftA acc = case acc of PlainAcc repr pacc -> [|| EvalAcc $$(liftArraysR repr) $$(liftPreOpenAccCommand arch pacc) ||] BuildAcc repr aenv obj pacc -> [|| ExecAcc $$(liftArraysR repr) $$(liftGamma aenv) $$(embedForTarget arch obj) $$(liftPreOpenAccSkeleton arch pacc) ||] - liftGamma :: Gamma aenv' -> Q (TExp (Gamma aenv'))-#if MIN_VERSION_containers(0,5,8)+ liftGamma :: Gamma aenv' -> CodeQ (Gamma aenv')+#if MIN_VERSION_containers(0,8,0) liftGamma IM.Nil = [|| IM.Nil ||]+ liftGamma (IM.Bin p l r) = [|| IM.Bin p $$(liftGamma l) $$(liftGamma r) ||]+ liftGamma (IM.Tip k v) = [|| IM.Tip k $$(liftV v) ||]+#elif MIN_VERSION_containers(0,5,8)+ liftGamma IM.Nil = [|| IM.Nil ||] liftGamma (IM.Bin p m l r) = [|| IM.Bin p m $$(liftGamma l) $$(liftGamma r) ||] liftGamma (IM.Tip k v) = [|| IM.Tip k $$(liftV v) ||] #else -- O(n) at runtime to reconstruct the set liftGamma aenv = [|| IM.fromAscList $$(liftIM (IM.toAscList aenv)) ||] where- liftIM :: [(Int, (Label, Idx' aenv'))] -> Q (TExp [(Int, (Label, Idx' aenv'))])+ liftIM :: [(Int, (Label, Idx' aenv'))] -> CodeQ [(Int, (Label, Idx' aenv'))] liftIM im = TH.TExp . TH.ListE <$> mapM (\(k,v) -> TH.unTypeQ [|| (k, $$(liftV v)) ||]) im #endif- liftV :: (Label, Idx' aenv') -> Q (TExp (Label, Idx' aenv'))+ liftV :: (Label, Idx' aenv') -> CodeQ (Label, Idx' aenv') liftV (Label n, Idx' repr ix) = [|| (Label $$(liftSBS n), Idx' $$(liftArrayR repr) $$(liftIdx ix)) ||] -- O(n) at runtime to copy from the Addr# to the ByteArray#. We should -- be able to do this without copying, but I don't think the definition of -- ByteArray# is exported (or it is deeply magical).- liftSBS :: ShortByteString -> Q (TExp ShortByteString)+ liftSBS :: ShortByteString -> CodeQ ShortByteString liftSBS bs = let bytes = BS.unpack bs len = BS.length bs in- [|| unsafePerformIO $ BS.createFromPtr $$( TH.unsafeTExpCoerce [| Ptr $(TH.litE (TH.StringPrimL bytes)) |]) len ||]+ [|| unsafePerformIO $ BS.createFromPtr $$( TH.unsafeCodeCoerce [| Ptr $(TH.litE (TH.StringPrimL bytes)) |]) len ||] {-# INLINEABLE liftPreOpenAfun #-}@@ -135,7 +139,7 @@ :: (HasCallStack, Embed arch) => arch -> PreOpenAfun (CompiledOpenAcc arch) aenv t- -> Q (TExp (PreOpenAfun (ExecOpenAcc arch) aenv t))+ -> CodeQ (PreOpenAfun (ExecOpenAcc arch) aenv t) liftPreOpenAfun arch (Alam lhs f) = [|| Alam $$(liftALeftHandSide lhs) $$(liftPreOpenAfun arch f) ||] liftPreOpenAfun arch (Abody b) = [|| Abody $$(embedOpenAcc arch b) ||] @@ -144,16 +148,16 @@ :: forall arch aenv a. (HasCallStack, Embed arch) => arch -> PreOpenAccCommand CompiledOpenAcc arch aenv a- -> Q (TExp (PreOpenAccCommand ExecOpenAcc arch aenv a))+ -> CodeQ (PreOpenAccCommand ExecOpenAcc arch aenv a) liftPreOpenAccCommand arch pacc = let- liftA :: CompiledOpenAcc arch aenv' arrs -> Q (TExp (ExecOpenAcc arch aenv' arrs))+ liftA :: CompiledOpenAcc arch aenv' arrs -> CodeQ (ExecOpenAcc arch aenv' arrs) liftA = embedOpenAcc arch - liftE :: Exp aenv t -> Q (TExp (Exp aenv t))+ liftE :: Exp aenv t -> CodeQ (Exp aenv t) liftE = liftOpenExp - liftAF :: PreOpenAfun (CompiledOpenAcc arch) aenv f -> Q (TExp (PreOpenAfun (ExecOpenAcc arch) aenv f))+ liftAF :: PreOpenAfun (CompiledOpenAcc arch) aenv f -> CodeQ (PreOpenAfun (ExecOpenAcc arch) aenv f) liftAF = liftPreOpenAfun arch in case pacc of@@ -164,6 +168,7 @@ Unit tp e -> [|| Unit $$(liftTypeR tp) $$(liftE e) ||] Apair a1 a2 -> [|| Apair $$(liftA a1) $$(liftA a2) ||] Anil -> [|| Anil ||]+ Atrace msg a1 a2 -> [|| Atrace $$(liftMessage (arraysR a1) msg) $$(liftA a1) $$(liftA a2) ||] Apply repr f a -> [|| Apply $$(liftArraysR repr) $$(liftAF f) $$(liftA a) ||] Acond p t e -> [|| Acond $$(liftE p) $$(liftA t) $$(liftA e) ||] Awhile p f a -> [|| Awhile $$(liftAF p) $$(liftAF f) $$(liftA a) ||]@@ -176,27 +181,27 @@ :: forall arch aenv a. (HasCallStack, Embed arch) => arch -> PreOpenAccSkeleton CompiledOpenAcc arch aenv a- -> Q (TExp (PreOpenAccSkeleton ExecOpenAcc arch aenv a))+ -> CodeQ (PreOpenAccSkeleton ExecOpenAcc arch aenv a) liftPreOpenAccSkeleton arch pacc = let- liftA :: CompiledOpenAcc arch aenv arrs -> Q (TExp (ExecOpenAcc arch aenv arrs))+ liftA :: CompiledOpenAcc arch aenv arrs -> CodeQ (ExecOpenAcc arch aenv arrs) liftA = embedOpenAcc arch - liftD :: DelayedOpenAcc CompiledOpenAcc arch aenv arrs -> Q (TExp (DelayedOpenAcc ExecOpenAcc arch aenv arrs))+ liftD :: DelayedOpenAcc CompiledOpenAcc arch aenv arrs -> CodeQ (DelayedOpenAcc ExecOpenAcc arch aenv arrs) liftD (Delayed repr sh) = [|| Delayed $$(liftArrayR repr) $$(liftE sh) ||] liftD (Manifest repr a) = [|| Manifest $$(liftArraysR repr) $$(liftA a) ||] - liftE :: Exp aenv t -> Q (TExp (Exp aenv t))+ liftE :: Exp aenv t -> CodeQ (Exp aenv t) liftE = liftOpenExp - liftS :: ShapeR sh -> sh -> Q (TExp sh)+ liftS :: ShapeR sh -> sh -> CodeQ sh liftS shr sh = [|| $$(liftElt (shapeType shr) sh) ||] - liftZ :: HasInitialValue -> Q (TExp HasInitialValue)+ liftZ :: HasInitialValue -> CodeQ HasInitialValue liftZ True = [|| True ||] liftZ False = [|| False ||] - liftDir :: Direction -> Q (TExp Direction)+ liftDir :: Direction -> CodeQ Direction liftDir LeftToRight = [|| LeftToRight ||] liftDir RightToLeft = [|| RightToLeft ||] in@@ -213,10 +218,10 @@ Stencil1 tp h a -> [|| Stencil1 $$(liftTypeR tp) $$(liftS (arrayRshape $ arrayR a) h) $$(liftD a) ||] Stencil2 tp h a b -> [|| Stencil2 $$(liftTypeR tp) $$(liftS (arrayRshape $ arrayR a) h) $$(liftD a) $$(liftD b) ||] -liftArrayVar :: ArrayVar aenv v -> Q (TExp (ArrayVar aenv v))+liftArrayVar :: ArrayVar aenv v -> CodeQ (ArrayVar aenv v) liftArrayVar (Var tp v) = [|| Var $$(liftArrayR tp) $$(liftIdx v) ||] -liftUnzipIdx :: UnzipIdx tup e -> Q (TExp (UnzipIdx tup e))+liftUnzipIdx :: UnzipIdx tup e -> CodeQ (UnzipIdx tup e) liftUnzipIdx UnzipId = [|| UnzipId ||] liftUnzipIdx (UnzipPrj PairIdxLeft ix) = [|| UnzipPrj PairIdxLeft $$(liftUnzipIdx ix) ||] liftUnzipIdx (UnzipPrj PairIdxRight ix) = [|| UnzipPrj PairIdxRight $$(liftUnzipIdx ix) ||]
src/Data/Array/Accelerate/LLVM/Execute.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -31,7 +30,7 @@ import Data.Array.Accelerate.AST.Var import Data.Array.Accelerate.Analysis.Match import Data.Array.Accelerate.Array.Data-import Data.Array.Accelerate.Interpreter ( evalPrim, evalPrimConst, evalCoerceScalar )+import Data.Array.Accelerate.Interpreter ( evalPrim, evalPrimConst, evalCoerceScalar, atraceOp ) import Data.Array.Accelerate.Representation.Array import Data.Array.Accelerate.Representation.Elt import Data.Array.Accelerate.Representation.Shape@@ -40,7 +39,7 @@ import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Representation.Vec import Data.Array.Accelerate.Type-import qualified Data.Array.Accelerate.Debug as Debug+import qualified Data.Array.Accelerate.Debug.Internal as Debug import Data.Array.Accelerate.LLVM.AST hiding ( Delayed, Manifest ) import Data.Array.Accelerate.LLVM.Array.Data@@ -51,6 +50,7 @@ import qualified Data.Array.Accelerate.LLVM.AST as AST import Control.Monad+import Control.Monad.Trans ( liftIO ) import System.IO.Unsafe import Prelude hiding ( exp, map, unzip, scanl, scanr, scanl1, scanr1 ) @@ -279,6 +279,12 @@ Anil -> return () Alloc repr sh -> allocate repr sh Apply _ f a -> travAF f =<< spawn (travA a)+ Atrace msg a1 a2 -> do+ let repr = arraysR a1+ a1' <- travA a1 >>= blockArrays repr >>= copyToHost repr+ liftIO $ atraceOp msg a1'+ travA a2+ -- We need quite some type applications in the rules for acond and awhile, and cannot use do notation. -- For some unknown reason, GHC will "simplify" 'FutureArraysR arch a' to 'FutureR arch a', which is not sound. -- It then complains that 'FutureR arch a' isn't assignable to 'FutureArraysR arch a'. By adding explicit
src/Data/Array/Accelerate/LLVM/Execute/Async.hs view
@@ -22,19 +22,21 @@ import Data.Array.Accelerate.Representation.Array import Data.Array.Accelerate.Representation.Type +import Control.Monad.Trans ( MonadIO )+import Data.Kind import GHC.Stack -class Monad (Par arch) => Async arch where+class (Monad (Par arch), MonadIO (Par arch)) => Async arch where -- | The monad parallel computations will be executed in. Presumably a stack -- with the LLVM monad at the base. --- data Par arch :: * -> *+ data Par arch :: Type -> Type -- | Parallel computations can communicate via futures. --- type FutureR arch :: * -> *+ type FutureR arch :: Type -> Type -- | Create a new (empty) promise, to be fulfilled at some future point. --
src/Data/Array/Accelerate/LLVM/Execute/Marshal.hs view
@@ -35,6 +35,7 @@ import Data.Array.Accelerate.LLVM.Execute.Environment import Data.Array.Accelerate.LLVM.Execute.Async +import Data.Bifunctor ( first ) import Data.DList ( DList ) import qualified Data.DList as DL import qualified Data.IntMap as IM@@ -42,49 +43,53 @@ -- Marshalling arguments -- ----------------------class Async arch => Marshal arch where+class (Async arch, Monoid (MarshalCleanup arch)) => Marshal arch where -- | A type family that is used to specify a concrete kernel argument and -- stream/context type for a given backend target. -- type ArgR arch + -- | A cleanup action for a marshalled argument. On PTX this is an IO action;+ -- on Native, no cleanup is necessary.+ type MarshalCleanup arch+ -- | Used to pass shapes as arguments to kernels. marshalInt :: Int -> ArgR arch -- | Pass arrays to kernels- marshalScalarData' :: SingleType e -> ScalarArrayData e -> Par arch (DList (ArgR arch))+ marshalScalarData' :: SingleType e -> ScalarArrayData e -> Par arch (DList (ArgR arch), MarshalCleanup arch) -- | Convert function arguments into stream a form suitable for function calls -- The functions ending in a prime return a DList, other functions return lists. ---marshalArrays :: forall arch arrs. Marshal arch => ArraysR arrs -> arrs -> Par arch [ArgR arch]-marshalArrays repr arrs = DL.toList <$> marshalArrays' @arch repr arrs+marshalArrays :: forall arch arrs. Marshal arch => ArraysR arrs -> arrs -> Par arch ([ArgR arch], MarshalCleanup arch)+marshalArrays repr arrs = first DL.toList <$> marshalArrays' @arch repr arrs -marshalArrays' :: forall arch arrs. Marshal arch => ArraysR arrs -> arrs -> Par arch (DList (ArgR arch))+marshalArrays' :: forall arch arrs. Marshal arch => ArraysR arrs -> arrs -> Par arch (DList (ArgR arch), MarshalCleanup arch) marshalArrays' = marshalTupR' @arch (marshalArray' @arch) -marshalArray' :: forall arch a. Marshal arch => ArrayR a -> a -> Par arch (DList (ArgR arch))+marshalArray' :: forall arch a. Marshal arch => ArrayR a -> a -> Par arch (DList (ArgR arch), MarshalCleanup arch) marshalArray' (ArrayR shr tp) (Array sh a) = do- arg1 <- marshalArrayData' @arch tp a+ (arg1, c1) <- marshalArrayData' @arch tp a let arg2 = marshalShape' @arch shr sh- return $ arg1 `DL.append` arg2+ return (arg1 `DL.append` arg2, c1) -marshalArrayData' :: forall arch t. Marshal arch => TypeR t -> ArrayData t -> Par arch (DList (ArgR arch))-marshalArrayData' TupRunit () = return DL.empty+marshalArrayData' :: forall arch t. Marshal arch => TypeR t -> ArrayData t -> Par arch (DList (ArgR arch), MarshalCleanup arch)+marshalArrayData' TupRunit () = return (DL.empty, mempty) marshalArrayData' (TupRpair t1 t2) (a1, a2) = do- l1 <- marshalArrayData' t1 a1- l2 <- marshalArrayData' t2 a2- return $ l1 `DL.append` l2+ (l1, c1) <- marshalArrayData' t1 a1+ (l2, c2) <- marshalArrayData' t2 a2+ return (l1 `DL.append` l2, c1 <> c2) marshalArrayData' (TupRsingle t) ad | ScalarArrayDict _ s <- scalarArrayDict t = marshalScalarData' @arch s ad -marshalEnv :: forall arch aenv. Marshal arch => Gamma aenv -> ValR arch aenv -> Par arch [ArgR arch]-marshalEnv g a = DL.toList <$> marshalEnv' g a+marshalEnv :: forall arch aenv. Marshal arch => Gamma aenv -> ValR arch aenv -> Par arch ([ArgR arch], MarshalCleanup arch)+marshalEnv g a = first DL.toList <$> marshalEnv' g a -marshalEnv' :: forall arch aenv. Marshal arch => Gamma aenv -> ValR arch aenv -> Par arch (DList (ArgR arch))+marshalEnv' :: forall arch aenv. Marshal arch => Gamma aenv -> ValR arch aenv -> Par arch (DList (ArgR arch), MarshalCleanup arch) marshalEnv' gamma aenv- = fmap DL.concat+ = fmap mconcat $ mapM (\(_, Idx' repr idx) -> marshalArray' @arch repr =<< get (prj idx aenv)) (IM.elems gamma) marshalShape :: forall arch sh. Marshal arch => ShapeR sh -> sh -> [ArgR arch]@@ -105,22 +110,22 @@ ParamRshape :: ShapeR sh -> ParamR arch sh ParamRargs :: ParamR arch (DList (ArgR arch)) -marshalParam' :: forall arch a. Marshal arch => ParamR arch a -> a -> Par arch (DList (ArgR arch))+marshalParam' :: forall arch a. Marshal arch => ParamR arch a -> a -> Par arch (DList (ArgR arch), MarshalCleanup arch) marshalParam' (ParamRarray repr) a = marshalArray' repr a-marshalParam' (ParamRmaybe _ ) Nothing = return $ DL.empty+marshalParam' (ParamRmaybe _ ) Nothing = return (DL.empty, mempty) marshalParam' (ParamRmaybe repr) (Just a) = marshalParam' repr a marshalParam' (ParamRfuture repr) future = marshalParam' repr =<< get future marshalParam' (ParamRenv gamma) aenv = marshalEnv' gamma aenv-marshalParam' ParamRint x = return $ DL.singleton $ marshalInt @arch x-marshalParam' (ParamRshape shr) sh = return $ marshalShape' @arch shr sh-marshalParam' ParamRargs args = return args+marshalParam' ParamRint x = return (DL.singleton (marshalInt @arch x), mempty)+marshalParam' (ParamRshape shr) sh = return (marshalShape' @arch shr sh, mempty)+marshalParam' ParamRargs args = return (args, mempty) -marshalParams' :: forall arch a. Marshal arch => ParamsR arch a -> a -> Par arch (DList (ArgR arch))+marshalParams' :: forall arch a. Marshal arch => ParamsR arch a -> a -> Par arch (DList (ArgR arch), MarshalCleanup arch) marshalParams' = marshalTupR' @arch (marshalParam' @arch) {-# INLINE marshalTupR' #-}-marshalTupR' :: forall arch s a. Marshal arch => (forall b. s b -> b -> Par arch (DList (ArgR arch))) -> TupR s a -> a -> Par arch (DList (ArgR arch))-marshalTupR' _ TupRunit () = return $ DL.empty+marshalTupR' :: forall arch s a. Marshal arch => (forall b. s b -> b -> Par arch (DList (ArgR arch), MarshalCleanup arch)) -> TupR s a -> a -> Par arch (DList (ArgR arch), MarshalCleanup arch)+marshalTupR' _ TupRunit () = return (DL.empty, mempty) marshalTupR' f (TupRsingle t) x = f t x-marshalTupR' f (TupRpair t1 t2) (x1, x2) = DL.append <$> marshalTupR' @arch f t1 x1 <*> marshalTupR' @arch f t2 x2+marshalTupR' f (TupRpair t1 t2) (x1, x2) = (<>) <$> marshalTupR' @arch f t1 x1 <*> marshalTupR' @arch f t2 x2
src/Data/Array/Accelerate/LLVM/Extra.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.Extra
src/Data/Array/Accelerate/LLVM/Link.hs view
@@ -122,6 +122,7 @@ Awhile p f a -> Awhile <$> travAF p <*> travAF f <*> travA a Acond p t e -> Acond p <$> travA t <*> travA e Apair a1 a2 -> Apair <$> travA a1 <*> travA a2+ Atrace msg a1 a2 -> Atrace msg <$> travA a1 <*> travA a2 Anil -> return Anil Reshape shr s ix -> Reshape shr s <$> pure ix Aforeign s r f a -> Aforeign s r f <$> travA a
src/Data/Array/Accelerate/LLVM/Link/Cache.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.Link.Cache@@ -16,15 +17,15 @@ ) where -import Data.Array.Accelerate.Debug+import Data.Array.Accelerate.Debug.Internal import Data.Array.Accelerate.Lifetime import Data.Array.Accelerate.LLVM.Compile.Cache import Control.Monad import Control.Concurrent.MVar import Data.Map.Strict ( Map )+import Formatting import Prelude hiding ( lookup )-import Text.Printf import qualified Data.Map.Strict as Map @@ -106,7 +107,7 @@ ticket <- newLifetime fun addFinalizer ticket $ let refcount (Entry c f o)- | c <= 1 = trace dump_ld (printf "ld: remove object code %s" (show key)) Nothing+ | c <= 1 = trace dump_ld (bformat ("ld: remove object code " % shown) key) Nothing | otherwise = Just (Entry (c-1) f o) in modifyMVar_ var $ \m -> return $! Map.update refcount key m
src/Data/Array/Accelerate/LLVM/State.hs view
@@ -1,5 +1,7 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.State@@ -14,11 +16,16 @@ module Data.Array.Accelerate.LLVM.State where --- library-import Control.Concurrent ( forkIO, threadDelay )+-- accelerate+import Data.Array.Accelerate.LLVM.Target.ClangInfo++-- llvm-pretty+import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty.PP as LP++-- standard library import Control.Monad.Catch ( MonadCatch, MonadThrow, MonadMask )-import Control.Monad.State ( StateT, MonadState, evalStateT )-import Control.Monad.Trans ( MonadIO )+import Control.Monad.Reader ( ReaderT(..), MonadReader, runReaderT, ask, local )+import Control.Monad.Trans ( MonadIO, lift ) import Prelude @@ -29,10 +36,15 @@ -- for the LLVM execution context as well as the per-execution target specific -- state 'target'. ---newtype LLVM target a = LLVM { runLLVM :: StateT target IO a }- deriving (Functor, Applicative, Monad, MonadIO, MonadState target, MonadThrow, MonadCatch, MonadMask)+newtype LLVM target a = LLVM { runLLVM :: ReaderT LP.LLVMVer (ReaderT target IO) a }+ deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask) --- | Extract the execution state: 'gets llvmTarget'+-- not derived because the LLVMVer reader masks this one+instance MonadReader target (LLVM target) where+ ask = LLVM (lift ask)+ local f (LLVM (ReaderT g)) = LLVM (ReaderT (local f . g))++-- | Extract the execution state: 'asks llvmTarget' -- llvmTarget :: t -> t llvmTarget = id@@ -41,19 +53,33 @@ -- evalLLVM :: t -> LLVM t a -> IO a evalLLVM target acc =- evalStateT (runLLVM acc) target+ case llvmverFromTuple hostLLVMVersion of+ Just version -> runReaderT (runReaderT (runLLVM acc) version) target+ Nothing -> fail "accelerate-llvm: Could not determine LLVM version from Clang output" +getLLVMVer :: LLVM target LP.LLVMVer+getLLVMVer = LLVM ask --- | Make sure the GC knows that we want to keep this thing alive forever.------ We may want to introduce some way to actually shut this down if, for example,--- the object has not been accessed in a while (whatever that means).------ Broken in ghci-7.6.1 Mac OS X due to bug #7299.----keepAlive :: a -> IO a-keepAlive x = forkIO (caffeine x) >> return x+-- | This is a valid implementation of @withRunInIO@ in+-- unliftio-core:Control.Monad.IO.Unlift(MonadUnliftIO); it's not an instance+-- to avoid a dependency.+unliftIOLLVM :: ((forall a. LLVM target a -> IO a) -> IO b) -> LLVM target b+unliftIOLLVM f = LLVM (ReaderT (\llvmver -> ReaderT (\target -> f (run llvmver target)))) where- caffeine hit = do threadDelay (5 * 1000 * 1000) -- microseconds = 5 seconds- caffeine hit+ run :: LP.LLVMVer -> target -> LLVM target a -> IO a+ run llvmver target (LLVM m) = runReaderT (runReaderT m llvmver) target+++-- -- | Make sure the GC knows that we want to keep this thing alive forever.+-- --+-- -- We may want to introduce some way to actually shut this down if, for example,+-- -- the object has not been accessed in a while (whatever that means).+-- --+-- -- Broken in ghci-7.6.1 Mac OS X due to bug #7299.+-- --+-- keepAlive :: a -> IO a+-- keepAlive x = forkIO (caffeine x) >> return x+-- where+-- caffeine hit = do threadDelay (5 * 1000 * 1000) -- microseconds = 5 seconds+-- caffeine hit
src/Data/Array/Accelerate/LLVM/Target.hs view
@@ -13,7 +13,7 @@ module Data.Array.Accelerate.LLVM.Target where -import LLVM.AST.DataLayout ( DataLayout )+import Data.Array.Accelerate.LLVM.Internal.LLVMPretty ( DataLayout ) import Data.ByteString.Short ( ShortByteString )
+ src/Data/Array/Accelerate/LLVM/Target/ClangInfo.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_HADDOCK hide #-}+module Data.Array.Accelerate.LLVM.Target.ClangInfo where++import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty.PP as LP++-- standard library+import qualified Control.Exception as E+import Data.ByteString ( ByteString )+import qualified Data.ByteString.Char8 as BS8+import Data.ByteString.Short ( ShortByteString )+import qualified Data.ByteString.Short.Char8 as SBS8+import Data.Char ( isDigit, isSpace )+import Data.List ( tails, sortBy )+import Data.List.NonEmpty ( NonEmpty )+import qualified Data.List.NonEmpty as NE+import Data.Maybe ( fromMaybe, catMaybes, isJust )+import Data.Ord ( comparing, Down(..) )+import System.Directory ( executable, getPermissions, listDirectory )+import System.Environment ( lookupEnv )+import qualified System.Info as Info+import System.IO ( hPutStrLn, stderr )+import System.IO.Unsafe+import System.Process+++-- | String that describes the native target+--+nativeTargetTriple :: ShortByteString+nativeTargetTriple =+ SBS8.pack $+ fromMaybe (error $ "Could not extract native target triple from `clang -###` output: <" ++ clangMachineVersionOutput ++ ">")+ (getLinePrefixedBy "Target: " clangMachineVersionOutput)++-- | String that describes the host CPU+--+nativeCPUName :: ByteString+nativeCPUName =+ case catMaybes (map tryFromLine (lines clangMachineVersionOutput)) of+ cpu : _ -> BS8.pack cpu+ _ -> error $ "Could not extract target CPU from `clang -###` output: <" ++ clangMachineVersionOutput ++ ">"+ where+ tryFromLine :: String -> Maybe String+ tryFromLine line =+ case map snd+ . filter ((== "\"-target-cpu\" ") . fst)+ . map (splitAt 14)+ $ tails line of+ ('"' : rest) : _+ | (cpu, '"' : _) <- break (== '"') rest+ -> Just cpu+ _ -> Nothing+++-- | Returns list of version components: '12.3' becomes [12, 3].+hostLLVMVersion :: NonEmpty Int+hostLLVMVersion =+ fmap read . splitOn '.' $+ let firstLine = takeWhile (/= '\n') $+ dropWhile isSpace clangMachineVersionOutput+ in case catMaybes (map (`startsWith` "clang version") (tails firstLine)) of+ rest : _ ->+ -- "Ubuntu clang version 14.0.0-1ubuntu1.1" <- we care about the "14.0.0" part only+ takeWhile (\c -> not (isSpace c) && c /= '-')+ $ dropWhile isSpace+ $ rest+ [] -> error $ "Could not extract clang version from `clang -###` output: <" ++ clangMachineVersionOutput ++ ">"+ where+ splitOn :: Eq a => a -> [a] -> NonEmpty [a]+ splitOn _ [] = [] NE.:| []+ splitOn sep (c:cs)+ | c == sep = [] NE.<| splitOn sep cs+ | otherwise = let hd NE.:| tl = splitOn sep cs+ in (c : hd) NE.:| tl++ startsWith :: Eq a => [a] -> [a] -> Maybe [a]+ long `startsWith` short =+ let (pre, post) = splitAt (length short) long+ in if pre == short then Just post else Nothing++llvmverFromTuple :: NonEmpty Int -> Maybe LP.LLVMVer+llvmverFromTuple (3 NE.:| 5 : _) = Just LP.llvmV3_5+llvmverFromTuple (3 NE.:| 6 : _) = Just LP.llvmV3_6+llvmverFromTuple (3 NE.:| 7 : _) = Just LP.llvmV3_7+llvmverFromTuple (3 NE.:| 8 : _) = Just LP.llvmV3_8+llvmverFromTuple (n NE.:| _)+ | n >= 4+ -- Don't compare against the "latest" here, because in practice, LLVM textual+ -- IR is fairly forward-compatible.+ -- , n <= P.llvmVlatest+ = Just n+llvmverFromTuple _ = Nothing++-- | This is a string that contains some debug metadata from clang (clang+-- version, target triple, etc.) as well as the inferred command-line+-- invocation for a simple operation (preprocessor mode). This list of+-- arguments happens to include the CPU name.+--+-- Yes, this does include the requisite information in the requisite format for+-- clang versions (tested) 7, 8, 9, 11, 12, 15, 18 and 19. Probably more.+{-# NOINLINE clangMachineVersionOutput #-}+clangMachineVersionOutput :: String+clangMachineVersionOutput =+ unsafePerformIO $ do+ mstderrOutput <- E.try @IOError $ do+ -- The -w flag is to suppress warnings.+ -- The -march is for x86, and -mcpu is for ARM. Handling of these flags+ -- is backend-dependent in clang and gcc and weirdly idiosyncratic; clang+ -- barely documents this if at all, but forum posts imply that it tries+ -- to match gcc's behaviour. Fortunately, it seems that clang still+ -- prints all we need even if the incompatible flag is present, so we+ -- just pass both.+ (_ec, _out, err) <- readProcessWithExitCode clangExePath ["-E", "-", "-march=native", "-mcpu=native", "-w", "-###"] ""+ return err+ case mstderrOutput of+ Left _ -> do+ let overridden = isJust clangExePathEnvironment+ let msg1 =+ "[accelerate-llvm] The Accelerate LLVM backend requires Clang to be installed. " +++ "Furthermore, accelerate-llvm-ptx, if you use it, requires clang version >= 16. " +++ "(Tried to run: '" ++ clangExePath ++ "'."+ msg2 | overridden = ""+ | otherwise =+ " To override this choice, set the " +++ "ACCELERATE_LLVM_CLANG_PATH environment variable to point to the desired " +++ "clang executable."+ msg3 = ")"+ hPutStrLn stderr $ msg1 ++ msg2 ++ msg3+ -- not an IOError because we're in unsafePerformIO+ errorWithoutStackTrace $+ "accelerate-llvm: Clang not found: " ++ clangExePath +++ (if overridden then "" else " (set ACCELERATE_LLVM_CLANG_PATH to override)")+ Right out -> return out++clangExePath :: FilePath+clangExePath+ | Just path <- clangExePathEnvironment = path+ -- For some reason, Windows is always "mingw32", even if it's actually 64-bit, or whatever.+ | Info.os == "mingw32" = clangExePathWindows+ | otherwise = "clang" -- on unix, don't try fancy logic++{-# NOINLINE clangExePathWindows #-}+clangExePathWindows :: FilePath+clangExePathWindows = unsafePerformIO $ do+ let attempts :: [IO (Maybe a)] -> IO (Maybe a)+ attempts [] = return Nothing+ attempts (act:acts) = act >>= maybe (attempts acts) (return . Just)++ -- Tries "$base\LLVM{,-[0-9]+}\bin\clang.exe"+ let tryLLVMdir base = do+ listing <- E.catch @E.IOException+ (listDirectory base)+ (\_ -> return [])+ let llvmdirs = filter (\s -> take 4 s == "LLVM") listing+ let plain = filter (== "LLVM") llvmdirs+ let versions = [(s, read (drop 5 s) :: Int)+ | s <- llvmdirs+ , take 5 s == "LLVM-"+ , length s > 5+ , all isDigit (drop 5 s)]+ -- Prefer a plain "LLVM" directory; if there are only versioned ones,+ -- prefer the highest-versioned.+ attempts+ [do isExe <- E.catch @E.IOException+ (executable <$> getPermissions exe)+ (\_ -> return False)+ return $ if isExe then Just exe else Nothing+ | name <- plain ++ map fst (sortBy (comparing (Down . snd)) versions)+ , let exe = base ++ "\\" ++ name ++ "\\bin\\clang.exe"]++ -- TODO: any more places to look?+ mpath <- attempts+ [tryLLVMdir "C:\\Program Files"+ ,tryLLVMdir "C:\\"]+ case mpath of+ Just path -> return path+ Nothing -> return "clang" -- fall back to the system path++{-# NOINLINE clangExePathEnvironment #-}+clangExePathEnvironment :: Maybe FilePath+clangExePathEnvironment = unsafePerformIO $ lookupEnv "ACCELERATE_LLVM_CLANG_PATH"++-- | Returns trimmed right-hand side+getLinePrefixedBy :: String -> String -> Maybe String+getLinePrefixedBy prefix str =+ case map snd+ . filter ((== prefix) . fst)+ . map (splitAt (length prefix))+ $ lines str of+ rhs : _ -> Just (trim rhs)+ _ -> Nothing+ where+ trim = reverse . dropWhile (== '\n') . reverse
+ src/Data/Array/Accelerate/TH/Compat.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.TH.Compat+-- Copyright : [2019..2021] The Accelerate Team+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.TH.Compat (++ module Language.Haskell.TH,+#if! MIN_VERSION_template_haskell(2,17,0)+ module Data.Array.Accelerate.TH.Compat,+#endif++) where++import Language.Haskell.TH++#if !MIN_VERSION_template_haskell(2,17,0)+import Language.Haskell.TH.Syntax ( unTypeQ, unsafeTExpCoerce )+#if MIN_VERSION_template_haskell(2,16,0)+import GHC.Exts ( RuntimeRep, TYPE )+#endif+#endif+++#if !MIN_VERSION_template_haskell(2,17,0)+#if MIN_VERSION_template_haskell(2,16,0)+type Code m (a :: TYPE (r :: RuntimeRep)) = m (TExp a)+type CodeQ (a :: TYPE (r :: RuntimeRep)) = Code Q a++unsafeCodeCoerce :: forall (r :: RuntimeRep) (a :: TYPE r). Q Exp -> CodeQ a+unsafeCodeCoerce = unsafeTExpCoerce++unTypeCode :: forall (r :: RuntimeRep) (a :: TYPE r). CodeQ a -> Q Exp+unTypeCode = unTypeQ++bindCode :: forall m a (r :: RuntimeRep) (b :: TYPE r). Monad m => m a -> (a -> Code m b) -> Code m b+bindCode = (>>=)++#else+type Code m a = m (TExp a)+type CodeQ a = Code Q a++unsafeCodeCoerce :: Q Exp -> Q (TExp a)+unsafeCodeCoerce = unsafeTExpCoerce++unTypeCode :: CodeQ a -> Q Exp+unTypeCode = unTypeQ++bindCode :: Monad m => m a -> (a -> Code m b) -> Code m b+bindCode = (>>=)+#endif+#endif+
src/Data/ByteString/Short/Char8.hs view
@@ -22,7 +22,7 @@ import Prelude as P hiding ( takeWhile ) import qualified Data.ByteString.Internal as BI import qualified Data.ByteString.Short as BS-import qualified Data.ByteString.Short.Extra as BS+import qualified Data.ByteString.Short.Extra as BE -- | /O(n)/ Convert a 'ShortByteString' into a list.@@ -42,5 +42,5 @@ -- {-# INLINEABLE takeWhile #-} takeWhile :: (Char -> Bool) -> ShortByteString -> ShortByteString-takeWhile f = BS.takeWhile (f . BI.w2c)+takeWhile f = BE.takeWhile (f . BI.w2c)
src/Data/ByteString/Short/Extra.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UnboxedTuples #-}@@ -22,22 +23,34 @@ ) where -import Data.ByteString.Short ( ShortByteString )+import Data.ByteString.Short import qualified Data.ByteString.Short as BS import qualified Data.ByteString.Short.Internal as BI -import Language.Haskell.TH ( Q, TExp )-import qualified Language.Haskell.TH as TH-import qualified Language.Haskell.TH.Syntax as TH+import Data.Array.Accelerate.TH.Compat ( CodeQ )+import qualified Data.Array.Accelerate.TH.Compat as TH import System.IO.Unsafe import Prelude hiding ( take, takeWhile ) +#if !MIN_VERSION_bytestring(0,11,3) import GHC.ST-import GHC.Exts import GHC.Word+#endif+import GHC.Exts +-- | Lift a ShortByteString into a Template Haskell splice+--+liftSBS :: ShortByteString -> CodeQ ShortByteString+liftSBS bs =+ let bytes = BS.unpack bs+ len = BS.length bs+ in+ [|| unsafePerformIO $ BI.createFromPtr $$( TH.unsafeCodeCoerce [| Ptr $(TH.litE (TH.StringPrimL bytes)) |]) len ||]+++#if !MIN_VERSION_bytestring(0,11,3) -- | /O(n)/ @'take' n@ applied to the ShortByteString @xs@, returns the prefix -- of @xs@ of length @n@ as a new ShortByteString, or @xs@ itself if -- @n > 'length' xs@@@ -75,15 +88,6 @@ | otherwise = go (i+1) --- | Lift a ShortByteString into a Template Haskell splice----liftSBS :: ShortByteString -> Q (TExp ShortByteString)-liftSBS bs =- let bytes = BS.unpack bs- len = BS.length bs- in- [|| unsafePerformIO $ BI.createFromPtr $$( TH.unsafeTExpCoerce [| Ptr $(TH.litE (TH.StringPrimL bytes)) |]) len ||]- ------------------------------------------------------------------------ -- Internal utils @@ -117,4 +121,5 @@ copyByteArray (BA# src#) (I# src_off#) (MBA# dst#) (I# dst_off#) (I# len#) = ST $ \s -> case copyByteArray# src# src_off# dst# dst_off# len# s of s' -> (# s', () #)+#endif
− src/LLVM/AST/Type/AddrSpace.hs
@@ -1,29 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}--- |--- Module : LLVM.AST.Type.AddrSpace--- Copyright : [2016..2020] The Accelerate Team--- License : BSD3------ Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>--- Stability : experimental--- Portability : non-portable (GHC extensions)------ Pointers exist in a particular address space-----module LLVM.AST.Type.AddrSpace (-- AddrSpace(..),- defaultAddrSpace,--) where--import LLVM.AST.AddrSpace----- | The default address space is number zero. The semantics of non-zero address--- spaces are target dependent.----defaultAddrSpace :: AddrSpace-defaultAddrSpace = AddrSpace 0-
src/LLVM/AST/Type/Constant.hs view
@@ -19,12 +19,11 @@ where import LLVM.AST.Type.Downcast+import LLVM.AST.Type.GetElementPtr import LLVM.AST.Type.Name import LLVM.AST.Type.Representation -import qualified LLVM.AST.Constant as LLVM-import qualified LLVM.AST.Float as LLVM-import qualified LLVM.AST.Type as LLVM+import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty as LLVM import Data.Constraint import Data.Primitive.ByteArray@@ -53,44 +52,55 @@ UndefConstant :: Type a -> Constant a + NullPtrConstant :: Type (Ptr a)+ -> Constant (Ptr a)+ GlobalReference :: Type a -> Name a -> Constant a + ConstantGetElementPtr :: GetElementPtr Constant (Ptr a) (Ptr b)+ -> Constant (Ptr b) --- | Convert to llvm-hs++-- | Convert to llvm-pretty ---instance Downcast (Constant a) LLVM.Constant where+instance Downcast (Constant a) (LLVM.Typed LLVM.Value) where downcast = \case- UndefConstant t -> LLVM.Undef (downcast t)- GlobalReference t n -> LLVM.GlobalReference (downcast t) (downcast n)- BooleanConstant x -> LLVM.Int 1 (toInteger (fromEnum x))- ScalarConstant t x -> scalar t x+ UndefConstant t -> LLVM.Typed (downcast t) LLVM.ValUndef+ GlobalReference t n -> LLVM.Typed (downcast t) (LLVM.ValSymbol (nameToPrettyS n))+ instr@(ConstantGetElementPtr (GEP t n i1 path)) ->+ LLVM.Typed (downcast (typeOf instr)) (LLVM.ValConstExpr (LLVM.ConstGEP inbounds Nothing (downcast t) (downcast n) (downcast i1 : downcast path)))+ BooleanConstant x -> LLVM.Typed (LLVM.PrimType (LLVM.Integer 1)) (LLVM.ValInteger (toInteger (fromEnum x)))+ NullPtrConstant t -> LLVM.Typed (downcast t) LLVM.ValNull+ ScalarConstant t x -> scalar t x where- scalar :: ScalarType s -> s -> LLVM.Constant+ scalar :: ScalarType s -> s -> LLVM.Typed LLVM.Value scalar (SingleScalarType s) = single s scalar (VectorScalarType s) = vector s - single :: SingleType s -> s -> LLVM.Constant+ single :: SingleType s -> s -> LLVM.Typed LLVM.Value single (NumSingleType s) = num s - vector :: VectorType s -> s -> LLVM.Constant- vector (VectorType _ s) (Vec ba#)- = LLVM.Vector- $ map (single s)+ vector :: VectorType s -> s -> LLVM.Typed LLVM.Value+ vector (VectorType n s) (Vec ba#)+ = LLVM.Typed (LLVM.Vector (fromIntegral n) (downcast s))+ $ LLVM.ValVector (downcast s)+ $ map (LLVM.typedValue . single s) $ singlePrim s `withDict` foldrByteArray (:) [] (ByteArray ba#) - num :: NumType s -> s -> LLVM.Constant+ num :: NumType s -> s -> LLVM.Typed LLVM.Value num (IntegralNumType s) v | IntegralDict <- integralDict s- = LLVM.Int (LLVM.typeBits (downcast s)) (fromIntegral v)+ = LLVM.Typed (downcast s) (LLVM.ValInteger (fromIntegral v)) num (FloatingNumType s) v- = LLVM.Float- $ case s of- TypeFloat -> LLVM.Single v- TypeDouble -> LLVM.Double v- TypeHalf | Half (CUShort u) <- v -> LLVM.Half u+ = case s of+ TypeFloat -> LLVM.Typed (LLVM.PrimType (LLVM.FloatType LLVM.Float)) (LLVM.ValFloat v)+ TypeDouble -> LLVM.Typed (LLVM.PrimType (LLVM.FloatType LLVM.Double)) (LLVM.ValDouble v)+ TypeHalf | Half (CUShort _u) <- v ->+ -- LLVM.Typed (LLVM.PrimType (LLVM.FloatType LLVM.Half)) (_ _u)+ error "TODO: Half floats unsupported by llvm-pretty" singlePrim :: SingleType s -> Dict (Prim s) singlePrim (NumSingleType s) = numPrim s@@ -116,9 +126,13 @@ floatingPrim TypeFloat = Dict floatingPrim TypeDouble = Dict -instance TypeOf Constant where- typeOf (BooleanConstant _) = type'- typeOf (ScalarConstant t _) = PrimType (ScalarPrimType t)- typeOf (UndefConstant t) = t- typeOf (GlobalReference t _) = t+ inbounds :: [LLVM.GEPAttr]+ inbounds = [LLVM.GEP_Inbounds] +instance TypeOf Constant where+ typeOf (BooleanConstant _) = type'+ typeOf (ScalarConstant t _) = PrimType (ScalarPrimType t)+ typeOf (UndefConstant t) = t+ typeOf (NullPtrConstant t) = t+ typeOf (GlobalReference t _) = t+ typeOf (ConstantGetElementPtr gep) = typeOf gep
src/LLVM/AST/Type/Downcast.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : LLVM.AST.Type.Downcast@@ -19,7 +21,8 @@ ) where import Data.Array.Accelerate.Type-import qualified LLVM.AST.Type as LLVM+-- import qualified LLVM.AST.Type as LLVM+import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty as LLVM import Data.Bits @@ -58,7 +61,7 @@ downcast (NumSingleType t) = downcast t instance Downcast (VectorType a) LLVM.Type where- downcast (VectorType n t) = LLVM.VectorType (fromIntegral n) (downcast t)+ downcast (VectorType n t) = LLVM.Vector (fromIntegral n) (downcast t) instance Downcast (BoundedType t) LLVM.Type where downcast (IntegralBoundedType t) = downcast t@@ -68,19 +71,19 @@ downcast (FloatingNumType t) = downcast t instance Downcast (IntegralType a) LLVM.Type where- downcast TypeInt = LLVM.IntegerType $( [| fromIntegral (finiteBitSize (undefined :: Int)) |] )- downcast TypeInt8 = LLVM.IntegerType 8- downcast TypeInt16 = LLVM.IntegerType 16- downcast TypeInt32 = LLVM.IntegerType 32- downcast TypeInt64 = LLVM.IntegerType 64- downcast TypeWord = LLVM.IntegerType $( [| fromIntegral (finiteBitSize (undefined :: Word)) |] )- downcast TypeWord8 = LLVM.IntegerType 8- downcast TypeWord16 = LLVM.IntegerType 16- downcast TypeWord32 = LLVM.IntegerType 32- downcast TypeWord64 = LLVM.IntegerType 64+ downcast TypeInt = LLVM.PrimType (LLVM.Integer (fromIntegral (finiteBitSize (undefined :: Int))))+ downcast TypeInt8 = LLVM.PrimType (LLVM.Integer 8)+ downcast TypeInt16 = LLVM.PrimType (LLVM.Integer 16)+ downcast TypeInt32 = LLVM.PrimType (LLVM.Integer 32)+ downcast TypeInt64 = LLVM.PrimType (LLVM.Integer 64)+ downcast TypeWord = LLVM.PrimType (LLVM.Integer (fromIntegral (finiteBitSize (undefined :: Word))))+ downcast TypeWord8 = LLVM.PrimType (LLVM.Integer 8)+ downcast TypeWord16 = LLVM.PrimType (LLVM.Integer 16)+ downcast TypeWord32 = LLVM.PrimType (LLVM.Integer 32)+ downcast TypeWord64 = LLVM.PrimType (LLVM.Integer 64) instance Downcast (FloatingType a) LLVM.Type where- downcast TypeHalf = LLVM.FloatingPointType LLVM.HalfFP- downcast TypeFloat = LLVM.FloatingPointType LLVM.FloatFP- downcast TypeDouble = LLVM.FloatingPointType LLVM.DoubleFP+ downcast TypeHalf = LLVM.PrimType (LLVM.FloatType LLVM.Half)+ downcast TypeFloat = LLVM.PrimType (LLVM.FloatType LLVM.Float)+ downcast TypeDouble = LLVM.PrimType (LLVM.FloatType LLVM.Double)
− src/LLVM/AST/Type/Flags.hs
@@ -1,50 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module : LLVM.AST.Type.Flags--- Copyright : [2015..2020] The Accelerate Team--- License : BSD3------ Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>--- Stability : experimental--- Portability : non-portable (GHC extensions)-----module LLVM.AST.Type.Flags (-- NSW(..), NUW(..), FastMathFlags(..)--) where--import Data.Default.Class-import LLVM.AST.Instruction ( FastMathFlags(..) )----- If the 'NoSignedWrap' or 'NoUnsignedWrap' keywords are present, the result--- value of an operation is a poison value if signed and/or unsigned overflow,--- respectively, occurs.----data NSW = NoSignedWrap | SignedWrap-data NUW = NoUnsignedWrap | UnsignedWrap--instance Default NSW where- def = SignedWrap--instance Default NUW where- def = UnsignedWrap--instance Default FastMathFlags where-#if MIN_VERSION_llvm_hs_pure(6,0,0)- def = FastMathFlags- { allowReassoc = True- , noNaNs = True- , noInfs = True- , noSignedZeros = True- , allowReciprocal = True- , allowContract = True- , approxFunc = True- }-#else- def = UnsafeAlgebra -- allow everything-#endif
src/LLVM/AST/Type/Function.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -22,9 +23,10 @@ import LLVM.AST.Type.Operand import LLVM.AST.Type.Representation -import qualified LLVM.AST.Attribute as LLVM-import qualified LLVM.AST.Global as LLVM-import qualified LLVM.AST.Instruction as LLVM+-- import qualified LLVM.AST.Attribute as LLVM+-- import qualified LLVM.AST.Global as LLVM+-- import qualified LLVM.AST.Instruction as LLVM+import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty as LLVM -- | Attributes for the function call instruction@@ -37,6 +39,7 @@ | AlwaysInline | NoDuplicate | Convergent+ | InaccessibleMemOnly -- | Tail call kind for function call instruction --@@ -64,31 +67,28 @@ Body :: Type r -> Maybe TailCall -> kind -> Function kind '[] r Lam :: PrimType a -> Operand a -> Function kind args t -> Function kind (a ': args) t -data HList (l :: [*]) where- HNil :: HList '[]- HCons :: e -> HList l -> HList (e ': l) --instance Downcast FunctionAttribute LLVM.FunctionAttribute where- downcast NoReturn = LLVM.NoReturn- downcast NoUnwind = LLVM.NoUnwind- downcast ReadOnly = LLVM.ReadOnly- downcast ReadNone = LLVM.ReadNone- downcast AlwaysInline = LLVM.AlwaysInline- downcast NoDuplicate = LLVM.NoDuplicate- downcast Convergent = LLVM.Convergent+instance Downcast FunctionAttribute LLVM.FunAttr where+ downcast NoReturn = LLVM.Noreturn+ downcast NoUnwind = LLVM.Nounwind+ downcast ReadOnly = LLVM.Readonly+ downcast ReadNone = LLVM.Readnone+ downcast AlwaysInline = LLVM.Alwaysinline+ downcast NoDuplicate = LLVM.Noduplicate+ downcast Convergent = LLVM.Convergent+ downcast InaccessibleMemOnly = LLVM.InaccessibleMemOnly -instance Downcast (Parameter a) LLVM.Parameter where- downcast (Parameter t n) = LLVM.Parameter (downcast t) (downcast n) attrs- where- attrs | PtrPrimType{} <- t = [LLVM.NoAlias, LLVM.NoCapture] -- XXX: alignment- | otherwise = []+instance Downcast (Parameter a) (LLVM.Typed LLVM.Ident) where+ -- TODO attributes! llvm-pretty doesn't seem to support them, but we put+ -- [NoAlias, NoCapture] on pointer types.+ -- TODO: Should check if these parameters are necessary (by benchmarking the old backend with llvm-hs), and if so, should send a PR to llvm-pretty+ downcast (Parameter t n) = LLVM.Typed (downcast t) (nameToPrettyI n) -instance Downcast TailCall LLVM.TailCallKind where- downcast Tail = LLVM.Tail- downcast NoTail = LLVM.NoTail- downcast MustTail = LLVM.MustTail+instance Downcast TailCall Bool where+ downcast Tail = True+ downcast NoTail = False+ downcast MustTail = error "TODO MustTail" -instance Downcast GroupID LLVM.GroupID where- downcast (GroupID n) = LLVM.GroupID n+-- instance Downcast GroupID LLVM.GroupID where+-- downcast (GroupID n) = LLVM.GroupID n
+ src/LLVM/AST/Type/GetElementPtr.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# OPTIONS_HADDOCK hide #-}+module LLVM.AST.Type.GetElementPtr where++import LLVM.AST.Type.Downcast+import LLVM.AST.Type.Representation+++-- | A @getelementptr@ instruction. The @op@ parameter is the type of operands+-- (in practice, 'LLVM.AST.Type.Operand.Operand' or+-- 'LLVM.AST.Type.Constant.Constant'). The @ptra@ and @ptrb@ type indices are+-- the input and output /pointer/ type.+--+-- The type of indices is unconstrained, which is more flexible than reality,+-- and the kind of operands must be uniform, which is /less/ flexible than+-- reality. Reality is quite cumbersome:+-- * When indexing into a structure (currently unsupported by this data type),+-- the index type must be @i32@ and its value must be constant.+-- * When indexing into an array, the index type may be any /integral/ type,+-- signed or unsigned, which are then treated as signed integers.+--+-- <https://llvm.org/docs/LangRef.html#getelementptr-instruction>+data GetElementPtr op ptra ptrb where+ GEP :: Type a+ -> op (Ptr a)+ -> op i -- ^ the offset to the initial pointer (counted in pointees, not in bytes)+ -> GEPIndex op a b -- ^ field/index selection path+ -> GetElementPtr op (Ptr a) (Ptr b)++-- | A convenience pattern synonym for the common case of a full path of length 1.+pattern GEP1 :: ScalarType a -> op (Ptr a) -> op i -> GetElementPtr op (Ptr a) (Ptr a)+pattern GEP1 ty ptr ix <- GEP (PrimType (ScalarPrimType ty)) ptr ix (GEPEmpty (ScalarPrimType _))+ where GEP1 ty ptr ix = GEP (PrimType (ScalarPrimType ty)) ptr ix (GEPEmpty (ScalarPrimType ty))++-- | An index sequence that goes from a 'Ptr a' to a 'Ptr b'. Note that this+-- data type is indexed with the base types of the pointers, not the pointer+-- types themselves.+data GEPIndex op a b where+ GEPEmpty :: PrimType b -> GEPIndex op b b+ GEPArray :: op i -> GEPIndex op a b -> GEPIndex op (LLArray a) b+ -- TODO: structure indexing++instance (forall i. Downcast (op i) v) => Downcast (GEPIndex op a b) [v] where+ downcast (GEPEmpty _) = []+ downcast (GEPArray i l) = downcast i : downcast l++gepIndexOutType :: GEPIndex op a b -> PrimType b+gepIndexOutType (GEPEmpty t) = t+gepIndexOutType (GEPArray _ l) = gepIndexOutType l++instance TypeOf op => TypeOf (GetElementPtr op ptra) where+ typeOf (GEP _ p _ path) =+ case typeOf p of+ PrimType (PtrPrimType _ addr) -> PrimType (PtrPrimType (gepIndexOutType path) addr)+ _ -> error "Pointer type is not a pointer type"
src/LLVM/AST/Type/Global.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ParallelListComp #-} {-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-}@@ -22,26 +21,28 @@ import LLVM.AST.Type.Function import LLVM.AST.Type.Name -import qualified LLVM.AST.Global as LLVM-import qualified LLVM.AST.Name as LLVM-import qualified LLVM.AST.Type as LLVM+import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty as LLVM --- | A global function definition.+-- | An external global function definition. -- type GlobalFunction args t = Function Label args t -instance Downcast (GlobalFunction args t) LLVM.Global where- downcast f = LLVM.functionDefaults { LLVM.name = nm- , LLVM.returnType = res- , LLVM.parameters = (params, False)- }+instance Downcast (GlobalFunction args t) LLVM.Declare where+ downcast f = LLVM.Declare+ { LLVM.decLinkage = Just LLVM.External+ , LLVM.decVisibility = Nothing+ , LLVM.decRetType = res+ , LLVM.decName = nm+ , LLVM.decArgs = args+ , LLVM.decVarArgs = False+ , LLVM.decAttrs = []+ , LLVM.decComdat = Nothing } where- trav :: GlobalFunction args t -> ([LLVM.Type], LLVM.Type, LLVM.Name)- trav (Body t _ n) = ([], downcast t, downcast n)+ trav :: GlobalFunction args t -> ([LLVM.Type], LLVM.Type, LLVM.Symbol)+ trav (Body t _ n) = ([], downcast t, labelToPrettyS n) trav (Lam a _ l) = let (as, r, n) = trav l in (downcast a : as, r, n) -- (args, res, nm) = trav f- params = [ LLVM.Parameter t (LLVM.UnName i) [] | t <- args | i <- [0..] ]
src/LLVM/AST/Type/InlineAssembly.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -15,19 +16,29 @@ module LLVM.AST.Type.InlineAssembly ( module LLVM.AST.Type.InlineAssembly,- LLVM.Dialect(..),+ Dialect(..), ) where -import LLVM.AST.Type.Downcast+-- import LLVM.AST.Type.Downcast -import qualified LLVM.AST.Type as LLVM-import qualified LLVM.AST.InlineAssembly as LLVM+-- import qualified LLVM.AST.Type as LLVM+-- import qualified LLVM.AST.InlineAssembly as LLVM import Data.ByteString import Data.ByteString.Short+import Data.Data +-- | the dialect of assembly used in an inline assembly string+-- <http://en.wikipedia.org/wiki/X86_assembly_language#Syntax>+--+-- Copied from llvm-hs-pure.+data Dialect+ = ATTDialect+ | IntelDialect+ deriving (Eq, Read, Show, Typeable, Data)+ -- | The 'call' instruction might be a label or inline assembly -- data InlineAssembly where@@ -35,10 +46,10 @@ -> ShortByteString -- constraints -> Bool -- has side effects? -> Bool -- align stack?- -> LLVM.Dialect+ -> Dialect -> InlineAssembly -instance Downcast (LLVM.Type, InlineAssembly) LLVM.InlineAssembly where- downcast (t, InlineAssembly asm cst s a d) =- LLVM.InlineAssembly t asm cst s a d+-- instance Downcast (LLVM.Type, InlineAssembly) LLVM.InlineAssembly where+-- downcast (t, InlineAssembly asm cst s a d) =+-- LLVM.InlineAssembly t asm cst s a d
src/LLVM/AST/Type/Instruction.hs view
@@ -1,13 +1,11 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_HADDOCK hide #-} -- |@@ -23,9 +21,10 @@ module LLVM.AST.Type.Instruction where -import LLVM.AST.Type.Constant+import LLVM.AST.Type.Constant ( Constant(ScalarConstant) ) import LLVM.AST.Type.Downcast import LLVM.AST.Type.Function+import LLVM.AST.Type.GetElementPtr import LLVM.AST.Type.InlineAssembly import LLVM.AST.Type.Name import LLVM.AST.Type.Operand@@ -34,25 +33,21 @@ import LLVM.AST.Type.Instruction.Atomic ( Atomicity, MemoryOrdering ) import LLVM.AST.Type.Instruction.Compare ( Ordering(..) ) import LLVM.AST.Type.Instruction.RMW ( RMWOperation )-import LLVM.AST.Type.Instruction.Volatile ( Volatility )+import LLVM.AST.Type.Instruction.Volatile ( Volatility(..) ) -import qualified LLVM.AST.Constant as LLVM ( Constant(GlobalReference, Int) )-import qualified LLVM.AST.AddrSpace as LLVM-import qualified LLVM.AST.CallingConvention as LLVM-import qualified LLVM.AST.FloatingPointPredicate as FP-import qualified LLVM.AST.Instruction as LLVM-import qualified LLVM.AST.IntegerPredicate as IP-import qualified LLVM.AST.Operand as LLVM ( Operand(..), CallableOperand )-import qualified LLVM.AST.ParameterAttribute as LLVM ( ParameterAttribute )-import qualified LLVM.AST.Type as LLVM ( Type(..) )+import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty as LP import Data.Array.Accelerate.AST ( PrimBool ) import Data.Array.Accelerate.AST.Idx+import qualified Data.Array.Accelerate.Debug.Internal as Debug import Data.Array.Accelerate.Error import Data.Array.Accelerate.Representation.Type import Data.Primitive.Vec import Prelude hiding ( Ordering(..), quot, rem, div, isNaN, tail )+import Data.Bifunctor ( bimap )+import Data.Maybe ( fromMaybe )+import System.IO.Unsafe ( unsafePerformIO ) -- | Non-terminating instructions@@ -233,9 +228,8 @@ -- <http://llvm.org/docs/LangRef.html#getelementptr-instruction> --- GetElementPtr :: Operand (Ptr a)- -> [Operand i]- -> Instruction (Ptr a)+ GetElementPtr :: GetElementPtr Operand (Ptr a) (Ptr b)+ -> Instruction (Ptr b) -- <http://llvm.org/docs/LangRef.html#i-fence> --@@ -361,7 +355,6 @@ -- <http://llvm.org/docs/LangRef.html#call-instruction> -- Call :: Function (Either InlineAssembly Label) args t- -> [Either GroupID FunctionAttribute] -> Instruction t -- <http://llvm.org/docs/LangRef.html#select-instruction>@@ -385,50 +378,52 @@ Do :: ins () -> Named ins () --- | Convert to llvm-hs+-- | Convert to llvm-pretty ---instance Downcast (Instruction a) LLVM.Instruction where+instance Downcast (Instruction a) LP.Instr where downcast = \case Add t x y -> add t (downcast x) (downcast y) Sub t x y -> sub t (downcast x) (downcast y) Mul t x y -> mul t (downcast x) (downcast y) Quot t x y -> quot t (downcast x) (downcast y) Rem t x y -> rem t (downcast x) (downcast y)- Div _ x y -> LLVM.FDiv fmf (downcast x) (downcast y) md- ShiftL _ x i -> LLVM.Shl nsw nuw (downcast x) (downcast i) md- ShiftRL _ x i -> LLVM.LShr exact (downcast x) (downcast i) md- ShiftRA _ x i -> LLVM.AShr exact (downcast x) (downcast i) md- BAnd _ x y -> LLVM.And (downcast x) (downcast y) md- LAnd x y -> LLVM.And (downcast x) (downcast y) md- BOr _ x y -> LLVM.Or (downcast x) (downcast y) md- LOr x y -> LLVM.Or (downcast x) (downcast y) md- BXor _ x y -> LLVM.Xor (downcast x) (downcast y) md- LNot x -> LLVM.Xor (downcast x) (LLVM.ConstantOperand (LLVM.Int 1 1)) md- InsertElement i v x -> LLVM.InsertElement (downcast v) (downcast x) (constant i) md- ExtractElement i v -> LLVM.ExtractElement (downcast v) (constant i) md+ Div _ x y -> LP.Arith (LP.FDiv fmf) (downcast x) (LP.typedValue (downcast y))+ ShiftL _ x i -> LP.Bit (LP.Shl nsw nuw) (downcast x) (LP.typedValue (downcast i))+ ShiftRL _ x i -> LP.Bit (LP.Lshr exact) (downcast x) (LP.typedValue (downcast i))+ ShiftRA _ x i -> LP.Bit (LP.Ashr exact) (downcast x) (LP.typedValue (downcast i))+ BAnd _ x y -> LP.Bit LP.And (downcast x) (LP.typedValue (downcast y))+ LAnd x y -> LP.Bit LP.And (downcast x) (LP.typedValue (downcast y))+ BOr _ x y -> LP.Bit LP.Or (downcast x) (LP.typedValue (downcast y))+ LOr x y -> LP.Bit LP.Or (downcast x) (LP.typedValue (downcast y))+ BXor _ x y -> LP.Bit LP.Xor (downcast x) (LP.typedValue (downcast y))+ LNot x -> LP.Bit LP.Xor (downcast x) (LP.ValInteger 1)+ InsertElement i v x -> LP.InsertElt (downcast v) (downcast x) (constant i)+ ExtractElement i v -> LP.ExtractElt (downcast v) (constant i) ExtractValue _ i s -> extractStruct i (downcast s)- Load _ v p -> LLVM.Load (downcast v) (downcast p) atomicity alignment md- Store v p x -> LLVM.Store (downcast v) (downcast p) (downcast x) atomicity alignment md- GetElementPtr n i -> LLVM.GetElementPtr inbounds (downcast n) (downcast i) md- Fence a -> LLVM.Fence (downcast a) md- CmpXchg _ v p x y a m -> LLVM.CmpXchg (downcast v) (downcast p) (downcast x) (downcast y) (downcast a) (downcast m) md- AtomicRMW t v f p x a -> LLVM.AtomicRMW (downcast v) (downcast (t,f)) (downcast p) (downcast x) (downcast a) md- Trunc _ t x -> LLVM.Trunc (downcast x) (downcast t) md- IntToBool _ x -> LLVM.Trunc (downcast x) (LLVM.IntegerType 1) md- FTrunc _ t x -> LLVM.FPTrunc (downcast x) (downcast t) md+ Store vol p x -> LP.Store (downcast vol) (downcast x) (downcast p) atomicity alignment+ Load t vol p -> LP.Load (downcast vol) (downcast t) (downcast p) atomicity alignment+ GetElementPtr (GEP t n i1 path) ->+ LP.GEP inbounds (downcast t) (downcast n) (downcast i1 : downcast path)+ Fence a -> LP.Fence (downcast (fst a)) (downcast (snd a))+ -- TODO: this is now a STRONG cmpxchg. Is that what was intended? I think llvm-hs defaulted to strong, but the LLVM source is very obtuse about this.+ CmpXchg _ v p x y a m -> LP.CmpXchg False (downcast v) (downcast p) (downcast x) (downcast y) (downcast (fst a)) (downcast (snd a)) (downcast m)+ AtomicRMW t v f p x a -> LP.AtomicRW (downcast v) (downcast (t,f)) (downcast p) (downcast x) (downcast (fst a)) (downcast (snd a))+ Trunc _ t x -> LP.Conv (LP.Trunc False False) (downcast x) (downcast t)+ IntToBool _ x -> LP.Conv (LP.Trunc False False) (downcast x) (LP.PrimType (LP.Integer 1))+ FTrunc _ t x -> LP.Conv LP.FpTrunc (downcast x) (downcast t) Ext a b x -> ext a b (downcast x)- BoolToInt a x -> LLVM.ZExt (downcast x) (downcast a) md- BoolToFP x a -> LLVM.UIToFP (downcast a) (downcast x) md- FExt _ t x -> LLVM.FPExt (downcast x) (downcast t) md+ BoolToInt a x -> LP.Conv (LP.ZExt False) (downcast x) (downcast a)+ BoolToFP x a -> LP.Conv (LP.UiToFp False) (downcast a) (downcast x)+ FExt _ t x -> LP.Conv LP.FpExt (downcast x) (downcast t) FPToInt _ b x -> float2int b (downcast x) IntToFP a b x -> int2float a b (downcast x)- BitCast t x -> LLVM.BitCast (downcast x) (downcast t) md- PtrCast t x -> LLVM.BitCast (downcast x) (downcast t) md- Phi t e -> LLVM.Phi (downcast t) (downcast e) md- Select _ p x y -> LLVM.Select (downcast p) (downcast x) (downcast y) md+ BitCast t x -> LP.Conv LP.BitCast (downcast x) (downcast t)+ PtrCast t x -> LP.Conv LP.BitCast (downcast x) (downcast t)+ Phi t e -> LP.Phi (fmfFor t) (downcast t) (map (bimap (LP.typedValue . downcast) (LP.Named . labelToPrettyI)) e)+ Select t p x y -> LP.Select (fmfFor t) (downcast p) (downcast x) (LP.typedValue (downcast y)) IsNaN _ x -> isNaN (downcast x) Cmp t p x y -> cmp t p (downcast x) (downcast y)- Call f a -> call f a+ Call f -> call f where nsw :: Bool -- no signed wrap@@ -440,140 +435,141 @@ exact :: Bool -- does not lose any information exact = False - inbounds :: Bool- inbounds = True+ fmf :: [LP.FMF]+ fmf = fastmathFlags - atomicity :: Maybe LLVM.Atomicity- atomicity = Nothing+ inbounds :: [LP.GEPAttr]+ inbounds = [LP.GEP_Inbounds] - alignment :: Word32- alignment = 0+ atomicity :: Maybe LP.AtomicOrdering+ atomicity = Nothing - fmf :: LLVM.FastMathFlags-#if MIN_VERSION_llvm_hs_pure(6,0,0)- fmf = LLVM.FastMathFlags- { LLVM.allowReassoc = True- , LLVM.noNaNs = True- , LLVM.noInfs = True- , LLVM.noSignedZeros = True- , LLVM.allowReciprocal = True- , LLVM.allowContract = True- , LLVM.approxFunc = True- }-#else- fmf = LLVM.UnsafeAlgebra -- allow everything-#endif+ alignment :: Maybe LP.Align+ alignment = Nothing -- was: 0 - md :: LLVM.InstructionMetadata- md = []+ -- fmf :: LLVM.FastMathFlags+ -- fmf = LLVM.FastMathFlags+ -- { LLVM.allowReassoc = True+ -- , LLVM.noNaNs = True+ -- , LLVM.noInfs = True+ -- , LLVM.noSignedZeros = True+ -- , LLVM.allowReciprocal = True+ -- , LLVM.allowContract = True+ -- , LLVM.approxFunc = True+ -- } - constant :: IsScalar a => a -> LLVM.Operand- constant x = downcast (ConstantOperand (ScalarConstant scalarType x))+ constant :: IsScalar a => a -> LP.Value+ constant x = LP.typedValue $ downcast (ConstantOperand (ScalarConstant scalarType x)) - add :: NumType a -> LLVM.Operand -> LLVM.Operand -> LLVM.Instruction- add IntegralNumType{} x y = LLVM.Add nsw nuw x y md- add FloatingNumType{} x y = LLVM.FAdd fmf x y md+ add :: NumType a -> LP.Typed LP.Value -> LP.Typed LP.Value -> LP.Instr+ add IntegralNumType{} x (LP.Typed _ y) = LP.Arith (LP.Add nsw nuw) x y+ add FloatingNumType{} x (LP.Typed _ y) = LP.Arith (LP.FAdd fmf) x y - sub :: NumType a -> LLVM.Operand -> LLVM.Operand -> LLVM.Instruction- sub IntegralNumType{} x y = LLVM.Sub nsw nuw x y md- sub FloatingNumType{} x y = LLVM.FSub fmf x y md+ sub :: NumType a -> LP.Typed LP.Value -> LP.Typed LP.Value -> LP.Instr+ sub IntegralNumType{} x (LP.Typed _ y) = LP.Arith (LP.Sub nsw nuw) x y+ sub FloatingNumType{} x (LP.Typed _ y) = LP.Arith (LP.FSub fmf) x y - mul :: NumType a -> LLVM.Operand -> LLVM.Operand -> LLVM.Instruction- mul IntegralNumType{} x y = LLVM.Mul nsw nuw x y md- mul FloatingNumType{} x y = LLVM.FMul fmf x y md+ mul :: NumType a -> LP.Typed LP.Value -> LP.Typed LP.Value -> LP.Instr+ mul IntegralNumType{} x (LP.Typed _ y) = LP.Arith (LP.Mul nsw nuw) x y+ mul FloatingNumType{} x (LP.Typed _ y) = LP.Arith (LP.FMul fmf) x y - quot :: IntegralType a -> LLVM.Operand -> LLVM.Operand -> LLVM.Instruction- quot t x y- | signed t = LLVM.SDiv exact x y md- | otherwise = LLVM.UDiv exact x y md+ quot :: IntegralType a -> LP.Typed LP.Value -> LP.Typed LP.Value -> LP.Instr+ quot t x (LP.Typed _ y)+ | signed t = LP.Arith (LP.SDiv exact) x y+ | otherwise = LP.Arith (LP.UDiv exact) x y - rem :: IntegralType a -> LLVM.Operand -> LLVM.Operand -> LLVM.Instruction- rem t x y- | signed t = LLVM.SRem x y md- | otherwise = LLVM.URem x y md+ rem :: IntegralType a -> LP.Typed LP.Value -> LP.Typed LP.Value -> LP.Instr+ rem t x (LP.Typed _ y)+ | signed t = LP.Arith LP.SRem x y+ | otherwise = LP.Arith LP.URem x y - extractStruct :: PairIdx s t -> LLVM.Operand -> LLVM.Instruction- extractStruct i s = LLVM.ExtractValue s ix md+ extractStruct :: PairIdx s t -> LP.Typed LP.Value -> LP.Instr+ extractStruct i s = LP.ExtractValue s ix where ix = case i of PairIdxLeft -> [0] PairIdxRight -> [1] - ext :: BoundedType a -> BoundedType b -> LLVM.Operand -> LLVM.Instruction+ ext :: BoundedType a -> BoundedType b -> LP.Typed LP.Value -> LP.Instr ext a (downcast -> b) x- | signed a = LLVM.SExt x b md- | otherwise = LLVM.ZExt x b md+ | signed a = LP.Conv LP.SExt x b+ | otherwise = LP.Conv (LP.ZExt False) x b - float2int :: IntegralType b -> LLVM.Operand -> LLVM.Instruction+ float2int :: IntegralType b -> LP.Typed LP.Value -> LP.Instr float2int t@(downcast -> t') x- | signed t = LLVM.FPToSI x t' md- | otherwise = LLVM.FPToUI x t' md+ | signed t = LP.Conv LP.FpToSi x t'+ | otherwise = LP.Conv LP.FpToUi x t' - int2float :: IntegralType a -> FloatingType b -> LLVM.Operand -> LLVM.Instruction+ int2float :: IntegralType a -> FloatingType b -> LP.Typed LP.Value -> LP.Instr int2float a (downcast -> b) x- | signed a = LLVM.SIToFP x b md- | otherwise = LLVM.UIToFP x b md+ | signed a = LP.Conv LP.SiToFp x b+ | otherwise = LP.Conv (LP.UiToFp False) x b - isNaN :: LLVM.Operand -> LLVM.Instruction- isNaN x = LLVM.FCmp FP.UNO x x md+ isNaN :: LP.Typed LP.Value -> LP.Instr+ isNaN x = LP.FCmp fmf LP.Funo x (LP.typedValue x) - cmp :: SingleType a -> Ordering -> LLVM.Operand -> LLVM.Operand -> LLVM.Instruction- cmp t p x y =+ cmp :: SingleType a -> Ordering -> LP.Typed LP.Value -> LP.Typed LP.Value -> LP.Instr+ cmp t p x (LP.Typed _ y) = case t of- NumSingleType FloatingNumType{} -> LLVM.FCmp (fp p) x y md- _ | signed t -> LLVM.ICmp (si p) x y md- | otherwise -> LLVM.ICmp (ui p) x y md+ NumSingleType FloatingNumType{} -> LP.FCmp fastmathFlags (fp p) x y+ _ | signed t -> LP.ICmp False (si p) x y+ | otherwise -> LP.ICmp False (ui p) x y where- fp :: Ordering -> FP.FloatingPointPredicate- fp EQ = FP.OEQ- fp NE = FP.ONE- fp LT = FP.OLT- fp LE = FP.OLE- fp GT = FP.OGT- fp GE = FP.OGE+ fp :: Ordering -> LP.FCmpOp+ fp EQ = LP.Foeq+ fp NE = LP.Fone+ fp LT = LP.Folt+ fp LE = LP.Fole+ fp GT = LP.Fogt+ fp GE = LP.Foge - si :: Ordering -> IP.IntegerPredicate- si EQ = IP.EQ- si NE = IP.NE- si LT = IP.SLT- si LE = IP.SLE- si GT = IP.SGT- si GE = IP.SGE+ si :: Ordering -> LP.ICmpOp+ si EQ = LP.Ieq+ si NE = LP.Ine+ si LT = LP.Islt+ si LE = LP.Isle+ si GT = LP.Isgt+ si GE = LP.Isge - ui :: Ordering -> IP.IntegerPredicate- ui EQ = IP.EQ- ui NE = IP.NE- ui LT = IP.ULT- ui LE = IP.ULE- ui GT = IP.UGT- ui GE = IP.UGE+ ui :: Ordering -> LP.ICmpOp+ ui EQ = LP.Ieq+ ui NE = LP.Ine+ ui LT = LP.Iult+ ui LE = LP.Iule+ ui GT = LP.Iugt+ ui GE = LP.Iuge - call :: Function (Either InlineAssembly Label) args t -> [Either GroupID FunctionAttribute] -> LLVM.Instruction- call f as = LLVM.Call tail LLVM.C [] target argv (downcast as) md+ call :: Function (Either InlineAssembly Label) args t -> LP.Instr+ call f = LP.Call tail fmFlags fun_ty target argv where trav :: Function (Either InlineAssembly Label) args t- -> ( [LLVM.Type] -- argument types- , [(LLVM.Operand, [LLVM.ParameterAttribute])] -- argument operands- , Maybe LLVM.TailCallKind -- calling kind- , LLVM.Type -- return type- , LLVM.CallableOperand -- function name or inline assembly+ -> ( [LP.Type] -- argument types+ , [LP.Typed LP.Value] -- argument operands+ , Bool -- tail call?+ , LP.Type -- return type+ , [LP.FMF] -- fast-math flags for this return type+ , LP.Value -- target: function name or inline assembly ) trav (Body u k o) = case o of- Left asm -> ([], [], downcast k, downcast u, Left (downcast (LLVM.FunctionType ret argt False, asm)))- Right n -> ([], [], downcast k, downcast u, Right (LLVM.ConstantOperand (LLVM.GlobalReference ptr_fun_ty (downcast n))))+ Left _asm ->+ internalError+ "Inline assembly should not be used as llvm-pretty does not \+ \support it. For a workaround, see the solution for nanosleep \+ \in Data.Array.Accelerate.LLVM.PTX.Compile."+ -- Left asm -> ([], [], downcast k, downcast u, Left (downcast (LLVM.FunctionType ret argt False, asm)))+ Right n -> ([], [], fromMaybe False (downcast k), downcast u, fmfFor u, LP.ValSymbol (labelToPrettyS n)) trav (Lam t x l) =- let (ts, xs, k, r, n) = trav l- in (downcast t : ts, (downcast x, []) : xs, k, r, n)+ let (ts, xs, k, r, fm, n) = trav l+ in (downcast t : ts, downcast x : xs, k, r, fm, n) - (argt, argv, tail, ret, target) = trav f- fun_ty = LLVM.FunctionType ret argt False- ptr_fun_ty = LLVM.PointerType fun_ty (LLVM.AddrSpace 0)+ (argt, argv, tail, ret, fmFlags, target) = trav f+ fun_ty = LP.FunTy ret argt False -instance Downcast (i a) i' => Downcast (Named i a) (LLVM.Named i') where- downcast (x := op) = downcast x LLVM.:= downcast op- downcast (Do op) = LLVM.Do (downcast op)+-- instance Downcast (i a) i' => Downcast (Named i a) (LLVM.Named i') where+-- downcast (x := op) = downcast x LLVM.:= downcast op+-- downcast (Do op) = LLVM.Do (downcast op) instance TypeOf Instruction where@@ -598,9 +594,9 @@ ExtractValue t _ _ -> scalar t Load t _ _ -> scalar t Store{} -> VoidType- GetElementPtr x _ -> typeOf x+ GetElementPtr gep -> typeOf gep Fence{} -> VoidType- CmpXchg t _ _ _ _ _ _ -> PrimType . StructPrimType $ SingleScalarType (NumSingleType (IntegralNumType t)) `pair` scalarType+ CmpXchg t _ _ _ _ _ _ -> PrimType . StructPrimType False $ ScalarPrimType (SingleScalarType (NumSingleType (IntegralNumType t))) `pair` primType AtomicRMW _ _ _ _ x _ -> typeOf x FTrunc _ t _ -> floating t FExt _ t _ -> floating t@@ -617,7 +613,7 @@ IsNaN{} -> type' Phi t _ -> PrimType t Select _ _ x _ -> typeOf x- Call f _ -> fun f+ Call f -> fun f where typeOfVec :: HasCallStack => Operand (Vec n a) -> Type a typeOfVec x@@ -642,7 +638,7 @@ integral :: IntegralType a -> Type a integral = single . NumSingleType . IntegralNumType - pair :: ScalarType a -> ScalarType b -> TypeR (a, b)+ pair :: PrimType a -> PrimType b -> TupR PrimType (a, b) pair a b = TupRsingle a `TupRpair` TupRsingle b bounded :: BoundedType a -> Type a@@ -651,4 +647,43 @@ fun :: Function kind args a -> Type a fun (Lam _ _ l) = fun l fun (Body t _ _) = t+++{-# NOINLINE fmfEnabled #-}+fmfEnabled :: Bool+fmfEnabled = unsafePerformIO $ Debug.getFlag Debug.fast_math++fastmathFlags :: [LP.FMF]+fastmathFlags+ -- We explicitly exclude 'nnan' and 'ninf' from this list, because apparently+ -- we care about NaN and Inf values:+ -- <https://github.com/AccelerateHS/accelerate/issues/407>+ | fmfEnabled = [LP.Fnsz, LP.Farcp, LP.Fcontract, LP.Fafn, LP.Freassoc]+ | otherwise = []++-- | Some LLVM instructions allow fast math flags only if their return type is+-- a "compatible floating-point type". This class returns fast-math flags given+-- such a return type.+class FmfFor s where+ fmfFor :: s a -> [LP.FMF]++instance FmfFor PrimType where+ fmfFor BoolPrimType = []+ fmfFor (ScalarPrimType t) = fmfFor t+ fmfFor PtrPrimType{} = []+ fmfFor (ArrayPrimType _ t) = fmfFor t+ fmfFor StructPrimType{} = [] -- TODO: homogeneous float structs are allowed by LLVM+ fmfFor NamedPrimType{} = []++instance FmfFor ScalarType where+ fmfFor (SingleScalarType st) = fmfFor st+ fmfFor (VectorScalarType (VectorType _ st)) = fmfFor st++instance FmfFor SingleType where+ fmfFor (NumSingleType (IntegralNumType _)) = []+ fmfFor (NumSingleType (FloatingNumType _)) = fastmathFlags++instance FmfFor Type where+ fmfFor VoidType = []+ fmfFor (PrimType t) = fmfFor t
src/LLVM/AST/Type/Instruction/Atomic.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_HADDOCK hide #-} -- |@@ -15,7 +15,7 @@ where import LLVM.AST.Type.Downcast-import qualified LLVM.AST.Instruction as LLVM+import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty as LLVM -- | Atomic instructions take ordering parameters that determine which other@@ -49,21 +49,18 @@ type Atomicity = (Synchronisation, MemoryOrdering) --- | Convert to llvm-hs+-- | Convert to llvm-pretty ---instance Downcast MemoryOrdering LLVM.MemoryOrdering where+instance Downcast MemoryOrdering LLVM.AtomicOrdering where downcast Unordered = LLVM.Unordered downcast Monotonic = LLVM.Monotonic downcast Acquire = LLVM.Acquire downcast Release = LLVM.Release- downcast AcquireRelease = LLVM.AcquireRelease- downcast SequentiallyConsistent = LLVM.SequentiallyConsistent+ downcast AcquireRelease = LLVM.AcqRel+ downcast SequentiallyConsistent = LLVM.SeqCst -instance Downcast Synchronisation LLVM.SynchronizationScope where- downcast SingleThread = LLVM.SingleThread-#if MIN_VERSION_llvm_hs_pure(5,0,0)- downcast CrossThread = LLVM.System-#else- downcast CrossThread = LLVM.CrossThread-#endif+-- llvm-pretty's typing is weak here+instance Downcast Synchronisation (Maybe String) where+ downcast SingleThread = Just "singlethread"+ downcast CrossThread = Nothing -- "system"
src/LLVM/AST/Type/Instruction/RMW.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : LLVM.AST.Type.Instruction.RMW@@ -20,7 +20,7 @@ import LLVM.AST.Type.Downcast import LLVM.AST.Type.Representation -import qualified LLVM.AST.RMWOperation as LLVM+import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty as LLVM -- | Operations for the 'AtomicRMW' instruction.@@ -39,34 +39,32 @@ | Max --- | Convert to llvm-hs+-- | Convert to llvm-pretty ---instance Downcast (NumType a, RMWOperation) LLVM.RMWOperation where+instance Downcast (NumType a, RMWOperation) LLVM.AtomicRWOp where downcast (IntegralNumType t, rmw) = downcast (t,rmw) downcast (FloatingNumType t, rmw) = downcast (t,rmw) -instance Downcast (IntegralType a, RMWOperation) LLVM.RMWOperation where+instance Downcast (IntegralType a, RMWOperation) LLVM.AtomicRWOp where downcast (t, rmw) = case rmw of- Exchange -> LLVM.Xchg- Add -> LLVM.Add- Sub -> LLVM.Sub- And -> LLVM.And- Or -> LLVM.Or- Xor -> LLVM.Xor- Nand -> LLVM.Nand- Min | signed t -> LLVM.Min- | otherwise -> LLVM.UMin- Max | signed t -> LLVM.Max- | otherwise -> LLVM.UMax+ Exchange -> LLVM.AtomicXchg+ Add -> LLVM.AtomicAdd+ Sub -> LLVM.AtomicSub+ And -> LLVM.AtomicAnd+ Or -> LLVM.AtomicOr+ Xor -> LLVM.AtomicXor+ Nand -> LLVM.AtomicNand+ Min | signed t -> LLVM.AtomicMin+ | otherwise -> LLVM.AtomicUMin+ Max | signed t -> LLVM.AtomicMax+ | otherwise -> LLVM.AtomicUMax -instance Downcast (FloatingType a, RMWOperation) LLVM.RMWOperation where+instance Downcast (FloatingType a, RMWOperation) LLVM.AtomicRWOp where downcast (_, rmw) = case rmw of- Exchange -> LLVM.Xchg-#if MIN_VERSION_llvm_hs_pure(10,0,0)- Add -> LLVM.FAdd- Sub -> LLVM.FSub-#endif+ Exchange -> LLVM.AtomicXchg+ Add -> LLVM.AtomicFAdd+ Sub -> LLVM.AtomicFSub _ -> internalError "unsupported operand type to RMWOperation"
src/LLVM/AST/Type/Metadata.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -18,10 +17,10 @@ import LLVM.AST.Type.Downcast -import qualified LLVM.AST.Constant as LLVM-import qualified LLVM.AST.Operand as LLVM+import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty as LLVM import Data.ByteString.Short ( ShortByteString )+import qualified Data.ByteString.Short.Char8 as SBS8 -- | Metadata does not have a type, and is not a value.@@ -30,31 +29,21 @@ -- data MetadataNode = MetadataNode ![Maybe Metadata]- | MetadataNodeReference {-# UNPACK #-} !LLVM.MetadataNodeID+ | MetadataNodeReference {-# UNPACK #-} !Int data Metadata = MetadataStringOperand {-# UNPACK #-} !ShortByteString- | MetadataConstantOperand !LLVM.Constant+ | MetadataConstantOperand !(LLVM.Typed LLVM.Value) | MetadataNodeOperand !MetadataNode -- | Convert to llvm-hs ---instance Downcast Metadata LLVM.Metadata where- downcast (MetadataStringOperand s) = LLVM.MDString s- downcast (MetadataConstantOperand o) = LLVM.MDValue (LLVM.ConstantOperand o)- downcast (MetadataNodeOperand n) = LLVM.MDNode (downcast n)--#if MIN_VERSION_llvm_hs_pure(6,1,0)-instance Downcast MetadataNode (LLVM.MDRef LLVM.MDNode) where- downcast (MetadataNode n) = LLVM.MDInline (downcast n)- downcast (MetadataNodeReference r) = LLVM.MDRef r--instance Downcast [Maybe Metadata] LLVM.MDNode where- downcast = LLVM.MDTuple . map downcast-#else-instance Downcast MetadataNode LLVM.MetadataNode where- downcast (MetadataNode n) = LLVM.MetadataNode (downcast n)- downcast (MetadataNodeReference r) = LLVM.MetadataNodeReference r-#endif+instance Downcast Metadata LLVM.ValMd where+ downcast (MetadataStringOperand s) = LLVM.ValMdString (SBS8.unpack s)+ downcast (MetadataConstantOperand o) = LLVM.ValMdValue o+ downcast (MetadataNodeOperand n) = downcast n +instance Downcast MetadataNode LLVM.ValMd where+ downcast (MetadataNode n) = LLVM.ValMdNode (downcast n)+ downcast (MetadataNodeReference r) = LLVM.ValMdRef r
src/LLVM/AST/Type/Name.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : LLVM.AST.Type.Name@@ -16,15 +18,16 @@ where import Data.ByteString.Short ( ShortByteString )+import qualified Data.ByteString.Short as SBS+import qualified Data.ByteString.Short.Char8 as SBS8 import Data.Data import Data.Semigroup+import Data.Hashable import Data.String import Data.Word import Prelude -import LLVM.AST.Type.Downcast--import qualified LLVM.AST.Name as LLVM+import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty as LLVM -- | Objects of various sorts in LLVM IR are identified by address in the LLVM@@ -83,13 +86,41 @@ instance Monoid Label where mempty = Label mempty +instance Hashable Label where+ hashWithSalt salt (Label sbs) = hashWithSalt salt sbs --- | Convert to llvm-hs+-- | Some names are not external function references but instead references to+-- definitions that we provide inline in the module to be compiled by LLVM. See+-- 'Data.Array.Accelerate.LLVM.CodeGen.Base.call' for more details. This+-- function checks whether the given label is one of those inline-provided+-- functions.+labelIsAccPrelude :: Label -> Bool+labelIsAccPrelude (Label x) = SBS.take (SBS.length prefix) x == prefix+ where Label prefix = makeAccPreludeLabel SBS.empty++-- | Create a reference to an inline-provided function. See+-- 'labelIsAccPrelude'.+makeAccPreludeLabel :: ShortByteString -> Label+makeAccPreludeLabel s = Label (SBS8.pack "accprelude_" <> s)+++-- | Convert to llvm-pretty ---instance Downcast (Name a) LLVM.Name where- downcast (Name s) = LLVM.Name s- downcast (UnName n) = LLVM.UnName n+-- We only explicit conversion functions for symbols and identifiers separately.+--+nameToPrettyS :: Name a -> LLVM.Symbol+nameToPrettyS (Name s) = LLVM.Symbol (SBS8.unpack s)+nameToPrettyS (UnName n) = LLVM.Symbol ("tollpr_s_" ++ show n) -instance Downcast Label LLVM.Name where- downcast (Label l) = LLVM.Name l+nameToPrettyI :: Name a -> LLVM.Ident+nameToPrettyI (Name s) = LLVM.Ident (SBS8.unpack s)+nameToPrettyI (UnName n) = LLVM.Ident ("tollpr_i_" ++ show n) +labelToPrettyS :: Label -> LLVM.Symbol+labelToPrettyS (Label s) = LLVM.Symbol (SBS8.unpack s)++labelToPrettyI :: Label -> LLVM.Ident+labelToPrettyI (Label s) = LLVM.Ident (SBS8.unpack s)++labelToPrettyBL :: Label -> LLVM.BlockLabel+labelToPrettyBL (Label s) = LLVM.Named (LLVM.Ident (SBS8.unpack s))
src/LLVM/AST/Type/Operand.hs view
@@ -23,21 +23,21 @@ import LLVM.AST.Type.Name import LLVM.AST.Type.Representation -import qualified LLVM.AST.Operand as LLVM+import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty as LLVM -- | An 'Operand' is roughly anything that is an argument to an 'Instruction' -- data Operand a where- LocalReference :: Type a -> Name a -> Operand a- ConstantOperand :: Constant a -> Operand a+ LocalReference :: Type a -> Name a -> Operand a+ ConstantOperand :: Constant a -> Operand a --- | Convert to llvm-hs+-- | Convert to llvm-pretty ---instance Downcast (Operand a) LLVM.Operand where- downcast (LocalReference t n) = LLVM.LocalReference (downcast t) (downcast n)- downcast (ConstantOperand c) = LLVM.ConstantOperand (downcast c)+instance Downcast (Operand a) (LLVM.Typed LLVM.Value) where+ downcast (LocalReference t n) = LLVM.Typed (downcast t) (LLVM.ValIdent (nameToPrettyI n))+ downcast (ConstantOperand c) = downcast c instance TypeOf Operand where typeOf (LocalReference t _) = t
src/LLVM/AST/Type/Representation.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : LLVM.AST.Type.Representation@@ -19,19 +20,26 @@ module Data.Array.Accelerate.Type, Ptr, AddrSpace(..),+ defaultAddrSpace, ) where import Data.Array.Accelerate.Type import Data.Array.Accelerate.Representation.Type -import LLVM.AST.Type.AddrSpace import LLVM.AST.Type.Downcast+import LLVM.AST.Type.Name -import qualified LLVM.AST.Type as LLVM+-- import qualified LLVM.AST.Type as LLVM+import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty as LLVM+import Data.Array.Accelerate.LLVM.Internal.LLVMPretty ( AddrSpace(..), defaultAddrSpace ) +import Data.List+import Data.Text.Lazy.Builder import Foreign.Ptr+import Formatting import Text.Printf+import qualified Data.ByteString.Short.Char8 as S8 -- Witnesses to observe the LLVM type hierarchy:@@ -68,13 +76,17 @@ VoidType :: Type () PrimType :: PrimType a -> Type a +data LLArray a+ data PrimType a where BoolPrimType :: PrimType Bool ScalarPrimType :: ScalarType a -> PrimType a -- scalar value types (things in registers) PtrPrimType :: PrimType a -> AddrSpace -> PrimType (Ptr a) -- pointers (XXX: volatility?)- StructPrimType :: TypeR a -> PrimType a -- opaque structures (required for CmpXchg)- ArrayPrimType :: Word64 -> ScalarType a -> PrimType a -- static arrays+ ArrayPrimType :: Word64 -> ScalarType a -> PrimType (LLArray a) -- static arrays (TODO: type-level array length)+ StructPrimType :: Bool -> TupR PrimType l -> PrimType l -- aggregate structures+ NamedPrimType :: Label -> PrimType a -- typedef (TODO: add a type witness) + -- | All types -- @@ -251,23 +263,51 @@ primType = BoolPrimType instance Show (Type a) where- show VoidType = "()"- show (PrimType t) = show t+ show VoidType = "()"+ show (PrimType t) = show t instance Show (PrimType a) where- show BoolPrimType = "Bool"- show (ScalarPrimType t) = show t- show (StructPrimType t) = show t- show (ArrayPrimType n t) = printf "[%d x %s]" n (show t)- show (PtrPrimType t (AddrSpace n)) = printf "Ptr%s %s" a p+ show BoolPrimType = "Bool"+ show (ScalarPrimType t) = show t+ show (NamedPrimType (Label l)) = S8.unpack l+ show (ArrayPrimType n t) = printf "[%d x %s]" n (show t)+ show (StructPrimType _ t) = printf "{ %s }" (intercalate ", " (go t)) where+ go :: TupR PrimType t -> [String]+ go TupRunit = []+ go (TupRsingle s) = [show s]+ go (TupRpair ta tb) = go ta ++ go tb++ show (PtrPrimType t (AddrSpace n)) = printf "Ptr%s %s" a p+ where p = show t a | n == 0 = ""- | otherwise = printf "[addrspace %d]" n+ | otherwise = printf "[addrspace %d]" n :: String -- p | PtrPrimType{} <- t = printf "(%s)" (show t) -- | otherwise = show t +formatType :: Format r (Type a -> r)+formatType = later $ \case+ VoidType -> "()"+ PrimType t -> bformat formatPrimType t +formatPrimType :: Format r (PrimType a -> r)+formatPrimType = later $ \case+ BoolPrimType -> "Bool"+ ScalarPrimType t -> bformat formatScalarType t+ NamedPrimType (Label t) -> bformat string (S8.unpack t)+ ArrayPrimType n t -> bformat (squared (int % " x " % formatScalarType)) n t+ StructPrimType _ t -> bformat (braced (commaSpaceSep builder)) (go t)+ where+ go :: TupR PrimType t -> [Builder]+ go TupRunit = []+ go (TupRsingle s) = [bformat formatPrimType s]+ go (TupRpair ta tb) = go ta ++ go tb++ PtrPrimType t (AddrSpace 0) -> bformat ("Ptr " % formatPrimType) t+ PtrPrimType t (AddrSpace n) -> bformat ("Ptr[addrspace " % int % "] " % formatPrimType) n t++ -- | Does the concrete type represent signed or unsigned values? -- class IsSigned dict where@@ -313,20 +353,21 @@ typeOf :: f a -> Type a --- | Convert to llvm-hs+-- | Convert to llvm-pretty -- instance Downcast (Type a) LLVM.Type where- downcast VoidType = LLVM.VoidType+ downcast VoidType = LLVM.PrimType LLVM.Void downcast (PrimType t) = downcast t instance Downcast (PrimType a) LLVM.Type where- downcast BoolPrimType = LLVM.IntegerType 1+ downcast BoolPrimType = LLVM.PrimType (LLVM.Integer 1)+ downcast (NamedPrimType lab) = LLVM.Alias (labelToPrettyI lab) downcast (ScalarPrimType t) = downcast t- downcast (PtrPrimType t a) = LLVM.PointerType (downcast t) a- downcast (ArrayPrimType n t) = LLVM.ArrayType n (downcast t)- downcast (StructPrimType t) = LLVM.StructureType False (go t)+ downcast (PtrPrimType t a) = LLVM.PtrTo (downcast t) a+ downcast (ArrayPrimType n t) = LLVM.Array n (downcast t)+ downcast (StructPrimType p t) = (if p then LLVM.PackedStruct else LLVM.Struct) (go t) where- go :: TypeR t -> [LLVM.Type]+ go :: TupR PrimType t -> [LLVM.Type] go TupRunit = [] go (TupRsingle s) = [downcast s] go (TupRpair ta tb) = go ta ++ go tb
src/LLVM/AST/Type/Terminator.hs view
@@ -1,6 +1,9 @@+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : LLVM.AST.Type.Terminator@@ -20,9 +23,11 @@ import LLVM.AST.Type.Operand import LLVM.AST.Type.Downcast -import qualified LLVM.AST.Instruction as LLVM+import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty as LLVM +import Data.Bifunctor ( bimap ) + -- | <http://llvm.org/docs/LangRef.html#terminators> -- -- TLM: well, I don't think the types of these terminators make any sense. When@@ -63,14 +68,17 @@ -- | Convert to llvm-hs ---instance Downcast (Terminator a) LLVM.Terminator where+instance Downcast (Terminator a) LLVM.Instr where downcast = \case- Ret -> LLVM.Ret Nothing md- RetVal x -> LLVM.Ret (Just (downcast x)) md- Br l -> LLVM.Br (downcast l) md- CondBr p t f -> LLVM.CondBr (downcast p) (downcast t) (downcast f) md- Switch p d a -> LLVM.Switch (downcast p) (downcast d) (downcast a) md- where- md :: LLVM.InstructionMetadata- md = []-+ Ret -> LLVM.RetVoid+ RetVal x -> LLVM.Ret (downcast x)+ Br l -> LLVM.Jump (LLVM.Named (labelToPrettyI l))+ CondBr p t f -> LLVM.Br (downcast p) (LLVM.Named (labelToPrettyI t)) (LLVM.Named (labelToPrettyI f))+ Switch p d a -> LLVM.Switch (downcast p)+ (labelToPrettyBL d)+ (map (bimap fromConstant labelToPrettyBL) a)+ where+ fromConstant :: Constant a -> Integer+ fromConstant cnst = case downcast @_ @(LLVM.Typed LLVM.Value) cnst of+ LLVM.Typed _ (LLVM.ValInteger n) -> n+ _ -> error "TODO: llvm-pretty supports only integral cases for Switch"