diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -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
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -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)
-
-[](https://stackage.org/lts/package/accelerate-llvm)
-[](https://stackage.org/nightly/package/accelerate-llvm)
[](https://hackage.haskell.org/package/accelerate-llvm)
-
-[](https://hub.docker.com/r/tmcdonell/accelerate-llvm/)
-[](https://microbadger.com/images/tmcdonell/accelerate-llvm)
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.
+Optionally, add clang (and more) to your system path. Click to see how.
-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:
+——
+
-```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.
diff --git a/accelerate-llvm.cabal b/accelerate-llvm.cabal
--- a/accelerate-llvm.cabal
+++ b/accelerate-llvm.cabal
@@ -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
- package.
+ 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:
- .
- *
- .
- * (if using )
- .
- * (if using )
- .
- [/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 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
- . 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.
+ * (not used to compile C code, but to compile generated LLVM IR via a mostly LLVM-version-independent interface)
+ * (if using )
+ * (if using )
.
- 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 .
.
+ This package includes (and exposes) a forked copy of
+ 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
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
diff --git a/llvm-pretty/src/Text/LLVM.hs b/llvm-pretty/src/Text/LLVM.hs
new file mode 100644
--- /dev/null
+++ b/llvm-pretty/src/Text/LLVM.hs
@@ -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))
diff --git a/llvm-pretty/src/Text/LLVM/AST.hs b/llvm-pretty/src/Text/LLVM/AST.hs
new file mode 100644
--- /dev/null
+++ b/llvm-pretty/src/Text/LLVM/AST.hs
@@ -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) "" 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.
+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 .
+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
diff --git a/llvm-pretty/src/Text/LLVM/DebugUtils.hs b/llvm-pretty/src/Text/LLVM/DebugUtils.hs
new file mode 100644
--- /dev/null
+++ b/llvm-pretty/src/Text/LLVM/DebugUtils.hs
@@ -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
diff --git a/llvm-pretty/src/Text/LLVM/Labels.hs b/llvm-pretty/src/Text/LLVM/Labels.hs
new file mode 100644
--- /dev/null
+++ b/llvm-pretty/src/Text/LLVM/Labels.hs
@@ -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
diff --git a/llvm-pretty/src/Text/LLVM/Labels/TH.hs b/llvm-pretty/src/Text/LLVM/Labels/TH.hs
new file mode 100644
--- /dev/null
+++ b/llvm-pretty/src/Text/LLVM/Labels/TH.hs
@@ -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
diff --git a/llvm-pretty/src/Text/LLVM/Lens.hs b/llvm-pretty/src/Text/LLVM/Lens.hs
new file mode 100644
--- /dev/null
+++ b/llvm-pretty/src/Text/LLVM/Lens.hs
@@ -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
+ ]
diff --git a/llvm-pretty/src/Text/LLVM/PP.hs b/llvm-pretty/src/Text/LLVM/PP.hs
new file mode 100644
--- /dev/null
+++ b/llvm-pretty/src/Text/LLVM/PP.hs
@@ -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 ';' <+> "