accelerate-llvm-native 1.3.0.0 → 1.4.0.0
raw patch · 40 files changed
+1199/−2380 lines, 40 filesdep +Win32dep +formattingdep +prettydep −cerealdep −ghc-primdep −llvm-hsdep ~acceleratedep ~accelerate-llvmdep ~containersbuild-type:Customsetup-changednew-uploaderPVP ok
version bump matches the API change (PVP)
Dependencies added: Win32, formatting, pretty, process, tasty, tasty-hunit, text, th-lift-instances, unordered-containers
Dependencies removed: cereal, ghc-prim, llvm-hs, llvm-hs-pure
Dependency ranges changed: accelerate, accelerate-llvm, containers, libffi
API changes (from Hackage documentation)
- Data.Array.Accelerate.LLVM.Native.Foreign: -- stack with the LLVM monad at the base.
- Data.Array.Accelerate.LLVM.Native.Foreign: -- | Parallel computations can communicate via futures.
- Data.Array.Accelerate.LLVM.Native: class Afunction f
+ Data.Array.Accelerate.LLVM.Native: class () => Afunction f
- Data.Array.Accelerate.LLVM.Native: class Arrays a
+ Data.Array.Accelerate.LLVM.Native: class () => Arrays a
- Data.Array.Accelerate.LLVM.Native: data Acc a
+ Data.Array.Accelerate.LLVM.Native: data () => Acc a
- Data.Array.Accelerate.LLVM.Native: data Async a
+ Data.Array.Accelerate.LLVM.Native: data () => Async a
- Data.Array.Accelerate.LLVM.Native: run :: Arrays a => Acc a -> a
+ Data.Array.Accelerate.LLVM.Native: run :: (Arrays a, HasCallStack) => Acc a -> a
- Data.Array.Accelerate.LLVM.Native: run1 :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> b
+ Data.Array.Accelerate.LLVM.Native: run1 :: (Arrays a, Arrays b, HasCallStack) => (Acc a -> Acc b) -> a -> b
- Data.Array.Accelerate.LLVM.Native: run1Async :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> IO (Async b)
+ Data.Array.Accelerate.LLVM.Native: run1Async :: (Arrays a, Arrays b, HasCallStack) => (Acc a -> Acc b) -> a -> IO (Async b)
- Data.Array.Accelerate.LLVM.Native: run1AsyncWith :: (Arrays a, Arrays b) => Native -> (Acc a -> Acc b) -> a -> IO (Async b)
+ Data.Array.Accelerate.LLVM.Native: run1AsyncWith :: (Arrays a, Arrays b, HasCallStack) => Native -> (Acc a -> Acc b) -> a -> IO (Async b)
- Data.Array.Accelerate.LLVM.Native: run1With :: (Arrays a, Arrays b) => Native -> (Acc a -> Acc b) -> a -> b
+ Data.Array.Accelerate.LLVM.Native: run1With :: (Arrays a, Arrays b, HasCallStack) => Native -> (Acc a -> Acc b) -> a -> b
- Data.Array.Accelerate.LLVM.Native: runAsync :: Arrays a => Acc a -> IO (Async a)
+ Data.Array.Accelerate.LLVM.Native: runAsync :: (Arrays a, HasCallStack) => Acc a -> IO (Async a)
- Data.Array.Accelerate.LLVM.Native: runAsyncWith :: Arrays a => Native -> Acc a -> IO (Async a)
+ Data.Array.Accelerate.LLVM.Native: runAsyncWith :: (Arrays a, HasCallStack) => Native -> Acc a -> IO (Async a)
- Data.Array.Accelerate.LLVM.Native: runN :: Afunction f => f -> AfunctionR f
+ Data.Array.Accelerate.LLVM.Native: runN :: (Afunction f, HasCallStack) => f -> AfunctionR f
- Data.Array.Accelerate.LLVM.Native: runNAsync :: (Afunction f, RunAsync r, ArraysFunctionR f ~ RunAsyncR r) => f -> r
+ Data.Array.Accelerate.LLVM.Native: runNAsync :: (Afunction f, RunAsync r, ArraysFunctionR f ~ RunAsyncR r, HasCallStack) => f -> r
- Data.Array.Accelerate.LLVM.Native: runNAsyncWith :: (Afunction f, RunAsync r, ArraysFunctionR f ~ RunAsyncR r) => Native -> f -> r
+ Data.Array.Accelerate.LLVM.Native: runNAsyncWith :: (Afunction f, RunAsync r, ArraysFunctionR f ~ RunAsyncR r, HasCallStack) => Native -> f -> r
- Data.Array.Accelerate.LLVM.Native: runNWith :: forall f. Afunction f => Native -> f -> AfunctionR f
+ Data.Array.Accelerate.LLVM.Native: runNWith :: forall f. (Afunction f, HasCallStack) => Native -> f -> AfunctionR f
- Data.Array.Accelerate.LLVM.Native: runQ :: Afunction f => f -> ExpQ
+ Data.Array.Accelerate.LLVM.Native: runQ :: (Afunction f, HasCallStack) => f -> ExpQ
- Data.Array.Accelerate.LLVM.Native: runQAsync :: Afunction f => f -> ExpQ
+ Data.Array.Accelerate.LLVM.Native: runQAsync :: (Afunction f, HasCallStack) => f -> ExpQ
- Data.Array.Accelerate.LLVM.Native: runQAsyncWith :: Afunction f => f -> ExpQ
+ Data.Array.Accelerate.LLVM.Native: runQAsyncWith :: (Afunction f, HasCallStack) => f -> ExpQ
- Data.Array.Accelerate.LLVM.Native: runQWith :: Afunction f => f -> ExpQ
+ Data.Array.Accelerate.LLVM.Native: runQWith :: (Afunction f, HasCallStack) => f -> ExpQ
- Data.Array.Accelerate.LLVM.Native: runWith :: Arrays a => Native -> Acc a -> a
+ Data.Array.Accelerate.LLVM.Native: runWith :: (Arrays a, HasCallStack) => Native -> Acc a -> a
- Data.Array.Accelerate.LLVM.Native: stream :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> [a] -> [b]
+ Data.Array.Accelerate.LLVM.Native: stream :: (Arrays a, Arrays b, HasCallStack) => (Acc a -> Acc b) -> [a] -> [b]
- Data.Array.Accelerate.LLVM.Native: streamWith :: (Arrays a, Arrays b) => Native -> (Acc a -> Acc b) -> [a] -> [b]
+ Data.Array.Accelerate.LLVM.Native: streamWith :: (Arrays a, Arrays b, HasCallStack) => Native -> (Acc a -> Acc b) -> [a] -> [b]
- Data.Array.Accelerate.LLVM.Native.Foreign: class Monad Par arch => Async arch where {
+ Data.Array.Accelerate.LLVM.Native.Foreign: class (Monad Par arch, MonadIO Par arch) => Async arch where {
- Data.Array.Accelerate.LLVM.Native.Foreign: data LLVM target a
+ Data.Array.Accelerate.LLVM.Native.Foreign: data () => LLVM target a
Files
- CHANGELOG.md +24/−1
- README.md +110/−151
- Setup.hs +127/−1
- SetupHooks.hs +29/−0
- accelerate-llvm-native.cabal +48/−78
- src/Control/Concurrent/Extra.hs +34/−0
- src/Data/Array/Accelerate/LLVM/Native.hs +76/−62
- src/Data/Array/Accelerate/LLVM/Native/CodeGen/Base.hs +33/−27
- src/Data/Array/Accelerate/LLVM/Native/CodeGen/Fold.hs +1/−5
- src/Data/Array/Accelerate/LLVM/Native/CodeGen/FoldSeg.hs +0/−2
- src/Data/Array/Accelerate/LLVM/Native/CodeGen/Generate.hs +1/−3
- src/Data/Array/Accelerate/LLVM/Native/CodeGen/Map.hs +1/−3
- src/Data/Array/Accelerate/LLVM/Native/CodeGen/Permute.hs +3/−20
- src/Data/Array/Accelerate/LLVM/Native/CodeGen/Scan.hs +0/−16
- src/Data/Array/Accelerate/LLVM/Native/CodeGen/Stencil.hs +4/−7
- src/Data/Array/Accelerate/LLVM/Native/CodeGen/Transform.hs +0/−2
- src/Data/Array/Accelerate/LLVM/Native/Compile.hs +178/−47
- src/Data/Array/Accelerate/LLVM/Native/Compile/Cache.hs +9/−4
- src/Data/Array/Accelerate/LLVM/Native/Compile/Optimise.hs +0/−142
- src/Data/Array/Accelerate/LLVM/Native/Debug.hs +55/−13
- src/Data/Array/Accelerate/LLVM/Native/Embed.hs +38/−29
- src/Data/Array/Accelerate/LLVM/Native/Execute.hs +56/−55
- src/Data/Array/Accelerate/LLVM/Native/Execute/Async.hs +5/−4
- src/Data/Array/Accelerate/LLVM/Native/Execute/Divide.hs +4/−4
- src/Data/Array/Accelerate/LLVM/Native/Execute/Environment.hs +0/−1
- src/Data/Array/Accelerate/LLVM/Native/Execute/Marshal.hs +10/−5
- src/Data/Array/Accelerate/LLVM/Native/Execute/Scheduler.hs +11/−8
- src/Data/Array/Accelerate/LLVM/Native/Link.hs +11/−18
- src/Data/Array/Accelerate/LLVM/Native/Link/COFF.hs +0/−35
- src/Data/Array/Accelerate/LLVM/Native/Link/Cache.hs +39/−1
- src/Data/Array/Accelerate/LLVM/Native/Link/ELF.chs +0/−739
- src/Data/Array/Accelerate/LLVM/Native/Link/MachO.chs +0/−733
- src/Data/Array/Accelerate/LLVM/Native/Link/Object.hs +21/−6
- src/Data/Array/Accelerate/LLVM/Native/Link/Runtime.hs +73/−0
- src/Data/Array/Accelerate/LLVM/Native/Plugin.hs +103/−62
- src/Data/Array/Accelerate/LLVM/Native/Plugin/BuildInfo.hs +32/−21
- src/Data/Array/Accelerate/LLVM/Native/State.hs +24/−9
- src/Data/Array/Accelerate/LLVM/Native/Target.hs +6/−62
- test/nofib/Data/Array/Accelerate/LLVM/Native/NoFib/RunQ.hs +31/−0
- test/nofib/Main.hs +2/−4
CHANGELOG.md view
@@ -6,6 +6,29 @@ project adheres to the [Haskell Package Versioning Policy (PVP)](https://pvp.haskell.org) +## [1.4.0.0] - ?+### Changed+ * Support for LLVM-15 to 22.+ * Wider platform support (including support for Apple silicon and other ARM systems) by using the system linker.+ * Support for the Tracy profiler, under the tracy and debug flags.++### Fixed+ * Undefined symbols for math functions ([accelerate-llvm#104])++### 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)+ * Mirek Kratochvil (@exaexa)+ * Tao He (@sighingnow)+ * Patsakula Nikita (@npatsakula)+ * Noah Williams (@noahmartinwilliams)+ ## [1.3.0.0] - 2018-08-27 ### Changed * Switch the thread scheduler to static, rather than dynamic, work stealing@@ -80,4 +103,4 @@ [#409]: https://github.com/AccelerateHS/accelerate/issues/409 [accelerate-llvm#17]: https://github.com/AccelerateHS/accelerate-llvm/issues/17 [accelerate-llvm#49]: https://github.com/AccelerateHS/accelerate-llvm/pull/49-+[accelerate-llvm#104]: https://github.com/AccelerateHS/accelerate-llvm/pull/104
README.md view
@@ -3,21 +3,16 @@ # LLVM backends for the Accelerate array language -[](https://github.com/tmcdonell/accelerate-llvm/actions)+[](https://github.com/AccelerateHS/accelerate-llvm/actions/workflows/ci.yml) [](https://gitter.im/AccelerateHS/Lobby)-<br>-[](https://stackage.org/lts/package/accelerate-llvm)-[](https://stackage.org/nightly/package/accelerate-llvm) [](https://hackage.haskell.org/package/accelerate-llvm)-<br>-[](https://hub.docker.com/r/tmcdonell/accelerate-llvm/)-[](https://microbadger.com/images/tmcdonell/accelerate-llvm) </div> This package compiles Accelerate code to LLVM IR, and executes that code on-multicore CPUs as well as NVIDIA GPUs. This avoids the need to go through `nvcc`-or `clang`. For details on Accelerate, refer to the [main repository][GitHub].+multicore CPUs as well as NVIDIA GPUs. This avoids the need to go through+`nvcc` or write C++ code. For details on Accelerate, refer to the [main+repository][GitHub]. We love all kinds of contributions, so feel free to open issues for missing features as well as report (or fix!) bugs on the [issue tracker][Issues].@@ -27,179 +22,143 @@ * [Dependencies](#dependencies)- * [Docker](#docker)- * [Installing LLVM](#installing-llvm)- * [Homebrew](#homebrew)+ * [macOS](#macos) * [Debian/Ubuntu](#debianubuntu)- * [Building from source](#building-from-source)- * [Installing Accelerate-LLVM](#installing-accelerate-llvm)- * [libNVVM](#libNVVM)+ * [Arch Linux](#archlinux)+ * [Windows](#windows) Dependencies ------------ -Haskell dependencies are available from Hackage, but there are several external+Haskell dependencies are available from Hackage, but there are some external library dependencies that you will need to install as well: - * [`LLVM`](http://llvm.org)- * [`libFFI`](http://sourceware.org/libffi/) (if using the `accelerate-llvm-native` backend for multicore CPUs)- * [`CUDA`](https://developer.nvidia.com/cuda-downloads) (if using the `accelerate-llvm-ptx` backend for NVIDIA GPUs)---Docker---------A [docker](https://www.docker.com) container is provided with this package-preinstalled (via stack) at `/opt/accelerate-llvm`. Note that if you wish to use-the `accelerate-llvm-ptx` GPU backend, you will need to install the [NVIDIA-docker](https://github.com/NVIDIA/nvidia-docker) plugin; see that page for more-information.--```sh-$ docker run -it tmcdonell/accelerate-llvm-```---Installing LLVM------------------When installing LLVM, make sure that it includes the `libLLVM` shared library.-If you want to use the GPU targeting `accelerate-llvm-ptx` backend, make sure-you install (or build) LLVM with the 'nvptx' target.+- if using `accelerate-llvm-native` for multicore CPU:+ [`libFFI`](http://sourceware.org/libffi/)+- if using `accelerate-llvm-ptx` for GPU:+ [`CUDA`](https://developer.nvidia.com/cuda-downloads);+ [Note that not all versions of CUDA support all NVIDIA GPUs](https://en.wikipedia.org/wiki/CUDA#GPUs_supported)+- [`clang`](https://clang.llvm.org/) (if using `accelerate-llvm-ptx`: version+ 16 or higher, built with support for the `nvptx` backend). `accelerate-llvm`+ uses the command-line tool as a way to be compatible with many different LLVM+ versions, not to compile C code. (Accelerate passes LLVM IR to `clang`.) -## Homebrew+Below are some OS-specific instructions. If anything here is wrong or out of+date, please file an issue. -Example using [Homebrew](http://brew.sh) on macOS:+## macOS -```sh-$ brew install llvm-hs/llvm/llvm-9-```+To get `libFFI`, run `brew install libffi`. `clang` is already provided with+macOS (you may need to `xcode-select --install`), and CUDA is not supported on+macOS. ## Debian/Ubuntu -For Debian/Ubuntu based Linux distributions, the LLVM.org website provides-binary distribution packages. Check [apt.llvm.org](http://apt.llvm.org) for-instructions for adding the correct package database for your OS version, and-then:--```sh-$ apt-get install llvm-9-dev-```--## Building from source--If your OS does not have an appropriate LLVM distribution available, you can also build from source. Detailed build instructions are available on the [LLVM.org website](http://releases.llvm.org/6.0.0/docs/CMake.html). Note that you will require at least [CMake 3.4.3](http://www.cmake.org/cmake/resources/software.html) and a recent C++ compiler; at least Clang 3.1, GCC 4.8, or Visual Studio 2015 (update 3).-- 1. Download and unpack the [LLVM-9 source code](https://github.com/llvm/llvm-project/releases/download/llvmorg-9.0.1/llvm-9.0.1.src.tar.xz). We'll refer to- the path that the source tree was unpacked to as `LLVM_SRC`. Only the main- LLVM source tree is required, but you can optionally add other components- such as the Clang compiler or Polly loop optimiser. See the [LLVM releases](http://releases.llvm.org/download.html#9.0.1)- page for the complete list.-- 2. Create a temporary build directory and `cd` into it, for example:- ```sh- $ mkdir /tmp/build- $ cd /tmp/build- ```-- 3. Execute the following to configure the build. Here `INSTALL_PREFIX` is- where LLVM is to be installed, for example `/usr/local` or- `$HOME/opt/llvm`:- ```sh- $ cmake $LLVM_SRC -DCMAKE_INSTALL_PREFIX=$INSTALL_PREFIX -DCMAKE_BUILD_TYPE=Release -DLLVM_ENABLE_ASSERTIONS=ON -DLLVM_BUILD_LLVM_DYLIB=ON -DLLVM_LINK_LLVM_DYLIB=ON- ```- See [options and variables](http://llvm.org/docs/CMake.html#options-and-variables)- for a list of additional build parameters you can specify.-- 4. Build and install:- ```sh- $ cmake --build .- $ cmake --build . --target install- ```-- 5. For macOS only, some additional steps are useful to work around issues related- to [System Integrity Protection](https://en.wikipedia.org/wiki/System_Integrity_Protection):- ```sh- cd $INSTALL_PREFIX/lib- ln -s libLLVM.dylib libLLVM-9.dylib- install_name_tool -id $PWD/libLTO.dylib libLTO.dylib- install_name_tool -id $PWD/libLLVM.dylib libLLVM.dylib- install_name_tool -change '@rpath/libLLVM.dylib' $PWD/libLLVM.dylib libLTO.dylib- ```-+For `clang`:+- On Ubuntu 24.04 (noble) / Debian trixie or higher: `sudo apt install clang`.+- Otherwise, if you need only the CPU backend (`accelerate-llvm-native`):+ `sudo apt install clang` will give you an old version of `clang`, but the CPU+ backend is likely to work fine.+- If you are on an older distro and need the GPU backend+ (`accelerate-llvm-ptx`): `clang` version 16 or higher is required.+ Add the apt source from [apt.llvm.org](https://apt.llvm.org/). The neatest+ way to do this is to create a file `/etc/apt/sources.list.d/llvm.list` (the+ precise file name does not matter) and put in it, for Ubuntu (change "jammy"+ as appropriate): -Installing Accelerate-LLVM---------------------------+ deb http://apt.llvm.org/jammy/ llvm-toolchain-jammy main+ deb-src http://apt.llvm.org/jammy/ llvm-toolchain-jammy main -Once the dependencies are installed, we are ready to install `accelerate-llvm`.+ or for Debian (change "bookworm" as appropriate): -For example, installation using [`stack`](http://docs.haskellstack.org/en/stable/README.html)-just requires you to point it to the appropriate configuration file:-```sh-$ ln -s stack-8.8.yaml stack.yaml-$ stack setup-$ stack install-```+ deb http://apt.llvm.org/bookworm/ llvm-toolchain-bookworm main+ deb-src http://apt.llvm.org/bookworm/ llvm-toolchain-bookworm main -Note that the version of [`llvm-hs`](https://hackage.haskell.org/package/llvm-hs)-used must match the installed version of LLVM, which is currently 9.0.+ and `sudo apt update; sudo apt install clang`. This gets you the latest+ version of `clang`; different sources are also available for specific+ versions (see [apt.llvm.org](https://apt.llvm.org)). +To use the CPU backend (`accelerate-llvm-native`), install `libFFI` using+`sudo apt install libffi-dev`. -## libNVVM+To use the GPU backend (`accelerate-llvm-ptx`), install CUDA from+[here](https://developer.nvidia.com/cuda-downloads?target_os=Linux)+("deb (network)" is smoother than the "deb (local)" option). -The `accelerate-llvm-ptx` backend can optionally be compiled to generate GPU-code using the `libNVVM` library, rather than LLVM's inbuilt NVPTX code-generator. `libNVVM` is a closed-source library distributed as part of the-NVIDIA CUDA toolkit, and is what the `nvcc` compiler itself uses internally when-compiling CUDA C code.+## Arch Linux -Using `libNVVM` _may_ improve GPU performance compared to the code generator-built in to LLVM. One difficulty with using it however is that since `libNVVM`-is also based on LLVM, and typically lags LLVM by several releases, you must-install `accelerate-llvm` with a "compatible" version of LLVM, which will depend-on the version of the CUDA toolkit you have installed. The following table shows-combinations which have been tested:+Run `sudo pacman -S clang`. To use the CPU backend (`accelerate-llvm-native`),+additionally run `sudo pacman -S libffi`. To use the GPU backend+(`accelerate-llvm-ptx`), additionally run `sudo pacman -S cuda`. -| | LLVM-3.3 | LLVM-3.4 | LLVM-3.5 | LLVM-3.8 | LLVM-3.9 | LLVM-4.0 | LLVM-5.0 | LLVM-6.0 | LLVM-7 | LLVM-8 | LLVM-9 |-| ------------- | :------: | :------: | :------: | :------: | :------: | :------: | :------: | :------: | :----: | :----: | :----: |-| **CUDA-7.0** | ⭕ | ❌ | | | | | | | | | |-| **CUDA-7.5** | | ⭕ | ⭕ | ❌ | | | | | | | |-| **CUDA-8.0** | | | ⭕ | ⭕ | ❌ | ❌ | | | | | |-| **CUDA-9.0** | | | | | | ❌ | ❌ | | | | |-| **CUDA-9.1** | | | | | | | | | | | |-| **CUDA-9.2** | | | | | | | | | | | |-| **CUDA-10.0** | | | | | | | | | | | |-| **CUDA-10.1** | | | | | | | | | | | |+## Windows -Where ⭕ = Works, and ❌ = Does not work.+We recommend WSL2 (not WSL1, WSL2!) and following the Ubuntu instructions+above. The remainder of this text attemps to give you a working system on+Windows native. -The above table is incomplete! If you try a particular combination and find that-it does or does not work, please let us know!+Install `clang`; you have two options:+1. Using+ [WinGet](https://learn.microsoft.com/en-us/windows/package-manager/winget/):+ `winget install LLVM.LLVM`+2. By downloading the installer directly (WinGet just runs the same installer)+ from [here](https://github.com/llvm/llvm-project/releases) (choose+ "LLVM-<version>-win64.exe" from the latest release; you may need to click+ "Show all 57 assets").+This will also give you `libFFI`. -Note that the above restrictions on CUDA and LLVM version exist _only_ if you-want to use the NVVM component. Otherwise, you should be free to use any-combination of CUDA and LLVM.+<details><summary>Optionally, add <code>clang</code> (and more) to your system path. Click to see how.</summary> -Also note that `accelerate-llvm-ptx` itself currently requires at least LLVM-4.0.+Accelerate should be able to find `clang` automatically even if you do not do+this. However, for easy access to `clang` and all other LLVM executables, add+`C:\Program Files\LLVM\bin` to the system path as follows:+1. Search for "environment variables" in the start menu+2. Click "Edit the system environment variables"+3. Click on "Environment Variables..."+4. Double-click on the user variable called "Path"+5. And add a new entry containing `C:\Program Files\LLVM\bin`. -Using `stack`, either edit the `stack.yaml` and add the following section:+Note that if you add an entry here manually, it is a good idea to clean it up+again if you uninstall LLVM/clang. (Leaving it there is not very harmful,+however.) -```yaml-flags:- accelerate-llvm-ptx:- nvvm: true-```+You may find that the LLVM/clang installer has already added the Path entry+automatically (it did not for us); if so, no need to add a second entry. -Or install using the following option on the command line:+——+</details> -```sh-$ stack install accelerate-llvm-ptx --flag accelerate-llvm-ptx:nvvm-```+You may additionally need the VS Build Tools, if you have not yet installed and+set up Visual Studio otherwise. You need this if `clang` complains that it is+`unable to find a Visual Studio installation; try running Clang from a developer command prompt`. -If installing via `cabal`:+1. If you already have the Visual Studio Installer on your system, open it and+ check if you already have Visual Studio (Community) installed. Note that+ this is completely unrelated to VS _Code_.+ - If you already have VS (Community): inside the Visual Studio Installer,+ click on "Modify" in the VS (Community) box. This should get you a screen+ with "workloads" you can select.+ - If you do not yet have VS (Community), install the VS Build Tools: go to+ https://visualstudio.microsoft.com/downloads, scroll down to "All+ Downloads", open "Tools for Visual Studio", and select "Build Tools for+ Visual Studio". If you run the installer, you should get a screen with+ "workloads" you can select.+2. Under the Workloads tab, choose the "Desktop development with C++" workload.+ If you want to save a bit of disk space (not much), keep only the following+ two options selected:+ - "MSVC v143 - VE 2022 C++ x64/x86 build tools (Latest)"+ - "Windows 11 SDK (…)" (choose the latest option). The attentive reader may+ note that the wizard also offers Clang; we recommend a separate Clang+ install for Accelerate because the one from VS somehow doesn’t seem to+ work properly with Accelerate. If you find out why, please let us know.+3. Install that. This takes a while. -```sh-$ cabal install accelerate-llvm-ptx -fnvvm-```+It turns out that having both Visual Studio and the Build Tools installed+results in Clang getting confused between the two (it appears that Visual+Studio is 64-bit (x64) and the Build Tools are 32-bit (x86)). If Clang+complains about the bit-ness of your system libraries, double-check that you+haven’t installed both simultaneously. +The GPU backend (`accelerate-llvm-ptx`) probably doesn't work on Windows; in+any case, it is untested.
Setup.hs view
@@ -1,2 +1,128 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}++module Main where++import Distribution.PackageDescription+import Distribution.PackageDescription.PrettyPrint import Distribution.Simple-main = defaultMain+import Distribution.Simple.BuildPaths+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.PackageIndex+import Distribution.Simple.Setup as Setup+import Distribution.Verbosity+import qualified Distribution.InstalledPackageInfo as Installed++#if MIN_VERSION_Cabal(3,8,0)+import Distribution.Simple.PackageDescription+#elif MIN_VERSION_Cabal(2,2,0)+import Distribution.PackageDescription.Parsec+#else+import Distribution.PackageDescription.Parse+#endif+#if MIN_VERSION_Cabal(3,14,0)+-- Note [Cabal 3.14]+--+-- If you change any path stuff, either test that the package still works with+-- Cabal 3.12 or stop declaring support for it in cuda.cabal. (If you do the+-- latter, also remove all of the other conditionals in this file.)+-- Note that supporting old versions of Cabal is useful for being able to run+-- e.g. Accelerate on old GPU clusters, which is nice.+import Distribution.Utils.Path (SymbolicPath, FileOrDir(File, Dir), Lib, Include, Pkg, CWD, makeSymbolicPath)+import qualified Distribution.Types.LocalBuildConfig as LBC+#endif++import System.FilePath+++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+ { postConf = postConfHook+ , preBuild = readHook buildVerbosity workingDirFlag+ , preRepl = readHook replVerbosity workingDirFlag+ , preCopy = readHook copyVerbosity workingDirFlag+ , preInst = readHook installVerbosity workingDirFlag+ , preHscolour = readHook hscolourVerbosity workingDirFlag+ , preHaddock = readHook haddockVerbosity workingDirFlag+ , preReg = readHook regVerbosity workingDirFlag+ , preUnreg = readHook regVerbosity workingDirFlag+ }+ where+ readHook :: (a -> Setup.Flag Verbosity) -> (a -> Setup.Flag CWDPath) -> Args -> a -> IO HookedBuildInfo+ readHook verbosity cwd _ flags = readHookedBuildInfoWithCWD (fromFlag (verbosity flags)) (flagToMaybe (cwd flags)) (makeSymbolicPath buildinfo_file)++ postConfHook :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ()+ postConfHook args flags pkg_desc lbi = do+ let accelerate_pkg = case searchByName (installedPkgs lbi) "accelerate" of+ Unambiguous [x] -> x+ _ -> error "accelerate package was not found or is ambiguous"++ dyld_library_name = mkSharedLibName (hostPlatform lbi) (compilerId (compiler lbi)) (installedUnitId accelerate_pkg)+ dyld_install_dir:_ = case Installed.libraryDynDirs accelerate_pkg of+ [] -> Installed.libraryDirs accelerate_pkg+ ds -> ds++ buildinfo = emptyBuildInfo { cppOptions = [ "-DACCELERATE_DYLD_LIBRARY_PATH=" ++ quote (dyld_install_dir </> dyld_library_name) ] }+ hooked_buildinfo = (Just buildinfo, [])+ pkg_desc' = updatePackageDescription hooked_buildinfo pkg_desc+++ writeHookedBuildInfo buildinfo_file hooked_buildinfo+ postConf simpleUserHooks args flags pkg_desc' lbi++buildinfo_file :: FilePath+buildinfo_file = "accelerate-llvm-native.buildinfo"++quote :: String -> String+#ifdef mingw32_HOST_OS+quote s = "\"" ++ (s >>= escape) ++ "\""+ where+ escape '\\' = "\\\\"+ escape '"' = "\\\""+ escape c = [c]+#else+quote = show+#endif+++-- Compatibility across Cabal 3.14 symbolic paths.+-- If we want to drop pre-Cabal-3.14 compatibility at some point, this should all be merged in above.++#if MIN_VERSION_Cabal(3,14,0)+type CWDPath = SymbolicPath CWD ('Dir Pkg)++regVerbosity :: RegisterFlags -> Flag Verbosity+regVerbosity = setupVerbosity . registerCommonFlags++workingDirFlag :: HasCommonFlags flags => flags -> Flag CWDPath+workingDirFlag = setupWorkingDir . getCommonFlags++-- makeSymbolicPath is an actual useful function in Cabal 3.14++class HasCommonFlags flags where getCommonFlags :: flags -> CommonSetupFlags+instance HasCommonFlags BuildFlags where getCommonFlags = buildCommonFlags+instance HasCommonFlags CleanFlags where getCommonFlags = cleanCommonFlags+instance HasCommonFlags ConfigFlags where getCommonFlags = configCommonFlags+instance HasCommonFlags CopyFlags where getCommonFlags = copyCommonFlags+instance HasCommonFlags InstallFlags where getCommonFlags = installCommonFlags+instance HasCommonFlags HscolourFlags where getCommonFlags = hscolourCommonFlags+instance HasCommonFlags HaddockFlags where getCommonFlags = haddockCommonFlags+instance HasCommonFlags RegisterFlags where getCommonFlags = registerCommonFlags+instance HasCommonFlags ReplFlags where getCommonFlags = replCommonFlags++readHookedBuildInfoWithCWD :: Verbosity -> Maybe CWDPath -> SymbolicPath Pkg 'File -> IO HookedBuildInfo+readHookedBuildInfoWithCWD = readHookedBuildInfo+#else+type CWDPath = ()++-- regVerbosity is still present as an actual field in Cabal 3.12++workingDirFlag :: flags -> Flag CWDPath+workingDirFlag _ = NoFlag++makeSymbolicPath :: FilePath -> FilePath+makeSymbolicPath = id++readHookedBuildInfoWithCWD :: Verbosity -> Maybe CWDPath -> FilePath -> IO HookedBuildInfo+readHookedBuildInfoWithCWD verb _ path = readHookedBuildInfo verb path+#endif
+ SetupHooks.hs view
@@ -0,0 +1,29 @@+module SetupHooks where++import Distribution.Simple.SetupHooks++setupHooks :: SetupHooks+setupHooks =+ noSetupHooks+ { configureHooks = noConfigureHooks { preConfPackageHook = Just hook } }+ where+ hook :: PreConfPackageInputs -> IO PreConfPackageOutputs+ hook inputs = _++ -- postConfHook args flags pkg_desc lbi = do+ -- let accelerate_pkg = case searchByName (installedPkgs lbi) "accelerate" of+ -- Unambiguous [x] -> x+ -- _ -> error "accelerate package was not found or is ambiguous"++ -- dyld_library_name = mkSharedLibName (hostPlatform lbi) (compilerId (compiler lbi)) (installedUnitId accelerate_pkg)+ -- dyld_install_dir:_ = case Installed.libraryDynDirs accelerate_pkg of+ -- [] -> Installed.libraryDirs accelerate_pkg+ -- ds -> ds++ -- buildinfo = emptyBuildInfo { cppOptions = [ "-DACCELERATE_DYLD_LIBRARY_PATH=" ++ quote (dyld_install_dir </> dyld_library_name) ] }+ -- hooked_buildinfo = (Just buildinfo, [])+ -- pkg_desc' = updatePackageDescription hooked_buildinfo pkg_desc+++ -- writeHookedBuildInfo buildinfo_file hooked_buildinfo+ -- postConf simpleUserHooks args flags pkg_desc' lbi
accelerate-llvm-native.cabal view
@@ -1,64 +1,45 @@+cabal-version: 2.2+ name: accelerate-llvm-native-version: 1.3.0.0-cabal-version: >= 1.10-tested-with: GHC >= 8.6-build-type: Simple+version: 1.4.0.0+tested-with: GHC >= 9.4+build-type: Custom synopsis: Accelerate backend for multicore CPUs description: This library implements a backend for the /Accelerate/ language which- generates LLVM-IR targeting multicore CPUs. For further information, refer+ generates LLVM IR targeting multicore CPUs. For further information, refer to the main <http://hackage.haskell.org/package/accelerate accelerate> package. . [/Dependencies/] . Haskell dependencies are available from Hackage. The following external- libraries are alse required:- .- * <http://llvm.org LLVM>- .- * <http://sourceware.org/libffi/ libFFI>- .- [/Installing LLVM/]- .- /Homebrew/- .- Example using Homebrew on macOS:- .- > brew install llvm-hs/llvm/llvm-9- .- /Debian & Ubuntu/- .- For Debian/Ubuntu based Linux distributions, the LLVM.org website provides- binary distribution packages. Check <http://apt.llvm.org apt.llvm.org> for- instructions for adding the correct package database for your OS version,- and then:- .- > apt-get install llvm-9-dev- .- /Building from source/+ dependencies are also required: .- If your OS does not have an appropriate LLVM distribution available, you can- also build from source. Detailed build instructions are available on- <http://releases.llvm.org/9.0.0/docs/CMake.html LLVM.org>. Make sure to- include the cmake build options- @-DLLVM_BUILD_LLVM_DYLIB=ON -DLLVM_LINK_LLVM_DYLIB=ON@ so that the @libLLVM@- shared library will be built.+ * <https://clang.llvm.org/ clang> (not used to compile C code, but to compile generated LLVM IR via a mostly LLVM-version-independent interface)+ * <https://sourceware.org/libffi/ libFFI> .+ For installation instructions, see the <https://github.com/AccelerateHS/accelerate-llvm#readme README>. -license: BSD3+license: BSD-3-Clause license-file: LICENSE author: Trevor L. McDonell maintainer: Trevor L. McDonell <trevor.mcdonell@gmail.com> bug-reports: https://github.com/AccelerateHS/accelerate/issues category: Accelerate, Compilers/Interpreters, Concurrency, Data, Parallelism -extra-source-files:+extra-doc-files: CHANGELOG.md README.md +custom-setup+ setup-depends:+ base >= 4.10 && < 5+ , Cabal >= 2 && < 3.18+ , filepath + -- Build configuration -- ------------------- @@ -88,11 +69,11 @@ Data.Array.Accelerate.LLVM.Native.Compile Data.Array.Accelerate.LLVM.Native.Compile.Cache- Data.Array.Accelerate.LLVM.Native.Compile.Optimise Data.Array.Accelerate.LLVM.Native.Link Data.Array.Accelerate.LLVM.Native.Link.Cache Data.Array.Accelerate.LLVM.Native.Link.Object+ Data.Array.Accelerate.LLVM.Native.Link.Runtime Data.Array.Accelerate.LLVM.Native.Embed @@ -106,28 +87,42 @@ Data.Array.Accelerate.LLVM.Native.Plugin.Annotation Data.Array.Accelerate.LLVM.Native.Plugin.BuildInfo + Control.Concurrent.Extra+ Paths_accelerate_llvm_native + autogen-modules:+ Paths_accelerate_llvm_native+ build-depends: base >= 4.10 && < 5- , accelerate == 1.3.*- , accelerate-llvm == 1.3.*+ , accelerate == 1.4.*+ , accelerate-llvm == 1.4.* , bytestring >= 0.10.4- , cereal >= 0.4- , containers >= 0.5 && < 0.7+ , containers >= 0.5 && < 0.9 , deepseq >= 1.4 , directory >= 1.0 , dlist >= 0.6 , filepath >= 1.0+ , formatting >= 7.0 , ghc , hashable >= 1.0 , libffi >= 0.1- , llvm-hs >= 4.1 && < 9.1- , llvm-hs-pure >= 4.1 && < 9.1+ -- , llvm-pretty >= 0.12 , lockfree-queue >= 0.2 , mtl >= 2.2.1+ -- only used to render llvm-pretty output+ , pretty+ , process >= 1.4.3+ -- TODO: These are only used for lifting ByteStrings. bytestring+ -- 0.11.2.0 include its own, better lifting instances. Once+ -- that's stable, we can remove this dependency and bump+ -- bytestring's version bound.+ , th-lift-instances , template-haskell+ , text >= 1.2 , unique+ , unordered-containers >= 0.2 , vector >= 0.11 hs-source-dirs:@@ -141,52 +136,27 @@ -Wall -fwarn-tabs - ghc-prof-options:- -caf-all- -auto-all-- if impl(ghc >= 8.0)- ghc-options:- -Wmissed-specialisations-- if os(darwin)- other-modules:- Data.Array.Accelerate.LLVM.Native.Link.MachO-+ if os(windows) build-depends:- ghc-prim- , unix >= 2.7-- build-tools:- c2hs >= 0.25-- if os(linux)- other-modules:- Data.Array.Accelerate.LLVM.Native.Link.ELF-+ Win32+ else build-depends:- ghc-prim- , unix >= 2.7-- build-tools:- c2hs >= 0.25-- if os(windows)- other-modules:- Data.Array.Accelerate.LLVM.Native.Link.COFF-- -- build-depends:+ unix >= 2.7 test-suite nofib-llvm-native type: exitcode-stdio-1.0 hs-source-dirs: test/nofib main-is: Main.hs+ other-modules:+ Data.Array.Accelerate.LLVM.Native.NoFib.RunQ build-depends: base >= 4.10 , accelerate , accelerate-llvm-native+ , tasty+ , tasty-hunit default-language: Haskell2010@@ -207,7 +177,7 @@ 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
+ src/Control/Concurrent/Extra.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnliftedFFITypes #-}+{-# OPTIONS_GHC -fobject-code #-}+-- |+-- Module : Control.Concurrent.Extra+-- Copyright : [2021] The Accelerate Team+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Control.Concurrent.Extra (++ getThreadId,++) where++import Data.Int+import Foreign.C.Types+import GHC.Conc ( ThreadId(..) )+import GHC.Exts ( ThreadId# )+++-- Stolen from GHC.Conc.Sync+--+getThreadId :: ThreadId -> Int32+getThreadId (ThreadId t#) =+ case getThreadId# t# of+ CInt i -> i++foreign import ccall unsafe "rts_getThreadId" getThreadId# :: ThreadId# -> CInt+
src/Data/Array/Accelerate/LLVM/Native.hs view
@@ -2,11 +2,13 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native@@ -80,11 +82,12 @@ import Control.Monad.Trans import System.IO.Unsafe-import Text.Printf-import qualified Language.Haskell.TH as TH+import qualified Data.Array.Accelerate.TH.Compat as TH import qualified Language.Haskell.TH.Syntax as TH +import GHC.Stack + -- Accelerate: LLVM backend for multicore CPUs -- ------------------------------------------- @@ -92,48 +95,54 @@ -- -- /NOTE:/ it is recommended to use 'runN' or 'runQ' whenever possible. ---run :: Arrays a => Acc a -> a-run = runWith defaultTarget+run :: (Arrays a, HasCallStack) => Acc a -> a+run a = withFrozenCallStack $ runWith defaultTarget a -- | As 'run', but execute using the specified target (thread gang). ---runWith :: Arrays a => Native -> Acc a -> a-runWith target a = unsafePerformIO (runWithIO target a)+runWith :: (Arrays a, HasCallStack) => Native -> Acc a -> a+runWith target a+ = withFrozenCallStack+ $ unsafePerformIO (runWithIO target a) -- | As 'run', but allow the computation to run asynchronously and return -- immediately without waiting for the result. The status of the computation can -- be queried using 'wait', 'poll', and 'cancel'. ---runAsync :: Arrays a => Acc a -> IO (Async a)-runAsync = runAsyncWith defaultTarget+runAsync :: (Arrays a, HasCallStack) => Acc a -> IO (Async a)+runAsync a+ = withFrozenCallStack+ $ runAsyncWith defaultTarget a -- | As 'runAsync', but execute using the specified target (thread gang). ---runAsyncWith :: Arrays a => Native -> Acc a -> IO (Async a)-runAsyncWith target a = async (runWithIO target a)+runAsyncWith :: (Arrays a, HasCallStack) => Native -> Acc a -> IO (Async a)+runAsyncWith target a+ = withFrozenCallStack+ $ async (runWithIO target a) -runWithIO :: Arrays a => Native -> Acc a -> IO a+runWithIO :: (Arrays a, HasCallStack) => Native -> Acc a -> IO a runWithIO target a = execute where !acc = convertAcc a execute = do dumpGraph acc evalNative target $ do- build <- phase "compile" elapsedS (compileAcc acc) >>= dumpStats- exec <- phase "link" elapsedS (linkAcc build)- res <- phase "execute" elapsedP (evalPar (executeAcc exec >>= getArrays (arraysR exec)))+ build <- phase Compile elapsedS (compileAcc acc) >>= dumpStats+ exec <- phase Link elapsedS (linkAcc build)+ res <- phase Execute elapsedP (evalPar (executeAcc exec >>= getArrays (arraysR exec))) return $ toArr res -- | This is 'runN', specialised to an array program of one argument. ---run1 :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> b-run1 = run1With defaultTarget+run1 :: (Arrays a, Arrays b, HasCallStack) => (Acc a -> Acc b) -> a -> b+run1 = withFrozenCallStack $ run1With defaultTarget -- | As 'run1', but execute using the specified target (thread gang). ---run1With :: (Arrays a, Arrays b) => Native -> (Acc a -> Acc b) -> a -> b-run1With = runNWith+run1With :: (Arrays a, Arrays b, HasCallStack) => Native -> (Acc a -> Acc b) -> a -> b+run1With = withFrozenCallStack $ runNWith -- | Prepare and execute an embedded array program.@@ -177,20 +186,22 @@ -- See also 'runQ', which compiles the Accelerate program at _Haskell_ compile -- time, thus eliminating the runtime overhead altogether. ---runN :: Afunction f => f -> AfunctionR f-runN = runNWith defaultTarget+runN :: (Afunction f, HasCallStack) => f -> AfunctionR f+runN = withFrozenCallStack $ runNWith defaultTarget -- | As 'runN', but execute using the specified target (thread gang). ---runNWith :: forall f. Afunction f => Native -> f -> AfunctionR f-runNWith target f = go (afunctionRepr @f) afun (return Empty)+runNWith :: forall f. (Afunction f, HasCallStack) => Native -> f -> AfunctionR f+runNWith target f+ = withFrozenCallStack+ $ go (afunctionRepr @f) afun (return Empty) where !acc = convertAfun f !afun = unsafePerformIO $ do dumpGraph acc evalNative target $ do- build <- phase "compile" elapsedS (compileAfun acc) >>= dumpStats- link <- phase "link" elapsedS (linkAfun build)+ build <- phase Compile elapsedS (compileAfun acc) >>= dumpStats+ link <- phase Link elapsedS (linkAfun build) return link go :: AfunctionRepr t (AfunctionR t) (ArraysFunctionR t)@@ -202,7 +213,7 @@ a <- useRemoteAsync (Sugar.arraysR @a) $ fromArr arrs return (aenv `push` (lhs, a)) in go repr l k'- go AfunctionReprBody (Abody b) k = unsafePerformIO . phase "execute" elapsedP . evalNative target . evalPar $ do+ go AfunctionReprBody (Abody b) k = unsafePerformIO . phase Execute elapsedP . evalNative target . evalPar $ do aenv <- k res <- executeOpenAcc b aenv arrs <- getArrays (arraysR b) res@@ -212,31 +223,31 @@ -- | As 'run1', but execute asynchronously. ---run1Async :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> IO (Async b)-run1Async = run1AsyncWith defaultTarget+run1Async :: (Arrays a, Arrays b, HasCallStack) => (Acc a -> Acc b) -> a -> IO (Async b)+run1Async = withFrozenCallStack $ run1AsyncWith defaultTarget -- | As 'run1Async', but execute using the specified target (thread gang). ---run1AsyncWith :: (Arrays a, Arrays b) => Native -> (Acc a -> Acc b) -> a -> IO (Async b)-run1AsyncWith = runNAsyncWith+run1AsyncWith :: (Arrays a, Arrays b, HasCallStack) => Native -> (Acc a -> Acc b) -> a -> IO (Async b)+run1AsyncWith = withFrozenCallStack runNAsyncWith -- | As 'runN', but execute asynchronously. ---runNAsync :: (Afunction f, RunAsync r, ArraysFunctionR f ~ RunAsyncR r) => f -> r-runNAsync = runNAsyncWith defaultTarget+runNAsync :: (Afunction f, RunAsync r, ArraysFunctionR f ~ RunAsyncR r, HasCallStack) => f -> r+runNAsync = withFrozenCallStack $ runNAsyncWith defaultTarget -- | As 'runNWith', but execute asynchronously. ---runNAsyncWith :: (Afunction f, RunAsync r, ArraysFunctionR f ~ RunAsyncR r) => Native -> f -> r-runNAsyncWith target f = exec+runNAsyncWith :: (Afunction f, RunAsync r, ArraysFunctionR f ~ RunAsyncR r, HasCallStack) => Native -> f -> r+runNAsyncWith target f = withFrozenCallStack exec where !acc = convertAfun f !afun = unsafePerformIO $ do dumpGraph acc evalNative target $ do- build <- phase "compile" elapsedS (compileAfun acc) >>= dumpStats- link <- phase "link" elapsedS (linkAfun build)+ build <- phase Compile elapsedS (compileAfun acc) >>= dumpStats+ link <- phase Link elapsedS (linkAfun build) return link !exec = runAsync' target afun (return Empty) @@ -256,7 +267,7 @@ instance Arrays b => RunAsync (IO (Async b)) where type RunAsyncR (IO (Async b)) = ArraysR b runAsync' _ Alam{} _ = error "runAsync: function not fully applied"- runAsync' target (Abody b) k = async . phase "execute" elapsedP . evalNative target . evalPar $ do+ runAsync' target (Abody b) k = async . phase Execute elapsedP . evalNative target . evalPar $ do aenv <- k ans <- executeOpenAcc b aenv arrs <- getArrays (arraysR b) ans@@ -266,13 +277,13 @@ -- | Stream a lazily read list of input arrays through the given program, -- collecting results as we go. ---stream :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> [a] -> [b]-stream = streamWith defaultTarget+stream :: (Arrays a, Arrays b, HasCallStack) => (Acc a -> Acc b) -> [a] -> [b]+stream = withFrozenCallStack $ streamWith defaultTarget -- | As 'stream', but execute using the specified target (thread gang). ---streamWith :: (Arrays a, Arrays b) => Native -> (Acc a -> Acc b) -> [a] -> [b]-streamWith target f arrs = map go arrs+streamWith :: (Arrays a, Arrays b, HasCallStack) => Native -> (Acc a -> Acc b) -> [a] -> [b]+streamWith target f arrs = withFrozenCallStack $ map go arrs where !go = run1With target f @@ -327,8 +338,10 @@ -- -- @since 1.1.0.0 ---runQ :: Afunction f => f -> TH.ExpQ-runQ = runQ' [| unsafePerformIO |] [| defaultTarget |]+runQ :: (Afunction f, HasCallStack) => f -> TH.ExpQ+runQ+ = withFrozenCallStack+ $ runQ' [| unsafePerformIO |] [| defaultTarget |] -- | Ahead-of-time analogue of 'runNWith'. See 'runQ' for more information. --@@ -338,10 +351,11 @@ -- -- @since 1.1.0.0 ---runQWith :: Afunction f => f -> TH.ExpQ-runQWith f = do- target <- TH.newName "target"- TH.lamE [TH.varP target] (runQ' [| unsafePerformIO |] (TH.varE target) f)+runQWith :: (Afunction f, HasCallStack) => f -> TH.ExpQ+runQWith f =+ withFrozenCallStack $ do+ target <- TH.newName "target"+ TH.lamE [TH.varP target] (runQ' [| unsafePerformIO |] (TH.varE target) f) -- | Ahead-of-time analogue of 'runNAsync'. See 'runQ' for more information.@@ -352,8 +366,10 @@ -- -- @since 1.1.0.0 ---runQAsync :: Afunction f => f -> TH.ExpQ-runQAsync = runQ' [| async |] [| defaultTarget |]+runQAsync :: (Afunction f, HasCallStack) => f -> TH.ExpQ+runQAsync+ = withFrozenCallStack+ $ runQ' [| async |] [| defaultTarget |] -- | Ahead-of-time analogue of 'runNAsyncWith'. See 'runQ' for more information. --@@ -363,13 +379,14 @@ -- -- @since 1.1.0.0 ---runQAsyncWith :: Afunction f => f -> TH.ExpQ-runQAsyncWith f = do- target <- TH.newName "target"- TH.lamE [TH.varP target] (runQ' [| async |] (TH.varE target) f)+runQAsyncWith :: (Afunction f, HasCallStack) => f -> TH.ExpQ+runQAsyncWith f =+ withFrozenCallStack $ do+ target <- TH.newName "target"+ TH.lamE [TH.varP target] (runQ' [| async |] (TH.varE target) f) -runQ' :: forall f. Afunction f => TH.ExpQ -> TH.ExpQ -> f -> TH.ExpQ+runQ' :: forall f. (Afunction f, HasCallStack) => TH.ExpQ -> TH.ExpQ -> f -> TH.ExpQ runQ' using target f = do #if MIN_VERSION_template_haskell(2,13,0) -- The plugin ensures that objects are loaded correctly into GHCi@@ -380,7 +397,7 @@ in TH.runIO $ do dumpGraph acc evalNative defaultTarget $- phase "compile" elapsedS (compileAfun acc) >>= dumpStats+ phase Compile elapsedS (compileAfun acc) >>= dumpStats -- generate a lambda function with the correct number of arguments and -- apply directly to the body expression.@@ -394,8 +411,8 @@ go (Alam lhs l) xs as stmts = do x <- TH.newName "x" -- lambda bound variable a <- TH.newName "a" -- local array name- s <- TH.bindS (TH.varP a) [| useRemoteAsync $(TH.unTypeQ $ liftArraysR (lhsToTupR lhs)) (fromArr $(TH.varE x)) |]- go l (TH.varP x : xs) ([| ($(TH.unTypeQ $ liftALeftHandSide lhs), $(TH.varE a)) |] : as) (return s : stmts)+ let s = TH.bindS (TH.varP a) [| useRemoteAsync $(TH.unTypeCode $ liftArraysR (lhsToTupR lhs)) (fromArr $(TH.varE x)) |]+ go l (TH.varP x : xs) ([| ($(TH.unTypeCode $ liftALeftHandSide lhs), $(TH.varE a)) |] : as) (s : stmts) go (Abody b) xs as stmts = do r <- TH.newName "r" -- result@@ -405,10 +422,10 @@ body = embedOpenAcc defaultTarget b -- TH.lamE (reverse xs)- [| $using . phase "execute" elapsedP . evalNative $target . evalPar $+ [| $using . phase Execute elapsedP . evalNative $target . evalPar $ $(TH.doE ( reverse stmts ++- [ TH.bindS (TH.varP r) [| executeOpenAcc $(TH.unTypeQ body) $aenv |]- , TH.bindS (TH.varP s) [| getArrays $(TH.unTypeQ (liftArraysR (arraysR b))) $(TH.varE r) |]+ [ TH.bindS (TH.varP r) [| executeOpenAcc $(TH.unTypeCode body) $aenv |]+ , TH.bindS (TH.varP s) [| getArrays $(TH.unTypeCode (liftArraysR (arraysR b))) $(TH.varE r) |] , TH.noBindS [| return $ toArr $(TH.varE s) |] ])) |]@@ -421,7 +438,4 @@ dumpStats :: MonadIO m => a -> m a dumpStats x = liftIO dumpSimplStats >> return x--phase :: MonadIO m => String -> (Double -> Double -> String) -> m a -> m a-phase n fmt go = timed dump_phases (\wall cpu -> printf "phase %s: %s" n (fmt wall cpu)) go
src/Data/Array/Accelerate/LLVM/Native/CodeGen/Base.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wno-orphans #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.Base -- Copyright : [2015..2020] The Accelerate Team@@ -20,29 +21,23 @@ import Data.Array.Accelerate.LLVM.CodeGen.IR import Data.Array.Accelerate.LLVM.CodeGen.Module import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Profile import Data.Array.Accelerate.LLVM.CodeGen.Sugar import Data.Array.Accelerate.LLVM.Compile.Cache import Data.Array.Accelerate.LLVM.Native.Target ( Native ) import Data.Array.Accelerate.Representation.Shape-import Data.Array.Accelerate.Representation.Type-import Data.Array.Accelerate.Type -import LLVM.AST.Type.Downcast import LLVM.AST.Type.Name-import qualified LLVM.AST.Global as LLVM-import qualified LLVM.AST.Type as LLVM+import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty as LP -import Control.Monad-import Data.Monoid import Data.String-import Text.Printf-import Prelude as P+import qualified Data.ByteString.Short.Char8 as S8 -- | Generate function parameters that will specify the first and last (linear) -- index of the array this thread should evaluate. ---gangParam :: ShapeR sh -> (Operands sh, Operands sh, [LLVM.Parameter])+gangParam :: ShapeR sh -> (Operands sh, Operands sh, [LP.Typed LP.Ident]) gangParam shr = let start = "ix.start" end = "ix.end"@@ -51,12 +46,12 @@ (local tp start, local tp end, parameter tp start ++ parameter tp end) --- | The worker ID of the calling thread----gangId :: (Operands Int, [LLVM.Parameter])-gangId =- let tid = "ix.tid"- in (local (TupRsingle scalarTypeInt) tid, [ scalarParameter scalarType tid ] )+-- -- | The worker ID of the calling thread+-- --+-- gangId :: (Operands Int, [LLVM.Parameter])+-- gangId =+-- let tid = "ix.tid"+-- in (local (TupRsingle scalarTypeInt) tid, [ downcast scalarTypeInt ] ) -- Global function definitions@@ -71,25 +66,36 @@ -- | Create a single kernel program ---makeOpenAcc :: UID -> Label -> [LLVM.Parameter] -> CodeGen Native () -> CodeGen Native (IROpenAcc Native aenv a)+makeOpenAcc :: UID -> Label -> [LP.Typed LP.Ident] -> CodeGen Native () -> CodeGen Native (IROpenAcc Native aenv a) makeOpenAcc uid name param kernel = do- body <- makeKernel (name <> fromString (printf "_%s" (show uid))) param kernel+ body <- makeKernel (name <> fromString ('_' : show uid)) param kernel return $ IROpenAcc [body] -- | Create a complete kernel function by running the code generation process -- specified in the final parameter. ---makeKernel :: Label -> [LLVM.Parameter] -> CodeGen Native () -> CodeGen Native (Kernel Native aenv a)-makeKernel name param kernel = do+makeKernel :: Label -> [LP.Typed LP.Ident] -> CodeGen Native () -> CodeGen Native (Kernel Native aenv a)+makeKernel name@(Label sbs) param kernel = do+ zone <- zone_begin_alloc 0 [] (S8.unpack sbs) [] 0 _ <- kernel+ _ <- zone_end zone+ return_ code <- createBlocks- return $ Kernel+ return $ Kernel { kernelMetadata = KM_Native ()- , unKernel = LLVM.functionDefaults- { LLVM.returnType = LLVM.VoidType- , LLVM.name = downcast name- , LLVM.parameters = (param, False)- , LLVM.basicBlocks = code- }+ , unKernel = LP.Define+ { LP.defLinkage = Just LP.DLLExport -- ensure the symbols are visible on Windows+ , LP.defVisibility = Nothing+ , LP.defRetType = LP.PrimType LP.Void+ , LP.defName = labelToPrettyS name+ , LP.defArgs = param+ , LP.defVarArgs = False+ , LP.defAttrs = []+ , LP.defSection = Nothing+ , LP.defGC = Nothing+ , LP.defBody = code+ , LP.defMetadata = mempty+ , LP.defComdat = Nothing+ } }
src/Data/Array/Accelerate/LLVM/Native/CodeGen/Fold.hs view
@@ -99,9 +99,7 @@ writeArray TypeInt arrOut i r - return_ - -- Reduce an array to single element. -- -- Since reductions consume arrays that have been fused into them,@@ -164,8 +162,8 @@ reduceFromTo eR (indexHead start) (indexHead end) (app2 combine) z (app1 (delayedLinearIndex arrIn)) Nothing -> reduce1FromTo eR (indexHead start) (indexHead end) (app2 combine) (app1 (delayedLinearIndex arrIn)) writeArray TypeInt arrOut zero r- return_ + -- Parallel reduction of an entire array to a single element, step 1. -- -- Threads reduce each stripe of the input into a temporary array, incorporating@@ -197,7 +195,6 @@ r <- reduce1FromTo eR (indexHead start) (indexHead end) (app2 combine) (app1 (delayedLinearIndex arrIn)) writeArray TypeInt arrTmp piece r - return_ -- Parallel reduction of an entire array to a single element, step 2. --@@ -229,7 +226,6 @@ reduceFromTo eR (indexHead start) (indexHead end) (app2 combine) z (readArray TypeInt arrTmp) Nothing -> reduce1FromTo eR (indexHead start) (indexHead end) (app2 combine) (readArray TypeInt arrTmp) writeArray TypeInt arrOut zero r- return_ -- Exclusive reductions over empty arrays (of any dimension) fill the lower
src/Data/Array/Accelerate/LLVM/Native/CodeGen/FoldSeg.hs view
@@ -140,5 +140,3 @@ writeArray TypeInt arrOut ii r - return_-
src/Data/Array/Accelerate/LLVM/Native/CodeGen/Generate.hs view
@@ -24,7 +24,7 @@ import Data.Array.Accelerate.LLVM.CodeGen.Sugar import Data.Array.Accelerate.LLVM.Compile.Cache -import Data.Array.Accelerate.LLVM.Native.Target ( Native )+import Data.Array.Accelerate.LLVM.Native.Target ( Native ) import Data.Array.Accelerate.LLVM.Native.CodeGen.Base import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop @@ -50,6 +50,4 @@ imapNestFromTo (arrayRshape repr) start end shOut $ \ix i -> do r <- app1 apply ix -- apply generator function writeArray TypeInt arrOut i r -- store result-- return_
src/Data/Array/Accelerate/LLVM/Native/CodeGen/Map.hs view
@@ -29,7 +29,7 @@ import Data.Array.Accelerate.LLVM.CodeGen.Sugar import Data.Array.Accelerate.LLVM.Compile.Cache -import Data.Array.Accelerate.LLVM.Native.Target ( Native )+import Data.Array.Accelerate.LLVM.Native.Target ( Native ) import Data.Array.Accelerate.LLVM.Native.CodeGen.Base import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop @@ -97,6 +97,4 @@ xs <- readArray TypeInt arrIn i ys <- app1 apply xs writeArray TypeInt arrOut i ys-- return_
src/Data/Array/Accelerate/LLVM/Native/CodeGen/Permute.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}@@ -40,7 +39,7 @@ import Data.Array.Accelerate.LLVM.Native.CodeGen.Base import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop -import LLVM.AST.Type.AddrSpace+import LLVM.AST.Type.GetElementPtr import LLVM.AST.Type.Instruction import LLVM.AST.Type.Instruction.Atomic import LLVM.AST.Type.Instruction.RMW as RMW@@ -118,9 +117,7 @@ writeArray TypeInt arrOut j r - return_ - -- Parallel forward permutation has to take special care because different -- threads could concurrently try to update the same memory location. Where -- available we make use of special atomic instructions and other optimisations,@@ -189,26 +186,14 @@ _ | TupRsingle (SingleScalarType s) <- arrayRtype repr , adata <- irArrayData arrOut -> do- addr <- instr' $ GetElementPtr (asPtr defaultAddrSpace (op s adata)) [op integralType j]+ addr <- instr' $ GetElementPtr $ GEP1 (SingleScalarType s) (asPtr defaultAddrSpace (op s adata)) (op integralType j) -- case s of-#if MIN_VERSION_llvm_hs(10,0,0) NumSingleType t -> void . instr' $ AtomicRMW t NonVolatile rmw addr (op t r) (CrossThread, AcquireRelease)-#else- NumSingleType t- | IntegralNumType{} <- t -> void . instr' $ AtomicRMW t NonVolatile rmw addr (op t r) (CrossThread, AcquireRelease)- | RMW.Add <- rmw -> atomicCAS_rmw s (A.add t r) addr- | RMW.Sub <- rmw -> atomicCAS_rmw s (A.sub t r) addr-#endif- _ | RMW.Min <- rmw -> atomicCAS_cmp s A.lt addr (op s r)- | RMW.Max <- rmw -> atomicCAS_cmp s A.gt addr (op s r)- _ -> internalError "unexpected transition" -- _ -> internalError "unexpected transition" - return_ - -- Parallel forward permutation function which uses a spinlock to acquire -- a mutex before updating the value at that location. --@@ -248,9 +233,7 @@ r <- app2 combine x y writeArray TypeInt arrOut j r - return_ - -- Atomically execute the critical section only when the lock at the given array -- index is obtained. The thread spins waiting for the lock to be released and -- there is no backoff strategy in case the lock is contended.@@ -277,7 +260,7 @@ crit <- newBlock "spinlock.critical-section" exit <- newBlock "spinlock.exit" - addr <- instr' $ GetElementPtr (asPtr defaultAddrSpace (op integralType (irArrayData barriers))) [op integralType i]+ addr <- instr' $ GetElementPtr $ GEP1 scalarTypeWord8 (asPtr defaultAddrSpace (op integralType (irArrayData barriers))) (op integralType i) _ <- br spin -- Atomically (attempt to) set the lock slot to the locked state. If the slot
src/Data/Array/Accelerate/LLVM/Native/CodeGen/Scan.hs view
@@ -209,9 +209,7 @@ A.trip <$> next i <*> next j <*> pure w) (A.trip i1 j1 v0) - return_ - mkScan'S :: Direction -> UID@@ -271,9 +269,7 @@ writeArray TypeInt arrSum ii (A.snd r) - return_ - mkScanP :: Direction -> UID@@ -384,9 +380,7 @@ -- Final reduction result of this piece writeArray TypeInt arrTmp piece (A.thd3 r) - return_ - -- Parallel scan, step 2. -- -- A single thread performs an in-place inclusive scan of the partial block@@ -435,9 +429,7 @@ return $ A.pair i' v') (A.pair i1 v0) - return_ - -- Parallel scan, step 3. -- -- Threads combine every element of the partial block results with the carry-in@@ -498,9 +490,7 @@ RightToLeft -> app2 combine x c writeArray TypeInt arrOut i y - return_ - mkScan'P :: Direction -> UID@@ -596,9 +586,7 @@ -- Write the final reduction result of this piece writeArray TypeInt arrTmp piece (A.thd3 r) - return_ - -- Parallel scan', step 2 -- -- Identical to mkScanP2, except we store the total scan result into a separate@@ -649,9 +637,7 @@ writeArray TypeInt arrSum (liftInt 0) (A.snd r) - return_ - -- Parallel scan', step 3 -- -- Similar to mkScanP3, except that indices are shifted by one since the output@@ -709,6 +695,4 @@ LeftToRight -> app2 combine c x RightToLeft -> app2 combine x c writeArray TypeInt arrOut i y-- return_
src/Data/Array/Accelerate/LLVM/Native/CodeGen/Stencil.hs view
@@ -42,7 +42,7 @@ import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop import Data.Array.Accelerate.LLVM.Native.Target ( Native ) -import qualified LLVM.AST.Global as LLVM+import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty as LP import Control.Monad @@ -110,7 +110,7 @@ -> Gamma aenv -> ArrayR (Array sh e) -> IRFun1 Native aenv (sh -> e)- -> [LLVM.Parameter]+ -> [LP.Typed LP.Ident] -> CodeGen Native (IROpenAcc Native aenv (Array sh e)) mkInside uid aenv repr apply paramIn = let@@ -123,16 +123,15 @@ imapNestFromToTile (arrayRshape repr) 4 start end shOut $ \ix i -> do r <- app1 apply ix -- apply generator function- writeArray TypeInt arrOut i r -- store result+ writeArray TypeInt arrOut i r -- store result - return_ mkBorder :: UID -> Gamma aenv -> ArrayR (Array sh e) -> IRFun1 Native aenv (sh -> e)- -> [LLVM.Parameter]+ -> [LP.Typed LP.Ident] -> CodeGen Native (IROpenAcc Native aenv (Array sh e)) mkBorder uid aenv repr apply paramIn = let@@ -146,8 +145,6 @@ imapNestFromTo (arrayRshape repr) start end shOut $ \ix i -> do r <- app1 apply ix -- apply generator function writeArray TypeInt arrOut i r -- store result-- return_ imapNestFromToTile
src/Data/Array/Accelerate/LLVM/Native/CodeGen/Transform.hs view
@@ -59,5 +59,3 @@ b <- app1 f a writeArray TypeInt arrOut i' b - return_-
src/Data/Array/Accelerate/LLVM/Native/Compile.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.Compile@@ -19,51 +20,64 @@ ) where import Data.Array.Accelerate.AST ( PreOpenAcc )+import Data.Array.Accelerate.Error import Data.Array.Accelerate.Trafo.Delayed import Data.Array.Accelerate.LLVM.CodeGen import Data.Array.Accelerate.LLVM.Compile import Data.Array.Accelerate.LLVM.State+import Data.Array.Accelerate.LLVM.Target.ClangInfo ( hostLLVMVersion, llvmverFromTuple, clangExePath ) import Data.Array.Accelerate.LLVM.CodeGen.Environment ( Gamma ) import Data.Array.Accelerate.LLVM.CodeGen.Module ( Module(..) ) import Data.Array.Accelerate.LLVM.Native.CodeGen ( ) import Data.Array.Accelerate.LLVM.Native.Compile.Cache-import Data.Array.Accelerate.LLVM.Native.Compile.Optimise import Data.Array.Accelerate.LLVM.Native.Foreign ( ) import Data.Array.Accelerate.LLVM.Native.Target import qualified Data.Array.Accelerate.LLVM.Native.Debug as Debug -import LLVM.AST hiding ( Module )-import LLVM.Module as LLVM hiding ( Module )-import LLVM.Context-import LLVM.Target+import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty as P+import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty.PP as P+import qualified Text.PrettyPrint as P ( render ) +import Control.Applicative import Control.Monad.State-import Data.ByteString ( ByteString ) import Data.ByteString.Short ( ShortByteString )+import Data.List ( intercalate )+import Data.Foldable ( toList ) import Data.Maybe+import Formatting import System.Directory+import System.Environment+import System.FilePath ( (<.>) )+import qualified System.Info as Info import System.IO.Unsafe-import Text.Printf-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Short as BS-import qualified Data.Map as Map+import System.Process+import qualified Data.ByteString.Short.Char8 as SBS8+import qualified Data.Map.Strict as Map instance Compile Native where- data ObjectR Native = ObjectR { objId :: {-# UNPACK #-} !UID- , objSyms :: {- LAZY -} [ShortByteString]- , objData :: {- LAZY -} ByteString- }+ data ObjectR Native = ObjectR+ { objId :: {-# UNPACK #-} !UID+ , objSyms :: ![ShortByteString]+ , staticObjPath :: {- LAZY -} FilePath+ , sharedObjPath :: {- LAZY -} FilePath+ } compileForTarget = compile instance Intrinsic Native --- | Compile an Accelerate expression to object code+-- | Compile an Accelerate expression to object code. --+-- This compilation step creates a static object file and a shared object+-- file, on demand. The former is used in the case of @runQ@ to statically+-- link the compiled object into the executable and generate FFI imports so+-- that the compiled kernel can be embedded directly into the resulting+-- executable. The latter will convert the former into a shared object to+-- be loaded into the running executable using the system's dynamic linker.+-- compile :: PreOpenAcc DelayedOpenAcc aenv a -> Gamma aenv -> LLVM Native (ObjectR Native) compile pacc aenv = do @@ -73,42 +87,159 @@ -- functions which will be contained in the object code, but the actual -- code generation step is executed lazily. --- (uid, cacheFile) <- cacheOfPreOpenAcc pacc- Module ast md <- llvmOfPreOpenAcc uid pacc aenv+ (uid, cachePath) <- cacheOfPreOpenAcc pacc+ Module ast md <- llvmOfPreOpenAcc uid pacc aenv - let triple = fromMaybe BS.empty (moduleTargetTriple ast)- datalayout = moduleDataLayout ast- nms = [ f | Name f <- Map.keys md ]+ let staticObjFile = cachePath <.> staticObjExt+ sharedObjFile = cachePath <.> sharedObjExt+ -- triple = fromMaybe BS.empty (moduleTargetTriple ast)+ -- datalayout = moduleDataLayout ast+ nms = [ SBS8.pack f | P.Symbol f <- Map.keys md ] -- Lower the generated LLVM and produce an object file. --- -- The 'objData' field is only lazy evaluated since the object code might- -- already have been loaded into memory from a different function, in which- -- case it will be found in the linker cache.+ -- The 'staticObjPath' field is only lazily evaluated since the object+ -- code might already have been loaded into memory from a different+ -- function, in which case it will be found in the linker cache. --- obj <- liftIO . unsafeInterleaveIO $ do- exists <- doesFileExist cacheFile- recomp <- if Debug.debuggingIsEnabled then Debug.getFlag Debug.force_recomp else return False- if exists && not recomp- then do- Debug.traceIO Debug.dump_cc (printf "cc: found cached object code %s" (show uid))- B.readFile cacheFile+ o_file <- liftIO . unsafeInterleaveIO $ do+ force_recomp <- if Debug.debuggingIsEnabled then Debug.getFlag Debug.force_recomp else return False+ o_file_exists <- doesFileExist staticObjFile+ if o_file_exists && not force_recomp+ then+ Debug.traceM Debug.dump_cc ("cc: found cached object " % shown) uid - else- withContext $ \ctx ->- withModuleFromAST ctx ast $ \mdl ->- withNativeTargetMachine $ \machine ->- withTargetLibraryInfo triple $ \libinfo -> do- optimiseModule datalayout (Just machine) (Just libinfo) mdl+ else do+ -- print ast - Debug.when Debug.verbose $ do- Debug.traceIO Debug.dump_cc . B8.unpack =<< moduleLLVMAssembly mdl- Debug.traceIO Debug.dump_asm . B8.unpack =<< moduleTargetAssembly machine mdl+ -- Detect LLVM version+ -- Note: this LLVM version is incorporated in the cache path, so we're safe detecting it at runtime.+ let prettyHostLLVMVersion = intercalate "." (Prelude.map show (toList hostLLVMVersion))+ llvmver <- case llvmverFromTuple hostLLVMVersion of+ Just llvmver -> return llvmver+ Nothing -> internalError ("accelerate-llvm-native: Unsupported LLVM version: " % string)+ prettyHostLLVMVersion+ Debug.traceM Debug.dump_cc ("Using Clang at " % string % " version " % shown) clangExePath prettyHostLLVMVersion - obj <- moduleObject machine mdl- Debug.traceIO Debug.dump_cc (printf "cc: new object code %s" (show uid))- B.writeFile cacheFile obj- return obj+ -- Convert module to llvm-pretty format so that we can print it+ let unoptimisedText = P.render (P.ppLLVM llvmver (P.ppModule ast))+ Debug.when Debug.verbose $ do+ Debug.traceM Debug.dump_cc ("Unoptimised LLVM IR:\n" % string) unoptimisedText - return $! ObjectR uid nms obj+ dVerbose <- Debug.getFlag Debug.verbose+ dDumpCC <- Debug.getFlag Debug.dump_cc+ dDumpAsm <- Debug.getFlag Debug.dump_asm + let clangFlags inputType outputFlags output =+ -- '-O3' is ignored when only assembling; let's avoid clang warning about that+ (if inputType == "assembler" then [] else ["-O3"]) +++ (case takeWhile (/= '-') (SBS8.unpack nativeTargetTriple) of+ "aarch64" -> ["-mcpu=native"] -- e.g. Ampere+ "arm64" -> ["-mcpu=native"] -- e.g. Apple+ _ -> ["-march=native"]) ++ -- e.g. x86_64+ ["-c", "-o", output, "-x", inputType, "-"+ -- clang knows better what the target triple (and the data+ -- layout) should be than us, so let it override the triple, and+ -- don't warn about it+ -- TODO: change llvm-pretty so that it doesn't require us to give+ -- it a target triple+ ,"-Wno-override-module"] +++ outputFlags++ let linkOutputFlags | Info.os == "mingw32" = []+ | otherwise = ["-fPIC"]++ -- Minimise the number of clang invocations (to 1) in the common case+ -- of no verbose debug flags. If we need to print some intermediate+ -- stages, run all stages separately for simplicity, and print only the+ -- intermediate values that were requested.+ -- See llvm-project/clang/include/clang/Driver/Types.def for "-x" argument values:+ -- https://github.com/llvm/llvm-project/blob/da286c8bf69684d1612d1fc440bd9c6f1a4326df/clang/include/clang/Driver/Types.def+ if dVerbose && (dDumpCC || dDumpAsm)+ then do+ optText <- readProcess clangExePath (clangFlags "ir" ["-S", "-emit-llvm"] "-") unoptimisedText+ Debug.traceM Debug.dump_cc ("Optimised LLVM IR:\n" % string) optText+ asmText <- readProcess clangExePath (clangFlags "ir" ["-S"] "-") optText+ Debug.traceM Debug.dump_asm ("Optimised assembly:\n" % string) asmText+ _ <- readProcess clangExePath (clangFlags "assembler" linkOutputFlags staticObjFile) asmText+ return ()+ else do+ _ <- readProcess clangExePath (clangFlags "ir" linkOutputFlags staticObjFile) unoptimisedText+ return ()++ Debug.traceM Debug.dump_cc ("cc: new object code " % shown) uid++ return staticObjFile++ -- Convert the relocatable object file (created above) into a shared+ -- object file using the operating system's native linker.+ --+ -- Once again, the 'sharedObjPath' is only lazily evaluated since the+ -- object code might already have been loaded into memory from+ -- a different function.+ --+ so_file <- liftIO . unsafeInterleaveIO $ do+ force_recomp <- if Debug.debuggingIsEnabled then Debug.getFlag Debug.force_recomp else return False+ so_file_exists <- doesFileExist sharedObjFile+ if so_file_exists && not force_recomp+ then+ Debug.traceM Debug.dump_cc ("cc: found cached shared object " % shown) uid++ else do+ o_file_exists <- doesFileExist staticObjFile+ objFile <- if o_file_exists && not force_recomp+ then do+ Debug.traceM Debug.dump_cc ("cc: found cached object " % shown) uid+ return staticObjFile+ else+ return o_file++ -- LLVM doesn't seem to provide a way to build a shared object file+ -- directly, so shell out to the system linker to do this.+ --+ case Info.os of+ "darwin" ->+ -- TODO: Unclear if -lm is necessary on Darwin too; let's add it+ -- just in case. (The -lm on Linux was added to properly declare+ -- dependency on libm, so that it gets pulled in even if the main+ -- executable is statically-linked and thus does not have a dynamic+ -- libm in its address space.)+ callProcess ld ["--shared", "-o", sharedObjFile, objFile, "-undefined", "dynamic_lookup", "-lm"]+ "mingw32" -> -- windows+ callProcess ld ["--shared", "-o", sharedObjFile, objFile] -- no -lm necessary on windows+ _ -> -- linux etc.+ callProcess ld ["--shared", "-o", sharedObjFile, objFile, "-lm"]+ Debug.traceM Debug.dump_cc ("cc: new shared object " % shown) uid++ return sharedObjFile++ return $! ObjectR uid nms o_file so_file+++-- Respect the common @LD@ and @CC@ environment variables, falling back to+-- search the path for @cc@ if neither of those exist.+--+-- XXX: On Unixy systems, we use @cc@ as the default instead of @ld@ because+-- on macOS this will do the right thing, whereas 'ld --shared' will not.+-- On Windows, we just use clang as the driver to "do the right thing".+--+ld :: FilePath+ld = unsafePerformIO $ do+ let defProgram | Info.os == "mingw32" = clangExePath+ | otherwise = "cc"+ mfromEnv <- liftA2 (<|>) (lookupEnv "LD") (lookupEnv "CC")+ return (fromMaybe defProgram mfromEnv)++-- The file extension for static libraries+--+staticObjExt :: String+staticObjExt | Info.os == "mingw32" = "obj"+ | otherwise = "o"++-- The file extension used for shared libraries+--+sharedObjExt :: String+sharedObjExt = case Info.os of+ "darwin" -> "dylib"+ "mingw32" -> "dll"+ _ -> "so" -- let's just default to the unixy ".so"
src/Data/Array/Accelerate/LLVM/Native/Compile/Cache.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-orphans #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.Compile.Cache -- Copyright : [2017..2020] The Accelerate Team@@ -18,7 +17,10 @@ import Data.Array.Accelerate.LLVM.Compile.Cache import Data.Array.Accelerate.LLVM.Native.Target+import Data.Array.Accelerate.LLVM.Target.ClangInfo ( hostLLVMVersion ) +import Data.Foldable ( toList )+import Data.List ( intercalate ) import Data.Version import System.FilePath import qualified Data.ByteString.Char8 as B8@@ -29,9 +31,12 @@ instance Persistent Native where targetCacheTemplate =+ -- The "llvmpr" is for "llvm-pretty". This is to ensure we still have a+ -- sensible cache path to switch to should we ever move away from+ -- llvm-pretty again. return $ "accelerate-llvm-native-" ++ showVersion version- </> "llvm-hs-" ++ VERSION_llvm_hs+ </> "llvmpr-" ++ intercalate "." (map show (toList hostLLVMVersion)) </> S8.unpack nativeTargetTriple </> B8.unpack nativeCPUName- </> "meep.o"+ </> "meep"
− src/Data/Array/Accelerate/LLVM/Native/Compile/Optimise.hs
@@ -1,142 +0,0 @@--- |--- Module : Data.Array.Accelerate.LLVM.Native.Compile.Optimise--- Copyright : [2014..2020] The Accelerate Team--- License : BSD3------ Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>--- Stability : experimental--- Portability : non-portable (GHC extensions)-----module Data.Array.Accelerate.LLVM.Native.Compile.Optimise (-- optimiseModule--) where---- llvm-hs-import LLVM.AST.DataLayout-import LLVM.Module-import LLVM.PassManager-import LLVM.Target---- accelerate-import qualified Data.Array.Accelerate.LLVM.Native.Debug as Debug---- standard library-import Text.Printf----- | Run the standard optimisations on the given module when targeting a--- specific machine and data layout. Specifically, this will run the--- optimisation passes such that LLVM has the necessary information to--- automatically vectorise loops (whenever it deems beneficial to do so).----optimiseModule- :: Maybe DataLayout- -> Maybe TargetMachine- -> Maybe TargetLibraryInfo- -> Module- -> IO ()-optimiseModule datalayout machine libinfo mdl = do-- let p1 = defaultCuratedPassSetSpec- { optLevel = Just 3- , dataLayout = datalayout- , targetMachine = machine- , targetLibraryInfo = libinfo- , loopVectorize = Just True- , superwordLevelParallelismVectorize = Just True- }- b1 <- withPassManager p1 $ \pm -> runPassManager pm mdl-- Debug.traceIO Debug.dump_cc $- printf "llvm: optimisation did work? %s" (show b1)--{----- The first gentle optimisation pass. I think this is usually done when loading--- the module?------ This is the first section of output running 'opt -O3 -debug-pass=Arguments'------ Pass Arguments:--- -datalayout -notti -basictti -x86tti -no-aa -tbaa -targetlibinfo -basicaa--- -preverify -domtree -verify -simplifycfg -domtree -sroa -early-cse--- -lower-expect----prepass :: [Pass]-prepass =- [ SimplifyControlFlowGraph- , ScalarReplacementOfAggregates { requiresDominatorTree = True }- , EarlyCommonSubexpressionElimination- , LowerExpectIntrinsic- ]---- The main optimisation pipeline. This mostly matches the process of running--- 'opt -O3 -debug-pass=Arguments'. We are missing dead argument elimination and--- in particular, slp-vectorizer (super-word level parallelism).------ Pass Arguments:--- -targetlibinfo -datalayout -notti -basictti -x86tti -no-aa -tbaa -basicaa--- -globalopt -ipsccp -deadargelim -instcombine -simplifycfg -basiccg -prune-eh--- -inline-cost -inline -functionattrs -argpromotion -sroa -domtree -early-cse--- -lazy-value-info -jump-threading -correlated-propagation -simplifycfg--- -instcombine -tailcallelim -simplifycfg -reassociate -domtree -loops--- -loop-simplify -lcssa -loop-rotate -licm -lcssa -loop-unswitch -instcombine--- -scalar-evolution -loop-simplify -lcssa -indvars -loop-idiom -loop-deletion--- -loop-unroll -memdep -gvn -memdep -memcpyopt -sccp -instcombine--- -lazy-value-info -jump-threading -correlated-propagation -domtree -memdep -dse--- -loops -scalar-evolution -slp-vectorizer -adce -simplifycfg -instcombine--- -barrier -domtree -loops -loop-simplify -lcssa -scalar-evolution--- -loop-simplify -lcssa -loop-vectorize -instcombine -simplifycfg--- -strip-dead-prototypes -globaldce -constmerge -preverify -domtree -verify----optpass :: [Pass]-optpass =- [- InterproceduralSparseConditionalConstantPropagation -- ipsccp- , InstructionCombining- , SimplifyControlFlowGraph- , PruneExceptionHandling- , FunctionInlining { functionInliningThreshold = 275 } -- -O2 => 275- , FunctionAttributes- , ArgumentPromotion -- not needed?- , ScalarReplacementOfAggregates { requiresDominatorTree = True } -- false?- , EarlyCommonSubexpressionElimination- , JumpThreading- , CorrelatedValuePropagation- , SimplifyControlFlowGraph- , InstructionCombining- , TailCallElimination- , SimplifyControlFlowGraph- , Reassociate- , LoopRotate- , LoopInvariantCodeMotion- , LoopClosedSingleStaticAssignment- , LoopUnswitch { optimizeForSize = False }- , LoopInstructionSimplify- , InstructionCombining- , InductionVariableSimplify- , LoopIdiom- , LoopDeletion- , LoopUnroll { loopUnrollThreshold = Nothing- , count = Nothing- , allowPartial = Nothing }- , GlobalValueNumbering { noLoads = False } -- True to add memory dependency analysis- , SparseConditionalConstantPropagation- , InstructionCombining- , JumpThreading- , CorrelatedValuePropagation- , DeadStoreElimination- , defaultVectorizeBasicBlocks -- instead of slp-vectorizer?- , AggressiveDeadCodeElimination- , SimplifyControlFlowGraph- , InstructionCombining- , LoopVectorize- , InstructionCombining- , SimplifyControlFlowGraph- , GlobalDeadCodeElimination- , ConstantMerge- ]---}-
src/Data/Array/Accelerate/LLVM/Native/Debug.hs view
@@ -1,5 +1,7 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.Debug -- Copyright : [2014..2020] The Accelerate Team@@ -12,30 +14,70 @@ module Data.Array.Accelerate.LLVM.Native.Debug ( - module Data.Array.Accelerate.Debug,+ module Data.Array.Accelerate.Debug.Internal, module Data.Array.Accelerate.LLVM.Native.Debug, ) where -import Data.Array.Accelerate.Debug hiding ( elapsed )-import qualified Data.Array.Accelerate.Debug as Debug+import Data.Array.Accelerate.Debug.Internal hiding ( elapsed )+import qualified Data.Array.Accelerate.Debug.Internal as Debug -import Text.Printf+import Formatting+import Formatting.Internal+import Data.Text.Lazy.Builder +import Control.Monad.Trans + -- | Display elapsed wall and CPU time, together with speedup fraction -- {-# INLINEABLE elapsedP #-}-elapsedP :: Double -> Double -> String-elapsedP wallTime cpuTime =- printf "%s (wall), %s (cpu), %.2f x speedup"- (showFFloatSIBase (Just 3) 1000 wallTime "s")- (showFFloatSIBase (Just 3) 1000 cpuTime "s")- (cpuTime / wallTime)+elapsedP :: Format r (Double -> Double -> r)+elapsedP = Format $ \k cpuTime wallTime ->+ k $ bformat (formatSIBase (Just 3) 1000 % "s (wall), " % formatSIBase (Just 3) 1000 % "s (cpu), " % fixed 2 % " x speedup")+ wallTime+ cpuTime+ (wallTime/cpuTime) -- | Display elapsed wall and CPU time -- {-# INLINEABLE elapsedS #-}-elapsedS :: Double -> Double -> String+elapsedS :: Format r (Double -> Double -> r) elapsedS = Debug.elapsed+++data Phase = Compile | Link | Execute++buildPhase :: Phase -> Builder+buildPhase = \case+ Compile -> "compile"+ Link -> "link"+ Execute -> "execute"++phase :: MonadIO m => Phase -> Format Builder (Double -> Double -> Builder) -> m a -> m a+phase p fmt = timed dump_phases (now ("phase " <> buildPhase p <> ": ") % fmt)++{--+phase :: (MonadIO m, HasCallStack) => Phase -> (Double -> Double -> Builder) -> m a -> m a+phase p fmt go = do+ let (p_phase, sz_phase) = case p of+ Compile -> (Ptr $(litE (stringPrimL (map (fromIntegral . ord) "compile\0"))), 7)+ Link -> (Ptr $(litE (stringPrimL (map (fromIntegral . ord) "link\0"))), 4)+ Execute -> (Ptr $(litE (stringPrimL (map (fromIntegral . ord) "execute\0"))), 7)+ (line, file, fun) = case getCallStack callStack of+ [] -> (0, [], [])+ ((f,l):_) -> (srcLocStartLine l, srcLocFile l, f)+ --+ zone <- liftIO $+ withCStringLen file $ \(p_file, sz_file) ->+ withCStringLen fun $ \(p_fun, sz_fun) -> do+ srcloc <- alloc_srcloc_name (fromIntegral line) p_file (fromIntegral sz_file) p_fun (fromIntegral sz_fun) p_phase sz_phase+ zone <- emit_zone_begin srcloc 1+ return zone++ result <- timed dump_phases (\wall cpu -> build "phase {}: {}" (p, fmt wall cpu)) go+ _ <- liftIO $ emit_zone_end zone++ return result+--}
src/Data/Array/Accelerate/LLVM/Native/Embed.hs view
@@ -22,7 +22,6 @@ import Data.ByteString.Short.Char8 as S8 import Data.ByteString.Short.Extra as BS-import Data.ByteString.Short.Internal as BS import Data.Array.Accelerate.Lifetime @@ -40,16 +39,15 @@ import Control.Monad import Data.Hashable import Foreign.Ptr-import Language.Haskell.TH ( Q, TExp )+import Data.Array.Accelerate.TH.Compat ( Q, CodeQ ) import Numeric+import System.FilePath ( (<.>) ) import System.IO.Unsafe-import qualified Language.Haskell.TH as TH+import qualified Data.Array.Accelerate.TH.Compat as TH import qualified Language.Haskell.TH.Syntax as TH -#if __GLASGOW_HASKELL__ >= 806 import Data.Maybe import qualified Data.Set as Set-#endif instance Embed Native where@@ -59,25 +57,28 @@ -- and generate FFI declarations to access the external functions of that file. -- The returned ExecutableR references the new FFI declarations. ---embed :: Native -> ObjectR Native -> Q (TExp (ExecutableR Native))-embed target (ObjectR uid nms !_) = do- objFile <- getObjectFile- funtab <- forM nms $ \fn -> return [|| ( $$(liftSBS (BS.take (BS.length fn - 65) fn)), $$(makeFFI fn objFile) ) ||]- --- [|| NativeR (unsafePerformIO $ newLifetime (FunctionTable $$(listE funtab))) ||]+embed :: Native -> ObjectR Native -> CodeQ (ExecutableR Native)+embed target (ObjectR uid nms !_ _) =+ TH.bindCode getObjectFile $ \objFile ->+ [|| NativeR (unsafePerformIO $ newLifetime (FunctionTable $$(listE $ makeTable objFile nms))) ||] where- listE :: [Q (TExp a)] -> Q (TExp [a])- listE xs = TH.unsafeTExpCoerce (TH.listE (map TH.unTypeQ xs))+ listE :: [CodeQ a] -> CodeQ [a]+ listE xs = TH.unsafeCodeCoerce (TH.listE (map TH.unTypeCode xs)) - makeFFI :: ShortByteString -> FilePath -> Q (TExp (FunPtr ()))- makeFFI (S8.unpack -> fn) objFile = do- i <- TH.runIO newUnique- fn' <- TH.newName ("__accelerate_llvm_native_" ++ showHex (hash i) [])- dec <- TH.forImpD TH.CCall TH.Unsafe ('&':fn) fn' [t| FunPtr () |]- ann <- TH.pragAnnD (TH.ValueAnnotation fn') [| (Object objFile) |]- TH.addTopDecls [dec, ann]- TH.unsafeTExpCoerce (TH.varE fn')+ makeTable :: FilePath -> [ShortByteString] -> [CodeQ (ShortByteString, FunPtr ())]+ makeTable objFile = map (\fn -> [|| ( $$(liftSBS fn), $$(makeFFI fn objFile) ) ||]) + makeFFI :: ShortByteString -> FilePath -> CodeQ (FunPtr ())+ makeFFI (S8.unpack -> fn) objFile = TH.bindCode go (TH.unsafeCodeCoerce . return)+ where+ go = do+ i <- TH.runIO newUnique+ fn' <- TH.newName ("__accelerate_llvm_native_" ++ showHex (hash i) [])+ dec <- TH.forImpD TH.CCall TH.Unsafe ('&':fn) fn' [t| FunPtr () |]+ ann <- TH.pragAnnD (TH.ValueAnnotation fn') [| (Object objFile) |]+ TH.addTopDecls [dec, ann]+ TH.varE fn'+ -- Note: [Template Haskell and raw object files] -- -- We can only addForeignFilePath once per object file, otherwise the@@ -89,14 +90,22 @@ -- getObjectFile :: Q FilePath getObjectFile = do- this <- TH.runIO (evalNative target (cacheOfUID uid))+ cachePath <- TH.runIO (evalNative target (cacheOfUID uid))+ let objFile = cachePath <.> staticObjExt #if __GLASGOW_HASKELL__ >= 806- rest <- fromMaybe Set.empty <$> TH.getQ- if Set.member this rest- then return ()- else do- TH.addForeignFilePath TH.RawObject this- TH.putQ (Set.insert this rest)+ objSet <- fromMaybe Set.empty <$> TH.getQ+ unless (Set.member objFile objSet) $ do+ TH.addForeignFilePath TH.RawObject objFile+ TH.putQ (Set.insert objFile objSet) #endif- return this+ return objFile++-- The file extension for static libraries+--+staticObjExt :: String+#if defined(mingw32_HOST_OS)+staticObjExt = "obj"+#else+staticObjExt = "o"+#endif
src/Data/Array/Accelerate/LLVM/Native/Execute.hs view
@@ -52,7 +52,8 @@ import qualified Data.Array.Accelerate.LLVM.Native.Debug as Debug import Control.Concurrent ( myThreadId )-import Control.Monad.State ( gets )+import Control.Concurrent.Extra ( getThreadId )+import Control.Monad.Reader ( asks ) import Control.Monad.Trans ( liftIO ) import Data.ByteString.Short ( ShortByteString ) import Data.IORef ( newIORef, readIORef, writeIORef )@@ -60,8 +61,10 @@ import Data.Maybe ( fromMaybe ) import Data.Sequence ( Seq ) import Data.Foldable ( asum )+import Formatting import System.CPUTime ( getCPUTime )-import Text.Printf ( printf )+import qualified Data.ByteString.Short as S+import qualified Data.ByteString.Short.Extra as SE import qualified Data.ByteString.Short.Char8 as S8 import qualified Data.Sequence as Seq import qualified Data.DList as DL@@ -136,7 +139,7 @@ simpleOp name repr NativeR{..} gamma aenv sh = do let fun = nativeExecutable !# name param = TupRsingle $ ParamRarray repr- Native{..} <- gets llvmTarget+ Native{..} <- asks llvmTarget future <- new result <- allocateRemote repr sh scheduleOp fun gamma aenv (arrayRshape repr) sh param result@@ -164,7 +167,7 @@ shr = arrayRshape repr repr' = ArrayR shr tp param = TupRsingle (ParamRarray repr') `TupRpair` TupRsingle (ParamRarray repr)- Native{..} <- gets llvmTarget+ Native{..} <- asks llvmTarget future <- new result <- case inplace of Just Refl -> return input@@ -198,7 +201,7 @@ -> Par Native (Future (Array sh' b)) transformOp repr repr' NativeR{..} gamma aenv sh' input = do let fun = nativeExecutable !# "transform"- Native{..} <- gets llvmTarget+ Native{..} <- asks llvmTarget future <- new result <- allocateRemote repr' sh' let param = TupRsingle (ParamRarray repr') `TupRpair` TupRsingle (ParamRarray repr)@@ -297,13 +300,13 @@ -> Delayed (Vector e) -> Par Native (Future (Scalar e)) foldAllOp tp NativeR{..} gamma aenv arr = do- Native{..} <- gets llvmTarget+ Native{..} <- asks llvmTarget future <- new result <- allocateRemote (ArrayR dim0 tp) () let minsize = 4096- splits = numWorkers workers ranges = divideWork1 splits minsize ((), 0) sh (,,)+ splits = numWorkers workers - 1 steps = Seq.length ranges sh = delayedShape arr --@@ -340,13 +343,13 @@ -> Delayed (Array (sh, Int) e) -> Par Native (Future (Array sh e)) foldDimOp repr NativeR{..} gamma aenv arr@(delayedShape -> (sh, _)) = do- Native{..} <- gets llvmTarget+ Native{..} <- asks llvmTarget future <- new result <- allocateRemote repr sh let ArrayR shr tp = repr fun = nativeExecutable !# "fold"- splits = numWorkers workers+ splits = numWorkers workers - 1 minsize = 1 param = TupRsingle (ParamRarray repr) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray $ ArrayR (ShapeRsnoc shr) tp) --@@ -367,15 +370,15 @@ -> Delayed (Array (sh, Int) e) -> Delayed (Segments i) -> Par Native (Future (Array (sh, Int) e))-foldSegOp int repr NativeR{..} gamma aenv input@(delayedShape -> (sh, _)) segments@(delayedShape -> ((), ss)) = do- Native{..} <- gets llvmTarget+foldSegOp iR repr NativeR{..} gamma aenv input@(delayedShape -> (sh, _)) segments@(delayedShape -> ((), ss)) = do+ Native{..} <- asks llvmTarget future <- new let n = ss-1- splits = numWorkers workers+ splits = numWorkers workers - 1 minsize = 1 shR = arrayRshape repr- segR = ArrayR dim1 $ TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType int+ segR = ArrayR dim1 $ TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType iR param = TupRsingle (ParamRarray repr) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray segR) -- result <- allocateRemote repr (sh, n)@@ -409,9 +412,10 @@ -> Val aenv -> Delayed (Array (sh, Int) e) -> Par Native (Future (Array (sh, Int) e))-scan1Op repr exe gamma aenv arr@(delayedShape -> (_, n))- = boundsCheck "empty array" (n > 0)- $ scanCore repr exe gamma aenv n arr+scan1Op repr exe gamma aenv arr@(delayedShape -> sh@(_, n)) =+ case n of+ 0 -> newFull =<< allocateRemote repr sh+ _ -> scanCore repr exe gamma aenv n arr {-# INLINE scanCore #-} scanCore@@ -424,7 +428,7 @@ -> Delayed (Array (sh, Int) e) -> Par Native (Future (Array (sh, Int) e)) scanCore repr NativeR{..} gamma aenv m input@(delayedShape -> (sz, n)) = do- Native{..} <- gets llvmTarget+ Native{..} <- asks llvmTarget future <- new result <- allocateRemote repr (sz, m) --@@ -438,7 +442,7 @@ then let fun = nativeExecutable !# "scanS"- splits = numWorkers workers+ splits = numWorkers workers - 1 minsize = 1 in scheduleOpWith splits minsize fun gamma aenv shR sz param (result, manifest input)@@ -459,9 +463,9 @@ -- parallel execution else do let- splits = numWorkers workers minsize = 8192 ranges = divideWork dim1 splits minsize ((), 0) ((), n) (,,)+ splits = numWorkers workers - 1 steps = Seq.length ranges reprTmp = ArrayR dim1 $ arrayRtype repr paramTmp = TupRsingle $ ParamRarray reprTmp@@ -523,7 +527,7 @@ paramA = TupRsingle $ ParamRarray repr paramA' = TupRsingle $ ParamRarray repr' --- Native{..} <- gets llvmTarget+ Native{..} <- asks llvmTarget future <- new result <- allocateRemote repr sh sums <- allocateRemote repr' sz@@ -534,7 +538,7 @@ -- then let fun = nativeExecutable !# "scanS"- splits = numWorkers workers+ splits = numWorkers workers - 1 minsize = 1 param = paramA `TupRpair` paramA' `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr) in@@ -558,9 +562,9 @@ -- parallel execution else do let- splits = numWorkers workers minsize = 8192 ranges = divideWork1 splits minsize ((), 0) ((), n) (,,)+ splits = numWorkers workers - 1 steps = Seq.length ranges reprTmp = ArrayR dim1 eR paramTmp = TupRsingle $ ParamRarray reprTmp@@ -604,13 +608,13 @@ let ArrayR shr tp = repr repr' = ArrayR shr' tp- Native{..} <- gets llvmTarget+ Native{..} <- asks llvmTarget future <- new result <- if inplace- then Debug.trace Debug.dump_exec "exec: permute/inplace" $ return defaults- else Debug.timed Debug.dump_exec (\wall cpu -> "exec: permute/clone " ++ Debug.elapsedS wall cpu) $ liftPar (cloneArray repr' defaults)+ then Debug.trace Debug.dump_exec "exec: permute/inplace" $ return defaults+ else Debug.timed Debug.dump_exec ("exec: permute/clone " % Debug.elapsedS) $ liftPar (cloneArray repr' defaults) let- splits = numWorkers workers+ splits = numWorkers workers - 1 minsize = case shr of ShapeRsnoc ShapeRz -> 4096 ShapeRsnoc (ShapeRsnoc ShapeRz) -> 64@@ -697,7 +701,7 @@ -> params -> Par Native (Future (Array sh e)) stencilCore repr NativeR{..} gamma aenv halo sh paramsR params = do- Native{..} <- gets llvmTarget+ Native{..} <- asks llvmTarget future <- new result <- allocateRemote repr sh let@@ -705,7 +709,7 @@ inside = nativeExecutable !# "stencil_inside" border = nativeExecutable !# "stencil_border" - splits = numWorkers workers+ splits = numWorkers workers - 1 minsize = case shr of ShapeRsnoc ShapeRz -> 4096 ShapeRsnoc (ShapeRsnoc ShapeRz) -> 64@@ -770,11 +774,8 @@ -> as -> Par Native (Future bs) aforeignOp name _ _ asm arr = do- wallBegin <- liftIO getMonotonicTime- result <- Debug.timed Debug.dump_exec (\wall cpu -> printf "exec: %s %s" name (Debug.elapsedP wall cpu)) (asm arr)- wallEnd <- liftIO getMonotonicTime- liftIO $ Debug.addProcessorTime Debug.Native (wallEnd - wallBegin)- return result+ -- TODO: add tracy marks+ Debug.timed Debug.dump_exec (now ("exec: " <> bformat string name <> " ") % Debug.elapsedP) (asm arr) -- Skeleton execution@@ -782,12 +783,12 @@ (!#) :: HasCallStack => Lifetime FunctionTable -> ShortByteString -> Function (!#) exe name- = fromMaybe (internalError ("function not found: " ++ S8.unpack name))+ = fromMaybe (internalError ("function not found: " % string) (S8.unpack name)) $ lookupFunction name exe lookupFunction :: ShortByteString -> Lifetime FunctionTable -> Maybe Function lookupFunction name nativeExecutable = do- find (\(n,_) -> n == name) (functionTable (unsafeGetValue nativeExecutable))+ find (\(n,_) -> SE.take (S.length n - 65) n == name) (functionTable (unsafeGetValue nativeExecutable)) andThen :: (Maybe a -> t) -> a -> t andThen f g = f (Just g)@@ -814,9 +815,9 @@ -> Maybe Action -> Par Native () scheduleOp fun gamma aenv shr sz paramsR params done = do- Native{..} <- gets llvmTarget+ Native{..} <- asks llvmTarget let- splits = numWorkers workers+ splits = numWorkers workers - 1 minsize = case shr of ShapeRsnoc ShapeRz -> 4096 ShapeRsnoc (ShapeRsnoc ShapeRz) -> 64@@ -841,7 +842,7 @@ -> Maybe Action -- run after the last piece completes -> Par Native () scheduleOpWith splits minsize fun gamma aenv shr sz paramsR params done = do- Native{..} <- gets llvmTarget+ Native{..} <- asks llvmTarget job <- mkJob splits minsize fun gamma aenv shr (empty shr) sz paramsR params done liftIO $ schedule workers job @@ -857,7 +858,7 @@ -> Maybe Action -> Par Native () scheduleOpUsing ranges fun gamma aenv shr paramsR params jobDone = do- Native{..} <- gets llvmTarget+ Native{..} <- asks llvmTarget job <- mkJobUsing ranges fun gamma aenv shr paramsR params jobDone liftIO $ schedule workers job @@ -918,9 +919,9 @@ -> params -> Par Native (Seq Action) mkTasksUsing ranges (name, f) gamma aenv shr paramsR params = do- arg <- marshalParams' @Native (paramsR `TupRpair` TupRsingle (ParamRenv gamma)) (params, aenv)+ (arg, ()) <- marshalParams' @Native (paramsR `TupRpair` TupRsingle (ParamRenv gamma)) (params, aenv) return $ flip fmap ranges $ \(_,u,v) -> do- sched $ printf "%s (%s) -> (%s)" (S8.unpack name) (showShape shr u) (showShape shr v)+ sched (string % " " % parenthesised string % " -> " % parenthesised string) (S8.unpack name) (showShape shr u) (showShape shr v) let argU = marshalShape' @Native shr u let argV = marshalShape' @Native shr v callFFI f retVoid $ DL.toList $ argU `DL.append` argV `DL.append` arg@@ -936,9 +937,9 @@ -> params -> Par Native (Seq Action) mkTasksUsingIndex ranges (name, f) gamma aenv shr paramsR params = do- arg <- marshalParams' @Native (paramsR `TupRpair` TupRsingle (ParamRenv gamma)) (params, aenv)+ (arg, ()) <- marshalParams' @Native (paramsR `TupRpair` TupRsingle (ParamRenv gamma)) (params, aenv) return $ flip fmap ranges $ \(i,u,v) -> do- sched $ printf "%s (%s) -> (%s)" (S8.unpack name) (showShape shr u) (showShape shr v)+ sched (string % " " % parenthesised string % " -> " % parenthesised string) (S8.unpack name) (showShape shr u) (showShape shr v) let argU = marshalShape' @Native shr u let argV = marshalShape' @Native shr v let argI = DL.singleton $ marshalInt @Native i@@ -972,10 +973,8 @@ case Debug.debuggingIsEnabled of False -> return job True -> do- yes <- if Debug.monitoringIsEnabled- then return True- else Debug.getFlag Debug.dump_exec- --+ yes <- Debug.getFlag Debug.dump_exec+ verbose <- Debug.getFlag Debug.verbose if yes then do ref1 <- newIORef 0@@ -992,9 +991,10 @@ -- let wallTime = wall1 - wall0 cpuTime = fromIntegral (cpu1 - cpu0) * 1E-12+ name' | verbose = name+ | otherwise = SE.take (S.length name - 65) name --- Debug.addProcessorTime Debug.Native cpuTime- Debug.traceIO Debug.dump_exec $ printf "exec: %s %s" (S8.unpack name) (Debug.elapsedP wallTime cpuTime)+ Debug.traceM Debug.dump_exec ("exec: " % string % " " % Debug.elapsedP) (S8.unpack name') wallTime cpuTime -- return $ Job { jobTasks = start Seq.<| jobTasks job , jobDone = case jobDone job of@@ -1008,10 +1008,11 @@ foreign import ccall unsafe "clock_gettime_monotonic_seconds" getMonotonicTime :: IO Double -sched :: String -> IO ()-sched msg- = Debug.when Debug.verbose- $ Debug.when Debug.dump_sched- $ do tid <- myThreadId- Debug.putTraceMsg $ printf "sched: %s %s" (show tid) msg+sched :: Format (IO ()) a -> a+sched fmt =+ runFormat fmt $ \k ->+ Debug.when Debug.verbose $+ Debug.when Debug.dump_sched $ do+ tid <- myThreadId+ Debug.putTraceMsg ("sched: Thread " % int % " " % builder) (getThreadId tid) k
src/Data/Array/Accelerate/LLVM/Native/Execute/Async.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-}@@ -32,7 +33,7 @@ -- standard library import Control.Concurrent import Control.Monad.Cont-import Control.Monad.State+import Control.Monad.Reader import Data.IORef import Data.Sequence ( Seq ) import qualified Data.Sequence as Seq@@ -77,7 +78,7 @@ instance Async Native where type FutureR Native = Future newtype Par Native a = Par { runPar :: ContT () (LLVM Native) a }- deriving ( Functor, Applicative, Monad, MonadIO, MonadCont, MonadState Native )+ deriving ( Functor, Applicative, Monad, MonadIO, MonadCont, MonadReader Native ) {-# INLINE new #-} {-# INLINE newFull #-}@@ -92,7 +93,7 @@ {-# INLINE get #-} get (Future ref) = callCC $ \k -> do- native <- gets llvmTarget+ native <- asks llvmTarget next <- liftIO . atomicModifyIORef' ref $ \case Empty -> (Blocked (Seq.singleton (evalParIO native . k)), reschedule) Blocked ks -> (Blocked (ks Seq.|> evalParIO native . k), reschedule)@@ -101,7 +102,7 @@ {-# INLINE put #-} put future ref = do- Native{..} <- gets llvmTarget+ Native{..} <- asks llvmTarget liftIO (putIO workers future ref) {-# INLINE liftPar #-}
src/Data/Array/Accelerate/LLVM/Native/Execute/Divide.hs view
@@ -65,7 +65,7 @@ divideWork0 _ _ () () action = Seq.singleton (action 0 () ()) divideWork1 :: Int -> Int -> DIM1 -> DIM1 -> (Int -> DIM1 -> DIM1 -> a) -> Seq a-divideWork1 !pieces !minsize ((), (!from)) ((), (!to)) action =+divideWork1 !n !minsize ((), (!from)) ((), (!to)) action = let split 0 !u !v !i !f !s | v - u < minsize = (i+1, f, s Seq.|> apply i u v)@@ -82,7 +82,7 @@ (i2, f2, s2) apply i u v = action i ((), u) ((), v)- (_, fs, ss) = split pieces from to 0 Seq.empty Seq.empty+ (_, fs, ss) = split n from to 0 Seq.empty Seq.empty in fs Seq.>< ss @@ -105,7 +105,7 @@ divideWorkN :: ShapeR sh -> Int -> Int -> sh -> sh -> (Int -> sh -> sh -> a) -> Seq a-divideWorkN !shr !pieces !minsize !from !to action =+divideWorkN !shr !n !minsize !from !to action = let -- Is it worth checking whether the piece is full? Doing so ensures that -- full pieces are assigned to threads first, with the non-full blocks@@ -126,7 +126,7 @@ (i2, f2, s2) apply i u v = action i (vecToShape shr u) (vecToShape shr v)- (_, fs, ss) = split pieces (shapeToVec shr from) (shapeToVec shr to) 0 Seq.empty Seq.empty+ (_, fs, ss) = split n (shapeToVec shr from) (shapeToVec shr to) 0 Seq.empty Seq.empty in fs Seq.>< ss
src/Data/Array/Accelerate/LLVM/Native/Execute/Environment.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.Execute.Environment
src/Data/Array/Accelerate/LLVM/Native/Execute/Marshal.hs view
@@ -4,6 +4,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-}@@ -20,20 +22,23 @@ module Data.Array.Accelerate.LLVM.Native.Execute.Marshal ( module M ) where --- accelerate import Data.Array.Accelerate.LLVM.Execute.Marshal as M import Data.Array.Accelerate.Array.Unique import Data.Array.Accelerate.LLVM.Native.Execute.Async () -- instance Async Native import Data.Array.Accelerate.LLVM.Native.Target --- libraries+import Data.Bits import qualified Data.DList as DL import qualified Foreign.LibFFI as FFI + instance Marshal Native where type ArgR Native = FFI.Arg-- marshalInt = FFI.argInt- marshalScalarData' _ = return . DL.singleton . FFI.argPtr . unsafeUniqueArrayPtr+ type MarshalCleanup Native = ()+ marshalInt = $( case finiteBitSize (undefined::Int) of+ 32 -> [| FFI.argInt32 . fromIntegral |]+ 64 -> [| FFI.argInt64 . fromIntegral |]+ _ -> error "I don't know what architecture I am" )+ marshalScalarData' _ = return . (,()) . DL.singleton . FFI.argPtr . unsafeUniqueArrayPtr
src/Data/Array/Accelerate/LLVM/Native/Execute/Scheduler.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}@@ -24,9 +25,10 @@ ) where -import qualified Data.Array.Accelerate.LLVM.Native.Debug as D+import qualified Data.Array.Accelerate.LLVM.Native.Debug as Debug import Control.Concurrent+import Control.Concurrent.Extra import Control.DeepSeq import Control.Exception import Control.Monad@@ -34,10 +36,10 @@ import Data.IORef import Data.Int import Data.Sequence ( Seq )-import Text.Printf+import Formatting import qualified Data.Sequence as Seq -import GHC.Base+import GHC.Base hiding ( build ) #include "MachDeps.h" @@ -135,7 +137,7 @@ -- -- When some other thread pushes new work, it will also write to that MVar -- and this thread will wake up.- message $ printf "sched: %s sleeping" (show tid)+ message ("sched: Thread " % int % " sleeping") (getThreadId tid) -- blocking, wake-up when new work is available () <- readMVar var@@ -143,7 +145,7 @@ -- Just task -> case task of Work io -> io >> loop 0- Retire -> message $ printf "sched: %s shutting down" (show tid)+ Retire -> message ("sched: Thread " % int % " shutting down") (getThreadId tid) -- Spawn a new worker thread for each capability@@ -169,7 +171,7 @@ (restore $ runWorker tid workerActive workerTaskQueue) (appendMVar workerException . (tid,)) --- message $ printf "sched: fork %s on capability %d" (show tid) cpu+ message ("sched: fork Thread " % int % " on capability " % int) (getThreadId tid) cpu return tid -- workerThreadIds `deepseq` return Workers { workerCount = length workerThreadIds, ..}@@ -253,6 +255,7 @@ -- Debug -- ----- -message :: String -> IO ()-message = D.traceIO D.dump_sched+{-# INLINE message #-}+message :: Format (IO ()) a -> a+message = Debug.traceM Debug.dump_sched
src/Data/Array/Accelerate/LLVM/Native/Link.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.Link@@ -29,19 +29,11 @@ import Data.Array.Accelerate.LLVM.Native.Target import Data.Array.Accelerate.LLVM.Native.Compile -import Data.Array.Accelerate.LLVM.Native.Link.Object import Data.Array.Accelerate.LLVM.Native.Link.Cache-#if defined(darwin_HOST_OS)-import Data.Array.Accelerate.LLVM.Native.Link.MachO-#elif defined(linux_HOST_OS)-import Data.Array.Accelerate.LLVM.Native.Link.ELF-#elif defined(mingw32_HOST_OS)-import Data.Array.Accelerate.LLVM.Native.Link.COFF-#else-#error "Runtime linking not supported on this platform"-#endif+import Data.Array.Accelerate.LLVM.Native.Link.Object+import Data.Array.Accelerate.LLVM.Native.Link.Runtime -import Control.Monad.State+import Control.Monad.Reader import Prelude hiding ( lookup ) @@ -51,12 +43,13 @@ linkForTarget = link --- | Load the generated object file into the target address space+-- | Link to the generated shared object file, creating function pointers for+-- every kernel's entry point. -- link :: ObjectR Native -> LLVM Native (ExecutableR Native)-link (ObjectR uid _ obj) = do- cache <- gets linkCache- funs <- liftIO $ dlsym uid cache (loadObject obj)+link (ObjectR uid nms _ so) = do+ cache <- asks linkCache+ funs <- liftIO $ dlsym uid cache (loadSharedObject nms so) return $! NativeR funs
− src/Data/Array/Accelerate/LLVM/Native/Link/COFF.hs
@@ -1,35 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--- |--- Module : Data.Array.Accelerate.LLVM.Native.Link.COFF--- Copyright : [2017..2020] The Accelerate Team--- License : BSD3------ Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>--- Stability : experimental--- Portability : non-portable (GHC extensions)-----module Data.Array.Accelerate.LLVM.Native.Link.COFF (-- loadObject,--) where--import Data.Array.Accelerate.Error-import Data.Array.Accelerate.LLVM.Native.Link.Object--import Data.ByteString ( ByteString )----- Dynamic object loading--- -------------------------- Load a COFF object file and return pointers to the executable functions--- defined within. The executable sections are aligned appropriately, as--- specified in the object file, and are ready to be executed on the target--- architecture.----loadObject :: ByteString -> IO (FunctionTable, ObjectCode)-loadObject _obj =- $internalError "loadObject" "not implemented yet: https://github.com/AccelerateHS/accelerate/issues/395"-
src/Data/Array/Accelerate/LLVM/Native/Link/Cache.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.Link.Cache -- Copyright : [2017..2020] The Accelerate Team@@ -11,12 +12,49 @@ module Data.Array.Accelerate.LLVM.Native.Link.Cache ( LinkCache,- LC.new, LC.dlsym,+ new, LC.dlsym, ) where +import Data.Array.Accelerate.Debug.Internal ( tracyIsEnabled )+ import Data.Array.Accelerate.LLVM.Native.Link.Object import qualified Data.Array.Accelerate.LLVM.Link.Cache as LC +import Control.Monad++#if defined(mingw32_HOST_OS)+import System.Win32.DLL+#else+import System.Posix.DynamicLinker+#endif+ type LinkCache = LC.LinkCache FunctionTable ObjectCode +new :: IO LinkCache+new = do+ -- For whatever reason ghci isn't adding library dependencies to the+ -- dynamic link state, which means that dynamic linking will fail in+ -- tracy mode because we depend on tracy symbols exported by the+ -- accelerate library. This brings those symbols into scope so that they+ -- can be found by later calls to dlsym().+ --+ -- Additionally, the Accelerate library has been compiled with -rdynamic+ -- in order to bring all exported symbols into the global symbol table.+ -- This seems to be required so that dlsym() can find symbols from the+ -- GHC RTS when we are in compiled (not interpreted) mode. In non-ghci+ -- mode, loading the RTS dynamic library explicitly (as we do with the+ -- Accelerate library) causes segfaults; possibly because the RTS was+ -- otherwise linked statically into the executable.+ --+ -- Because the accelerate library lives somewhere in ~/.cabal/..., this+ -- hack prevents executables from running on any other machine than the+ -- one they were built on. Fortunately, this happens only in tracy mode.+ --+ when tracyIsEnabled $ void $+#if defined(mingw32_HOST_OS)+ loadLibrary ACCELERATE_DYLD_LIBRARY_PATH+#else+ dlopen ACCELERATE_DYLD_LIBRARY_PATH [RTLD_LAZY, RTLD_GLOBAL]+#endif+ LC.new
− src/Data/Array/Accelerate/LLVM/Native/Link/ELF.chs
@@ -1,739 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE RecordWildCards #-}--- |--- Module : Data.Array.Accelerate.LLVM.Native.Link.ELF--- Copyright : [2017..2020] The Accelerate Team--- License : BSD3------ Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>--- Stability : experimental--- Portability : non-portable (GHC extensions)-----module Data.Array.Accelerate.LLVM.Native.Link.ELF (-- loadObject,--) where--import Data.Array.Accelerate.Error-import Data.Array.Accelerate.LLVM.Native.Link.Object-import Data.Array.Accelerate.Lifetime-import qualified Data.Array.Accelerate.Debug as Debug--import Control.Applicative-import Control.Monad-import Data.Bits-import Data.ByteString ( ByteString )-import Data.Char-import Data.Int-import Data.List-import Data.Serialize.Get-import Data.Vector ( Vector )-import Data.Word-import Foreign.C-import Foreign.ForeignPtr-import Foreign.Marshal-import Foreign.Ptr-import Foreign.Storable-import GHC.ForeignPtr ( mallocPlainForeignPtrAlignedBytes )-import GHC.Prim ( addr2Int#, int2Word# )-import GHC.Ptr ( Ptr(..) )-import GHC.Word ( Word64(..) )-import System.IO.Unsafe-import System.Posix.DynamicLinker-import Text.Printf-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Internal as B-import qualified Data.ByteString.Short as BS-import qualified Data.ByteString.Unsafe as B-import qualified Data.Vector as V-import Prelude as P--#include <elf.h>-#include <sys/mman.h>----- Dynamic object loading--- -------------------------- Load an ELF object file and return pointers to the executable functions--- defined within. The executable sections are aligned appropriately, as--- specified in the object file, and are ready to be executed on the target--- architecture.----loadObject :: HasCallStack => ByteString -> IO (FunctionTable, ObjectCode)-loadObject obj =- case parseObject obj of- Left err -> internalError err- Right (secs, symbols, relocs, strtab) -> do- -- Load the sections into executable memory- --- (funtab, oc) <- loadSegment obj strtab secs symbols relocs-- -- The executable pages were allocated on the GC heap. When the pages- -- are finalised, unset the executable bit and mark them as- -- read/write so that the memory can be reused.- --- objectcode <- newLifetime [oc]- addFinalizer objectcode $ do- Debug.traceIO Debug.dump_gc ("gc: unload module: " ++ show funtab)- case oc of- Segment vmsize oc_fp ->- withForeignPtr oc_fp $ \oc_p ->- mprotect oc_p vmsize ({#const PROT_READ#} .|. {#const PROT_WRITE#})-- return (funtab, objectcode)----- Load the sections into memory.------ Extra jump islands are added directly after the section data. On x86_64--- PC-relative jumps and accesses to the global offset table are limited to--- 32-bits (+-2GB). If we need to go outside of this range than we must do so--- via the jump islands.------ NOTE: This puts all the sections into a single block of memory. Technically--- this is incorrect because we then have both text and data sections together,--- meaning that data sections are marked as execute when they really shouldn't--- be. These would need to live in different pages in order to be mprotect-ed--- properly.----loadSegment- :: HasCallStack- => ByteString- -> ByteString- -> Vector SectionHeader- -> Vector Symbol- -> Vector Relocation- -> IO (FunctionTable, Segment)-loadSegment obj strtab secs symtab relocs = do- let- pagesize = fromIntegral c_getpagesize-- -- round up to next multiple of given alignment- pad align n = (n + align - 1) .&. (complement (align - 1))-- -- determine where each section should be placed in memory, respecting- -- alignment requirements. SectionHeaders which do not correspond to- -- program data (e.g. systab) just carry along the previous offset value.- -- This is to avoid filtering the list of sections, so that section- -- indices (e.g. in relocations) remain valid.- --- nsecs = V.length secs- offsets = V.constructN (nsecs + 1) $ \v ->- case V.length v of- 0 -> 0- n -> let this = secs V.! n- prev = secs V.! (n-1)- alloc s = testBit (sh_flags s) 1 -- SHF_ALLOC: section occupies memory at execution?- --- align | n >= nsecs = 16- | not (alloc this) = 1- | otherwise = sh_align this- --- size | alloc prev = sh_size prev- | otherwise = 0- in- pad align (size + v V.! (n-1))-- -- The section at index `i` should place its data beginning at page boundary- -- offset given by offsets!i.- --- vmsize' = V.last offsets -- bytes required to store all sections- vmsize = pad pagesize (vmsize' + (V.length symtab * 16)) -- sections + jump tables-- seg_fp <- mallocPlainForeignPtrAlignedBytes vmsize pagesize- funtab <- withForeignPtr seg_fp $ \seg_p -> do-- -- Clear the segment data; this takes care of .bss sections- fillBytes seg_p 0 vmsize-- -- Jump tables are placed directly after the segment data- let jump_p = seg_p `plusPtr` vmsize'- V.imapM_ (makeJumpIsland jump_p) symtab-- -- Copy over section data- V.izipWithM_ (loadSection obj strtab seg_p) offsets secs-- -- Process relocations- V.mapM_ (processRelocation symtab offsets seg_p jump_p) relocs-- -- Mark the page as executable and read-only- mprotect seg_p vmsize ({#const PROT_READ#} .|. {#const PROT_EXEC#})-- -- Resolve external symbols defined in the sections into function- -- pointers.- --- -- Note that in order to support ahead-of-time compilation, the generated- -- functions are given unique names by appending with an underscore followed- -- by a unique ID. The execution phase doesn't need to know about this- -- however, so un-mangle the name to the basic "map", "fold", etc.- --- let funtab = FunctionTable $ V.toList (V.map resolve (V.filter extern symtab))- extern Symbol{..} = sym_binding == Global && sym_type == Func- resolve Symbol{..} =- let name = BS.toShort (B8.take (B8.length sym_name - 65) sym_name)- addr = castPtrToFunPtr (seg_p `plusPtr` (fromIntegral sym_value + offsets V.! sym_section))- in- (name, addr)- --- return funtab- --- return (funtab, Segment vmsize seg_fp)----- Add the jump-table entries directly to each external undefined symbol.----makeJumpIsland :: Ptr Word8 -> Int -> Symbol -> IO ()-makeJumpIsland jump_p symbolnum Symbol{..} = do-#ifdef x86_64_HOST_ARCH- when (sym_binding == Global && sym_section == 0) $ do- let- target = jump_p `plusPtr` (symbolnum * 16) :: Ptr Word64 -- addr- instr = target `plusPtr` 8 :: Ptr Word8 -- jumpIsland- --- poke target sym_value- pokeArray instr [ 0xFF, 0x25, 0xF2, 0xFF, 0xFF, 0xFF ] -- jmp *-14(%rip)-#endif- return ()----- Load the section at the correct offset into the given segment----loadSection :: HasCallStack => ByteString -> ByteString -> Ptr Word8 -> Int -> Int -> SectionHeader -> IO ()-loadSection obj strtab seg_p sec_num sec_addr SectionHeader{..} =- when (sh_type == ProgBits && sh_size > 0) $ do- message (printf "section %d: Mem: 0x%09x-0x%09x %s" sec_num sec_addr (sec_addr+sh_size) (B8.unpack (indexStringTable strtab sh_name)))- let (obj_fp, obj_offset, _) = B.toForeignPtr obj- --- withForeignPtr obj_fp $ \obj_p -> do- -- Copy this section's data to the appropriate place in the segment- let src = obj_p `plusPtr` (obj_offset + sh_offset)- dst = seg_p `plusPtr` sec_addr- --- copyBytes dst src sh_size----- Process local and external relocations.----processRelocation :: HasCallStack => Vector Symbol -> Vector Int -> Ptr Word8 -> Ptr Word8 -> Relocation -> IO ()-#ifdef x86_64_HOST_ARCH-processRelocation symtab sec_offset seg_p jump_p Relocation{..} = do- message (printf "relocation: 0x%04x to symbol %d in section %d, type=%-14s value=%s%+d" r_offset r_symbol r_section (show r_type) (B8.unpack sym_name) r_addend)- case r_type of- R_X86_64_None -> return ()- R_X86_64_64 -> relocate value-- R_X86_64_PC32 ->- let offset :: Int64- offset = fromIntegral (value - pc')- in- if offset >= 0x7fffffff || offset < -0x80000000- then- let jump' = castPtrToWord64 (jump_p `plusPtr` (r_symbol * 16 + 8))- offset' = fromIntegral jump' + r_addend - fromIntegral pc'- in- relocate (fromIntegral offset' :: Word32)- else- relocate (fromIntegral offset :: Word32)-- R_X86_64_PC64 ->- let offset :: Int64- offset = fromIntegral (value - pc')- in- relocate (fromIntegral offset :: Word32)-- R_X86_64_32 ->- if value >= 0x7fffffff- then- let jump' = castPtrToWord64 (jump_p `plusPtr` (r_symbol * 16 + 8))- value' = fromIntegral jump' + r_addend- in- relocate (fromIntegral value' :: Word32)- else- relocate (fromIntegral value :: Word32)-- R_X86_64_32S ->- let values :: Int64- values = fromIntegral value- in- if values > 0x7fffffff || values < -0x80000000- then- let jump' = castPtrToWord64 (jump_p `plusPtr` (r_symbol * 16 + 8))- value' = fromIntegral jump' + r_addend- in- relocate (fromIntegral value' :: Int32)- else- relocate (fromIntegral value :: Int32)-- R_X86_64_PLT32 ->- let offset :: Int64- offset = fromIntegral (value - pc')- in- if offset >= 0x7fffffff || offset < -0x80000000- then- let jump' = castPtrToWord64 (jump_p `plusPtr` (r_symbol * 16 + 8))- offset' = fromIntegral jump' + r_addend - fromIntegral pc'- in- relocate (fromIntegral offset' :: Word32)- else- relocate (fromIntegral offset :: Word32)-- where- pc :: Ptr Word8- pc = seg_p `plusPtr` (fromIntegral r_offset + sec_offset V.! r_section)- pc' = castPtrToWord64 pc-- value :: Word64- value = symval + fromIntegral r_addend-- symval :: Word64- symval =- case sym_binding of- Local -> castPtrToWord64 (seg_p `plusPtr` (sec_offset V.! sym_section + fromIntegral sym_value))- Global -> sym_value- Weak -> internalError "unhandled weak symbol"-- Symbol{..} = symtab V.! r_symbol-- relocate :: Storable a => a -> IO ()- relocate x = poke (castPtr pc) x--#else-precessRelocation =- internalError "not defined for non-x86_64 architectures yet"-#endif----- Object file parser--- ---------------------- Parse an ELF object file and return the set of section load commands, as well--- as the symbols defined within the sections of the object.------ Actually loading the sections into executable memory happens separately.----parseObject :: HasCallStack => ByteString -> Either String (Vector SectionHeader, Vector Symbol, Vector Relocation, ByteString)-parseObject obj = do- (p, tph, tsec, strix) <- runGet readHeader obj-- -- As this is an object file, we do not expect any program headers- unless (tb_entries tph == 0) $ Left "unhandled program header(s)"-- -- Read the object file headers- secs <- runGet (V.replicateM (tb_entries tsec) (readSectionHeader p)) (B.drop (tb_fileoff tsec) obj)- strtab <- readStringTable obj (secs V.! strix)-- let symtab = V.toList . V.filter (\s -> sh_type s == SymTab)- reloc = V.toList . V.filter (\s -> sh_type s == Rel || sh_type s == RelA)-- symbols <- V.concat <$> sequence [ readSymbolTable p secs obj sh | sh <- symtab secs ]- relocs <- V.concat <$> sequence [ readRelocations p obj sh | sh <- reloc secs ]-- return (secs, symbols, relocs, strtab)----- Parsing depends on whether the ELF file is 64-bit and whether it should be--- read as big- or little-endian.----data Peek = Peek- { is64Bit :: !Bool- , getWord16 :: !(Get Word16)- , getWord32 :: !(Get Word32)- , getWord64 :: !(Get Word64)- }--data Table = Table- { tb_fileoff :: {-# UNPACK #-} !Int -- byte offset to start of table (array)- , tb_entries :: {-# UNPACK #-} !Int -- number of entries in the table (array)- , tb_entrysize :: {-# UNPACK #-} !Int -- size in bytes per entry- }--{---data ProgramHeader = ProgramHeader- { prog_vmaddr :: {-# UNPACK #-} !Int -- virtual address- , prog_vmsize :: {-# UNPACK #-} !Int -- size in memory- , prog_fileoff :: {-# UNPACK #-} !Int -- file offset- , prog_filesize :: {-# UNPACK #-} !Int -- size in file- , prog_align :: {-# UNPACK #-} !Int -- alignment- , prog_paddr :: {-# UNPACK #-} !Int -- physical address- }---}--data SectionHeader = SectionHeader- { sh_name :: {-# UNPACK #-} !Int -- string table index- , sh_addr :: {-# UNPACK #-} !Word64 -- virtual memory address- , sh_size :: {-# UNPACK #-} !Int -- section size in bytes- , sh_offset :: {-# UNPACK #-} !Int -- file offset in bytes- , sh_align :: {-# UNPACK #-} !Int- , sh_link :: {-# UNPACK #-} !Int- , sh_info :: {-# UNPACK #-} !Int -- additional section info- , sh_entsize :: {-# UNPACK #-} !Int -- entry size, if section holds table- , sh_flags :: {-# UNPACK #-} !Word64- , sh_type :: !SectionType- }- deriving Show--{#enum define SectionType- { SHT_NULL as NullSection- , SHT_PROGBITS as ProgBits- , SHT_SYMTAB as SymTab- , SHT_STRTAB as StrTab- , SHT_RELA as RelA- , SHT_HASH as Hash- , SHT_DYNAMIC as Dynamic- , SHT_NOTE as Note- , SHT_NOBITS as NoBits- , SHT_REL as Rel- , SHT_DYNSYM as DynSym- }- deriving (Eq, Show)-#}--data Symbol = Symbol- { sym_name :: {-# UNPACK #-} !ByteString- , sym_value :: {-# UNPACK #-} !Word64- , sym_section :: {-# UNPACK #-} !Int- , sym_binding :: !SymbolBinding- , sym_type :: !SymbolType- }- deriving Show--{#enum define SymbolBinding- { STB_LOCAL as Local- , STB_GLOBAL as Global- , STB_WEAK as Weak- }- deriving (Eq, Show)-#}--{#enum define SymbolType- { STT_NOTYPE as NoType- , STT_OBJECT as Object -- data object- , STT_FUNC as Func -- function object- , STT_SECTION as Section- , STT_FILE as File- , STT_COMMON as Common- , STT_TLS as TLS- }- deriving (Eq, Show)-#}--data Relocation = Relocation- { r_offset :: {-# UNPACK #-} !Word64- , r_symbol :: {-# UNPACK #-} !Int- , r_section :: {-# UNPACK #-} !Int- , r_addend :: {-# UNPACK #-} !Int64- , r_type :: !RelocationType- }- deriving Show--#ifdef i386_HOST_ARCH-{#enum define RelocationType- { R_386_NONE as R_386_None- , R_386_32 as R_386_32- , R_386_PC32 as R_386_PC32- }- deriving (Eq, Show)-#}-#endif-#ifdef x86_64_HOST_ARCH-{#enum define RelocationType- { R_X86_64_NONE as R_X86_64_None -- no relocation- , R_X86_64_64 as R_X86_64_64 -- direct 64-bit- , R_X86_64_PC32 as R_X86_64_PC32 -- PC relative 32-bit signed- , R_X86_64_PC64 as R_X86_64_PC64 -- PC relative 64-bit- , R_X86_64_32 as R_X86_64_32 -- direct 32-bit zero extended- , R_X86_64_32S as R_X86_64_32S -- direct 32-bit sign extended- , R_X86_64_PLT32 as R_X86_64_PLT32 -- 32-bit PLT address- -- ... many more relocation types- }- deriving (Eq, Show)-#}-#endif---- The ELF file header appears at the start of every file.----readHeader :: Get (Peek, Table, Table, Int)-readHeader = do- p@Peek{..} <- readIdent- (_, phs, secs, shstr) <- case is64Bit of- True -> readHeader64 p- False -> readHeader32 p- return (p, phs, secs, shstr)---readHeader32 :: Peek -> Get (Int, Table, Table, Int)-readHeader32 _ = fail "TODO: readHeader32"--readHeader64 :: Peek -> Get (Int, Table, Table, Int)-readHeader64 p@Peek{..} = do- readType p- readMachine p- skip {#sizeof Elf64_Word#} -- e_version- e_entry <- getWord64 -- entry point virtual address (page offset?)- e_phoff <- getWord64 -- program header table file offset- e_shoff <- getWord64 -- section header table file offset- skip ({#sizeof Elf64_Word#}+{#sizeof Elf64_Half#}) -- e_flags + e_ehsize- e_phentsize <- getWord16 -- byte size per program header entry- e_phnum <- getWord16 -- #program header entries- e_shentsize <- getWord16- e_shnum <- getWord16- e_shstrndx <- getWord16- return ( fromIntegral e_entry- , Table { tb_fileoff = fromIntegral e_phoff, tb_entries = fromIntegral e_phnum, tb_entrysize = fromIntegral e_phentsize }- , Table { tb_fileoff = fromIntegral e_shoff, tb_entries = fromIntegral e_shnum, tb_entrysize = fromIntegral e_shentsize }- , fromIntegral e_shstrndx- )---readIdent :: Get Peek-readIdent = do- ei_magic <- getBytes 4- unless (ei_magic == B8.pack [chr {#const ELFMAG0#}, {#const ELFMAG1#}, {#const ELFMAG2#}, {#const ELFMAG3#}]) $- fail "invalid magic number"-- ei_class <- getWord8- is64Bit <- case ei_class of- {#const ELFCLASS32#} -> return False- {#const ELFCLASS64#} -> return True- _ -> fail "invalid class"- ei_data <- getWord8- p <- case ei_data of- {#const ELFDATA2LSB#} -> return $ Peek { getWord16 = getWord16le, getWord32 = getWord32le, getWord64 = getWord64le, .. }- {#const ELFDATA2MSB#} -> return $ Peek { getWord16 = getWord16be, getWord32 = getWord32be, getWord64 = getWord64be, .. }- _ -> fail "invalid data layout"- ei_version <- getWord8- unless (ei_version == {#const EV_CURRENT#}) $ fail "invalid version"- skip (1+1+{#const EI_NIDENT#}-{#const EI_PAD#}) -- ABI, ABI version, padding- return p---readType :: Peek -> Get ()-readType Peek{..} = do- e_type <- getWord16- case e_type of- {#const ET_REL#} -> return ()- _ -> fail "expected relocatable object file"--readMachine :: Peek -> Get ()-readMachine Peek{..} = do- e_machine <- getWord16- case e_machine of-#ifdef i386_HOST_ARCH- {#const EM_386#} -> return ()-#endif-#ifdef x86_64_HOST_ARCH- {#const EM_X86_64#} -> return ()-#endif- _ -> fail "expected host architecture object file"---{----- Program headers define how the ELF program behaves once it has been loaded,--- as well as runtime linking information.------ TLM: Since we are loading object files we shouldn't get any program headers.----readProgramHeader :: Peek -> Get ProgramHeader-readProgramHeader p@Peek{..} =- case is64Bit of- True -> readProgramHeader64 p- False -> readProgramHeader32 p--readProgramHeader32 :: Peek -> Get ProgramHeader-readProgramHeader32 _ = fail "TODO: readProgramHeader32"--readProgramHeader64 :: Peek -> Get ProgramHeader-readProgramHeader64 _ = fail "TODO: readProgramHeader64"---}---- Section headers contain information such as the section name, size, and--- location in the object file. The list of all the section headers in the ELF--- file is known as the section header table.----readSectionHeader :: Peek -> Get SectionHeader-readSectionHeader p@Peek{..} =- case is64Bit of- True -> readSectionHeader64 p- False -> readSectionHeader32 p--readSectionHeader32 :: Peek -> Get SectionHeader-readSectionHeader32 _ = fail "TODO: readSectionHeader32"--readSectionHeader64 :: Peek -> Get SectionHeader-readSectionHeader64 Peek{..} = do- sh_name <- fromIntegral <$> getWord32- sh_type <- toEnum . fromIntegral <$> getWord32- sh_flags <- getWord64- sh_addr <- getWord64- sh_offset <- fromIntegral <$> getWord64- sh_size <- fromIntegral <$> getWord64- sh_link <- fromIntegral <$> getWord32- sh_info <- fromIntegral <$> getWord32- sh_align <- fromIntegral <$> getWord64- sh_entsize <- fromIntegral <$> getWord64- return SectionHeader {..}---indexStringTable :: ByteString -> Int -> ByteString-indexStringTable strtab ix = B.takeWhile (/= 0) (B.drop ix strtab)--readStringTable :: ByteString -> SectionHeader -> Either String ByteString-readStringTable obj SectionHeader{..} =- case sh_type of- StrTab -> Right $ B.take sh_size (B.drop sh_offset obj)- _ -> Left "expected string table"---readRelocations :: Peek -> ByteString -> SectionHeader -> Either String (Vector Relocation)-readRelocations p@Peek{..} obj SectionHeader{..} = do- unless (sh_type == Rel || sh_type == RelA) $ Left "expected relocation section"- --- let nrel = sh_size `quot` sh_entsize- runGet (V.replicateM nrel (readRel p sh_type sh_info)) (B.drop sh_offset obj)---readRel :: Peek -> SectionType -> Int -> Get Relocation-readRel p@Peek{..} sh_type r_section =- case is64Bit of- True -> readRel64 p sh_type r_section- False -> readRel32 p sh_type r_section--readRel32 :: Peek -> SectionType -> Int -> Get Relocation-readRel32 _ _ _ = fail "TODO: readRel32"--readRel64 :: Peek -> SectionType -> Int -> Get Relocation-readRel64 Peek{..} sh_type r_section = do- r_offset <- getWord64- r_info <- getWord64- r_addend <- case sh_type of- RelA -> fromIntegral <$> getWord64- _ -> return 0- let r_type = toEnum (fromIntegral (r_info .&. 0xffffffff))- r_symbol = fromIntegral (r_info `shiftR` 32) - 1- --- return Relocation {..}---readSymbolTable :: Peek -> Vector SectionHeader -> ByteString -> SectionHeader -> Either String (Vector Symbol)-readSymbolTable p@Peek{..} secs obj SectionHeader{..} = do- unless (sh_type == SymTab) $ Left "expected symbol table"-- let nsym = sh_size `quot` sh_entsize- offset = sh_offset + sh_entsize -- First symbol in the table is always null; skip it.- -- Make sure to update relocation indices- strtab <- readStringTable obj (secs V.! sh_link)- symbols <- runGet (V.replicateM (nsym-1) (readSymbol p secs strtab)) (B.drop offset obj)- return symbols--readSymbol :: Peek -> Vector SectionHeader -> ByteString -> Get Symbol-readSymbol p@Peek{..} secs strtab =- case is64Bit of- True -> readSymbol64 p secs strtab- False -> readSymbol32 p secs strtab--readSymbol32 :: Peek -> Vector SectionHeader -> ByteString -> Get Symbol-readSymbol32 _ _ _ = fail "TODO: readSymbol32"--readSymbol64 :: Peek -> Vector SectionHeader -> ByteString -> Get Symbol-readSymbol64 Peek{..} secs strtab = do- st_strx <- fromIntegral <$> getWord32- st_info <- getWord8- skip 1 -- st_other <- getWord8- sym_section <- fromIntegral <$> getWord16- sym_value <- getWord64- skip 8 -- st_size <- getWord64-- let sym_name- | sym_type == Section = indexStringTable strtab (sh_name (secs V.! sym_section))- | st_strx == 0 = B.empty- | otherwise = indexStringTable strtab st_strx-- sym_binding = toEnum $ fromIntegral ((st_info .&. 0xF0) `shiftR` 4)- sym_type = toEnum $ fromIntegral (st_info .&. 0x0F)-- case sym_section of- -- External symbol; lookup value- {#const SHN_UNDEF#} | not (B.null sym_name) -> do- funptr <- resolveSymbol sym_name- message (printf "%s: external symbol found at %s" (B8.unpack sym_name) (show funptr))- return Symbol { sym_value = castPtrToWord64 (castFunPtrToPtr funptr), .. }-- -- Internally defined symbol- n | n < {#const SHN_LORESERVE#} -> do- message (printf "%s: local symbol in section %d at 0x%02x" (B8.unpack sym_name) sym_section sym_value)- return Symbol {..}-- {#const SHN_ABS#} | sym_type == File -> return Symbol {..}- {#const SHN_ABS#} -> fail "unhandled absolute symbol"- _ -> fail "unhandled symbol section"----- Return the address binding the named symbol----resolveSymbol :: ByteString -> Get (FunPtr ())-resolveSymbol name- = unsafePerformIO- $ B.unsafeUseAsCString name $ \c_name -> do- addr <- c_dlsym (packDL Default) c_name- if addr == nullFunPtr- then do- err <- dlerror- return (fail $ printf "failed to resolve symbol %s: %s" (B8.unpack name) err)- else do- return (return addr)----- Utilities--- ------------- Get the address of a pointer as a Word64----castPtrToWord64 :: Ptr a -> Word64-castPtrToWord64 (Ptr addr#) = W64# (int2Word# (addr2Int# addr#))----- c-bits--- ---------- Control the protection of pages----mprotect :: Ptr Word8 -> Int -> Int -> IO ()-mprotect addr len prot- = throwErrnoIfMinus1_ "mprotect"- $ c_mprotect addr (fromIntegral len) (fromIntegral prot)--foreign import ccall unsafe "mprotect"- c_mprotect :: Ptr a -> CSize -> CInt -> IO CInt--foreign import ccall unsafe "getpagesize"- c_getpagesize :: CInt--#if __GLASGOW_HASKELL__ <= 708--- Fill a given number of bytes in memory. Added in base-4.8.0.0.----fillBytes :: Ptr a -> Word8 -> Int -> IO ()-fillBytes dest char size = do- _ <- memset dest (fromIntegral char) (fromIntegral size)- return ()--foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO (Ptr a)-#endif----- Debug--- -------{-# INLINE trace #-}-trace :: String -> a -> a-trace msg = Debug.trace Debug.dump_ld ("ld: " ++ msg)--{-# INLINE message #-}-message :: Monad m => String -> m ()-message msg = trace msg (return ())-
− src/Data/Array/Accelerate/LLVM/Native/Link/MachO.chs
@@ -1,733 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}--- |--- Module : Data.Array.Accelerate.LLVM.Native.Link.MachO--- Copyright : [2017..2020] The Accelerate Team--- License : BSD3------ Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>--- Stability : experimental--- Portability : non-portable (GHC extensions)-----module Data.Array.Accelerate.LLVM.Native.Link.MachO (-- loadObject,--) where--import Data.Array.Accelerate.Error-import Data.Array.Accelerate.LLVM.Native.Link.Object-import Data.Array.Accelerate.Lifetime-import qualified Data.Array.Accelerate.Debug as Debug--import Control.Applicative-import Control.Monad-import Data.Bits-import Data.ByteString ( ByteString )-import Data.Maybe ( catMaybes )-import Data.Serialize.Get-import Data.Vector ( Vector )-import Data.Word-import Foreign.C-import Foreign.ForeignPtr-import Foreign.ForeignPtr.Unsafe-import Foreign.Marshal-import Foreign.Ptr-import Foreign.Storable-import GHC.ForeignPtr ( mallocPlainForeignPtrAlignedBytes )-import GHC.Prim ( addr2Int#, int2Word# )-import GHC.Ptr ( Ptr(..) )-import GHC.Word ( Word64(..) )-import System.IO.Unsafe-import System.Posix.DynamicLinker-import Text.Printf-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Internal as B-import qualified Data.ByteString.Short as BS-import qualified Data.ByteString.Unsafe as B-import qualified Data.Vector as V-import Prelude as P--#include <mach-o/loader.h>-#include <mach-o/nlist.h>-#include <mach-o/reloc.h>-#include <mach/machine.h>-#include <sys/mman.h>-#ifdef x86_64_HOST_ARCH-#include <mach-o/x86_64/reloc.h>-#endif-#ifdef powerpc_HOST_ARCH-#include <mach-o/ppc/reloc.h>-#endif----- Dynamic object loading--- -------------------------- Load a Mach-O object file and return pointers to the executable functions--- defined within. The executable sections are aligned appropriately, as--- specified in the object file, and are ready to be executed on the target--- architecture.----loadObject :: HasCallStack => ByteString -> IO (FunctionTable, ObjectCode)-loadObject obj =- case parseObject obj of- Left err -> internalError err- Right (symtab, lcs) -> loadSegments obj symtab lcs----- Execute the load segment commands and return function pointers to the--- executable code in the target memory space.----loadSegments :: HasCallStack => ByteString -> Vector Symbol -> Vector LoadSegment -> IO (FunctionTable, ObjectCode)-loadSegments obj symtab lcs = do- -- Load the segments into executable memory.- --- segs <- V.mapM (loadSegment obj symtab) lcs-- -- Resolve the external symbols defined in the sections of this object into- -- function pointers.- --- -- Note that in order to support ahead-of-time compilation, the generated- -- functions are given unique names by appending with an underscore followed- -- by a unique ID. The execution phase doesn't need to know about this- -- however, so un-mangle the name to the basic "map", "fold", etc.- --- let extern Symbol{..} = sym_extern && sym_segment > 0- resolve Symbol{..} =- let Segment _ fp = segs V.! (fromIntegral (sym_segment-1))- name = BS.toShort (B8.take (B8.length sym_name - 65) sym_name)- addr = castPtrToFunPtr (unsafeForeignPtrToPtr fp `plusPtr` fromIntegral sym_value)- in- (name, addr)- --- funtab = FunctionTable $ V.toList $ V.map resolve (V.filter extern symtab)- objectcode = V.toList segs-- -- The executable pages were allocated on the GC heap. When the pages are- -- finalised, unset the executable bit and mark them as read/write so that- -- they can be reused.- --- objectcode' <- newLifetime objectcode- addFinalizer objectcode' $ do- Debug.traceIO Debug.dump_gc ("gc: unload module: " ++ show funtab)- forM_ objectcode $ \(Segment vmsize oc_fp) -> do- withForeignPtr oc_fp $ \oc_p -> do- mprotect oc_p vmsize ({#const PROT_READ#} .|. {#const PROT_WRITE#})-- return (funtab, objectcode')----- Load a segment and all its sections into memory.------ Extra jump islands are added directly after the segment. On x86_64--- PC-relative jumps and accesses to the global offset table (GOT) are limited--- to 32-bit (+-2GB). If we need to go outside of this range then we must do so--- via the jump islands.------ NOTE: This puts all the sections into a single block of memory. Technically--- this is incorrect because we then have both text and data sections together,--- meaning that data sections are marked as execute when they really shouldn't--- be. These would need to live in different pages in order to be mprotect-ed--- properly.----loadSegment :: HasCallStack => ByteString -> Vector Symbol -> LoadSegment -> IO Segment-loadSegment obj symtab seg@LoadSegment{..} = do- let- pagesize = fromIntegral c_getpagesize-- -- round up to next multiple of given alignment- pad align n = (n + align - 1) .&. (complement (align - 1))-- seg_vmsize' = pad 16 seg_vmsize -- align jump islands to 16 bytes- segsize = pad pagesize (seg_vmsize' + (V.length symtab * 16)) -- jump entries are 16 bytes each (x86_64)- --- seg_fp <- mallocPlainForeignPtrAlignedBytes segsize pagesize- _ <- withForeignPtr seg_fp $ \seg_p -> do- -- Just in case, clear out the segment data (corresponds to NOP)- fillBytes seg_p 0 segsize-- -- Jump tables are placed directly after the segment data- let jump_p = seg_p `plusPtr` seg_vmsize'- V.imapM_ (makeJumpIsland jump_p) symtab-- -- Process each of the sections of this segment- V.mapM_ (loadSection obj symtab seg seg_p jump_p) seg_sections-- -- Mark the page as executable and read-only- mprotect seg_p segsize ({#const PROT_READ#} .|. {#const PROT_EXEC#})- --- return (Segment segsize seg_fp)----- Add the jump-table entries directly to each external undefined symbol.----makeJumpIsland :: Ptr Word8 -> Int -> Symbol -> IO ()-makeJumpIsland jump_p symbolnum Symbol{..} = do-#ifdef x86_64_HOST_ARCH- when (sym_extern && sym_segment == 0) $ do- let- target = jump_p `plusPtr` (symbolnum * 16) :: Ptr Word64- instr = target `plusPtr` 8 :: Ptr Word8- --- poke target sym_value- pokeArray instr [ 0xFF, 0x25, 0xF2, 0xFF, 0xFF, 0xFF ] -- jmp *-14(%rip)-#endif- return ()----- Load a section at the correct offset into the given segment, and apply--- relocations.----loadSection :: HasCallStack => ByteString -> Vector Symbol -> LoadSegment -> Ptr Word8 -> Ptr Word8 -> LoadSection -> IO ()-loadSection obj symtab seg seg_p jump_p sec@LoadSection{..} = do- let (obj_fp, obj_offset, _) = B.toForeignPtr obj- --- withForeignPtr obj_fp $ \obj_p -> do- -- Copy this section's data to the appropriate place in the segment- let src = obj_p `plusPtr` (obj_offset + sec_offset)- dst = seg_p `plusPtr` sec_addr- --- copyBytes dst src sec_size- V.mapM_ (processRelocation symtab seg seg_p jump_p sec) sec_relocs----- Process both local and external relocations. The former are probably not--- necessary since we load all sections into the same memory segment at the--- correct offsets.----processRelocation :: HasCallStack => Vector Symbol -> LoadSegment -> Ptr Word8 -> Ptr Word8 -> LoadSection -> RelocationInfo -> IO ()-#ifdef x86_64_HOST_ARCH-processRelocation symtab LoadSegment{} seg_p jump_p sec RelocationInfo{..}- -- Relocation through global offset table- --- | ri_type == X86_64_RELOC_GOT ||- ri_type == X86_64_RELOC_GOT_LOAD- = internalError "Global offset table relocations not handled yet"-- -- External symbols, both those defined in the sections of this object, and- -- undefined externals. For the latter, the symbol might be outside of the- -- range of 32-bit pc-relative addressing, in which case we need to go via the- -- jump tables.- --- | ri_extern- = let value = sym_value (symtab V.! ri_symbolnum)- value_rel = value - pc' - 2 ^ ri_length -- also subtract size of instruction from PC- in- case ri_pcrel of- False -> relocate value- True -> if (fromIntegral (fromIntegral value_rel::Word32) :: Word64) == value_rel- then relocate value_rel- else do- let value' = castPtrToWord64 (jump_p `plusPtr` (ri_symbolnum * 16 + 8))- value'_rel = value' - pc' - 2 ^ ri_length- --- -- message (printf "relocating %s via jump table" (B8.unpack (sym_name (symtab V.! ri_symbolnum))))- relocate value'_rel-- -- Internal relocation (to constant sections, for example). Since the sections- -- are loaded at the appropriate offsets in a single contiguous segment, this- -- is unnecessary.- --- | otherwise- = return ()-- where- pc :: Ptr Word8- pc = seg_p `plusPtr` (sec_addr sec + ri_address)- pc' = castPtrToWord64 pc-- -- Include the addend value already encoded in the instruction- addend :: (Integral a, Storable a) => Ptr a -> Word64 -> IO a- addend p x = do- base <- peek p- case ri_type of- X86_64_RELOC_SUBTRACTOR -> return $ fromIntegral (fromIntegral base - x)- _ -> return $ fromIntegral (fromIntegral base + x)-- -- Write the new relocated address- relocate :: Word64 -> IO ()- relocate x =- case ri_length of- 0 -> let p' = castPtr pc :: Ptr Word8 in poke p' =<< addend p' x- 1 -> let p' = castPtr pc :: Ptr Word16 in poke p' =<< addend p' x- 2 -> let p' = castPtr pc :: Ptr Word32 in poke p' =<< addend p' x- _ -> internalError "unhandled relocation size"--#else-precessRelocation =- internalError "not defined for non-x86_64 architectures yet"-#endif----- Object file parser--- ---------------------- Parsing depends on whether the Mach-O file is 64-bit and whether it should be--- read as big- or little-endian.----data Peek = Peek- { is64Bit :: !Bool- , getWord16 :: !(Get Word16)- , getWord32 :: !(Get Word32)- , getWord64 :: !(Get Word64)- }---- Load commands directly follow the Mach-O header.----data LoadCommand- = LC_Segment {-# UNPACK #-} !LoadSegment- | LC_SymbolTable {-# UNPACK #-} !(Vector Symbol)---- Indicates that a part of this file is to be mapped into the task's--- address space. The size of the segment in memory, vmsize, must be equal--- to or larger than the amount to map from this file, filesize. The file is--- mapped starting at fileoff to the beginning of the segment in memory,--- vmaddr. If the segment has sections then the section structures directly--- follow the segment command.------ For compactness object files contain only one (unnamed) segment, which--- contains all the sections.----data LoadSegment = LoadSegment- { seg_name :: {-# UNPACK #-} !ByteString- , seg_vmaddr :: {-# UNPACK #-} !Int -- starting virtual memory address of the segment- , seg_vmsize :: {-# UNPACK #-} !Int -- size (bytes) of virtual memory occupied by the segment- , seg_fileoff :: {-# UNPACK #-} !Int -- offset in the file for the data mapped at 'seg_vmaddr'- , seg_filesize :: {-# UNPACK #-} !Int -- size (bytes) of the segment in the file- , seg_sections :: {-# UNPACK #-} !(Vector LoadSection) -- the sections of this segment- }- deriving Show--data LoadSection = LoadSection- { sec_secname :: {-# UNPACK #-} !ByteString- , sec_segname :: {-# UNPACK #-} !ByteString- , sec_addr :: {-# UNPACK #-} !Int -- virtual memory address of this section- , sec_size :: {-# UNPACK #-} !Int -- size in bytes- , sec_offset :: {-# UNPACK #-} !Int -- offset of this section in the file- , sec_align :: {-# UNPACK #-} !Int- , sec_relocs :: {-# UNPACK #-} !(Vector RelocationInfo)- }- deriving Show--data RelocationInfo = RelocationInfo- { ri_address :: {-# UNPACK #-} !Int -- offset from start of the section- , ri_symbolnum :: {-# UNPACK #-} !Int -- index into the symbol table (when ri_extern=True) else section number (??)- , ri_length :: {-# UNPACK #-} !Int -- length of address (bytes) to be relocated- , ri_pcrel :: !Bool -- item containing the address to be relocated uses PC-relative addressing- , ri_extern :: !Bool- , ri_type :: !RelocationType -- type of relocation- }- deriving Show---- A symbol defined in the sections of this object----data Symbol = Symbol- { sym_name :: {-# UNPACK #-} !ByteString- , sym_value :: {-# UNPACK #-} !Word64- , sym_segment :: {-# UNPACK #-} !Word8- , sym_extern :: !Bool- }- deriving Show--#ifdef i386_HOST_ARCH-{# enum reloc_type_generic as RelocationType { } deriving (Eq, Show) #}-#endif-#ifdef x86_64_HOST_ARCH-{# enum reloc_type_x86_64 as RelocationType { } deriving (Eq, Show) #}-#endif-#ifdef powerpc_HOST_ARCH-{# enum reloc_type_ppc as RelocationType { } deriving (Eq, Show) #}-#endif----- Parse the Mach-O object file and return the set of section load commands, as--- well as the symbols defined within the sections of this object.------ Actually _executing_ the load commands, which entails copying the pointed-to--- segments into an appropriate VM image in the target address space, happens--- separately.----parseObject :: ByteString -> Either String (Vector Symbol, Vector LoadSegment)-parseObject obj = do- ((p, ncmd, _), rest) <- runGetState readHeader obj 0- cmds <- catMaybes <$> runGet (replicateM ncmd (readLoadCommand p obj)) rest- let- lc = [ x | LC_Segment x <- cmds ]- st = [ x | LC_SymbolTable x <- cmds ]- --- return (V.concat st, V.fromListN ncmd lc)----- The Mach-O file consists of a header block, a number of load commands,--- followed by the segment data.------ +-------------------+--- | Mach-O header |--- +-------------------+ <- sizeofheader--- | Load command |--- | Load command |--- | ... |--- +-------------------+ <- sizeofcmds + sizeofheader--- | Segment data |--- | Segment data |--- | ... |--- +-------------------+----readHeader :: Get (Peek, Int, Int)-readHeader = do- magic <- getWord32le- p@Peek{..} <- case magic of- {#const MH_MAGIC#} -> return $ Peek False getWord16le getWord32le getWord64le- {#const MH_CIGAM#} -> return $ Peek False getWord16be getWord32be getWord64be- {#const MH_MAGIC_64#} -> return $ Peek True getWord16le getWord32le getWord64le- {#const MH_CIGAM_64#} -> return $ Peek True getWord16be getWord32be getWord64be- m -> fail (printf "unknown magic: %x" m)- cpu_type <- getWord32- -- c2HS has trouble with the CPU_TYPE_* macros due to the type cast-#ifdef i386_HOST_ARCH- when (cpu_type /= 0x0000007) $ fail "expected i386 object file"-#endif-#ifdef x86_64_HOST_ARCH- when (cpu_type /= 0x1000007) $ fail "expected x86_64 object file"-#endif-#ifdef powerpc_HOST_ARCH- case is64Bit of- False -> when (cpu_type /= 0x0000012) $ fail "expected PPC object file"- True -> when (cpu_type /= 0x1000012) $ fail "expected PPC64 object file"-#endif- skip {#sizeof cpu_subtype_t#}- filetype <- getWord32- case filetype of- {#const MH_OBJECT#} -> return ()- _ -> fail "expected object file"- ncmds <- fromIntegral <$> getWord32- sizeofcmds <- fromIntegral <$> getWord32- skip $ case is64Bit of- True -> 8 -- flags + reserved- False -> 4 -- flags- return (p, ncmds, sizeofcmds)----- Read a segment load command from the Mach-O file.------ The only thing we are interested in are the symbol table, which tell us which--- external symbols are defined by this object, and the load commands, which--- indicate part of the file is to be mapped into the target address space.--- These will tell us everything we need to know about the generated machine--- code in order to execute it.------ Since we are only concerned with loading object files, there should really--- only be one of each of these.----readLoadCommand :: Peek -> ByteString -> Get (Maybe LoadCommand)-readLoadCommand p@Peek{..} obj = do- cmd <- getWord32- cmdsize <- fromIntegral <$> getWord32- --- let required = toBool $ cmd .&. {#const LC_REQ_DYLD#}- --- case cmd .&. (complement {#const LC_REQ_DYLD#}) of- {#const LC_SEGMENT#} -> Just . LC_Segment <$> readLoadSegment p obj- {#const LC_SEGMENT_64#} -> Just . LC_Segment <$> readLoadSegment p obj- {#const LC_SYMTAB#} -> Just . LC_SymbolTable <$> readLoadSymbolTable p obj- {#const LC_DYSYMTAB#} -> const Nothing <$> readDynamicSymbolTable p obj- {#const LC_LOAD_DYLIB#} -> fail "unhandled LC_LOAD_DYLIB"- this -> do if required- then fail (printf "unknown load command required for execution: 0x%x" this)- else message (printf "skipping load command: 0x%x" this)- skip (cmdsize - 8)- return Nothing----- Read a load segment command, including any relocation entries.----readLoadSegment :: Peek -> ByteString -> Get LoadSegment-readLoadSegment p@Peek{..} obj =- if is64Bit- then readLoadSegment64 p obj- else readLoadSegment32 p obj--readLoadSegment32 :: Peek -> ByteString -> Get LoadSegment-readLoadSegment32 p@Peek{..} obj = do- name <- B.takeWhile (/= 0) <$> getBytes 16- vmaddr <- fromIntegral <$> getWord32- vmsize <- fromIntegral <$> getWord32- fileoff <- fromIntegral <$> getWord32- filesize <- fromIntegral <$> getWord32- skip (2 * {#sizeof vm_prot_t#}) -- maxprot, initprot- nsect <- fromIntegral <$> getWord32- skip 4 -- flags- --- message (printf "LC_SEGMENT: Mem: 0x%09x-0x09%x" vmaddr (vmaddr + vmsize))- secs <- V.replicateM nsect (readLoadSection32 p obj)- --- return LoadSegment- { seg_name = name- , seg_vmaddr = vmaddr- , seg_vmsize = vmsize- , seg_fileoff = fileoff- , seg_filesize = filesize- , seg_sections = secs- }--readLoadSegment64 :: Peek -> ByteString -> Get LoadSegment-readLoadSegment64 p@Peek{..} obj = do- name <- B.takeWhile (/= 0) <$> getBytes 16- vmaddr <- fromIntegral <$> getWord64- vmsize <- fromIntegral <$> getWord64- fileoff <- fromIntegral <$> getWord64- filesize <- fromIntegral <$> getWord64- skip (2 * {#sizeof vm_prot_t#}) -- maxprot, initprot- nsect <- fromIntegral <$> getWord32- skip 4 -- flags- --- message (printf "LC_SEGMENT_64: Mem: 0x%09x-0x%09x" vmaddr (vmaddr + vmsize))- secs <- V.replicateM nsect (readLoadSection64 p obj)- --- return LoadSegment- { seg_name = name- , seg_vmaddr = vmaddr- , seg_vmsize = vmsize- , seg_fileoff = fileoff- , seg_filesize = filesize- , seg_sections = secs- }--readLoadSection32 :: Peek -> ByteString -> Get LoadSection-readLoadSection32 p@Peek{..} obj = do- secname <- B.takeWhile (/= 0) <$> getBytes 16- segname <- B.takeWhile (/= 0) <$> getBytes 16- addr <- fromIntegral <$> getWord32- size <- fromIntegral <$> getWord32- offset <- fromIntegral <$> getWord32- align <- fromIntegral <$> getWord32- reloff <- fromIntegral <$> getWord32- nreloc <- fromIntegral <$> getWord32- skip 12 -- flags, reserved1, reserved2- --- message (printf " Mem: 0x%09x-0x%09x %s.%s" addr (addr+size) (B8.unpack segname) (B8.unpack secname))- relocs <- either fail return $ runGet (V.replicateM nreloc (loadRelocation p)) (B.drop reloff obj)- --- return LoadSection- { sec_secname = secname- , sec_segname = segname- , sec_addr = addr- , sec_size = size- , sec_offset = offset- , sec_align = align- , sec_relocs = relocs- }--readLoadSection64 :: Peek -> ByteString -> Get LoadSection-readLoadSection64 p@Peek{..} obj = do- secname <- B.takeWhile (/= 0) <$> getBytes 16- segname <- B.takeWhile (/= 0) <$> getBytes 16- addr <- fromIntegral <$> getWord64- size <- fromIntegral <$> getWord64- offset <- fromIntegral <$> getWord32- align <- fromIntegral <$> getWord32- reloff <- fromIntegral <$> getWord32- nreloc <- fromIntegral <$> getWord32- skip 16 -- flags, reserved1, reserved2, reserved3- message (printf " Mem: 0x%09x-0x%09x %s.%s" addr (addr+size) (B8.unpack segname) (B8.unpack secname))- relocs <- either fail return $ runGet (V.replicateM nreloc (loadRelocation p)) (B.drop reloff obj)- --- return LoadSection- { sec_secname = secname- , sec_segname = segname- , sec_addr = addr- , sec_size = size- , sec_offset = offset- , sec_align = align- , sec_relocs = relocs- }--loadRelocation :: Peek -> Get RelocationInfo-loadRelocation Peek{..} = do- addr <- fromIntegral <$> getWord32- val <- getWord32- let symbol = val .&. 0xFFFFFF- pcrel = testBit val 24- extern = testBit val 27- len = (val `shiftR` 25) .&. 0x3- rtype = (val `shiftR` 28) .&. 0xF- rtype' = toEnum (fromIntegral rtype)- --- when (toBool $ addr .&. {#const R_SCATTERED#}) $ fail "unhandled scatted relocation info"- message (printf " Reloc: 0x%04x to %s %d: length=%d, pcrel=%s, type=%s" addr (if extern then "symbol" else "section") symbol len (show pcrel) (show rtype'))- --- return RelocationInfo- { ri_address = addr- , ri_symbolnum = fromIntegral symbol- , ri_pcrel = pcrel- , ri_extern = extern- , ri_length = fromIntegral len- , ri_type = rtype'- }---readLoadSymbolTable :: Peek -> ByteString -> Get (Vector Symbol)-readLoadSymbolTable p@Peek{..} obj = do- symoff <- fromIntegral <$> getWord32- nsyms <- fromIntegral <$> getWord32- stroff <- fromIntegral <$> getWord32- strsize <- getWord32- message "LC_SYMTAB"- message (printf " symbol table is at offset 0x%x (%d), %d entries" symoff symoff nsyms)- message (printf " string table is at offset 0x%x (%d), %d bytes" stroff stroff strsize)- --- let symbols = B.drop symoff obj- strtab = B.drop stroff obj- --- either fail return $ runGet (V.replicateM nsyms (loadSymbol p strtab)) symbols---readDynamicSymbolTable :: Peek -> ByteString -> Get ()-readDynamicSymbolTable Peek{..} _obj = do- if not Debug.debuggingIsEnabled- then skip ({#sizeof dysymtab_command#} - 8)- else do- ilocalsym <- getWord32- nlocalsym <- getWord32- iextdefsym <- getWord32- nextdefsym <- getWord32- iundefsym <- getWord32- nundefsym <- getWord32- skip 4 -- tocoff- ntoc <- getWord32- skip 4 -- modtaboff- nmodtab <- getWord32- skip 12 -- extrefsymoff, nextrefsyms, indirectsymoff,- nindirectsyms <- getWord32- skip 16 -- extreloff, nextrel, locreloff, nlocrel,- message "LC_DYSYMTAB:"- --- if nlocalsym > 0- then message (printf " %d local symbols at index %d" nlocalsym ilocalsym)- else message (printf " No local symbols")- if nextdefsym > 0- then message (printf " %d external symbols at index %d" nextdefsym iextdefsym)- else message (printf " No external symbols")- if nundefsym > 0- then message (printf " %d undefined symbols at index %d" nundefsym iundefsym)- else message (printf " No undefined symbols")- if ntoc > 0- then message (printf " %d table of contents entries" ntoc)- else message (printf " No table of contents")- if nmodtab > 0- then message (printf " %d module table entries" nmodtab)- else message (printf " No module table")- if nindirectsyms > 0- then message (printf " %d indirect symbols" nindirectsyms)- else message (printf " No indirect symbols")--loadSymbol :: Peek -> ByteString -> Get Symbol-loadSymbol Peek{..} strtab = do- n_strx <- fromIntegral <$> getWord32- n_flag <- getWord8- n_sect <- getWord8- skip 2 -- n_desc- n_value <- case is64Bit of- True -> fromIntegral <$> getWord64- False -> fromIntegral <$> getWord32-- let -- Symbols with string table index zero are defined to have a null- -- name (""). Otherwise, drop the leading underscore.- str | n_strx == 0 = B.empty- | otherwise = B.takeWhile (/= 0) (B.drop n_strx strtab)- name- | B.length str > 0 && B8.head str == '_' = B.tail str- | otherwise = str-- -- Extract the four bit fields of the type flag- -- n_pext = n_flag .&. {#const N_PEXT#} -- private external symbol bit- n_stab = n_flag .&. {#const N_STAB#} -- if any bits set, a symbolic debugging entry- n_type = n_flag .&. {#const N_TYPE#} -- mask for type bits- n_ext = n_flag .&. {#const N_EXT#} -- external symbol bit-- unless (n_stab == 0) $ fail "unhandled symbolic debugging entry (stab)"-- case n_type of- {#const N_UNDF#} -> do- funptr <- resolveSymbol name- message (printf " %s: external symbol found at %s" (B8.unpack name) (show funptr))- return Symbol- { sym_name = name- , sym_extern = toBool n_ext- , sym_segment = n_sect- , sym_value = castPtrToWord64 (castFunPtrToPtr funptr)- }-- {#const N_SECT#} -> do- message (printf " %s: local symbol in section %d at 0x%02x" (B8.unpack name) n_sect n_value)- return Symbol- { sym_name = name- , sym_extern = toBool n_ext- , sym_segment = n_sect- , sym_value = n_value- }-- {#const N_ABS#} -> fail "unhandled absolute symbol"- {#const N_PBUD#} -> fail "unhandled prebound (dylib) symbol"- {#const N_INDR#} -> fail "unhandled indirect symbol"- _ -> fail "unknown symbol type"----- Return the address binding the named symbol----resolveSymbol :: ByteString -> Get (FunPtr ())-resolveSymbol name- = unsafePerformIO- $ B.unsafeUseAsCString name $ \c_name -> do- addr <- c_dlsym (packDL Default) c_name- if addr == nullFunPtr- then do- err <- dlerror- return (fail $ printf "failed to resolve symbol %s: %s" (B8.unpack name) err)- else do- return (return addr)----- Utilities--- ------------- Get the address of a pointer as a Word64----castPtrToWord64 :: Ptr a -> Word64-castPtrToWord64 (Ptr addr#) = W64# (int2Word# (addr2Int# addr#))----- C-bits--- ---------- Control the protection of pages----mprotect :: Ptr Word8 -> Int -> Int -> IO ()-mprotect addr len prot- = throwErrnoIfMinus1_ "mprotect"- $ c_mprotect (castPtr addr) (fromIntegral len) (fromIntegral prot)--foreign import ccall unsafe "mprotect"- c_mprotect :: Ptr () -> CSize -> CInt -> IO CInt--foreign import ccall unsafe "getpagesize"- c_getpagesize :: CInt----- Debug--- -------{-# INLINE trace #-}-trace :: String -> a -> a-trace msg = Debug.trace Debug.dump_ld ("ld: " ++ msg)--{-# INLINE message #-}-message :: Monad m => String -> m ()-message msg = trace msg (return ())-
src/Data/Array/Accelerate/LLVM/Native/Link/Object.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.Link.Object -- Copyright : [2017..2020] The Accelerate Team@@ -12,14 +13,19 @@ where import Data.List-import Data.Word-import Foreign.ForeignPtr import Foreign.Ptr+import Formatting import Data.ByteString.Short.Char8 ( ShortByteString, unpack ) import Data.Array.Accelerate.Lifetime +#if defined(mingw32_HOST_OS)+import System.Win32.Types+#else+import System.Posix.DynamicLinker+#endif + -- | The function table is a list of function names together with a pointer in -- the target address space containing the corresponding executable code. --@@ -32,9 +38,18 @@ . showString (intercalate "," [ unpack n | (n,_) <- functionTable f ]) . showString ">>" --- | Object code consists of memory in the target address space.+formatFunctionTable :: Format r (FunctionTable -> r)+formatFunctionTable = later $ \f ->+ bformat (angled (angled (commaSep string))) [ unpack n | (n,_) <- functionTable f ]++-- | Object code consists of a handle to dynamically loaded code, managed+-- by the system linker. ---type ObjectCode = Lifetime [Segment]-data Segment = Segment {-# UNPACK #-} !Int -- size in bytes- {-# UNPACK #-} !(ForeignPtr Word8) -- memory in target address space+type ObjectCode = Lifetime LibraryHandle++#if defined(mingw32_HOST_OS)+type LibraryHandle = HINSTANCE+#else+type LibraryHandle = DL+#endif
+ src/Data/Array/Accelerate/LLVM/Native/Link/Runtime.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.Native.Link.Runtime+-- Copyright : [2022] The Accelerate Team+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- Utilities for linking object code to shared objects and loading those+-- generated shared objects on Unix-like systems.+--++module Data.Array.Accelerate.LLVM.Native.Link.Runtime (++ loadSharedObject++) where++import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Lifetime++import Data.Array.Accelerate.LLVM.Native.Link.Object+import qualified Data.Array.Accelerate.LLVM.Native.Debug as Debug++import Control.Monad+import Data.ByteString.Short.Char8 ( ShortByteString )+import Formatting+import qualified Data.ByteString.Short.Char8 as B8++#if defined(mingw32_HOST_OS)+import Foreign.Ptr ( castPtrToFunPtr )+import System.Win32.DLL+#else+import System.Posix.DynamicLinker+#endif+++-- Dynamic object loading+-- ----------------------++-- Load the shared object file and return pointers to the executable+-- functions defined within+--+loadSharedObject :: HasCallStack => [ShortByteString] -> FilePath -> IO (FunctionTable, ObjectCode)+loadSharedObject nms path = do+#if defined(mingw32_HOST_OS)+ -- shims for win32 api compatibility+ let dlopen' path' = loadLibrary path'+ dlsym dll sym = castPtrToFunPtr <$> getProcAddress dll sym+ dlclose dll = freeLibrary dll+#else+ let dlopen' path' = dlopen path' [RTLD_LAZY, RTLD_LOCAL]+#endif+ --+ so <- dlopen' path+ fun_tab <- fmap FunctionTable $ forM nms $ \nm -> do+ let s = B8.unpack nm+ Debug.traceM Debug.dump_ld ("ld: looking up symbol " % string) s+ sym <- dlsym so s+ return (nm, sym)++ object_code <- newLifetime so+ addFinalizer object_code $ do+ -- XXX: Should we disable unloading objects in tracy mode? Tracy might+ -- still need access to e.g. embedded string data+ Debug.traceM Debug.dump_gc ("gc: unload module: " % formatFunctionTable) fun_tab+ dlclose so++ return (fun_tab, object_code)+
src/Data/Array/Accelerate/LLVM/Native/Plugin.hs view
@@ -27,9 +27,22 @@ import Data.List import qualified Data.Map as Map +#if __GLASGOW_HASKELL__ >= 902+import GHC.Driver.Backend+#if __GLASGOW_HASKELL__ < 910+import GHC.Linker+#endif+import GHC.Linker.Loader ( loadCmdLineLibs )+import GHC.Plugins+import GHC.Runtime.Interpreter+#elif __GLASGOW_HASKELL__ >= 900+import GHC.Plugins+import GHC.Runtime.Linker+#else import GhcPlugins import Linker import SysTools+#endif -- | This GHC plugin is required to support ahead-of-time compilation for the@@ -38,10 +51,14 @@ -- 'Data.Array.Accelerate.LLVM.Native.runQ'* which must be linked into the final -- executable. ----- To use it, add the following to the .cabal file of your project:+-- This plugin is automatically installed when using runQ. In older versions of+-- GHC, it was necessary to manually add the plugin using: -- -- > ghc-options: -fplugin=Data.Array.Accelerate.LLVM.Native.Plugin --+-- That is no longer needed.++-- plugin :: Plugin plugin = defaultPlugin { installCoreToDos = install@@ -59,89 +76,113 @@ pass :: HasCallStack => ModGuts -> CoreM ModGuts pass guts = do- -- Determine the current build environment- --- hscEnv <- getHscEnv- dynFlags <- getDynFlags- this <- getModule- -- Gather annotations for the extra object files which must be supplied to the -- linker in order to complete the current module. --- paths <- nub . concat <$> mapM (objectPaths guts) (mg_binds guts)+ this <- getModule+ paths <- nub . concat <$> mapM (objectPaths guts) (mg_binds guts) - when (not (null paths))+ unless (null paths) $ debugTraceMsg $ hang (text "Data.Array.Accelerate.LLVM.Native.Plugin: linking module" <+> quotes (pprModule this) <+> text "with:") 2 (vcat (map text paths)) -- The linking method depends on the current build target+ -- TODO: Need to update for ghc-8.6: the Backend data type is now abstract --- case hscTarget dynFlags of- HscNothing -> return ()- HscInterpreted ->- -- We are in interactive mode (ghci)- --- when (not (null paths)) . liftIO $ do- let opts = ldInputs dynFlags- objs = map optionOfPath paths- --- linkCmdLineLibs- $ hscEnv { hsc_dflags = dynFlags { ldInputs = opts ++ objs }}+ -- Determine the current build environment+ --+ hscEnv <- getHscEnv+ dynFlags <- getDynFlags - -- This case is not necessary for GHC-8.6 and above.- --- -- We are building to object code.- --- -- Because of separate compilation, we will only encounter the annotation- -- pragmas on files which have changed between invocations. This applies to- -- both @ghc --make@ as well as the separate compile/link phases of building- -- with @cabal@ (and @stack@). Note that whenever _any_ file is updated we- -- must make sure that the linker options contains the complete list of- -- objects required to build the entire project.- --- _ -> liftIO $ do+#if __GLASGOW_HASKELL__ >= 902+ let target = backend dynFlags+#else+ let target = hscTarget dynFlags+#endif++ when (backendGeneratesCode target) $+ if backendWritesFiles target+ then do+ -- The compiler will write files (interface files and object code). This+ -- is true of "real" backends, i.e. not the interpreter. #if __GLASGOW_HASKELL__ < 806- -- Read the object file index and update (we may have added or removed- -- objects for the given module)- --- let buildInfo = mkBuildInfoFileName (objectMapPath dynFlags)- abi <- readBuildInfo buildInfo- --- let abi' = if null paths- then Map.delete this abi- else Map.insert this paths abi- allPaths = nub (concat (Map.elems abi'))- allObjs = map optionOfPath allPaths- --- writeBuildInfo buildInfo abi'+ -- Because of separate compilation, we will only encounter the annotation+ -- pragmas on files which have changed between invocations. This applies to+ -- both @ghc --make@ as well as the separate compile/link phases of building+ -- with @cabal@ (and @stack@). Note that whenever _any_ file is updated we+ -- must make sure that the linker options contains the complete list of+ -- objects required to build the entire project.+ -- - -- Make sure the linker flags are up-to-date.- --- when (not (isNoLink (ghcLink dynFlags))) $ do- linker_info <- getLinkerInfo dynFlags- writeIORef (rtldInfo dynFlags)- $ Just- $ case linker_info of- GnuLD opts -> GnuLD (nub (opts ++ allObjs))- GnuGold opts -> GnuGold (nub (opts ++ allObjs))- DarwinLD opts -> DarwinLD (nub (opts ++ allObjs))- SolarisLD opts -> SolarisLD (nub (opts ++ allObjs))- AixLD opts -> AixLD (nub (opts ++ allObjs))- LlvmLLD opts -> LlvmLLD (nub (opts ++ allObjs))- UnknownLD -> UnknownLD -- no linking performed?+ -- Read the object file index and update (we may have added or removed+ -- objects for the given module)+ --+ let buildInfo = mkBuildInfoFileName (objectMapPath dynFlags)+ abi <- readBuildInfo buildInfo+ --+ let abi' = if null paths+ then Map.delete this abi+ else Map.insert this paths abi+ allPaths = nub (concat (Map.elems abi'))+ allObjs = map optionOfPath allPaths+ --+ writeBuildInfo buildInfo abi'++ -- Make sure the linker flags are up-to-date.+ --+ unless (isNoLink (ghcLink dynFlags)) $ do+ linker_info <- getLinkerInfo dynFlags+ writeIORef (rtldInfo dynFlags)+ $ Just+ $ case linker_info of+ GnuLD opts -> GnuLD (nub (opts ++ allObjs))+ GnuGold opts -> GnuGold (nub (opts ++ allObjs))+ DarwinLD opts -> DarwinLD (nub (opts ++ allObjs))+ SolarisLD opts -> SolarisLD (nub (opts ++ allObjs))+ AixLD opts -> AixLD (nub (opts ++ allObjs))+ LlvmLLD opts -> LlvmLLD (nub (opts ++ allObjs))+ UnknownLD -> UnknownLD -- no linking performed? #endif- return ()+ return () + else+ -- We are in interactive mode (ghci)+ --+ unless (null paths) . liftIO $ do+ let opts = ldInputs dynFlags+ objs = map optionOfPath paths+ --+#if __GLASGOW_HASKELL__ >= 902+ loadCmdLineLibs (hscInterp hscEnv)+ $ hscEnv { hsc_dflags = dynFlags { ldInputs = opts ++ objs }}+#else+ linkCmdLineLibs+ $ hscEnv { hsc_dflags = dynFlags { ldInputs = opts ++ objs }}+#endif return guts +#if __GLASGOW_HASKELL__ < 906+backendGeneratesCode :: Backend -> Bool+backendGeneratesCode NoBackend = False+backendGeneratesCode _ = True++backendWritesFiles :: Backend -> Bool+backendWritesFiles Interpreter = False+backendWritesFiles _ = True+#endif+ objectPaths :: ModGuts -> CoreBind -> CoreM [FilePath] objectPaths guts (NonRec b _) = objectAnns guts b-objectPaths guts (Rec bs) = concat <$> mapM (objectAnns guts) (map fst bs)+objectPaths guts (Rec bs) = concat <$> mapM (objectAnns guts . fst) bs objectAnns :: ModGuts -> CoreBndr -> CoreM [FilePath] objectAnns guts bndr = do anns <- getAnnotations deserializeWithData guts- return [ path | Object path <- lookupWithDefaultUFM anns [] (varUnique bndr) ]+#if __GLASGOW_HASKELL__ >= 900+ return [ path | Object path <- lookupWithDefaultUFM (snd anns) [] (varName bndr) ]+#else+ return [ path | Object path <- lookupWithDefaultUFM anns [] (varUnique bndr) ]+#endif objectMapPath :: DynFlags -> FilePath objectMapPath DynFlags{..}
src/Data/Array/Accelerate/LLVM/Native/Plugin/BuildInfo.hs view
@@ -13,14 +13,19 @@ module Data.Array.Accelerate.LLVM.Native.Plugin.BuildInfo where +#if __GLASGOW_HASKELL__ >= 900+import GHC.Unit+import GHC.Utils.Binary+#else+import Binary import Module+#endif import Data.Map ( Map )-import Data.Serialize import System.Directory import System.FilePath-import qualified Data.ByteString as B import qualified Data.Map as Map+import qualified Data.Map.Internal as Map import Data.Array.Accelerate.Error @@ -33,28 +38,34 @@ exists <- doesFileExist path if not exists then return Map.empty- else do- f <- B.readFile path- case decode f of- Left err -> internalError err- Right m -> return m+ else get =<< readBinMem path writeBuildInfo :: FilePath -> Map Module [FilePath] -> IO ()-writeBuildInfo path objs = B.writeFile path (encode objs)+writeBuildInfo path objs = do+ h <- openBinMem 4096+ put_ h objs+ writeBinMem h path -instance Serialize Module where- put (Module p n) = put p >> put n- get = do- p <- get- n <- get- return (Module p n)--instance Serialize UnitId where- put u = put (unitIdString u)- get = stringToUnitId <$> get+instance (Binary k, Binary v) => Binary (Map k v) where+ get h = do+ t <- getByte h+ case t of+ 0 -> return Map.Tip+ _ -> do+ s <- get h+ k <- get h+ a <- get h+ l <- get h+ r <- get h+ return $ Map.Bin s k a l r -instance Serialize ModuleName where- put m = put (moduleNameString m)- get = mkModuleName <$> get+ put_ h Map.Tip = putByte h 0+ put_ h (Map.Bin s k a l r) = do+ putByte h 1+ put_ h s+ put_ h k+ put_ h a+ put_ h l+ put_ h r
src/Data/Array/Accelerate/LLVM/Native/State.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.State -- Copyright : [2014..2020] The Accelerate Team@@ -16,30 +18,43 @@ ) where --- accelerate+import Data.Array.Accelerate.Debug.Internal+ import Data.Array.Accelerate.LLVM.State import Data.Array.Accelerate.LLVM.Native.Target import Data.Array.Accelerate.LLVM.Native.Execute.Scheduler-import qualified Data.Array.Accelerate.LLVM.Native.Link.Cache as LC-import qualified Data.Array.Accelerate.LLVM.Native.Debug as Debug+import qualified Data.Array.Accelerate.LLVM.Native.Link.Cache as LC+import qualified Data.Array.Accelerate.LLVM.Native.Debug as Debug --- library+import Data.Char import Data.Maybe+import Formatting+import Language.Haskell.TH import System.Environment import System.IO.Unsafe-import Text.Printf import Text.Read-import Prelude as P import GHC.Conc+import GHC.Ptr -- | Execute a computation in the Native backend -- evalNative :: Native -> LLVM Native a -> IO a-evalNative = evalLLVM+-- evalNative = evalLLVM +-- XXX: This is correct for run, but for runN we'll use this operation to+-- do the compilation separately from execution, thus there will be an+-- empty "frame" with no (execution) trace+--+evalNative target acc = do+ let label = Ptr $(litE (stringPrimL (map (fromIntegral . ord) "Native.run\0")))+ emit_frame_mark_start label+ !result <- evalLLVM target acc+ emit_frame_mark_end label+ return result + -- | Create a Native execution target by spawning a worker thread on each of the -- given capabilities. --@@ -128,7 +143,7 @@ -- setNumCapabilities (max ncaps nthreads) - Debug.traceIO Debug.dump_gc (printf "gc: initialise native target with %d worker threads" nthreads)+ Debug.traceM Debug.dump_gc ("gc: initialise native target with " % int % " worker threads") nthreads createTarget [0 .. nthreads-1]
src/Data/Array/Accelerate/LLVM/Native/Target.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TypeApplications #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.Target -- Copyright : [2014..2020] The Accelerate Team@@ -11,26 +12,17 @@ module Data.Array.Accelerate.LLVM.Native.Target ( module Data.Array.Accelerate.LLVM.Target,- module Data.Array.Accelerate.LLVM.Native.Target+ module Data.Array.Accelerate.LLVM.Native.Target,+ nativeTargetTriple,+ nativeCPUName, ) where --- llvm-hs-import LLVM.Target hiding ( Target )-import LLVM.AST.DataLayout ( DataLayout )-import qualified LLVM.Relocation as RelocationModel-import qualified LLVM.CodeModel as CodeModel-import qualified LLVM.CodeGenOpt as CodeOptimisation- -- accelerate import Data.Array.Accelerate.LLVM.Native.Link.Cache ( LinkCache ) import Data.Array.Accelerate.LLVM.Native.Execute.Scheduler ( Workers ) import Data.Array.Accelerate.LLVM.Target ( Target(..) )---- standard library-import Data.ByteString ( ByteString )-import Data.ByteString.Short ( ShortByteString )-import System.IO.Unsafe+import Data.Array.Accelerate.LLVM.Target.ClangInfo -- | Native machine code JIT execution target@@ -42,52 +34,4 @@ instance Target Native where targetTriple = Just nativeTargetTriple- targetDataLayout = Just nativeDataLayout----- | String that describes the native target----{-# NOINLINE nativeTargetTriple #-}-nativeTargetTriple :: ShortByteString-nativeTargetTriple = unsafePerformIO $- -- A target triple suitable for loading code into the current process- getProcessTargetTriple---- | A description of the various data layout properties that may be used during--- optimisation.----{-# NOINLINE nativeDataLayout #-}-nativeDataLayout :: DataLayout-nativeDataLayout- = unsafePerformIO- $ withNativeTargetMachine getTargetMachineDataLayout---- | String that describes the host CPU----{-# NOINLINE nativeCPUName #-}-nativeCPUName :: ByteString-nativeCPUName = unsafePerformIO $ getHostCPUName----- | Bracket the creation and destruction of a target machine for the native--- backend running on this host.----withNativeTargetMachine- :: (TargetMachine -> IO a)- -> IO a-withNativeTargetMachine k = do- initializeNativeTarget- nativeCPUFeatures <- getHostCPUFeatures- (nativeTarget, _) <- lookupTarget Nothing nativeTargetTriple- withTargetOptions $ \targetOptions ->- withTargetMachine- nativeTarget- nativeTargetTriple- nativeCPUName- nativeCPUFeatures- targetOptions- RelocationModel.PIC- CodeModel.Default- CodeOptimisation.Default- k-+ targetDataLayout = Nothing -- LLVM will fill it in just fine for CPU targets
+ test/nofib/Data/Array/Accelerate/LLVM/Native/NoFib/RunQ.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TemplateHaskell #-}+module Data.Array.Accelerate.LLVM.Native.NoFib.RunQ where++import qualified Data.Array.Accelerate as A+import qualified Data.Array.Accelerate.LLVM.Native as CPU++import Test.Tasty+import Test.Tasty.HUnit+++-- WARNING: This module is duplicated (apart from Native/PTX) between the+-- accelerate-llvm-native and accelerate-llvm-ptx backends. This code is not+-- included in the main Accelerate nofib testsuite because of staging issues:+-- the test can only be defined after runQ is known, and runQ is only built+-- after the 'accelerate' package has already finished building. It would be+-- possible to deduplicate the little Accelerate program in there, but that was+-- not deemed worth the effort.+++test_runq :: TestTree+test_runq =+ testGroup "runQ"+ [ testCase "simple" test_simple ]++test_simple :: Assertion+test_simple = do+ let prog :: A.Vector Int -> A.Scalar Int+ !prog = $(CPU.runQ $ \a -> A.sum (A.map (+1) (a :: A.Acc (A.Vector Int))))+ let n = 10000+ prog (A.fromList (A.Z A.:. 10000) [1..]) @=? A.fromList A.Z [n * (n + 1) `div` 2 + n]
test/nofib/Main.hs view
@@ -12,10 +12,8 @@ import Data.Array.Accelerate.Test.NoFib import Data.Array.Accelerate.LLVM.Native-import Data.Array.Accelerate.Debug+import Data.Array.Accelerate.LLVM.Native.NoFib.RunQ main :: IO ()-main = do- beginMonitoring- nofib runN+main = nofib runN test_runq