diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,21 +3,16 @@ # LLVM backends for the Accelerate array language -[![GitHub CI](https://github.com/tmcdonell/accelerate-llvm/workflows/CI/badge.svg)](https://github.com/tmcdonell/accelerate-llvm/actions) +[![CI](https://github.com/AccelerateHS/accelerate-llvm/actions/workflows/ci.yml/badge.svg)](https://github.com/AccelerateHS/accelerate-llvm/actions/workflows/ci.yml) [![Gitter](https://img.shields.io/gitter/room/nwjs/nw.js.svg)](https://gitter.im/AccelerateHS/Lobby) -
-[![Stackage LTS](https://stackage.org/package/accelerate-llvm/badge/lts)](https://stackage.org/lts/package/accelerate-llvm) -[![Stackage Nightly](https://stackage.org/package/accelerate-llvm/badge/nightly)](https://stackage.org/nightly/package/accelerate-llvm) [![Hackage](https://img.shields.io/hackage/v/accelerate-llvm.svg)](https://hackage.haskell.org/package/accelerate-llvm) -
-[![Docker Automated build](https://img.shields.io/docker/automated/tmcdonell/accelerate-llvm.svg)](https://hub.docker.com/r/tmcdonell/accelerate-llvm/) -[![Docker status](https://images.microbadger.com/badges/image/tmcdonell/accelerate-llvm.svg)](https://microbadger.com/images/tmcdonell/accelerate-llvm) This package compiles Accelerate code to LLVM IR, and executes that code on -multicore CPUs as well as NVIDIA GPUs. This avoids the need to go through `nvcc` -or `clang`. For details on Accelerate, refer to the [main repository][GitHub]. +multicore CPUs as well as NVIDIA GPUs. This avoids the need to go through +`nvcc` or write C++ code. For details on Accelerate, refer to the [main +repository][GitHub]. We love all kinds of contributions, so feel free to open issues for missing features as well as report (or fix!) bugs on the [issue tracker][Issues]. @@ -27,179 +22,143 @@ * [Dependencies](#dependencies) - * [Docker](#docker) - * [Installing LLVM](#installing-llvm) - * [Homebrew](#homebrew) + * [macOS](#macos) * [Debian/Ubuntu](#debianubuntu) - * [Building from source](#building-from-source) - * [Installing Accelerate-LLVM](#installing-accelerate-llvm) - * [libNVVM](#libNVVM) + * [Arch Linux](#archlinux) + * [Windows](#windows) Dependencies ------------ -Haskell dependencies are available from Hackage, but there are several external +Haskell dependencies are available from Hackage, but there are some external library dependencies that you will need to install as well: - * [`LLVM`](http://llvm.org) - * [`libFFI`](http://sourceware.org/libffi/) (if using the `accelerate-llvm-native` backend for multicore CPUs) - * [`CUDA`](https://developer.nvidia.com/cuda-downloads) (if using the `accelerate-llvm-ptx` backend for NVIDIA GPUs) - - -Docker ------- - -A [docker](https://www.docker.com) container is provided with this package -preinstalled (via stack) at `/opt/accelerate-llvm`. Note that if you wish to use -the `accelerate-llvm-ptx` GPU backend, you will need to install the [NVIDIA -docker](https://github.com/NVIDIA/nvidia-docker) plugin; see that page for more -information. - -```sh -$ docker run -it tmcdonell/accelerate-llvm -``` - - -Installing LLVM ---------------- - -When installing LLVM, make sure that it includes the `libLLVM` shared library. -If you want to use the GPU targeting `accelerate-llvm-ptx` backend, make sure -you install (or build) LLVM with the 'nvptx' target. +- if using `accelerate-llvm-native` for multicore CPU: + [`libFFI`](http://sourceware.org/libffi/) +- if using `accelerate-llvm-ptx` for GPU: + [`CUDA`](https://developer.nvidia.com/cuda-downloads); + [Note that not all versions of CUDA support all NVIDIA GPUs](https://en.wikipedia.org/wiki/CUDA#GPUs_supported) +- [`clang`](https://clang.llvm.org/) (if using `accelerate-llvm-ptx`: version + 16 or higher, built with support for the `nvptx` backend). `accelerate-llvm` + uses the command-line tool as a way to be compatible with many different LLVM + versions, not to compile C code. (Accelerate passes LLVM IR to `clang`.) -## Homebrew +Below are some OS-specific instructions. If anything here is wrong or out of +date, please file an issue. -Example using [Homebrew](http://brew.sh) on macOS: +## macOS -```sh -$ brew install llvm-hs/llvm/llvm-9 -``` +To get `libFFI`, run `brew install libffi`. `clang` is already provided with +macOS (you may need to `xcode-select --install`), and CUDA is not supported on +macOS. ## Debian/Ubuntu -For Debian/Ubuntu based Linux distributions, the LLVM.org website provides -binary distribution packages. Check [apt.llvm.org](http://apt.llvm.org) for -instructions for adding the correct package database for your OS version, and -then: - -```sh -$ apt-get install llvm-9-dev -``` - -## Building from source - -If your OS does not have an appropriate LLVM distribution available, you can also build from source. Detailed build instructions are available on the [LLVM.org website](http://releases.llvm.org/6.0.0/docs/CMake.html). Note that you will require at least [CMake 3.4.3](http://www.cmake.org/cmake/resources/software.html) and a recent C++ compiler; at least Clang 3.1, GCC 4.8, or Visual Studio 2015 (update 3). - - 1. Download and unpack the [LLVM-9 source code](https://github.com/llvm/llvm-project/releases/download/llvmorg-9.0.1/llvm-9.0.1.src.tar.xz). We'll refer to - the path that the source tree was unpacked to as `LLVM_SRC`. Only the main - LLVM source tree is required, but you can optionally add other components - such as the Clang compiler or Polly loop optimiser. See the [LLVM releases](http://releases.llvm.org/download.html#9.0.1) - page for the complete list. - - 2. Create a temporary build directory and `cd` into it, for example: - ```sh - $ mkdir /tmp/build - $ cd /tmp/build - ``` - - 3. Execute the following to configure the build. Here `INSTALL_PREFIX` is - where LLVM is to be installed, for example `/usr/local` or - `$HOME/opt/llvm`: - ```sh - $ cmake $LLVM_SRC -DCMAKE_INSTALL_PREFIX=$INSTALL_PREFIX -DCMAKE_BUILD_TYPE=Release -DLLVM_ENABLE_ASSERTIONS=ON -DLLVM_BUILD_LLVM_DYLIB=ON -DLLVM_LINK_LLVM_DYLIB=ON - ``` - See [options and variables](http://llvm.org/docs/CMake.html#options-and-variables) - for a list of additional build parameters you can specify. - - 4. Build and install: - ```sh - $ cmake --build . - $ cmake --build . --target install - ``` - - 5. For macOS only, some additional steps are useful to work around issues related - to [System Integrity Protection](https://en.wikipedia.org/wiki/System_Integrity_Protection): - ```sh - cd $INSTALL_PREFIX/lib - ln -s libLLVM.dylib libLLVM-9.dylib - install_name_tool -id $PWD/libLTO.dylib libLTO.dylib - install_name_tool -id $PWD/libLLVM.dylib libLLVM.dylib - install_name_tool -change '@rpath/libLLVM.dylib' $PWD/libLLVM.dylib libLTO.dylib - ``` - +For `clang`: +- On Ubuntu 24.04 (noble) / Debian trixie or higher: `sudo apt install clang`. +- Otherwise, if you need only the CPU backend (`accelerate-llvm-native`): + `sudo apt install clang` will give you an old version of `clang`, but the CPU + backend is likely to work fine. +- If you are on an older distro and need the GPU backend + (`accelerate-llvm-ptx`): `clang` version 16 or higher is required. + Add the apt source from [apt.llvm.org](https://apt.llvm.org/). The neatest + way to do this is to create a file `/etc/apt/sources.list.d/llvm.list` (the + precise file name does not matter) and put in it, for Ubuntu (change "jammy" + as appropriate): -Installing Accelerate-LLVM --------------------------- + deb http://apt.llvm.org/jammy/ llvm-toolchain-jammy main + deb-src http://apt.llvm.org/jammy/ llvm-toolchain-jammy main -Once the dependencies are installed, we are ready to install `accelerate-llvm`. + or for Debian (change "bookworm" as appropriate): -For example, installation using [`stack`](http://docs.haskellstack.org/en/stable/README.html) -just requires you to point it to the appropriate configuration file: -```sh -$ ln -s stack-8.8.yaml stack.yaml -$ stack setup -$ stack install -``` + deb http://apt.llvm.org/bookworm/ llvm-toolchain-bookworm main + deb-src http://apt.llvm.org/bookworm/ llvm-toolchain-bookworm main -Note that the version of [`llvm-hs`](https://hackage.haskell.org/package/llvm-hs) -used must match the installed version of LLVM, which is currently 9.0. + and `sudo apt update; sudo apt install clang`. This gets you the latest + version of `clang`; different sources are also available for specific + versions (see [apt.llvm.org](https://apt.llvm.org)). +To use the CPU backend (`accelerate-llvm-native`), install `libFFI` using +`sudo apt install libffi-dev`. -## libNVVM +To use the GPU backend (`accelerate-llvm-ptx`), install CUDA from +[here](https://developer.nvidia.com/cuda-downloads?target_os=Linux) +("deb (network)" is smoother than the "deb (local)" option). -The `accelerate-llvm-ptx` backend can optionally be compiled to generate GPU -code using the `libNVVM` library, rather than LLVM's inbuilt NVPTX code -generator. `libNVVM` is a closed-source library distributed as part of the -NVIDIA CUDA toolkit, and is what the `nvcc` compiler itself uses internally when -compiling CUDA C code. +## Arch Linux -Using `libNVVM` _may_ improve GPU performance compared to the code generator -built in to LLVM. One difficulty with using it however is that since `libNVVM` -is also based on LLVM, and typically lags LLVM by several releases, you must -install `accelerate-llvm` with a "compatible" version of LLVM, which will depend -on the version of the CUDA toolkit you have installed. The following table shows -combinations which have been tested: +Run `sudo pacman -S clang`. To use the CPU backend (`accelerate-llvm-native`), +additionally run `sudo pacman -S libffi`. To use the GPU backend +(`accelerate-llvm-ptx`), additionally run `sudo pacman -S cuda`. -| | LLVM-3.3 | LLVM-3.4 | LLVM-3.5 | LLVM-3.8 | LLVM-3.9 | LLVM-4.0 | LLVM-5.0 | LLVM-6.0 | LLVM-7 | LLVM-8 | LLVM-9 | -| ------------- | :------: | :------: | :------: | :------: | :------: | :------: | :------: | :------: | :----: | :----: | :----: | -| **CUDA-7.0** | ⭕ | ❌ | | | | | | | | | | -| **CUDA-7.5** | | ⭕ | ⭕ | ❌ | | | | | | | | -| **CUDA-8.0** | | | ⭕ | ⭕ | ❌ | ❌ | | | | | | -| **CUDA-9.0** | | | | | | ❌ | ❌ | | | | | -| **CUDA-9.1** | | | | | | | | | | | | -| **CUDA-9.2** | | | | | | | | | | | | -| **CUDA-10.0** | | | | | | | | | | | | -| **CUDA-10.1** | | | | | | | | | | | | +## Windows -Where ⭕ = Works, and ❌ = Does not work. +We recommend WSL2 (not WSL1, WSL2!) and following the Ubuntu instructions +above. The remainder of this text attemps to give you a working system on +Windows native. -The above table is incomplete! If you try a particular combination and find that -it does or does not work, please let us know! +Install `clang`; you have two options: +1. Using + [WinGet](https://learn.microsoft.com/en-us/windows/package-manager/winget/): + `winget install LLVM.LLVM` +2. By downloading the installer directly (WinGet just runs the same installer) + from [here](https://github.com/llvm/llvm-project/releases) (choose + "LLVM-<version>-win64.exe" from the latest release; you may need to click + "Show all 57 assets"). +This will also give you `libFFI`. -Note that the above restrictions on CUDA and LLVM version exist _only_ if you -want to use the NVVM component. Otherwise, you should be free to use any -combination of CUDA and LLVM. +
Optionally, add clang (and more) to your system path. Click to see how. -Also note that `accelerate-llvm-ptx` itself currently requires at least LLVM-4.0. +Accelerate should be able to find `clang` automatically even if you do not do +this. However, for easy access to `clang` and all other LLVM executables, add +`C:\Program Files\LLVM\bin` to the system path as follows: +1. Search for "environment variables" in the start menu +2. Click "Edit the system environment variables" +3. Click on "Environment Variables..." +4. Double-click on the user variable called "Path" +5. And add a new entry containing `C:\Program Files\LLVM\bin`. -Using `stack`, either edit the `stack.yaml` and add the following section: +Note that if you add an entry here manually, it is a good idea to clean it up +again if you uninstall LLVM/clang. (Leaving it there is not very harmful, +however.) -```yaml -flags: - accelerate-llvm-ptx: - nvvm: true -``` +You may find that the LLVM/clang installer has already added the Path entry +automatically (it did not for us); if so, no need to add a second entry. -Or install using the following option on the command line: +—— +
-```sh -$ stack install accelerate-llvm-ptx --flag accelerate-llvm-ptx:nvvm -``` +You may additionally need the VS Build Tools, if you have not yet installed and +set up Visual Studio otherwise. You need this if `clang` complains that it is +`unable to find a Visual Studio installation; try running Clang from a developer command prompt`. -If installing via `cabal`: +1. If you already have the Visual Studio Installer on your system, open it and + check if you already have Visual Studio (Community) installed. Note that + this is completely unrelated to VS _Code_. + - If you already have VS (Community): inside the Visual Studio Installer, + click on "Modify" in the VS (Community) box. This should get you a screen + with "workloads" you can select. + - If you do not yet have VS (Community), install the VS Build Tools: go to + https://visualstudio.microsoft.com/downloads, scroll down to "All + Downloads", open "Tools for Visual Studio", and select "Build Tools for + Visual Studio". If you run the installer, you should get a screen with + "workloads" you can select. +2. Under the Workloads tab, choose the "Desktop development with C++" workload. + If you want to save a bit of disk space (not much), keep only the following + two options selected: + - "MSVC v143 - VE 2022 C++ x64/x86 build tools (Latest)" + - "Windows 11 SDK (…)" (choose the latest option). The attentive reader may + note that the wizard also offers Clang; we recommend a separate Clang + install for Accelerate because the one from VS somehow doesn’t seem to + work properly with Accelerate. If you find out why, please let us know. +3. Install that. This takes a while. -```sh -$ cabal install accelerate-llvm-ptx -fnvvm -``` +It turns out that having both Visual Studio and the Build Tools installed +results in Clang getting confused between the two (it appears that Visual +Studio is 64-bit (x64) and the Build Tools are 32-bit (x86)). If Clang +complains about the bit-ness of your system libraries, double-check that you +haven’t installed both simultaneously. +The GPU backend (`accelerate-llvm-ptx`) probably doesn't work on Windows; in +any case, it is untested. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 diff --git a/SetupHooks.hs b/SetupHooks.hs new file mode 100644 --- /dev/null +++ b/SetupHooks.hs @@ -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 diff --git a/accelerate-llvm-native.cabal b/accelerate-llvm-native.cabal --- a/accelerate-llvm-native.cabal +++ b/accelerate-llvm-native.cabal @@ -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 package. . [/Dependencies/] . Haskell dependencies are available from Hackage. The following external - libraries are alse required: - . - * - . - * - . - [/Installing LLVM/] - . - /Homebrew/ - . - Example using Homebrew on macOS: - . - > brew install llvm-hs/llvm/llvm-9 - . - /Debian & Ubuntu/ - . - For Debian/Ubuntu based Linux distributions, the LLVM.org website provides - binary distribution packages. Check for - instructions for adding the correct package database for your OS version, - and then: - . - > apt-get install llvm-9-dev - . - /Building from source/ + dependencies are also required: . - If your OS does not have an appropriate LLVM distribution available, you can - also build from source. Detailed build instructions are available on - . Make sure to - include the cmake build options - @-DLLVM_BUILD_LLVM_DYLIB=ON -DLLVM_LINK_LLVM_DYLIB=ON@ so that the @libLLVM@ - shared library will be built. + * (not used to compile C code, but to compile generated LLVM IR via a mostly LLVM-version-independent interface) + * . + For installation instructions, see the . -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Trevor L. McDonell maintainer: Trevor L. McDonell bug-reports: https://github.com/AccelerateHS/accelerate/issues category: Accelerate, Compilers/Interpreters, Concurrency, Data, Parallelism -extra-source-files: +extra-doc-files: CHANGELOG.md README.md +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 diff --git a/src/Control/Concurrent/Extra.hs b/src/Control/Concurrent/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Extra.hs @@ -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 +-- 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 + diff --git a/src/Data/Array/Accelerate/LLVM/Native.hs b/src/Data/Array/Accelerate/LLVM/Native.hs --- a/src/Data/Array/Accelerate/LLVM/Native.hs +++ b/src/Data/Array/Accelerate/LLVM/Native.hs @@ -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 diff --git a/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Base.hs b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Base.hs --- a/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Base.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Base.hs @@ -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 + } } diff --git a/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Fold.hs b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Fold.hs --- a/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Fold.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Fold.hs @@ -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 diff --git a/src/Data/Array/Accelerate/LLVM/Native/CodeGen/FoldSeg.hs b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/FoldSeg.hs --- a/src/Data/Array/Accelerate/LLVM/Native/CodeGen/FoldSeg.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/FoldSeg.hs @@ -140,5 +140,3 @@ writeArray TypeInt arrOut ii r - return_ - diff --git a/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Generate.hs b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Generate.hs --- a/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Generate.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Generate.hs @@ -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_ diff --git a/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Map.hs b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Map.hs --- a/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Map.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Map.hs @@ -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_ diff --git a/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Permute.hs b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Permute.hs --- a/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Permute.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Permute.hs @@ -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 diff --git a/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Scan.hs b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Scan.hs --- a/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Scan.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Scan.hs @@ -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_ diff --git a/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Stencil.hs b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Stencil.hs --- a/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Stencil.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Stencil.hs @@ -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 diff --git a/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Transform.hs b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Transform.hs --- a/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Transform.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Transform.hs @@ -59,5 +59,3 @@ b <- app1 f a writeArray TypeInt arrOut i' b - return_ - diff --git a/src/Data/Array/Accelerate/LLVM/Native/Compile.hs b/src/Data/Array/Accelerate/LLVM/Native/Compile.hs --- a/src/Data/Array/Accelerate/LLVM/Native/Compile.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/Compile.hs @@ -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" diff --git a/src/Data/Array/Accelerate/LLVM/Native/Compile/Cache.hs b/src/Data/Array/Accelerate/LLVM/Native/Compile/Cache.hs --- a/src/Data/Array/Accelerate/LLVM/Native/Compile/Cache.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/Compile/Cache.hs @@ -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" diff --git a/src/Data/Array/Accelerate/LLVM/Native/Compile/Optimise.hs b/src/Data/Array/Accelerate/LLVM/Native/Compile/Optimise.hs deleted file mode 100644 --- a/src/Data/Array/Accelerate/LLVM/Native/Compile/Optimise.hs +++ /dev/null @@ -1,142 +0,0 @@ --- | --- Module : Data.Array.Accelerate.LLVM.Native.Compile.Optimise --- Copyright : [2014..2020] The Accelerate Team --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- 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 - ] ---} - diff --git a/src/Data/Array/Accelerate/LLVM/Native/Debug.hs b/src/Data/Array/Accelerate/LLVM/Native/Debug.hs --- a/src/Data/Array/Accelerate/LLVM/Native/Debug.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/Debug.hs @@ -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 +--} diff --git a/src/Data/Array/Accelerate/LLVM/Native/Embed.hs b/src/Data/Array/Accelerate/LLVM/Native/Embed.hs --- a/src/Data/Array/Accelerate/LLVM/Native/Embed.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/Embed.hs @@ -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 diff --git a/src/Data/Array/Accelerate/LLVM/Native/Execute.hs b/src/Data/Array/Accelerate/LLVM/Native/Execute.hs --- a/src/Data/Array/Accelerate/LLVM/Native/Execute.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/Execute.hs @@ -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 diff --git a/src/Data/Array/Accelerate/LLVM/Native/Execute/Async.hs b/src/Data/Array/Accelerate/LLVM/Native/Execute/Async.hs --- a/src/Data/Array/Accelerate/LLVM/Native/Execute/Async.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/Execute/Async.hs @@ -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 #-} diff --git a/src/Data/Array/Accelerate/LLVM/Native/Execute/Divide.hs b/src/Data/Array/Accelerate/LLVM/Native/Execute/Divide.hs --- a/src/Data/Array/Accelerate/LLVM/Native/Execute/Divide.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/Execute/Divide.hs @@ -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 diff --git a/src/Data/Array/Accelerate/LLVM/Native/Execute/Environment.hs b/src/Data/Array/Accelerate/LLVM/Native/Execute/Environment.hs --- a/src/Data/Array/Accelerate/LLVM/Native/Execute/Environment.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/Execute/Environment.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.Execute.Environment diff --git a/src/Data/Array/Accelerate/LLVM/Native/Execute/Marshal.hs b/src/Data/Array/Accelerate/LLVM/Native/Execute/Marshal.hs --- a/src/Data/Array/Accelerate/LLVM/Native/Execute/Marshal.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/Execute/Marshal.hs @@ -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 diff --git a/src/Data/Array/Accelerate/LLVM/Native/Execute/Scheduler.hs b/src/Data/Array/Accelerate/LLVM/Native/Execute/Scheduler.hs --- a/src/Data/Array/Accelerate/LLVM/Native/Execute/Scheduler.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/Execute/Scheduler.hs @@ -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 diff --git a/src/Data/Array/Accelerate/LLVM/Native/Link.hs b/src/Data/Array/Accelerate/LLVM/Native/Link.hs --- a/src/Data/Array/Accelerate/LLVM/Native/Link.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/Link.hs @@ -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 diff --git a/src/Data/Array/Accelerate/LLVM/Native/Link/COFF.hs b/src/Data/Array/Accelerate/LLVM/Native/Link/COFF.hs deleted file mode 100644 --- a/src/Data/Array/Accelerate/LLVM/Native/Link/COFF.hs +++ /dev/null @@ -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 --- 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" - diff --git a/src/Data/Array/Accelerate/LLVM/Native/Link/Cache.hs b/src/Data/Array/Accelerate/LLVM/Native/Link/Cache.hs --- a/src/Data/Array/Accelerate/LLVM/Native/Link/Cache.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/Link/Cache.hs @@ -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 diff --git a/src/Data/Array/Accelerate/LLVM/Native/Link/ELF.chs b/src/Data/Array/Accelerate/LLVM/Native/Link/ELF.chs deleted file mode 100644 --- a/src/Data/Array/Accelerate/LLVM/Native/Link/ELF.chs +++ /dev/null @@ -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 --- 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 -#include - - --- 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 ()) - diff --git a/src/Data/Array/Accelerate/LLVM/Native/Link/MachO.chs b/src/Data/Array/Accelerate/LLVM/Native/Link/MachO.chs deleted file mode 100644 --- a/src/Data/Array/Accelerate/LLVM/Native/Link/MachO.chs +++ /dev/null @@ -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 --- 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 -#include -#include -#include -#include -#ifdef x86_64_HOST_ARCH -#include -#endif -#ifdef powerpc_HOST_ARCH -#include -#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 ()) - diff --git a/src/Data/Array/Accelerate/LLVM/Native/Link/Object.hs b/src/Data/Array/Accelerate/LLVM/Native/Link/Object.hs --- a/src/Data/Array/Accelerate/LLVM/Native/Link/Object.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/Link/Object.hs @@ -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 diff --git a/src/Data/Array/Accelerate/LLVM/Native/Link/Runtime.hs b/src/Data/Array/Accelerate/LLVM/Native/Link/Runtime.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Link/Runtime.hs @@ -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 +-- 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) + diff --git a/src/Data/Array/Accelerate/LLVM/Native/Plugin.hs b/src/Data/Array/Accelerate/LLVM/Native/Plugin.hs --- a/src/Data/Array/Accelerate/LLVM/Native/Plugin.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/Plugin.hs @@ -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{..} diff --git a/src/Data/Array/Accelerate/LLVM/Native/Plugin/BuildInfo.hs b/src/Data/Array/Accelerate/LLVM/Native/Plugin/BuildInfo.hs --- a/src/Data/Array/Accelerate/LLVM/Native/Plugin/BuildInfo.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/Plugin/BuildInfo.hs @@ -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 diff --git a/src/Data/Array/Accelerate/LLVM/Native/State.hs b/src/Data/Array/Accelerate/LLVM/Native/State.hs --- a/src/Data/Array/Accelerate/LLVM/Native/State.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/State.hs @@ -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] diff --git a/src/Data/Array/Accelerate/LLVM/Native/Target.hs b/src/Data/Array/Accelerate/LLVM/Native/Target.hs --- a/src/Data/Array/Accelerate/LLVM/Native/Target.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/Target.hs @@ -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 diff --git a/test/nofib/Data/Array/Accelerate/LLVM/Native/NoFib/RunQ.hs b/test/nofib/Data/Array/Accelerate/LLVM/Native/NoFib/RunQ.hs new file mode 100644 --- /dev/null +++ b/test/nofib/Data/Array/Accelerate/LLVM/Native/NoFib/RunQ.hs @@ -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] diff --git a/test/nofib/Main.hs b/test/nofib/Main.hs --- a/test/nofib/Main.hs +++ b/test/nofib/Main.hs @@ -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