diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,69 +6,78 @@ project adheres to the [Haskell Package Versioning Policy (PVP)](https://pvp.haskell.org) -## [1.2.0.1] - 2019-04-29 -### Added - * support for GHC-8.6 - * support for LLVM-7 - * support for LLVM-8 +## [1.3.0.0] - 2018-08-27 +### Changed + * Switch the thread scheduler to static, rather than dynamic, work stealing + * Thread scheduler is no longer block-synchronous + * Code generation improvements, in particular for >=2-dimensional operations +### Fixed + * Stability improvements + * Race condition in thread scheduler ([accelerate-llvm#49]) + ### Contributors Special thanks to those who contributed patches as part of this release: - * Trevor L. McDonell (@tmcdonell) - * Viktor Kronvall (@considerate) + * Trevor L. McDonell (@tmcdonell) + * Josh Meredith (@JoshMeredith) + * Ivo Gabe de Wolff (@ivogabe) + * Lars van den Haak (@sakehl) + * Joshua Meredith (@JoshMeredith) + ## [1.2.0.0] - 2018-04-03 ### Fixed - * LLVM native throws "SIGSEGV: invalid address" due to fused FP operation ([#409]) + * LLVM native throws "SIGSEGV: invalid address" due to fused FP operation ([#409]) ### Added - * support for half-precision floats - * support for struct-of-array-of-struct representations - * support for LLVM-6.0 - * support for GHC-8.4 + * support for half-precision floats + * support for struct-of-array-of-struct representations + * support for LLVM-6.0 + * support for GHC-8.4 ### Contributors Special thanks to those who contributed patches as part of this release: - * Trevor L. McDonell (@tmcdonell) - * @samft - * Ryan Scott (@ryanglscott) - * Jesse Sigal (@jasigal) - * Moritz Kiefer (@cocreature) + * Trevor L. McDonell (@tmcdonell) + * @samft + * Ryan Scott (@ryanglscott) + * Jesse Sigal (@jasigal) + * Moritz Kiefer (@cocreature) ## [1.1.0.1] - 2017-10-04 ### Fixed - * fix for `runQ*` generating multiple declarations with the same name + * fix for `runQ*` generating multiple declarations with the same name ## [1.1.0.0] - 2017-09-21 ### Added - * support for GHC-8.2 - * caching of compilation results ([accelerate-llvm#17]) - * new runtime linker; this fixes the annoying "forkOS_entry: interrupted" error. Note that currently this only supports x86_64 macOS and linux - * support for ahead-of-time compilation (`runQ` and `runQAsync`) + * support for GHC-8.2 + * caching of compilation results ([accelerate-llvm#17]) + * new runtime linker; this fixes the annoying "forkOS_entry: interrupted" error. Note that currently this only supports x86_64 macOS and linux + * support for ahead-of-time compilation (`runQ` and `runQAsync`) ### Changed - * generalise `run1*` to polyvariadic `runN*` - * programs run using all cores by default; the environment variable - `ACCELERATE_LLVM_NATIVE_THREADS` is used to set the number of worker threads - rather than `+RTS -N` + * generalise `run1*` to polyvariadic `runN*` + * programs run using all cores by default; the environment variable + `ACCELERATE_LLVM_NATIVE_THREADS` is used to set the number of worker threads + rather than `+RTS -N` ## [1.0.0.0] - 2017-03-31 - * initial release + * initial release -[1.2.0.1]: https://github.com/AccelerateHS/accelerate-llvm/compare/v1.2.0.0...v1.2.0.1 -[1.2.0.0]: https://github.com/AccelerateHS/accelerate-llvm/compare/1.1.0.1-native...v1.2.0.0 +[1.3.0.0]: https://github.com/AccelerateHS/accelerate-llvm/compare/1.2.0.0...v1.3.0.0 +[1.2.0.0]: https://github.com/AccelerateHS/accelerate-llvm/compare/1.1.0.1-native...1.2.0.0 [1.1.0.1]: https://github.com/AccelerateHS/accelerate-llvm/compare/1.1.0.0...1.1.0.1-native [1.1.0.0]: https://github.com/AccelerateHS/accelerate-llvm/compare/1.0.0.0...1.1.0.0 [1.0.0.0]: https://github.com/AccelerateHS/accelerate-llvm/compare/be7f91295f77434b2103c70aa1cabb6a4f2b09a8...1.0.0.0 [#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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) [2014..2017] The Accelerate Team. All rights reserved. +Copyright (c) [2014..2020] The Accelerate Team. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,14 +1,20 @@ -An LLVM backend for the Accelerate Array Language -================================================= +
+henlo, my name is Theia -[![Travis](https://img.shields.io/travis/AccelerateHS/accelerate-llvm/master.svg?label=linux)](https://travis-ci.org/AccelerateHS/accelerate-llvm) -[![AppVeyor](https://img.shields.io/appveyor/ci/tmcdonell/accelerate-llvm/master.svg?label=windows)](https://ci.appveyor.com/project/tmcdonell/accelerate-llvm) +# 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) +[![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]. @@ -67,7 +73,7 @@ Example using [Homebrew](http://brew.sh) on macOS: ```sh -$ brew install llvm-hs/llvm/llvm-8 +$ brew install llvm-hs/llvm/llvm-9 ``` ## Debian/Ubuntu @@ -78,17 +84,17 @@ then: ```sh -$ apt-get install llvm-8-dev +$ 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-8.0 source code](http://releases.llvm.org/8.0.0/llvm-8.0.0.src.tar.xz). We'll refer to + 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#8.0.0) + 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: @@ -116,7 +122,7 @@ to [System Integrity Protection](https://en.wikipedia.org/wiki/System_Integrity_Protection): ```sh cd $INSTALL_PREFIX/lib - ln -s libLLVM.dylib libLLVM-8.0.dylib + 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 @@ -131,13 +137,13 @@ 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.6.yaml stack.yaml +$ ln -s stack-8.8.yaml stack.yaml $ stack setup $ stack install ``` 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 8.0. +used must match the installed version of LLVM, which is currently 9.0. ## libNVVM @@ -153,20 +159,23 @@ 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 -some combinations: +combinations which have been tested: -| | 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.0 | LLVM-8.0 | -|:-------------:|:--------:|:--------:|:--------:|:--------:|:--------:|:--------:|:--------:|:--------:|:--------:|:--------:| -| **CUDA-7.0** | ⭕ | ❌ | | | | | | | | | -| **CUDA-7.5** | | ⭕ | ⭕ | ❌ | | | | | | | -| **CUDA-8.0** | | | ⭕ | ⭕ | ❌ | ❌ | | | | | -| **CUDA-9.0** | | | | | | ❌ | ❌ | | | | -| **CUDA-9.1** | | | | | | | | | | | -| **CUDA-9.2** | | | | | | | | | | | -| **CUDA-10.0** | | | | | | | | | | | -| **CUDA-10.1** | | | | | | | | | | | +| | 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** | | | | | | | | | | | | Where ⭕ = Works, and ❌ = Does not work. + +The above table is incomplete! If you try a particular combination and find that +it does or does not work, please let us know! 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 diff --git a/accelerate-llvm-native.cabal b/accelerate-llvm-native.cabal --- a/accelerate-llvm-native.cabal +++ b/accelerate-llvm-native.cabal @@ -1,7 +1,7 @@ name: accelerate-llvm-native -version: 1.2.0.1 +version: 1.3.0.0 cabal-version: >= 1.10 -tested-with: GHC >= 8.0 +tested-with: GHC >= 8.6 build-type: Simple synopsis: Accelerate backend for multicore CPUs @@ -26,7 +26,7 @@ . Example using Homebrew on macOS: . - > brew install llvm-hs/llvm/llvm-8 + > brew install llvm-hs/llvm/llvm-9 . /Debian & Ubuntu/ . @@ -35,40 +35,24 @@ instructions for adding the correct package database for your OS version, and then: . - > apt-get install llvm-8-dev + > 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 - . Make sure to + . 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. . - [/Installing accelerate-llvm/] - . - To use @accelerate-llvm@ it is important that the @llvm-hs@ package is - installed against the @libLLVM@ shared library, rather than statically - linked, so that we can use LLVM from GHCi and Template Haskell. This is the - default configuration, but you can also enforce this explicitly by adding - the following to your @stack.yaml@ file: - . - > flags: - > llvm-hs: - > shared-llvm: true - . - Or by specifying the @shared-llvm@ flag to cabal: - . - > cabal install llvm-hs -fshared-llvm - . license: BSD3 license-file: LICENSE author: Trevor L. McDonell -maintainer: Trevor L. McDonell +maintainer: Trevor L. McDonell bug-reports: https://github.com/AccelerateHS/accelerate/issues -category: Compilers/Interpreters, Concurrency, Data, Parallelism +category: Accelerate, Compilers/Interpreters, Concurrency, Data, Parallelism extra-source-files: CHANGELOG.md @@ -83,7 +67,6 @@ Data.Array.Accelerate.LLVM.Native Data.Array.Accelerate.LLVM.Native.Plugin Data.Array.Accelerate.LLVM.Native.Foreign - Data.Array.Accelerate.LLVM.Native.Distribution.Simple other-modules: Data.Array.Accelerate.LLVM.Native.Array.Data @@ -100,6 +83,8 @@ Data.Array.Accelerate.LLVM.Native.CodeGen.Map Data.Array.Accelerate.LLVM.Native.CodeGen.Permute Data.Array.Accelerate.LLVM.Native.CodeGen.Scan + Data.Array.Accelerate.LLVM.Native.CodeGen.Stencil + Data.Array.Accelerate.LLVM.Native.CodeGen.Transform Data.Array.Accelerate.LLVM.Native.Compile Data.Array.Accelerate.LLVM.Native.Compile.Cache @@ -113,40 +98,37 @@ Data.Array.Accelerate.LLVM.Native.Execute Data.Array.Accelerate.LLVM.Native.Execute.Async + Data.Array.Accelerate.LLVM.Native.Execute.Divide Data.Array.Accelerate.LLVM.Native.Execute.Environment - Data.Array.Accelerate.LLVM.Native.Execute.LBS Data.Array.Accelerate.LLVM.Native.Execute.Marshal + Data.Array.Accelerate.LLVM.Native.Execute.Scheduler Data.Array.Accelerate.LLVM.Native.Plugin.Annotation Data.Array.Accelerate.LLVM.Native.Plugin.BuildInfo - Data.Array.Accelerate.LLVM.Native.Distribution.Simple.Build - Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC - Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC.Internal - Paths_accelerate_llvm_native build-depends: - base >= 4.7 && < 4.13 - , accelerate == 1.2.* - , accelerate-llvm == 1.2.* + base >= 4.10 && < 5 + , accelerate == 1.3.* + , accelerate-llvm == 1.3.* , bytestring >= 0.10.4 - , Cabal >= 2.0 , cereal >= 0.4 , containers >= 0.5 && < 0.7 + , deepseq >= 1.4 , directory >= 1.0 , dlist >= 0.6 , filepath >= 1.0 , ghc , hashable >= 1.0 , libffi >= 0.1 - , llvm-hs >= 4.1 && < 8.1 - , llvm-hs-pure >= 4.1 && < 8.1 + , llvm-hs >= 4.1 && < 9.1 + , llvm-hs-pure >= 4.1 && < 9.1 , lockfree-queue >= 0.2 , mtl >= 2.2.1 , template-haskell - , time >= 1.4 , unique + , vector >= 0.11 hs-source-dirs: src @@ -172,11 +154,8 @@ Data.Array.Accelerate.LLVM.Native.Link.MachO build-depends: - bytestring >= 0.10 - , cereal >= 0.4 - , ghc-prim + ghc-prim , unix >= 2.7 - , vector >= 0.11 build-tools: c2hs >= 0.25 @@ -186,11 +165,8 @@ Data.Array.Accelerate.LLVM.Native.Link.ELF build-depends: - bytestring >= 0.10 - , cereal >= 0.4 - , ghc-prim + ghc-prim , unix >= 2.7 - , vector >= 0.11 build-tools: c2hs >= 0.25 @@ -199,8 +175,7 @@ other-modules: Data.Array.Accelerate.LLVM.Native.Link.COFF - build-depends: - bytestring >= 0.10 + -- build-depends: test-suite nofib-llvm-native @@ -209,7 +184,7 @@ main-is: Main.hs build-depends: - base >= 4.7 + base >= 4.10 , accelerate , accelerate-llvm-native @@ -223,6 +198,7 @@ -rtsopts -with-rtsopts=-A128M -with-rtsopts=-n4M + -with-rtsopts=-N source-repository head @@ -231,7 +207,7 @@ source-repository this type: git - tag: v1.2.0.1 + tag: v1.3.0.0 location: https://github.com/AccelerateHS/accelerate-llvm.git -- vim: nospell 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 @@ -1,16 +1,19 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- Copyright : [2014..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -49,34 +52,32 @@ runQAsync, runQAsyncWith, -- * Execution targets - Native, Strategy, - createTarget, balancedParIO, unbalancedParIO, + Native, + createTarget, ) where --- accelerate -import Data.Array.Accelerate.Array.Sugar ( Arrays ) -import Data.Array.Accelerate.AST ( PreOpenAfun(..) ) -import Data.Array.Accelerate.Async +import Data.Array.Accelerate.AST ( PreOpenAfun(..), arraysR, liftALeftHandSide ) +import Data.Array.Accelerate.AST.LeftHandSide +import Data.Array.Accelerate.Async ( Async, async, wait, poll, cancel ) +import Data.Array.Accelerate.Representation.Array ( liftArraysR ) import Data.Array.Accelerate.Smart ( Acc ) +import Data.Array.Accelerate.Sugar.Array ( Arrays, toArr, fromArr, ArraysR ) import Data.Array.Accelerate.Trafo +import Data.Array.Accelerate.Trafo.Sharing ( Afunction(..), AfunctionRepr(..), afunctionRepr ) +import qualified Data.Array.Accelerate.Sugar.Array as Sugar -import Data.Array.Accelerate.LLVM.Execute.Async ( AsyncR(..) ) -import Data.Array.Accelerate.LLVM.Execute.Environment ( AvalR(..) ) import Data.Array.Accelerate.LLVM.Native.Array.Data ( useRemoteAsync ) import Data.Array.Accelerate.LLVM.Native.Compile ( CompiledOpenAfun, compileAcc, compileAfun ) import Data.Array.Accelerate.LLVM.Native.Embed ( embedOpenAcc ) import Data.Array.Accelerate.LLVM.Native.Execute ( executeAcc, executeOpenAcc ) -import Data.Array.Accelerate.LLVM.Native.Execute.Environment ( Aval ) +import Data.Array.Accelerate.LLVM.Native.Execute.Async ( Par, evalPar, getArrays ) +import Data.Array.Accelerate.LLVM.Native.Execute.Environment ( Val, ValR(..), push ) import Data.Array.Accelerate.LLVM.Native.Link ( ExecOpenAfun, linkAcc, linkAfun ) import Data.Array.Accelerate.LLVM.Native.State import Data.Array.Accelerate.LLVM.Native.Target -import Data.Array.Accelerate.LLVM.State ( LLVM ) import Data.Array.Accelerate.LLVM.Native.Debug as Debug -import qualified Data.Array.Accelerate.LLVM.Native.Execute.Async as E --- standard library -import Data.Typeable import Control.Monad.Trans import System.IO.Unsafe import Text.Printf @@ -97,8 +98,7 @@ -- | As 'run', but execute using the specified target (thread gang). -- runWith :: Arrays a => Native -> Acc a -> a -runWith target a = unsafePerformIO (run' target a) - +runWith target a = 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 @@ -110,19 +110,19 @@ -- | As 'runAsync', but execute using the specified target (thread gang). -- runAsyncWith :: Arrays a => Native -> Acc a -> IO (Async a) -runAsyncWith target a = async (run' target a) +runAsyncWith target a = async (runWithIO target a) -run' :: Arrays a => Native -> Acc a -> IO a -run' target a = execute +runWithIO :: Arrays a => Native -> Acc a -> IO a +runWithIO target a = execute where - !acc = convertAccWith (config target) a - execute = do + !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 (executeAcc exec) - return res + res <- phase "execute" elapsedP (evalPar (executeAcc exec >>= getArrays (arraysR exec))) + return $ toArr res -- | This is 'runN', specialised to an array program of one argument. @@ -182,27 +182,32 @@ -- | As 'runN', but execute using the specified target (thread gang). -- -runNWith :: Afunction f => Native -> f -> AfunctionR f -runNWith target f = exec +runNWith :: forall f. Afunction f => Native -> f -> AfunctionR f +runNWith target f = go (afunctionRepr @f) afun (return Empty) where - !acc = convertAfunWith (config target) f + !acc = convertAfun f !afun = unsafePerformIO $ do dumpGraph acc evalNative target $ do build <- phase "compile" elapsedS (compileAfun acc) >>= dumpStats link <- phase "link" elapsedS (linkAfun build) return link - !exec = go afun (return Aempty) - go :: ExecOpenAfun Native aenv t -> LLVM Native (Aval aenv) -> t - go (Alam l) k = \arrs -> - let k' = do aenv <- k - AsyncR _ a <- E.async (useRemoteAsync arrs) - return (aenv `Apush` a) - in go l k' - go (Abody b) k = unsafePerformIO . phase "execute" elapsedP . evalNative target $ do - aenv <- k - E.get =<< E.async (executeOpenAcc b aenv) + go :: AfunctionRepr t (AfunctionR t) (ArraysFunctionR t) + -> ExecOpenAfun Native aenv (ArraysFunctionR t) + -> Par Native (Val aenv) + -> AfunctionR t + go (AfunctionReprLam repr) (Alam lhs l) k = \(arrs :: a) -> + let k' = do aenv <- k + 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 + aenv <- k + res <- executeOpenAcc b aenv + arrs <- getArrays (arraysR b) res + return $ toArr arrs + go _ _ _ = error "The moon is hanging upside down" -- | As 'run1', but execute asynchronously. @@ -218,41 +223,44 @@ -- | As 'runN', but execute asynchronously. -- -runNAsync :: (Afunction f, RunAsync r, AfunctionR f ~ RunAsyncR r) => f -> r +runNAsync :: (Afunction f, RunAsync r, ArraysFunctionR f ~ RunAsyncR r) => f -> r runNAsync = runNAsyncWith defaultTarget -- | As 'runNWith', but execute asynchronously. -- -runNAsyncWith :: (Afunction f, RunAsync r, AfunctionR f ~ RunAsyncR r) => Native -> f -> r -runNAsyncWith target f = runAsync' target afun (return Aempty) +runNAsyncWith :: (Afunction f, RunAsync r, ArraysFunctionR f ~ RunAsyncR r) => Native -> f -> r +runNAsyncWith target f = exec where - !acc = convertAfunWith (config target) f + !acc = convertAfun f !afun = unsafePerformIO $ do dumpGraph acc evalNative target $ do build <- phase "compile" elapsedS (compileAfun acc) >>= dumpStats link <- phase "link" elapsedS (linkAfun build) return link + !exec = runAsync' target afun (return Empty) class RunAsync f where type RunAsyncR f - runAsync' :: Native -> ExecOpenAfun Native aenv (RunAsyncR f) -> LLVM Native (Aval aenv) -> f + runAsync' :: Native -> ExecOpenAfun Native aenv (RunAsyncR f) -> Par Native (Val aenv) -> f -instance RunAsync b => RunAsync (a -> b) where - type RunAsyncR (a -> b) = a -> RunAsyncR b +instance (Arrays a, RunAsync b) => RunAsync (a -> b) where + type RunAsyncR (a -> b) = ArraysR a -> RunAsyncR b runAsync' _ Abody{} _ _ = error "runAsync: function oversaturated" - runAsync' target (Alam l) k arrs = - let k' = do aenv <- k - AsyncR _ a <- E.async (useRemoteAsync arrs) - return (aenv `Apush` a) + runAsync' target (Alam lhs l) k arrs = + let k' = do aenv <- k + a <- useRemoteAsync (Sugar.arraysR @a) $ fromArr arrs + return (aenv `push` (lhs, a)) in runAsync' target l k' -instance RunAsync (IO (Async b)) where - type RunAsyncR (IO (Async b)) = b +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 $ do - aenv <- k - E.get =<< E.async (executeOpenAcc b aenv) + runAsync' target (Abody b) k = async . phase "execute" elapsedP . evalNative target . evalPar $ do + aenv <- k + ans <- executeOpenAcc b aenv + arrs <- getArrays (arraysR b) ans + return $ toArr arrs -- | Stream a lazily read list of input arrays through the given program, @@ -299,38 +307,17 @@ -- Note that at the splice point the usage of @f@ must monomorphic; i.e. the -- types @a@, @b@ and @c@ must be at some known concrete type. -- --- In order to link the final program together, the included GHC plugin must be --- used when compiling and linking the program. Add the following option to the --- .cabal file of your project: --- --- > ghc-options: -fplugin=Data.Array.Accelerate.LLVM.Native.Plugin --- --- Similarly, the plugin must also run when loading modules in @ghci@. --- --- Additionally, when building a _library_ with Cabal which utilises 'runQ', you --- will need to use the following custom build @Setup.hs@ to ensure that the --- library is linked together properly: --- --- > import Data.Array.Accelerate.LLVM.Native.Distribution.Simple --- > main = defaultMain --- --- And in the .cabal file: --- --- > build-type: Custom --- > custom-setup --- > setup-depends: --- > base --- > , Cabal --- > , accelerate-llvm-native --- --- The custom @Setup.hs@ is only required when building a library with Cabal. --- Building executables with cabal requires only the GHC plugin. --- -- See the -- project for an example. -- -- [/Note:/] -- +-- It is recommended to use GHC-8.6 or later. Earlier GHC versions can +-- successfully build executables utilising 'runQ', but fail to correctly link +-- libraries containing this function. +-- +-- [/Note:/] +-- -- Due to , this -- currently must be as an /untyped/ splice. -- @@ -382,59 +369,58 @@ TH.lamE [TH.varP target] (runQ' [| async |] (TH.varE target) f) -runQ' :: Afunction f => TH.ExpQ -> TH.ExpQ -> f -> TH.ExpQ +runQ' :: forall f. Afunction f => TH.ExpQ -> TH.ExpQ -> f -> TH.ExpQ runQ' using target f = do - -- Reification of the program for segmented folds depends on whether we are - -- executing in parallel or sequentially, where the parallel case requires - -- some extra work to convert the segments descriptor into a segment offset - -- array. Also do this conversion, so that the program can be run both in - -- parallel as well as sequentially (albeit with some additional work that - -- could have been avoided). - -- - -- TLM: We could also just reify the program twice and select at runtime which - -- version to execute. - -- - afun <- let acc = convertAfunWith (phases { convertOffsetOfSegment = True }) f - in TH.runIO $ do +#if MIN_VERSION_template_haskell(2,13,0) + -- The plugin ensures that objects are loaded correctly into GHCi + TH.addCorePlugin "Data.Array.Accelerate.LLVM.Native.Plugin" +#endif + + afun <- let acc = convertAfun f + in TH.runIO $ do dumpGraph acc - evalNative (defaultTarget { segmentOffset = True }) $ - phase "compile" elapsedS (compileAfun acc) >>= dumpStats + evalNative defaultTarget $ + phase "compile" elapsedS (compileAfun acc) >>= dumpStats - -- generate a lambda function with the correct number of arguments and apply - -- directly to the body expression. + -- generate a lambda function with the correct number of arguments and + -- apply directly to the body expression. + -- + -- XXX: remove use of 'getArrays', 'toArr', and 'fromArr' in the embedded + -- code; we should be able to generate all bindings directly and assemble + -- the pieces directly. + -- let - go :: Typeable aenv => CompiledOpenAfun Native aenv t -> [TH.PatQ] -> [TH.ExpQ] -> [TH.StmtQ] -> TH.ExpQ - go (Alam lam) xs as stmts = do + go :: CompiledOpenAfun Native aenv t -> [TH.PatQ] -> [TH.ExpQ] -> [TH.StmtQ] -> TH.ExpQ + 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.conP 'AsyncR [TH.wildP, TH.varP a]) [| E.async (useRemoteAsync $(TH.varE x)) |] - go lam (TH.varP x : xs) (TH.varE a : as) (return s : stmts) + 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) - go (Abody body) xs as stmts = - let aenv = foldr (\a gamma -> [| $gamma `Apush` $a |] ) [| Aempty |] as - eval = TH.noBindS [| E.get =<< E.async (executeOpenAcc $(TH.unTypeQ (embedOpenAcc (defaultTarget { segmentOffset = True }) body)) $aenv) |] - in - TH.lamE (reverse xs) [| $using . phase "execute" elapsedP . evalNative ($target { segmentOffset = True }) $ - $(TH.doE (reverse (eval : stmts))) |] + go (Abody b) xs as stmts = do + r <- TH.newName "r" -- result + s <- TH.newName "s" + let + aenv = foldr (\a gamma -> [| $gamma `push` $a |]) [| Empty |] as + body = embedOpenAcc defaultTarget b + -- + TH.lamE (reverse xs) + [| $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.noBindS [| return $ toArr $(TH.varE s) |] + ])) + |] -- go afun [] [] [] --- How the Accelerate program should be evaluated. --- --- TODO: make sharing/fusion runtime configurable via debug flags or otherwise. --- -config :: Native -> Phase -config target = phases - { convertOffsetOfSegment = segmentOffset target - } - - -- Debugging -- ========= dumpStats :: MonadIO m => a -> m a -dumpStats x = dumpSimplStats >> return x +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/Array/Data.hs b/src/Data/Array/Accelerate/LLVM/Native/Array/Data.hs --- a/src/Data/Array/Accelerate/LLVM/Native/Array/Data.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/Array/Data.hs @@ -1,13 +1,14 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.Array.Data --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- Copyright : [2014..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -15,89 +16,58 @@ module Data.Array.Accelerate.LLVM.Native.Array.Data ( module Data.Array.Accelerate.LLVM.Array.Data, - cloneArray, ) where --- accelerate -import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Array.Data +import Data.Array.Accelerate.Array.Unique +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Elt +import Data.Array.Accelerate.Representation.Shape +import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Type import Data.Array.Accelerate.LLVM.State import Data.Array.Accelerate.LLVM.Array.Data +import Data.Array.Accelerate.LLVM.Native.Execute.Async () -- Async Native import Data.Array.Accelerate.LLVM.Native.Target -import Data.Array.Accelerate.LLVM.Native.Execute.Async () --- standard library import Control.Monad.Trans -import Data.Word -import Foreign.C import Foreign.Ptr -import Foreign.Storable -- | Data instance for arrays in the native backend. We assume a shared-memory -- machine, and just manipulate the underlying Haskell array directly. -- -instance Remote Native +instance Remote Native where + {-# INLINE allocateRemote #-} + allocateRemote repr = liftIO . allocateArray repr -- | Copy an array into a newly allocated array. This uses 'memcpy'. -- -cloneArray :: (Shape sh, Elt e) => Array sh e -> LLVM Native (Array sh e) -cloneArray arr@(Array _ src) = liftIO $ do - out@(Array _ dst) <- allocateArray sh - copyR arrayElt src dst +cloneArray :: ArrayR (Array sh e) -> Array sh e -> LLVM Native (Array sh e) +cloneArray repr (Array sh src) = liftIO $ do + out@(Array _ dst) <- allocateArray repr sh + copyR (arrayRtype repr) src dst return out where - sh = shape arr - n = size sh + n = size (arrayRshape repr) sh - copyR :: ArrayEltR e -> ArrayData e -> ArrayData e -> IO () - copyR ArrayEltRunit _ _ = return () - copyR (ArrayEltRpair aeR1 aeR2) ad1 ad2 = copyR aeR1 (fstArrayData ad1) (fstArrayData ad2) >> - copyR aeR2 (sndArrayData ad1) (sndArrayData ad2) - -- - copyR (ArrayEltRvec2 aeR) (AD_V2 ad1) (AD_V2 ad2) = copyR aeR ad1 ad2 - copyR (ArrayEltRvec3 aeR) (AD_V3 ad1) (AD_V3 ad3) = copyR aeR ad1 ad3 - copyR (ArrayEltRvec4 aeR) (AD_V4 ad1) (AD_V4 ad4) = copyR aeR ad1 ad4 - copyR (ArrayEltRvec8 aeR) (AD_V8 ad1) (AD_V8 ad8) = copyR aeR ad1 ad8 - copyR (ArrayEltRvec16 aeR) (AD_V16 ad1) (AD_V16 ad16) = copyR aeR ad1 ad16 - -- - copyR ArrayEltRint ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRint8 ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRint16 ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRint32 ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRint64 ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRword ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRword8 ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRword16 ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRword32 ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRword64 ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRhalf ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRfloat ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRdouble ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRbool ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRchar ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRcshort ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRcushort ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRcint ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRcuint ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRclong ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRculong ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRcllong ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRcullong ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRcfloat ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRcdouble ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRcchar ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRcschar ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRcuchar ad1 ad2 = copyPrim ad1 ad2 + copyR :: TypeR e -> ArrayData e -> ArrayData e -> IO () + copyR TupRunit !_ !_ = return () + copyR (TupRsingle t) !ad1 !ad2 = copyPrim t ad1 ad2 + copyR (TupRpair !t !t') (ad1, ad1') (ad2, ad2') = do + copyR t ad1 ad2 + copyR t' ad1' ad2' - copyPrim :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Storable a) => ArrayData e -> ArrayData e -> IO () - copyPrim a1 a2 = do - let p1 = ptrsOfArrayData a1 - p2 = ptrsOfArrayData a2 - memcpy (castPtr p2) (castPtr p1) (n * sizeOf (undefined :: a)) + copyPrim :: ScalarType e -> ArrayData e -> ArrayData e -> IO () + copyPrim !tp !a1 !a2 + | ScalarArrayDict{} <- scalarArrayDict tp = do + let p1 = unsafeUniqueArrayPtr a1 + p2 = unsafeUniqueArrayPtr a2 + memcpy (castPtr p2) (castPtr p1) (n * bytesElt (TupRsingle tp)) -- Standard C functions diff --git a/src/Data/Array/Accelerate/LLVM/Native/CodeGen.hs b/src/Data/Array/Accelerate/LLVM/Native/CodeGen.hs --- a/src/Data/Array/Accelerate/LLVM/Native/CodeGen.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/CodeGen.hs @@ -1,11 +1,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.CodeGen --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- Copyright : [2014..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -26,21 +25,20 @@ import Data.Array.Accelerate.LLVM.Native.CodeGen.Map import Data.Array.Accelerate.LLVM.Native.CodeGen.Permute import Data.Array.Accelerate.LLVM.Native.CodeGen.Scan +import Data.Array.Accelerate.LLVM.Native.CodeGen.Stencil +import Data.Array.Accelerate.LLVM.Native.CodeGen.Transform import Data.Array.Accelerate.LLVM.Native.Target instance Skeleton Native where - map _ = mkMap - generate _ = mkGenerate - fold _ = mkFold - fold1 _ = mkFold1 - foldSeg _ = mkFoldSeg - fold1Seg _ = mkFold1Seg - scanl _ = mkScanl - scanl1 _ = mkScanl1 - scanl' _ = mkScanl' - scanr _ = mkScanr - scanr1 _ = mkScanr1 - scanr' _ = mkScanr' - permute _ = mkPermute + map = mkMap + generate = mkGenerate + transform = mkTransform + fold = mkFold + foldSeg = mkFoldSeg + scan = mkScan + scan' = mkScan' + permute = mkPermute + stencil1 = mkStencil1 + stencil2 = mkStencil2 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 @@ -1,13 +1,14 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.Base --- Copyright : [2015..2017] Trevor L. McDonell +-- Copyright : [2015..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -15,20 +16,23 @@ module Data.Array.Accelerate.LLVM.Native.CodeGen.Base where -import Data.Array.Accelerate.Type import Data.Array.Accelerate.LLVM.CodeGen.Base -import Data.Array.Accelerate.LLVM.CodeGen.Downcast 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.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 Control.Monad import Data.Monoid import Data.String import Text.Printf @@ -38,23 +42,21 @@ -- | Generate function parameters that will specify the first and last (linear) -- index of the array this thread should evaluate. -- -gangParam :: (IR Int, IR Int, [LLVM.Parameter]) -gangParam = - let t = scalarType - start = "ix.start" - end = "ix.end" +gangParam :: ShapeR sh -> (Operands sh, Operands sh, [LLVM.Parameter]) +gangParam shr = + let start = "ix.start" + end = "ix.end" + tp = shapeType shr in - (local t start, local t end, [ scalarParameter t start, scalarParameter t end ] ) + (local tp start, local tp end, parameter tp start ++ parameter tp end) --- | The thread ID of a gang worker +-- | The worker ID of the calling thread -- -gangId :: (IR Int, [LLVM.Parameter]) +gangId :: (Operands Int, [LLVM.Parameter]) gangId = - let t = scalarType - tid = "ix.tid" - in - (local t tid, [ scalarParameter t tid ] ) + let tid = "ix.tid" + in (local (TupRsingle scalarTypeInt) tid, [ scalarParameter scalarType tid ] ) -- Global function definitions @@ -69,7 +71,7 @@ -- | Create a single kernel program -- -makeOpenAcc :: UID -> Label -> [LLVM.Parameter] -> CodeGen () -> CodeGen (IROpenAcc Native aenv a) +makeOpenAcc :: UID -> Label -> [LLVM.Parameter] -> CodeGen Native () -> CodeGen Native (IROpenAcc Native aenv a) makeOpenAcc uid name param kernel = do body <- makeKernel (name <> fromString (printf "_%s" (show uid))) param kernel return $ IROpenAcc [body] @@ -77,7 +79,7 @@ -- | Create a complete kernel function by running the code generation process -- specified in the final parameter. -- -makeKernel :: Label -> [LLVM.Parameter] -> CodeGen () -> CodeGen (Kernel Native aenv a) +makeKernel :: Label -> [LLVM.Parameter] -> CodeGen Native () -> CodeGen Native (Kernel Native aenv a) makeKernel name param kernel = do _ <- kernel code <- createBlocks 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 @@ -2,13 +2,14 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.Fold --- Copyright : [2014..2017] Trevor L. McDonell +-- Copyright : [2014..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -16,17 +17,17 @@ module Data.Array.Accelerate.LLVM.Native.CodeGen.Fold where --- accelerate -import Data.Array.Accelerate.Analysis.Match -import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Shape +import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Type -import Data.Array.Accelerate.LLVM.Analysis.Match import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic as A import Data.Array.Accelerate.LLVM.CodeGen.Array import Data.Array.Accelerate.LLVM.CodeGen.Base import Data.Array.Accelerate.LLVM.CodeGen.Constant import Data.Array.Accelerate.LLVM.CodeGen.Environment +import Data.Array.Accelerate.LLVM.CodeGen.Exp import Data.Array.Accelerate.LLVM.CodeGen.IR import Data.Array.Accelerate.LLVM.CodeGen.Monad import Data.Array.Accelerate.LLVM.CodeGen.Sugar @@ -41,45 +42,28 @@ import Prelude as P hiding ( length ) --- Reduce a (possibly empty) array along the innermost dimension. The reduction +-- Reduce an array along the innermost dimension. The reduction -- function must be associative to allow for an efficient parallel --- implementation. The initial element does not need to be a neutral element of --- the operator. +-- implementation. When an initial value is given, the input can be +-- empty. The initial element does not need to be a neutral element of +-- the operator. When no initial value is given, the array must be +-- non-empty -- mkFold - :: forall aenv sh e. (Shape sh, Elt e) - => UID - -> Gamma aenv - -> IRFun2 Native aenv (e -> e -> e) - -> IRExp Native aenv e - -> IRDelayed Native aenv (Array (sh :. Int) e) - -> CodeGen (IROpenAcc Native aenv (Array sh e)) -mkFold uid aenv f z acc - | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) - = (+++) <$> mkFoldAll uid aenv f (Just z) acc - <*> mkFoldFill uid aenv z - - | otherwise - = (+++) <$> mkFoldDim uid aenv f (Just z) acc - <*> mkFoldFill uid aenv z - - --- Reduce a non-empty array along the innermost dimension. The reduction --- function must be associative to allow for efficient parallel implementation. --- -mkFold1 - :: forall aenv sh e. (Shape sh, Elt e) - => UID - -> Gamma aenv - -> IRFun2 Native aenv (e -> e -> e) - -> IRDelayed Native aenv (Array (sh :. Int) e) - -> CodeGen (IROpenAcc Native aenv (Array sh e)) -mkFold1 uid aenv f acc - | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) - = mkFoldAll uid aenv f Nothing acc - - | otherwise - = mkFoldDim uid aenv f Nothing acc + :: UID + -> Gamma aenv + -> ArrayR (Array sh e) + -> IRFun2 Native aenv (e -> e -> e) + -> Maybe (IRExp Native aenv e) + -> MIRDelayed Native aenv (Array (sh, Int) e) + -> CodeGen Native (IROpenAcc Native aenv (Array sh e)) +mkFold uid aenv aR f z arr = + (+++) <$> case aR of + ArrayR ShapeRz eR -> mkFoldAll uid aenv eR f z arr + _ -> mkFoldDim uid aenv aR f z arr + <*> case z of + Just z' -> mkFoldFill uid aenv aR z' + Nothing -> return (IROpenAcc []) -- Reduce a multidimensional (>1) array along the innermost dimension. @@ -88,33 +72,33 @@ -- of an innermost-dimension index) is computed by a single thread. -- mkFoldDim - :: forall aenv sh e. (Shape sh, Elt e) - => UID - -> Gamma aenv - -> IRFun2 Native aenv (e -> e -> e) - -> Maybe (IRExp Native aenv e) - -> IRDelayed Native aenv (Array (sh :. Int) e) - -> CodeGen (IROpenAcc Native aenv (Array sh e)) -mkFoldDim uid aenv combine mseed IRDelayed{..} = + :: UID + -> Gamma aenv + -> ArrayR (Array sh e) + -> IRFun2 Native aenv (e -> e -> e) + -> MIRExp Native aenv e + -> MIRDelayed Native aenv (Array (sh, Int) e) + -> CodeGen Native (IROpenAcc Native aenv (Array sh e)) +mkFoldDim uid aenv aR@(ArrayR shR eR) combine mseed mdelayed = let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Array sh e)) - paramEnv = envParam aenv - -- - paramStride = scalarParameter scalarType ("ix.stride" :: Name Int) - stride = local scalarType ("ix.stride" :: Name Int) + (start, end, paramGang) = gangParam shR + (arrOut, paramOut) = mutableArray aR "out" + (arrIn, paramIn) = delayedArray "in" mdelayed + paramEnv = envParam aenv + zero = liftInt 0 in - makeOpenAcc uid "fold" (paramGang ++ paramStride : paramOut ++ paramEnv) $ do + makeOpenAcc uid "fold" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do - imapFromTo start end $ \seg -> do - from <- mul numType seg stride - to <- add numType from stride - -- - r <- case mseed of - Just seed -> do z <- seed - reduceFromTo from to (app2 combine) z (app1 delayedLinearIndex) - Nothing -> reduce1FromTo from to (app2 combine) (app1 delayedLinearIndex) - writeArray arrOut seg r + sz <- indexHead <$> delayedExtent arrIn + + imapNestFromTo shR start end (irArrayShape arrOut) $ \ix i -> do + r <- case mseed of + Just seed -> do z <- seed + reduceFromTo eR zero sz (app2 combine) z (app1 (delayedIndex arrIn) . indexCons ix) + Nothing -> reduce1FromTo eR zero sz (app2 combine) (app1 (delayedIndex arrIn) . indexCons ix) + + writeArray TypeInt arrOut i r + return_ @@ -142,43 +126,44 @@ -- is an exclusive reduction, the seed element is included at this point. -- mkFoldAll - :: forall aenv e. Elt e - => UID - -> Gamma aenv -- ^ array environment - -> IRFun2 Native aenv (e -> e -> e) -- ^ combination function - -> Maybe (IRExp Native aenv e) -- ^ seed element, if this is an exclusive reduction - -> IRDelayed Native aenv (Vector e) -- ^ input data - -> CodeGen (IROpenAcc Native aenv (Scalar e)) -mkFoldAll uid aenv combine mseed arr = - foldr1 (+++) <$> sequence [ mkFoldAllS uid aenv combine mseed arr - , mkFoldAllP1 uid aenv combine arr - , mkFoldAllP2 uid aenv combine mseed + :: UID + -> Gamma aenv -- ^ array environment + -> TypeR e + -> IRFun2 Native aenv (e -> e -> e) -- ^ combination function + -> MIRExp Native aenv e -- ^ seed element, if this is an exclusive reduction + -> MIRDelayed Native aenv (Vector e) -- ^ input data + -> CodeGen Native (IROpenAcc Native aenv (Scalar e)) +mkFoldAll uid aenv eR combine mseed mdelayed = + foldr1 (+++) <$> sequence [ mkFoldAllS uid aenv eR combine mseed mdelayed + , mkFoldAllP1 uid aenv eR combine mdelayed + , mkFoldAllP2 uid aenv eR combine mseed ] -- Sequential reduction of an entire array to a single element -- mkFoldAllS - :: forall aenv e. Elt e - => UID - -> Gamma aenv -- ^ array environment - -> IRFun2 Native aenv (e -> e -> e) -- ^ combination function - -> Maybe (IRExp Native aenv e) -- ^ seed element, if this is an exclusive reduction - -> IRDelayed Native aenv (Vector e) -- ^ input data - -> CodeGen (IROpenAcc Native aenv (Scalar e)) -mkFoldAllS uid aenv combine mseed IRDelayed{..} = + :: UID + -> Gamma aenv -- ^ array environment + -> TypeR e + -> IRFun2 Native aenv (e -> e -> e) -- ^ combination function + -> MIRExp Native aenv e -- ^ seed element, if this is an exclusive reduction + -> MIRDelayed Native aenv (Vector e) -- ^ input data + -> CodeGen Native (IROpenAcc Native aenv (Scalar e)) +mkFoldAllS uid aenv eR combine mseed mdelayed = let - (start, end, paramGang) = gangParam - paramEnv = envParam aenv - (arrOut, paramOut) = mutableArray ("out" :: Name (Scalar e)) - zero = lift 0 :: IR Int + (start, end, paramGang) = gangParam dim1 + (arrOut, paramOut) = mutableArray (ArrayR dim0 eR) "out" + (arrIn, paramIn) = delayedArray "in" mdelayed + paramEnv = envParam aenv + zero = liftInt 0 in - makeOpenAcc uid "foldAllS" (paramGang ++ paramOut ++ paramEnv) $ do + makeOpenAcc uid "foldAllS" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do r <- case mseed of Just seed -> do z <- seed - reduceFromTo start end (app2 combine) z (app1 delayedLinearIndex) - Nothing -> reduce1FromTo start end (app2 combine) (app1 delayedLinearIndex) - writeArray arrOut zero r + 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. @@ -187,36 +172,30 @@ -- any fused functions on the way. -- mkFoldAllP1 - :: forall aenv e. Elt e - => UID - -> Gamma aenv -- ^ array environment - -> IRFun2 Native aenv (e -> e -> e) -- ^ combination function - -> IRDelayed Native aenv (Vector e) -- ^ input data - -> CodeGen (IROpenAcc Native aenv (Scalar e)) -mkFoldAllP1 uid aenv combine IRDelayed{..} = + :: UID + -> Gamma aenv -- ^ array environment + -> TypeR e + -> IRFun2 Native aenv (e -> e -> e) -- ^ combination function + -> MIRDelayed Native aenv (Vector e) -- ^ input data + -> CodeGen Native (IROpenAcc Native aenv (Scalar e)) +mkFoldAllP1 uid aenv eR combine mdelayed = let - (start, end, paramGang) = gangParam - paramEnv = envParam aenv - (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) - length = local scalarType ("ix.length" :: Name Int) - stride = local scalarType ("ix.stride" :: Name Int) - paramLength = scalarParameter scalarType ("ix.length" :: Name Int) - paramStride = scalarParameter scalarType ("ix.stride" :: Name Int) + (start, end, paramGang) = gangParam dim1 + (arrTmp, paramTmp) = mutableArray (ArrayR dim1 eR) "tmp" + (arrIn, paramIn) = delayedArray "in" mdelayed + piece = local (TupRsingle scalarTypeInt) "ix.piece" + paramPiece = parameter (TupRsingle scalarTypeInt) "ix.piece" + paramEnv = envParam aenv in - makeOpenAcc uid "foldAllP1" (paramGang ++ paramLength : paramStride : paramTmp ++ paramEnv) $ do + makeOpenAcc uid "foldAllP1" (paramGang ++ paramPiece ++ paramTmp ++ paramIn ++ paramEnv) $ do -- A thread reduces a sequential (non-empty) stripe of the input and stores - -- that value into a temporary array at a specific index. The size of the - -- stripe is fixed, but work stealing occurs between stripe indices. This - -- method thus supports non-commutative operators because the order of - -- operations remains left-to-right. + -- that value into a temporary array at a specific index. This method thus + -- supports non-commutative operators because the order of operations + -- remains left-to-right. -- - imapFromTo start end $ \i -> do - inf <- A.mul numType i stride - a <- A.add numType inf stride - sup <- A.min singleType a length - r <- reduce1FromTo inf sup (app2 combine) (app1 delayedLinearIndex) - writeArray arrTmp i r + r <- reduce1FromTo eR (indexHead start) (indexHead end) (app2 combine) (app1 (delayedLinearIndex arrIn)) + writeArray TypeInt arrTmp piece r return_ @@ -230,26 +209,26 @@ -- large, continuing reducing it in parallel. -- mkFoldAllP2 - :: forall aenv e. Elt e - => UID - -> Gamma aenv -- ^ array environment - -> IRFun2 Native aenv (e -> e -> e) -- ^ combination function - -> Maybe (IRExp Native aenv e) -- ^ seed element, if this is an exclusive reduction - -> CodeGen (IROpenAcc Native aenv (Scalar e)) -mkFoldAllP2 uid aenv combine mseed = + :: UID + -> Gamma aenv -- ^ array environment + -> TypeR e + -> IRFun2 Native aenv (e -> e -> e) -- ^ combination function + -> MIRExp Native aenv e -- ^ seed element, if this is an exclusive reduction + -> CodeGen Native (IROpenAcc Native aenv (Scalar e)) +mkFoldAllP2 uid aenv eR combine mseed = let - (start, end, paramGang) = gangParam - paramEnv = envParam aenv - (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) - (arrOut, paramOut) = mutableArray ("out" :: Name (Scalar e)) - zero = lift 0 :: IR Int + (start, end, paramGang) = gangParam dim1 + (arrTmp, paramTmp) = mutableArray (ArrayR dim1 eR) "tmp" + (arrOut, paramOut) = mutableArray (ArrayR dim0 eR) "out" + paramEnv = envParam aenv + zero = liftInt 0 in makeOpenAcc uid "foldAllP2" (paramGang ++ paramTmp ++ paramOut ++ paramEnv) $ do r <- case mseed of Just seed -> do z <- seed - reduceFromTo start end (app2 combine) z (readArray arrTmp) - Nothing -> reduce1FromTo start end (app2 combine) (readArray arrTmp) - writeArray arrOut zero r + 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_ @@ -257,13 +236,13 @@ -- dimensions with the initial element -- mkFoldFill - :: (Shape sh, Elt e) - => UID + :: UID -> Gamma aenv - -> IRExp Native aenv e - -> CodeGen (IROpenAcc Native aenv (Array sh e)) -mkFoldFill uid aenv seed = - mkGenerate uid aenv (IRFun1 (const seed)) + -> ArrayR (Array sh e) + -> IRExp Native aenv e + -> CodeGen Native (IROpenAcc Native aenv (Array sh e)) +mkFoldFill uid aenv aR seed = + mkGenerate uid aenv aR (IRFun1 (const seed)) -- Reduction loops -- --------------- @@ -271,15 +250,15 @@ -- Reduction of a (possibly empty) index space. -- reduceFromTo - :: Elt a - => IR Int -- ^ starting index - -> IR Int -- ^ final index (exclusive) - -> (IR a -> IR a -> CodeGen (IR a)) -- ^ combination function - -> IR a -- ^ initial value - -> (IR Int -> CodeGen (IR a)) -- ^ function to retrieve element at index - -> CodeGen (IR a) -reduceFromTo m n f z get = - iterFromTo m n z $ \i acc -> do + :: TypeR e + -> Operands Int -- ^ starting index + -> Operands Int -- ^ final index (exclusive) + -> (Operands e -> Operands e -> CodeGen Native (Operands e)) -- ^ combination function + -> Operands e -- ^ initial value + -> (Operands Int -> CodeGen Native (Operands e)) -- ^ function to retrieve element at index + -> CodeGen Native (Operands e) +reduceFromTo eR m n f z get = + iterFromTo eR m n z $ \i acc -> do x <- get i y <- f acc x return y @@ -288,14 +267,14 @@ -- contain at least one element. -- reduce1FromTo - :: Elt a - => IR Int -- ^ starting index - -> IR Int -- ^ final index - -> (IR a -> IR a -> CodeGen (IR a)) -- ^ combination function - -> (IR Int -> CodeGen (IR a)) -- ^ function to retrieve element at index - -> CodeGen (IR a) -reduce1FromTo m n f get = do + :: TypeR e + -> Operands Int -- ^ starting index + -> Operands Int -- ^ final index + -> (Operands e -> Operands e -> CodeGen Native (Operands e)) -- ^ combination function + -> (Operands Int -> CodeGen Native (Operands e)) -- ^ function to retrieve element at index + -> CodeGen Native (Operands e) +reduce1FromTo eR m n f get = do z <- get m m1 <- add numType m (ir numType (num numType 1)) - reduceFromTo m1 n f z get + reduceFromTo eR m1 n f z get 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 @@ -1,14 +1,15 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.FoldSeg --- Copyright : [2014..2017] Trevor L. McDonell +-- Copyright : [2014..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -16,17 +17,14 @@ module Data.Array.Accelerate.LLVM.Native.CodeGen.FoldSeg where --- accelerate -import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Representation.Array import Data.Array.Accelerate.Type import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic as A import Data.Array.Accelerate.LLVM.CodeGen.Array import Data.Array.Accelerate.LLVM.CodeGen.Base import Data.Array.Accelerate.LLVM.CodeGen.Environment -import Data.Array.Accelerate.LLVM.CodeGen.IR -import Data.Array.Accelerate.LLVM.CodeGen.Exp ( indexHead ) -import Data.Array.Accelerate.LLVM.CodeGen.Loop +import Data.Array.Accelerate.LLVM.CodeGen.Exp import Data.Array.Accelerate.LLVM.CodeGen.Monad import Data.Array.Accelerate.LLVM.CodeGen.Sugar import Data.Array.Accelerate.LLVM.Compile.Cache @@ -36,86 +34,54 @@ import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop import Data.Array.Accelerate.LLVM.Native.Target ( Native ) -import Control.Applicative import Control.Monad import Prelude as P - --- Segmented reduction along the innermost dimension of an array. Performs one --- reduction per segment of the source array. --- -mkFoldSeg - :: forall aenv sh i e. (Shape sh, IsIntegral i, Elt i, Elt e) - => UID - -> Gamma aenv - -> IRFun2 Native aenv (e -> e -> e) - -> IRExp Native aenv e - -> IRDelayed Native aenv (Array (sh :. Int) e) - -> IRDelayed Native aenv (Segments i) - -> CodeGen (IROpenAcc Native aenv (Array (sh :. Int) e)) -mkFoldSeg uid aenv combine seed arr seg = - (+++) <$> mkFoldSegS uid aenv combine (Just seed) arr seg - <*> mkFoldSegP uid aenv combine (Just seed) arr seg - - --- Segmented reduction along the innermost dimension of an array, where /all/ --- segments are non-empty. --- -mkFold1Seg - :: forall aenv sh i e. (Shape sh, IsIntegral i, Elt i, Elt e) - => UID - -> Gamma aenv - -> IRFun2 Native aenv (e -> e -> e) - -> IRDelayed Native aenv (Array (sh :. Int) e) - -> IRDelayed Native aenv (Segments i) - -> CodeGen (IROpenAcc Native aenv (Array (sh :. Int) e)) -mkFold1Seg uid aenv combine arr seg = - (+++) <$> mkFoldSegS uid aenv combine Nothing arr seg - <*> mkFoldSegP uid aenv combine Nothing arr seg - - +{-- -- Segmented reduction where a single processor reduces the entire array. The -- segments array contains the length of each segment. -- mkFoldSegS :: forall aenv sh i e. (Shape sh, IsIntegral i, Elt i, Elt e) - => UID - -> Gamma aenv - -> IRFun2 Native aenv (e -> e -> e) - -> Maybe (IRExp Native aenv e) - -> IRDelayed Native aenv (Array (sh :. Int) e) - -> IRDelayed Native aenv (Segments i) - -> CodeGen (IROpenAcc Native aenv (Array (sh :. Int) e)) -mkFoldSegS uid aenv combine mseed arr seg = + => UID + -> Gamma aenv + -> IRFun2 Native aenv (e -> e -> e) + -> MIRExp Native aenv e + -> MIRDelayed Native aenv (Array (sh :. Int) e) + -> MIRDelayed Native aenv (Segments i) + -> CodeGen Native (IROpenAcc Native aenv (Array (sh :. Int) e)) +mkFoldSegS uid aenv combine mseed marr mseg = let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Array (sh :. Int) e)) - paramEnv = envParam aenv + (start, end, paramGang) = gangParam @DIM1 + (arrOut, paramOut) = mutableArray @(sh:.Int) "out" + (arrIn, paramIn) = delayedArray @(sh:.Int) "in" marr + (arrSeg, paramSeg) = delayedArray @DIM1 "seg" mseg + paramEnv = envParam aenv in - makeOpenAcc uid "foldSegS" (paramGang ++ paramOut ++ paramEnv) $ do + makeOpenAcc uid "foldSegS" (paramGang ++ paramOut ++ paramIn ++ paramSeg ++ paramEnv) $ do -- Number of segments, useful only if reducing DIM2 and higher - ss <- indexHead <$> delayedExtent seg + ss <- indexHead <$> delayedExtent arrSeg - let test si = A.lt singleType (A.fst si) end - initial = A.pair start (lift 0) + let test si = A.lt singleType (A.fst si) (indexHead end) + initial = A.pair (indexHead start) (lift 0) - body :: IR (Int,Int) -> CodeGen (IR (Int,Int)) + body :: IR (Int,Int) -> CodeGen Native (IR (Int,Int)) body (A.unpair -> (s,inf)) = do -- We can avoid an extra division if this is a DIM1 array. Higher -- dimensional reductions need to wrap around the segment array at -- each new lower-dimensional index. - s' <- case rank (undefined::sh) of + s' <- case rank @sh of 0 -> return s _ -> A.rem integralType s ss - len <- A.fromIntegral integralType numType =<< app1 (delayedLinearIndex seg) s' + len <- A.fromIntegral integralType numType =<< app1 (delayedLinearIndex arrSeg) s' sup <- A.add numType inf len r <- case mseed of Just seed -> do z <- seed - reduceFromTo inf sup (app2 combine) z (app1 (delayedLinearIndex arr)) - Nothing -> reduce1FromTo inf sup (app2 combine) (app1 (delayedLinearIndex arr)) + reduceFromTo inf sup (app2 combine) z (app1 (delayedLinearIndex arrIn)) + Nothing -> reduce1FromTo inf sup (app2 combine) (app1 (delayedLinearIndex arrIn)) writeArray arrOut s r t <- A.add numType s (lift 1) @@ -123,59 +89,56 @@ void $ while test body initial return_ +--} +-- Segmented reduction along the innermost dimension of an array. Performs one +-- reduction per segment of the source array. When no seed is given, assumes +-- that /all/ segments are non-empty. +-- -- This implementation assumes that the segments array represents the offset -- indices to the source array, rather than the lengths of each segment. The -- segment-offset approach is required for parallel implementations. -- -mkFoldSegP - :: forall aenv sh i e. (Shape sh, IsIntegral i, Elt i, Elt e) - => UID - -> Gamma aenv - -> IRFun2 Native aenv (e -> e -> e) - -> Maybe (IRExp Native aenv e) - -> IRDelayed Native aenv (Array (sh :. Int) e) - -> IRDelayed Native aenv (Segments i) - -> CodeGen (IROpenAcc Native aenv (Array (sh :. Int) e)) -mkFoldSegP uid aenv combine mseed arr seg = +mkFoldSeg + :: UID + -> Gamma aenv + -> ArrayR (Array (sh, Int) e) + -> IntegralType i + -> IRFun2 Native aenv (e -> e -> e) + -> MIRExp Native aenv e + -> MIRDelayed Native aenv (Array (sh, Int) e) + -> MIRDelayed Native aenv (Segments i) + -> CodeGen Native (IROpenAcc Native aenv (Array (sh, Int) e)) +mkFoldSeg uid aenv aR@(ArrayR shR eR) int combine mseed marr mseg = let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Array (sh :. Int) e)) - paramEnv = envParam aenv + (start, end, paramGang) = gangParam shR + (arrOut, paramOut) = mutableArray aR "out" + (arrIn, paramIn) = delayedArray "in" marr + (arrSeg, paramSeg) = delayedArray "seg" mseg + paramEnv = envParam aenv in - makeOpenAcc uid "foldSegP" (paramGang ++ paramOut ++ paramEnv) $ do - - -- Number of segments and size of the innermost dimension. These are - -- required if we are reducing a DIM2 or higher array, to properly compute - -- the start and end indices of the portion of the array to reduce. Note - -- that this is a segment-offset array computed by 'scanl (+) 0' of the - -- segment length array, so its size has increased by one. - sz <- indexHead <$> delayedExtent arr - ss <- do n <- indexHead <$> delayedExtent seg - A.sub numType n (lift 1) - - imapFromTo start end $ \s -> do + makeOpenAcc uid "foldSegP" (paramGang ++ paramOut ++ paramIn ++ paramSeg ++ paramEnv) $ do - i <- case rank (undefined::sh) of - 0 -> return s - _ -> A.rem integralType s ss - j <- A.add numType i (lift 1) - u <- A.fromIntegral integralType numType =<< app1 (delayedLinearIndex seg) i - v <- A.fromIntegral integralType numType =<< app1 (delayedLinearIndex seg) j + imapNestFromTo shR start end (irArrayShape arrOut) $ \ix ii -> do - (inf,sup) <- A.unpair <$> case rank (undefined::sh) of - 0 -> return (A.pair u v) - _ -> do q <- A.quot integralType s ss - a <- A.mul numType q sz - A.pair <$> A.add numType u a <*> A.add numType v a + -- Determine the start and end indices of the innermost portion of + -- the array to reduce. This is a segment-offset array computed by + -- 'scanl (+) 0' of the segment length array. + -- + let iz = indexTail ix + i = indexHead ix + -- + j <- A.add numType i (liftInt 1) + u <- A.fromIntegral int numType =<< app1 (delayedLinearIndex arrSeg) i + v <- A.fromIntegral int numType =<< app1 (delayedLinearIndex arrSeg) j - r <- case mseed of - Just seed -> do z <- seed - reduceFromTo inf sup (app2 combine) z (app1 (delayedLinearIndex arr)) - Nothing -> reduce1FromTo inf sup (app2 combine) (app1 (delayedLinearIndex arr)) + r <- case mseed of + Just seed -> do z <- seed + reduceFromTo eR u v (app2 combine) z (app1 (delayedIndex arrIn) . indexCons iz) + Nothing -> reduce1FromTo eR u v (app2 combine) (app1 (delayedIndex arrIn) . indexCons iz) - writeArray arrOut s r + 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 @@ -1,12 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.Generate --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- Copyright : [2014..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -14,13 +14,12 @@ module Data.Array.Accelerate.LLVM.Native.CodeGen.Generate where --- accelerate -import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt ) +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Type import Data.Array.Accelerate.LLVM.CodeGen.Array import Data.Array.Accelerate.LLVM.CodeGen.Base import Data.Array.Accelerate.LLVM.CodeGen.Environment -import Data.Array.Accelerate.LLVM.CodeGen.Exp import Data.Array.Accelerate.LLVM.CodeGen.Monad import Data.Array.Accelerate.LLVM.CodeGen.Sugar import Data.Array.Accelerate.LLVM.Compile.Cache @@ -34,23 +33,23 @@ -- processes multiple adjacent elements. -- mkGenerate - :: forall aenv sh e. (Shape sh, Elt e) - => UID + :: UID -> Gamma aenv - -> IRFun1 Native aenv (sh -> e) - -> CodeGen (IROpenAcc Native aenv (Array sh e)) -mkGenerate uid aenv apply = + -> ArrayR (Array sh e) + -> IRFun1 Native aenv (sh -> e) + -> CodeGen Native (IROpenAcc Native aenv (Array sh e)) +mkGenerate uid aenv repr apply = let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Array sh e)) + (start, end, paramGang) = gangParam (arrayRshape repr) + (arrOut, paramOut) = mutableArray repr "out" paramEnv = envParam aenv + shOut = irArrayShape arrOut in makeOpenAcc uid "generate" (paramGang ++ paramOut ++ paramEnv) $ do - imapFromTo start end $ \i -> do - ix <- indexOfInt (irArrayShape arrOut) i -- convert to multidimensional index - r <- app1 apply ix -- apply generator function - writeArray arrOut i r -- store result + 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/Loop.hs b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Loop.hs --- a/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Loop.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Loop.hs @@ -1,9 +1,13 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module : Data.Array.Accelerate.LLVM.CodeGen.Native.Loop --- Copyright : [2014..2017] Trevor L. McDonell +-- Copyright : [2014..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -12,35 +16,145 @@ where -- accelerate -import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Representation.Shape import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic +import Data.Array.Accelerate.LLVM.CodeGen.Exp import Data.Array.Accelerate.LLVM.CodeGen.IR import Data.Array.Accelerate.LLVM.CodeGen.Monad -import qualified Data.Array.Accelerate.LLVM.CodeGen.Loop as Loop +import qualified Data.Array.Accelerate.LLVM.CodeGen.Loop as Loop +import Data.Array.Accelerate.LLVM.Native.Target ( Native ) + -- | A standard 'for' loop, that steps from the start to end index executing the -- given function at each index. -- imapFromTo - :: IR Int -- ^ starting index (inclusive) - -> IR Int -- ^ final index (exclusive) - -> (IR Int -> CodeGen ()) -- ^ apply at each index - -> CodeGen () + :: Operands Int -- ^ starting index (inclusive) + -> Operands Int -- ^ final index (exclusive) + -> (Operands Int -> CodeGen Native ()) -- ^ apply at each index + -> CodeGen Native () imapFromTo start end body = - Loop.imapFromStepTo start (lift 1) end body + Loop.imapFromStepTo start (liftInt 1) end body + +-- | Generate a series of nested 'for' loops which iterate between the start and +-- end indices of a given hyper-rectangle. LLVM is very good at vectorising +-- these kinds of nested loops, but not so good at vectorising the flattened +-- representation utilising to/from index. +-- +imapNestFromTo + :: ShapeR sh + -> Operands sh -- ^ initial index (inclusive) + -> Operands sh -- ^ final index (exclusive) + -> Operands sh -- ^ total array extent + -> (Operands sh -> Operands Int -> CodeGen Native ()) -- ^ apply at each index + -> CodeGen Native () +imapNestFromTo shr start end extent body = + go shr start end body' + where + body' ix = body ix =<< intOfIndex shr extent ix + + go :: ShapeR t -> Operands t -> Operands t -> (Operands t -> CodeGen Native ()) -> CodeGen Native () + go ShapeRz OP_Unit OP_Unit k + = k OP_Unit + + go (ShapeRsnoc shr') (OP_Pair ssh ssz) (OP_Pair esh esz) k + = go shr' ssh esh + $ \sz -> imapFromTo ssz esz + $ \i -> k (OP_Pair sz i) + + +{-- +-- TLM: this version (seems to) compute the corresponding linear index as it +-- goes. We need to compare it against the above implementation to see if +-- there are any advantages. +-- +imapNestFromTo' + :: forall sh. Shape sh + => Operands sh + -> Operands sh + -> Operands sh + -> (Operands sh -> Operands Int -> CodeGen Native ()) + -> CodeGen Native () +imapNestFromTo' start end extent body = do + startl <- intOfIndex extent start + void $ go (eltType @sh) start end extent (int 1) startl body' + where + body' :: Operands (EltRepr sh) -> Operands Int -> CodeGen Native (Operands Int) + body' ix l = body ix l >> add numType (int 1) l + + go :: TupleType t + -> Operands t + -> Operands t + -> Operands t + -> Operands Int + -> Operands Int + -> (Operands t -> Operands Int -> CodeGen Native (Operands Int)) + -> CodeGen Native (Operands Int) + go TypeRunit OP_Unit OP_Unit OP_Unit _delta l k + = k OP_Unit l + + go (TypeRpair tsh tsz) (OP_Pair ssh ssz) (OP_Pair esh esz) (OP_Pair exh exz) delta l k + | TypeRscalar t <- tsz + , Just Refl <- matchScalarType t (scalarType :: ScalarType Int) + = do + delta' <- mul numType delta exz + go tsh ssh esh exh delta' l $ \sz ll -> do + Loop.iterFromStepTo ssz (int 1) esz ll $ \i l' -> + k (OP_Pair sz i) l' + add numType ll delta' + + go _ _ _ _ _ _ _ + = $internalError "imapNestFromTo'" "expected shape with Int components" +--} + +{-- +-- | Generate a series of nested 'for' loops which iterate between the start and +-- end indices of a given hyper-rectangle. LLVM is very good at vectorising +-- these kinds of nested loops, but not so good at vectorising the flattened +-- representation utilising to/from index. +-- +imapNestFromStepTo + :: forall sh. Shape sh + => Operands sh -- ^ initial index (inclusive) + -> Operands sh -- ^ steps + -> Operands sh -- ^ final index (exclusive) + -> Operands sh -- ^ total array extent + -> (Operands sh -> Operands Int -> CodeGen Native ()) -- ^ apply at each index + -> CodeGen Native () +imapNestFromStepTo start steps end extent body = + go (eltType @sh) start steps end (body' . IR) + where + body' ix = body ix =<< intOfIndex extent ix + + go :: TupleType t -> Operands t -> Operands t -> Operands t -> (Operands t -> CodeGen Native ()) -> CodeGen Native () + go TypeRunit OP_Unit OP_Unit OP_Unit k + = k OP_Unit + + go (TypeRpair tsh tsz) (OP_Pair ssh ssz) (OP_Pair sts stz) (OP_Pair esh esz) k + | TypeRscalar t <- tsz + , Just Refl <- matchScalarType t (scalarType :: ScalarType Int) + = go tsh ssh sts esh + $ \sz -> Loop.imapFromStepTo ssz stz esz + $ \i -> k (OP_Pair sz i) + + go _ _ _ _ _ + = $internalError "imapNestFromTo" "expected shape with Int components" +--} + -- | Iterate with an accumulator between the start and end index, executing the -- given function at each. -- iterFromTo - :: Elt a - => IR Int -- ^ starting index (inclusive) - -> IR Int -- ^ final index (exclusive) - -> IR a -- ^ initial value - -> (IR Int -> IR a -> CodeGen (IR a)) -- ^ apply at each index - -> CodeGen (IR a) -iterFromTo start end seed body = - Loop.iterFromStepTo start (lift 1) end seed body + :: TypeR a + -> Operands Int -- ^ starting index (inclusive) + -> Operands Int -- ^ final index (exclusive) + -> Operands a -- ^ initial value + -> (Operands Int -> Operands a -> CodeGen Native (Operands a)) -- ^ apply at each index + -> CodeGen Native (Operands a) +iterFromTo tp start end seed body = + Loop.iterFromStepTo tp start (liftInt 1) end seed body 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 @@ -2,13 +2,13 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.Map --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- Copyright : [2014..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -16,12 +16,15 @@ module Data.Array.Accelerate.LLVM.Native.CodeGen.Map where --- accelerate -import Data.Array.Accelerate.Array.Sugar ( Array, Elt ) +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Shape +import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Type import Data.Array.Accelerate.LLVM.CodeGen.Array import Data.Array.Accelerate.LLVM.CodeGen.Base import Data.Array.Accelerate.LLVM.CodeGen.Environment +import Data.Array.Accelerate.LLVM.CodeGen.Exp import Data.Array.Accelerate.LLVM.CodeGen.Monad import Data.Array.Accelerate.LLVM.CodeGen.Sugar import Data.Array.Accelerate.LLVM.Compile.Cache @@ -70,27 +73,30 @@ -- declare float @apply(float) -- - -- Apply the given unary function to each element of an array. -- -mkMap :: forall aenv sh a b. Elt b - => UID - -> Gamma aenv - -> IRFun1 Native aenv (a -> b) - -> IRDelayed Native aenv (Array sh a) - -> CodeGen (IROpenAcc Native aenv (Array sh b)) -mkMap uid aenv apply IRDelayed{..} = +-- The map operation can always treat an array of any dimension in its flat +-- underlying representation, which simplifies code generation. +-- +mkMap :: UID + -> Gamma aenv + -> ArrayR (Array sh a) + -> TypeR b + -> IRFun1 Native aenv (a -> b) + -> CodeGen Native (IROpenAcc Native aenv (Array sh b)) +mkMap uid aenv (ArrayR shR aR) bR apply = let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Array sh b)) + (start, end, paramGang) = gangParam dim1 + (arrIn, paramIn) = mutableArray (ArrayR shR aR) "in" + (arrOut, paramOut) = mutableArray (ArrayR shR bR) "out" paramEnv = envParam aenv in - makeOpenAcc uid "map" (paramGang ++ paramOut ++ paramEnv) $ do + makeOpenAcc uid "map" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do - imapFromTo start end $ \i -> do - xs <- app1 delayedLinearIndex i + imapFromTo (indexHead start) (indexHead end) $ \i -> do + xs <- readArray TypeInt arrIn i ys <- app1 apply xs - writeArray arrOut i ys + 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,14 +1,15 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.Permute --- Copyright : [2016..2017] Trevor L. McDonell +-- Copyright : [2016..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -16,10 +17,11 @@ module Data.Array.Accelerate.LLVM.Native.CodeGen.Permute where --- accelerate -import Data.Array.Accelerate.Array.Sugar ( Array, Vector, Shape, Elt, eltType ) +import Data.Array.Accelerate.AST ( PrimMaybe ) import Data.Array.Accelerate.Error -import qualified Data.Array.Accelerate.Array.Sugar as S +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Shape +import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic as A import Data.Array.Accelerate.LLVM.CodeGen.Array @@ -47,7 +49,6 @@ import Control.Applicative import Control.Monad ( void ) -import Data.Typeable import Prelude @@ -60,16 +61,18 @@ -- that are mapped to the magic index 'ignore' are dropped. -- mkPermute - :: (Shape sh, Shape sh', Elt e) + :: HasCallStack => UID - -> Gamma aenv + -> Gamma aenv + -> ArrayR (Array sh e) + -> ShapeR sh' -> IRPermuteFun Native aenv (e -> e -> e) - -> IRFun1 Native aenv (sh -> sh') - -> IRDelayed Native aenv (Array sh e) - -> CodeGen (IROpenAcc Native aenv (Array sh' e)) -mkPermute uid aenv combine project arr = - (+++) <$> mkPermuteS uid aenv combine project arr - <*> mkPermuteP uid aenv combine project arr + -> IRFun1 Native aenv (sh -> PrimMaybe sh') + -> MIRDelayed Native aenv (Array sh e) + -> CodeGen Native (IROpenAcc Native aenv (Array sh' e)) +mkPermute uid aenv repr shr combine project arr = + (+++) <$> mkPermuteS uid aenv repr shr combine project arr + <*> mkPermuteP uid aenv repr shr combine project arr -- Forward permutation which does not require locking the output array. This @@ -81,37 +84,39 @@ -- co-domain). -- mkPermuteS - :: forall aenv sh sh' e. (Shape sh, Shape sh', Elt e) - => UID - -> Gamma aenv + :: UID + -> Gamma aenv + -> ArrayR (Array sh e) + -> ShapeR sh' -> IRPermuteFun Native aenv (e -> e -> e) - -> IRFun1 Native aenv (sh -> sh') - -> IRDelayed Native aenv (Array sh e) - -> CodeGen (IROpenAcc Native aenv (Array sh' e)) -mkPermuteS uid aenv IRPermuteFun{..} project IRDelayed{..} = + -> IRFun1 Native aenv (sh -> PrimMaybe sh') + -> MIRDelayed Native aenv (Array sh e) + -> CodeGen Native (IROpenAcc Native aenv (Array sh' e)) +mkPermuteS uid aenv repr shr IRPermuteFun{..} project marr = let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Array sh' e)) - paramEnv = envParam aenv + (start, end, paramGang) = gangParam (arrayRshape repr) + (arrOut, paramOut) = mutableArray (reprOut repr shr) "out" + (arrIn, paramIn) = delayedArray "in" marr + paramEnv = envParam aenv in - makeOpenAcc uid "permuteS" (paramGang ++ paramOut ++ paramEnv) $ do + makeOpenAcc uid "permuteS" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do - sh <- delayedExtent + sh <- delayedExtent arrIn - imapFromTo start end $ \i -> do + imapNestFromTo (arrayRshape repr) start end sh $ \ix _ -> do - ix <- indexOfInt sh i ix' <- app1 project ix - unless (ignore ix') $ do - j <- intOfIndex (irArrayShape arrOut) ix' + when (isJust ix') $ do + i <- fromJust ix' + j <- intOfIndex shr (irArrayShape arrOut) i -- project element onto the destination array and update - x <- app1 delayedLinearIndex i - y <- readArray arrOut j + x <- app1 (delayedIndex arrIn) ix + y <- readArray TypeInt arrOut j r <- app2 combine x y - writeArray arrOut j r + writeArray TypeInt arrOut j r return_ @@ -127,71 +132,79 @@ -- a queue or some such. -- mkPermuteP - :: forall aenv sh sh' e. (Shape sh, Shape sh', Elt e) + :: HasCallStack => UID - -> Gamma aenv + -> Gamma aenv + -> ArrayR (Array sh e) + -> ShapeR sh' -> IRPermuteFun Native aenv (e -> e -> e) - -> IRFun1 Native aenv (sh -> sh') - -> IRDelayed Native aenv (Array sh e) - -> CodeGen (IROpenAcc Native aenv (Array sh' e)) -mkPermuteP uid aenv IRPermuteFun{..} project arr = + -> IRFun1 Native aenv (sh -> PrimMaybe sh') + -> MIRDelayed Native aenv (Array sh e) + -> CodeGen Native (IROpenAcc Native aenv (Array sh' e)) +mkPermuteP uid aenv repr shr IRPermuteFun{..} project arr = case atomicRMW of - Nothing -> mkPermuteP_mutex uid aenv combine project arr - Just (rmw, f) -> mkPermuteP_rmw uid aenv rmw f project arr + Nothing -> mkPermuteP_mutex uid aenv repr shr combine project arr + Just (rmw, f) -> mkPermuteP_rmw uid aenv repr shr rmw f project arr -- Parallel forward permutation function which uses atomic instructions to -- implement lock-free array updates. -- mkPermuteP_rmw - :: forall aenv sh sh' e. (Shape sh, Shape sh', Elt e) + :: HasCallStack => UID -> Gamma aenv + -> ArrayR (Array sh e) + -> ShapeR sh' -> RMWOperation - -> IRFun1 Native aenv (e -> e) - -> IRFun1 Native aenv (sh -> sh') - -> IRDelayed Native aenv (Array sh e) - -> CodeGen (IROpenAcc Native aenv (Array sh' e)) -mkPermuteP_rmw uid aenv rmw update project IRDelayed{..} = + -> IRFun1 Native aenv (e -> e) + -> IRFun1 Native aenv (sh -> PrimMaybe sh') + -> MIRDelayed Native aenv (Array sh e) + -> CodeGen Native (IROpenAcc Native aenv (Array sh' e)) +mkPermuteP_rmw uid aenv repr shr rmw update project marr = let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Array sh' e)) - paramEnv = envParam aenv + (start, end, paramGang) = gangParam (arrayRshape repr) + (arrOut, paramOut) = mutableArray (reprOut repr shr) "out" + (arrIn, paramIn) = delayedArray "in" marr + paramEnv = envParam aenv in - makeOpenAcc uid "permuteP_rmw" (paramGang ++ paramOut ++ paramEnv) $ do + makeOpenAcc uid "permuteP_rmw" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do - sh <- delayedExtent + sh <- delayedExtent arrIn - imapFromTo start end $ \i -> do + imapNestFromTo (arrayRshape repr) start end sh $ \ix _ -> do - ix <- indexOfInt sh i ix' <- app1 project ix - unless (ignore ix') $ do - j <- intOfIndex (irArrayShape arrOut) ix' - x <- app1 delayedLinearIndex i + when (isJust ix') $ do + i <- fromJust ix' + j <- intOfIndex shr (irArrayShape arrOut) i + x <- app1 (delayedIndex arrIn) ix r <- app1 update x case rmw of Exchange - -> writeArray arrOut j r + -> writeArray TypeInt arrOut j r -- - _ | TypeRscalar (SingleScalarType s) <- eltType (undefined::e) - , Just adata <- gcast (irArrayData arrOut) - , Just r' <- gcast r + _ | TupRsingle (SingleScalarType s) <- arrayRtype repr + , adata <- irArrayData arrOut -> do addr <- instr' $ GetElementPtr (asPtr defaultAddrSpace (op s adata)) [op integralType j] -- case s of - NumSingleType (IntegralNumType t) -> void . instr' $ AtomicRMW t NonVolatile rmw addr (op t r') (CrossThread, AcquireRelease) - NumSingleType t | RMW.Add <- rmw -> atomicCAS_rmw s (A.add t r') addr - NumSingleType t | RMW.Sub <- rmw -> atomicCAS_rmw s (A.sub t r') addr - _ -> case rmw of - RMW.Min -> atomicCAS_cmp s A.lt addr (op s r') - RMW.Max -> atomicCAS_cmp s A.gt addr (op s r') - _ -> $internalError "mkPermute_rmw" "unexpected transition" +#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 "mkPermute_rmw" "unexpected transition" + _ -> internalError "unexpected transition" return_ @@ -200,38 +213,40 @@ -- a mutex before updating the value at that location. -- mkPermuteP_mutex - :: forall aenv sh sh' e. (Shape sh, Shape sh', Elt e) - => UID - -> Gamma aenv - -> IRFun2 Native aenv (e -> e -> e) - -> IRFun1 Native aenv (sh -> sh') - -> IRDelayed Native aenv (Array sh e) - -> CodeGen (IROpenAcc Native aenv (Array sh' e)) -mkPermuteP_mutex uid aenv combine project IRDelayed{..} = + :: UID + -> Gamma aenv + -> ArrayR (Array sh e) + -> ShapeR sh' + -> IRFun2 Native aenv (e -> e -> e) + -> IRFun1 Native aenv (sh -> PrimMaybe sh') + -> MIRDelayed Native aenv (Array sh e) + -> CodeGen Native (IROpenAcc Native aenv (Array sh' e)) +mkPermuteP_mutex uid aenv repr shr combine project marr = let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Array sh' e)) - (arrLock, paramLock) = mutableArray ("lock" :: Name (Vector Word8)) - paramEnv = envParam aenv + (start, end, paramGang) = gangParam (arrayRshape repr) + (arrOut, paramOut) = mutableArray (reprOut repr shr) "out" + (arrLock, paramLock) = mutableArray reprLock "lock" + (arrIn, paramIn) = delayedArray "in" marr + paramEnv = envParam aenv in - makeOpenAcc uid "permuteP_mutex" (paramGang ++ paramOut ++ paramLock ++ paramEnv) $ do + makeOpenAcc uid "permuteP_mutex" (paramGang ++ paramOut ++ paramLock ++ paramIn ++ paramEnv) $ do - sh <- delayedExtent + sh <- delayedExtent arrIn - imapFromTo start end $ \i -> do + imapNestFromTo (arrayRshape repr) start end sh $ \ix _ -> do - ix <- indexOfInt sh i ix' <- app1 project ix -- project element onto the destination array and (atomically) update - unless (ignore ix') $ do - j <- intOfIndex (irArrayShape arrOut) ix' - x <- app1 delayedLinearIndex i + when (isJust ix') $ do + i <- fromJust ix' + j <- intOfIndex shr (irArrayShape arrOut) i + x <- app1 (delayedIndex arrIn) ix atomically arrLock j $ do - y <- readArray arrOut j + y <- readArray TypeInt arrOut j r <- app2 combine x y - writeArray arrOut j r + writeArray TypeInt arrOut j r return_ @@ -249,14 +264,14 @@ -- atomically :: IRArray (Vector Word8) - -> IR Int - -> CodeGen a - -> CodeGen a + -> Operands Int + -> CodeGen Native a + -> CodeGen Native a atomically barriers i action = do let lock = integral integralType 1 unlock = integral integralType 0 - unlocked = lift 0 + unlocked = ir TypeWord8 unlock -- spin <- newBlock "spinlock.entry" crit <- newBlock "spinlock.critical-section" @@ -269,7 +284,7 @@ -- was unlocked we just acquired it, otherwise the state remains unchanged and -- we spin until it becomes available. setBlock spin - old <- instr $ AtomicRMW integralType NonVolatile Exchange addr lock (CrossThread, Acquire) + old <- instr $ AtomicRMW numType NonVolatile Exchange addr lock (CrossThread, Acquire) ok <- A.eq singleType old unlocked _ <- cbr ok crit spin @@ -279,7 +294,7 @@ -- rules. setBlock crit r <- action - _ <- instr $ AtomicRMW integralType NonVolatile Exchange addr unlock (CrossThread, Release) + _ <- instr $ AtomicRMW numType NonVolatile Exchange addr unlock (CrossThread, Release) _ <- br exit setBlock exit @@ -289,18 +304,9 @@ -- Helper functions -- ---------------- --- Test whether the given index is the magic value 'ignore'. This operates --- strictly rather than performing short-circuit (&&). --- -ignore :: forall ix. Shape ix => IR ix -> CodeGen (IR Bool) -ignore (IR ix) = go (S.eltType (undefined::ix)) (S.fromElt (S.ignore::ix)) ix - where - go :: TupleType t -> t -> Operands t -> CodeGen (IR Bool) - go TypeRunit () OP_Unit = return (lift True) - go (TypeRpair tsh tsz) (ish, isz) (OP_Pair sh sz) = do x <- go tsh ish sh - y <- go tsz isz sz - land' x y - go (TypeRscalar s) ig sz = case s of - SingleScalarType t -> A.eq t (ir t (single t ig)) (ir t (op' t sz)) - VectorScalarType{} -> $internalError "ignore" "unexpected shape type" +reprOut :: ArrayR (Array sh e) -> ShapeR sh' -> ArrayR (Array sh' e) +reprOut (ArrayR _ tp) shr = ArrayR shr tp + +reprLock :: ArrayR (Array ((), Int) Word8) +reprLock = ArrayR (ShapeRsnoc ShapeRz) $ TupRsingle scalarTypeWord8 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 @@ -3,14 +3,15 @@ {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.Scan --- Copyright : [2014..2017] Trevor L. McDonell +-- Copyright : [2014..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -18,18 +19,17 @@ module Data.Array.Accelerate.LLVM.Native.CodeGen.Scan where --- accelerate -import Data.Array.Accelerate.Analysis.Match -import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.AST ( Direction(..) ) +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Shape +import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Type -import Data.Array.Accelerate.LLVM.Analysis.Match import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic as A import Data.Array.Accelerate.LLVM.CodeGen.Array import Data.Array.Accelerate.LLVM.CodeGen.Base import Data.Array.Accelerate.LLVM.CodeGen.Environment import Data.Array.Accelerate.LLVM.CodeGen.Exp -import Data.Array.Accelerate.LLVM.CodeGen.IR ( IR ) import Data.Array.Accelerate.LLVM.CodeGen.Loop import Data.Array.Accelerate.LLVM.CodeGen.Monad import Data.Array.Accelerate.LLVM.CodeGen.Sugar @@ -47,59 +47,34 @@ import Prelude as P -data Direction = L | R - --- 'Data.List.scanl' style left-to-right exclusive scan, but with the --- restriction that the combination function must be associative to enable --- efficient parallel implementation. +-- 'Data.List.scanl' or 'Data.List.scanl1' style exclusive scan, +-- but with the restriction that the combination function must be associative +-- to enable efficient parallel implementation. -- -- > scanl (+) 10 (use $ fromList (Z :. 10) [0..]) -- > -- > ==> Array (Z :. 11) [10,10,11,13,16,20,25,31,38,46,55] -- -mkScanl - :: forall aenv sh e. (Shape sh, Elt e) - => UID - -> Gamma aenv - -> IRFun2 Native aenv (e -> e -> e) - -> IRExp Native aenv e - -> IRDelayed Native aenv (Array (sh:.Int) e) - -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e)) -mkScanl uid aenv combine seed arr - | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) - = foldr1 (+++) <$> sequence [ mkScanS L uid aenv combine (Just seed) arr - , mkScanP L uid aenv combine (Just seed) arr - , mkScanFill uid aenv seed - ] - -- - | otherwise - = (+++) <$> mkScanS L uid aenv combine (Just seed) arr - <*> mkScanFill uid aenv seed - - --- 'Data.List.scanl1' style left-to-right inclusive scan, but with the --- restriction that the combination function must be associative to enable --- efficient parallel implementation. The array must not be empty. --- --- > scanl1 (+) (use $ fromList (Z :. 10) [0..]) --- > --- > ==> Array (Z :. 10) [0,1,3,6,10,15,21,28,36,45] --- -mkScanl1 - :: forall aenv sh e. (Shape sh, Elt e) - => UID - -> Gamma aenv - -> IRFun2 Native aenv (e -> e -> e) - -> IRDelayed Native aenv (Array (sh:.Int) e) - -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e)) -mkScanl1 uid aenv combine arr - | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) - = (+++) <$> mkScanS L uid aenv combine Nothing arr - <*> mkScanP L uid aenv combine Nothing arr - -- - | otherwise - = mkScanS L uid aenv combine Nothing arr - +mkScan + :: UID + -> Gamma aenv + -> ArrayR (Array (sh, Int) e) + -> Direction + -> IRFun2 Native aenv (e -> e -> e) + -> Maybe (IRExp Native aenv e) + -> MIRDelayed Native aenv (Array (sh, Int) e) + -> CodeGen Native (IROpenAcc Native aenv (Array (sh, Int) e)) +mkScan uid aenv aR dir combine seed arr + = foldr1 (+++) <$> sequence (codeScanS ++ codeScanP ++ codeScanFill) + where + codeScanS = [ mkScanS dir uid aenv aR combine seed arr ] + codeScanP = case aR of + ArrayR (ShapeRsnoc ShapeRz) eR -> [ mkScanP dir uid aenv eR combine seed arr ] + _ -> [] + -- Input can be empty iff a seed is given. We then need to compile a fill kernel + codeScanFill = case seed of + Just s -> [ mkScanFill uid aenv aR s ] + Nothing -> [] -- Variant of 'scanl' where the final result is returned in a separate array. -- @@ -109,126 +84,46 @@ -- , Array Z [55] -- ) -- -mkScanl' - :: forall aenv sh e. (Shape sh, Elt e) - => UID - -> Gamma aenv - -> IRFun2 Native aenv (e -> e -> e) - -> IRExp Native aenv e - -> IRDelayed Native aenv (Array (sh:.Int) e) - -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e, Array sh e)) -mkScanl' uid aenv combine seed arr - | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) - = foldr1 (+++) <$> sequence [ mkScan'S L uid aenv combine seed arr - , mkScan'P L uid aenv combine seed arr - , mkScan'Fill uid aenv seed - ] - -- - | otherwise - = (+++) <$> mkScan'S L uid aenv combine seed arr - <*> mkScan'Fill uid aenv seed - - --- 'Data.List.scanr' style right-to-left exclusive scan, but with the --- restriction that the combination function must be associative to enable --- efficient parallel implementation. --- --- > scanr (+) 10 (use $ fromList (Z :. 10) [0..]) --- > --- > ==> Array (Z :. 11) [55,55,54,52,49,45,40,34,27,19,10] --- -mkScanr - :: forall aenv sh e. (Shape sh, Elt e) - => UID - -> Gamma aenv - -> IRFun2 Native aenv (e -> e -> e) - -> IRExp Native aenv e - -> IRDelayed Native aenv (Array (sh:.Int) e) - -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e)) -mkScanr uid aenv combine seed arr - | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) - = foldr1 (+++) <$> sequence [ mkScanS R uid aenv combine (Just seed) arr - , mkScanP R uid aenv combine (Just seed) arr - , mkScanFill uid aenv seed - ] - -- - | otherwise - = (+++) <$> mkScanS R uid aenv combine (Just seed) arr - <*> mkScanFill uid aenv seed - - --- 'Data.List.scanr1' style right-to-left inclusive scan, but with the --- restriction that the combination function must be associative to enable --- efficient parallel implementation. The array must not be empty. --- --- > scanr (+) 10 (use $ fromList (Z :. 10) [0..]) --- > --- > ==> Array (Z :. 10) [45,45,44,42,39,35,30,24,17,9] --- -mkScanr1 - :: forall aenv sh e. (Shape sh, Elt e) - => UID - -> Gamma aenv - -> IRFun2 Native aenv (e -> e -> e) - -> IRDelayed Native aenv (Array (sh:.Int) e) - -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e)) -mkScanr1 uid aenv combine arr - | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) - = (+++) <$> mkScanS R uid aenv combine Nothing arr - <*> mkScanP R uid aenv combine Nothing arr - -- - | otherwise - = mkScanS R uid aenv combine Nothing arr - - --- Variant of 'scanr' where the final result is returned in a separate array. --- --- > scanr' (+) 10 (use $ fromList (Z :. 10) [0..]) --- > --- > ==> ( Array (Z :. 10) [55,54,52,49,45,40,34,27,19,10] --- , Array Z [55] --- ) --- -mkScanr' - :: forall aenv sh e. (Shape sh, Elt e) - => UID - -> Gamma aenv - -> IRFun2 Native aenv (e -> e -> e) - -> IRExp Native aenv e - -> IRDelayed Native aenv (Array (sh:.Int) e) - -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e, Array sh e)) -mkScanr' uid aenv combine seed arr - | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) - = foldr1 (+++) <$> sequence [ mkScan'S R uid aenv combine seed arr - , mkScan'P R uid aenv combine seed arr - , mkScan'Fill uid aenv seed +mkScan' + :: UID + -> Gamma aenv + -> ArrayR (Array (sh, Int) e) + -> Direction + -> IRFun2 Native aenv (e -> e -> e) + -> IRExp Native aenv e + -> MIRDelayed Native aenv (Array (sh, Int) e) + -> CodeGen Native (IROpenAcc Native aenv (Array (sh, Int) e, Array sh e)) +mkScan' uid aenv aR dir combine seed arr + | ArrayR (ShapeRsnoc ShapeRz) eR <- aR + = foldr1 (+++) <$> sequence [ mkScan'S dir uid aenv aR combine seed arr + , mkScan'P dir uid aenv eR combine seed arr + , mkScan'Fill uid aenv aR seed ] -- | otherwise - = (+++) <$> mkScan'S R uid aenv combine seed arr - <*> mkScan'Fill uid aenv seed - + = (+++) <$> mkScan'S dir uid aenv aR combine seed arr + <*> mkScan'Fill uid aenv aR seed -- If the innermost dimension of an exclusive scan is empty, then we just fill -- the result with the seed element. -- mkScanFill - :: (Shape sh, Elt e) - => UID - -> Gamma aenv - -> IRExp Native aenv e - -> CodeGen (IROpenAcc Native aenv (Array sh e)) -mkScanFill uid aenv seed = - mkGenerate uid aenv (IRFun1 (const seed)) + :: UID + -> Gamma aenv + -> ArrayR (Array sh e) + -> IRExp Native aenv e + -> CodeGen Native (IROpenAcc Native aenv (Array sh e)) +mkScanFill uid aenv aR seed = + mkGenerate uid aenv aR (IRFun1 (const seed)) mkScan'Fill - :: forall aenv sh e. (Shape sh, Elt e) - => UID - -> Gamma aenv - -> IRExp Native aenv e - -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e, Array sh e)) -mkScan'Fill uid aenv seed = - Safe.coerce <$> (mkScanFill uid aenv seed :: CodeGen (IROpenAcc Native aenv (Array sh e))) + :: UID + -> Gamma aenv + -> ArrayR (Array (sh, Int) e) + -> IRExp Native aenv e + -> CodeGen Native (IROpenAcc Native aenv (Array (sh, Int) e, Array sh e)) +mkScan'Fill uid aenv aR seed = + Safe.coerce <$> mkScanFill uid aenv (reduceRank aR) seed -- A single thread sequentially scans along an entire innermost dimension. For @@ -239,162 +134,159 @@ -- where threads are scheduled over the outer dimensions (segments). -- mkScanS - :: forall aenv sh e. Elt e - => Direction + :: Direction -> UID - -> Gamma aenv - -> IRFun2 Native aenv (e -> e -> e) - -> Maybe (IRExp Native aenv e) - -> IRDelayed Native aenv (Array (sh:.Int) e) - -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e)) -mkScanS dir uid aenv combine mseed IRDelayed{..} = + -> Gamma aenv + -> ArrayR (Array (sh, Int) e) + -> IRFun2 Native aenv (e -> e -> e) + -> MIRExp Native aenv e + -> MIRDelayed Native aenv (Array (sh, Int) e) + -> CodeGen Native (IROpenAcc Native aenv (Array (sh, Int) e)) +mkScanS dir uid aenv aR combine mseed marr = let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Array (sh:.Int) e)) - paramEnv = envParam aenv + (start, end, paramGang) = gangParam shR + (arrOut, paramOut) = mutableArray aR "out" + (arrIn, paramIn) = delayedArray "in" marr + paramEnv = envParam aenv + ShapeRsnoc shR = arrayRshape aR -- - next i = case dir of - L -> A.add numType i (lift 1) - R -> A.sub numType i (lift 1) + next i = case dir of + LeftToRight -> A.add numType i (liftInt 1) + RightToLeft -> A.sub numType i (liftInt 1) in - makeOpenAcc uid "scanS" (paramGang ++ paramOut ++ paramEnv) $ do + makeOpenAcc uid "scanS" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do - sz <- indexHead <$> delayedExtent - szp1 <- A.add numType sz (lift 1) - szm1 <- A.sub numType sz (lift 1) + -- The dimensions of the input and output arrays are (almost) the same + -- but LLVM can't know that so make it explicit so that we reuse loop + -- variables and index calculations + shIn <- delayedExtent arrIn + let sz = indexHead shIn + shOut = case mseed of + Nothing -> shIn + Just{} -> indexCons (indexTail shIn) (indexHead (irArrayShape arrOut)) - -- loop over each lower-dimensional index (segment) - imapFromTo start end $ \seg -> do + -- Loop over the outer dimensions + imapNestFromTo shR start end (indexTail shIn) $ \ix _ -> do -- index i* is the index that we will read data from. Recall that the -- supremum index is exclusive i0 <- case dir of - L -> A.mul numType sz seg - R -> do x <- A.mul numType sz seg - y <- A.add numType szm1 x - return y + LeftToRight -> return (liftInt 0) + RightToLeft -> A.sub numType sz (liftInt 1) -- index j* is the index that we write to. Recall that for exclusive scans -- the output array inner dimension is one larger than the input. j0 <- case mseed of Nothing -> return i0 -- merge 'i' and 'j' indices whenever we can Just{} -> case dir of - L -> A.mul numType szp1 seg - R -> do x <- A.mul numType szp1 seg - y <- A.add numType x sz - return y + LeftToRight -> return i0 + RightToLeft -> return sz -- Evaluate or read the initial element. Update the read-from index -- appropriately. (v0,i1) <- case mseed of - Just seed -> (,) <$> seed <*> pure i0 - Nothing -> (,) <$> app1 delayedLinearIndex i0 <*> next i0 + Just seed -> (,) <$> seed <*> pure i0 + Nothing -> (,) <$> app1 (delayedIndex arrIn) (indexCons ix i0) <*> next i0 - -- Write first element, then continue looping through the rest - writeArray arrOut j0 v0 + -- Write first element, then continue looping through the rest of + -- this innermost dimension + k0 <- intOfIndex (arrayRshape aR) shOut (indexCons ix j0) j1 <- next j0 - - iz <- case dir of - L -> A.add numType i0 sz - R -> A.sub numType i0 sz - - let cont i = case dir of - L -> A.lt singleType i iz - R -> A.gt singleType i iz + writeArray TypeInt arrOut k0 v0 - void $ while (cont . A.fst3) - (\(A.untrip -> (i,j,v)) -> do - u <- app1 delayedLinearIndex i - v' <- case dir of - L -> app2 combine v u - R -> app2 combine u v - writeArray arrOut j v' - A.trip <$> next i <*> next j <*> pure v') + void $ while (TupRunit `TupRpair` TupRsingle scalarTypeInt `TupRpair` TupRsingle scalarTypeInt `TupRpair` arrayRtype aR) + (\(A.untrip -> (i,_,_)) -> do + case dir of + LeftToRight -> A.lt singleType i sz + RightToLeft -> A.gte singleType i (liftInt 0)) + (\(A.untrip -> (i,j,u)) -> do + v <- app1 (delayedIndex arrIn) (indexCons ix i) + w <- case dir of + LeftToRight -> app2 combine u v + RightToLeft -> app2 combine v u + k <- intOfIndex (arrayRshape aR) shOut (indexCons ix j) + writeArray TypeInt arrOut k w + A.trip <$> next i <*> next j <*> pure w) (A.trip i1 j1 v0) return_ mkScan'S - :: forall aenv sh e. (Shape sh, Elt e) - => Direction + :: Direction -> UID - -> Gamma aenv - -> IRFun2 Native aenv (e -> e -> e) - -> IRExp Native aenv e - -> IRDelayed Native aenv (Array (sh:.Int) e) - -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e, Array sh e)) -mkScan'S dir uid aenv combine seed IRDelayed{..} = + -> Gamma aenv + -> ArrayR (Array (sh, Int) e) + -> IRFun2 Native aenv (e -> e -> e) + -> IRExp Native aenv e + -> MIRDelayed Native aenv (Array (sh, Int) e) + -> CodeGen Native (IROpenAcc Native aenv (Array (sh, Int) e, Array sh e)) +mkScan'S dir uid aenv aR combine seed marr = let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Array (sh:.Int) e)) - (arrSum, paramSum) = mutableArray ("sum" :: Name (Array sh e)) - paramEnv = envParam aenv + (start, end, paramGang) = gangParam shR + (arrOut, paramOut) = mutableArray aR "out" + (arrSum, paramSum) = mutableArray (reduceRank aR) "sum" + (arrIn, paramIn) = delayedArray "in" marr + paramEnv = envParam aenv + ShapeRsnoc shR = arrayRshape aR -- - next i = case dir of - L -> A.add numType i (lift 1) - R -> A.sub numType i (lift 1) + next i = case dir of + LeftToRight -> A.add numType i (liftInt 1) + RightToLeft -> A.sub numType i (liftInt 1) in - makeOpenAcc uid "scanS" (paramGang ++ paramOut ++ paramSum ++ paramEnv) $ do + makeOpenAcc uid "scanS" (paramGang ++ paramOut ++ paramSum ++ paramIn ++ paramEnv) $ do - sz <- indexHead <$> delayedExtent - szm1 <- A.sub numType sz (lift 1) + shIn <- delayedExtent arrIn + let sz = indexHead shIn + shOut = shIn - -- iterate over each lower-dimensional index (segment) - imapFromTo start end $ \seg -> do + imapNestFromTo shR start end (indexTail shIn) $ \ix ii -> do -- index to read data from i0 <- case dir of - L -> A.mul numType seg sz - R -> do x <- A.mul numType sz seg - y <- A.add numType x szm1 - return y + LeftToRight -> return (liftInt 0) + RightToLeft -> A.sub numType sz (liftInt 1) -- initial element v0 <- seed - iz <- case dir of - L -> A.add numType i0 sz - R -> A.sub numType i0 sz - - let cont i = case dir of - L -> A.lt singleType i iz - R -> A.gt singleType i iz - -- Loop through the input. Only at the top of the loop to we write the -- carry-in value (i.e. value from the last loop iteration) to the output -- array. This ensures correct behaviour if the input array was empty. - r <- while (cont . A.fst) - (\(A.unpair -> (i,v)) -> do - writeArray arrOut i v + r <- while (TupRsingle scalarTypeInt `TupRpair` arrayRtype aR) + (\(A.unpair -> (i,_)) -> do + case dir of + LeftToRight -> A.lt singleType i sz + RightToLeft -> A.gte singleType i (liftInt 0)) + (\(A.unpair -> (i,u)) -> do + k <- intOfIndex (arrayRshape aR) shOut (indexCons ix i) + writeArray TypeInt arrOut k u - u <- app1 delayedLinearIndex i - v' <- case dir of - L -> app2 combine v u - R -> app2 combine u v - i' <- next i - return $ A.pair i' v') + v <- app1 (delayedIndex arrIn) (indexCons ix i) + w <- case dir of + LeftToRight -> app2 combine u v + RightToLeft -> app2 combine v u + A.pair <$> next i <*> pure w) (A.pair i0 v0) - -- write final reduction result - writeArray arrSum seg (A.snd r) + writeArray TypeInt arrSum ii (A.snd r) return_ mkScanP - :: forall aenv e. Elt e - => Direction + :: Direction -> UID - -> Gamma aenv - -> IRFun2 Native aenv (e -> e -> e) - -> Maybe (IRExp Native aenv e) - -> IRDelayed Native aenv (Vector e) - -> CodeGen (IROpenAcc Native aenv (Vector e)) -mkScanP dir uid aenv combine mseed arr = - foldr1 (+++) <$> sequence [ mkScanP1 dir uid aenv combine mseed arr - , mkScanP2 dir uid aenv combine - , mkScanP3 dir uid aenv combine mseed + -> Gamma aenv + -> TypeR e + -> IRFun2 Native aenv (e -> e -> e) + -> MIRExp Native aenv e + -> MIRDelayed Native aenv (Vector e) + -> CodeGen Native (IROpenAcc Native aenv (Vector e)) +mkScanP dir uid aenv eR combine mseed marr = + foldr1 (+++) <$> sequence [ mkScanP1 dir uid aenv eR combine mseed marr + , mkScanP2 dir uid aenv eR combine + , mkScanP3 dir uid aenv eR combine mseed ] -- Parallel scan, step 1. @@ -404,36 +296,35 @@ -- result of this chunk is written to a separate array. -- mkScanP1 - :: forall aenv e. Elt e - => Direction + :: Direction -> UID - -> Gamma aenv - -> IRFun2 Native aenv (e -> e -> e) - -> Maybe (IRExp Native aenv e) - -> IRDelayed Native aenv (Vector e) - -> CodeGen (IROpenAcc Native aenv (Vector e)) -mkScanP1 dir uid aenv combine mseed IRDelayed{..} = + -> Gamma aenv + -> TypeR e + -> IRFun2 Native aenv (e -> e -> e) + -> MIRExp Native aenv e + -> MIRDelayed Native aenv (Vector e) + -> CodeGen Native (IROpenAcc Native aenv (Vector e)) +mkScanP1 dir uid aenv eR combine mseed marr = let - (chunk, _, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Vector e)) - (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) - paramEnv = envParam aenv + (start, end, paramGang) = gangParam dim1 + (arrOut, paramOut) = mutableArray (ArrayR dim1 eR) "out" + (arrTmp, paramTmp) = mutableArray (ArrayR dim1 eR) "tmp" + (arrIn, paramIn) = delayedArray "in" marr + paramEnv = envParam aenv -- - steps = local scalarType ("ix.steps" :: Name Int) - paramSteps = scalarParameter scalarType ("ix.steps" :: Name Int) - stride = local scalarType ("ix.stride" :: Name Int) - paramStride = scalarParameter scalarType ("ix.stride" :: Name Int) + steps = local (TupRsingle scalarTypeInt) "ix.steps" + paramSteps = parameter (TupRsingle scalarTypeInt) "ix.steps" + piece = local (TupRsingle scalarTypeInt) "ix.piece" + paramPiece = parameter (TupRsingle scalarTypeInt) "ix.piece" -- - next i = case dir of - L -> A.add numType i (lift 1) - R -> A.sub numType i (lift 1) - firstChunk = case dir of - L -> lift 0 - R -> steps + next i = case dir of + LeftToRight -> A.add numType i (liftInt 1) + RightToLeft -> A.sub numType i (liftInt 1) + firstPiece = case dir of + LeftToRight -> liftInt 0 + RightToLeft -> steps in - makeOpenAcc uid "scanP1" (paramGang ++ paramStride : paramSteps : paramOut ++ paramTmp ++ paramEnv) $ do - - len <- indexHead <$> delayedExtent + makeOpenAcc uid "scanP1" (paramGang ++ paramPiece ++ paramSteps ++ paramOut ++ paramTmp ++ paramIn ++ paramEnv) $ do -- A thread scans a non-empty stripe of the input, storing the final -- reduction result into a separate array. @@ -441,59 +332,57 @@ -- For exclusive scans the first chunk must incorporate the initial element -- into the input and output, while all other chunks increment their output -- index by one. - inf <- A.mul numType chunk stride - a <- A.add numType inf stride - sup <- A.min singleType a len - + -- -- index i* is the index that we read data from. Recall that the supremum -- index is exclusive i0 <- case dir of - L -> return inf - R -> next sup + LeftToRight -> return (indexHead start) + RightToLeft -> next (indexHead end) -- index j* is the index that we write to. Recall that for exclusive scan - -- the output array is one larger than the input; the first chunk uses + -- the output array is one larger than the input; the first piece uses -- this spot to write the initial element, all other chunks shift by one. j0 <- case mseed of Nothing -> return i0 Just _ -> case dir of - L -> if A.eq singleType chunk firstChunk - then return i0 - else next i0 - R -> if A.eq singleType chunk firstChunk - then return sup - else return i0 + LeftToRight -> if (TupRsingle scalarTypeInt, A.eq singleType piece firstPiece) + then return i0 + else next i0 + RightToLeft -> if (TupRsingle scalarTypeInt, A.eq singleType piece firstPiece) + then return (indexHead end) + else return i0 - -- Evaluate/read the initial element for this chunk. Update the read-from + -- Evaluate/read the initial element for this piece. Update the read-from -- index appropriately (v0,i1) <- A.unpair <$> case mseed of - Just seed -> if A.eq singleType chunk firstChunk - then A.pair <$> seed <*> pure i0 - else A.pair <$> app1 delayedLinearIndex i0 <*> next i0 - Nothing -> A.pair <$> app1 delayedLinearIndex i0 <*> next i0 + Just seed -> if (eR `TupRpair` TupRsingle scalarTypeInt, A.eq singleType piece firstPiece) + then A.pair <$> seed <*> pure i0 + else A.pair <$> app1 (delayedLinearIndex arrIn) i0 <*> next i0 + Nothing -> A.pair <$> app1 (delayedLinearIndex arrIn) i0 <*> next i0 -- Write first element - writeArray arrOut j0 v0 + writeArray TypeInt arrOut j0 v0 j1 <- next j0 -- Continue looping through the rest of the input let cont i = case dir of - L -> A.lt singleType i sup - R -> A.gte singleType i inf + LeftToRight -> A.lt singleType i (indexHead end) + RightToLeft -> A.gte singleType i (indexHead start) - r <- while (cont . A.fst3) + r <- while (TupRunit `TupRpair` TupRsingle scalarTypeInt `TupRpair` TupRsingle scalarTypeInt `TupRpair` eR) + (cont . A.fst3) (\(A.untrip -> (i,j,v)) -> do - u <- app1 delayedLinearIndex i + u <- app1 (delayedLinearIndex arrIn) i v' <- case dir of - L -> app2 combine v u - R -> app2 combine u v - writeArray arrOut j v' + LeftToRight -> app2 combine v u + RightToLeft -> app2 combine u v + writeArray TypeInt arrOut j v' A.trip <$> next i <*> next j <*> pure v') (A.trip i1 j1 v0) - -- Final reduction result of this chunk - writeArray arrTmp chunk (A.thd3 r) + -- Final reduction result of this piece + writeArray TypeInt arrTmp piece (A.thd3 r) return_ @@ -505,43 +394,44 @@ -- results in the final step. -- mkScanP2 - :: forall aenv e. Elt e - => Direction + :: Direction -> UID - -> Gamma aenv - -> IRFun2 Native aenv (e -> e -> e) - -> CodeGen (IROpenAcc Native aenv (Vector e)) -mkScanP2 dir uid aenv combine = + -> Gamma aenv + -> TypeR e + -> IRFun2 Native aenv (e -> e -> e) + -> CodeGen Native (IROpenAcc Native aenv (Vector e)) +mkScanP2 dir uid aenv eR combine = let - (start, end, paramGang) = gangParam - (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) - paramEnv = envParam aenv + (start, end, paramGang) = gangParam dim1 + (arrTmp, paramTmp) = mutableArray (ArrayR dim1 eR) "tmp" + paramEnv = envParam aenv -- - cont i = case dir of - L -> A.lt singleType i end - R -> A.gte singleType i start + cont i = case dir of + LeftToRight -> A.lt singleType i (indexHead end) + RightToLeft -> A.gte singleType i (indexHead start) - next i = case dir of - L -> A.add numType i (lift 1) - R -> A.sub numType i (lift 1) + next i = case dir of + LeftToRight -> A.add numType i (liftInt 1) + RightToLeft -> A.sub numType i (liftInt 1) in makeOpenAcc uid "scanP2" (paramGang ++ paramTmp ++ paramEnv) $ do i0 <- case dir of - L -> return start - R -> next end + LeftToRight -> return (indexHead start) + RightToLeft -> next (indexHead end) - v0 <- readArray arrTmp i0 + v0 <- readArray TypeInt arrTmp i0 i1 <- next i0 - void $ while (cont . A.fst) + void $ while (TupRsingle scalarTypeInt `TupRpair` eR) + (cont . A.fst) (\(A.unpair -> (i,v)) -> do - u <- readArray arrTmp i + u <- readArray TypeInt arrTmp i i' <- next i v' <- case dir of - L -> app2 combine v u - R -> app2 combine u v - writeArray arrTmp i v' + LeftToRight -> app2 combine v u + RightToLeft -> app2 combine u v + writeArray TypeInt arrTmp i v' return $ A.pair i' v') (A.pair i1 v0) @@ -553,165 +443,158 @@ -- Threads combine every element of the partial block results with the carry-in -- value computed from step 2. -- --- Note that we launch (chunks-1) threads, because the first chunk does not need --- extra processing (has no carry-in value). +-- Note that first chunk does not need extra processing (has no carry-in value). -- mkScanP3 - :: forall aenv e. Elt e - => Direction + :: Direction -> UID -> Gamma aenv - -> IRFun2 Native aenv (e -> e -> e) - -> Maybe (IRExp Native aenv e) - -> CodeGen (IROpenAcc Native aenv (Vector e)) -mkScanP3 dir uid aenv combine mseed = + -> TypeR e + -> IRFun2 Native aenv (e -> e -> e) + -> MIRExp Native aenv e + -> CodeGen Native (IROpenAcc Native aenv (Vector e)) +mkScanP3 dir uid aenv eR combine mseed = let - (chunk, _, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Vector e)) - (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) - paramEnv = envParam aenv + (start, end, paramGang) = gangParam dim1 + (arrOut, paramOut) = mutableArray (ArrayR dim1 eR) "out" + (arrTmp, paramTmp) = mutableArray (ArrayR dim1 eR) "tmp" + paramEnv = envParam aenv -- - stride = local scalarType ("ix.stride" :: Name Int) - paramStride = scalarParameter scalarType ("ix.stride" :: Name Int) + steps = local (TupRsingle scalarTypeInt) "ix.steps" + paramSteps = parameter (TupRsingle scalarTypeInt) "ix.steps" + piece = local (TupRsingle scalarTypeInt) "ix.piece" + paramPiece = parameter (TupRsingle scalarTypeInt) "ix.piece" -- - next i = case dir of - L -> A.add numType i (lift 1) - R -> A.sub numType i (lift 1) - prev i = case dir of - L -> A.sub numType i (lift 1) - R -> A.add numType i (lift 1) + next i = case dir of + LeftToRight -> A.add numType i (liftInt 1) + RightToLeft -> A.sub numType i (liftInt 1) + prev i = case dir of + LeftToRight -> A.sub numType i (liftInt 1) + RightToLeft -> A.add numType i (liftInt 1) + firstPiece = case dir of + LeftToRight -> liftInt 0 + RightToLeft -> steps in - makeOpenAcc uid "scanP3" (paramGang ++ paramStride : paramOut ++ paramTmp ++ paramEnv) $ do - - -- Determine which chunk will be carrying in values for. Compute appropriate - -- start and end indices. - a <- case dir of - L -> next chunk - R -> pure chunk + makeOpenAcc uid "scanP3" (paramGang ++ paramPiece ++ paramSteps ++ paramOut ++ paramTmp ++ paramEnv) $ do - b <- A.mul numType a stride - c <- A.add numType b stride - d <- A.min singleType c (indexHead (irArrayShape arrOut)) + -- TODO: Don't schedule the "first" piece. In the scheduler this corresponds + -- to the split range with the smallest/largest linear index for left/right + -- scans respectively. For right scans this is not necessarily the last piece(?). + -- + A.when (neq singleType piece firstPiece) $ do - (inf,sup) <- case (dir,mseed) of - (L,Just _) -> (,) <$> next b <*> next d - _ -> (,) <$> pure b <*> pure d + -- Compute start and end indices, leaving space for the initial element + (inf,sup) <- case (dir, mseed) of + (LeftToRight, Just{}) -> (,) <$> next (indexHead start) <*> next (indexHead end) + _ -> (,) <$> pure (indexHead start) <*> pure (indexHead end) - -- Carry in value from the previous chunk - e <- case dir of - L -> pure chunk - R -> prev chunk - carry <- readArray arrTmp e + -- Read in the carry in value for this piece + c <- readArray TypeInt arrTmp =<< prev piece - imapFromTo inf sup $ \i -> do - x <- readArray arrOut i - y <- case dir of - L -> app2 combine carry x - R -> app2 combine x carry - writeArray arrOut i y + imapFromTo inf sup $ \i -> do + x <- readArray TypeInt arrOut i + y <- case dir of + LeftToRight -> app2 combine c x + RightToLeft -> app2 combine x c + writeArray TypeInt arrOut i y return_ mkScan'P - :: forall aenv e. Elt e - => Direction + :: Direction -> UID - -> Gamma aenv - -> IRFun2 Native aenv (e -> e -> e) - -> IRExp Native aenv e - -> IRDelayed Native aenv (Vector e) - -> CodeGen (IROpenAcc Native aenv (Vector e, Scalar e)) -mkScan'P dir uid aenv combine seed arr = - foldr1 (+++) <$> sequence [ mkScan'P1 dir uid aenv combine seed arr - , mkScan'P2 dir uid aenv combine - , mkScan'P3 dir uid aenv combine + -> Gamma aenv + -> TypeR e + -> IRFun2 Native aenv (e -> e -> e) + -> IRExp Native aenv e + -> MIRDelayed Native aenv (Vector e) + -> CodeGen Native (IROpenAcc Native aenv (Vector e, Scalar e)) +mkScan'P dir uid aenv eR combine seed arr = + foldr1 (+++) <$> sequence [ mkScan'P1 dir uid aenv eR combine seed arr + , mkScan'P2 dir uid aenv eR combine + , mkScan'P3 dir uid aenv eR combine ] -- Parallel scan', step 1 -- -- Threads scan a stripe of the input into a temporary array. Similar to --- exclusive scan, but since the size of the output array is the same as the --- input, input and output indices are shifted by one. +-- exclusive scan, the output indices are shifted by one relative to the input +-- indices to make space for the initial element. -- mkScan'P1 - :: forall aenv e. Elt e - => Direction + :: Direction -> UID - -> Gamma aenv - -> IRFun2 Native aenv (e -> e -> e) - -> IRExp Native aenv e - -> IRDelayed Native aenv (Vector e) - -> CodeGen (IROpenAcc Native aenv (Vector e, Scalar e)) -mkScan'P1 dir uid aenv combine seed IRDelayed{..} = + -> Gamma aenv + -> TypeR e + -> IRFun2 Native aenv (e -> e -> e) + -> IRExp Native aenv e + -> MIRDelayed Native aenv (Vector e) + -> CodeGen Native (IROpenAcc Native aenv (Vector e, Scalar e)) +mkScan'P1 dir uid aenv eR combine seed marr = let - (chunk, _, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Vector e)) - (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) - paramEnv = envParam aenv + (start, end, paramGang) = gangParam dim1 + (arrOut, paramOut) = mutableArray (ArrayR dim1 eR) "out" + (arrTmp, paramTmp) = mutableArray (ArrayR dim1 eR) "tmp" + (arrIn, paramIn) = delayedArray "in" marr + paramEnv = envParam aenv -- - steps = local scalarType ("ix.steps" :: Name Int) - paramSteps = scalarParameter scalarType ("ix.steps" :: Name Int) - stride = local scalarType ("ix.stride" :: Name Int) - paramStride = scalarParameter scalarType ("ix.stride" :: Name Int) + steps = local (TupRsingle scalarTypeInt) "ix.steps" + paramSteps = parameter (TupRsingle scalarTypeInt) "ix.steps" + piece = local (TupRsingle scalarTypeInt) "ix.piece" + paramPiece = parameter (TupRsingle scalarTypeInt) "ix.piece" -- - next i = case dir of - L -> A.add numType i (lift 1) - R -> A.sub numType i (lift 1) + next i = case dir of + LeftToRight -> A.add numType i (liftInt 1) + RightToLeft -> A.sub numType i (liftInt 1) - firstChunk = case dir of - L -> lift 0 - R -> steps + firstPiece = case dir of + LeftToRight -> liftInt 0 + RightToLeft -> steps in - makeOpenAcc uid "scanP1" (paramGang ++ paramStride : paramSteps : paramOut ++ paramTmp ++ paramEnv) $ do - - -- Compute the start and end indices for this non-empty chunk of the input. - -- - len <- indexHead <$> delayedExtent - inf <- A.mul numType chunk stride - a <- A.add numType inf stride - sup <- A.min singleType a len + makeOpenAcc uid "scanP1" (paramGang ++ paramPiece ++ paramSteps ++ paramOut ++ paramTmp ++ paramIn ++ paramEnv) $ do -- index i* is the index that we pull data from. i0 <- case dir of - L -> return inf - R -> next sup + LeftToRight -> return (indexHead start) + RightToLeft -> next (indexHead end) - -- index j* is the index that we write results to. The first chunk needs to + -- index j* is the index that we write results to. The first piece needs to -- include the initial element, and all other chunks shift their results -- across by one to make space. - j0 <- if A.eq singleType chunk firstChunk + j0 <- if (TupRsingle scalarTypeInt, A.eq singleType piece firstPiece) then pure i0 else next i0 -- Evaluate/read the initial element. Update the read-from index -- appropriately. - (v0,i1) <- A.unpair <$> if A.eq singleType chunk firstChunk - then A.pair <$> seed <*> pure i0 - else A.pair <$> app1 delayedLinearIndex i0 <*> pure j0 + (v0,i1) <- A.unpair <$> if (eR `TupRpair` TupRsingle scalarTypeInt, A.eq singleType piece firstPiece) + then A.pair <$> seed <*> pure i0 + else A.pair <$> app1 (delayedLinearIndex arrIn) i0 <*> pure j0 -- Write the first element - writeArray arrOut j0 v0 + writeArray TypeInt arrOut j0 v0 j1 <- next j0 -- Continue looping through the rest of the input let cont i = case dir of - L -> A.lt singleType i sup - R -> A.gte singleType i inf + LeftToRight -> A.lt singleType i (indexHead end) + RightToLeft -> A.gte singleType i (indexHead start) - r <- while (cont . A.fst3) + r <- while (TupRunit `TupRpair` TupRsingle scalarTypeInt `TupRpair` TupRsingle scalarTypeInt `TupRpair` eR) + (cont . A.fst3) (\(A.untrip-> (i,j,v)) -> do - u <- app1 delayedLinearIndex i + u <- app1 (delayedLinearIndex arrIn) i v' <- case dir of - L -> app2 combine v u - R -> app2 combine u v - writeArray arrOut j v' + LeftToRight -> app2 combine v u + RightToLeft -> app2 combine u v + writeArray TypeInt arrOut j v' A.trip <$> next i <*> next j <*> pure v') (A.trip i1 j1 v0) - -- Write the final reduction result of this chunk - writeArray arrTmp chunk (A.thd3 r) + -- Write the final reduction result of this piece + writeArray TypeInt arrTmp piece (A.thd3 r) return_ @@ -722,48 +605,49 @@ -- array (rather than discard it). -- mkScan'P2 - :: forall aenv e. Elt e - => Direction + :: Direction -> UID - -> Gamma aenv - -> IRFun2 Native aenv (e -> e -> e) - -> CodeGen (IROpenAcc Native aenv (Vector e, Scalar e)) -mkScan'P2 dir uid aenv combine = + -> Gamma aenv + -> TypeR e + -> IRFun2 Native aenv (e -> e -> e) + -> CodeGen Native (IROpenAcc Native aenv (Vector e, Scalar e)) +mkScan'P2 dir uid aenv eR combine = let - (start, end, paramGang) = gangParam - (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) - (arrSum, paramSum) = mutableArray ("sum" :: Name (Scalar e)) - paramEnv = envParam aenv + (start, end, paramGang) = gangParam dim1 + (arrTmp, paramTmp) = mutableArray (ArrayR dim1 eR) "tmp" + (arrSum, paramSum) = mutableArray (ArrayR dim0 eR) "sum" + paramEnv = envParam aenv -- - cont i = case dir of - L -> A.lt singleType i end - R -> A.gte singleType i start + cont i = case dir of + LeftToRight -> A.lt singleType i (indexHead end) + RightToLeft -> A.gte singleType i (indexHead start) - next i = case dir of - L -> A.add numType i (lift 1) - R -> A.sub numType i (lift 1) + next i = case dir of + LeftToRight -> A.add numType i (liftInt 1) + RightToLeft -> A.sub numType i (liftInt 1) in makeOpenAcc uid "scanP2" (paramGang ++ paramSum ++ paramTmp ++ paramEnv) $ do i0 <- case dir of - L -> return start - R -> next end + LeftToRight -> return (indexHead start) + RightToLeft -> next (indexHead end) - v0 <- readArray arrTmp i0 + v0 <- readArray TypeInt arrTmp i0 i1 <- next i0 - r <- while (cont . A.fst) + r <- while (TupRpair (TupRsingle scalarTypeInt) eR) + (cont . A.fst) (\(A.unpair -> (i,v)) -> do - u <- readArray arrTmp i + u <- readArray TypeInt arrTmp i i' <- next i v' <- case dir of - L -> app2 combine v u - R -> app2 combine u v - writeArray arrTmp i v' + LeftToRight -> app2 combine v u + RightToLeft -> app2 combine u v + writeArray TypeInt arrTmp i v' return $ A.pair i' v') (A.pair i1 v0) - writeArray arrSum (lift 0 :: IR Int) (A.snd r) + writeArray TypeInt arrSum (liftInt 0) (A.snd r) return_ @@ -773,61 +657,58 @@ -- Similar to mkScanP3, except that indices are shifted by one since the output -- array is the same size as the input (despite being an exclusive scan). -- --- Launch (chunks-1) threads, because the first chunk does not need extra --- processing. +-- Note that the first chunk does not need to do any extra processing (has no +-- carry-in value). -- mkScan'P3 - :: forall aenv e. Elt e - => Direction + :: Direction -> UID - -> Gamma aenv - -> IRFun2 Native aenv (e -> e -> e) - -> CodeGen (IROpenAcc Native aenv (Vector e, Scalar e)) -mkScan'P3 dir uid aenv combine = + -> Gamma aenv + -> TypeR e + -> IRFun2 Native aenv (e -> e -> e) + -> CodeGen Native (IROpenAcc Native aenv (Vector e, Scalar e)) +mkScan'P3 dir uid aenv eR combine = let - (chunk, _, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Vector e)) - (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) - paramEnv = envParam aenv + (start, end, paramGang) = gangParam dim1 + (arrOut, paramOut) = mutableArray (ArrayR dim1 eR) "out" + (arrTmp, paramTmp) = mutableArray (ArrayR dim1 eR) "tmp" + paramEnv = envParam aenv -- - stride = local scalarType ("ix.stride" :: Name Int) - paramStride = scalarParameter scalarType ("ix.stride" :: Name Int) + steps = local (TupRsingle scalarTypeInt) "ix.steps" + paramSteps = parameter (TupRsingle scalarTypeInt) "ix.steps" + piece = local (TupRsingle scalarTypeInt) "ix.piece" + paramPiece = parameter (TupRsingle scalarTypeInt) "ix.piece" -- - next i = case dir of - L -> A.add numType i (lift 1) - R -> A.sub numType i (lift 1) - prev i = case dir of - L -> A.sub numType i (lift 1) - R -> A.add numType i (lift 1) + next i = case dir of + LeftToRight -> A.add numType i (liftInt 1) + RightToLeft -> A.sub numType i (liftInt 1) + prev i = case dir of + LeftToRight -> A.sub numType i (liftInt 1) + RightToLeft -> A.add numType i (liftInt 1) + firstPiece = case dir of + LeftToRight -> liftInt 0 + RightToLeft -> steps in - makeOpenAcc uid "scanP3" (paramGang ++ paramStride : paramOut ++ paramTmp ++ paramEnv) $ do - - -- Determine which chunk we will be carrying in the values of, and compute - -- the appropriate start and end indices - a <- case dir of - L -> next chunk - R -> pure chunk - - b <- A.mul numType a stride - c <- A.add numType b stride - d <- A.min singleType c (indexHead (irArrayShape arrOut)) + makeOpenAcc uid "scanP3" (paramGang ++ paramPiece ++ paramSteps ++ paramOut ++ paramTmp ++ paramEnv) $ do - inf <- next b - sup <- next d + -- TODO: don't schedule the "first" piece. + -- + A.when (neq singleType piece firstPiece) $ do - -- Carry-value from the previous chunk - e <- case dir of - L -> pure chunk - R -> prev chunk + -- Compute start and end indices, leaving space for the initial element + inf <- next (indexHead start) + sup <- next (indexHead end) - carry <- readArray arrTmp e + -- Read the carry-in value for this piece + c <- readArray TypeInt arrTmp =<< prev piece - imapFromTo inf sup $ \i -> do - x <- readArray arrOut i - y <- case dir of - L -> app2 combine carry x - R -> app2 combine x carry - writeArray arrOut i y + -- Apply the carry-in value to all elements of the output + imapFromTo inf sup $ \i -> do + x <- readArray TypeInt arrOut i + y <- case dir of + 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 new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Stencil.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.Stencil +-- Copyright : [2018..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.CodeGen.Stencil ( + + mkStencil1, + mkStencil2, + +) where + +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Shape +import Data.Array.Accelerate.Representation.Stencil +import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Type + +import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic +import Data.Array.Accelerate.LLVM.CodeGen.Array +import Data.Array.Accelerate.LLVM.CodeGen.Base +import Data.Array.Accelerate.LLVM.CodeGen.Environment +import Data.Array.Accelerate.LLVM.CodeGen.Exp +import Data.Array.Accelerate.LLVM.CodeGen.IR +import Data.Array.Accelerate.LLVM.CodeGen.Loop hiding ( imapFromStepTo ) +import Data.Array.Accelerate.LLVM.CodeGen.Monad +import Data.Array.Accelerate.LLVM.CodeGen.Stencil +import Data.Array.Accelerate.LLVM.CodeGen.Sugar +import Data.Array.Accelerate.LLVM.Compile.Cache + +import Data.Array.Accelerate.LLVM.Native.CodeGen.Base +import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop +import Data.Array.Accelerate.LLVM.Native.Target ( Native ) + +import qualified LLVM.AST.Global as LLVM + +import Control.Monad + + +-- The stencil function is similar to a map, but has access to surrounding +-- elements as specified by the stencil pattern. +-- +-- This generates two functions: +-- +-- * stencil_inside: does not apply boundary conditions, assumes all element +-- accesses are valid +-- +-- * stencil_border: applies boundary condition check to each array access +-- +mkStencil1 + :: UID + -> Gamma aenv + -> StencilR sh a stencil + -> TypeR b + -> IRFun1 Native aenv (stencil -> b) + -> IRBoundary Native aenv (Array sh a) + -> MIRDelayed Native aenv (Array sh a) + -> CodeGen Native (IROpenAcc Native aenv (Array sh b)) +mkStencil1 uid aenv sr tp f bnd marr = + let (arrIn, paramIn) = delayedArray "in" marr + repr = ArrayR (stencilShapeR sr) tp + in (+++) <$> mkInside uid aenv repr (IRFun1 $ app1 f <=< stencilAccess sr Nothing arrIn) paramIn + <*> mkBorder uid aenv repr (IRFun1 $ app1 f <=< stencilAccess sr (Just bnd) arrIn) paramIn + +mkStencil2 + :: UID + -> Gamma aenv + -> StencilR sh a stencil1 + -> StencilR sh b stencil2 + -> TypeR c + -> IRFun2 Native aenv (stencil1 -> stencil2 -> c) + -> IRBoundary Native aenv (Array sh a) + -> MIRDelayed Native aenv (Array sh a) + -> IRBoundary Native aenv (Array sh b) + -> MIRDelayed Native aenv (Array sh b) + -> CodeGen Native (IROpenAcc Native aenv (Array sh c)) +mkStencil2 uid aenv sr1 sr2 tp f bnd1 marr1 bnd2 marr2 = + let + (arrIn1, paramIn1) = delayedArray "in1" marr1 + (arrIn2, paramIn2) = delayedArray "in2" marr2 + + repr = ArrayR (stencilShapeR sr1) tp + + inside = IRFun1 $ \ix -> do + stencil1 <- stencilAccess sr1 Nothing arrIn1 ix + stencil2 <- stencilAccess sr2 Nothing arrIn2 ix + app2 f stencil1 stencil2 + -- + border = IRFun1 $ \ix -> do + stencil1 <- stencilAccess sr1 (Just bnd1) arrIn1 ix + stencil2 <- stencilAccess sr2 (Just bnd2) arrIn2 ix + app2 f stencil1 stencil2 + in + (+++) <$> mkInside uid aenv repr inside (paramIn1 ++ paramIn2) + <*> mkBorder uid aenv repr border (paramIn1 ++ paramIn2) + + +mkInside + :: UID + -> Gamma aenv + -> ArrayR (Array sh e) + -> IRFun1 Native aenv (sh -> e) + -> [LLVM.Parameter] + -> CodeGen Native (IROpenAcc Native aenv (Array sh e)) +mkInside uid aenv repr apply paramIn = + let + (start, end, paramGang) = gangParam (arrayRshape repr) + (arrOut, paramOut) = mutableArray repr "out" + paramEnv = envParam aenv + shOut = irArrayShape arrOut + in + makeOpenAcc uid "stencil_inside" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do + + imapNestFromToTile (arrayRshape repr) 4 start end shOut $ \ix i -> do + r <- app1 apply ix -- apply generator function + writeArray TypeInt arrOut i r -- store result + + return_ + +mkBorder + :: UID + -> Gamma aenv + -> ArrayR (Array sh e) + -> IRFun1 Native aenv (sh -> e) + -> [LLVM.Parameter] + -> CodeGen Native (IROpenAcc Native aenv (Array sh e)) +mkBorder uid aenv repr apply paramIn = + let + (start, end, paramGang) = gangParam (arrayRshape repr) + (arrOut, paramOut) = mutableArray repr "out" + paramEnv = envParam aenv + shOut = irArrayShape arrOut + in + makeOpenAcc uid "stencil_border" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do + + 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 + :: ShapeR sh + -> Int -- ^ unroll amount (tile height) + -> Operands sh -- ^ initial index (inclusive) + -> Operands sh -- ^ final index (exclusive) + -> Operands sh -- ^ total array extent + -> (Operands sh -> Operands Int -> CodeGen Native ()) -- ^ apply at each index + -> CodeGen Native () +imapNestFromToTile shr unroll start end extent body = + go shr start end body' + where + body' ix = body ix =<< intOfIndex shr extent ix + + go :: ShapeR t + -> Operands t + -> Operands t + -> (Operands t -> CodeGen Native ()) + -> CodeGen Native () + go ShapeRz OP_Unit OP_Unit k + = k OP_Unit + + -- To correctly generate the unrolled loop nest we need to explicitly match + -- on the last two dimensions. + -- + go (ShapeRsnoc (ShapeRsnoc ShapeRz)) (OP_Pair (OP_Pair OP_Unit sy) sx) (OP_Pair (OP_Pair OP_Unit ey) ex) k + = do + -- Tile the stencil operator in the xy-plane by unrolling in the + -- y-dimension and vectorising in the x-dimension. + -- + sy' <- imapFromStepTo sy (liftInt unroll) ey $ \iy -> + imapFromTo sx ex $ \ix -> + forM_ [0 .. unroll-1] $ \n -> do + iy' <- add numType iy (liftInt n) + k (OP_Pair (OP_Pair OP_Unit iy') ix) + + -- Take care of any remaining loop iterations in the y-dimension + -- + _ <- imapFromTo sy' ey $ \iy -> + imapFromTo sx ex $ \ix -> + k (OP_Pair (OP_Pair OP_Unit iy) ix) + return () + + -- The 1- and 3+-dimensional cases can recurse normally + -- + go (ShapeRsnoc shr') (OP_Pair ssh ssz) (OP_Pair esh esz) k + = go shr' ssh esh + $ \sz -> imapFromTo ssz esz + $ \i -> k (OP_Pair sz i) + +imapFromStepTo + :: Operands Int + -> Operands Int + -> Operands Int + -> (Operands Int -> CodeGen Native ()) + -> CodeGen Native (Operands Int) +imapFromStepTo start step end body = + let + incr i = add numType i step + test i = do i' <- incr i + lt singleType i' end + in + while (TupRsingle scalarTypeInt) test + (\i -> body i >> incr i) + start + diff --git a/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Transform.hs b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Transform.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Transform.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.Transform +-- 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.CodeGen.Transform + where + +-- accelerate +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Type + +import Data.Array.Accelerate.LLVM.CodeGen.Array +import Data.Array.Accelerate.LLVM.CodeGen.Base +import Data.Array.Accelerate.LLVM.CodeGen.Environment +import Data.Array.Accelerate.LLVM.CodeGen.Exp +import Data.Array.Accelerate.LLVM.CodeGen.Monad +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.CodeGen.Base +import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop + + +-- Hybrid map/backpermute operation +-- +mkTransform + :: UID + -> Gamma aenv + -> ArrayR (Array sh a) + -> ArrayR (Array sh' b) + -> IRFun1 Native aenv (sh' -> sh) + -> IRFun1 Native aenv (a -> b) + -> CodeGen Native (IROpenAcc Native aenv (Array sh' b)) +mkTransform uid aenv reprIn reprOut p f = + let + (start, end, paramGang) = gangParam (arrayRshape reprOut) + (arrIn, paramIn) = mutableArray reprIn "in" + (arrOut, paramOut) = mutableArray reprOut "out" + paramEnv = envParam aenv + shIn = irArrayShape arrIn + shOut = irArrayShape arrOut + in + makeOpenAcc uid "transform" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do + + imapNestFromTo (arrayRshape reprOut) start end shOut $ \ix' i' -> do + ix <- app1 p ix' + i <- intOfIndex (arrayRshape reprIn) shIn ix + a <- readArray TypeInt arrIn i + 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 @@ -3,11 +3,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.Compile --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- Copyright : [2014..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -19,14 +18,8 @@ ) where --- llvm-hs -import LLVM.AST hiding ( Module ) -import LLVM.Module as LLVM hiding ( Module ) -import LLVM.Context -import LLVM.Target - --- accelerate -import Data.Array.Accelerate.Trafo ( DelayedOpenAcc ) +import Data.Array.Accelerate.AST ( PreOpenAcc ) +import Data.Array.Accelerate.Trafo.Delayed import Data.Array.Accelerate.LLVM.CodeGen import Data.Array.Accelerate.LLVM.Compile @@ -41,7 +34,11 @@ import Data.Array.Accelerate.LLVM.Native.Target import qualified Data.Array.Accelerate.LLVM.Native.Debug as Debug --- standard library +import LLVM.AST hiding ( Module ) +import LLVM.Module as LLVM hiding ( Module ) +import LLVM.Context +import LLVM.Target + import Control.Monad.State import Data.ByteString ( ByteString ) import Data.ByteString.Short ( ShortByteString ) @@ -67,15 +64,19 @@ -- | Compile an Accelerate expression to object code -- -compile :: DelayedOpenAcc aenv a -> Gamma aenv -> LLVM Native (ObjectR Native) -compile acc aenv = do - target <- gets llvmTarget - (uid, cacheFile) <- cacheOfOpenAcc acc +compile :: PreOpenAcc DelayedOpenAcc aenv a -> Gamma aenv -> LLVM Native (ObjectR Native) +compile pacc aenv = do -- Generate code for this Acc operation -- - let Module ast md = llvmOfOpenAcc target uid acc aenv - triple = fromMaybe BS.empty (moduleTargetTriple ast) + -- We require the metadata result, which will give us the names of the + -- 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 + + let triple = fromMaybe BS.empty (moduleTargetTriple ast) datalayout = moduleDataLayout ast nms = [ f | Name f <- Map.keys md ] 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 @@ -2,10 +2,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.Compile.Cache --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/LLVM/Native/Compile/Optimise.hs b/src/Data/Array/Accelerate/LLVM/Native/Compile/Optimise.hs --- a/src/Data/Array/Accelerate/LLVM/Native/Compile/Optimise.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/Compile/Optimise.hs @@ -1,10 +1,9 @@ -- | -- Module : Data.Array.Accelerate.LLVM.Native.Compile.Optimise --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- Copyright : [2014..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- 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 @@ -2,11 +2,10 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.Debug --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- Copyright : [2014..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple.hs b/src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple.hs deleted file mode 100644 --- a/src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple.hs +++ /dev/null @@ -1,65 +0,0 @@ --- | --- Module : Data.Array.Accelerate.LLVM.Native.Distribution.Simple --- Copyright : [2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.Native.Distribution.Simple ( - - defaultMain, - simpleUserHooks, - module Distribution.Simple, - -) where - -import Data.Array.Accelerate.LLVM.Native.Distribution.Simple.Build - -import Distribution.PackageDescription ( PackageDescription ) -import Distribution.Simple.Setup ( BuildFlags ) -import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo ) -import Distribution.Simple.PreProcess ( PPSuffixHandler, knownSuffixHandlers ) -import Distribution.Simple hiding ( defaultMain, simpleUserHooks ) -import qualified Distribution.Simple as Cabal - -import Data.List ( unionBy ) - - --- | A simple implementation of @main@ for a Cabal setup script. This is the --- same as 'Distribution.Simple.defaultMain', with added support for building --- libraries utilising 'Data.Array.Accelerate.LLVM.Native.runQ'*. --- -defaultMain :: IO () -defaultMain = Cabal.defaultMainWithHooks simpleUserHooks - - --- | Hooks that correspond to a plain instantiation of the \"simple\" build --- system. --- -simpleUserHooks :: UserHooks -simpleUserHooks = - Cabal.simpleUserHooks - { buildHook = accelerateBuildHook - } - -accelerateBuildHook - :: PackageDescription - -> LocalBuildInfo - -> UserHooks - -> BuildFlags - -> IO () -accelerateBuildHook pkg_descr localbuildinfo hooks flags = - build pkg_descr localbuildinfo flags (allSuffixHandlers hooks) - --- | Combine the preprocessors in the given hooks with the --- preprocessors built into cabal. -allSuffixHandlers :: UserHooks -> [PPSuffixHandler] -allSuffixHandlers hooks - = overridesPP (hookedPreProcessors hooks) knownSuffixHandlers - where - overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler] - overridesPP = unionBy (\x y -> fst x == fst y) - diff --git a/src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/Build.hs b/src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/Build.hs deleted file mode 100644 --- a/src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/Build.hs +++ /dev/null @@ -1,467 +0,0 @@ -{-# LANGUAGE CPP #-} --- | --- Module : Data.Array.Accelerate.LLVM.Native.Distribution.Simple.Build --- Copyright : [2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- --- Copied from: https://github.com/haskell/cabal/blob/2.0/Cabal/Distribution/Simple/Build.hs --- - -module Data.Array.Accelerate.LLVM.Native.Distribution.Simple.Build ( - - build, - -) where - -import qualified Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC as Acc - -import qualified Distribution.Simple.Build as Cabal - -import Distribution.Types.Dependency -import Distribution.Types.LocalBuildInfo -import Distribution.Types.TargetInfo -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.ForeignLib -import Distribution.Types.MungedPackageId -import Distribution.Types.MungedPackageName -import Distribution.Types.UnqualComponentName -import Distribution.Types.ComponentLocalBuildInfo -import Distribution.Types.ExecutableScope - -import Distribution.Package -import Distribution.Backpack -import Distribution.Backpack.DescribeUnitId -import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.GHCJS as GHCJS -import qualified Distribution.Simple.UHC as UHC -import qualified Distribution.Simple.HaskellSuite as HaskellSuite -import qualified Distribution.Simple.PackageIndex as Index - -import qualified Distribution.Simple.Program.HcPkg as HcPkg - -import Distribution.Simple.Compiler hiding (Flag) -import Distribution.PackageDescription hiding (Flag) -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.InstalledPackageInfo (InstalledPackageInfo) - -import Distribution.Simple.Setup -import Distribution.Simple.BuildTarget -import Distribution.Simple.BuildToolDepends -import Distribution.Simple.PreProcess -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Program.Types -import Distribution.Simple.Program.Db -import Distribution.Simple.BuildPaths -import Distribution.Simple.Configure -import Distribution.Simple.Register -import Distribution.Simple.Test.LibV09 -import Distribution.Simple.Utils - -import Distribution.Text -#if MIN_VERSION_Cabal(2,4,0) -import Distribution.System (buildPlatform, Platform) -#else -import Distribution.System (buildPlatform) -#endif -import Distribution.Verbosity - -import Distribution.Compat.Graph (IsNode(..)) - -import Control.Monad -import qualified Data.Set as Set -import System.FilePath ( (), (<.>) ) -import System.Directory ( getCurrentDirectory ) - - -build :: PackageDescription -- ^ Mostly information from the .cabal file - -> LocalBuildInfo -- ^ Configuration information - -> BuildFlags -- ^ Flags that the user passed to build - -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling - -> IO () -build pkg_descr lbi flags suffixes = do - targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs flags) - let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) - info verbosity $ "Component build order: " - ++ intercalate ", " - (map (showComponentName . componentLocalName . targetCLBI) - componentsToBuild) - - when (null targets) $ - -- Only bother with this message if we're building the whole package - setupMessage verbosity "Building" (packageId pkg_descr) - - internalPackageDB <- createInternalPackageDB verbosity lbi distPref - - (\f -> foldM_ f (installedPkgs lbi) componentsToBuild) $ \index target -> do - let comp = targetComponent target - clbi = targetCLBI target - Cabal.componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity - let bi = componentBuildInfo comp - progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi) - lbi' = lbi { - withPrograms = progs', - withPackageDB = withPackageDB lbi ++ [internalPackageDB], - installedPkgs = index - } - mb_ipi <- buildComponent verbosity (buildNumJobs flags) pkg_descr - lbi' suffixes comp clbi distPref - return (maybe index (Index.insert `flip` index) mb_ipi) - return () - where - distPref = fromFlag (buildDistPref flags) - verbosity = fromFlag (buildVerbosity flags) - - -buildComponent :: Verbosity - -> Flag (Maybe Int) - -> PackageDescription - -> LocalBuildInfo - -> [PPSuffixHandler] - -> Component - -> ComponentLocalBuildInfo - -> FilePath - -> IO (Maybe InstalledPackageInfo) -buildComponent verbosity numJobs pkg_descr lbi suffixes - comp@(CLib lib) clbi distPref = do - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - let libbi = libBuildInfo lib - lib' = lib { libBuildInfo = addExtraCSources libbi extras } - buildLib verbosity numJobs pkg_descr lbi lib' clbi - - let oneComponentRequested (OneComponentRequestedSpec _) = True - oneComponentRequested _ = False - -- Don't register inplace if we're only building a single component; - -- it's not necessary because there won't be any subsequent builds - -- that need to tag us - if (not (oneComponentRequested (componentEnabledSpec lbi))) - then do - -- Register the library in-place, so exes can depend - -- on internally defined libraries. - pwd <- getCurrentDirectory - let -- The in place registration uses the "-inplace" suffix, not an ABI hash - installedPkgInfo = inplaceInstalledPackageInfo pwd distPref pkg_descr - -- NB: Use a fake ABI hash to avoid - -- needing to recompute it every build. - (mkAbiHash "inplace") lib' lbi clbi - - debug verbosity $ "Registering inplace:\n" ++ (IPI.showInstalledPackageInfo installedPkgInfo) - registerPackage verbosity (compiler lbi) (withPrograms lbi) - (withPackageDB lbi) installedPkgInfo - HcPkg.defaultRegisterOptions { - HcPkg.registerMultiInstance = True - } - return (Just installedPkgInfo) - else return Nothing - -buildComponent verbosity numJobs pkg_descr lbi suffixes - comp@(CFLib flib) clbi _distPref = do - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - buildFLib verbosity numJobs pkg_descr lbi flib clbi - return Nothing - -buildComponent verbosity numJobs pkg_descr lbi suffixes - comp@(CExe exe) clbi _ = do - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - let ebi = buildInfo exe - exe' = exe { buildInfo = addExtraCSources ebi extras } - buildExe verbosity numJobs pkg_descr lbi exe' clbi - return Nothing - - -buildComponent verbosity numJobs pkg_descr lbi suffixes - comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} }) - clbi _distPref = do - let exe = testSuiteExeV10AsExe test - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - let ebi = buildInfo exe - exe' = exe { buildInfo = addExtraCSources ebi extras } - buildExe verbosity numJobs pkg_descr lbi exe' clbi - return Nothing - - -buildComponent verbosity numJobs pkg_descr lbi0 suffixes - comp@(CTest - test@TestSuite { testInterface = TestSuiteLibV09{} }) - clbi -- This ComponentLocalBuildInfo corresponds to a detailed - -- test suite and not a real component. It should not - -- be used, except to construct the CLBIs for the - -- library and stub executable that will actually be - -- built. - distPref = do - pwd <- getCurrentDirectory - let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) = - testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - buildLib verbosity numJobs pkg lbi lib libClbi - -- NB: need to enable multiple instances here, because on 7.10+ - -- the package name is the same as the library, and we still - -- want the registration to go through. - registerPackage verbosity (compiler lbi) (withPrograms lbi) - (withPackageDB lbi) ipi - HcPkg.defaultRegisterOptions { - HcPkg.registerMultiInstance = True - } - let ebi = buildInfo exe - exe' = exe { buildInfo = addExtraCSources ebi extras } - buildExe verbosity numJobs pkg_descr lbi exe' exeClbi - return Nothing -- Can't depend on test suite - - -buildComponent verbosity _ _ _ _ - (CTest TestSuite { testInterface = TestSuiteUnsupported tt }) - _ _ = - die' verbosity $ "No support for building test suite type " ++ display tt - - -buildComponent verbosity numJobs pkg_descr lbi suffixes - comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} }) - clbi _ = do - let (exe, exeClbi) = benchmarkExeV10asExe bm clbi - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - let ebi = buildInfo exe - exe' = exe { buildInfo = addExtraCSources ebi extras } - buildExe verbosity numJobs pkg_descr lbi exe' exeClbi - return Nothing - - -buildComponent verbosity _ _ _ _ - (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt }) - _ _ = - die' verbosity $ "No support for building benchmark type " ++ display tt - - - --- | Add extra C sources generated by preprocessing to build --- information. -addExtraCSources :: BuildInfo -> [FilePath] -> BuildInfo -addExtraCSources bi extras = bi { cSources = new } - where new = Set.toList $ old `Set.union` exs - old = Set.fromList $ cSources bi - exs = Set.fromList extras - - --- | Translate a exe-style 'TestSuite' component into an exe for building -testSuiteExeV10AsExe :: TestSuite -> Executable -testSuiteExeV10AsExe test@TestSuite { testInterface = TestSuiteExeV10 _ mainFile } = - Executable { - exeName = testName test, - modulePath = mainFile, - exeScope = ExecutablePublic, - buildInfo = testBuildInfo test - } -testSuiteExeV10AsExe TestSuite{} = error "testSuiteExeV10AsExe: wrong kind" - -#if MIN_VERSION_Cabal(2,4,0) -setBuildDepends :: [Dependency] -> PackageDescription -> PackageDescription -setBuildDepends deps pkg_descr@PackageDescription{ setupBuildInfo = Just buildInfo'} - = pkg_descr { setupBuildInfo = Just (buildInfo' {setupDepends = deps})} -setBuildDepends deps pkg_descr@PackageDescription{ setupBuildInfo = Nothing} - = pkg_descr - { setupBuildInfo = Just (SetupBuildInfo {setupDepends = deps, defaultSetupDepends = True}) - } -exeExtension' :: Platform -> String -exeExtension' = exeExtension -#else -setBuildDepends :: [Dependency] -> PackageDescription -> PackageDescription -setBuildDepends deps pkg_descr = pkg_descr {buildDepends = deps} -exeExtension' :: a -> String -exeExtension' _ = exeExtension -#endif - - --- | Translate a lib-style 'TestSuite' component into a lib + exe for building -testSuiteLibV09AsLibAndExe :: PackageDescription - -> TestSuite - -> ComponentLocalBuildInfo - -> LocalBuildInfo - -> FilePath - -> FilePath - -> (PackageDescription, - Library, ComponentLocalBuildInfo, - LocalBuildInfo, - IPI.InstalledPackageInfo, - Executable, ComponentLocalBuildInfo) -testSuiteLibV09AsLibAndExe pkg_descr - test@TestSuite { testInterface = TestSuiteLibV09 _ m } - clbi lbi distPref pwd = - (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) - where - bi = testBuildInfo test - lib = Library { - libName = Nothing, - exposedModules = [ m ], - reexportedModules = [], - signatures = [], - libExposed = True, - libBuildInfo = bi - } - -- This is, like, the one place where we use a CTestName for a library. - -- Should NOT use library name, since that could conflict! - PackageIdentifier pkg_name pkg_ver = package pkg_descr - compat_name = computeCompatPackageName pkg_name (Just (testName test)) - compat_key = computeCompatPackageKey (compiler lbi) compat_name pkg_ver (componentUnitId clbi) - libClbi = LibComponentLocalBuildInfo - { componentPackageDeps = componentPackageDeps clbi - , componentInternalDeps = componentInternalDeps clbi - , componentIsIndefinite_ = False - , componentExeDeps = componentExeDeps clbi - , componentLocalName = CSubLibName (testName test) - , componentIsPublic = False - , componentIncludes = componentIncludes clbi - , componentUnitId = componentUnitId clbi - , componentComponentId = componentComponentId clbi - , componentInstantiatedWith = [] - , componentCompatPackageName = compat_name - , componentCompatPackageKey = compat_key - , componentExposedModules = [IPI.ExposedModule m Nothing] - } - pkg = setBuildDepends (targetBuildDepends $ testBuildInfo test) $ pkg_descr { - package = (package pkg_descr) { pkgName = mkPackageName $ unMungedPackageName compat_name } - , executables = [] - , testSuites = [] - , subLibraries = [lib] - } - ipi = inplaceInstalledPackageInfo pwd distPref pkg (mkAbiHash "") lib lbi libClbi - testDir = buildDir lbi stubName test - stubName test ++ "-tmp" - testLibDep = thisPackageVersion $ package pkg - exe = Executable { - exeName = mkUnqualComponentName $ stubName test, - modulePath = stubFilePath test, - exeScope = ExecutablePublic, - buildInfo = (testBuildInfo test) { - hsSourceDirs = [ testDir ], - targetBuildDepends = testLibDep - : (targetBuildDepends $ testBuildInfo test) - } - } - -- | The stub executable needs a new 'ComponentLocalBuildInfo' - -- that exposes the relevant test suite library. - deps = (IPI.installedUnitId ipi, mungedId ipi) - : (filter (\(_, x) -> let name = unMungedPackageName $ mungedName x - in name == "Cabal" || name == "base") - (componentPackageDeps clbi)) - exeClbi = ExeComponentLocalBuildInfo { - -- TODO: this is a hack, but as long as this is unique - -- (doesn't clobber something) we won't run into trouble - componentUnitId = mkUnitId (stubName test), - componentComponentId = mkComponentId (stubName test), - componentInternalDeps = [componentUnitId clbi], - componentExeDeps = [], - componentLocalName = CExeName $ mkUnqualComponentName $ stubName test, - componentPackageDeps = deps, - -- Assert DefUnitId invariant! - -- Executable can't be indefinite, so dependencies must - -- be definite packages. - componentIncludes = zip (map (DefiniteUnitId . unsafeMkDefUnitId . fst) deps) - (repeat defaultRenaming) - } -testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind" - - --- | Translate a exe-style 'Benchmark' component into an exe for building -benchmarkExeV10asExe :: Benchmark -> ComponentLocalBuildInfo - -> (Executable, ComponentLocalBuildInfo) -benchmarkExeV10asExe bm@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f } - clbi = - (exe, exeClbi) - where - exe = Executable { - exeName = benchmarkName bm, - modulePath = f, - exeScope = ExecutablePublic, - buildInfo = benchmarkBuildInfo bm - } - exeClbi = ExeComponentLocalBuildInfo { - componentUnitId = componentUnitId clbi, - componentComponentId = componentComponentId clbi, - componentLocalName = CExeName (benchmarkName bm), - componentInternalDeps = componentInternalDeps clbi, - componentExeDeps = componentExeDeps clbi, - componentPackageDeps = componentPackageDeps clbi, - componentIncludes = componentIncludes clbi - } -benchmarkExeV10asExe Benchmark{} _ = error "benchmarkExeV10asExe: wrong kind" - - --- | Initialize a new package db file for libraries defined --- internally to the package. -createInternalPackageDB :: Verbosity -> LocalBuildInfo -> FilePath - -> IO PackageDB -createInternalPackageDB verbosity lbi distPref = do - existsAlready <- doesPackageDBExist dbPath - when existsAlready $ deletePackageDB dbPath - createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath - return (SpecificPackageDB dbPath) - where - dbPath = internalPackageDBPath lbi distPref - -addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo - -> ProgramDb -> ProgramDb -addInternalBuildTools pkg lbi bi progs = - foldr updateProgram progs internalBuildTools - where - internalBuildTools = - [ simpleConfiguredProgram toolName' (FoundOnSystem toolLocation) - | toolName <- getAllInternalToolDependencies pkg bi - , let toolName' = unUnqualComponentName toolName - , let toolLocation = buildDir lbi toolName' toolName' <.> exeExtension' buildPlatform ] - - --- TODO: build separate libs in separate dirs so that we can build --- multiple libs, e.g. for 'LibTest' library-style test suites -buildLib :: Verbosity -> Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () -buildLib verbosity numJobs pkg_descr lbi lib clbi = - case compilerFlavor (compiler lbi) of - GHC -> Acc.buildLib verbosity numJobs pkg_descr lbi lib clbi -- XXX only change here - GHCJS -> GHCJS.buildLib verbosity numJobs pkg_descr lbi lib clbi - UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi - HaskellSuite {} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi - _ -> die' verbosity "Building is not supported with this compiler." - --- | Build a foreign library --- --- NOTE: We assume that we already checked that we can actually build the --- foreign library in configure. -buildFLib :: Verbosity -> Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> ForeignLib -> ComponentLocalBuildInfo -> IO () -buildFLib verbosity numJobs pkg_descr lbi flib clbi = - case compilerFlavor (compiler lbi) of - GHC -> GHC.buildFLib verbosity numJobs pkg_descr lbi flib clbi - _ -> die' verbosity "Building is not supported with this compiler." - -buildExe :: Verbosity -> Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> Executable -> ComponentLocalBuildInfo -> IO () -buildExe verbosity numJobs pkg_descr lbi exe clbi = - case compilerFlavor (compiler lbi) of - GHC -> GHC.buildExe verbosity numJobs pkg_descr lbi exe clbi - GHCJS -> GHCJS.buildExe verbosity numJobs pkg_descr lbi exe clbi - UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi - _ -> die' verbosity "Building is not supported with this compiler." - - diff --git a/src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC.hs b/src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC.hs deleted file mode 100644 --- a/src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC.hs +++ /dev/null @@ -1,458 +0,0 @@ -{-# LANGUAGE CPP #-} --- | --- Module : Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC --- Copyright : [2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- --- Copied from: https://github.com/haskell/cabal/blob/2.0/Cabal/Distribution/Simple/GHC.hs --- - -module Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC ( - - buildLib, - replLib, - -) where - -import qualified Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC.Internal as Internal -import qualified Data.Array.Accelerate.LLVM.Native.Plugin.BuildInfo as Internal - -import qualified Distribution.Simple.GHC as Cabal -import Distribution.PackageDescription as PD -import Distribution.Simple.LocalBuildInfo -import Distribution.Types.ComponentLocalBuildInfo -import qualified Distribution.Simple.Hpc as Hpc -import Distribution.Simple.BuildPaths -import Distribution.Simple.Utils -import qualified Distribution.ModuleName as ModuleName -import Distribution.Simple.Program -import qualified Distribution.Simple.Program.Ar as Ar -import Distribution.Simple.Program.GHC -import Distribution.Simple.Setup -import qualified Distribution.Simple.Setup as Cabal -import Distribution.Simple.Compiler hiding (Flag) -import Distribution.Version -import Distribution.System -import Distribution.Verbosity -import Distribution.Text -import Distribution.Types.UnitId(UnitId) -import Distribution.Utils.NubList -import Language.Haskell.Extension - -import Control.Monad (when, unless) -import Data.List (nub) -import Data.Maybe (catMaybes) -import System.FilePath ( (), replaceExtension, isRelative ) -import qualified Data.Map as Map - - --- --- -buildLib, replLib :: Verbosity -> Cabal.Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () -buildLib = buildOrReplLib False -replLib = buildOrReplLib True - - -#if MIN_VERSION_Cabal(2,4,0) -nubList :: a -> a -nubList = id - -overNubListR' :: a -> a -overNubListR' = id - -mkSharedLibName' :: Platform -> CompilerId -> UnitId -> String -mkSharedLibName' = mkSharedLibName -#else -nubList :: (Ord a) => [a] -> NubListR a -nubList = toNubListR - -overNubListR' :: (Ord a) => ([a] -> [a]) -> NubListR a -> NubListR a -overNubListR' = overNubListR - -mkSharedLibName' :: Platform -> CompilerId -> UnitId -> String -mkSharedLibName' _ compiler_uid path = mkSharedLibName compiler_uid path -#endif - -buildOrReplLib :: Bool -> Verbosity -> Cabal.Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () -buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do - let uid = componentUnitId clbi - libTargetDir = componentBuildDir lbi clbi - whenVanillaLib forceVanilla = - when (forceVanilla || withVanillaLib lbi) - whenProfLib = when (withProfLib lbi) - whenSharedLib forceShared = - when (forceShared || withSharedLib lbi) - whenGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi) - ifReplLib = when forRepl - comp = compiler lbi - ghcVersion = compilerVersion comp - implInfo = Cabal.getImplInfo comp - platform@(Platform _hostArch hostOS) = hostPlatform lbi - has_code = not (componentIsIndefinite clbi) - - (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) - let runGhcProg = runGHC verbosity ghcProg comp platform - - libBi <- hackThreadedFlag verbosity - comp (withProfLib lbi) (libBuildInfo lib) - - let isGhcDynamic = Cabal.isDynamic comp - dynamicTooSupported = supportsDynamicToo comp - doingTH = EnableExtension TemplateHaskell `elem` allExtensions libBi - forceVanillaLib = doingTH && not isGhcDynamic - forceSharedLib = doingTH && isGhcDynamic - -- TH always needs default libs, even when building for profiling - - -- Determine if program coverage should be enabled and if so, what - -- '-hpcdir' should be. - let isCoverageEnabled = libCoverage lbi - -- TODO: Historically HPC files have been put into a directory which - -- has the package name. I'm going to avoid changing this for - -- now, but it would probably be better for this to be the - -- component ID instead... - pkg_name = display (PD.package pkg_descr) - distPref = fromFlag $ configDistPref $ configFlags lbi - hpcdir way - | forRepl = mempty -- HPC is not supported in ghci - | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name - | otherwise = mempty - - createDirectoryIfMissingVerbose verbosity True libTargetDir - -- TODO: do we need to put hs-boot files into place for mutually recursive - -- modules? - let cObjs = map (`replaceExtension` objExtension) (cSources libBi) - baseOpts = Cabal.componentGhcOptions verbosity lbi libBi clbi libTargetDir - vanillaOpts = baseOpts `mappend` mempty { - ghcOptMode = toFlag GhcModeMake, - ghcOptNumJobs = numJobs, - ghcOptInputModules = toNubListR $ allLibModules lib clbi, - ghcOptHPCDir = hpcdir Hpc.Vanilla - } - - profOpts = vanillaOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptProfilingAuto = Internal.profDetailLevelFlag True - (withProfLibDetail lbi), - ghcOptHiSuffix = toFlag "p_hi", - ghcOptObjSuffix = toFlag "p_o", - ghcOptExtra = nubList $ hcProfOptions GHC libBi, - ghcOptHPCDir = hpcdir Hpc.Prof - } - - sharedOpts = vanillaOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptFPic = toFlag True, - ghcOptHiSuffix = toFlag "dyn_hi", - ghcOptObjSuffix = toFlag "dyn_o", - ghcOptExtra = nubList $ hcSharedOptions GHC libBi, - ghcOptHPCDir = hpcdir Hpc.Dyn - } - linkerOpts = mempty { - ghcOptLinkOptions = nubList $ PD.ldOptions libBi, - ghcOptLinkLibs = nubList $ extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, - ghcOptLinkFrameworks = toNubListR $ - PD.frameworks libBi, - ghcOptLinkFrameworkDirs = toNubListR $ - PD.extraFrameworkDirs libBi, - ghcOptInputFiles = toNubListR - [libTargetDir x | x <- cObjs] - } - replOpts = vanillaOpts { - ghcOptExtra = overNubListR' Internal.filterGhciFlags $ - ghcOptExtra vanillaOpts, - ghcOptNumJobs = mempty - } - `mappend` linkerOpts - `mappend` mempty { - ghcOptMode = toFlag GhcModeInteractive, - ghcOptOptimisation = toFlag GhcNoOptimisation - } - - vanillaSharedOpts = vanillaOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, - ghcOptDynHiSuffix = toFlag "dyn_hi", - ghcOptDynObjSuffix = toFlag "dyn_o", - ghcOptHPCDir = hpcdir Hpc.Dyn - } - - unless (forRepl || null (allLibModules lib clbi)) $ - do let vanilla = whenVanillaLib forceVanillaLib (runGhcProg vanillaOpts) - shared = whenSharedLib forceSharedLib (runGhcProg sharedOpts) - useDynToo = dynamicTooSupported && - (forceVanillaLib || withVanillaLib lbi) && - (forceSharedLib || withSharedLib lbi) && - null (hcSharedOptions GHC libBi) - if not has_code - then vanilla - else - if useDynToo - then do - runGhcProg vanillaSharedOpts - case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of - (Cabal.Flag dynDir, Cabal.Flag vanillaDir) -> - -- When the vanilla and shared library builds are done - -- in one pass, only one set of HPC module interfaces - -- are generated. This set should suffice for both - -- static and dynamically linked executables. We copy - -- the modules interfaces so they are available under - -- both ways. - copyDirectoryRecursive verbosity dynDir vanillaDir - _ -> return () - else if isGhcDynamic - then do shared; vanilla - else do vanilla; shared - when has_code $ whenProfLib (runGhcProg profOpts) - - -- build any C sources - unless (not has_code || null (cSources libBi)) $ do - info verbosity "Building C Sources..." - sequence_ - [ do let baseCcOpts = Cabal.componentCcGhcOptions verbosity - lbi libBi clbi libTargetDir filename - vanillaCcOpts = if isGhcDynamic - -- Dynamic GHC requires C sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCcOpts { ghcOptFPic = toFlag True } - else baseCcOpts - profCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - sharedCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaCcOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded ccOpts = do - needsRecomp <- checkNeedsRecompilation filename ccOpts - when needsRecomp $ runGhcProg ccOpts - runGhcProgIfNeeded vanillaCcOpts - unless forRepl $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts) - unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts) - | filename <- cSources libBi] - - -- TODO: problem here is we need the .c files built first, so we can load them - -- with ghci, but .c files can depend on .h files generated by ghc by ffi - -- exports. - - when has_code . ifReplLib $ do - when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules" - ifReplLib (runGhcProg replOpts) - - -- link: - when has_code . unless forRepl $ do - info verbosity "Linking..." - let cProfObjs = map (`replaceExtension` ("p_" ++ objExtension)) - (cSources libBi) - cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) - (cSources libBi) - compiler_id = compilerId (compiler lbi) - vanillaLibFilePath = libTargetDir mkLibName uid - profileLibFilePath = libTargetDir mkProfLibName uid - sharedLibFilePath = libTargetDir mkSharedLibName' buildPlatform compiler_id uid - ghciLibFilePath = libTargetDir Internal.mkGHCiLibName uid - libInstallPath = libdir $ absoluteComponentInstallDirs pkg_descr lbi uid NoCopyDest - sharedLibInstallPath = libInstallPath mkSharedLibName' buildPlatform compiler_id uid - - stubObjs <- catMaybes <$> sequenceA - [ findFileWithExtension [objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi ] - stubProfObjs <- catMaybes <$> sequenceA - [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi ] - stubSharedObjs <- catMaybes <$> sequenceA - [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi ] - - hObjs <- Internal.getHaskellObjects implInfo lib lbi clbi - libTargetDir objExtension True - hProfObjs <- - if withProfLib lbi - then Internal.getHaskellObjects implInfo lib lbi clbi - libTargetDir ("p_" ++ objExtension) True - else return [] - hSharedObjs <- - if withSharedLib lbi - then Internal.getHaskellObjects implInfo lib lbi clbi - libTargetDir ("dyn_" ++ objExtension) False - else return [] - - -- XXX: This is the only change; determine if there are any - -- accelerate-generated object files which need to linked into the final - -- libraries. - accObjs <- fmap (nub . concat . Map.elems) - $ Internal.readBuildInfo - $ Internal.mkBuildInfoFileName libTargetDir - - unless (null accObjs && null hObjs && null cObjs && null stubObjs) $ do - rpaths <- getRPaths lbi clbi - - let staticObjectFiles = - hObjs - ++ accObjs - ++ map (libTargetDir ) cObjs - ++ stubObjs - profObjectFiles = - hProfObjs - ++ accObjs - ++ map (libTargetDir ) cProfObjs - ++ stubProfObjs - ghciObjFiles = - hObjs - ++ accObjs - ++ map (libTargetDir ) cObjs - ++ stubObjs - dynamicObjectFiles = - hSharedObjs - ++ accObjs - ++ map (libTargetDir ) cSharedObjs - ++ stubSharedObjs - -- After the relocation lib is created we invoke ghc -shared - -- with the dependencies spelled out as -package arguments - -- and ghc invokes the linker with the proper library paths - ghcSharedLinkArgs = - mempty { - ghcOptShared = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptInputFiles = toNubListR dynamicObjectFiles, - ghcOptOutputFile = toFlag sharedLibFilePath, - ghcOptExtra = nubList $ hcSharedOptions GHC libBi, - -- For dynamic libs, Mac OS/X needs to know the install location - -- at build time. This only applies to GHC < 7.8 - see the - -- discussion in #1660. - ghcOptDylibName = if hostOS == OSX - && ghcVersion < mkVersion [7,8] - then toFlag sharedLibInstallPath - else mempty, - ghcOptHideAllPackages = toFlag True, - ghcOptNoAutoLinkPackages = toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo { componentCompatPackageKey = pk } - -> toFlag pk - _ -> mempty, - ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> - if null insts - then mempty - else toFlag (componentComponentId clbi) - _ -> mempty, - ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } - -> insts - _ -> [], - ghcOptPackages = toNubListR $ - Internal.mkGhcOptPackages clbi , - ghcOptLinkLibs = nubList $ extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, - ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, - ghcOptLinkFrameworkDirs = - toNubListR $ PD.extraFrameworkDirs libBi, - ghcOptRPaths = rpaths - } - - info verbosity (show (ghcOptPackages ghcSharedLinkArgs)) - - whenVanillaLib False $ - Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles - - whenProfLib $ - Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles - - whenGHCiLib $ do - (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) - Internal.combineObjectFiles verbosity lbi ldProg - ghciLibFilePath ghciObjFiles - - whenSharedLib False $ - runGhcProg ghcSharedLinkArgs - - --- | Returns True if the modification date of the given source file is newer than --- the object file we last compiled for it, or if no object file exists yet. -checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool -checkNeedsRecompilation filename opts = filename `moreRecentFile` oname - where oname = getObjectFileName filename opts - --- | Finds the object file name of the given source file -getObjectFileName :: FilePath -> GhcOptions -> FilePath -getObjectFileName filename opts = oname - where odir = fromFlag (ghcOptObjDir opts) - oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts) - oname = odir replaceExtension filename oext - --- | Calculate the RPATHs for the component we are building. --- --- Calculates relative RPATHs when 'relocatable' is set. -getRPaths :: LocalBuildInfo - -> ComponentLocalBuildInfo -- ^ Component we are building - -> IO (NubListR FilePath) -getRPaths lbi clbi | supportRPaths hostOS = do - libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi - let hostPref = case hostOS of - OSX -> "@loader_path" - _ -> "$ORIGIN" - relPath p = if isRelative p then hostPref p else p - rpaths = toNubListR (map relPath libraryPaths) - return rpaths - where - (Platform _ hostOS) = hostPlatform lbi - - -- The list of RPath-supported operating systems below reflects the - -- platforms on which Cabal's RPATH handling is tested. It does _NOT_ - -- reflect whether the OS supports RPATH. - - -- E.g. when this comment was written, the *BSD operating systems were - -- untested with regards to Cabal RPATH handling, and were hence set to - -- 'False', while those operating systems themselves do support RPATH. - supportRPaths Linux = True - supportRPaths Windows = False - supportRPaths OSX = True - supportRPaths FreeBSD = False - supportRPaths OpenBSD = False - supportRPaths NetBSD = False - supportRPaths DragonFly = False - supportRPaths Solaris = False - supportRPaths AIX = False - supportRPaths HPUX = False - supportRPaths IRIX = False - supportRPaths HaLVM = False - supportRPaths IOS = False - supportRPaths Android = False - supportRPaths Ghcjs = False - supportRPaths Hurd = False - supportRPaths (OtherOS _) = False - -- Do _not_ add a default case so that we get a warning here when a new OS - -- is added. - -getRPaths _ _ = return mempty - --- | Filter the "-threaded" flag when profiling as it does not --- work with ghc-6.8 and older. -hackThreadedFlag :: Verbosity -> Compiler -> Bool -> BuildInfo -> IO BuildInfo -hackThreadedFlag _ _ _ = return - --- ----------------------------------------------------------------------------- --- Utils - -supportsDynamicToo :: Compiler -> Bool -supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too" - diff --git a/src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC/Internal.hs b/src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC/Internal.hs deleted file mode 100644 --- a/src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC/Internal.hs +++ /dev/null @@ -1,126 +0,0 @@ -{-# LANGUAGE CPP #-} --- | --- Module : Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC.Internal --- Copyright : [2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- --- Copied from: https://github.com/haskell/cabal/blob/2.0/Cabal/Distribution/Simple/GHC/Internal.hs --- - -module Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC.Internal ( - - mkGHCiLibName, - ghcLookupProperty, - filterGhciFlags, - getHaskellObjects, - mkGhcOptPackages, - profDetailLevelFlag, - combineObjectFiles - -) where - -#if MIN_VERSION_Cabal(2,0,0) -import Distribution.Backpack -#endif -import Distribution.PackageDescription as PD hiding (Flag) -import Distribution.Simple.Compiler hiding (Flag) -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Program (ConfiguredProgram) -import Distribution.Simple.Program.GHC -import qualified Distribution.Simple.Program.Ld as Ld -import Distribution.Simple.Setup -import Distribution.Simple -import Distribution.Verbosity (Verbosity) -import qualified Distribution.ModuleName as ModuleName - -import qualified Data.Map as Map -import System.Directory ( getDirectoryContents ) -import System.FilePath ( (), (<.>), takeExtension ) - - --- | Strip out flags that are not supported in ghci -filterGhciFlags :: [String] -> [String] -filterGhciFlags = filter supported - where - supported ('-':'O':_) = False - supported "-debug" = False - supported "-threaded" = False - supported "-ticky" = False - supported "-eventlog" = False - supported "-prof" = False - supported "-unreg" = False - supported _ = True - -#if MIN_VERSION_Cabal(1,24,0) -mkGHCiLibName :: UnitId -> String -mkGHCiLibName lib = getHSLibraryName lib <.> "o" -#else -mkGHCiLibName :: LibraryName -> String -mkGHCiLibName (LibraryName lib) = lib <.> "o" -#endif - -ghcLookupProperty :: String -> Compiler -> Bool -ghcLookupProperty prop comp = - case Map.lookup prop (compilerProperties comp) of - Just "YES" -> True - _ -> False - --- when using -split-objs, we need to search for object files in the --- Module_split directory for each module. -getHaskellObjects :: _GhcImplInfo -> Library -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> FilePath -> String -> Bool -> IO [FilePath] -getHaskellObjects _implInfo lib lbi clbi pref wanted_obj_ext allow_split_objs - | splitObjs lbi && allow_split_objs = do - let splitSuffix = "_" ++ wanted_obj_ext ++ "_split" - dirs = [ pref (ModuleName.toFilePath x ++ splitSuffix) - | x <- allLibModules lib clbi ] - objss <- traverse getDirectoryContents dirs - let objs = [ dir obj - | (objs',dir) <- zip objss dirs, obj <- objs', - let obj_ext = takeExtension obj, - '.':wanted_obj_ext == obj_ext ] - return objs - | otherwise = - return [ pref ModuleName.toFilePath x <.> wanted_obj_ext - | x <- allLibModules lib clbi ] - -#if MIN_VERSION_Cabal(2,0,0) -mkGhcOptPackages :: ComponentLocalBuildInfo - -> [(OpenUnitId, ModuleRenaming)] -mkGhcOptPackages = componentIncludes -#else -mkGhcOptPackages :: ComponentLocalBuildInfo - -> [(InstalledPackageId, PackageId, ModuleRenaming)] -mkGhcOptPackages clbi = - map (\(i,p) -> (i,p,lookupRenaming p (componentPackageRenaming clbi))) - (componentPackageDeps clbi) -#endif - -profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto -profDetailLevelFlag forLib mpl = - case mpl of - ProfDetailNone -> mempty - ProfDetailDefault | forLib -> toFlag GhcProfAutoExported - | otherwise -> toFlag GhcProfAutoToplevel - ProfDetailExportedFunctions -> toFlag GhcProfAutoExported - ProfDetailToplevelFunctions -> toFlag GhcProfAutoToplevel - ProfDetailAllFunctions -> toFlag GhcProfAutoAll - ProfDetailOther _ -> mempty - -#if !MIN_VERSION_Cabal(2,0,0) -allLibModules :: Library -> ComponentLocalBuildInfo -> [ModuleName.ModuleName] -allLibModules lib _ = libModules lib -#endif - -combineObjectFiles :: Verbosity -> LocalBuildInfo -> ConfiguredProgram - -> FilePath -> [FilePath] -> IO () -#if MIN_VERSION_Cabal(2,1,0) -combineObjectFiles = Ld.combineObjectFiles -#else -combineObjectFiles v _ = Ld.combineObjectFiles v -#endif 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 @@ -1,14 +1,15 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.Embed --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -39,14 +40,18 @@ import Control.Monad import Data.Hashable import Foreign.Ptr -import GHC.Ptr ( Ptr(..) ) import Language.Haskell.TH ( Q, TExp ) import Numeric import System.IO.Unsafe import qualified Language.Haskell.TH 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 embedForTarget = embed @@ -56,7 +61,7 @@ -- embed :: Native -> ObjectR Native -> Q (TExp (ExecutableR Native)) embed target (ObjectR uid nms !_) = do - objFile <- TH.runIO (evalNative target (cacheOfUID uid)) + objFile <- getObjectFile funtab <- forM nms $ \fn -> return [|| ( $$(liftSBS (BS.take (BS.length fn - 65) fn)), $$(makeFFI fn objFile) ) ||] -- [|| NativeR (unsafePerformIO $ newLifetime (FunctionTable $$(listE funtab))) ||] @@ -64,13 +69,6 @@ listE :: [Q (TExp a)] -> Q (TExp [a]) listE xs = TH.unsafeTExpCoerce (TH.listE (map TH.unTypeQ xs)) - liftSBS :: ShortByteString -> Q (TExp ShortByteString) - liftSBS bs = - let bytes = BS.unpack bs - len = BS.length bs - in - [|| unsafePerformIO $ BS.createFromPtr $$( TH.unsafeTExpCoerce [| Ptr $(TH.litE (TH.StringPrimL bytes)) |]) len ||] - makeFFI :: ShortByteString -> FilePath -> Q (TExp (FunPtr ())) makeFFI (S8.unpack -> fn) objFile = do i <- TH.runIO newUnique @@ -79,4 +77,26 @@ ann <- TH.pragAnnD (TH.ValueAnnotation fn') [| (Object objFile) |] TH.addTopDecls [dec, ann] TH.unsafeTExpCoerce (TH.varE fn') + + -- Note: [Template Haskell and raw object files] + -- + -- We can only addForeignFilePath once per object file, otherwise the + -- linker will complain about duplicate symbols. To work around this, + -- we use putQ/getQ to keep track of which object files have already + -- been encountered during compilation _of the current module_. This + -- means that we might still run into problems if runQ is invoked at + -- multiple modules. + -- + getObjectFile :: Q FilePath + getObjectFile = do + this <- TH.runIO (evalNative target (cacheOfUID uid)) +#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) +#endif + return this 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 @@ -1,516 +1,1017 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | --- Module : Data.Array.Accelerate.LLVM.Native.Execute --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.Native.Execute ( - - executeAcc, executeAfun, - executeOpenAcc - -) where - --- accelerate -import Data.Array.Accelerate.Analysis.Match -import Data.Array.Accelerate.Array.Sugar -import Data.Array.Accelerate.Error - -import Data.Array.Accelerate.LLVM.Analysis.Match -import Data.Array.Accelerate.LLVM.Execute -import Data.Array.Accelerate.LLVM.State - -import Data.Array.Accelerate.LLVM.Native.Array.Data -import Data.Array.Accelerate.LLVM.Native.Link -import Data.Array.Accelerate.LLVM.Native.Execute.Async -import Data.Array.Accelerate.LLVM.Native.Execute.Environment -import Data.Array.Accelerate.LLVM.Native.Execute.Marshal -import Data.Array.Accelerate.LLVM.Native.Target -import qualified Data.Array.Accelerate.LLVM.Native.Debug as Debug - --- Use work-stealing scheduler -import Data.Range ( Range(..) ) -import Control.Parallel.Meta ( Executable(..) ) -import Data.Array.Accelerate.LLVM.Native.Execute.LBS - --- library -import Control.Monad.State ( gets ) -import Control.Monad.Trans ( liftIO ) -import Data.ByteString.Short ( ShortByteString ) -import Data.List ( find ) -import Data.Maybe ( fromMaybe ) -import Data.Time.Clock ( getCurrentTime, diffUTCTime ) -import Data.Word ( Word8 ) -import Text.Printf ( printf ) -import Prelude hiding ( map, sum, scanl, scanr, init ) -import qualified Data.ByteString.Short.Char8 as S8 - -import Foreign.C -import Foreign.LibFFI -import Foreign.Ptr - - --- Array expression evaluation --- --------------------------- - --- Computations are evaluated by traversing the AST bottom up, and for each node --- distinguishing between three cases: --- --- 1. If it is a Use node, we return a reference to the array data. Even though --- we execute with multiple cores, we assume a shared memory multiprocessor --- machine. --- --- 2. If it is a non-skeleton node, such as a let binding or shape conversion, --- then execute directly by updating the environment or similar. --- --- 3. If it is a skeleton node, then we need to execute the generated LLVM --- code. --- -instance Execute Native where - map = simpleOp - generate = simpleOp - transform = simpleOp - backpermute = simpleOp - fold = foldOp - fold1 = fold1Op - foldSeg = foldSegOp - fold1Seg = foldSegOp - scanl = scanOp - scanl1 = scan1Op - scanl' = scan'Op - scanr = scanOp - scanr1 = scan1Op - scanr' = scan'Op - permute = permuteOp - stencil1 = simpleOp - stencil2 = stencil2Op - aforeign = aforeignOp - - --- Skeleton implementation --- ----------------------- - --- Simple kernels just needs to know the shape of the output array. --- -simpleOp - :: (Shape sh, Elt e) - => ExecutableR Native - -> Gamma aenv - -> Aval aenv - -> Stream - -> sh - -> LLVM Native (Array sh e) -simpleOp exe gamma aenv () sh = withExecutable exe $ \nativeExecutable -> do - let fun = case functionTable nativeExecutable of - f:_ -> f - _ -> $internalError "simpleOp" "no functions found" - -- - Native{..} <- gets llvmTarget - liftIO $ do - out <- allocateArray sh - executeOp defaultLargePPT fillP fun gamma aenv (IE 0 (size sh)) out - return out - -simpleNamed - :: (Shape sh, Elt e) - => ShortByteString - -> ExecutableR Native - -> Gamma aenv - -> Aval aenv - -> Stream - -> sh - -> LLVM Native (Array sh e) -simpleNamed name exe gamma aenv () sh = withExecutable exe $ \nativeExecutable -> do - Native{..} <- gets llvmTarget - liftIO $ do - out <- allocateArray sh - executeOp defaultLargePPT fillP (nativeExecutable !# name) gamma aenv (IE 0 (size sh)) out - return out - - --- Note: [Reductions] --- --- There are two flavours of reduction: --- --- 1. If we are collapsing to a single value, then threads reduce strips of --- the input in parallel, and then a single thread reduces the partial --- reductions to a single value. Load balancing occurs over the input --- stripes. --- --- 2. If this is a multidimensional reduction, then each inner dimension is --- handled by a single thread. Load balancing occurs over the outer --- dimension indices. --- --- The entry points to executing the reduction are 'foldOp' and 'fold1Op', for --- exclusive and inclusive reductions respectively. These functions handle --- whether the input array is empty. If the input and output arrays are --- non-empty, we then further dispatch (via 'foldCore') to 'foldAllOp' or --- 'foldDimOp' for single or multidimensional reductions, respectively. --- 'foldAllOp' in particular must execute specially whether the gang has --- multiple worker threads which can process the array in parallel. --- - -fold1Op - :: (Shape sh, Elt e) - => ExecutableR Native - -> Gamma aenv - -> Aval aenv - -> Stream - -> (sh :. Int) - -> LLVM Native (Array sh e) -fold1Op kernel gamma aenv stream sh@(sx :. sz) - = $boundsCheck "fold1" "empty array" (sz > 0) - $ case size sh of - 0 -> liftIO $ allocateArray sx -- empty, but possibly with non-zero dimensions - _ -> foldCore kernel gamma aenv stream sh - -foldOp - :: (Shape sh, Elt e) - => ExecutableR Native - -> Gamma aenv - -> Aval aenv - -> Stream - -> (sh :. Int) - -> LLVM Native (Array sh e) -foldOp kernel gamma aenv stream sh@(sx :. _) = - case size sh of - 0 -> simpleNamed "generate" kernel gamma aenv stream sx - _ -> foldCore kernel gamma aenv stream sh - -foldCore - :: (Shape sh, Elt e) - => ExecutableR Native - -> Gamma aenv - -> Aval aenv - -> Stream - -> (sh :. Int) - -> LLVM Native (Array sh e) -foldCore kernel gamma aenv stream sh - | Just Refl <- matchShapeType sh (undefined::DIM1) - = foldAllOp kernel gamma aenv stream sh - -- - | otherwise - = foldDimOp kernel gamma aenv stream sh - -foldAllOp - :: forall aenv e. Elt e - => ExecutableR Native - -> Gamma aenv - -> Aval aenv - -> Stream - -> DIM1 - -> LLVM Native (Scalar e) -foldAllOp exe gamma aenv () (Z :. sz) = withExecutable exe $ \nativeExecutable -> do - Native{..} <- gets llvmTarget - let - ncpu = gangSize - stride = defaultLargePPT `min` ((sz + ncpu - 1) `quot` ncpu) - steps = (sz + stride - 1) `quot` stride - -- - if ncpu == 1 || sz <= defaultLargePPT - then liftIO $ do - -- Sequential reduction - out <- allocateArray Z - executeOp 1 fillS (nativeExecutable !# "foldAllS") gamma aenv (IE 0 sz) out - return out - - else liftIO $ do - -- Parallel reduction - out <- allocateArray Z - tmp <- allocateArray (Z :. steps) :: IO (Vector e) - executeOp 1 fillP (nativeExecutable !# "foldAllP1") gamma aenv (IE 0 steps) (sz, stride, tmp) - executeOp 1 fillS (nativeExecutable !# "foldAllP2") gamma aenv (IE 0 steps) (tmp, out) - return out - -foldDimOp - :: (Shape sh, Elt e) - => ExecutableR Native - -> Gamma aenv - -> Aval aenv - -> Stream - -> (sh :. Int) - -> LLVM Native (Array sh e) -foldDimOp exe gamma aenv () (sh :. sz) = withExecutable exe $ \nativeExecutable -> do - Native{..} <- gets llvmTarget - let ppt = defaultSmallPPT `max` (defaultLargePPT `quot` (max 1 sz)) - liftIO $ do - out <- allocateArray sh - executeOp ppt fillP (nativeExecutable !# "fold") gamma aenv (IE 0 (size sh)) (sz, out) - return out - -foldSegOp - :: (Shape sh, Elt e) - => ExecutableR Native - -> Gamma aenv - -> Aval aenv - -> Stream - -> (sh :. Int) - -> (Z :. Int) - -> LLVM Native (Array (sh :. Int) e) -foldSegOp exe gamma aenv () (sh :. _) (Z :. ss) = withExecutable exe $ \nativeExecutable -> do - Native{..} <- gets llvmTarget - let - kernel | segmentOffset = "foldSegP" - | otherwise = "foldSegS" - n | segmentOffset = ss - 1 -- segments array has been 'scanl (+) 0'`ed - | otherwise = ss - ppt | rank sh == 0 = defaultLargePPT -- work-steal over the single dimension - | otherwise = n -- a thread computes all segments along an index - -- - liftIO $ do - out <- allocateArray (sh :. n) - executeOp ppt fillP (nativeExecutable !# kernel) gamma aenv (IE 0 (size (sh :. n))) out - return out - - -scanOp - :: (Shape sh, Elt e) - => ExecutableR Native - -> Gamma aenv - -> Aval aenv - -> Stream - -> sh :. Int - -> LLVM Native (Array (sh:.Int) e) -scanOp kernel gamma aenv stream (sz :. n) = - case n of - 0 -> simpleNamed "generate" kernel gamma aenv stream (sz :. 1) - _ -> scanCore kernel gamma aenv stream sz n (n+1) - -scan1Op - :: (Shape sh, Elt e) - => ExecutableR Native - -> Gamma aenv - -> Aval aenv - -> Stream - -> sh :. Int - -> LLVM Native (Array (sh:.Int) e) -scan1Op kernel gamma aenv stream (sz :. n) - = $boundsCheck "scan1" "empty array" (n > 0) - $ scanCore kernel gamma aenv stream sz n n - -scanCore - :: forall aenv sh e. (Shape sh, Elt e) - => ExecutableR Native - -> Gamma aenv - -> Aval aenv - -> Stream - -> sh - -> Int - -> Int - -> LLVM Native (Array (sh:.Int) e) -scanCore exe gamma aenv () sz n m = withExecutable exe $ \nativeExecutable -> do - Native{..} <- gets llvmTarget - let - ncpu = gangSize - stride = defaultLargePPT `min` ((n + ncpu - 1) `quot` ncpu) - steps = (n + stride - 1) `quot` stride - steps' = steps - 1 - -- - if ncpu == 1 || rank sz > 0 || n <= 2 * defaultLargePPT - then liftIO $ do - -- Either: - -- - -- 1. Sequential scan of an array of any rank - -- - -- 2. Parallel scan of multidimensional array: threads scan along the - -- length of the innermost dimension. Threads are scheduled over the - -- inner dimensions. - -- - -- 3. Small 1D array. Since parallel scan requires ~4n data transfer - -- compared to ~2n in the sequential case, it is only worthwhile if - -- the extra cores can offset the increased bandwidth requirements. - -- - out <- allocateArray (sz :. m) - executeOp 1 fillP (nativeExecutable !# "scanS") gamma aenv (IE 0 (size sz)) out - return out - - else liftIO $ do - -- parallel one-dimensional scan - out <- allocateArray (sz :. m) - tmp <- allocateArray (Z :. steps) :: IO (Vector e) - executeOp 1 fillP (nativeExecutable !# "scanP1") gamma aenv (IE 0 steps) (stride, steps', out, tmp) - executeOp 1 fillS (nativeExecutable !# "scanP2") gamma aenv (IE 0 steps) tmp - executeOp 1 fillP (nativeExecutable !# "scanP3") gamma aenv (IE 0 steps') (stride, out, tmp) - return out - - -scan'Op - :: forall aenv sh e. (Shape sh, Elt e) - => ExecutableR Native - -> Gamma aenv - -> Aval aenv - -> Stream - -> sh :. Int - -> LLVM Native (Array (sh:.Int) e, Array sh e) -scan'Op native gamma aenv stream sh@(sz :. n) = - case n of - 0 -> do - out <- liftIO $ allocateArray (sz :. 0) - sum <- simpleNamed "generate" native gamma aenv stream sz - return (out, sum) - -- - _ -> scan'Core native gamma aenv stream sh - -scan'Core - :: forall aenv sh e. (Shape sh, Elt e) - => ExecutableR Native - -> Gamma aenv - -> Aval aenv - -> Stream - -> sh :. Int - -> LLVM Native (Array (sh:.Int) e, Array sh e) -scan'Core exe gamma aenv () sh@(sz :. n) = withExecutable exe $ \nativeExecutable -> do - Native{..} <- gets llvmTarget - let - ncpu = gangSize - stride = defaultLargePPT `min` ((n + ncpu - 1) `quot` ncpu) - steps = (n + stride - 1) `quot` stride - steps' = steps - 1 - -- - if ncpu == 1 || rank sz > 0 || n <= 2 * defaultLargePPT - then liftIO $ do - out <- allocateArray sh - sum <- allocateArray sz - executeOp 1 fillP (nativeExecutable !# "scanS") gamma aenv (IE 0 (size sz)) (out,sum) - return (out,sum) - - else liftIO $ do - tmp <- allocateArray (Z :. steps) :: IO (Vector e) - out <- allocateArray sh - sum <- allocateArray sz - executeOp 1 fillP (nativeExecutable !# "scanP1") gamma aenv (IE 0 steps) (stride, steps', out, tmp) - executeOp 1 fillS (nativeExecutable !# "scanP2") gamma aenv (IE 0 steps) (sum, tmp) - executeOp 1 fillP (nativeExecutable !# "scanP3") gamma aenv (IE 0 steps') (stride, out, tmp) - return (out,sum) - - --- Forward permutation, specified by an indexing mapping into an array and a --- combination function to combine elements. --- -permuteOp - :: (Shape sh, Shape sh', Elt e) - => ExecutableR Native - -> Gamma aenv - -> Aval aenv - -> Stream - -> Bool - -> sh - -> Array sh' e - -> LLVM Native (Array sh' e) -permuteOp exe gamma aenv () inplace shIn dfs = withExecutable exe $ \nativeExecutable -> do - Native{..} <- gets llvmTarget - out <- if inplace - then return dfs - else cloneArray dfs - let - ncpu = gangSize - n = size shIn - m = size (shape out) - -- - if ncpu == 1 || n <= defaultLargePPT - then liftIO $ do - -- sequential permutation - executeOp 1 fillS (nativeExecutable !# "permuteS") gamma aenv (IE 0 n) out - - else liftIO $ do - -- parallel permutation - case lookupFunction "permuteP_rmw" nativeExecutable of - Just f -> executeOp defaultLargePPT fillP f gamma aenv (IE 0 n) out - Nothing -> do - barrier@(Array _ adb) <- allocateArray (Z :. m) :: IO (Vector Word8) - memset (ptrsOfArrayData adb) 0 m - executeOp defaultLargePPT fillP (nativeExecutable !# "permuteP_mutex") gamma aenv (IE 0 n) (out, barrier) - - return out - - -stencil2Op - :: (Shape sh, Elt e) - => ExecutableR Native - -> Gamma aenv - -> Aval aenv - -> Stream - -> sh - -> sh - -> LLVM Native (Array sh e) -stencil2Op kernel gamma aenv stream sh1 sh2 = - simpleOp kernel gamma aenv stream (sh1 `intersect` sh2) - - -aforeignOp - :: (Arrays as, Arrays bs) - => String - -> (Stream -> as -> LLVM Native bs) - -> Stream - -> as - -> LLVM Native bs -aforeignOp name asm stream arr = do - wallBegin <- liftIO $ getCurrentTime - result <- Debug.timed Debug.dump_exec (\wall cpu -> printf "exec: %s %s" name (Debug.elapsedP wall cpu)) (asm stream arr) - wallEnd <- liftIO $ getCurrentTime - liftIO $ Debug.addProcessorTime Debug.Native (realToFrac (diffUTCTime wallEnd wallBegin)) - return result - - --- Skeleton execution --- ------------------ - -(!#) :: FunctionTable -> ShortByteString -> Function -(!#) exe name - = fromMaybe ($internalError "lookupFunction" ("function not found: " ++ S8.unpack name)) - $ lookupFunction name exe - -lookupFunction :: ShortByteString -> FunctionTable -> Maybe Function -lookupFunction name nativeExecutable = do - find (\(n,_) -> n == name) (functionTable nativeExecutable) - --- Execute the given function distributed over the available threads. --- -executeOp - :: Marshalable args - => Int - -> Executable - -> Function - -> Gamma aenv - -> Aval aenv - -> Range - -> args - -> IO () -executeOp ppt exe (name, f) gamma aenv r args = do - args' <- marshal (undefined::Native) () (args, (gamma, aenv)) - -- - runExecutable exe name ppt r $ \start end _tid -> do - monitorProcTime $ - callFFI f retVoid (argInt start : argInt end : args') - - --- Standard C functions --- -------------------- - -memset :: Ptr Word8 -> Word8 -> Int -> IO () -memset p w s = c_memset p (fromIntegral w) (fromIntegral s) >> return () - -foreign import ccall unsafe "string.h memset" c_memset - :: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8) - - --- Debugging --- --------- - -monitorProcTime :: IO a -> IO a -monitorProcTime = Debug.withProcessor Debug.Native +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Execute +-- 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.Execute ( + + executeAcc, + executeOpenAcc + +) where + +import Data.Array.Accelerate.Analysis.Match +import Data.Array.Accelerate.Array.Unique +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Lifetime +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Shape +import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Type + +import Data.Array.Accelerate.LLVM.Execute +import Data.Array.Accelerate.LLVM.Execute.Async (FutureArraysR) +import Data.Array.Accelerate.LLVM.State + +import Data.Array.Accelerate.LLVM.Native.Array.Data +import Data.Array.Accelerate.LLVM.Native.Execute.Async +import Data.Array.Accelerate.LLVM.Native.Execute.Divide +import Data.Array.Accelerate.LLVM.Native.Execute.Environment ( Val ) +import Data.Array.Accelerate.LLVM.Native.Execute.Marshal +import Data.Array.Accelerate.LLVM.Native.Execute.Scheduler +import Data.Array.Accelerate.LLVM.Native.Link +import Data.Array.Accelerate.LLVM.Native.Target +import qualified Data.Array.Accelerate.LLVM.Native.Debug as Debug + +import Control.Concurrent ( myThreadId ) +import Control.Monad.State ( gets ) +import Control.Monad.Trans ( liftIO ) +import Data.ByteString.Short ( ShortByteString ) +import Data.IORef ( newIORef, readIORef, writeIORef ) +import Data.List ( find ) +import Data.Maybe ( fromMaybe ) +import Data.Sequence ( Seq ) +import Data.Foldable ( asum ) +import System.CPUTime ( getCPUTime ) +import Text.Printf ( printf ) +import qualified Data.ByteString.Short.Char8 as S8 +import qualified Data.Sequence as Seq +import qualified Data.DList as DL +import Prelude hiding ( map, sum, scanl, scanr, init ) + +import Foreign.LibFFI +import Foreign.Ptr + +{-# SPECIALISE INLINE executeAcc :: ExecAcc Native a -> Par Native (FutureArraysR Native a) #-} +{-# SPECIALISE INLINE executeOpenAcc :: ExecOpenAcc Native aenv a -> Val aenv -> Par Native (FutureArraysR Native a) #-} + +-- Array expression evaluation +-- --------------------------- + +-- Computations are evaluated by traversing the AST bottom up, and for each node +-- distinguishing between three cases: +-- +-- 1. If it is a Use node, we return a reference to the array data. Even though +-- we execute with multiple cores, we assume a shared memory multiprocessor +-- machine. +-- +-- 2. If it is a non-skeleton node, such as a let binding or shape conversion, +-- then execute directly by updating the environment or similar. +-- +-- 3. If it is a skeleton node, then we need to execute the generated LLVM +-- code. +-- +instance Execute Native where + {-# INLINE map #-} + {-# INLINE generate #-} + {-# INLINE transform #-} + {-# INLINE backpermute #-} + {-# INLINE fold #-} + {-# INLINE foldSeg #-} + {-# INLINE scan #-} + {-# INLINE scan' #-} + {-# INLINE permute #-} + {-# INLINE stencil1 #-} + {-# INLINE stencil2 #-} + {-# INLINE aforeign #-} + map = mapOp + generate = generateOp + transform = transformOp + backpermute = backpermuteOp + fold True = foldOp + fold False = fold1Op + foldSeg i _ = foldSegOp i + scan _ True = scanOp + scan _ False = scan1Op + scan' _ = scan'Op + permute = permuteOp + stencil1 = stencil1Op + stencil2 = stencil2Op + aforeign = aforeignOp + + +-- Skeleton implementation +-- ----------------------- + +-- Simple kernels just needs to know the shape of the output array. +-- +{-# INLINE simpleOp #-} +simpleOp + :: HasCallStack + => ShortByteString + -> ArrayR (Array sh e) + -> ExecutableR Native + -> Gamma aenv + -> Val aenv + -> sh + -> Par Native (Future (Array sh e)) +simpleOp name repr NativeR{..} gamma aenv sh = do + let fun = nativeExecutable !# name + param = TupRsingle $ ParamRarray repr + Native{..} <- gets llvmTarget + future <- new + result <- allocateRemote repr sh + scheduleOp fun gamma aenv (arrayRshape repr) sh param result + `andThen` do putIO workers future result + touchLifetime nativeExecutable -- XXX: must not unload the object code early + return future + +-- Mapping over an array can ignore the dimensionality of the array and +-- treat it as its underlying linear representation. +-- +{-# INLINE mapOp #-} +mapOp + :: HasCallStack + => Maybe (a :~: b) + -> ArrayR (Array sh a) + -> TypeR b + -> ExecutableR Native + -> Gamma aenv + -> Val aenv + -> Array sh a + -> Par Native (Future (Array sh b)) +mapOp inplace repr tp NativeR{..} gamma aenv input = do + let fun = nativeExecutable !# "map" + sh = shape input + shr = arrayRshape repr + repr' = ArrayR shr tp + param = TupRsingle (ParamRarray repr') `TupRpair` TupRsingle (ParamRarray repr) + Native{..} <- gets llvmTarget + future <- new + result <- case inplace of + Just Refl -> return input + Nothing -> allocateRemote repr' sh + scheduleOp fun gamma aenv dim1 ((), size shr sh) param (result, input) + `andThen` do putIO workers future result + touchLifetime nativeExecutable + return future + +{-# INLINE generateOp #-} +generateOp + :: HasCallStack + => ArrayR (Array sh e) + -> ExecutableR Native + -> Gamma aenv + -> Val aenv + -> sh + -> Par Native (Future (Array sh e)) +generateOp = simpleOp "generate" + +{-# INLINE transformOp #-} +transformOp + :: HasCallStack + => ArrayR (Array sh a) + -> ArrayR (Array sh' b) + -> ExecutableR Native + -> Gamma aenv + -> Val aenv + -> sh' + -> Array sh a + -> Par Native (Future (Array sh' b)) +transformOp repr repr' NativeR{..} gamma aenv sh' input = do + let fun = nativeExecutable !# "transform" + Native{..} <- gets llvmTarget + future <- new + result <- allocateRemote repr' sh' + let param = TupRsingle (ParamRarray repr') `TupRpair` TupRsingle (ParamRarray repr) + scheduleOp fun gamma aenv (arrayRshape repr') sh' param (result, input) + `andThen` do putIO workers future result + touchLifetime nativeExecutable + return future + +{-# INLINE backpermuteOp #-} +backpermuteOp + :: HasCallStack + => ArrayR (Array sh e) + -> ShapeR sh' + -> ExecutableR Native + -> Gamma aenv + -> Val aenv + -> sh' + -> Array sh e + -> Par Native (Future (Array sh' e)) +backpermuteOp (ArrayR shr tp) shr' = transformOp (ArrayR shr tp) (ArrayR shr' tp) + +-- Note: [Reductions] +-- +-- There are two flavours of reduction: +-- +-- 1. If we are collapsing to a single value, then threads reduce strips of +-- the input in parallel, and then a single thread reduces the partial +-- reductions to a single value. Load balancing occurs over the input +-- stripes. +-- +-- 2. If this is a multidimensional reduction, then each inner dimension is +-- handled by a single thread. Load balancing occurs over the outer +-- dimension indices. +-- +-- The entry points to executing the reduction are 'foldOp' and 'fold1Op', for +-- exclusive and inclusive reductions respectively. These functions handle +-- whether the input array is empty. If the input and output arrays are +-- non-empty, we then further dispatch (via 'foldCore') to 'foldAllOp' or +-- 'foldDimOp' for single or multidimensional reductions, respectively. +-- 'foldAllOp' in particular behaves differently whether we are evaluating the +-- array in parallel or sequentially. +-- + +{-# INLINE fold1Op #-} +fold1Op + :: HasCallStack + => ArrayR (Array sh e) + -> ExecutableR Native + -> Gamma aenv + -> Val aenv + -> Delayed (Array (sh, Int) e) + -> Par Native (Future (Array sh e)) +fold1Op repr exe gamma aenv arr@(delayedShape -> sh@(sx, sz)) + = boundsCheck "empty array" (sz > 0) + $ case size (ShapeRsnoc $ arrayRshape repr) sh of + 0 -> newFull =<< allocateRemote repr sx -- empty, but possibly with non-zero dimensions + _ -> foldCore repr exe gamma aenv arr + +{-# INLINE foldOp #-} +foldOp + :: HasCallStack + => ArrayR (Array sh e) + -> ExecutableR Native + -> Gamma aenv + -> Val aenv + -> Delayed (Array (sh, Int) e) + -> Par Native (Future (Array sh e)) +foldOp repr exe gamma aenv arr@(delayedShape -> sh@(sx, _)) = + case size (ShapeRsnoc $ arrayRshape repr) sh of + 0 -> generateOp repr exe gamma aenv sx + _ -> foldCore repr exe gamma aenv arr + +{-# INLINE foldCore #-} +foldCore + :: HasCallStack + => ArrayR (Array sh e) + -> ExecutableR Native + -> Gamma aenv + -> Val aenv + -> Delayed (Array (sh, Int) e) + -> Par Native (Future (Array sh e)) +foldCore repr exe gamma aenv arr + | ArrayR ShapeRz tp <- repr + = foldAllOp tp exe gamma aenv arr + -- + | otherwise + = foldDimOp repr exe gamma aenv arr + +{-# INLINE foldAllOp #-} +foldAllOp + :: HasCallStack + => TypeR e + -> ExecutableR Native + -> Gamma aenv + -> Val aenv + -> Delayed (Vector e) + -> Par Native (Future (Scalar e)) +foldAllOp tp NativeR{..} gamma aenv arr = do + Native{..} <- gets llvmTarget + future <- new + result <- allocateRemote (ArrayR dim0 tp) () + let + minsize = 4096 + splits = numWorkers workers + ranges = divideWork1 splits minsize ((), 0) sh (,,) + steps = Seq.length ranges + sh = delayedShape arr + -- + if steps <= 1 + then + let param = TupRsingle (ParamRarray $ ArrayR dim0 tp) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray $ ArrayR dim1 tp) + in scheduleOpUsing ranges (nativeExecutable !# "foldAllS") gamma aenv dim1 param (result, manifest arr) + `andThen` do putIO workers future result + touchLifetime nativeExecutable + + else do + let param1 = TupRsingle (ParamRarray $ ArrayR dim1 tp) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray $ ArrayR dim1 tp) + let param2 = TupRsingle (ParamRarray $ ArrayR dim1 tp) `TupRpair` TupRsingle (ParamRarray $ ArrayR dim0 tp) + tmp <- allocateRemote (ArrayR dim1 tp) ((), steps) + job2 <- mkJobUsing (Seq.singleton (0, ((), 0), ((), steps))) (nativeExecutable !# "foldAllP2") gamma aenv dim1 param2 (tmp, result) + `andThen` do putIO workers future result + touchLifetime nativeExecutable + + job1 <- mkJobUsingIndex ranges (nativeExecutable !# "foldAllP1") gamma aenv dim1 param1 (tmp, manifest arr) + `andThen` do schedule workers job2 + + liftIO $ schedule workers job1 + -- + return future + + +{-# INLINE foldDimOp #-} +foldDimOp + :: HasCallStack + => ArrayR (Array sh e) + -> ExecutableR Native + -> Gamma aenv + -> Val aenv + -> Delayed (Array (sh, Int) e) + -> Par Native (Future (Array sh e)) +foldDimOp repr NativeR{..} gamma aenv arr@(delayedShape -> (sh, _)) = do + Native{..} <- gets llvmTarget + future <- new + result <- allocateRemote repr sh + let + ArrayR shr tp = repr + fun = nativeExecutable !# "fold" + splits = numWorkers workers + minsize = 1 + param = TupRsingle (ParamRarray repr) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray $ ArrayR (ShapeRsnoc shr) tp) + -- + scheduleOpWith splits minsize fun gamma aenv shr sh param (result, manifest arr) + `andThen` do putIO workers future result + touchLifetime nativeExecutable + return future + + +{-# INLINE foldSegOp #-} +foldSegOp + :: HasCallStack + => IntegralType i + -> ArrayR (Array (sh, Int) e) + -> ExecutableR Native + -> Gamma aenv + -> Val aenv + -> 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 + future <- new + let + n = ss-1 + splits = numWorkers workers + minsize = 1 + shR = arrayRshape repr + segR = ArrayR dim1 $ TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType int + param = TupRsingle (ParamRarray repr) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray segR) + -- + result <- allocateRemote repr (sh, n) + scheduleOpWith splits minsize (nativeExecutable !# "foldSegP") gamma aenv shR (sh, n) param ((result, manifest input), manifest segments) + `andThen` do putIO workers future result + touchLifetime nativeExecutable + + return future + + +{-# INLINE scanOp #-} +scanOp + :: HasCallStack + => ArrayR (Array (sh, Int) e) + -> ExecutableR Native + -> Gamma aenv + -> Val aenv + -> Delayed (Array (sh, Int) e) + -> Par Native (Future (Array (sh, Int) e)) +scanOp repr exe gamma aenv arr@(delayedShape -> (sz, n)) = + case n of + 0 -> generateOp repr exe gamma aenv (sz, 1) + _ -> scanCore repr exe gamma aenv (n+1) arr + +{-# INLINE scan1Op #-} +scan1Op + :: HasCallStack + => ArrayR (Array (sh, Int) e) + -> ExecutableR Native + -> Gamma aenv + -> 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 + +{-# INLINE scanCore #-} +scanCore + :: HasCallStack + => ArrayR (Array (sh, Int) e) + -> ExecutableR Native + -> Gamma aenv + -> Val aenv + -> Int -- output size of innermost dimension + -> 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 + future <- new + result <- allocateRemote repr (sz, m) + -- + let paramA = TupRsingle $ ParamRarray repr + param = paramA `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr) + shR = arrayRshape (reduceRank repr) + + if isMultiDim $ arrayRshape repr + -- This is a multidimensional scan. Each partial scan result is evaluated + -- individually by a thread, so no inter-thread communication is required. + then + let + fun = nativeExecutable !# "scanS" + splits = numWorkers workers + minsize = 1 + in + scheduleOpWith splits minsize fun gamma aenv shR sz param (result, manifest input) + `andThen` do putIO workers future result + touchLifetime nativeExecutable + + -- This is a one-dimensional scan. If the array is small just compute it + -- sequentially using a single thread, otherwise we require multiple steps + -- to execute it in parallel. + else + if n < 8192 + -- sequential execution + then + scheduleOpUsing (Seq.singleton (0, (), ())) (nativeExecutable !# "scanS") gamma aenv dim0 param (result, manifest input) + `andThen` do putIO workers future result + touchLifetime nativeExecutable + + -- parallel execution + else do + let + splits = numWorkers workers + minsize = 8192 + ranges = divideWork dim1 splits minsize ((), 0) ((), n) (,,) + steps = Seq.length ranges + reprTmp = ArrayR dim1 $ arrayRtype repr + paramTmp = TupRsingle $ ParamRarray reprTmp + param1 = TupRsingle ParamRint `TupRpair` paramA `TupRpair` paramTmp `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr) + param3 = TupRsingle ParamRint `TupRpair` paramA `TupRpair` paramTmp + -- + -- XXX: Should the sequential scan of the carry-in values just be + -- executed immediately as part of the finalisation action? + -- + tmp <- allocateRemote (ArrayR dim1 $ arrayRtype repr) ((), steps) + job3 <- mkJobUsingIndex ranges (nativeExecutable !# "scanP3") gamma aenv dim1 param3 ((steps, result), tmp) + `andThen` do putIO workers future result + touchLifetime nativeExecutable + job2 <- mkJobUsing (Seq.singleton (0, ((), 0), ((), steps))) (nativeExecutable !# "scanP2") gamma aenv dim1 paramTmp tmp + `andThen` schedule workers job3 + job1 <- mkJobUsingIndex ranges (nativeExecutable !# "scanP1") gamma aenv dim1 param1 (((steps, result), tmp), manifest input) + `andThen` schedule workers job2 + + liftIO $ schedule workers job1 + -- + return future + + +{-# INLINE scan'Op #-} +scan'Op + :: HasCallStack + => ArrayR (Array (sh, Int) e) + -> ExecutableR Native + -> Gamma aenv + -> Val aenv + -> Delayed (Array (sh, Int) e) + -> Par Native (Future (Array (sh, Int) e, Array sh e)) +scan'Op repr exe gamma aenv arr@(delayedShape -> (sz, n)) = do + case n of + 0 -> do + out <- allocateRemote repr (sz, 0) + sum <- generateOp (reduceRank repr) exe gamma aenv sz + future <- new + fork $ do sum' <- get sum + put future (out, sum') + return future + -- + _ -> scan'Core repr exe gamma aenv arr + +{-# INLINE scan'Core #-} +scan'Core + :: forall aenv sh e. HasCallStack + => ArrayR (Array (sh, Int) e) + -> ExecutableR Native + -> Gamma aenv + -> Val aenv + -> Delayed (Array (sh, Int) e) + -> Par Native (Future (Array (sh, Int) e, Array sh e)) +scan'Core repr NativeR{..} gamma aenv input@(delayedShape -> sh@(sz, n)) = do + let + ArrayR shR eR = repr + ShapeRsnoc shR' = shR + repr' = ArrayR shR' eR + paramA = TupRsingle $ ParamRarray repr + paramA' = TupRsingle $ ParamRarray repr' + -- + Native{..} <- gets llvmTarget + future <- new + result <- allocateRemote repr sh + sums <- allocateRemote repr' sz + -- + if isMultiDim shR + -- This is a multidimensional scan. Each partial scan result is evaluated + -- individually by a thread, so no inter-thread communication is required. + -- + then + let fun = nativeExecutable !# "scanS" + splits = numWorkers workers + minsize = 1 + param = paramA `TupRpair` paramA' `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr) + in + scheduleOpWith splits minsize fun gamma aenv shR' sz param ((result, sums), manifest input) + `andThen` do putIO workers future (result, sums) + touchLifetime nativeExecutable + + -- One dimensional scan. If the array is small just compute it sequentially + -- with a single thread, otherwise we require multiple steps to execute it + -- in parallel. + -- + else + if n < 8192 + -- sequential execution + then + let param = paramA `TupRpair` paramA' `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr) + in scheduleOpUsing (Seq.singleton (0, (), ())) (nativeExecutable !# "scanS") gamma aenv dim0 param ((result, sums), manifest input) + `andThen` do putIO workers future (result, sums) + touchLifetime nativeExecutable + + -- parallel execution + else do + let + splits = numWorkers workers + minsize = 8192 + ranges = divideWork1 splits minsize ((), 0) ((), n) (,,) + steps = Seq.length ranges + reprTmp = ArrayR dim1 eR + paramTmp = TupRsingle $ ParamRarray reprTmp + param1 = TupRsingle ParamRint `TupRpair` paramA `TupRpair` paramTmp `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr) + param2 = paramA' `TupRpair` paramTmp + param3 = TupRsingle ParamRint `TupRpair` paramA `TupRpair` paramTmp + -- + tmp <- allocateRemote reprTmp ((), steps) + job3 <- mkJobUsingIndex ranges (nativeExecutable !# "scanP3") gamma aenv dim1 param3 ((steps, result), tmp) + `andThen` do putIO workers future (result, sums) + touchLifetime nativeExecutable + job2 <- mkJobUsing (Seq.singleton (0, ((), 0), ((), steps))) (nativeExecutable !# "scanP2") gamma aenv dim1 param2 (sums, tmp) + `andThen` schedule workers job3 + job1 <- mkJobUsingIndex ranges (nativeExecutable !# "scanP1") gamma aenv dim1 param1 (((steps, result), tmp), manifest input) + `andThen` schedule workers job2 + + liftIO $ schedule workers job1 + -- + return future + +isMultiDim :: ShapeR sh -> Bool +isMultiDim (ShapeRsnoc ShapeRz) = False +isMultiDim _ = True + +-- Forward permutation, specified by an indexing mapping into an array and a +-- combination function to combine elements. +-- +{-# INLINE permuteOp #-} +permuteOp + :: forall sh e sh' aenv. HasCallStack + => Bool + -> ArrayR (Array sh e) + -> ShapeR sh' + -> ExecutableR Native + -> Gamma aenv + -> Val aenv + -> Array sh' e + -> Delayed (Array sh e) + -> Par Native (Future (Array sh' e)) +permuteOp inplace repr shr' NativeR{..} gamma aenv defaults@(shape -> shOut) input@(delayedShape -> shIn) = do + let + ArrayR shr tp = repr + repr' = ArrayR shr' tp + Native{..} <- gets 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) + let + splits = numWorkers workers + minsize = case shr of + ShapeRsnoc ShapeRz -> 4096 + ShapeRsnoc (ShapeRsnoc ShapeRz) -> 64 + _ -> 16 + ranges = divideWork shr splits minsize (empty shr) shIn (,,) + steps = Seq.length ranges + paramR = TupRsingle (ParamRarray repr') `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr) + -- + if steps <= 1 + -- sequential execution does not require handling critical sections + then + scheduleOpUsing ranges (nativeExecutable !# "permuteS") gamma aenv shr paramR (result, manifest input) + `andThen` do putIO workers future result + touchLifetime nativeExecutable + + -- parallel execution + else + case lookupFunction "permuteP_rmw" nativeExecutable of + -- using atomic operations + Just f -> + scheduleOpUsing ranges f gamma aenv shr paramR (result, manifest input) + `andThen` do putIO workers future result + touchLifetime nativeExecutable + + -- uses a temporary array of spin-locks to guard the critical section + Nothing -> do + let m = size shr' shOut + reprBarrier = ArrayR dim1 $ TupRsingle scalarTypeWord8 + paramR' = TupRsingle (ParamRarray repr') `TupRpair` TupRsingle (ParamRarray reprBarrier) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr) + -- + barrier@(Array _ adb) <- allocateRemote reprBarrier ((), m) :: Par Native (Vector Word8) + liftIO $ memset (unsafeUniqueArrayPtr adb) 0 m + scheduleOpUsing ranges (nativeExecutable !# "permuteP_mutex") gamma aenv shr paramR' ((result, barrier), manifest input) + `andThen` do putIO workers future result + touchLifetime nativeExecutable + -- + return future + + +{-# INLINE stencil1Op #-} +stencil1Op + :: HasCallStack + => TypeR a + -> ArrayR (Array sh b) + -> sh + -> ExecutableR Native + -> Gamma aenv + -> Val aenv + -> Delayed (Array sh a) + -> Par Native (Future (Array sh b)) +stencil1Op tp repr halo exe gamma aenv input@(delayedShape -> sh) = + stencilCore repr exe gamma aenv halo sh (TupRsingle $ ParamRmaybe $ ParamRarray $ ArrayR (arrayRshape repr) tp) (manifest input) + +{-# INLINE stencil2Op #-} +stencil2Op + :: forall aenv sh a b c. HasCallStack + => TypeR a + -> TypeR b + -> ArrayR (Array sh c) + -> sh + -> ExecutableR Native + -> Gamma aenv + -> Val aenv + -> Delayed (Array sh a) + -> Delayed (Array sh b) + -> Par Native (Future (Array sh c)) +stencil2Op t1 t2 repr halo exe gamma aenv input1@(delayedShape -> sh1) input2@(delayedShape -> sh2) = + stencilCore repr exe gamma aenv halo (intersect (arrayRshape repr) sh1 sh2) (param t1 `TupRpair` param t2) (manifest input1, manifest input2) + where + shr = arrayRshape repr + param :: TypeR t -> ParamsR Native (Maybe (Array sh t)) + param = TupRsingle . ParamRmaybe . ParamRarray . ArrayR shr + +{-# INLINE stencilCore #-} +stencilCore + :: forall aenv sh e params. HasCallStack + => ArrayR (Array sh e) + -> ExecutableR Native + -> Gamma aenv + -> Val aenv + -> sh -- border dimensions (i.e. index of first interior element) + -> sh -- output array size + -> ParamsR Native params + -> params + -> Par Native (Future (Array sh e)) +stencilCore repr NativeR{..} gamma aenv halo sh paramsR params = do + Native{..} <- gets llvmTarget + future <- new + result <- allocateRemote repr sh + let + shr = arrayRshape repr + inside = nativeExecutable !# "stencil_inside" + border = nativeExecutable !# "stencil_border" + + splits = numWorkers workers + minsize = case shr of + ShapeRsnoc ShapeRz -> 4096 + ShapeRsnoc (ShapeRsnoc ShapeRz) -> 64 + _ -> 16 + + ins = divideWork shr splits minsize halo (sub sh halo) (,,) + outs = asum . flip fmap (stencilBorders shr sh halo) $ \(u,v) -> divideWork shr splits minsize u v (,,) + + sub :: sh -> sh -> sh + sub a b = go shr a b + where + go :: ShapeR t -> t -> t -> t + go ShapeRz () () = () + go (ShapeRsnoc shr') (xa,xb) (ya,yb) = (go shr' xa ya, xb - yb) + + paramsR' = TupRsingle (ParamRarray repr) `TupRpair` paramsR + -- + jobsInside <- mkTasksUsing ins inside gamma aenv shr paramsR' (result, params) + jobsBorder <- mkTasksUsing outs border gamma aenv shr paramsR' (result, params) + let jobTasks = jobsInside Seq.>< jobsBorder + jobDone = Just $ do putIO workers future result + touchLifetime nativeExecutable + -- + liftIO $ schedule workers =<< timed "stencil" Job{..} + return future + +-- Compute the stencil border regions, where we may need to evaluate the +-- boundary conditions. +-- +{-# INLINE stencilBorders #-} +stencilBorders + :: forall sh. HasCallStack + => ShapeR sh + -> sh + -> sh + -> Seq (sh, sh) +stencilBorders shr sh halo = Seq.fromFunction (2 * rank shr) face + where + face :: Int -> (sh, sh) + face n = go n shr sh halo + + go :: Int -> ShapeR t -> t -> t -> (t, t) + go _ ShapeRz () () = ((), ()) + go n (ShapeRsnoc shr') (sha, sza) (shb, szb) + = let + (sha', shb') = go (n-2) shr' sha shb + (sza', szb') + | n < 0 = (0, sza) + | n == 0 = (0, szb) + | n == 1 = (sza-szb, sza) + | otherwise = (szb, sza-szb) + in + ((sha', sza'), (shb', szb')) + +{-# INLINE aforeignOp #-} +aforeignOp + :: HasCallStack + => String + -> ArraysR as + -> ArraysR bs + -> (as -> Par Native (Future bs)) + -> 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 + + +-- Skeleton execution +-- ------------------ + +(!#) :: HasCallStack => Lifetime FunctionTable -> ShortByteString -> Function +(!#) exe name + = fromMaybe (internalError ("function not found: " ++ S8.unpack name)) + $ lookupFunction name exe + +lookupFunction :: ShortByteString -> Lifetime FunctionTable -> Maybe Function +lookupFunction name nativeExecutable = do + find (\(n,_) -> n == name) (functionTable (unsafeGetValue nativeExecutable)) + +andThen :: (Maybe a -> t) -> a -> t +andThen f g = f (Just g) + +delayedShape :: Delayed (Array sh e) -> sh +delayedShape (Delayed sh) = sh +delayedShape (Manifest a) = shape a + +manifest :: Delayed (Array sh e) -> Maybe (Array sh e) +manifest (Manifest a) = Just a +manifest Delayed{} = Nothing + + +{-# INLINABLE scheduleOp #-} +scheduleOp + :: HasCallStack + => Function + -> Gamma aenv + -> Val aenv + -> ShapeR sh + -> sh + -> ParamsR Native params + -> params + -> Maybe Action + -> Par Native () +scheduleOp fun gamma aenv shr sz paramsR params done = do + Native{..} <- gets llvmTarget + let + splits = numWorkers workers + minsize = case shr of + ShapeRsnoc ShapeRz -> 4096 + ShapeRsnoc (ShapeRsnoc ShapeRz) -> 64 + _ -> 16 + -- + scheduleOpWith splits minsize fun gamma aenv shr sz paramsR params done + +-- Schedule an operation over the entire iteration space, specifying the number +-- of partitions and minimum dimension size. +-- +{-# INLINABLE scheduleOpWith #-} +scheduleOpWith + :: Int -- # subdivisions (hint) + -> Int -- minimum size of a dimension (must be a power of two) + -> Function -- function to execute + -> Gamma aenv + -> Val aenv + -> ShapeR sh + -> sh + -> ParamsR Native params + -> params + -> 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 + job <- mkJob splits minsize fun gamma aenv shr (empty shr) sz paramsR params done + liftIO $ schedule workers job + +{-# INLINABLE scheduleOpUsing #-} +scheduleOpUsing + :: Seq (Int, sh, sh) + -> Function + -> Gamma aenv + -> Val aenv + -> ShapeR sh + -> ParamsR Native params + -> params + -> Maybe Action + -> Par Native () +scheduleOpUsing ranges fun gamma aenv shr paramsR params jobDone = do + Native{..} <- gets llvmTarget + job <- mkJobUsing ranges fun gamma aenv shr paramsR params jobDone + liftIO $ schedule workers job + +{-# INLINABLE mkJob #-} +mkJob :: Int + -> Int + -> Function + -> Gamma aenv + -> Val aenv + -> ShapeR sh + -> sh + -> sh + -> ParamsR Native params + -> params + -> Maybe Action + -> Par Native Job +mkJob splits minsize fun gamma aenv shr from to paramsR params jobDone = + mkJobUsing (divideWork shr splits minsize from to (,,)) fun gamma aenv shr paramsR params jobDone + +{-# INLINABLE mkJobUsing #-} +mkJobUsing + :: Seq (Int, sh, sh) + -> Function + -> Gamma aenv + -> Val aenv + -> ShapeR sh + -> ParamsR Native params + -> params + -> Maybe Action + -> Par Native Job +mkJobUsing ranges fun@(name,_) gamma aenv shr paramsR params jobDone = do + jobTasks <- mkTasksUsing ranges fun gamma aenv shr paramsR params + liftIO $ timed name Job {..} + +{-# INLINABLE mkJobUsingIndex #-} +mkJobUsingIndex + :: Seq (Int, sh, sh) + -> Function + -> Gamma aenv + -> Val aenv + -> ShapeR sh + -> ParamsR Native params + -> params + -> Maybe Action + -> Par Native Job +mkJobUsingIndex ranges fun@(name,_) gamma aenv shr paramsR params jobDone = do + jobTasks <- mkTasksUsingIndex ranges fun gamma aenv shr paramsR params + liftIO $ timed name Job {..} + +{-# INLINABLE mkTasksUsing #-} +mkTasksUsing + :: Seq (Int, sh, sh) + -> Function + -> Gamma aenv + -> Val aenv + -> ShapeR sh + -> ParamsR Native params + -> 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) + return $ flip fmap ranges $ \(_,u,v) -> do + sched $ printf "%s (%s) -> (%s)" (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 + +{-# INLINABLE mkTasksUsingIndex #-} +mkTasksUsingIndex + :: Seq (Int, sh, sh) + -> Function + -> Gamma aenv + -> Val aenv + -> ShapeR sh + -> ParamsR Native params + -> 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) + return $ flip fmap ranges $ \(i,u,v) -> do + sched $ printf "%s (%s) -> (%s)" (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 + callFFI f retVoid $ DL.toList $ argU `DL.append` argV `DL.append` argI `DL.append` arg + + +-- Standard C functions +-- -------------------- + +memset :: Ptr Word8 -> Word8 -> Int -> IO () +memset p w s = c_memset p (fromIntegral w) (fromIntegral s) >> return () + +foreign import ccall unsafe "string.h memset" c_memset + :: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8) + + +-- Debugging +-- --------- + +-- Since the (new) thread scheduler does not operate in block-synchronous mode, +-- it is a bit more difficult to track how long an individual operation took to +-- execute as we won't know when exactly it will begin. The following method +-- (where initial timing information is recorded as the first task) should give +-- reasonable results. +-- +-- TLM: missing GC stats information (verbose mode) since we aren't using the +-- the default 'timed' helper. +-- +timed :: ShortByteString -> Job -> IO Job +timed name job = + case Debug.debuggingIsEnabled of + False -> return job + True -> do + yes <- if Debug.monitoringIsEnabled + then return True + else Debug.getFlag Debug.dump_exec + -- + if yes + then do + ref1 <- newIORef 0 + ref2 <- newIORef 0 + let start = do !wall0 <- getMonotonicTime + !cpu0 <- getCPUTime + writeIORef ref1 wall0 + writeIORef ref2 cpu0 + + end = do !cpu1 <- getCPUTime + !wall1 <- getMonotonicTime + !wall0 <- readIORef ref1 + !cpu0 <- readIORef ref2 + -- + let wallTime = wall1 - wall0 + cpuTime = fromIntegral (cpu1 - cpu0) * 1E-12 + -- + Debug.addProcessorTime Debug.Native cpuTime + Debug.traceIO Debug.dump_exec $ printf "exec: %s %s" (S8.unpack name) (Debug.elapsedP wallTime cpuTime) + -- + return $ Job { jobTasks = start Seq.<| jobTasks job + , jobDone = case jobDone job of + Nothing -> Just end + Just finished -> Just (finished >> end) + } + else + return job + +-- accelerate/cbits/clock.c +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 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,52 +1,164 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.Execute.Async --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- Copyright : [2014..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- module Data.Array.Accelerate.LLVM.Native.Execute.Async ( - Async, Stream, Event, - module Data.Array.Accelerate.LLVM.Execute.Async, + Async(..), Future(..), IVar(..), getArrays, + evalPar, putIO, ) where -- accelerate -import Data.Array.Accelerate.LLVM.Execute.Async hiding ( Async ) -import qualified Data.Array.Accelerate.LLVM.Execute.Async as A - +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.LLVM.Execute.Async +import Data.Array.Accelerate.LLVM.Native.Execute.Scheduler import Data.Array.Accelerate.LLVM.Native.Target +import Data.Array.Accelerate.LLVM.State +-- standard library +import Control.Concurrent +import Control.Monad.Cont +import Control.Monad.State +import Data.IORef +import Data.Sequence ( Seq ) +import qualified Data.Sequence as Seq -type Async a = A.AsyncR Native a -type Stream = A.StreamR Native -type Event = A.EventR Native --- The native backend does everything synchronously. +-- | Evaluate a parallel computation -- -instance A.Async Native where - type StreamR Native = () - type EventR Native = () +-- The worker threads execute the computation, while the calling thread +-- effectively sleeps waiting for the result. +-- +{-# INLINEABLE evalPar #-} +evalPar :: Par Native a -> LLVM Native a +evalPar work = do + result <- liftIO newEmptyMVar + runContT (runPar work) (liftIO . putMVar result) + liftIO $ takeMVar result - {-# INLINE fork #-} - fork = return () + -- XXX: Running the initial computation on the worker threads can lead to the + -- workers becoming blocked, possibly waiting for the result MVars to be + -- filled from previous (lazily evaluated) computations (speculation). This + -- happened for example with the code from Issue255, when extracting the + -- result at index > number of worker threads. + -- + -- liftIO $ do + -- schedule (workers native) + -- Job { jobTasks = Seq.singleton $ evalLLVM native (runContT (runPar work) (liftIO . putMVar result)) + -- , jobDone = Nothing + -- } + -- takeMVar result - {-# INLINE join #-} - join () = return () - {-# INLINE checkpoint #-} - checkpoint () = return () +-- Implementation +-- -------------- - {-# INLINE after #-} - after () () = return () +data Future a = Future {-# UNPACK #-} !(IORef (IVar a)) - {-# INLINE block #-} - block () = return () +data IVar a + = Full !a + | Blocked !(Seq (a -> IO ())) + | Empty + +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 ) + + {-# INLINE new #-} + {-# INLINE newFull #-} + new = Future <$> liftIO (newIORef Empty) + newFull v = Future <$> liftIO (newIORef (Full v)) + + {-# INLINE fork #-} + {-# INLINE spawn #-} + fork = id + spawn = id + + {-# INLINE get #-} + get (Future ref) = + callCC $ \k -> do + native <- gets llvmTarget + next <- liftIO . atomicModifyIORef' ref $ \case + Empty -> (Blocked (Seq.singleton (evalParIO native . k)), reschedule) + Blocked ks -> (Blocked (ks Seq.|> evalParIO native . k), reschedule) + Full a -> (Full a, return a) + next + + {-# INLINE put #-} + put future ref = do + Native{..} <- gets llvmTarget + liftIO (putIO workers future ref) + + {-# INLINE liftPar #-} + liftPar = Par . lift + +-- | Evaluate a continuation +-- +{-# INLINE evalParIO #-} +evalParIO :: Native -> Par Native () -> IO () +evalParIO native@Native{} work = + evalLLVM native (runContT (runPar work) return) + +-- | The value represented by a future is now available. Push any blocked +-- continuations to the worker threads. +-- +{-# INLINEABLE putIO #-} +putIO :: HasCallStack => Workers -> Future a -> a -> IO () +putIO workers (Future ref) v = do + ks <- atomicModifyIORef' ref $ \case + Empty -> (Full v, Seq.empty) + Blocked ks -> (Full v, ks) + _ -> internalError "multiple put" + -- + schedule workers Job { jobTasks = fmap ($ v) ks + , jobDone = Nothing + } + +-- | The worker threads should search for other work to execute +-- +{-# INLINE reschedule #-} +reschedule :: Par Native a +reschedule = Par $ ContT (\_ -> return ()) + + +-- reschedule :: Par Native a +-- reschedule = Par $ ContT (const loop) +-- where +-- loop :: ReaderT Schedule (LLVM Native) () +-- loop = do +-- queue <- ask +-- mwork <- liftIO $ tryPopR queue +-- case mwork of +-- Just work -> runContT (runPar work) (const loop) +-- Nothing -> liftIO yield >> loop + +-- pushL :: MVar (Seq a) -> a -> IO () +-- pushL ref a = +-- mask_ $ do +-- ma <- tryTakeMVar ref +-- case ma of +-- Nothing -> putMVar ref (Seq.singleton a) +-- Just as -> putMVar ref (a Seq.<| as) + +-- popR :: MVar (Seq a) -> IO a +-- popR ref = do +-- q <- takeMVar ref +-- case Seq.viewr q of +-- Seq.EmptyR -> popR ref -- should be impossible +-- as Seq.:> a -> putMVar ref as >> return a diff --git a/src/Data/Array/Accelerate/LLVM/Native/Execute/Divide.hs b/src/Data/Array/Accelerate/LLVM/Native/Execute/Divide.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Execute/Divide.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Execute.Divide +-- Copyright : [2018..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Execute.Divide ( + + divideWork, divideWork1 + +) where + +import Data.Array.Accelerate.Representation.Shape + +import Data.Bits +import Data.Sequence ( Seq ) +import qualified Data.Sequence as Seq +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as M + + +-- Divide the given multidimensional index range into a sequence of work pieces. +-- Splits will be made on the outermost (left-most) index preferentially, so +-- that spans are longest on the innermost dimension (because caches). +-- +-- No dimension will be made smaller than the given minimum. +-- +-- The number of subdivisions a hint (at most, it should generate a number of +-- pieces rounded up to the next power-of-two). +-- +-- Full pieces will occur first in the resulting sequence, with smaller pieces +-- at the end (suitable for work-stealing). Note that the pieces are not sorted +-- according by size, and are ordered in the resulting sequence depending only +-- on whether all dimensions are above the minimum threshold or not. The integer +-- parameter to the apply action can be used to access the chunks linearly (for +-- example, this is useful when evaluating non-commutative operations). +-- +-- {-# INLINABLE divideWork #-} +divideWork + :: ShapeR sh + -> Int -- #subdivisions (hint) + -> Int -- minimum size of a dimension (must be a power of two) + -> sh -- start index (e.g. top-left) + -> sh -- end index (e.g. bottom-right) + -> (Int -> sh -> sh -> a) -- action given start/end index range, and split number in the range [0..] + -> Seq a +divideWork ShapeRz = divideWork0 +divideWork (ShapeRsnoc ShapeRz) = divideWork1 +divideWork shr = divideWorkN shr + -- + -- It is slightly faster to use lists instead of a Sequence here (though the + -- difference is <1us on 'divideWork empty (Z:.2000) nop 8 32'). However, + -- later operations will benefit from more efficient append, etc. + +divideWork0 :: Int -> Int -> DIM0 -> DIM0 -> (Int -> DIM0 -> DIM0 -> a) -> Seq a +divideWork0 _ _ () () action = Seq.singleton (action 0 () ()) + +divideWork1 :: Int -> Int -> DIM1 -> DIM1 -> (Int -> DIM1 -> DIM1 -> a) -> Seq a +divideWork1 !pieces !minsize ((), (!from)) ((), (!to)) action = + let + split 0 !u !v !i !f !s + | v - u < minsize = (i+1, f, s Seq.|> apply i u v) + | otherwise = (i+1, f Seq.|> apply i u v, s) + -- + split !s !u !v !i0 !f0 !s0 = + case findSplitPoint1 u v minsize of + Nothing -> (i0+1, f0, s0 Seq.|> apply i0 u v) + Just (u', v') -> + let s' = unsafeShiftR s 1 + (i1,f1,s1) = split s' u v' i0 f0 s0 + (i2,f2,s2) = split s' u' v i1 f1 s1 + in + (i2, f2, s2) + + apply i u v = action i ((), u) ((), v) + (_, fs, ss) = split pieces from to 0 Seq.empty Seq.empty + in + fs Seq.>< ss + +{-# INLINE findSplitPoint1 #-} +findSplitPoint1 + :: Int + -> Int + -> Int + -> Maybe (Int, Int) +findSplitPoint1 !u !v !minsize = + let a = v - u in + if a <= minsize + then Nothing + else + let b = unsafeShiftR (a+1) 1 + c = minsize - 1 + d = (b+c) .&. complement c + in + Just (d+u, v-a+d) + + +divideWorkN :: ShapeR sh -> Int -> Int -> sh -> sh -> (Int -> sh -> sh -> a) -> Seq a +divideWorkN !shr !pieces !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 + -- being the ones at the end of the work queue to be stolen. + -- + split 0 !u !v !i !f !s + | U.any (< minsize) (U.zipWith (-) v u) = (i+1, f, s Seq.|> apply i u v) + | otherwise = (i+1, f Seq.|> apply i u v, s) + -- + split !s !u !v !i0 !f0 !s0 = + case findSplitPointN u v minsize of + Nothing -> (i0+1, f0, s0 Seq.|> apply i0 u v) + Just (u', v') -> + let s' = unsafeShiftR s 1 + (i1,f1,s1) = split s' u v' i0 f0 s0 + (i2,f2,s2) = split s' u' v i1 f1 s1 + in + (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 + in + fs Seq.>< ss + + +-- Determine if and where to split the given index range. Returns new start and +-- end indices if found. +-- +{-# INLINE findSplitPointN #-} +findSplitPointN + :: U.Vector Int -- start + -> U.Vector Int -- end + -> Int -- minimum size of a dimension (must be power of 2) + -> Maybe (U.Vector Int, U.Vector Int) +findSplitPointN !from !to !minsize = + let + mix = U.ifoldr' combine Nothing + $ U.zipWith (-) to from + + combine i v old = + if v <= minsize + then old + else case old of + Nothing -> Just (i,v) + Just (_,u) -> if v < u + then Just (i,v) + else old + in + case mix of + Nothing -> Nothing + Just (i,a) -> + let b = unsafeShiftR (a+1) 1 -- divide by 2 (rounded up) + c = minsize - 1 + d = (b+c) .&. complement c -- round up to next multiple of chunk size + e = U.unsafeIndex from i + f = U.unsafeIndex to i + -- + from' = U.modify (\mv -> M.unsafeWrite mv i (d+e)) from + to' = U.modify (\mv -> M.unsafeWrite mv i (f-a+d)) to + in + Just (from', to') + +{-# INLINE vecToShape #-} +vecToShape :: ShapeR sh -> U.Vector Int -> sh +vecToShape shr = listToShape shr . U.toList + +{-# INLINE shapeToVec #-} +shapeToVec :: ShapeR sh -> sh -> U.Vector Int +shapeToVec shr sh = U.fromListN (rank shr) (shapeToList shr sh) + 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 @@ -2,24 +2,23 @@ {-# LANGUAGE GADTs #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.Execute.Environment --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- Copyright : [2014..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- module Data.Array.Accelerate.LLVM.Native.Execute.Environment ( - Aval, aprj + module Data.Array.Accelerate.LLVM.Execute.Environment, + module Data.Array.Accelerate.LLVM.Native.Execute.Environment, ) where --- accelerate import Data.Array.Accelerate.LLVM.Native.Target import Data.Array.Accelerate.LLVM.Execute.Environment -type Aval = AvalR Native +type Val = ValR Native diff --git a/src/Data/Array/Accelerate/LLVM/Native/Execute/LBS.hs b/src/Data/Array/Accelerate/LLVM/Native/Execute/LBS.hs deleted file mode 100644 --- a/src/Data/Array/Accelerate/LLVM/Native/Execute/LBS.hs +++ /dev/null @@ -1,34 +0,0 @@ --- | --- Module : Data.Array.Accelerate.LLVM.Native.Execute.LBS --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.Native.Execute.LBS - where - --- Some default values for the profitable parallelism threshold (PPT). These are --- chosen as to reduce the frequency of deque checks. Since a deque check also --- requires returning from the foreign LLVM function back to the scheduler code, --- it is important to combine fine-grained iterations via the PPT. --- --- The large PPT is meant for operations such as @map@ and @generate@, where the --- input length equates the total number of elements to process. The small PPT --- is meant for operations such as multidimensional reduction, where each input --- index corresponds to a non-unit amount of work. --- --- These should really be dynamic values based on how long it took to execute --- the last chunk, increase or decrease the chunk size to ensure quick --- turnaround and also low scheduler overhead. --- -defaultLargePPT :: Int -defaultLargePPT = 4096 - -defaultSmallPPT :: Int -defaultSmallPPT = 64 - 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 @@ -1,108 +1,39 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -#if __GLASGOW_HASKELL__ <= 708 -{-# LANGUAGE OverlappingInstances #-} -{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} -#endif -- | -- Module : Data.Array.Accelerate.LLVM.Native.Execute.Marshal --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- Copyright : [2014..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- -module Data.Array.Accelerate.LLVM.Native.Execute.Marshal ( - - Marshalable, M.marshal - -) where +module Data.Array.Accelerate.LLVM.Native.Execute.Marshal ( module M ) + where -- accelerate -import Data.Array.Accelerate.LLVM.CodeGen.Environment ( Gamma, Idx'(..) ) -import qualified Data.Array.Accelerate.LLVM.Execute.Marshal as M +import Data.Array.Accelerate.LLVM.Execute.Marshal as M +import Data.Array.Accelerate.Array.Unique -import Data.Array.Accelerate.LLVM.Native.Array.Data -import Data.Array.Accelerate.LLVM.Native.Execute.Async -import Data.Array.Accelerate.LLVM.Native.Execute.Environment +import Data.Array.Accelerate.LLVM.Native.Execute.Async () -- instance Async Native import Data.Array.Accelerate.LLVM.Native.Target -- libraries -import Data.DList ( DList ) import qualified Data.DList as DL -import qualified Data.IntMap as IM import qualified Foreign.LibFFI as FFI - --- Instances for the Native backend --- -type Marshalable args = M.Marshalable Native args -type instance M.ArgR Native = FFI.Arg - - --- Instances for handling concrete types in this backend, namely shapes and --- array data. --- -instance M.Marshalable Native Int where - marshal' _ _ x = return $ DL.singleton (FFI.argInt x) - -instance {-# OVERLAPS #-} M.Marshalable Native (Gamma aenv, Aval aenv) where - marshal' t s (gamma, aenv) - = fmap DL.concat - $ mapM (\(_, Idx' idx) -> M.marshal' t s (sync (aprj idx aenv))) (IM.elems gamma) - where - sync (AsyncR () a) = a +instance Marshal Native where + type ArgR Native = FFI.Arg -instance ArrayElt e => M.Marshalable Native (ArrayData e) where - marshal' _ _ adata = return $ marshalR arrayElt adata - where - marshalR :: ArrayEltR e' -> ArrayData e' -> DList FFI.Arg - marshalR ArrayEltRunit _ = DL.empty - marshalR (ArrayEltRpair aeR1 aeR2) ad = - marshalR aeR1 (fstArrayData ad) `DL.append` - marshalR aeR2 (sndArrayData ad) - -- - marshalR (ArrayEltRvec2 ae) (AD_V2 ad) = marshalR ae ad - marshalR (ArrayEltRvec3 ae) (AD_V3 ad) = marshalR ae ad - marshalR (ArrayEltRvec4 ae) (AD_V4 ad) = marshalR ae ad - marshalR (ArrayEltRvec8 ae) (AD_V8 ad) = marshalR ae ad - marshalR (ArrayEltRvec16 ae) (AD_V16 ad) = marshalR ae ad - -- - marshalR ArrayEltRint ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) - marshalR ArrayEltRint8 ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) - marshalR ArrayEltRint16 ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) - marshalR ArrayEltRint32 ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) - marshalR ArrayEltRint64 ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) - marshalR ArrayEltRword ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) - marshalR ArrayEltRword8 ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) - marshalR ArrayEltRword16 ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) - marshalR ArrayEltRword32 ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) - marshalR ArrayEltRword64 ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) - marshalR ArrayEltRhalf ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) - marshalR ArrayEltRfloat ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) - marshalR ArrayEltRdouble ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) - marshalR ArrayEltRchar ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) - marshalR ArrayEltRcshort ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) - marshalR ArrayEltRcushort ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) - marshalR ArrayEltRcint ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) - marshalR ArrayEltRcuint ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) - marshalR ArrayEltRclong ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) - marshalR ArrayEltRculong ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) - marshalR ArrayEltRcllong ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) - marshalR ArrayEltRcullong ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) - marshalR ArrayEltRcchar ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) - marshalR ArrayEltRcschar ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) - marshalR ArrayEltRcuchar ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) - marshalR ArrayEltRcfloat ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) - marshalR ArrayEltRcdouble ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) - marshalR ArrayEltRbool ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalInt = FFI.argInt + 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 new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Execute/Scheduler.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UnboxedTuples #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Execute.Scheduler +-- Copyright : [2018..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Execute.Scheduler ( + + Action, Job(..), Workers, + + schedule, + hireWorkers, hireWorkersOn, retireWorkers, fireWorkers, numWorkers, + +) where + +import qualified Data.Array.Accelerate.LLVM.Native.Debug as D + +import Control.Concurrent +import Control.DeepSeq +import Control.Exception +import Control.Monad +import Data.Concurrent.Queue.MichaelScott +import Data.IORef +import Data.Int +import Data.Sequence ( Seq ) +import Text.Printf +import qualified Data.Sequence as Seq + +import GHC.Base + +#include "MachDeps.h" + + +-- An individual computation is a job consisting of a sequence of actions to be +-- executed by the worker threads in parallel. +-- +type Action = IO () + +data Task + = Work Action + | Retire + +data Job = Job + { jobTasks :: !(Seq Action) -- actions required to complete this job + , jobDone :: !(Maybe Action) -- execute after the last action is completed + } + +data Workers = Workers + { workerCount :: {-# UNPACK #-} !Int -- number of worker threads (length workerThreadIds) + , workerActive :: {-# UNPACK #-} !(IORef (MVar ())) -- fill to signal to the threads to wake up + , workerTaskQueue :: {-# UNPACK #-} !(LinkedQueue Task) -- tasks currently being executed; may be from different jobs + , workerThreadIds :: ![ThreadId] -- to send signals to / kill + , workerException :: !(MVar (Seq (ThreadId, SomeException))) -- XXX: what should we do with these? + } + + +-- Schedule a job to be executed by the worker threads. May be called +-- concurrently. +-- +{-# INLINEABLE schedule #-} +schedule :: Workers -> Job -> IO () +schedule workers Job{..} = do + -- Generate the work list. If there is a finalisation action, there is a bit + -- of extra work to do at each step. + -- + tasks <- case jobDone of + Nothing -> return $ fmap Work jobTasks + Just done -> do + -- The thread which finishes the last task runs the finalisation + -- action, so keep track of how many items have been completed. + -- + count <- newAtomic (Seq.length jobTasks) + return $ flip fmap jobTasks $ \io -> Work $ do + _result <- io + remaining <- fetchSubAtomic count -- returns old value + when (remaining == 1) done + + -- Submit the tasks to the queue to be executed by the worker threads. + -- + pushTasks workers tasks + + +-- Workers can either be executing tasks (real work), waiting for work, or +-- going into retirement (whence the thread will exit). +-- +-- So that threads don't spin endlessly on an empty queue waiting for work, +-- they will automatically sleep waiting on the signal MVar after several +-- failed retries. Note that 'readMVar' is multiple wake up, so all threads +-- will be efficiently woken up when new work is added via 'submit'. +-- +-- The MVar is stored in an IORef. When scheduling new work, we resolve the +-- old MVar by putting a value in it, and we put a new, at that moment +-- unresolved, MVar in the IORef. If the queue is empty in runWorker, then +-- we will after some attempts wait on an MVar. It is essential that we +-- first get the MVar out of the IORef, before trying to read from the +-- queue. If this would have been done the other way around, we could have +-- a race condition, where new work is pushed after we tried to dequeue +-- work and before we wait on an MVar. We then wait on the new MVar, which +-- may cause that this thread stalls forever. +-- +runWorker :: ThreadId -> IORef (MVar ()) -> LinkedQueue Task -> IO () +runWorker tid ref queue = loop 0 + where + loop :: Int16 -> IO () + loop !retries = do + -- Extract the activation MVar from the IORef, before trying to claim + -- an item from the work queue + var <- readIORef ref + req <- tryPopR queue + case req of + -- The number of retries and thread delay on failure are knobs which can + -- be tuned. Having these values too high results in busy work which + -- will detract from time spent adding new work thus reducing + -- productivity, whereas low values will reduce responsiveness and thus + -- also reduce productivity. + -- + -- TODO: Tune these values a bit + -- + Nothing -> if retries < 16 + then loop (retries+1) + else do + -- This thread will sleep, by waiting on the MVar (var) we previously + -- extracted from the IORef (ref) + -- + -- 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) + + -- blocking, wake-up when new work is available + () <- readMVar var + loop 0 + -- + Just task -> case task of + Work io -> io >> loop 0 + Retire -> message $ printf "sched: %s shutting down" (show tid) + + +-- Spawn a new worker thread for each capability +-- +hireWorkers :: IO Workers +hireWorkers = do + ncpu <- getNumCapabilities + workers <- hireWorkersOn [0 .. ncpu-1] + return workers + +-- Spawn worker threads on the specified capabilities +-- +hireWorkersOn :: [Int] -> IO Workers +hireWorkersOn caps = do + active <- newEmptyMVar + workerActive <- newIORef active + workerException <- newEmptyMVar + workerTaskQueue <- newQ + workerThreadIds <- forM caps $ \cpu -> do + tid <- mask_ $ forkOnWithUnmask cpu $ \restore -> do + tid <- myThreadId + catch + (restore $ runWorker tid workerActive workerTaskQueue) + (appendMVar workerException . (tid,)) + -- + message $ printf "sched: fork %s on capability %d" (show tid) cpu + return tid + -- + workerThreadIds `deepseq` return Workers { workerCount = length workerThreadIds, ..} + + +-- Submit a job telling every worker to retire. Currently pending tasks will be +-- completed first. +-- +retireWorkers :: Workers -> IO () +retireWorkers workers@Workers{..} = + pushTasks workers (Seq.replicate workerCount Retire) + + +-- Pushes work to the task queue +-- +-- Wakes up the worker threads if needed, by writing to the old MVar in +-- workerActive. We replace workerActive with a new, empty MVar, such that +-- we can wake them up later when we again have new work. +-- +pushTasks :: Workers -> Seq Task -> IO () +pushTasks Workers{..} tasks = do + -- Push work to the queue + mapM_ (pushL workerTaskQueue) tasks + + -- Create a new MVar, which we use in a later call to pushTasks to wake + -- up the threads, then swap the MVar in the IORef workerActive, with the + -- new MVar. + -- + -- This must be atomic, to prevent race conditions when two threads are + -- adding new work. Without the atomic, it may occur that some MVar is + -- never resolved, causing that a worker thread which waits on that MVar + -- to stall. + new <- newEmptyMVar + old <- atomicModifyIORef' workerActive (new,) + + -- Resolve the old MVar to wake up all waiting threads + putMVar old () + + +-- Kill worker threads immediately. +-- +fireWorkers :: Workers -> IO () +fireWorkers Workers{..} = + mapM_ killThread workerThreadIds + +-- Number of workers +-- +numWorkers :: Workers -> Int +numWorkers = workerCount + + +-- Utility +-- ------- + +data Atomic = Atomic !(MutableByteArray# RealWorld) + +{-# INLINE newAtomic #-} +newAtomic :: Int -> IO Atomic +newAtomic (I# n#) = IO $ \s0 -> + case SIZEOF_HSINT of { I# size# -> + case newByteArray# size# s0 of { (# s1, mba# #) -> + case writeIntArray# mba# 0# n# s1 of { s2 -> -- non-atomic is ok + (# s2, Atomic mba# #) }}} + +{-# INLINE fetchSubAtomic #-} +fetchSubAtomic :: Atomic -> IO Int +fetchSubAtomic (Atomic mba#) = IO $ \s0 -> + case fetchSubIntArray# mba# 0# 1# s0 of { (# s1, old# #) -> + (# s1, I# old# #) } + +{-# INLINE appendMVar #-} +appendMVar :: MVar (Seq a) -> a -> IO () +appendMVar mvar a = + mask_ $ do + ma <- tryTakeMVar mvar + case ma of + Nothing -> putMVar mvar (Seq.singleton a) + Just as -> putMVar mvar (as Seq.|> a) + + +-- Debug +-- ----- + +message :: String -> IO () +message = D.traceIO D.dump_sched + diff --git a/src/Data/Array/Accelerate/LLVM/Native/Foreign.hs b/src/Data/Array/Accelerate/LLVM/Native/Foreign.hs --- a/src/Data/Array/Accelerate/LLVM/Native/Foreign.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/Foreign.hs @@ -2,13 +2,14 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.Foreign --- Copyright : [2016..2017] Trevor L. McDonell +-- Copyright : [2016..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -24,16 +25,18 @@ Native(..), liftIO, module Data.Array.Accelerate.LLVM.Native.Array.Data, + module Data.Array.Accelerate.LLVM.Native.Execute.Async, ) where -import qualified Data.Array.Accelerate.Array.Sugar as S +import qualified Data.Array.Accelerate.Sugar.Foreign as S import Data.Array.Accelerate.LLVM.State import Data.Array.Accelerate.LLVM.CodeGen.Sugar import Data.Array.Accelerate.LLVM.Foreign import Data.Array.Accelerate.LLVM.Native.Array.Data +import Data.Array.Accelerate.LLVM.Native.Execute.Async import Data.Array.Accelerate.LLVM.Native.Target import Control.Monad.State @@ -41,14 +44,15 @@ instance Foreign Native where - foreignAcc _ (ff :: asm (a -> b)) - | Just (ForeignAcc _ asm :: ForeignAcc (a -> b)) <- cast ff = Just (const asm) - | otherwise = Nothing - - foreignExp _ (ff :: asm (x -> y)) - | Just (ForeignExp _ asm :: ForeignExp (x -> y)) <- cast ff = Just asm - | otherwise = Nothing + foreignAcc (ff :: asm (a -> b)) + | Just Refl <- eqT @asm @ForeignAcc + , ForeignAcc _ asm <- ff = Just asm + | otherwise = Nothing + foreignExp (ff :: asm (x -> y)) + | Just Refl <- eqT @asm @ForeignExp + , ForeignExp _ asm <- ff = Just asm + | otherwise = Nothing instance S.Foreign ForeignAcc where strForeign (ForeignAcc s _) = s @@ -63,13 +67,13 @@ -- data ForeignAcc f where ForeignAcc :: String - -> (a -> LLVM Native b) + -> (a -> Par Native (Future b)) -> ForeignAcc (a -> b) -- Foreign expressions in the Native backend. -- -- I'm not sure how useful this is; perhaps we want a way to splice in an --- arbitrary llvm-general term, which would give us access to instructions not +-- arbitrary llvm-hs term, which would give us access to instructions not -- currently encoded in Accelerate (i.e. SIMD operations, struct types, etc.) -- data ForeignExp f where 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 @@ -4,10 +4,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.Link --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -62,7 +62,7 @@ -- | Execute some operation with the supplied executable functions -- -withExecutable :: ExecutableR Native -> (FunctionTable -> LLVM Native b) -> LLVM Native b +withExecutable :: MonadIO m => ExecutableR Native -> (FunctionTable -> m b) -> m b withExecutable NativeR{..} f = do r <- f (unsafeGetValue nativeExecutable) liftIO $ touchLifetime nativeExecutable diff --git a/src/Data/Array/Accelerate/LLVM/Native/Link/COFF.hs b/src/Data/Array/Accelerate/LLVM/Native/Link/COFF.hs --- a/src/Data/Array/Accelerate/LLVM/Native/Link/COFF.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/Link/COFF.hs @@ -1,10 +1,10 @@ {-# LANGUAGE TemplateHaskell #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.Link.COFF --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- 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,9 +1,9 @@ -- | -- Module : Data.Array.Accelerate.LLVM.Native.Link.Cache --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/LLVM/Native/Link/ELF.chs b/src/Data/Array/Accelerate/LLVM/Native/Link/ELF.chs --- a/src/Data/Array/Accelerate/LLVM/Native/Link/ELF.chs +++ b/src/Data/Array/Accelerate/LLVM/Native/Link/ELF.chs @@ -2,13 +2,12 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.Link.ELF --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -39,12 +38,12 @@ import Foreign.Marshal import Foreign.Ptr import Foreign.Storable -import GHC.Prim ( addr2Int#, int2Word#, int2Addr# ) +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 System.Posix.Types ( COff(..) ) import Text.Printf import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 @@ -66,16 +65,18 @@ -- specified in the object file, and are ready to be executed on the target -- architecture. -- -loadObject :: ByteString -> IO (FunctionTable, ObjectCode) +loadObject :: HasCallStack => ByteString -> IO (FunctionTable, ObjectCode) loadObject obj = case parseObject obj of - Left err -> $internalError "loadObject" err + Left err -> internalError err Right (secs, symbols, relocs, strtab) -> do -- Load the sections into executable memory -- (funtab, oc) <- loadSegment obj strtab secs symbols relocs - -- Unmap the executable pages when they are no longer required + -- 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 @@ -83,7 +84,7 @@ case oc of Segment vmsize oc_fp -> withForeignPtr oc_fp $ \oc_p -> - munmap oc_p vmsize + mprotect oc_p vmsize ({#const PROT_READ#} .|. {#const PROT_WRITE#}) return (funtab, objectcode) @@ -102,7 +103,8 @@ -- properly. -- loadSegment - :: ByteString + :: HasCallStack + => ByteString -> ByteString -> Vector SectionHeader -> Vector Symbol @@ -144,44 +146,42 @@ vmsize' = V.last offsets -- bytes required to store all sections vmsize = pad pagesize (vmsize' + (V.length symtab * 16)) -- sections + jump tables - -- Allocate new pages to store the executable code. This is allocated in - -- the lower 2GB so that 32-bit relocations should work without needing - -- to go via the jump tables. - -- - -- The memory is implicitly initialised to zero (corresponding to NOP). - -- This also takes care of .bss sections. - -- - seg_p <- mmap vmsize - seg_fp <- newForeignPtr_ seg_p + seg_fp <- mallocPlainForeignPtrAlignedBytes vmsize pagesize + funtab <- withForeignPtr seg_fp $ \seg_p -> do - -- Jump tables are placed directly after the segment data - let jump_p = seg_p `plusPtr` vmsize' - V.imapM_ (makeJumpIsland jump_p) symtab + -- Clear the segment data; this takes care of .bss sections + fillBytes seg_p 0 vmsize - -- Copy over section data - V.izipWithM_ (loadSection obj strtab seg_p) offsets secs + -- Jump tables are placed directly after the segment data + let jump_p = seg_p `plusPtr` vmsize' + V.imapM_ (makeJumpIsland jump_p) symtab - -- Process relocations - V.mapM_ (processRelocation symtab offsets seg_p jump_p) relocs + -- Copy over section data + V.izipWithM_ (loadSection obj strtab seg_p) offsets secs - -- Mark the page as executable and read-only - mprotect seg_p vmsize ({#const PROT_READ#} .|. {#const PROT_EXEC#}) + -- Process relocations + V.mapM_ (processRelocation symtab offsets seg_p jump_p) relocs - -- 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) + -- 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) @@ -204,7 +204,7 @@ -- Load the section at the correct offset into the given segment -- -loadSection :: ByteString -> ByteString -> Ptr Word8 -> Int -> Int -> SectionHeader -> IO () +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))) @@ -220,7 +220,7 @@ -- Process local and external relocations. -- -processRelocation :: Vector Symbol -> Vector Int -> Ptr Word8 -> Ptr Word8 -> Relocation -> IO () +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) @@ -296,7 +296,7 @@ case sym_binding of Local -> castPtrToWord64 (seg_p `plusPtr` (sec_offset V.! sym_section + fromIntegral sym_value)) Global -> sym_value - Weak -> $internalError "processRelocation" "unhandled weak symbol" + Weak -> internalError "unhandled weak symbol" Symbol{..} = symtab V.! r_symbol @@ -305,7 +305,7 @@ #else precessRelocation = - $internalError "processRelocation" "not defined for non-x86_64 architectures yet" + internalError "not defined for non-x86_64 architectures yet" #endif @@ -317,12 +317,12 @@ -- -- Actually loading the sections into executable memory happens separately. -- -parseObject :: ByteString -> Either String (Vector SectionHeader, Vector Symbol, Vector Relocation, ByteString) +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) $ fail "unhandled program header(s)" + 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) @@ -592,7 +592,7 @@ readRelocations :: Peek -> ByteString -> SectionHeader -> Either String (Vector Relocation) readRelocations p@Peek{..} obj SectionHeader{..} = do - unless (sh_type == Rel || sh_type == RelA) $ fail "expected relocation section" + 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) @@ -622,7 +622,7 @@ readSymbolTable :: Peek -> Vector SectionHeader -> ByteString -> SectionHeader -> Either String (Vector Symbol) readSymbolTable p@Peek{..} secs obj SectionHeader{..} = do - unless (sh_type == SymTab) $ fail "expected symbol table" + 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. @@ -708,35 +708,22 @@ = throwErrnoIfMinus1_ "mprotect" $ c_mprotect addr (fromIntegral len) (fromIntegral prot) --- Allocate memory pages in the lower 2GB --- -mmap :: Int -> IO (Ptr Word8) -mmap len - = throwErrnoIf (== _MAP_FAILED) "mmap" - $ c_mmap nullPtr (fromIntegral len) prot flags (-1) 0 - where - prot = {#const PROT_READ#} .|. {#const PROT_WRITE#} - flags = {#const MAP_ANONYMOUS#} .|. {#const MAP_PRIVATE#} .|. {#const MAP_32BIT#} - _MAP_FAILED = Ptr (int2Addr# (-1#)) - --- Remove a memory mapping --- -munmap :: Ptr Word8 -> Int -> IO () -munmap addr len - = throwErrnoIfMinus1_ "munmap" - $ c_munmap addr (fromIntegral len) - foreign import ccall unsafe "mprotect" c_mprotect :: Ptr a -> CSize -> CInt -> IO CInt -foreign import ccall unsafe "mmap" - c_mmap :: Ptr a -> CSize -> CInt -> CInt -> CInt -> COff -> IO (Ptr a) - -foreign import ccall unsafe "munmap" - c_munmap :: Ptr a -> CSize -> 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 diff --git a/src/Data/Array/Accelerate/LLVM/Native/Link/MachO.chs b/src/Data/Array/Accelerate/LLVM/Native/Link/MachO.chs --- a/src/Data/Array/Accelerate/LLVM/Native/Link/MachO.chs +++ b/src/Data/Array/Accelerate/LLVM/Native/Link/MachO.chs @@ -5,10 +5,10 @@ {-# LANGUAGE TemplateHaskell #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.Link.MachO --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -74,17 +74,17 @@ -- specified in the object file, and are ready to be executed on the target -- architecture. -- -loadObject :: ByteString -> IO (FunctionTable, ObjectCode) +loadObject :: HasCallStack => ByteString -> IO (FunctionTable, ObjectCode) loadObject obj = case parseObject obj of - Left err -> $internalError "loadObject" err + 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 :: ByteString -> Vector Symbol -> Vector LoadSegment -> IO (FunctionTable, ObjectCode) +loadSegments :: HasCallStack => ByteString -> Vector Symbol -> Vector LoadSegment -> IO (FunctionTable, ObjectCode) loadSegments obj symtab lcs = do -- Load the segments into executable memory. -- @@ -136,7 +136,7 @@ -- be. These would need to live in different pages in order to be mprotect-ed -- properly. -- -loadSegment :: ByteString -> Vector Symbol -> LoadSegment -> IO Segment +loadSegment :: HasCallStack => ByteString -> Vector Symbol -> LoadSegment -> IO Segment loadSegment obj symtab seg@LoadSegment{..} = do let pagesize = fromIntegral c_getpagesize @@ -184,7 +184,7 @@ -- Load a section at the correct offset into the given segment, and apply -- relocations. -- -loadSection :: ByteString -> Vector Symbol -> LoadSegment -> Ptr Word8 -> Ptr Word8 -> LoadSection -> IO () +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 -- @@ -201,14 +201,14 @@ -- necessary since we load all sections into the same memory segment at the -- correct offsets. -- -processRelocation :: Vector Symbol -> LoadSegment -> Ptr Word8 -> Ptr Word8 -> LoadSection -> RelocationInfo -> IO () +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{..} +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 "processRelocation" "Global offset table relocations not handled yet" + = 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 @@ -257,11 +257,11 @@ 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 "processRelocation" "unhandled relocation size" + _ -> internalError "unhandled relocation size" #else precessRelocation = - $internalError "processRelocation" "not defined for non-x86_64 architectures yet" + internalError "not defined for non-x86_64 architectures yet" #endif @@ -718,17 +718,6 @@ 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 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,9 +1,9 @@ -- | -- Module : Data.Array.Accelerate.LLVM.Native.Link.Object --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- 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 @@ -1,11 +1,13 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.Plugin --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -16,17 +18,18 @@ ) where -import GhcPlugins -import Linker -import SysTools +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.LLVM.Native.Plugin.Annotation +import Data.Array.Accelerate.LLVM.Native.Plugin.BuildInfo import Control.Monad import Data.IORef import Data.List import qualified Data.Map as Map -import Data.Array.Accelerate.LLVM.Native.Plugin.Annotation -import Data.Array.Accelerate.LLVM.Native.Plugin.BuildInfo +import GhcPlugins +import Linker +import SysTools -- | This GHC plugin is required to support ahead-of-time compilation for the @@ -42,19 +45,19 @@ plugin :: Plugin plugin = defaultPlugin { installCoreToDos = install +#if __GLASGOW_HASKELL__ >= 806 + , pluginRecompile = purePlugin +#endif } -install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install :: HasCallStack => [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] install _ rest = do -#if __GLASGOW_HASKELL__ < 802 - reinitializeGlobals -#endif let this (CoreDoPluginPass "accelerate-llvm-native" _) = True this _ = False -- return $ CoreDoPluginPass "accelerate-llvm-native" pass : filter (not . this) rest -pass :: ModGuts -> CoreM ModGuts +pass :: HasCallStack => ModGuts -> CoreM ModGuts pass guts = do -- Determine the current build environment -- @@ -83,12 +86,10 @@ objs = map optionOfPath paths -- linkCmdLineLibs -#if __GLASGOW_HASKELL__ < 800 - $ dynFlags { ldInputs = opts ++ objs } -#else $ hscEnv { hsc_dflags = dynFlags { ldInputs = opts ++ objs }} -#endif + -- 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 @@ -99,7 +100,7 @@ -- objects required to build the entire project. -- _ -> liftIO $ do - +#if __GLASGOW_HASKELL__ < 806 -- Read the object file index and update (we may have added or removed -- objects for the given module) -- @@ -125,14 +126,10 @@ GnuGold opts -> GnuGold (nub (opts ++ allObjs)) DarwinLD opts -> DarwinLD (nub (opts ++ allObjs)) SolarisLD opts -> SolarisLD (nub (opts ++ allObjs)) -#if __GLASGOW_HASKELL__ >= 800 AixLD opts -> AixLD (nub (opts ++ allObjs)) -#endif -#if __GLASGOW_HASKELL__ >= 804 LlvmLLD opts -> LlvmLLD (nub (opts ++ allObjs)) -#endif UnknownLD -> UnknownLD -- no linking performed? - +#endif return () return guts diff --git a/src/Data/Array/Accelerate/LLVM/Native/Plugin/Annotation.hs b/src/Data/Array/Accelerate/LLVM/Native/Plugin/Annotation.hs --- a/src/Data/Array/Accelerate/LLVM/Native/Plugin/Annotation.hs +++ b/src/Data/Array/Accelerate/LLVM/Native/Plugin/Annotation.hs @@ -1,10 +1,10 @@ {-# LANGUAGE DeriveDataTypeable #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.Plugin.Annotation --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- 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 @@ -1,12 +1,11 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.Plugin.BuildInfo --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -29,7 +28,7 @@ mkBuildInfoFileName :: FilePath -> FilePath mkBuildInfoFileName path = path "accelerate-llvm-native.buildinfo" -readBuildInfo :: FilePath -> IO (Map Module [FilePath]) +readBuildInfo :: HasCallStack => FilePath -> IO (Map Module [FilePath]) readBuildInfo path = do exists <- doesFileExist path if not exists @@ -37,7 +36,7 @@ else do f <- B.readFile path case decode f of - Left err -> $internalError "readBuildInfo" err + Left err -> internalError err Right m -> return m writeBuildInfo :: FilePath -> Map Module [FilePath] -> IO () @@ -51,15 +50,9 @@ n <- get return (Module p n) -#if __GLASGOW_HASKELL__ < 800 -instance Serialize PackageKey where - put p = put (packageKeyString p) - get = stringToPackageKey <$> get -#else instance Serialize UnitId where put u = put (unitIdString u) get = stringToUnitId <$> get -#endif instance Serialize ModuleName where put m = put (moduleNameString m) 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,11 +1,10 @@ {-# LANGUAGE CPP #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.State --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- Copyright : [2014..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -15,28 +14,17 @@ evalNative, createTarget, defaultTarget, - Strategy, - balancedParIO, unbalancedParIO, - ) where -- accelerate -import Control.Parallel.Meta -import Control.Parallel.Meta.Worker -import qualified Control.Parallel.Meta.Trans.LBS as LBS -import qualified Control.Parallel.Meta.Resource.SMP as SMP -import qualified Control.Parallel.Meta.Resource.Single as Single -import qualified Control.Parallel.Meta.Resource.Backoff as Backoff - 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 -- library -import Data.ByteString.Short.Char8 ( ShortByteString, unpack ) import Data.Maybe -import Data.Monoid import System.Environment import System.IO.Unsafe import Text.Printf @@ -53,20 +41,17 @@ -- | Create a Native execution target by spawning a worker thread on each of the --- given capabilities, and using the given strategy to load balance the workers --- when executing parallel operations. +-- given capabilities. -- createTarget - :: [Int] -- ^ CPU IDs to launch worker threads on - -> Strategy -- ^ Strategy to balance parallel workloads + :: [Int] -- ^ CPUs to launch worker threads on -> IO Native -createTarget caps parallelIO = do - let size = length caps - gang <- forkGangOn caps - linker <- LC.new - return $! Native size linker (sequentialIO gang) (parallelIO gang) (size > 1) - +createTarget cpus = do + gang <- hireWorkersOn cpus + linker <- LC.new + return $! Native linker gang +{-- -- | The strategy for balancing work amongst the available worker threads. -- type Strategy = Gang -> Executable @@ -103,6 +88,7 @@ -- let resource = LBS.mkResource ppt (SMP.mkResource retries <> Backoff.mkResource) in timed name $ runParIO resource gang range fill +--} -- Top-level mutable state @@ -120,11 +106,10 @@ -- This globally shared thread gang is auto-initialised on startup and shared by -- all computations (unless the user chooses to 'run' with a different gang). -- --- In a data parallel setting, it does not help to have multiple gangs running --- at the same time. This is because a single data parallel computation should --- already be able to keep all threads busy. If we had multiple gangs running at --- the same time, then the system as a whole would run slower as the gangs --- contend for cache and thrash the scheduler. +-- It does not help to have multiple gangs running at the same time, as then the +-- system as a whole may run slower as the threads contend for cache. The +-- scheduler is able to execute operations from multiple sources concurrently, +-- so multiple gangs should not be necessary. -- {-# NOINLINE defaultTarget #-} defaultTarget :: Native @@ -144,11 +129,10 @@ setNumCapabilities (max ncaps nthreads) Debug.traceIO Debug.dump_gc (printf "gc: initialise native target with %d worker threads" nthreads) - case nthreads of - 1 -> createTarget [0] sequentialIO - n -> createTarget [0 .. n-1] (balancedParIO n) + createTarget [0 .. nthreads-1] +{-- -- Debugging -- --------- @@ -159,4 +143,5 @@ {-# INLINE elapsed #-} elapsed :: ShortByteString -> Double -> Double -> String elapsed name x y = printf "exec: %s %s" (unpack name) (Debug.elapsedP x y) +--} 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,10 +1,9 @@ -- | -- Module : Data.Array.Accelerate.LLVM.Native.Target --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- Copyright : [2014..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -16,7 +15,7 @@ ) where --- llvm-general +-- llvm-hs import LLVM.Target hiding ( Target ) import LLVM.AST.DataLayout ( DataLayout ) import qualified LLVM.Relocation as RelocationModel @@ -25,8 +24,8 @@ -- 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(..) ) -import Control.Parallel.Meta ( Executable ) -- standard library import Data.ByteString ( ByteString ) @@ -37,16 +36,13 @@ -- | Native machine code JIT execution target -- data Native = Native - { gangSize :: {-# UNPACK #-} !Int - , linkCache :: {-# UNPACK #-} !LinkCache - , fillS :: {-# UNPACK #-} !Executable - , fillP :: {-# UNPACK #-} !Executable - , segmentOffset :: !Bool + { linkCache :: !LinkCache + , workers :: !Workers } instance Target Native where - targetTriple _ = Just nativeTargetTriple - targetDataLayout _ = Just nativeDataLayout + targetTriple = Just nativeTargetTriple + targetDataLayout = Just nativeDataLayout -- | String that describes the native target @@ -90,7 +86,7 @@ nativeCPUName nativeCPUFeatures targetOptions - RelocationModel.DynamicNoPIC + RelocationModel.PIC CodeModel.Default CodeOptimisation.Default k diff --git a/test/nofib/Main.hs b/test/nofib/Main.hs --- a/test/nofib/Main.hs +++ b/test/nofib/Main.hs @@ -1,9 +1,9 @@ -- | -- Module : nofib-llvm-native --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) --