diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,31 +6,101 @@ project adheres to the [Haskell Package Versioning Policy (PVP)](https://pvp.haskell.org) +## [1.4.0.0] - ? +### Changed + * Support for LLVM-15 to 22. + * Wider platform support (including support for Apple silicon and other ARM systems) by using the system linker. + * Support for the Tracy profiler, under the tracy and debug flags. + +### Fixed + * Undefined symbols for math functions ([accelerate-llvm#104]) + +### Contributors + +Special thanks to those who contributed patches as part of this release: + + * Trevor L. McDonell (@tmcdonell) + * Tom Smeding (@tomsmeding) + * David van Balen (@dpvanbalen) + * Ivo Gabe de Wolff (@ivogabe) + * Robbert van der Helm (@robbert-vdh) + * Mirek Kratochvil (@exaexa) + * Tao He (@sighingnow) + * Patsakula Nikita (@npatsakula) + * Noah Williams (@noahmartinwilliams) + +## [1.3.0.0] - 2018-08-27 +### Changed + * Switch the thread scheduler to static, rather than dynamic, work stealing + * 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) + * 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]) + +### Added + * 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) + + ## [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 +[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 +[accelerate-llvm#104]: https://github.com/AccelerateHS/accelerate-llvm/pull/104 diff --git a/Data/Array/Accelerate/LLVM/Native.hs b/Data/Array/Accelerate/LLVM/Native.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native.hs +++ /dev/null @@ -1,440 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} --- | --- Module : Data.Array.Accelerate.LLVM.Native --- 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) --- --- This module implements a backend for the /Accelerate/ language targeting --- multicore CPUs. Expressions are on-line translated into LLVM code, which is --- just-in-time executed in parallel over the available CPUs. Functions are --- automatically parallelised over all available cores, unless you set the --- environment variable 'ACCELERATE_LLVM_NATIVE_THREADS=N', in which case 'N' --- threads will be used. --- --- Programs must be compiled with '-threaded', otherwise you will get a "Blocked --- indefinitely on MVar" error. --- - -module Data.Array.Accelerate.LLVM.Native ( - - Acc, Arrays, - - -- * Synchronous execution - run, runWith, - run1, run1With, - runN, runNWith, - stream, streamWith, - - -- * Asynchronous execution - Async, - wait, poll, cancel, - - runAsync, runAsyncWith, - run1Async, run1AsyncWith, - runNAsync, runNAsyncWith, - - -- * Ahead-of-time compilation - runQ, runQWith, - runQAsync, runQAsyncWith, - - -- * Execution targets - Native, Strategy, - createTarget, balancedParIO, unbalancedParIO, - -) where - --- accelerate -import Data.Array.Accelerate.Array.Sugar ( Arrays ) -import Data.Array.Accelerate.AST ( PreOpenAfun(..) ) -import Data.Array.Accelerate.Async -import Data.Array.Accelerate.Smart ( Acc ) -import Data.Array.Accelerate.Trafo - -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.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 -import qualified Language.Haskell.TH as TH -import qualified Language.Haskell.TH.Syntax as TH - - --- Accelerate: LLVM backend for multicore CPUs --- ------------------------------------------- - --- | Compile and run a complete embedded array program. --- --- /NOTE:/ it is recommended to use 'runN' or 'runQ' whenever possible. --- -run :: Arrays a => Acc a -> a -run = runWith defaultTarget - --- | As 'run', but execute using the specified target (thread gang). --- -runWith :: Arrays a => Native -> Acc a -> a -runWith target a = unsafePerformIO (run' target a) - - --- | As 'run', but allow the computation to run asynchronously and return --- immediately without waiting for the result. The status of the computation can --- be queried using 'wait', 'poll', and 'cancel'. --- -runAsync :: Arrays a => Acc a -> IO (Async a) -runAsync = runAsyncWith defaultTarget - --- | 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) - -run' :: Arrays a => Native -> Acc a -> IO a -run' target a = execute - where - !acc = convertAccWith (config target) 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 - - --- | This is 'runN', specialised to an array program of one argument. --- -run1 :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> b -run1 = run1With defaultTarget - --- | As 'run1', but execute using the specified target (thread gang). --- -run1With :: (Arrays a, Arrays b) => Native -> (Acc a -> Acc b) -> a -> b -run1With = runNWith - - --- | Prepare and execute an embedded array program. --- --- This function can be used to improve performance in cases where the array --- program is constant between invocations, because it enables us to bypass --- front-end conversion stages and move directly to the execution phase. If you --- have a computation applied repeatedly to different input data, use this, --- specifying any changing aspects of the computation via the input parameters. --- If the function is only evaluated once, this is equivalent to 'run'. --- --- In order to use 'runN' you must express your Accelerate program as a function --- of array terms: --- --- > f :: (Arrays a, Arrays b, ... Arrays c) => Acc a -> Acc b -> ... -> Acc c --- --- This function then returns the compiled version of 'f': --- --- > runN f :: (Arrays a, Arrays b, ... Arrays c) => a -> b -> ... -> c --- --- At an example, rather than: --- --- > step :: Acc (Vector a) -> Acc (Vector b) --- > step = ... --- > --- > simulate :: Vector a -> Vector b --- > simulate xs = run $ step (use xs) --- --- Instead write: --- --- > simulate = runN step --- --- You can use the debugging options to check whether this is working --- successfully. For example, running with the @-ddump-phases@ flag should show --- that the compilation steps only happen once, not on the second and subsequent --- invocations of 'simulate'. Note that this typically relies on GHC knowing --- that it can lift out the function returned by 'runN' and reuse it. --- --- See the programs in the 'accelerate-examples' package for examples. --- --- See also 'runQ', which compiles the Accelerate program at _Haskell_ compile --- time, thus eliminating the runtime overhead altogether. --- -runN :: Afunction f => f -> AfunctionR f -runN = runNWith defaultTarget - --- | As 'runN', but execute using the specified target (thread gang). --- -runNWith :: Afunction f => Native -> f -> AfunctionR f -runNWith target f = exec - where - !acc = convertAfunWith (config target) 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) - - --- | As 'run1', but execute asynchronously. --- -run1Async :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> IO (Async b) -run1Async = run1AsyncWith defaultTarget - --- | As 'run1Async', but execute using the specified target (thread gang). --- -run1AsyncWith :: (Arrays a, Arrays b) => Native -> (Acc a -> Acc b) -> a -> IO (Async b) -run1AsyncWith = runNAsyncWith - - --- | As 'runN', but execute asynchronously. --- -runNAsync :: (Afunction f, RunAsync r, AfunctionR 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) - where - !acc = convertAfunWith (config target) f - !afun = unsafePerformIO $ do - dumpGraph acc - evalNative target $ do - build <- phase "compile" elapsedS (compileAfun acc) >>= dumpStats - link <- phase "link" elapsedS (linkAfun build) - return link - -class RunAsync f where - type RunAsyncR f - runAsync' :: Native -> ExecOpenAfun Native aenv (RunAsyncR f) -> LLVM Native (Aval aenv) -> f - -instance RunAsync b => RunAsync (a -> b) where - type RunAsyncR (a -> b) = 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) - in runAsync' target l k' - -instance RunAsync (IO (Async b)) where - type RunAsyncR (IO (Async b)) = 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) - - --- | Stream a lazily read list of input arrays through the given program, --- collecting results as we go. --- -stream :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> [a] -> [b] -stream = streamWith defaultTarget - --- | As 'stream', but execute using the specified target (thread gang). --- -streamWith :: (Arrays a, Arrays b) => Native -> (Acc a -> Acc b) -> [a] -> [b] -streamWith target f arrs = map go arrs - where - !go = run1With target f - - --- | Ahead-of-time compilation for an embedded array program. --- --- This function will generate, compile, and link into the final executable, --- code to execute the given Accelerate computation /at Haskell compile time/. --- This eliminates any runtime overhead associated with the other @run*@ --- operations. The generated code will be optimised for the compiling --- architecture. --- --- Since the Accelerate program will be generated at Haskell compile time, --- construction of the Accelerate program, in particular via meta-programming, --- will be limited to operations available to that phase. Also note that any --- arrays which are embedded into the program via 'Data.Array.Accelerate.use' --- will be stored as part of the final executable. --- --- Usage of this function in your program is similar to that of 'runN'. First, --- express your Accelerate program as a function of array terms: --- --- > f :: (Arrays a, Arrays b, ... Arrays c) => Acc a -> Acc b -> ... -> Acc c --- --- This function then returns a compiled version of @f@ as a Template Haskell --- splice, to be added into your program at Haskell compile time: --- --- > {-# LANGUAGE TemplateHaskell #-} --- > --- > f' :: a -> b -> ... -> c --- > f' = $( runQ f ) --- --- 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:/] --- --- Due to , this --- currently must be as an /untyped/ splice. --- --- The correct type of this function is similar to that of 'runN': --- --- > runQ :: Afunction f => f -> Q (TExp (AfunctionR f)) --- --- @since 1.1.0.0 --- -runQ :: Afunction f => f -> TH.ExpQ -runQ = runQ' [| unsafePerformIO |] [| defaultTarget |] - --- | Ahead-of-time analogue of 'runNWith'. See 'runQ' for more information. --- --- The correct type of this function is: --- --- > runQWith :: Afunction f => f -> Q (TExp (Native -> AfunctionR f)) --- --- @since 1.1.0.0 --- -runQWith :: Afunction f => f -> TH.ExpQ -runQWith f = do - target <- TH.newName "target" - TH.lamE [TH.varP target] (runQ' [| unsafePerformIO |] (TH.varE target) f) - - --- | Ahead-of-time analogue of 'runNAsync'. See 'runQ' for more information. --- --- The correct type of this function is: --- --- > runQAsync :: (Afunction f, RunAsync r, AfunctionR f ~ RunAsyncR r) => f -> Q (TExp r) --- --- @since 1.1.0.0 --- -runQAsync :: Afunction f => f -> TH.ExpQ -runQAsync = runQ' [| async |] [| defaultTarget |] - --- | Ahead-of-time analogue of 'runNAsyncWith'. See 'runQ' for more information. --- --- The correct type of this function is: --- --- > runQAsyncWith :: (Afunction f, RunAsync r, AfunctionR f ~ RunAsyncR r) => f -> Q (TExp (Native -> r)) --- --- @since 1.1.0.0 --- -runQAsyncWith :: Afunction f => f -> TH.ExpQ -runQAsyncWith f = do - target <- TH.newName "target" - TH.lamE [TH.varP target] (runQ' [| async |] (TH.varE target) f) - - -runQ' :: 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 - dumpGraph acc - evalNative (defaultTarget { segmentOffset = True }) $ - phase "compile" elapsedS (compileAfun acc) >>= dumpStats - - -- generate a lambda function with the correct number of arguments and apply - -- directly to the body expression. - let - go :: Typeable aenv => CompiledOpenAfun Native aenv t -> [TH.PatQ] -> [TH.ExpQ] -> [TH.StmtQ] -> TH.ExpQ - go (Alam lam) 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) - - 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 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 - -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/Data/Array/Accelerate/LLVM/Native/Array/Data.hs b/Data/Array/Accelerate/LLVM/Native/Array/Data.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/Array/Data.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# 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) --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -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.LLVM.State -import Data.Array.Accelerate.LLVM.Array.Data -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 - - --- | 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 - return out - where - sh = shape arr - n = size 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 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 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 - - 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)) - - --- Standard C functions --- -------------------- - -memcpy :: Ptr Word8 -> Ptr Word8 -> Int -> IO () -memcpy p q s = c_memcpy p q (fromIntegral s) >> return () - -foreign import ccall unsafe "string.h memcpy" c_memcpy - :: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8) - diff --git a/Data/Array/Accelerate/LLVM/Native/CodeGen.hs b/Data/Array/Accelerate/LLVM/Native/CodeGen.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/CodeGen.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | --- Module : Data.Array.Accelerate.LLVM.Native.CodeGen --- 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.CodeGen ( - - KernelMetadata(..), - -) where - --- accelerate -import Data.Array.Accelerate.LLVM.CodeGen - -import Data.Array.Accelerate.LLVM.Native.CodeGen.Base -import Data.Array.Accelerate.LLVM.Native.CodeGen.Fold -import Data.Array.Accelerate.LLVM.Native.CodeGen.FoldSeg -import Data.Array.Accelerate.LLVM.Native.CodeGen.Generate -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.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 - diff --git a/Data/Array/Accelerate/LLVM/Native/CodeGen/Base.hs b/Data/Array/Accelerate/LLVM/Native/CodeGen/Base.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/CodeGen/Base.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} --- | --- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.Base --- Copyright : [2015..2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -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 LLVM.AST.Type.Name -import qualified LLVM.AST.Global as LLVM -import qualified LLVM.AST.Type as LLVM - -import Data.Monoid -import Data.String -import Text.Printf - - --- | 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" - in - (local t start, local t end, [ scalarParameter t start, scalarParameter t end ] ) - - --- | The thread ID of a gang worker --- -gangId :: (IR Int, [LLVM.Parameter]) -gangId = - let t = scalarType - tid = "ix.tid" - in - (local t tid, [ scalarParameter t tid ] ) - - --- Global function definitions --- --------------------------- - -data instance KernelMetadata Native = KM_Native () - --- | Combine kernels into a single program --- -(+++) :: IROpenAcc Native aenv a -> IROpenAcc Native aenv a -> IROpenAcc Native aenv a -IROpenAcc k1 +++ IROpenAcc k2 = IROpenAcc (k1 ++ k2) - --- | Create a single kernel program --- -makeOpenAcc :: UID -> Label -> [LLVM.Parameter] -> CodeGen () -> CodeGen (IROpenAcc Native aenv a) -makeOpenAcc uid name param kernel = do - body <- makeKernel (name <> fromString (printf "_%016x" uid)) param kernel - return $ IROpenAcc [body] - --- | Create a complete kernel function by running the code generation process --- specified in the final parameter. --- -makeKernel :: Label -> [LLVM.Parameter] -> CodeGen () -> CodeGen (Kernel Native aenv a) -makeKernel name param kernel = do - _ <- kernel - code <- createBlocks - return $ Kernel - { kernelMetadata = KM_Native () - , unKernel = LLVM.functionDefaults - { LLVM.returnType = LLVM.VoidType - , LLVM.name = downcast name - , LLVM.parameters = (param, False) - , LLVM.basicBlocks = code - } - } - diff --git a/Data/Array/Accelerate/LLVM/Native/CodeGen/Fold.hs b/Data/Array/Accelerate/LLVM/Native/CodeGen/Fold.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/CodeGen/Fold.hs +++ /dev/null @@ -1,301 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} --- | --- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.Fold --- Copyright : [2014..2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -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.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.IR -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.CodeGen.Base -import Data.Array.Accelerate.LLVM.Native.CodeGen.Generate -import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop -import Data.Array.Accelerate.LLVM.Native.Target ( Native ) - -import Control.Applicative -import Prelude as P hiding ( length ) - - --- Reduce a (possibly empty) 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. --- -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 - - --- Reduce a multidimensional (>1) array along the innermost dimension. --- --- For simplicity, each element of the output (reduction along the entire length --- 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{..} = - 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) - in - makeOpenAcc uid "fold" (paramGang ++ paramStride : paramOut ++ 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 - return_ - - --- Reduce an array to single element. --- --- Since reductions consume arrays that have been fused into them, --- a parallel fold requires two passes. At an example, take vector dot --- product: --- --- > dotp xs ys = fold (+) 0 (zipWith (*) xs ys) --- --- 1. The first pass reads in the fused array data, in this case corresponding --- to the function (\i -> (xs!i) * (ys!i)). --- --- 2. The second pass reads in the manifest array data from the first step and --- directly reduces the array. This second step should be small and so is --- usually just done by a single core. --- --- Note that the first step is split into two kernels, the second of which --- reads a carry-in value of that thread's partial reduction, so that --- threads can still participate in work-stealing. These kernels must not --- be invoked over empty ranges. --- --- The final step is sequential reduction of the partial results. If this --- 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 - ] - - --- 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{..} = - let - (start, end, paramGang) = gangParam - paramEnv = envParam aenv - (arrOut, paramOut) = mutableArray ("out" :: Name (Scalar e)) - zero = lift 0 :: IR Int - in - makeOpenAcc uid "foldAllS" (paramGang ++ paramOut ++ 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 - return_ - --- Parallel reduction of an entire array to a single element, step 1. --- --- Threads reduce each stripe of the input into a temporary array, incorporating --- 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{..} = - 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) - in - makeOpenAcc uid "foldAllP1" (paramGang ++ paramLength : paramStride : paramTmp ++ 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. - -- - imapFromTo start end $ \i -> do - inf <- A.mul numType i stride - a <- A.add numType inf stride - sup <- A.min scalarType a length - r <- reduce1FromTo inf sup (app2 combine) (app1 delayedLinearIndex) - writeArray arrTmp i r - - return_ - --- Parallel reduction of an entire array to a single element, step 2. --- --- A single thread reduces the temporary array to a single element. --- --- During execution, we choose a stripe size in phase 1 so that the temporary is --- small-ish and thus suitable for sequential reduction. An alternative would be --- to keep the stripe size constant and, for if the partial reductions array is --- 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 = - 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 - 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 - return_ - - --- Exclusive reductions over empty arrays (of any dimension) fill the lower --- dimensions with the initial element --- -mkFoldFill - :: (Shape sh, Elt e) - => UID - -> Gamma aenv - -> IRExp Native aenv e - -> CodeGen (IROpenAcc Native aenv (Array sh e)) -mkFoldFill uid aenv seed = - mkGenerate uid aenv (IRFun1 (const seed)) - --- Reduction loops --- --------------- - --- 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 - x <- get i - y <- f acc x - return y - --- Reduction of an array over a _non-empty_ index space. The array must --- 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 - z <- get m - m1 <- add numType m (ir numType (num numType 1)) - reduceFromTo m1 n f z get - diff --git a/Data/Array/Accelerate/LLVM/Native/CodeGen/FoldSeg.hs b/Data/Array/Accelerate/LLVM/Native/CodeGen/FoldSeg.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/CodeGen/FoldSeg.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} --- | --- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.FoldSeg --- Copyright : [2014..2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.Native.CodeGen.FoldSeg - where - --- accelerate -import Data.Array.Accelerate.Array.Sugar -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.Monad -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.Fold -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 = - let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Array (sh :. Int) e)) - paramEnv = envParam aenv - in - makeOpenAcc uid "foldSegS" (paramGang ++ paramOut ++ paramEnv) $ do - - -- Number of segments, useful only if reducing DIM2 and higher - ss <- indexHead <$> delayedExtent seg - - let test si = A.lt scalarType (A.fst si) end - initial = A.pair start (lift 0) - - body :: IR (Int,Int) -> CodeGen (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 - 0 -> return s - _ -> A.rem integralType s ss - - len <- A.fromIntegral integralType numType =<< app1 (delayedLinearIndex seg) 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)) - writeArray arrOut s r - - t <- A.add numType s (lift 1) - return $ A.pair t sup - - void $ while test body initial - return_ - - --- 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 = - let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Array (sh :. Int) e)) - 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 - - 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 - - (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 - - 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)) - - writeArray arrOut s r - - return_ - diff --git a/Data/Array/Accelerate/LLVM/Native/CodeGen/Generate.hs b/Data/Array/Accelerate/LLVM/Native/CodeGen/Generate.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/CodeGen/Generate.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | --- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.Generate --- 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.CodeGen.Generate - where - --- accelerate -import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt ) - -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 - - --- Construct a new array by applying a function to each index. Each thread --- processes multiple adjacent elements. --- -mkGenerate - :: forall aenv sh e. (Shape sh, Elt e) - => UID - -> Gamma aenv - -> IRFun1 Native aenv (sh -> e) - -> CodeGen (IROpenAcc Native aenv (Array sh e)) -mkGenerate uid aenv apply = - let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Array sh e)) - paramEnv = envParam aenv - 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 - - return_ - diff --git a/Data/Array/Accelerate/LLVM/Native/CodeGen/Loop.hs b/Data/Array/Accelerate/LLVM/Native/CodeGen/Loop.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/CodeGen/Loop.hs +++ /dev/null @@ -1,46 +0,0 @@ --- | --- Module : Data.Array.Accelerate.LLVM.CodeGen.Native.Loop --- Copyright : [2014..2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.Native.CodeGen.Loop - where - --- accelerate -import Data.Array.Accelerate.Array.Sugar - -import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic -import Data.Array.Accelerate.LLVM.CodeGen.IR -import Data.Array.Accelerate.LLVM.CodeGen.Monad -import qualified Data.Array.Accelerate.LLVM.CodeGen.Loop as Loop - - --- | 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 () -imapFromTo start end body = - Loop.imapFromStepTo start (lift 1) end body - --- | 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 - diff --git a/Data/Array/Accelerate/LLVM/Native/CodeGen/Map.hs b/Data/Array/Accelerate/LLVM/Native/CodeGen/Map.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/CodeGen/Map.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | --- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.Map --- 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.CodeGen.Map - where - --- accelerate -import Data.Array.Accelerate.Array.Sugar ( Array, Elt ) - -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.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 - - --- C Code --- ====== --- --- float f(float); --- --- void map(float* __restrict__ out, const float* __restrict__ in, const int n) --- { --- for (int i = 0; i < n; ++i) --- out[i] = f(in[i]); --- --- return; --- } - --- Corresponding LLVM --- ================== --- --- define void @map(float* noalias nocapture %out, float* noalias nocapture %in, i32 %n) nounwind uwtable ssp { --- %1 = icmp sgt i32 %n, 0 --- br i1 %1, label %.lr.ph, label %._crit_edge --- --- .lr.ph: ; preds = %0, %.lr.ph --- %indvars.iv = phi i64 [ %indvars.iv.next, %.lr.ph ], [ 0, %0 ] --- %2 = getelementptr inbounds float* %in, i64 %indvars.iv --- %3 = load float* %2, align 4 --- %4 = tail call float @apply(float %3) nounwind --- %5 = getelementptr inbounds float* %out, i64 %indvars.iv --- store float %4, float* %5, align 4 --- %indvars.iv.next = add i64 %indvars.iv, 1 --- %lftr.wideiv = trunc i64 %indvars.iv.next to i32 --- %exitcond = icmp eq i32 %lftr.wideiv, %n --- br i1 %exitcond, label %._crit_edge, label %.lr.ph --- --- ._crit_edge: ; preds = %.lr.ph, %0 --- ret void --- } --- --- 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{..} = - let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Array sh b)) - paramEnv = envParam aenv - in - makeOpenAcc uid "map" (paramGang ++ paramOut ++ paramEnv) $ do - - imapFromTo start end $ \i -> do - xs <- app1 delayedLinearIndex i - ys <- app1 apply xs - writeArray arrOut i ys - - return_ - diff --git a/Data/Array/Accelerate/LLVM/Native/CodeGen/Permute.hs b/Data/Array/Accelerate/LLVM/Native/CodeGen/Permute.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/CodeGen/Permute.hs +++ /dev/null @@ -1,304 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} --- | --- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.Permute --- Copyright : [2016..2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -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.Error -import qualified Data.Array.Accelerate.Array.Sugar as S - -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.Permute -import Data.Array.Accelerate.LLVM.CodeGen.Ptr -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 - -import LLVM.AST.Type.AddrSpace -import LLVM.AST.Type.Instruction -import LLVM.AST.Type.Instruction.Atomic -import LLVM.AST.Type.Instruction.RMW as RMW -import LLVM.AST.Type.Instruction.Volatile -import LLVM.AST.Type.Representation - -import Control.Applicative -import Control.Monad ( void ) -import Data.Typeable -import Prelude - - --- Forward permutation specified by an indexing mapping. The resulting array is --- initialised with the given defaults, and any further values that are permuted --- into the result array are added to the current value using the combination --- function. --- --- The combination function must be /associative/ and /commutative/. Elements --- that are mapped to the magic index 'ignore' are dropped. --- -mkPermute - :: (Shape sh, Shape sh', Elt e) - => UID - -> Gamma aenv - -> 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 - - --- Forward permutation which does not require locking the output array. This --- could be because we are executing sequentially with a single thread, or --- because the default values are unused (e.g. for a filter). --- --- We could also use this method if we can prove that the mapping function is --- injective (distinct elements in the domain map to distinct elements in the --- co-domain). --- -mkPermuteS - :: forall aenv sh sh' e. (Shape sh, Shape sh', Elt e) - => UID - -> Gamma aenv - -> 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{..} = - let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Array sh' e)) - paramEnv = envParam aenv - in - makeOpenAcc uid "permuteS" (paramGang ++ paramOut ++ paramEnv) $ do - - sh <- delayedExtent - - imapFromTo start end $ \i -> do - - ix <- indexOfInt sh i - ix' <- app1 project ix - - unless (ignore ix') $ do - j <- intOfIndex (irArrayShape arrOut) ix' - - -- project element onto the destination array and update - x <- app1 delayedLinearIndex i - y <- readArray arrOut j - r <- app2 combine x y - - writeArray arrOut j r - - return_ - - --- Parallel forward permutation has to take special care because different --- threads could concurrently try to update the same memory location. Where --- available we make use of special atomic instructions and other optimisations, --- but in the general case each element of the output array has a lock which --- must be obtained by the thread before it can update that memory location. --- --- TODO: After too many failures to acquire the lock on an element, the thread --- should back off and try a different element, adding this failed element to --- a queue or some such. --- -mkPermuteP - :: forall aenv sh sh' e. (Shape sh, Shape sh', Elt e) - => UID - -> Gamma aenv - -> 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 = - case atomicRMW of - Nothing -> mkPermuteP_mutex uid aenv combine project arr - Just (rmw, f) -> mkPermuteP_rmw uid aenv 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) - => UID - -> Gamma aenv - -> 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{..} = - let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Array sh' e)) - paramEnv = envParam aenv - in - makeOpenAcc uid "permuteP_rmw" (paramGang ++ paramOut ++ paramEnv) $ do - - sh <- delayedExtent - - imapFromTo start end $ \i -> do - - ix <- indexOfInt sh i - ix' <- app1 project ix - - unless (ignore ix') $ do - j <- intOfIndex (irArrayShape arrOut) ix' - x <- app1 delayedLinearIndex i - r <- app1 update x - - case rmw of - Exchange - -> writeArray arrOut j r - -- - _ | SingleTuple s <- eltType (undefined::e) - , Just adata <- gcast (irArrayData arrOut) - , Just r' <- gcast r - -> do - addr <- instr' $ GetElementPtr (asPtr defaultAddrSpace (op s adata)) [op integralType j] - -- - case s of - NumScalarType (IntegralNumType t) -> void . instr' $ AtomicRMW t NonVolatile rmw addr (op t r') (CrossThread, AcquireRelease) - NumScalarType t | RMW.Add <- rmw -> atomicCAS_rmw s (A.add t r') addr - NumScalarType 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" - -- - _ -> $internalError "mkPermute_rmw" "unexpected transition" - - return_ - - --- Parallel forward permutation function which uses a spinlock to acquire --- 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{..} = - let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Array sh' e)) - (arrLock, paramLock) = mutableArray ("lock" :: Name (Vector Word8)) - paramEnv = envParam aenv - in - makeOpenAcc uid "permuteP_mutex" (paramGang ++ paramOut ++ paramLock ++ paramEnv) $ do - - sh <- delayedExtent - - imapFromTo start end $ \i -> 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 - - atomically arrLock j $ do - y <- readArray arrOut j - r <- app2 combine x y - writeArray arrOut j r - - return_ - - --- Atomically execute the critical section only when the lock at the given array --- index is obtained. The thread spins waiting for the lock to be released and --- there is no backoff strategy in case the lock is contended. --- --- It is important that the thread loops trying to acquire the lock without --- writing data anything until the lock value changes. Then, because of MESI --- caching protocols there will be no bus traffic while the CPU waits for the --- value to change. --- --- --- -atomically - :: IRArray (Vector Word8) - -> IR Int - -> CodeGen a - -> CodeGen a -atomically barriers i action = do - let - lock = integral integralType 1 - unlock = integral integralType 0 - unlocked = lift 0 - -- - spin <- newBlock "spinlock.entry" - crit <- newBlock "spinlock.critical-section" - exit <- newBlock "spinlock.exit" - - addr <- instr' $ GetElementPtr (asPtr defaultAddrSpace (op integralType (irArrayData barriers))) [op integralType i] - _ <- br spin - - -- Atomically (attempt to) set the lock slot to the locked state. If the slot - -- 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) - ok <- A.eq scalarType old unlocked - _ <- cbr ok crit spin - - -- We just acquired the lock; perform the critical section then release the - -- lock and exit. For ("some") x86 processors, an unlocked MOV instruction - -- could be used rather than the slower XCHG, due to subtle memory ordering - -- rules. - setBlock crit - r <- action - _ <- instr $ AtomicRMW integralType NonVolatile Exchange addr unlock (CrossThread, Release) - _ <- br exit - - setBlock exit - return r - - --- 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 UnitTuple () OP_Unit = return (lift True) - go (PairTuple tsh tsz) (ish, isz) (OP_Pair sh sz) = do x <- go tsh ish sh - y <- go tsz isz sz - land' x y - go (SingleTuple t) ig sz = A.eq t (ir t (scalar t ig)) (ir t (op' t sz)) - diff --git a/Data/Array/Accelerate/LLVM/Native/CodeGen/Scan.hs b/Data/Array/Accelerate/LLVM/Native/CodeGen/Scan.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/CodeGen/Scan.hs +++ /dev/null @@ -1,833 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} --- | --- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.Scan --- Copyright : [2014..2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -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.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 -import Data.Array.Accelerate.LLVM.Compile.Cache - -import Data.Array.Accelerate.LLVM.Native.CodeGen.Base -import Data.Array.Accelerate.LLVM.Native.CodeGen.Generate -import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop -import Data.Array.Accelerate.LLVM.Native.Target ( Native ) - -import Control.Applicative -import Control.Monad -import Data.String ( fromString ) -import Data.Coerce as Safe -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. --- --- > 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 - - --- Variant of 'scanl' where the final result is returned in a separate array. --- --- > scanr' (+) 10 (use $ fromList (Z :. 10) [0..]) --- > --- > ==> ( Array (Z :. 10) [10,10,11,13,16,20,25,31,38,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 - ] - -- - | otherwise - = (+++) <$> mkScan'S R uid aenv combine seed arr - <*> mkScan'Fill uid aenv 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)) - -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))) - - --- A single thread sequentially scans along an entire innermost dimension. For --- inclusive scans we can assume that the innermost-dimension is at least one --- element. --- --- Note that we can use this both when there is a single thread, or in parallel --- where threads are scheduled over the outer dimensions (segments). --- -mkScanS - :: forall aenv sh e. Elt e - => 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{..} = - let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Array (sh:.Int) e)) - paramEnv = envParam aenv - -- - next i = case dir of - L -> A.add numType i (lift 1) - R -> A.sub numType i (lift 1) - in - makeOpenAcc uid "scanS" (paramGang ++ paramOut ++ paramEnv) $ do - - sz <- indexHead <$> delayedExtent - szp1 <- A.add numType sz (lift 1) - szm1 <- A.sub numType sz (lift 1) - - -- loop over each lower-dimensional index (segment) - imapFromTo start end $ \seg -> 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 - - -- 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 - - -- 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 - - -- Write first element, then continue looping through the rest - writeArray arrOut j0 v0 - 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 scalarType i iz - R -> A.gt scalarType i iz - - 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') - (A.trip i1 j1 v0) - - return_ - - -mkScan'S - :: forall aenv sh e. (Shape sh, Elt e) - => 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{..} = - 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 - -- - next i = case dir of - L -> A.add numType i (lift 1) - R -> A.sub numType i (lift 1) - in - makeOpenAcc uid "scanS" (paramGang ++ paramOut ++ paramSum ++ paramEnv) $ do - - sz <- indexHead <$> delayedExtent - szm1 <- A.sub numType sz (lift 1) - - -- iterate over each lower-dimensional index (segment) - imapFromTo start end $ \seg -> 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 - - -- 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 scalarType i iz - R -> A.gt scalarType 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 - - 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') - (A.pair i0 v0) - - -- write final reduction result - writeArray arrSum seg (A.snd r) - - return_ - - -mkScanP - :: forall aenv e. Elt e - => 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 - ] - --- Parallel scan, step 1. --- --- Threads scan a stripe of the input into a temporary array, incorporating the --- initial element and any fused functions on the way. The final reduction --- result of this chunk is written to a separate array. --- -mkScanP1 - :: forall aenv e. Elt e - => 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{..} = - let - (chunk, _, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Vector e)) - (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) - 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) - -- - 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 - in - makeOpenAcc uid "scanP1" (paramGang ++ paramStride : paramSteps : paramOut ++ paramTmp ++ paramEnv) $ do - - len <- indexHead <$> delayedExtent - - -- A thread scans a non-empty stripe of the input, storing the final - -- reduction result into a separate array. - -- - -- 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 scalarType 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 - - -- 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 - -- 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 scalarType chunk firstChunk - then return i0 - else next i0 - R -> if A.eq scalarType chunk firstChunk - then return sup - else return i0 - - -- Evaluate/read the initial element for this chunk. Update the read-from - -- index appropriately - (v0,i1) <- A.unpair <$> case mseed of - Just seed -> if A.eq scalarType chunk firstChunk - then A.pair <$> seed <*> pure i0 - else A.pair <$> app1 delayedLinearIndex i0 <*> next i0 - Nothing -> A.pair <$> app1 delayedLinearIndex i0 <*> next i0 - - -- Write first element - writeArray arrOut j0 v0 - j1 <- next j0 - - -- Continue looping through the rest of the input - let cont i = - case dir of - L -> A.lt scalarType i sup - R -> A.gte scalarType i inf - - r <- 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') - (A.trip i1 j1 v0) - - -- Final reduction result of this chunk - writeArray arrTmp chunk (A.thd3 r) - - return_ - - --- Parallel scan, step 2. --- --- A single thread performs an in-place inclusive scan of the partial block --- sums. This forms the carry-in value which are added to the stripe partial --- results in the final step. --- -mkScanP2 - :: forall aenv e. Elt e - => Direction - -> UID - -> Gamma aenv - -> IRFun2 Native aenv (e -> e -> e) - -> CodeGen (IROpenAcc Native aenv (Vector e)) -mkScanP2 dir uid aenv combine = - let - (start, end, paramGang) = gangParam - (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) - paramEnv = envParam aenv - -- - cont i = case dir of - L -> A.lt scalarType i end - R -> A.gte scalarType i start - - next i = case dir of - L -> A.add numType i (lift 1) - R -> A.sub numType i (lift 1) - in - makeOpenAcc uid "scanP2" (paramGang ++ paramTmp ++ paramEnv) $ do - - i0 <- case dir of - L -> return start - R -> next end - - v0 <- readArray arrTmp i0 - i1 <- next i0 - - void $ while (cont . A.fst) - (\(A.unpair -> (i,v)) -> do - u <- readArray arrTmp i - i' <- next i - v' <- case dir of - L -> app2 combine v u - R -> app2 combine u v - writeArray arrTmp i v' - return $ A.pair i' v') - (A.pair i1 v0) - - return_ - - --- Parallel scan, step 3. --- --- Threads combine every element of the partial block results with the carry-in --- 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). --- -mkScanP3 - :: forall aenv e. Elt e - => 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 = - let - (chunk, _, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Vector e)) - (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) - paramEnv = envParam aenv - -- - stride = local scalarType ("ix.stride" :: Name Int) - paramStride = scalarParameter scalarType ("ix.stride" :: Name Int) - -- - 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) - 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 - - b <- A.mul numType a stride - c <- A.add numType b stride - d <- A.min scalarType c (indexHead (irArrayShape arrOut)) - - (inf,sup) <- case (dir,mseed) of - (L,Just _) -> (,) <$> next b <*> next d - _ -> (,) <$> pure b <*> pure d - - -- Carry in value from the previous chunk - e <- case dir of - L -> pure chunk - R -> prev chunk - carry <- readArray arrTmp e - - 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 - - return_ - - -mkScan'P - :: forall aenv e. Elt e - => 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 - ] - --- 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. --- -mkScan'P1 - :: forall aenv e. Elt e - => 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{..} = - let - (chunk, _, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Vector e)) - (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) - 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) - -- - 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 - 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 scalarType a len - - -- index i* is the index that we pull data from. - i0 <- case dir of - L -> return inf - R -> next sup - - -- index j* is the index that we write results to. The first chunk needs to - -- include the initial element, and all other chunks shift their results - -- across by one to make space. - j0 <- if A.eq scalarType chunk firstChunk - then pure i0 - else next i0 - - -- Evaluate/read the initial element. Update the read-from index - -- appropriately. - (v0,i1) <- A.unpair <$> if A.eq scalarType chunk firstChunk - then A.pair <$> seed <*> pure i0 - else A.pair <$> app1 delayedLinearIndex i0 <*> pure j0 - - -- Write the first element - writeArray arrOut j0 v0 - j1 <- next j0 - - -- Continue looping through the rest of the input - let cont i = - case dir of - L -> A.lt scalarType i sup - R -> A.gte scalarType i inf - - r <- 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') - (A.trip i1 j1 v0) - - -- Write the final reduction result of this chunk - writeArray arrTmp chunk (A.thd3 r) - - return_ - - --- Parallel scan', step 2 --- --- Identical to mkScanP2, except we store the total scan result into a separate --- array (rather than discard it). --- -mkScan'P2 - :: forall aenv e. Elt e - => Direction - -> UID - -> Gamma aenv - -> IRFun2 Native aenv (e -> e -> e) - -> CodeGen (IROpenAcc Native aenv (Vector e, Scalar e)) -mkScan'P2 dir uid aenv combine = - let - (start, end, paramGang) = gangParam - (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) - (arrSum, paramSum) = mutableArray ("sum" :: Name (Scalar e)) - paramEnv = envParam aenv - -- - cont i = case dir of - L -> A.lt scalarType i end - R -> A.gte scalarType i start - - next i = case dir of - L -> A.add numType i (lift 1) - R -> A.sub numType i (lift 1) - in - makeOpenAcc uid "scanP2" (paramGang ++ paramSum ++ paramTmp ++ paramEnv) $ do - - i0 <- case dir of - L -> return start - R -> next end - - v0 <- readArray arrTmp i0 - i1 <- next i0 - - r <- while (cont . A.fst) - (\(A.unpair -> (i,v)) -> do - u <- readArray arrTmp i - i' <- next i - v' <- case dir of - L -> app2 combine v u - R -> app2 combine u v - writeArray arrTmp i v' - return $ A.pair i' v') - (A.pair i1 v0) - - writeArray arrSum (lift 0 :: IR Int) (A.snd r) - - return_ - - --- Parallel scan', step 3 --- --- 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. --- -mkScan'P3 - :: forall aenv e. Elt e - => Direction - -> UID - -> Gamma aenv - -> IRFun2 Native aenv (e -> e -> e) - -> CodeGen (IROpenAcc Native aenv (Vector e, Scalar e)) -mkScan'P3 dir uid aenv combine = - let - (chunk, _, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Vector e)) - (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) - paramEnv = envParam aenv - -- - stride = local scalarType ("ix.stride" :: Name Int) - paramStride = scalarParameter scalarType ("ix.stride" :: Name Int) - -- - 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) - 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 scalarType c (indexHead (irArrayShape arrOut)) - - inf <- next b - sup <- next d - - -- Carry-value from the previous chunk - e <- case dir of - L -> pure chunk - R -> prev chunk - - carry <- readArray arrTmp e - - 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 - - return_ - diff --git a/Data/Array/Accelerate/LLVM/Native/Compile.hs b/Data/Array/Accelerate/LLVM/Native/Compile.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/Compile.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | --- Module : Data.Array.Accelerate.LLVM.Native.Compile --- 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.Compile ( - - module Data.Array.Accelerate.LLVM.Compile, - ObjectR(..), - -) 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.LLVM.CodeGen -import Data.Array.Accelerate.LLVM.Compile -import Data.Array.Accelerate.LLVM.State -import Data.Array.Accelerate.LLVM.CodeGen.Environment ( Gamma ) -import Data.Array.Accelerate.LLVM.CodeGen.Module ( Module(..) ) - -import Data.Array.Accelerate.LLVM.Native.CodeGen ( ) -import Data.Array.Accelerate.LLVM.Native.Compile.Cache -import Data.Array.Accelerate.LLVM.Native.Compile.Optimise -import Data.Array.Accelerate.LLVM.Native.Foreign ( ) -import Data.Array.Accelerate.LLVM.Native.Target -import qualified Data.Array.Accelerate.LLVM.Native.Debug as Debug - --- standard library -import Control.Monad.State -import Data.ByteString ( ByteString ) -import Data.ByteString.Short ( ShortByteString ) -import Data.Maybe -import System.Directory -import System.IO.Unsafe -import Text.Printf -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Short as BS -import qualified Data.Map as Map - - -instance Compile Native where - data ObjectR Native = ObjectR { objId :: {-# UNPACK #-} !UID - , objSyms :: {- LAZY -} [ShortByteString] - , objData :: {- LAZY -} ByteString - } - compileForTarget = compile - -instance Intrinsic Native - - --- | 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 - - -- Generate code for this Acc operation - -- - let Module ast md = llvmOfOpenAcc target uid acc aenv - triple = fromMaybe BS.empty (moduleTargetTriple ast) - datalayout = moduleDataLayout ast - nms = [ f | Name f <- Map.keys md ] - - -- Lower the generated LLVM and produce an object file. - -- - -- The 'objData' field is only lazy evaluated since the object code might - -- already have been loaded into memory from a different function, in which - -- case it will be found in the linker cache. - -- - obj <- liftIO . unsafeInterleaveIO $ do - exists <- doesFileExist cacheFile - recomp <- Debug.queryFlag Debug.force_recomp - if exists && not (fromMaybe False recomp) - then do - Debug.traceIO Debug.dump_cc (printf "cc: found cached object code %016x" uid) - B.readFile cacheFile - - else - withContext $ \ctx -> - withModuleFromAST ctx ast $ \mdl -> - withNativeTargetMachine $ \machine -> - withTargetLibraryInfo triple $ \libinfo -> do - optimiseModule datalayout (Just machine) (Just libinfo) mdl - - Debug.when Debug.verbose $ do - Debug.traceIO Debug.dump_cc . B8.unpack =<< moduleLLVMAssembly mdl - Debug.traceIO Debug.dump_asm . B8.unpack =<< moduleTargetAssembly machine mdl - - obj <- moduleObject machine mdl - B.writeFile cacheFile obj - return obj - - return $! ObjectR uid nms obj - diff --git a/Data/Array/Accelerate/LLVM/Native/Compile/Cache.hs b/Data/Array/Accelerate/LLVM/Native/Compile/Cache.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/Compile/Cache.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | --- Module : Data.Array.Accelerate.LLVM.Native.Compile.Cache --- Copyright : [2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.Native.Compile.Cache ( - - module Data.Array.Accelerate.LLVM.Compile.Cache - -) where - -import Data.Array.Accelerate.LLVM.Compile.Cache -import Data.Array.Accelerate.LLVM.Native.Target - -import Data.Version -import System.FilePath -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Short.Char8 as S8 - -import Paths_accelerate_llvm_native - - -instance Persistent Native where - targetCacheTemplate = - return $ "accelerate-llvm-native-" ++ showVersion version - S8.unpack nativeTargetTriple - B8.unpack nativeCPUName - "meep.o" - diff --git a/Data/Array/Accelerate/LLVM/Native/Compile/Optimise.hs b/Data/Array/Accelerate/LLVM/Native/Compile/Optimise.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/Compile/Optimise.hs +++ /dev/null @@ -1,143 +0,0 @@ --- | --- Module : Data.Array.Accelerate.LLVM.Native.Compile.Optimise --- 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.Compile.Optimise ( - - optimiseModule - -) where - --- llvm-hs -import LLVM.AST.DataLayout -import LLVM.Module -import LLVM.PassManager -import LLVM.Target - --- accelerate -import qualified Data.Array.Accelerate.LLVM.Native.Debug as Debug - --- standard library -import Text.Printf - - --- | Run the standard optimisations on the given module when targeting a --- specific machine and data layout. Specifically, this will run the --- optimisation passes such that LLVM has the necessary information to --- automatically vectorise loops (whenever it deems beneficial to do so). --- -optimiseModule - :: Maybe DataLayout - -> Maybe TargetMachine - -> Maybe TargetLibraryInfo - -> Module - -> IO () -optimiseModule datalayout machine libinfo mdl = do - - let p1 = defaultCuratedPassSetSpec - { optLevel = Just 3 - , dataLayout = datalayout - , targetMachine = machine - , targetLibraryInfo = libinfo - , loopVectorize = Just True - , superwordLevelParallelismVectorize = Just True - } - b1 <- withPassManager p1 $ \pm -> runPassManager pm mdl - - Debug.traceIO Debug.dump_cc $ - printf "llvm: optimisation did work? %s" (show b1) - -{-- --- The first gentle optimisation pass. I think this is usually done when loading --- the module? --- --- This is the first section of output running 'opt -O3 -debug-pass=Arguments' --- --- Pass Arguments: --- -datalayout -notti -basictti -x86tti -no-aa -tbaa -targetlibinfo -basicaa --- -preverify -domtree -verify -simplifycfg -domtree -sroa -early-cse --- -lower-expect --- -prepass :: [Pass] -prepass = - [ SimplifyControlFlowGraph - , ScalarReplacementOfAggregates { requiresDominatorTree = True } - , EarlyCommonSubexpressionElimination - , LowerExpectIntrinsic - ] - --- The main optimisation pipeline. This mostly matches the process of running --- 'opt -O3 -debug-pass=Arguments'. We are missing dead argument elimination and --- in particular, slp-vectorizer (super-word level parallelism). --- --- Pass Arguments: --- -targetlibinfo -datalayout -notti -basictti -x86tti -no-aa -tbaa -basicaa --- -globalopt -ipsccp -deadargelim -instcombine -simplifycfg -basiccg -prune-eh --- -inline-cost -inline -functionattrs -argpromotion -sroa -domtree -early-cse --- -lazy-value-info -jump-threading -correlated-propagation -simplifycfg --- -instcombine -tailcallelim -simplifycfg -reassociate -domtree -loops --- -loop-simplify -lcssa -loop-rotate -licm -lcssa -loop-unswitch -instcombine --- -scalar-evolution -loop-simplify -lcssa -indvars -loop-idiom -loop-deletion --- -loop-unroll -memdep -gvn -memdep -memcpyopt -sccp -instcombine --- -lazy-value-info -jump-threading -correlated-propagation -domtree -memdep -dse --- -loops -scalar-evolution -slp-vectorizer -adce -simplifycfg -instcombine --- -barrier -domtree -loops -loop-simplify -lcssa -scalar-evolution --- -loop-simplify -lcssa -loop-vectorize -instcombine -simplifycfg --- -strip-dead-prototypes -globaldce -constmerge -preverify -domtree -verify --- -optpass :: [Pass] -optpass = - [ - InterproceduralSparseConditionalConstantPropagation -- ipsccp - , InstructionCombining - , SimplifyControlFlowGraph - , PruneExceptionHandling - , FunctionInlining { functionInliningThreshold = 275 } -- -O2 => 275 - , FunctionAttributes - , ArgumentPromotion -- not needed? - , ScalarReplacementOfAggregates { requiresDominatorTree = True } -- false? - , EarlyCommonSubexpressionElimination - , JumpThreading - , CorrelatedValuePropagation - , SimplifyControlFlowGraph - , InstructionCombining - , TailCallElimination - , SimplifyControlFlowGraph - , Reassociate - , LoopRotate - , LoopInvariantCodeMotion - , LoopClosedSingleStaticAssignment - , LoopUnswitch { optimizeForSize = False } - , LoopInstructionSimplify - , InstructionCombining - , InductionVariableSimplify - , LoopIdiom - , LoopDeletion - , LoopUnroll { loopUnrollThreshold = Nothing - , count = Nothing - , allowPartial = Nothing } - , GlobalValueNumbering { noLoads = False } -- True to add memory dependency analysis - , SparseConditionalConstantPropagation - , InstructionCombining - , JumpThreading - , CorrelatedValuePropagation - , DeadStoreElimination - , defaultVectorizeBasicBlocks -- instead of slp-vectorizer? - , AggressiveDeadCodeElimination - , SimplifyControlFlowGraph - , InstructionCombining - , LoopVectorize - , InstructionCombining - , SimplifyControlFlowGraph - , GlobalDeadCodeElimination - , ConstantMerge - ] ---} - diff --git a/Data/Array/Accelerate/LLVM/Native/Debug.hs b/Data/Array/Accelerate/LLVM/Native/Debug.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/Debug.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeOperators #-} --- | --- Module : Data.Array.Accelerate.LLVM.Native.Debug --- 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.Debug ( - - module Data.Array.Accelerate.Debug, - module Data.Array.Accelerate.LLVM.Native.Debug, - -) where - -import Data.Array.Accelerate.Debug hiding ( elapsed ) -import qualified Data.Array.Accelerate.Debug as Debug - -import Text.Printf - - --- | Display elapsed wall and CPU time, together with speedup fraction --- -{-# INLINEABLE elapsedP #-} -elapsedP :: Double -> Double -> String -elapsedP wallTime cpuTime = - printf "%s (wall), %s (cpu), %.2f x speedup" - (showFFloatSIBase (Just 3) 1000 wallTime "s") - (showFFloatSIBase (Just 3) 1000 cpuTime "s") - (cpuTime / wallTime) - --- | Display elapsed wall and CPU time --- -{-# INLINEABLE elapsedS #-} -elapsedS :: Double -> Double -> String -elapsedS = Debug.elapsed - diff --git a/Data/Array/Accelerate/LLVM/Native/Distribution/Simple.hs b/Data/Array/Accelerate/LLVM/Native/Distribution/Simple.hs deleted file mode 100644 --- a/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/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/Build.hs b/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/Build.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/Build.hs +++ /dev/null @@ -1,451 +0,0 @@ --- | --- 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.JHC as JHC -import qualified Distribution.Simple.LHC as LHC -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 -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" - - --- | 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 = pkg_descr { - package = (package pkg_descr) { pkgName = mkPackageName $ unMungedPackageName compat_name } - , buildDepends = targetBuildDepends $ testBuildInfo test - , 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 ] - - --- 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 - JHC -> JHC.buildLib verbosity pkg_descr lbi lib clbi - LHC -> LHC.buildLib verbosity 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 - JHC -> JHC.buildExe verbosity pkg_descr lbi exe clbi - LHC -> LHC.buildExe verbosity 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/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC.hs b/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC.hs +++ /dev/null @@ -1,438 +0,0 @@ --- | --- 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 qualified Distribution.Simple.Program.Ld as Ld -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.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 - -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 = toNubListR $ 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 = toNubListR $ hcSharedOptions GHC libBi, - ghcOptHPCDir = hpcdir Hpc.Dyn - } - linkerOpts = mempty { - ghcOptLinkOptions = toNubListR $ PD.ldOptions libBi, - ghcOptLinkLibs = toNubListR $ 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 compiler_id uid - ghciLibFilePath = libTargetDir Internal.mkGHCiLibName uid - libInstallPath = libdir $ absoluteComponentInstallDirs pkg_descr lbi uid NoCopyDest - sharedLibInstallPath = libInstallPath mkSharedLibName 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 = toNubListR $ - 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 = toNubListR $ 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) - Ld.combineObjectFiles verbosity 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/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC/Internal.hs b/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC/Internal.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC/Internal.hs +++ /dev/null @@ -1,115 +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, - -) 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.GHC -import Distribution.Simple.Setup -import Distribution.Simple -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 - diff --git a/Data/Array/Accelerate/LLVM/Native/Embed.hs b/Data/Array/Accelerate/LLVM/Native/Embed.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/Embed.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | --- Module : Data.Array.Accelerate.LLVM.Native.Embed --- Copyright : [2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.Native.Embed ( - - module Data.Array.Accelerate.LLVM.Embed, - -) where - -import Data.ByteString.Short.Char8 as S8 -import Data.ByteString.Short.Extra as BS -import Data.ByteString.Short.Internal as BS - -import Data.Array.Accelerate.Lifetime - -import Data.Array.Accelerate.LLVM.Compile -import Data.Array.Accelerate.LLVM.Embed - -import Data.Array.Accelerate.LLVM.Native.Compile -import Data.Array.Accelerate.LLVM.Native.Compile.Cache -import Data.Array.Accelerate.LLVM.Native.Link -import Data.Array.Accelerate.LLVM.Native.Plugin.Annotation -import Data.Array.Accelerate.LLVM.Native.State -import Data.Array.Accelerate.LLVM.Native.Target - -import Control.Concurrent.Unique -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 - - -instance Embed Native where - embedForTarget = embed - --- Add the given object code to the set of files to link the executable with, --- and generate FFI declarations to access the external functions of that file. --- The returned ExecutableR references the new FFI declarations. --- -embed :: Native -> ObjectR Native -> Q (TExp (ExecutableR Native)) -embed target (ObjectR uid nms !_) = do - objFile <- TH.runIO (evalNative target (cacheOfUID uid)) - funtab <- forM nms $ \fn -> return [|| ( $$(liftSBS (BS.take (BS.length fn - 17) fn)), $$(makeFFI fn objFile) ) ||] - -- - [|| NativeR (unsafePerformIO $ newLifetime (FunctionTable $$(listE funtab))) ||] - where - 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 - fn' <- TH.newName ("__accelerate_llvm_native_" ++ showHex (hash i) []) - dec <- TH.forImpD TH.CCall TH.Unsafe ('&':fn) fn' [t| FunPtr () |] - ann <- TH.pragAnnD (TH.ValueAnnotation fn') [| (Object objFile) |] - TH.addTopDecls [dec, ann] - TH.unsafeTExpCoerce (TH.varE fn') - diff --git a/Data/Array/Accelerate/LLVM/Native/Execute.hs b/Data/Array/Accelerate/LLVM/Native/Execute.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/Execute.hs +++ /dev/null @@ -1,508 +0,0 @@ -{-# 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 ( 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.Word ( Word8 ) -import Prelude hiding ( map, sum, scanl, scanr, init ) -import qualified Data.ByteString.Short.Char8 as S8 -import qualified Prelude as P - -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 = stencil1Op - stencil2 = stencil2Op - - --- 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 (listToShape (P.map (max 1) (shapeToList 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 - - -stencil1Op - :: (Shape sh, Elt b) - => ExecutableR Native - -> Gamma aenv - -> Aval aenv - -> Stream - -> Array sh a - -> LLVM Native (Array sh b) -stencil1Op kernel gamma aenv stream arr = - simpleOp kernel gamma aenv stream (shape arr) - -stencil2Op - :: (Shape sh, Elt c) - => ExecutableR Native - -> Gamma aenv - -> Aval aenv - -> Stream - -> Array sh a - -> Array sh b - -> LLVM Native (Array sh c) -stencil2Op kernel gamma aenv stream arr brr = - simpleOp kernel gamma aenv stream (shape arr `intersect` shape brr) - - --- 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 = - runExecutable exe name ppt r $ \start end _tid -> - monitorProcTime $ - callFFI f retVoid =<< marshal (undefined::Native) () (start, end, args, (gamma, aenv)) - - --- 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 - diff --git a/Data/Array/Accelerate/LLVM/Native/Execute/Async.hs b/Data/Array/Accelerate/LLVM/Native/Execute/Async.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/Execute/Async.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# 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) --- License : BSD3 --- --- 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, - -) 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.LLVM.Native.Target - - -type Async a = A.AsyncR Native a -type Stream = A.StreamR Native -type Event = A.EventR Native - --- The native backend does everything synchronously. --- -instance A.Async Native where - type StreamR Native = () - type EventR Native = () - - {-# INLINE fork #-} - fork = return () - - {-# INLINE join #-} - join () = return () - - {-# INLINE checkpoint #-} - checkpoint () = return () - - {-# INLINE after #-} - after () () = return () - - {-# INLINE block #-} - block () = return () - diff --git a/Data/Array/Accelerate/LLVM/Native/Execute/Environment.hs b/Data/Array/Accelerate/LLVM/Native/Execute/Environment.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/Execute/Environment.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} --- | --- Module : Data.Array.Accelerate.LLVM.Native.Execute.Environment --- 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.Environment ( - - Aval, aprj - -) where - --- accelerate -import Data.Array.Accelerate.LLVM.Native.Target -import Data.Array.Accelerate.LLVM.Execute.Environment - -type Aval = AvalR Native - diff --git a/Data/Array/Accelerate/LLVM/Native/Execute/LBS.hs b/Data/Array/Accelerate/LLVM/Native/Execute/LBS.hs deleted file mode 100644 --- a/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/Data/Array/Accelerate/LLVM/Native/Execute/Marshal.hs b/Data/Array/Accelerate/LLVM/Native/Execute/Marshal.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/Execute/Marshal.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# 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) --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.Native.Execute.Marshal ( - - Marshalable, M.marshal - -) 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.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.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 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 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 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) - diff --git a/Data/Array/Accelerate/LLVM/Native/Foreign.hs b/Data/Array/Accelerate/LLVM/Native/Foreign.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/Foreign.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | --- Module : Data.Array.Accelerate.LLVM.Native.Foreign --- Copyright : [2016..2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.Native.Foreign ( - - -- Foreign functions - ForeignAcc(..), - ForeignExp(..), - - -- useful re-exports - LLVM, - Native(..), - liftIO, - module Data.Array.Accelerate.LLVM.Native.Array.Data, - -) where - -import qualified Data.Array.Accelerate.Array.Sugar 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.Target - -import Control.Monad.State -import Data.Typeable - - -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 - - -instance S.Foreign ForeignAcc where - strForeign (ForeignAcc s _) = s - -instance S.Foreign ForeignExp where - strForeign (ForeignExp s _) = s - - --- Foreign functions in the Native backend. --- --- This is just some arbitrary monadic computation. --- -data ForeignAcc f where - ForeignAcc :: String - -> (a -> LLVM Native 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 --- currently encoded in Accelerate (i.e. SIMD operations, struct types, etc.) --- -data ForeignExp f where - ForeignExp :: String - -> IRFun1 Native () (x -> y) - -> ForeignExp (x -> y) - -deriving instance Typeable ForeignAcc -deriving instance Typeable ForeignExp - diff --git a/Data/Array/Accelerate/LLVM/Native/Link.hs b/Data/Array/Accelerate/LLVM/Native/Link.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/Link.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | --- Module : Data.Array.Accelerate.LLVM.Native.Link --- Copyright : [2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.Native.Link ( - - module Data.Array.Accelerate.LLVM.Link, - module Data.Array.Accelerate.LLVM.Native.Link, - ExecutableR(..), FunctionTable(..), Function, ObjectCode, - -) where - -import Data.Array.Accelerate.Lifetime - -import Data.Array.Accelerate.LLVM.Compile -import Data.Array.Accelerate.LLVM.Link -import Data.Array.Accelerate.LLVM.State - -import Data.Array.Accelerate.LLVM.Native.Target -import Data.Array.Accelerate.LLVM.Native.Compile - -import Data.Array.Accelerate.LLVM.Native.Link.Object -import Data.Array.Accelerate.LLVM.Native.Link.Cache -#if defined(darwin_HOST_OS) -import Data.Array.Accelerate.LLVM.Native.Link.MachO -#elif defined(linux_HOST_OS) -import Data.Array.Accelerate.LLVM.Native.Link.ELF -#elif defined(mingw32_HOST_OS) -import Data.Array.Accelerate.LLVM.Native.Link.COFF -#else -#error "Runtime linking not supported on this platform" -#endif - -import Control.Monad.State -import Prelude hiding ( lookup ) - - -instance Link Native where - data ExecutableR Native = NativeR { nativeExecutable :: {-# UNPACK #-} !(Lifetime FunctionTable) - } - linkForTarget = link - - --- | Load the generated object file into the target address space --- -link :: ObjectR Native -> LLVM Native (ExecutableR Native) -link (ObjectR uid _ obj) = do - cache <- gets linkCache - funs <- liftIO $ dlsym uid cache (loadObject obj) - return $! NativeR funs - - --- | Execute some operation with the supplied executable functions --- -withExecutable :: ExecutableR Native -> (FunctionTable -> LLVM Native b) -> LLVM Native b -withExecutable NativeR{..} f = do - r <- f (unsafeGetValue nativeExecutable) - liftIO $ touchLifetime nativeExecutable - return r - diff --git a/Data/Array/Accelerate/LLVM/Native/Link/COFF.hs b/Data/Array/Accelerate/LLVM/Native/Link/COFF.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/Link/COFF.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --- | --- Module : Data.Array.Accelerate.LLVM.Native.Link.COFF --- Copyright : [2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.Native.Link.COFF ( - - loadObject, - -) where - -import Data.Array.Accelerate.Error -import Data.Array.Accelerate.LLVM.Native.Link.Object - -import Data.ByteString ( ByteString ) - - --- Dynamic object loading --- ---------------------- - --- Load a COFF object file and return pointers to the executable functions --- defined within. The executable sections are aligned appropriately, as --- specified in the object file, and are ready to be executed on the target --- architecture. --- -loadObject :: ByteString -> IO (FunctionTable, ObjectCode) -loadObject _obj = - $internalError "loadObject" "not implemented yet: https://github.com/AccelerateHS/accelerate/issues/395" - diff --git a/Data/Array/Accelerate/LLVM/Native/Link/Cache.hs b/Data/Array/Accelerate/LLVM/Native/Link/Cache.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/Link/Cache.hs +++ /dev/null @@ -1,22 +0,0 @@ --- | --- Module : Data.Array.Accelerate.LLVM.Native.Link.Cache --- Copyright : [2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.Native.Link.Cache ( - - LinkCache, - LC.new, LC.dlsym, - -) where - -import Data.Array.Accelerate.LLVM.Native.Link.Object -import qualified Data.Array.Accelerate.LLVM.Link.Cache as LC - -type LinkCache = LC.LinkCache FunctionTable ObjectCode - diff --git a/Data/Array/Accelerate/LLVM/Native/Link/ELF.chs b/Data/Array/Accelerate/LLVM/Native/Link/ELF.chs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/Link/ELF.chs +++ /dev/null @@ -1,710 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} --- | --- Module : Data.Array.Accelerate.LLVM.Native.Link.ELF --- Copyright : [2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.Native.Link.ELF ( - - loadObject, - -) where - -import Data.Array.Accelerate.Error -import Data.Array.Accelerate.LLVM.Native.Link.Object -import Data.Array.Accelerate.Lifetime -import qualified Data.Array.Accelerate.Debug as Debug - -import Control.Applicative -import Control.Monad -import Data.Bits -import Data.ByteString ( ByteString ) -import Data.Char -import Data.Int -import Data.List -import Data.Serialize.Get -import Data.Vector ( Vector ) -import Data.Word -import Foreign.C -import Foreign.ForeignPtr -import Foreign.Marshal -import Foreign.Ptr -import Foreign.Storable -import GHC.ForeignPtr ( mallocPlainForeignPtrAlignedBytes ) -import GHC.Prim ( addr2Int#, int2Word# ) -import GHC.Ptr ( Ptr(..) ) -import GHC.Word ( Word64(..) ) -import System.IO.Unsafe -import System.Posix.DynamicLinker -import Text.Printf -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Internal as B -import qualified Data.ByteString.Short as BS -import qualified Data.ByteString.Unsafe as B -import qualified Data.Vector as V -import Prelude as P - -#include -#include - - --- Dynamic object loading --- ---------------------- - --- Load an ELF object file and return pointers to the executable functions --- defined within. The executable sections are aligned appropriately, as --- specified in the object file, and are ready to be executed on the target --- architecture. --- -loadObject :: ByteString -> IO (FunctionTable, ObjectCode) -loadObject obj = - case parseObject obj of - Left err -> $internalError "loadObject" err - Right (secs, symbols, relocs, strtab) -> do - -- Load the sections into executable memory - -- - (funtab, oc) <- loadSegment obj strtab secs symbols relocs - - -- The executable pages are allocated on the GC heap. When the pages are - -- finalised, unset the executable bit and mark them as read/write so that - -- they can be reused - -- - objectcode <- newLifetime [oc] - addFinalizer objectcode $ do - Debug.traceIO Debug.dump_gc ("gc: unload module: " ++ show funtab) - case oc of - Segment vmsize oc_fp -> do - withForeignPtr oc_fp $ \oc_p -> do - mprotect oc_p vmsize ({#const PROT_READ#} .|. {#const PROT_WRITE#}) - - return (funtab, objectcode) - - --- Load the sections into memory. --- --- Extra jump islands are added directly after the section data. On x86_64 --- PC-relative jumps and accesses to the global offset table are limited to --- 32-bits (+-2GB). If we need to go outside of this range than we must do so --- via the jump islands. --- --- NOTE: This puts all the sections into a single block of memory. Technically --- this is incorrect because we then have both text and data sections together, --- meaning that data sections are marked as execute when they really shouldn't --- be. These would need to live in different pages in order to be mprotect-ed --- properly. --- -loadSegment - :: ByteString - -> ByteString - -> Vector SectionHeader - -> Vector Symbol - -> Vector Relocation - -> IO (FunctionTable, Segment) -loadSegment obj strtab secs symtab relocs = do - let - pagesize = fromIntegral c_getpagesize - - -- round up to next multiple of given alignment - pad align n = (n + align - 1) .&. (complement (align - 1)) - - -- determine where each section should be placed in memory, respecting - -- alignment requirements. SectionHeaders which do not correspond to - -- program data (e.g. systab) just carry along the previous offset value. - -- This is to avoid filtering the list of sections, so that section - -- indices (e.g. in relocations) remain valid. - -- - nsecs = V.length secs - offsets = V.constructN (nsecs + 1) $ \v -> - case V.length v of - 0 -> 0 - n -> let this = secs V.! n - prev = secs V.! (n-1) - alloc s = testBit (sh_flags s) 1 -- SHF_ALLOC: section occupies memory at execution? - -- - align | n >= nsecs = 16 - | not (alloc this) = 1 - | otherwise = sh_align this - -- - size | alloc prev = sh_size prev - | otherwise = 0 - in - pad align (size + v V.! (n-1)) - - -- The section at index `i` should place its data beginning at page boundary - -- offset given by offsets!i. - -- - vmsize' = V.last offsets -- bytes required to store all sections - vmsize = pad pagesize (vmsize' + (V.length symtab * 16)) -- sections + jump tables - -- - seg_fp <- mallocPlainForeignPtrAlignedBytes vmsize pagesize - funtab <- withForeignPtr seg_fp $ \seg_p -> do - -- Just in case, clear out the segment data (corresponds to NOP). - -- This also takes care of .bss sections - fillBytes seg_p 0 vmsize - - -- Jump tables are placed directly after the segment data - let jump_p = seg_p `plusPtr` vmsize' - V.imapM_ (makeJumpIsland jump_p) symtab - - -- Copy over section data - V.izipWithM_ (loadSection obj strtab seg_p) offsets secs - - -- Process relocations - V.mapM_ (processRelocation symtab offsets seg_p jump_p) relocs - - -- Mark the page as executable and read-only - mprotect seg_p vmsize ({#const PROT_READ#} .|. {#const PROT_EXEC#}) - - -- Resolve external symbols defined in the sections into function - -- pointers. - -- - -- Note that in order to support ahead-of-time compilation, the - -- generated functions are given unique names by appending with an - -- underscore followed by a 16-digit unique ID. The execution - -- phase doesn't need to know about this however, so un-mangle the - -- name to the basic "map", "fold", etc. - -- - let extern Symbol{..} = sym_binding == Global && sym_type == Func - resolve Symbol{..} = - let name = BS.toShort (B8.take (B8.length sym_name - 17) sym_name) - addr = castPtrToFunPtr (seg_p `plusPtr` (fromIntegral sym_value + offsets V.! sym_section)) - in - (name, addr) - return $ FunctionTable $ V.toList (V.map resolve (V.filter extern symtab)) - -- - return (funtab, Segment vmsize seg_fp) - - --- Add the jump-table entries directly to each external undefined symbol. --- -makeJumpIsland :: Ptr Word8 -> Int -> Symbol -> IO () -makeJumpIsland jump_p symbolnum Symbol{..} = do -#ifdef x86_64_HOST_ARCH - when (sym_binding == Global && sym_section == 0) $ do - let - target = jump_p `plusPtr` (symbolnum * 16) :: Ptr Word64 -- addr - instr = target `plusPtr` 8 :: Ptr Word8 -- jumpIsland - -- - poke target sym_value - pokeArray instr [ 0xFF, 0x25, 0xF2, 0xFF, 0xFF, 0xFF ] -- jmp *-14(%rip) -#endif - return () - - --- Load the section at the correct offset into the given segment --- -loadSection :: ByteString -> ByteString -> Ptr Word8 -> Int -> Int -> SectionHeader -> IO () -loadSection obj strtab seg_p sec_num sec_addr SectionHeader{..} = - when (sh_type == ProgBits && sh_size > 0) $ do - message (printf "section %d: Mem: 0x%09x-0x%09x %s" sec_num sec_addr (sec_addr+sh_size) (B8.unpack (indexStringTable strtab sh_name))) - let (obj_fp, obj_offset, _) = B.toForeignPtr obj - -- - withForeignPtr obj_fp $ \obj_p -> do - -- Copy this section's data to the appropriate place in the segment - let src = obj_p `plusPtr` (obj_offset + sh_offset) - dst = seg_p `plusPtr` sec_addr - -- - copyBytes dst src sh_size - - --- Process local and external relocations. --- -processRelocation :: 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=%s, value=%s%+d" r_offset r_symbol r_section (show r_type) (B8.unpack sym_name) r_addend) - case r_type of - R_X86_64_None -> return () - R_X86_64_64 -> relocate (fromIntegral symval + r_addend) - R_X86_64_PC32 -> - let offset = fromIntegral symval + r_addend - fromIntegral pc' in - if offset >= 0x7fffffff || offset < -0x80000000 - then do - let jump' = castPtrToWord64 (jump_p `plusPtr` (r_symbol * 16 + 8)) - offset' = fromIntegral jump' + r_addend - fromIntegral pc' - relocate offset' - else - relocate offset - - R_X86_64_PC64 -> - let offset = fromIntegral symval + r_addend - fromIntegral pc' in - relocate offset - - R_X86_64_32 -> - let value = symval + fromIntegral r_addend in - if value >= 0x7fffffff - then do - let jump' = castPtrToWord64 (jump_p `plusPtr` (r_symbol * 16 + 8)) - value' = fromIntegral jump' + r_addend - relocate value' - else - relocate (fromIntegral value) - - R_X86_64_32S -> - let value = fromIntegral symval + r_addend in - if value >= 0x7fffffff || value < -0x80000000 - then do - let jump' = castPtrToWord64 (jump_p `plusPtr` (r_symbol * 16 + 8)) - value' = fromIntegral jump' + r_addend - relocate value' - else - relocate value - - where - pc :: Ptr Word8 - pc = seg_p `plusPtr` (fromIntegral r_offset + sec_offset V.! r_section) - pc' = castPtrToWord64 pc - - symval :: Word64 - symval = - case sym_binding of - Local -> castPtrToWord64 (seg_p `plusPtr` (sec_offset V.! sym_section + fromIntegral sym_value)) - Global -> sym_value - Weak -> $internalError "processRelocation" "unhandled weak symbol" - - Symbol{..} = symtab V.! r_symbol - - relocate :: Int64 -> IO () - relocate x = poke (castPtr pc :: Ptr Word32) (fromIntegral x) - -#else -precessRelocation = - $internalError "processRelocation" "not defined for non-x86_64 architectures yet" -#endif - - --- Object file parser --- ------------------ - --- Parse an ELF object file and return the set of section load commands, as well --- as the symbols defined within the sections of the object. --- --- Actually loading the sections into executable memory happens separately. --- -parseObject :: 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)" - - -- Read the object file headers - secs <- runGet (V.replicateM (tb_entries tsec) (readSectionHeader p)) (B.drop (tb_fileoff tsec) obj) - strtab <- readStringTable obj (secs V.! strix) - - let symtab = V.toList . V.filter (\s -> sh_type s == SymTab) - reloc = V.toList . V.filter (\s -> sh_type s == Rel || sh_type s == RelA) - - symbols <- V.concat <$> sequence [ readSymbolTable p secs obj sh | sh <- symtab secs ] - relocs <- V.concat <$> sequence [ readRelocations p obj sh | sh <- reloc secs ] - - return (secs, symbols, relocs, strtab) - - --- Parsing depends on whether the ELF file is 64-bit and whether it should be --- read as big- or little-endian. --- -data Peek = Peek - { is64Bit :: !Bool - , getWord16 :: !(Get Word16) - , getWord32 :: !(Get Word32) - , getWord64 :: !(Get Word64) - } - -data Table = Table - { tb_fileoff :: {-# UNPACK #-} !Int -- byte offset to start of table (array) - , tb_entries :: {-# UNPACK #-} !Int -- number of entries in the table (array) - , tb_entrysize :: {-# UNPACK #-} !Int -- size in bytes per entry - } - -{-- -data ProgramHeader = ProgramHeader - { prog_vmaddr :: {-# UNPACK #-} !Int -- virtual address - , prog_vmsize :: {-# UNPACK #-} !Int -- size in memory - , prog_fileoff :: {-# UNPACK #-} !Int -- file offset - , prog_filesize :: {-# UNPACK #-} !Int -- size in file - , prog_align :: {-# UNPACK #-} !Int -- alignment - , prog_paddr :: {-# UNPACK #-} !Int -- physical address - } ---} - -data SectionHeader = SectionHeader - { sh_name :: {-# UNPACK #-} !Int -- string table index - , sh_addr :: {-# UNPACK #-} !Word64 -- virtual memory address - , sh_size :: {-# UNPACK #-} !Int -- section size in bytes - , sh_offset :: {-# UNPACK #-} !Int -- file offset in bytes - , sh_align :: {-# UNPACK #-} !Int - , sh_link :: {-# UNPACK #-} !Int - , sh_info :: {-# UNPACK #-} !Int -- additional section info - , sh_entsize :: {-# UNPACK #-} !Int -- entry size, if section holds table - , sh_flags :: {-# UNPACK #-} !Word64 - , sh_type :: !SectionType - } - deriving Show - -{#enum define SectionType - { SHT_NULL as NullSection - , SHT_PROGBITS as ProgBits - , SHT_SYMTAB as SymTab - , SHT_STRTAB as StrTab - , SHT_RELA as RelA - , SHT_HASH as Hash - , SHT_DYNAMIC as Dynamic - , SHT_NOTE as Note - , SHT_NOBITS as NoBits - , SHT_REL as Rel - , SHT_DYNSYM as DynSym - } - deriving (Eq, Show) -#} - -data Symbol = Symbol - { sym_name :: {-# UNPACK #-} !ByteString - , sym_value :: {-# UNPACK #-} !Word64 - , sym_section :: {-# UNPACK #-} !Int - , sym_binding :: !SymbolBinding - , sym_type :: !SymbolType - } - deriving Show - -{#enum define SymbolBinding - { STB_LOCAL as Local - , STB_GLOBAL as Global - , STB_WEAK as Weak - } - deriving (Eq, Show) -#} - -{#enum define SymbolType - { STT_NOTYPE as NoType - , STT_OBJECT as Object -- data object - , STT_FUNC as Func -- function object - , STT_SECTION as Section - , STT_FILE as File - , STT_COMMON as Common - , STT_TLS as TLS - } - deriving (Eq, Show) -#} - -data Relocation = Relocation - { r_offset :: {-# UNPACK #-} !Word64 - , r_symbol :: {-# UNPACK #-} !Int - , r_section :: {-# UNPACK #-} !Int - , r_addend :: {-# UNPACK #-} !Int64 - , r_type :: !RelocationType - } - deriving Show - -#ifdef i386_HOST_ARCH -{#enum define RelocationType - { R_386_NONE as R_386_None - , R_386_32 as R_386_32 - , R_386_PC32 as R_386_PC32 - } - deriving (Eq, Show) -#} -#endif -#ifdef x86_64_HOST_ARCH -{#enum define RelocationType - { R_X86_64_NONE as R_X86_64_None -- no relocation - , R_X86_64_64 as R_X86_64_64 -- direct 64-bit - , R_X86_64_PC32 as R_X86_64_PC32 -- PC relative 32-bit signed - , R_X86_64_PC64 as R_X86_64_PC64 -- PC relative 64-bit - , R_X86_64_32 as R_X86_64_32 -- direct 32-bit zero extended - , R_X86_64_32S as R_X86_64_32S -- direct 32-bit sign extended - -- ... many more relocation types - } - deriving (Eq, Show) -#} -#endif - --- The ELF file header appears at the start of every file. --- -readHeader :: Get (Peek, Table, Table, Int) -readHeader = do - p@Peek{..} <- readIdent - (_, phs, secs, shstr) <- case is64Bit of - True -> readHeader64 p - False -> readHeader32 p - return (p, phs, secs, shstr) - - -readHeader32 :: Peek -> Get (Int, Table, Table, Int) -readHeader32 _ = fail "TODO: readHeader32" - -readHeader64 :: Peek -> Get (Int, Table, Table, Int) -readHeader64 p@Peek{..} = do - readType p - readMachine p - skip {#sizeof Elf64_Word#} -- e_version - e_entry <- getWord64 -- entry point virtual address (page offset?) - e_phoff <- getWord64 -- program header table file offset - e_shoff <- getWord64 -- section header table file offset - skip ({#sizeof Elf64_Word#}+{#sizeof Elf64_Half#}) -- e_flags + e_ehsize - e_phentsize <- getWord16 -- byte size per program header entry - e_phnum <- getWord16 -- #program header entries - e_shentsize <- getWord16 - e_shnum <- getWord16 - e_shstrndx <- getWord16 - return ( fromIntegral e_entry - , Table { tb_fileoff = fromIntegral e_phoff, tb_entries = fromIntegral e_phnum, tb_entrysize = fromIntegral e_phentsize } - , Table { tb_fileoff = fromIntegral e_shoff, tb_entries = fromIntegral e_shnum, tb_entrysize = fromIntegral e_shentsize } - , fromIntegral e_shstrndx - ) - - -readIdent :: Get Peek -readIdent = do - ei_magic <- getBytes 4 - unless (ei_magic == B8.pack [chr {#const ELFMAG0#}, {#const ELFMAG1#}, {#const ELFMAG2#}, {#const ELFMAG3#}]) $ - fail "invalid magic number" - - ei_class <- getWord8 - is64Bit <- case ei_class of - {#const ELFCLASS32#} -> return False - {#const ELFCLASS64#} -> return True - _ -> fail "invalid class" - ei_data <- getWord8 - p <- case ei_data of - {#const ELFDATA2LSB#} -> return $ Peek { getWord16 = getWord16le, getWord32 = getWord32le, getWord64 = getWord64le, .. } - {#const ELFDATA2MSB#} -> return $ Peek { getWord16 = getWord16be, getWord32 = getWord32be, getWord64 = getWord64be, .. } - _ -> fail "invalid data layout" - ei_version <- getWord8 - unless (ei_version == {#const EV_CURRENT#}) $ fail "invalid version" - skip (1+1+{#const EI_NIDENT#}-{#const EI_PAD#}) -- ABI, ABI version, padding - return p - - -readType :: Peek -> Get () -readType Peek{..} = do - e_type <- getWord16 - case e_type of - {#const ET_REL#} -> return () - _ -> fail "expected relocatable object file" - -readMachine :: Peek -> Get () -readMachine Peek{..} = do - e_machine <- getWord16 - case e_machine of -#ifdef i386_HOST_ARCH - {#const EM_386#} -> return () -#endif -#ifdef x86_64_HOST_ARCH - {#const EM_X86_64#} -> return () -#endif - _ -> fail "expected host architecture object file" - - -{-- --- Program headers define how the ELF program behaves once it has been loaded, --- as well as runtime linking information. --- --- TLM: Since we are loading object files we shouldn't get any program headers. --- -readProgramHeader :: Peek -> Get ProgramHeader -readProgramHeader p@Peek{..} = - case is64Bit of - True -> readProgramHeader64 p - False -> readProgramHeader32 p - -readProgramHeader32 :: Peek -> Get ProgramHeader -readProgramHeader32 _ = fail "TODO: readProgramHeader32" - -readProgramHeader64 :: Peek -> Get ProgramHeader -readProgramHeader64 _ = fail "TODO: readProgramHeader64" ---} - --- Section headers contain information such as the section name, size, and --- location in the object file. The list of all the section headers in the ELF --- file is known as the section header table. --- -readSectionHeader :: Peek -> Get SectionHeader -readSectionHeader p@Peek{..} = - case is64Bit of - True -> readSectionHeader64 p - False -> readSectionHeader32 p - -readSectionHeader32 :: Peek -> Get SectionHeader -readSectionHeader32 _ = fail "TODO: readSectionHeader32" - -readSectionHeader64 :: Peek -> Get SectionHeader -readSectionHeader64 Peek{..} = do - sh_name <- fromIntegral <$> getWord32 - sh_type <- toEnum . fromIntegral <$> getWord32 - sh_flags <- getWord64 - sh_addr <- getWord64 - sh_offset <- fromIntegral <$> getWord64 - sh_size <- fromIntegral <$> getWord64 - sh_link <- fromIntegral <$> getWord32 - sh_info <- fromIntegral <$> getWord32 - sh_align <- fromIntegral <$> getWord64 - sh_entsize <- fromIntegral <$> getWord64 - return SectionHeader {..} - - -indexStringTable :: ByteString -> Int -> ByteString -indexStringTable strtab ix = B.takeWhile (/= 0) (B.drop ix strtab) - -readStringTable :: ByteString -> SectionHeader -> Either String ByteString -readStringTable obj SectionHeader{..} = - case sh_type of - StrTab -> Right $ B.take sh_size (B.drop sh_offset obj) - _ -> Left "expected string table" - - -readRelocations :: Peek -> ByteString -> SectionHeader -> Either String (Vector Relocation) -readRelocations p@Peek{..} obj SectionHeader{..} = do - unless (sh_type == Rel || sh_type == RelA) $ fail "expected relocation section" - -- - let nrel = sh_size `quot` sh_entsize - runGet (V.replicateM nrel (readRel p sh_type sh_info)) (B.drop sh_offset obj) - - -readRel :: Peek -> SectionType -> Int -> Get Relocation -readRel p@Peek{..} sh_type r_section = - case is64Bit of - True -> readRel64 p sh_type r_section - False -> readRel32 p sh_type r_section - -readRel32 :: Peek -> SectionType -> Int -> Get Relocation -readRel32 _ _ _ = fail "TODO: readRel32" - -readRel64 :: Peek -> SectionType -> Int -> Get Relocation -readRel64 Peek{..} sh_type r_section = do - r_offset <- getWord64 - r_info <- getWord64 - r_addend <- case sh_type of - RelA -> fromIntegral <$> getWord64 - _ -> return 0 - let r_type = toEnum (fromIntegral (r_info .&. 0xffffffff)) - r_symbol = fromIntegral (r_info `shiftR` 32) - 1 - -- - return Relocation {..} - - -readSymbolTable :: Peek -> Vector SectionHeader -> ByteString -> SectionHeader -> Either String (Vector Symbol) -readSymbolTable p@Peek{..} secs obj SectionHeader{..} = do - unless (sh_type == SymTab) $ fail "expected symbol table" - - let nsym = sh_size `quot` sh_entsize - offset = sh_offset + sh_entsize -- First symbol in the table is always null; skip it. - -- Make sure to update relocation indices - strtab <- readStringTable obj (secs V.! sh_link) - symbols <- runGet (V.replicateM (nsym-1) (readSymbol p strtab)) (B.drop offset obj) - return symbols - -readSymbol :: Peek -> ByteString -> Get Symbol -readSymbol p@Peek{..} strtab = - case is64Bit of - True -> readSymbol64 p strtab - False -> readSymbol32 p strtab - -readSymbol32 :: Peek -> ByteString -> Get Symbol -readSymbol32 _ _ = fail "TODO: readSymbol32" - -readSymbol64 :: Peek -> ByteString -> Get Symbol -readSymbol64 Peek{..} strtab = do - st_strx <- fromIntegral <$> getWord32 - st_info <- getWord8 - skip 1 -- st_other <- getWord8 - sym_section <- fromIntegral <$> getWord16 - sym_value <- getWord64 - skip 8 -- st_size <- getWord64 - - let sym_name | st_strx == 0 = B.empty - | otherwise = indexStringTable strtab st_strx - - sym_binding = toEnum $ fromIntegral ((st_info .&. 0xF0) `shiftR` 4) - sym_type = toEnum $ fromIntegral (st_info .&. 0x0F) - - case sym_section of - -- External symbol; lookup value - {#const SHN_UNDEF#} | not (B.null sym_name) -> do - funptr <- resolveSymbol sym_name - message (printf "%s: external symbol found at %s" (B8.unpack sym_name) (show funptr)) - return Symbol { sym_value = castPtrToWord64 (castFunPtrToPtr funptr), .. } - - -- Internally defined symbol - n | n < {#const SHN_LORESERVE#} -> do - message (printf "%s: local symbol in section %d at 0x%02x" (B8.unpack sym_name) sym_section sym_value) - return Symbol {..} - - {#const SHN_ABS#} | sym_type == File -> return Symbol {..} - {#const SHN_ABS#} -> fail "unhandled absolute symbol" - _ -> fail "unhandled symbol section" - - --- Return the address binding the named symbol --- -resolveSymbol :: ByteString -> Get (FunPtr ()) -resolveSymbol name - = unsafePerformIO - $ B.unsafeUseAsCString name $ \c_name -> do - addr <- c_dlsym (packDL Next) c_name - if addr == nullFunPtr - then do - err <- dlerror - return (fail $ printf "failed to resolve symbol %s: %s" (B8.unpack name) err) - else do - return (return addr) - - --- Utilities --- --------- - --- Get the address of a pointer as a Word64 --- -castPtrToWord64 :: Ptr a -> Word64 -castPtrToWord64 (Ptr addr#) = W64# (int2Word# (addr2Int# addr#)) - - --- c-bits --- ------ - --- Control the protection of pages --- -mprotect :: Ptr Word8 -> Int -> Int -> IO () -mprotect addr len prot - = throwErrnoIfMinus1_ "mprotect" - $ c_mprotect (castPtr addr) (fromIntegral len) (fromIntegral prot) - -foreign import ccall unsafe "mprotect" - c_mprotect :: Ptr () -> CSize -> CInt -> IO CInt - -foreign import ccall unsafe "getpagesize" - c_getpagesize :: CInt - -#if __GLASGOW_HASKELL__ <= 708 --- Fill a given number of bytes in memory. Added in base-4.8.0.0. --- -fillBytes :: Ptr a -> Word8 -> Int -> IO () -fillBytes dest char size = do - _ <- memset dest (fromIntegral char) (fromIntegral size) - return () - -foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO (Ptr a) -#endif - - --- Debug --- ----- - -{-# INLINE trace #-} -trace :: String -> a -> a -trace msg = Debug.trace Debug.dump_ld ("ld: " ++ msg) - -{-# INLINE message #-} -message :: Monad m => String -> m () -message msg = trace msg (return ()) - diff --git a/Data/Array/Accelerate/LLVM/Native/Link/MachO.chs b/Data/Array/Accelerate/LLVM/Native/Link/MachO.chs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/Link/MachO.chs +++ /dev/null @@ -1,746 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} --- | --- Module : Data.Array.Accelerate.LLVM.Native.Link.MachO --- Copyright : [2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.Native.Link.MachO ( - - loadObject, - -) where - -import Data.Array.Accelerate.Error -import Data.Array.Accelerate.LLVM.Native.Link.Object -import Data.Array.Accelerate.Lifetime -import qualified Data.Array.Accelerate.Debug as Debug - -import Control.Applicative -import Control.Monad -import Data.Bits -import Data.ByteString ( ByteString ) -import Data.Maybe ( catMaybes ) -import Data.Serialize.Get -import Data.Vector ( Vector ) -import Data.Word -import Foreign.C -import Foreign.ForeignPtr -import Foreign.ForeignPtr.Unsafe -import Foreign.Marshal -import Foreign.Ptr -import Foreign.Storable -import GHC.ForeignPtr ( mallocPlainForeignPtrAlignedBytes ) -import GHC.Prim ( addr2Int#, int2Word# ) -import GHC.Ptr ( Ptr(..) ) -import GHC.Word ( Word64(..) ) -import System.IO.Unsafe -import System.Posix.DynamicLinker -import Text.Printf -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Internal as B -import qualified Data.ByteString.Short as BS -import qualified Data.ByteString.Unsafe as B -import qualified Data.Vector as V -import Prelude as P - -#include -#include -#include -#include -#include -#ifdef x86_64_HOST_ARCH -#include -#endif -#ifdef powerpc_HOST_ARCH -#include -#endif - - --- Dynamic object loading --- ---------------------- - --- Load a Mach-O object file and return pointers to the executable functions --- defined within. The executable sections are aligned appropriately, as --- specified in the object file, and are ready to be executed on the target --- architecture. --- -loadObject :: ByteString -> IO (FunctionTable, ObjectCode) -loadObject obj = - case parseObject obj of - Left err -> $internalError "loadObject" 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 obj symtab lcs = do - -- Load the segments into executable memory. - -- - segs <- V.mapM (loadSegment obj symtab) lcs - - -- Resolve the external symbols defined in the sections of this object into - -- function pointers. - -- - -- Note that in order to support ahead-of-time compilation, the generated - -- functions are given unique names by appending with an underscore followed - -- by a 16-digit unique ID. The execution phase doesn't need to know about - -- this however, so un-mangle the name to the basic "map", "fold", etc. - -- - let extern Symbol{..} = sym_extern && sym_segment > 0 - resolve Symbol{..} = - let Segment _ fp = segs V.! (fromIntegral (sym_segment-1)) - name = BS.toShort (B8.take (B8.length sym_name - 17) sym_name) - addr = castPtrToFunPtr (unsafeForeignPtrToPtr fp `plusPtr` fromIntegral sym_value) - in - (name, addr) - -- - funtab = FunctionTable $ V.toList $ V.map resolve (V.filter extern symtab) - objectcode = V.toList segs - - -- The executable pages were allocated on the GC heap. When the pages are - -- finalised, unset the executable bit and mark them as read/write so that - -- they can be reused. - -- - objectcode' <- newLifetime objectcode - addFinalizer objectcode' $ do - Debug.traceIO Debug.dump_gc ("gc: unload module: " ++ show funtab) - forM_ objectcode $ \(Segment vmsize oc_fp) -> do - withForeignPtr oc_fp $ \oc_p -> do - mprotect oc_p vmsize ({#const PROT_READ#} .|. {#const PROT_WRITE#}) - - return (funtab, objectcode') - - --- Load a segment and all its sections into memory. --- --- Extra jump islands are added directly after the segment. On x86_64 --- PC-relative jumps and accesses to the global offset table (GOT) are limited --- to 32-bit (+-2GB). If we need to go outside of this range then we must do so --- via the jump islands. --- --- NOTE: This puts all the sections into a single block of memory. Technically --- this is incorrect because we then have both text and data sections together, --- meaning that data sections are marked as execute when they really shouldn't --- be. These would need to live in different pages in order to be mprotect-ed --- properly. --- -loadSegment :: ByteString -> Vector Symbol -> LoadSegment -> IO Segment -loadSegment obj symtab seg@LoadSegment{..} = do - let - pagesize = fromIntegral c_getpagesize - - -- round up to next multiple of given alignment - pad align n = (n + align - 1) .&. (complement (align - 1)) - - seg_vmsize' = pad 16 seg_vmsize -- align jump islands to 16 bytes - segsize = pad pagesize (seg_vmsize' + (V.length symtab * 16)) -- jump entries are 16 bytes each (x86_64) - -- - seg_fp <- mallocPlainForeignPtrAlignedBytes segsize pagesize - _ <- withForeignPtr seg_fp $ \seg_p -> do - -- Just in case, clear out the segment data (corresponds to NOP) - fillBytes seg_p 0 segsize - - -- Jump tables are placed directly after the segment data - let jump_p = seg_p `plusPtr` seg_vmsize' - V.imapM_ (makeJumpIsland jump_p) symtab - - -- Process each of the sections of this segment - V.mapM_ (loadSection obj symtab seg seg_p jump_p) seg_sections - - -- Mark the page as executable and read-only - mprotect seg_p segsize ({#const PROT_READ#} .|. {#const PROT_EXEC#}) - -- - return (Segment segsize seg_fp) - - --- Add the jump-table entries directly to each external undefined symbol. --- -makeJumpIsland :: Ptr Word8 -> Int -> Symbol -> IO () -makeJumpIsland jump_p symbolnum Symbol{..} = do -#ifdef x86_64_HOST_ARCH - when (sym_extern && sym_segment == 0) $ do - let - target = jump_p `plusPtr` (symbolnum * 16) :: Ptr Word64 - instr = target `plusPtr` 8 :: Ptr Word8 - -- - poke target sym_value - pokeArray instr [ 0xFF, 0x25, 0xF2, 0xFF, 0xFF, 0xFF ] -- jmp *-14(%rip) -#endif - return () - - --- Load a section at the correct offset into the given segment, and apply --- relocations. --- -loadSection :: ByteString -> Vector Symbol -> LoadSegment -> Ptr Word8 -> Ptr Word8 -> LoadSection -> IO () -loadSection obj symtab seg seg_p jump_p sec@LoadSection{..} = do - let (obj_fp, obj_offset, _) = B.toForeignPtr obj - -- - withForeignPtr obj_fp $ \obj_p -> do - -- Copy this section's data to the appropriate place in the segment - let src = obj_p `plusPtr` (obj_offset + sec_offset) - dst = seg_p `plusPtr` sec_addr - -- - copyBytes dst src sec_size - V.mapM_ (processRelocation symtab seg seg_p jump_p sec) sec_relocs - - --- Process both local and external relocations. The former are probably not --- necessary since we load all sections into the same memory segment at the --- correct offsets. --- -processRelocation :: Vector Symbol -> LoadSegment -> Ptr Word8 -> Ptr Word8 -> LoadSection -> RelocationInfo -> IO () -#ifdef x86_64_HOST_ARCH -processRelocation symtab LoadSegment{..} seg_p jump_p sec RelocationInfo{..} - -- Relocation through global offset table - -- - | ri_type == X86_64_RELOC_GOT || - ri_type == X86_64_RELOC_GOT_LOAD - = $internalError "processRelocation" "Global offset table relocations not handled yet" - - -- External symbols, both those defined in the sections of this object, and - -- undefined externals. For the latter, the symbol might be outside of the - -- range of 32-bit pc-relative addressing, in which case we need to go via the - -- jump tables. - -- - | ri_extern - = let value = sym_value (symtab V.! ri_symbolnum) - value_rel = value - pc' - 2 ^ ri_length -- also subtract size of instruction from PC - in - case ri_pcrel of - False -> relocate value - True -> if (fromIntegral (fromIntegral value_rel::Word32) :: Word64) == value_rel - then relocate value_rel - else do - let value' = castPtrToWord64 (jump_p `plusPtr` (ri_symbolnum * 16 + 8)) - value'_rel = value' - pc' - 2 ^ ri_length - -- - -- message (printf "relocating %s via jump table" (B8.unpack (sym_name (symtab V.! ri_symbolnum)))) - relocate value'_rel - - -- Internal relocation (to constant sections, for example). Since the sections - -- are loaded at the appropriate offsets in a single contiguous segment, this - -- is unnecessary. - -- - | otherwise - = return () - - where - pc :: Ptr Word8 - pc = seg_p `plusPtr` (sec_addr sec + ri_address) - pc' = castPtrToWord64 pc - - -- Include the addend value already encoded in the instruction - addend :: (Integral a, Storable a) => Ptr a -> Word64 -> IO a - addend p x = do - base <- peek p - case ri_type of - X86_64_RELOC_SUBTRACTOR -> return $ fromIntegral (fromIntegral base - x) - _ -> return $ fromIntegral (fromIntegral base + x) - - -- Write the new relocated address - relocate :: Word64 -> IO () - relocate x = - case ri_length of - 0 -> let p' = castPtr pc :: Ptr Word8 in poke p' =<< addend p' x - 1 -> let p' = castPtr pc :: Ptr Word16 in poke p' =<< addend p' x - 2 -> let p' = castPtr pc :: Ptr Word32 in poke p' =<< addend p' x - _ -> $internalError "processRelocation" "unhandled relocation size" - -#else -precessRelocation = - $internalError "processRelocation" "not defined for non-x86_64 architectures yet" -#endif - - --- Object file parser --- ------------------ - --- Parsing depends on whether the Mach-O file is 64-bit and whether it should be --- read as big- or little-endian. --- -data Peek = Peek - { is64Bit :: !Bool - , getWord16 :: !(Get Word16) - , getWord32 :: !(Get Word32) - , getWord64 :: !(Get Word64) - } - --- Load commands directly follow the Mach-O header. --- -data LoadCommand - = LC_Segment {-# UNPACK #-} !LoadSegment - | LC_SymbolTable {-# UNPACK #-} !(Vector Symbol) - --- Indicates that a part of this file is to be mapped into the task's --- address space. The size of the segment in memory, vmsize, must be equal --- to or larger than the amount to map from this file, filesize. The file is --- mapped starting at fileoff to the beginning of the segment in memory, --- vmaddr. If the segment has sections then the section structures directly --- follow the segment command. --- --- For compactness object files contain only one (unnamed) segment, which --- contains all the sections. --- -data LoadSegment = LoadSegment - { seg_name :: {-# UNPACK #-} !ByteString - , seg_vmaddr :: {-# UNPACK #-} !Int -- starting virtual memory address of the segment - , seg_vmsize :: {-# UNPACK #-} !Int -- size (bytes) of virtual memory occupied by the segment - , seg_fileoff :: {-# UNPACK #-} !Int -- offset in the file for the data mapped at 'seg_vmaddr' - , seg_filesize :: {-# UNPACK #-} !Int -- size (bytes) of the segment in the file - , seg_sections :: {-# UNPACK #-} !(Vector LoadSection) -- the sections of this segment - } - deriving Show - -data LoadSection = LoadSection - { sec_secname :: {-# UNPACK #-} !ByteString - , sec_segname :: {-# UNPACK #-} !ByteString - , sec_addr :: {-# UNPACK #-} !Int -- virtual memory address of this section - , sec_size :: {-# UNPACK #-} !Int -- size in bytes - , sec_offset :: {-# UNPACK #-} !Int -- offset of this section in the file - , sec_align :: {-# UNPACK #-} !Int - , sec_relocs :: {-# UNPACK #-} !(Vector RelocationInfo) - } - deriving Show - -data RelocationInfo = RelocationInfo - { ri_address :: {-# UNPACK #-} !Int -- offset from start of the section - , ri_symbolnum :: {-# UNPACK #-} !Int -- index into the symbol table (when ri_extern=True) else section number (??) - , ri_length :: {-# UNPACK #-} !Int -- length of address (bytes) to be relocated - , ri_pcrel :: !Bool -- item containing the address to be relocated uses PC-relative addressing - , ri_extern :: !Bool - , ri_type :: !RelocationType -- type of relocation - } - deriving Show - --- A symbol defined in the sections of this object --- -data Symbol = Symbol - { sym_name :: {-# UNPACK #-} !ByteString - , sym_value :: {-# UNPACK #-} !Word64 - , sym_segment :: {-# UNPACK #-} !Word8 - , sym_extern :: !Bool - } - deriving Show - -#ifdef i386_HOST_ARCH -{# enum reloc_type_generic as RelocationType { } deriving (Eq, Show) #} -#endif -#ifdef x86_64_HOST_ARCH -{# enum reloc_type_x86_64 as RelocationType { } deriving (Eq, Show) #} -#endif -#ifdef powerpc_HOST_ARCH -{# enum reloc_type_ppc as RelocationType { } deriving (Eq, Show) #} -#endif - - --- Parse the Mach-O object file and return the set of section load commands, as --- well as the symbols defined within the sections of this object. --- --- Actually _executing_ the load commands, which entails copying the pointed-to --- segments into an appropriate VM image in the target address space, happens --- separately. --- -parseObject :: ByteString -> Either String (Vector Symbol, Vector LoadSegment) -parseObject obj = do - ((p, ncmd, _), rest) <- runGetState readHeader obj 0 - cmds <- catMaybes <$> runGet (replicateM ncmd (readLoadCommand p obj)) rest - let - lc = [ x | LC_Segment x <- cmds ] - st = [ x | LC_SymbolTable x <- cmds ] - -- - return (V.concat st, V.fromListN ncmd lc) - - --- The Mach-O file consists of a header block, a number of load commands, --- followed by the segment data. --- --- +-------------------+ --- | Mach-O header | --- +-------------------+ <- sizeofheader --- | Load command | --- | Load command | --- | ... | --- +-------------------+ <- sizeofcmds + sizeofheader --- | Segment data | --- | Segment data | --- | ... | --- +-------------------+ --- -readHeader :: Get (Peek, Int, Int) -readHeader = do - magic <- getWord32le - p@Peek{..} <- case magic of - {#const MH_MAGIC#} -> return $ Peek False getWord16le getWord32le getWord64le - {#const MH_CIGAM#} -> return $ Peek False getWord16be getWord32be getWord64be - {#const MH_MAGIC_64#} -> return $ Peek True getWord16le getWord32le getWord64le - {#const MH_CIGAM_64#} -> return $ Peek True getWord16be getWord32be getWord64be - m -> fail (printf "unknown magic: %x" m) - cpu_type <- getWord32 - -- c2HS has trouble with the CPU_TYPE_* macros due to the type cast -#ifdef i386_HOST_ARCH - when (cpu_type /= 0x0000007) $ fail "expected i386 object file" -#endif -#ifdef x86_64_HOST_ARCH - when (cpu_type /= 0x1000007) $ fail "expected x86_64 object file" -#endif -#ifdef powerpc_HOST_ARCH - case is64Bit of - False -> when (cpu_type /= 0x0000012) $ fail "expected PPC object file" - True -> when (cpu_type /= 0x1000012) $ fail "expected PPC64 object file" -#endif - skip {#sizeof cpu_subtype_t#} - filetype <- getWord32 - case filetype of - {#const MH_OBJECT#} -> return () - _ -> fail "expected object file" - ncmds <- fromIntegral <$> getWord32 - sizeofcmds <- fromIntegral <$> getWord32 - skip $ case is64Bit of - True -> 8 -- flags + reserved - False -> 4 -- flags - return (p, ncmds, sizeofcmds) - - --- Read a segment load command from the Mach-O file. --- --- The only thing we are interested in are the symbol table, which tell us which --- external symbols are defined by this object, and the load commands, which --- indicate part of the file is to be mapped into the target address space. --- These will tell us everything we need to know about the generated machine --- code in order to execute it. --- --- Since we are only concerned with loading object files, there should really --- only be one of each of these. --- -readLoadCommand :: Peek -> ByteString -> Get (Maybe LoadCommand) -readLoadCommand p@Peek{..} obj = do - cmd <- getWord32 - cmdsize <- fromIntegral <$> getWord32 - -- - let required = toBool $ cmd .&. {#const LC_REQ_DYLD#} - -- - case cmd .&. (complement {#const LC_REQ_DYLD#}) of - {#const LC_SEGMENT#} -> Just . LC_Segment <$> readLoadSegment p obj - {#const LC_SEGMENT_64#} -> Just . LC_Segment <$> readLoadSegment p obj - {#const LC_SYMTAB#} -> Just . LC_SymbolTable <$> readLoadSymbolTable p obj - {#const LC_DYSYMTAB#} -> const Nothing <$> readDynamicSymbolTable p obj - {#const LC_LOAD_DYLIB#} -> fail "unhandled LC_LOAD_DYLIB" - this -> do if required - then fail (printf "unknown load command required for execution: 0x%x" this) - else message (printf "skipping load command: 0x%x" this) - skip (cmdsize - 8) - return Nothing - - --- Read a load segment command, including any relocation entries. --- -readLoadSegment :: Peek -> ByteString -> Get LoadSegment -readLoadSegment p@Peek{..} obj = - if is64Bit - then readLoadSegment64 p obj - else readLoadSegment32 p obj - -readLoadSegment32 :: Peek -> ByteString -> Get LoadSegment -readLoadSegment32 p@Peek{..} obj = do - name <- B.takeWhile (/= 0) <$> getBytes 16 - vmaddr <- fromIntegral <$> getWord32 - vmsize <- fromIntegral <$> getWord32 - fileoff <- fromIntegral <$> getWord32 - filesize <- fromIntegral <$> getWord32 - skip (2 * {#sizeof vm_prot_t#}) -- maxprot, initprot - nsect <- fromIntegral <$> getWord32 - skip 4 -- flags - -- - message (printf "LC_SEGMENT: Mem: 0x%09x-0x09%x" vmaddr (vmaddr + vmsize)) - secs <- V.replicateM nsect (readLoadSection32 p obj) - -- - return LoadSegment - { seg_name = name - , seg_vmaddr = vmaddr - , seg_vmsize = vmsize - , seg_fileoff = fileoff - , seg_filesize = filesize - , seg_sections = secs - } - -readLoadSegment64 :: Peek -> ByteString -> Get LoadSegment -readLoadSegment64 p@Peek{..} obj = do - name <- B.takeWhile (/= 0) <$> getBytes 16 - vmaddr <- fromIntegral <$> getWord64 - vmsize <- fromIntegral <$> getWord64 - fileoff <- fromIntegral <$> getWord64 - filesize <- fromIntegral <$> getWord64 - skip (2 * {#sizeof vm_prot_t#}) -- maxprot, initprot - nsect <- fromIntegral <$> getWord32 - skip 4 -- flags - -- - message (printf "LC_SEGMENT_64: Mem: 0x%09x-0x%09x" vmaddr (vmaddr + vmsize)) - secs <- V.replicateM nsect (readLoadSection64 p obj) - -- - return LoadSegment - { seg_name = name - , seg_vmaddr = vmaddr - , seg_vmsize = vmsize - , seg_fileoff = fileoff - , seg_filesize = filesize - , seg_sections = secs - } - -readLoadSection32 :: Peek -> ByteString -> Get LoadSection -readLoadSection32 p@Peek{..} obj = do - secname <- B.takeWhile (/= 0) <$> getBytes 16 - segname <- B.takeWhile (/= 0) <$> getBytes 16 - addr <- fromIntegral <$> getWord32 - size <- fromIntegral <$> getWord32 - offset <- fromIntegral <$> getWord32 - align <- fromIntegral <$> getWord32 - reloff <- fromIntegral <$> getWord32 - nreloc <- fromIntegral <$> getWord32 - skip 12 -- flags, reserved1, reserved2 - -- - message (printf " Mem: 0x%09x-0x%09x %s.%s" addr (addr+size) (B8.unpack segname) (B8.unpack secname)) - relocs <- either fail return $ runGet (V.replicateM nreloc (loadRelocation p)) (B.drop reloff obj) - -- - return LoadSection - { sec_secname = secname - , sec_segname = segname - , sec_addr = addr - , sec_size = size - , sec_offset = offset - , sec_align = align - , sec_relocs = relocs - } - -readLoadSection64 :: Peek -> ByteString -> Get LoadSection -readLoadSection64 p@Peek{..} obj = do - secname <- B.takeWhile (/= 0) <$> getBytes 16 - segname <- B.takeWhile (/= 0) <$> getBytes 16 - addr <- fromIntegral <$> getWord64 - size <- fromIntegral <$> getWord64 - offset <- fromIntegral <$> getWord32 - align <- fromIntegral <$> getWord32 - reloff <- fromIntegral <$> getWord32 - nreloc <- fromIntegral <$> getWord32 - skip 16 -- flags, reserved1, reserved2, reserved3 - message (printf " Mem: 0x%09x-0x%09x %s.%s" addr (addr+size) (B8.unpack segname) (B8.unpack secname)) - relocs <- either fail return $ runGet (V.replicateM nreloc (loadRelocation p)) (B.drop reloff obj) - -- - return LoadSection - { sec_secname = secname - , sec_segname = segname - , sec_addr = addr - , sec_size = size - , sec_offset = offset - , sec_align = align - , sec_relocs = relocs - } - -loadRelocation :: Peek -> Get RelocationInfo -loadRelocation Peek{..} = do - addr <- fromIntegral <$> getWord32 - val <- getWord32 - let symbol = val .&. 0xFFFFFF - pcrel = testBit val 24 - extern = testBit val 27 - len = (val `shiftR` 25) .&. 0x3 - rtype = (val `shiftR` 28) .&. 0xF - rtype' = toEnum (fromIntegral rtype) - -- - when (toBool $ addr .&. {#const R_SCATTERED#}) $ fail "unhandled scatted relocation info" - message (printf " Reloc: 0x%04x to %s %d: length=%d, pcrel=%s, type=%s" addr (if extern then "symbol" else "section") symbol len (show pcrel) (show rtype')) - -- - return RelocationInfo - { ri_address = addr - , ri_symbolnum = fromIntegral symbol - , ri_pcrel = pcrel - , ri_extern = extern - , ri_length = fromIntegral len - , ri_type = rtype' - } - - -readLoadSymbolTable :: Peek -> ByteString -> Get (Vector Symbol) -readLoadSymbolTable p@Peek{..} obj = do - symoff <- fromIntegral <$> getWord32 - nsyms <- fromIntegral <$> getWord32 - stroff <- fromIntegral <$> getWord32 - strsize <- getWord32 - message "LC_SYMTAB" - message (printf " symbol table is at offset 0x%x (%d), %d entries" symoff symoff nsyms) - message (printf " string table is at offset 0x%x (%d), %d bytes" stroff stroff strsize) - -- - let symbols = B.drop symoff obj - strtab = B.drop stroff obj - -- - either fail return $ runGet (V.replicateM nsyms (loadSymbol p strtab)) symbols - - -readDynamicSymbolTable :: Peek -> ByteString -> Get () -readDynamicSymbolTable Peek{..} _obj = do -#ifdef ACCELERATE_DEBUG - ilocalsym <- getWord32 - nlocalsym <- getWord32 - iextdefsym <- getWord32 - nextdefsym <- getWord32 - iundefsym <- getWord32 - nundefsym <- getWord32 - skip 4 -- tocoff - ntoc <- getWord32 - skip 4 -- modtaboff - nmodtab <- getWord32 - skip 12 -- extrefsymoff, nextrefsyms, indirectsymoff, - nindirectsyms <- getWord32 - skip 16 -- extreloff, nextrel, locreloff, nlocrel, - message "LC_DYSYMTAB:" - -- - if nlocalsym > 0 - then message (printf " %d local symbols at index %d" nlocalsym ilocalsym) - else message (printf " No local symbols") - if nextdefsym > 0 - then message (printf " %d external symbols at index %d" nextdefsym iextdefsym) - else message (printf " No external symbols") - if nundefsym > 0 - then message (printf " %d undefined symbols at index %d" nundefsym iundefsym) - else message (printf " No undefined symbols") - if ntoc > 0 - then message (printf " %d table of contents entries" ntoc) - else message (printf " No table of contents") - if nmodtab > 0 - then message (printf " %d module table entries" nmodtab) - else message (printf " No module table") - if nindirectsyms > 0 - then message (printf " %d indirect symbols" nindirectsyms) - else message (printf " No indirect symbols") -#else - skip ({#sizeof dysymtab_command#} - 8) -#endif - return () - -loadSymbol :: Peek -> ByteString -> Get Symbol -loadSymbol Peek{..} strtab = do - n_strx <- fromIntegral <$> getWord32 - n_flag <- getWord8 - n_sect <- getWord8 - skip 2 -- n_desc - n_value <- case is64Bit of - True -> fromIntegral <$> getWord64 - False -> fromIntegral <$> getWord32 - - let -- Symbols with string table index zero are defined to have a null - -- name (""). Otherwise, drop the leading underscore. - str | n_strx == 0 = B.empty - | otherwise = B.takeWhile (/= 0) (B.drop n_strx strtab) - name - | B.length str > 0 && B8.head str == '_' = B.tail str - | otherwise = str - - -- Extract the four bit fields of the type flag - -- n_pext = n_flag .&. {#const N_PEXT#} -- private external symbol bit - n_stab = n_flag .&. {#const N_STAB#} -- if any bits set, a symbolic debugging entry - n_type = n_flag .&. {#const N_TYPE#} -- mask for type bits - n_ext = n_flag .&. {#const N_EXT#} -- external symbol bit - - unless (n_stab == 0) $ fail "unhandled symbolic debugging entry (stab)" - - case n_type of - {#const N_UNDF#} -> do - funptr <- resolveSymbol name - message (printf " %s: external symbol found at %s" (B8.unpack name) (show funptr)) - return Symbol - { sym_name = name - , sym_extern = toBool n_ext - , sym_segment = n_sect - , sym_value = castPtrToWord64 (castFunPtrToPtr funptr) - } - - {#const N_SECT#} -> do - message (printf " %s: local symbol in section %d at 0x%02x" (B8.unpack name) n_sect n_value) - return Symbol - { sym_name = name - , sym_extern = toBool n_ext - , sym_segment = n_sect - , sym_value = n_value - } - - {#const N_ABS#} -> fail "unhandled absolute symbol" - {#const N_PBUD#} -> fail "unhandled prebound (dylib) symbol" - {#const N_INDR#} -> fail "unhandled indirect symbol" - _ -> fail "unknown symbol type" - - --- Return the address binding the named symbol --- -resolveSymbol :: ByteString -> Get (FunPtr ()) -resolveSymbol name - = unsafePerformIO - $ B.unsafeUseAsCString name $ \c_name -> do - addr <- c_dlsym (packDL Next) c_name - if addr == nullFunPtr - then do - err <- dlerror - return (fail $ printf "failed to resolve symbol %s: %s" (B8.unpack name) err) - else do - return (return addr) - - --- Utilities --- --------- - --- Get the address of a pointer as a Word64 --- -castPtrToWord64 :: Ptr a -> Word64 -castPtrToWord64 (Ptr addr#) = W64# (int2Word# (addr2Int# addr#)) - - --- C-bits --- ------ - --- Control the protection of pages --- -mprotect :: Ptr Word8 -> Int -> Int -> IO () -mprotect addr len prot - = throwErrnoIfMinus1_ "mprotect" - $ c_mprotect (castPtr addr) (fromIntegral len) (fromIntegral prot) - -foreign import ccall unsafe "mprotect" - c_mprotect :: Ptr () -> CSize -> CInt -> IO CInt - -foreign import ccall unsafe "getpagesize" - c_getpagesize :: CInt - -#if __GLASGOW_HASKELL__ <= 708 --- Fill a given number of bytes in memory. Added in base-4.8.0.0. --- -fillBytes :: Ptr a -> Word8 -> Int -> IO () -fillBytes dest char size = do - _ <- memset dest (fromIntegral char) (fromIntegral size) - return () - -foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO (Ptr a) -#endif - - --- Debug --- ----- - -{-# INLINE trace #-} -trace :: String -> a -> a -trace msg = Debug.trace Debug.dump_ld ("ld: " ++ msg) - -{-# INLINE message #-} -message :: Monad m => String -> m () -message msg = trace msg (return ()) - diff --git a/Data/Array/Accelerate/LLVM/Native/Link/Object.hs b/Data/Array/Accelerate/LLVM/Native/Link/Object.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/Link/Object.hs +++ /dev/null @@ -1,40 +0,0 @@ --- | --- Module : Data.Array.Accelerate.LLVM.Native.Link.Object --- Copyright : [2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.Native.Link.Object - where - -import Data.List -import Data.Word -import Foreign.ForeignPtr -import Foreign.Ptr - -import Data.ByteString.Short.Char8 ( ShortByteString, unpack ) -import Data.Array.Accelerate.Lifetime - - --- | The function table is a list of function names together with a pointer in --- the target address space containing the corresponding executable code. --- -data FunctionTable = FunctionTable { functionTable :: [Function] } -type Function = (ShortByteString, FunPtr ()) - -instance Show FunctionTable where - showsPrec _ f - = showString "<<" - . showString (intercalate "," [ unpack n | (n,_) <- functionTable f ]) - . showString ">>" - --- | Object code consists of memory in the target address space. --- -type ObjectCode = Lifetime [Segment] -data Segment = Segment {-# UNPACK #-} !Int -- size in bytes - {-# UNPACK #-} !(ForeignPtr Word8) -- memory in target address space - diff --git a/Data/Array/Accelerate/LLVM/Native/Plugin.hs b/Data/Array/Accelerate/LLVM/Native/Plugin.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/Plugin.hs +++ /dev/null @@ -1,154 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE RecordWildCards #-} --- | --- Module : Data.Array.Accelerate.LLVM.Native.Plugin --- Copyright : [2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.Native.Plugin ( - - plugin, - -) where - -import GhcPlugins -import Linker -import SysTools - -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 - - --- | This GHC plugin is required to support ahead-of-time compilation for the --- accelerate-llvm-native backend. In particular, it tells GHC about the --- additional object files generated by --- 'Data.Array.Accelerate.LLVM.Native.runQ'* which must be linked into the final --- executable. --- --- To use it, add the following to the .cabal file of your project: --- --- > ghc-options: -fplugin=Data.Array.Accelerate.LLVM.Native.Plugin --- -plugin :: Plugin -plugin = defaultPlugin - { installCoreToDos = install - } - -install :: [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 guts = do - -- Determine the current build environment - -- - hscEnv <- getHscEnv - dynFlags <- getDynFlags - this <- getModule - - -- Gather annotations for the extra object files which must be supplied to the - -- linker in order to complete the current module. - -- - paths <- nub . concat <$> mapM (objectPaths guts) (mg_binds guts) - - when (not (null paths)) - $ debugTraceMsg - $ hang (text "Data.Array.Accelerate.LLVM.Native.Plugin: linking module" <+> quotes (pprModule this) <+> text "with:") 2 (vcat (map text paths)) - - -- The linking method depends on the current build target - -- - case hscTarget dynFlags of - HscNothing -> return () - HscInterpreted -> - -- We are in interactive mode (ghci) - -- - when (not (null paths)) . liftIO $ do - let opts = ldInputs dynFlags - objs = map optionOfPath paths - -- - linkCmdLineLibs -#if __GLASGOW_HASKELL__ < 800 - $ dynFlags { ldInputs = opts ++ objs } -#else - $ hscEnv { hsc_dflags = dynFlags { ldInputs = opts ++ objs }} -#endif - - -- We are building to object code. - -- - -- Because of separate compilation, we will only encounter the annotation - -- pragmas on files which have changed between invocations. This applies to - -- both @ghc --make@ as well as the separate compile/link phases of building - -- with @cabal@ (and @stack@). Note that whenever _any_ file is updated we - -- must make sure that the linker options contains the complete list of - -- objects required to build the entire project. - -- - _ -> liftIO $ do - - -- Read the object file index and update (we may have added or removed - -- objects for the given module) - -- - let buildInfo = mkBuildInfoFileName (objectMapPath dynFlags) - abi <- readBuildInfo buildInfo - -- - let abi' = if null paths - then Map.delete this abi - else Map.insert this paths abi - allPaths = nub (concat (Map.elems abi')) - allObjs = map optionOfPath allPaths - -- - writeBuildInfo buildInfo abi' - - -- Make sure the linker flags are up-to-date. - -- - when (not (isNoLink (ghcLink dynFlags))) $ do - linker_info <- getLinkerInfo dynFlags - writeIORef (rtldInfo dynFlags) - $ Just - $ case linker_info of - GnuLD opts -> GnuLD (nub (opts ++ allObjs)) - GnuGold opts -> GnuGold (nub (opts ++ allObjs)) - DarwinLD opts -> DarwinLD (nub (opts ++ allObjs)) - SolarisLD opts -> SolarisLD (nub (opts ++ allObjs)) -#if __GLASGOW_HASKELL__ >= 800 - AixLD opts -> AixLD (nub (opts ++ allObjs)) -#endif - UnknownLD -> UnknownLD -- no linking performed? - - return () - - return guts - -objectPaths :: ModGuts -> CoreBind -> CoreM [FilePath] -objectPaths guts (NonRec b _) = objectAnns guts b -objectPaths guts (Rec bs) = concat <$> mapM (objectAnns guts) (map fst bs) - -objectAnns :: ModGuts -> CoreBndr -> CoreM [FilePath] -objectAnns guts bndr = do - anns <- getAnnotations deserializeWithData guts - return [ path | Object path <- lookupWithDefaultUFM anns [] (varUnique bndr) ] - -objectMapPath :: DynFlags -> FilePath -objectMapPath DynFlags{..} - | Just p <- objectDir = p - | Just p <- dumpDir = p - | otherwise = "." - -optionOfPath :: FilePath -> Option -optionOfPath = FileOption [] - diff --git a/Data/Array/Accelerate/LLVM/Native/Plugin/Annotation.hs b/Data/Array/Accelerate/LLVM/Native/Plugin/Annotation.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/Plugin/Annotation.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} --- | --- Module : Data.Array.Accelerate.LLVM.Native.Plugin.Annotation --- Copyright : [2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.Native.Plugin.Annotation ( - - Object(..), - -) where - -import Data.Data - -data Object = Object FilePath - deriving (Show, Data, Typeable) - diff --git a/Data/Array/Accelerate/LLVM/Native/Plugin/BuildInfo.hs b/Data/Array/Accelerate/LLVM/Native/Plugin/BuildInfo.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/Plugin/BuildInfo.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | --- Module : Data.Array.Accelerate.LLVM.Native.Plugin.BuildInfo --- Copyright : [2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.Native.Plugin.BuildInfo - where - -import Module - -import Data.Map ( Map ) -import Data.Serialize -import System.Directory -import System.FilePath -import qualified Data.ByteString as B -import qualified Data.Map as Map - -import Data.Array.Accelerate.Error - - -mkBuildInfoFileName :: FilePath -> FilePath -mkBuildInfoFileName path = path "accelerate-llvm-native.buildinfo" - -readBuildInfo :: FilePath -> IO (Map Module [FilePath]) -readBuildInfo path = do - exists <- doesFileExist path - if not exists - then return Map.empty - else do - f <- B.readFile path - case decode f of - Left err -> $internalError "readBuildInfo" err - Right m -> return m - -writeBuildInfo :: FilePath -> Map Module [FilePath] -> IO () -writeBuildInfo path objs = B.writeFile path (encode objs) - - -instance Serialize Module where - put (Module p n) = put p >> put n - get = do - p <- get - 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) - get = mkModuleName <$> get - diff --git a/Data/Array/Accelerate/LLVM/Native/State.hs b/Data/Array/Accelerate/LLVM/Native/State.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/State.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE CPP #-} --- | --- Module : Data.Array.Accelerate.LLVM.Native.State --- 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.State ( - - 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 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 -import Text.Read - -import GHC.Conc - - --- | Execute a computation in the Native backend --- -evalNative :: Native -> LLVM Native a -> IO a -evalNative = evalLLVM - - --- | 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. --- -createTarget - :: [Int] -- ^ CPU IDs to launch worker threads on - -> Strategy -- ^ Strategy to balance parallel workloads - -> 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) - - --- | The strategy for balancing work amongst the available worker threads. --- -type Strategy = Gang -> Executable - - --- | Execute an operation sequentially on a single thread --- -sequentialIO :: Strategy -sequentialIO gang = - Executable $ \name _ppt range fill -> - timed name $ runSeqIO gang range fill - - --- | Execute a computation without load balancing. Each thread computes an --- equally sized chunk of the input. No work stealing occurs. --- -unbalancedParIO :: Strategy -unbalancedParIO gang = - Executable $ \name _ppt range fill -> - timed name $ runParIO Single.mkResource gang range fill - - --- | Execute a computation where threads use work stealing (based on lazy --- splitting of work stealing queues and exponential backoff) in order to --- automatically balance the workload amongst themselves. --- -balancedParIO - :: Int -- ^ number of steal attempts before backing off - -> Strategy -balancedParIO retries gang = - Executable $ \name ppt range fill -> - -- TLM: A suitable PPT should be chosen when invoking the continuation in - -- order to balance scheduler overhead with fine-grained function calls - -- - let resource = LBS.mkResource ppt (SMP.mkResource retries <> Backoff.mkResource) - in timed name $ runParIO resource gang range fill - - --- Top-level mutable state --- ----------------------- --- --- It is important to keep some information alive for the entire run of the --- program, not just a single execution. These tokens use 'unsafePerformIO' to --- ensure they are executed only once, and reused for subsequent invocations. --- - --- | Initialise the gang of threads that will be used to execute computations. --- This spawns one worker for each available processor, or as specified by the --- value of the environment variable @ACCELERATE_LLVM_NATIVE_THREADS@. --- --- 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. --- -{-# NOINLINE defaultTarget #-} -defaultTarget :: Native -defaultTarget = unsafePerformIO $ do - nproc <- getNumProcessors - ncaps <- getNumCapabilities - menv <- (readMaybe =<<) <$> lookupEnv "ACCELERATE_LLVM_NATIVE_THREADS" - - let nthreads = fromMaybe nproc menv - - -- Update the number of capabilities, but never set it lower than it already - -- is. This target will spawn a worker on each processor (as returned by - -- 'getNumProcessors', which includes SMT (hyperthreading) cores), but the - -- user may have requested more capabilities than this to handle, for example, - -- concurrent output. - -- - 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) - - --- Debugging --- --------- - -{-# INLINE timed #-} -timed :: ShortByteString -> IO a -> IO a -timed name f = Debug.timed Debug.dump_exec (elapsed name) f - -{-# INLINE elapsed #-} -elapsed :: ShortByteString -> Double -> Double -> String -elapsed name x y = printf "exec: %s %s" (unpack name) (Debug.elapsedP x y) - diff --git a/Data/Array/Accelerate/LLVM/Native/Target.hs b/Data/Array/Accelerate/LLVM/Native/Target.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/Target.hs +++ /dev/null @@ -1,80 +0,0 @@ --- | --- Module : Data.Array.Accelerate.LLVM.Native.Target --- 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.Target ( - - module Data.Array.Accelerate.LLVM.Target, - module Data.Array.Accelerate.LLVM.Native.Target - -) where - --- llvm-general -import LLVM.Target hiding ( Target ) -import LLVM.AST.DataLayout ( DataLayout ) - --- accelerate -import Data.Array.Accelerate.LLVM.Native.Link.Cache ( LinkCache ) -import Data.Array.Accelerate.LLVM.Target ( Target(..) ) -import Control.Parallel.Meta ( Executable ) - --- standard library -import Data.ByteString ( ByteString ) -import Data.ByteString.Short ( ShortByteString ) -import System.IO.Unsafe - - --- | Native machine code JIT execution target --- -data Native = Native - { gangSize :: {-# UNPACK #-} !Int - , linkCache :: {-# UNPACK #-} !LinkCache - , fillS :: {-# UNPACK #-} !Executable - , fillP :: {-# UNPACK #-} !Executable - , segmentOffset :: !Bool - } - -instance Target Native where - targetTriple _ = Just nativeTargetTriple - targetDataLayout _ = Just nativeDataLayout - - --- | String that describes the native target --- -{-# NOINLINE nativeTargetTriple #-} -nativeTargetTriple :: ShortByteString -nativeTargetTriple = unsafePerformIO $ - -- A target triple suitable for loading code into the current process - getProcessTargetTriple - --- | A description of the various data layout properties that may be used during --- optimisation. --- -{-# NOINLINE nativeDataLayout #-} -nativeDataLayout :: DataLayout -nativeDataLayout - = unsafePerformIO - $ withNativeTargetMachine getTargetMachineDataLayout - --- | String that describes the host CPU --- -{-# NOINLINE nativeCPUName #-} -nativeCPUName :: ByteString -nativeCPUName = unsafePerformIO $ getHostCPUName - - --- | Bracket the creation and destruction of a target machine for the native --- backend running on this host. --- -withNativeTargetMachine - :: (TargetMachine -> IO a) - -> IO a -withNativeTargetMachine = withHostTargetMachine - 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,18 @@ -An LLVM backend for the Accelerate Array Language -================================================= +
+henlo, my name is Theia -[![Build Status](https://travis-ci.org/AccelerateHS/accelerate-llvm.svg)](https://travis-ci.org/AccelerateHS/accelerate-llvm) +# LLVM backends for the Accelerate array language + +[![CI](https://github.com/AccelerateHS/accelerate-llvm/actions/workflows/ci.yml/badge.svg)](https://github.com/AccelerateHS/accelerate-llvm/actions/workflows/ci.yml) +[![Gitter](https://img.shields.io/gitter/room/nwjs/nw.js.svg)](https://gitter.im/AccelerateHS/Lobby) [![Hackage](https://img.shields.io/hackage/v/accelerate-llvm.svg)](https://hackage.haskell.org/package/accelerate-llvm) -[![Docker Automated build](https://img.shields.io/docker/automated/tmcdonell/accelerate-llvm.svg)](https://hub.docker.com/r/tmcdonell/accelerate-llvm/) -[![Docker status](https://images.microbadger.com/badges/image/tmcdonell/accelerate-llvm.svg)](https://microbadger.com/images/tmcdonell/accelerate-llvm) +
+ This package compiles Accelerate code to LLVM IR, and executes that code on -multicore CPUs as well as NVIDIA GPUs. This avoids the need to go through `nvcc` -or `clang`. For details on Accelerate, refer to the [main repository][GitHub]. +multicore CPUs as well as NVIDIA GPUs. This avoids the need to go through +`nvcc` or write C++ code. For details on Accelerate, refer to the [main +repository][GitHub]. We love all kinds of contributions, so feel free to open issues for missing features as well as report (or fix!) bugs on the [issue tracker][Issues]. @@ -18,171 +22,143 @@ * [Dependencies](#dependencies) - * [Docker](#docker) - * [Installing LLVM](#installing-llvm) - * [Homebrew](#homebrew) + * [macOS](#macos) * [Debian/Ubuntu](#debianubuntu) - * [Building from source](#building-from-source) - * [Installing Accelerate-LLVM](#installing-accelerate-llvm) - * [libNVVM](#libNVVM) + * [Arch Linux](#archlinux) + * [Windows](#windows) Dependencies ------------ -Haskell dependencies are available from Hackage, but there are several external +Haskell dependencies are available from Hackage, but there are some external library dependencies that you will need to install as well: - * [`LLVM`](http://llvm.org) - * [`libFFI`](http://sourceware.org/libffi/) (if using the `accelerate-llvm-native` backend for multicore CPUs) - * [`CUDA`](https://developer.nvidia.com/cuda-downloads) (if using the `accelerate-llvm-ptx` backend for NVIDIA GPUs) - - -Docker ------- - -A [docker](https://www.docker.com) container is provided with this package -preinstalled (via stack) at `/opt/accelerate-llvm`. Note that if you wish to use -the `accelerate-llvm-ptx` GPU backend, you will need to install the [NVIDIA -docker](https://github.com/NVIDIA/nvidia-docker) plugin; see that page for more -information. - -```sh -$ docker run -it tmcdonell/accelerate-llvm -``` - - -Installing LLVM ---------------- - -When installing LLVM, make sure that it includes the `libLLVM` shared library. -If you want to use the GPU targeting `accelerate-llvm-ptx` backend, make sure -you install (or build) LLVM with the 'nvptx' target. +- if using `accelerate-llvm-native` for multicore CPU: + [`libFFI`](http://sourceware.org/libffi/) +- if using `accelerate-llvm-ptx` for GPU: + [`CUDA`](https://developer.nvidia.com/cuda-downloads); + [Note that not all versions of CUDA support all NVIDIA GPUs](https://en.wikipedia.org/wiki/CUDA#GPUs_supported) +- [`clang`](https://clang.llvm.org/) (if using `accelerate-llvm-ptx`: version + 16 or higher, built with support for the `nvptx` backend). `accelerate-llvm` + uses the command-line tool as a way to be compatible with many different LLVM + versions, not to compile C code. (Accelerate passes LLVM IR to `clang`.) -## Homebrew +Below are some OS-specific instructions. If anything here is wrong or out of +date, please file an issue. -Example using [Homebrew](http://brew.sh) on macOS: +## macOS -```sh -$ brew install llvm-hs/homebrew-llvm/llvm-4.0 -``` +To get `libFFI`, run `brew install libffi`. `clang` is already provided with +macOS (you may need to `xcode-select --install`), and CUDA is not supported on +macOS. ## Debian/Ubuntu -For Debian/Ubuntu based Linux distributions, the LLVM.org website provides -binary distribution packages. Check [apt.llvm.org](http://apt.llvm.org) for -instructions for adding the correct package database for your OS version, and -then: - -```sh -$ apt-get install llvm-4.0-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/4.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-4.0 source code](http://releases.llvm.org/4.0.0/llvm-4.0.0.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#4.0.0) - page for the complete list. - - 2. Create a temporary build directory and `cd` into it, for example: - ```sh - $ mkdir /tmp/build - $ cd /tmp/build - ``` - - 3. Execute the following to configure the build. Here `INSTALL_PREFIX` is - where LLVM is to be installed, for example `/usr/local` or - `$HOME/opt/llvm`: - ```sh - $ cmake $LLVM_SRC -DCMAKE_INSTALL_PREFIX=$INSTALL_PREFIX -DCMAKE_BUILD_TYPE=Release -DLLVM_ENABLE_ASSERTIONS=ON -DLLVM_BUILD_LLVM_DYLIB=ON -DLLVM_LINK_LLVM_DYLIB=ON - ``` - See [options and variables](http://llvm.org/docs/CMake.html#options-and-variables) - for a list of additional build parameters you can specify. - - 4. Build and install: - ```sh - $ cmake --build . - $ cmake --build . --target install - ``` - - 5. For macOS only, some additional steps are useful to work around issues related - to [System Integrity Protection](https://en.wikipedia.org/wiki/System_Integrity_Protection): - ```sh - cd $INSTALL_PREFIX/lib - ln -s libLLVM.dylib libLLVM-4.0.dylib - install_name_tool -id $PWD/libLTO.dylib libLTO.dylib - install_name_tool -id $PWD/libLLVM.dylib libLLVM.dylib - install_name_tool -change '@rpath/libLLVM.dylib' $PWD/libLLVM.dylib libLTO.dylib - ``` +For `clang`: +- On Ubuntu 24.04 (noble) / Debian trixie or higher: `sudo apt install clang`. +- Otherwise, if you need only the CPU backend (`accelerate-llvm-native`): + `sudo apt install clang` will give you an old version of `clang`, but the CPU + backend is likely to work fine. +- If you are on an older distro and need the GPU backend + (`accelerate-llvm-ptx`): `clang` version 16 or higher is required. + Add the apt source from [apt.llvm.org](https://apt.llvm.org/). The neatest + way to do this is to create a file `/etc/apt/sources.list.d/llvm.list` (the + precise file name does not matter) and put in it, for Ubuntu (change "jammy" + as appropriate): + deb http://apt.llvm.org/jammy/ llvm-toolchain-jammy main + deb-src http://apt.llvm.org/jammy/ llvm-toolchain-jammy main -Installing Accelerate-LLVM --------------------------- + or for Debian (change "bookworm" as appropriate): -Once the dependencies are installed, we are ready to install `accelerate-llvm`. + deb http://apt.llvm.org/bookworm/ llvm-toolchain-bookworm main + deb-src http://apt.llvm.org/bookworm/ llvm-toolchain-bookworm main -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.0.yaml stack.yaml -$ stack setup -$ stack install -``` + and `sudo apt update; sudo apt install clang`. This gets you the latest + version of `clang`; different sources are also available for specific + versions (see [apt.llvm.org](https://apt.llvm.org)). -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 4.0. +To use the CPU backend (`accelerate-llvm-native`), install `libFFI` using +`sudo apt install libffi-dev`. +To use the GPU backend (`accelerate-llvm-ptx`), install CUDA from +[here](https://developer.nvidia.com/cuda-downloads?target_os=Linux) +("deb (network)" is smoother than the "deb (local)" option). -## libNVVM +## Arch Linux -The `accelerate-llvm-ptx` backend can optionally be compiled to generate GPU -code using the `libNVVM` library, rather than LLVM's inbuilt NVPTX code -generator. `libNVVM` is a closed-source library distributed as part of the -NVIDIA CUDA toolkit, and is what the `nvcc` compiler itself uses internally when -compiling CUDA C code. +Run `sudo pacman -S clang`. To use the CPU backend (`accelerate-llvm-native`), +additionally run `sudo pacman -S libffi`. To use the GPU backend +(`accelerate-llvm-ptx`), additionally run `sudo pacman -S cuda`. -Using `libNVVM` _may_ improve GPU performance compared to the code generator -built in to LLVM. One difficulty with using it however is that since `libNVVM` -is also based on LLVM, and typically lags LLVM by several releases, you must -install `accelerate-llvm` with a "compatible" version of LLVM, which will depend -on the version of the CUDA toolkit you have installed. The following table shows -some combinations: +## Windows -| | LLVM-3.3 | LLVM-3.4 | LLVM-3.5 | LLVM-3.8 | LLVM-3.9 | LLVM-4.0 | -|:------------:|:--------:|:--------:|:--------:|:--------:|:--------:|:--------:| -| **CUDA-7.0** | ⭕ | ❌ | | | | | -| **CUDA-7.5** | | ⭕ | ⭕ | ❌ | | | -| **CUDA-8.0** | | | ⭕ | ⭕ | ❌ | ❌ | +We recommend WSL2 (not WSL1, WSL2!) and following the Ubuntu instructions +above. The remainder of this text attemps to give you a working system on +Windows native. -Where ⭕ = Works, and ❌ = Does not work. +Install `clang`; you have two options: +1. Using + [WinGet](https://learn.microsoft.com/en-us/windows/package-manager/winget/): + `winget install LLVM.LLVM` +2. By downloading the installer directly (WinGet just runs the same installer) + from [here](https://github.com/llvm/llvm-project/releases) (choose + "LLVM-<version>-win64.exe" from the latest release; you may need to click + "Show all 57 assets"). +This will also give you `libFFI`. -Note that the above restrictions on CUDA and LLVM version exist _only_ if you -want to use the NVVM component. Otherwise, you should be free to use any -combination of CUDA and LLVM. +
Optionally, add clang (and more) to your system path. Click to see how. -Also note that `accelerate-llvm-ptx` itself currently requires at least LLVM-3.5. +Accelerate should be able to find `clang` automatically even if you do not do +this. However, for easy access to `clang` and all other LLVM executables, add +`C:\Program Files\LLVM\bin` to the system path as follows: +1. Search for "environment variables" in the start menu +2. Click "Edit the system environment variables" +3. Click on "Environment Variables..." +4. Double-click on the user variable called "Path" +5. And add a new entry containing `C:\Program Files\LLVM\bin`. -Using `stack`, either edit the `stack.yaml` and add the following section: +Note that if you add an entry here manually, it is a good idea to clean it up +again if you uninstall LLVM/clang. (Leaving it there is not very harmful, +however.) -```yaml -flags: - accelerate-llvm-ptx: - nvvm: true -``` +You may find that the LLVM/clang installer has already added the Path entry +automatically (it did not for us); if so, no need to add a second entry. -Or install using the following option on the command line: +—— +
-```sh -$ stack install accelerate-llvm-ptx --flag accelerate-llvm-ptx:nvvm -``` +You may additionally need the VS Build Tools, if you have not yet installed and +set up Visual Studio otherwise. You need this if `clang` complains that it is +`unable to find a Visual Studio installation; try running Clang from a developer command prompt`. -If installing via `cabal`: +1. If you already have the Visual Studio Installer on your system, open it and + check if you already have Visual Studio (Community) installed. Note that + this is completely unrelated to VS _Code_. + - If you already have VS (Community): inside the Visual Studio Installer, + click on "Modify" in the VS (Community) box. This should get you a screen + with "workloads" you can select. + - If you do not yet have VS (Community), install the VS Build Tools: go to + https://visualstudio.microsoft.com/downloads, scroll down to "All + Downloads", open "Tools for Visual Studio", and select "Build Tools for + Visual Studio". If you run the installer, you should get a screen with + "workloads" you can select. +2. Under the Workloads tab, choose the "Desktop development with C++" workload. + If you want to save a bit of disk space (not much), keep only the following + two options selected: + - "MSVC v143 - VE 2022 C++ x64/x86 build tools (Latest)" + - "Windows 11 SDK (…)" (choose the latest option). The attentive reader may + note that the wizard also offers Clang; we recommend a separate Clang + install for Accelerate because the one from VS somehow doesn’t seem to + work properly with Accelerate. If you find out why, please let us know. +3. Install that. This takes a while. -```sh -$ cabal install accelerate-llvm-ptx -fnvvm -``` +It turns out that having both Visual Studio and the Build Tools installed +results in Clang getting confused between the two (it appears that Visual +Studio is 64-bit (x64) and the Build Tools are 32-bit (x86)). If Clang +complains about the bit-ness of your system libraries, double-check that you +haven’t installed both simultaneously. +The GPU backend (`accelerate-llvm-ptx`) probably doesn't work on Windows; in +any case, it is untested. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,128 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} + +module Main where + +import Distribution.PackageDescription +import Distribution.PackageDescription.PrettyPrint import Distribution.Simple -main = defaultMain +import Distribution.Simple.BuildPaths +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PackageIndex +import Distribution.Simple.Setup as Setup +import Distribution.Verbosity +import qualified Distribution.InstalledPackageInfo as Installed + +#if MIN_VERSION_Cabal(3,8,0) +import Distribution.Simple.PackageDescription +#elif MIN_VERSION_Cabal(2,2,0) +import Distribution.PackageDescription.Parsec +#else +import Distribution.PackageDescription.Parse +#endif +#if MIN_VERSION_Cabal(3,14,0) +-- Note [Cabal 3.14] +-- +-- If you change any path stuff, either test that the package still works with +-- Cabal 3.12 or stop declaring support for it in cuda.cabal. (If you do the +-- latter, also remove all of the other conditionals in this file.) +-- Note that supporting old versions of Cabal is useful for being able to run +-- e.g. Accelerate on old GPU clusters, which is nice. +import Distribution.Utils.Path (SymbolicPath, FileOrDir(File, Dir), Lib, Include, Pkg, CWD, makeSymbolicPath) +import qualified Distribution.Types.LocalBuildConfig as LBC +#endif + +import System.FilePath + + +main :: IO () +main = defaultMainWithHooks simpleUserHooks + { postConf = postConfHook + , preBuild = readHook buildVerbosity workingDirFlag + , preRepl = readHook replVerbosity workingDirFlag + , preCopy = readHook copyVerbosity workingDirFlag + , preInst = readHook installVerbosity workingDirFlag + , preHscolour = readHook hscolourVerbosity workingDirFlag + , preHaddock = readHook haddockVerbosity workingDirFlag + , preReg = readHook regVerbosity workingDirFlag + , preUnreg = readHook regVerbosity workingDirFlag + } + where + readHook :: (a -> Setup.Flag Verbosity) -> (a -> Setup.Flag CWDPath) -> Args -> a -> IO HookedBuildInfo + readHook verbosity cwd _ flags = readHookedBuildInfoWithCWD (fromFlag (verbosity flags)) (flagToMaybe (cwd flags)) (makeSymbolicPath buildinfo_file) + + postConfHook :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO () + postConfHook args flags pkg_desc lbi = do + let accelerate_pkg = case searchByName (installedPkgs lbi) "accelerate" of + Unambiguous [x] -> x + _ -> error "accelerate package was not found or is ambiguous" + + dyld_library_name = mkSharedLibName (hostPlatform lbi) (compilerId (compiler lbi)) (installedUnitId accelerate_pkg) + dyld_install_dir:_ = case Installed.libraryDynDirs accelerate_pkg of + [] -> Installed.libraryDirs accelerate_pkg + ds -> ds + + buildinfo = emptyBuildInfo { cppOptions = [ "-DACCELERATE_DYLD_LIBRARY_PATH=" ++ quote (dyld_install_dir dyld_library_name) ] } + hooked_buildinfo = (Just buildinfo, []) + pkg_desc' = updatePackageDescription hooked_buildinfo pkg_desc + + + writeHookedBuildInfo buildinfo_file hooked_buildinfo + postConf simpleUserHooks args flags pkg_desc' lbi + +buildinfo_file :: FilePath +buildinfo_file = "accelerate-llvm-native.buildinfo" + +quote :: String -> String +#ifdef mingw32_HOST_OS +quote s = "\"" ++ (s >>= escape) ++ "\"" + where + escape '\\' = "\\\\" + escape '"' = "\\\"" + escape c = [c] +#else +quote = show +#endif + + +-- Compatibility across Cabal 3.14 symbolic paths. +-- If we want to drop pre-Cabal-3.14 compatibility at some point, this should all be merged in above. + +#if MIN_VERSION_Cabal(3,14,0) +type CWDPath = SymbolicPath CWD ('Dir Pkg) + +regVerbosity :: RegisterFlags -> Flag Verbosity +regVerbosity = setupVerbosity . registerCommonFlags + +workingDirFlag :: HasCommonFlags flags => flags -> Flag CWDPath +workingDirFlag = setupWorkingDir . getCommonFlags + +-- makeSymbolicPath is an actual useful function in Cabal 3.14 + +class HasCommonFlags flags where getCommonFlags :: flags -> CommonSetupFlags +instance HasCommonFlags BuildFlags where getCommonFlags = buildCommonFlags +instance HasCommonFlags CleanFlags where getCommonFlags = cleanCommonFlags +instance HasCommonFlags ConfigFlags where getCommonFlags = configCommonFlags +instance HasCommonFlags CopyFlags where getCommonFlags = copyCommonFlags +instance HasCommonFlags InstallFlags where getCommonFlags = installCommonFlags +instance HasCommonFlags HscolourFlags where getCommonFlags = hscolourCommonFlags +instance HasCommonFlags HaddockFlags where getCommonFlags = haddockCommonFlags +instance HasCommonFlags RegisterFlags where getCommonFlags = registerCommonFlags +instance HasCommonFlags ReplFlags where getCommonFlags = replCommonFlags + +readHookedBuildInfoWithCWD :: Verbosity -> Maybe CWDPath -> SymbolicPath Pkg 'File -> IO HookedBuildInfo +readHookedBuildInfoWithCWD = readHookedBuildInfo +#else +type CWDPath = () + +-- regVerbosity is still present as an actual field in Cabal 3.12 + +workingDirFlag :: flags -> Flag CWDPath +workingDirFlag _ = NoFlag + +makeSymbolicPath :: FilePath -> FilePath +makeSymbolicPath = id + +readHookedBuildInfoWithCWD :: Verbosity -> Maybe CWDPath -> FilePath -> IO HookedBuildInfo +readHookedBuildInfoWithCWD verb _ path = readHookedBuildInfo verb path +#endif diff --git a/SetupHooks.hs b/SetupHooks.hs new file mode 100644 --- /dev/null +++ b/SetupHooks.hs @@ -0,0 +1,29 @@ +module SetupHooks where + +import Distribution.Simple.SetupHooks + +setupHooks :: SetupHooks +setupHooks = + noSetupHooks + { configureHooks = noConfigureHooks { preConfPackageHook = Just hook } } + where + hook :: PreConfPackageInputs -> IO PreConfPackageOutputs + hook inputs = _ + + -- postConfHook args flags pkg_desc lbi = do + -- let accelerate_pkg = case searchByName (installedPkgs lbi) "accelerate" of + -- Unambiguous [x] -> x + -- _ -> error "accelerate package was not found or is ambiguous" + + -- dyld_library_name = mkSharedLibName (hostPlatform lbi) (compilerId (compiler lbi)) (installedUnitId accelerate_pkg) + -- dyld_install_dir:_ = case Installed.libraryDynDirs accelerate_pkg of + -- [] -> Installed.libraryDirs accelerate_pkg + -- ds -> ds + + -- buildinfo = emptyBuildInfo { cppOptions = [ "-DACCELERATE_DYLD_LIBRARY_PATH=" ++ quote (dyld_install_dir dyld_library_name) ] } + -- hooked_buildinfo = (Just buildinfo, []) + -- pkg_desc' = updatePackageDescription hooked_buildinfo pkg_desc + + + -- writeHookedBuildInfo buildinfo_file hooked_buildinfo + -- postConf simpleUserHooks args flags pkg_desc' lbi diff --git a/accelerate-llvm-native.cabal b/accelerate-llvm-native.cabal --- a/accelerate-llvm-native.cabal +++ b/accelerate-llvm-native.cabal @@ -1,101 +1,43 @@ +cabal-version: 2.2 + name: accelerate-llvm-native -version: 1.1.0.1 -cabal-version: >= 1.10 -tested-with: GHC >= 7.10 -build-type: Simple +version: 1.4.0.0 +tested-with: GHC >= 9.4 +build-type: Custom synopsis: Accelerate backend for multicore CPUs description: This library implements a backend for the /Accelerate/ language which - generates LLVM-IR targeting multicore CPUs. For further information, refer + generates LLVM IR targeting multicore CPUs. For further information, refer to the main package. . [/Dependencies/] . Haskell dependencies are available from Hackage. The following external - libraries are alse required: - . - * - . - * - . - [/Installing LLVM/] - . - /Homebrew/ - . - Example using Homebrew on macOS: - . - > brew install llvm-hs/homebrew-llvm/llvm-5.0 - . - /Debian & Ubuntu/ - . - For Debian/Ubuntu based Linux distributions, the LLVM.org website provides - binary distribution packages. Check for - instructions for adding the correct package database for your OS version, - and then: - . - > apt-get install llvm-5.0-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 - 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: + dependencies are also required: . - > cabal install llvm-hs -fshared-llvm + * (not used to compile C code, but to compile generated LLVM IR via a mostly LLVM-version-independent interface) + * . + For installation instructions, see the . -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Trevor L. McDonell -maintainer: Trevor L. McDonell +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: +extra-doc-files: CHANGELOG.md README.md - --- Configuration flags --- ------------------- - -Flag debug - Default: False - Description: - Enable debug tracing message flags. Note that 'debug' must be enabled in the - base 'accelerate' package as well. See the 'accelerate' package for usage - and available options. - -Flag bounds-checks - Default: True - Description: Enable bounds checking - -Flag unsafe-checks - Default: False - Description: Enable bounds checking in unsafe operations - -Flag internal-checks - Default: False - Description: Enable internal consistency checks +custom-setup + setup-depends: + base >= 4.10 && < 5 + , Cabal >= 2 && < 3.18 + , filepath -- Build configuration @@ -106,12 +48,10 @@ 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 Data.Array.Accelerate.LLVM.Native.Debug - Data.Array.Accelerate.LLVM.Native.Execute Data.Array.Accelerate.LLVM.Native.State Data.Array.Accelerate.LLVM.Native.Target @@ -124,107 +64,111 @@ 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 - Data.Array.Accelerate.LLVM.Native.Compile.Optimise Data.Array.Accelerate.LLVM.Native.Link Data.Array.Accelerate.LLVM.Native.Link.Cache Data.Array.Accelerate.LLVM.Native.Link.Object + Data.Array.Accelerate.LLVM.Native.Link.Runtime Data.Array.Accelerate.LLVM.Native.Embed + 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 + Control.Concurrent.Extra Paths_accelerate_llvm_native + autogen-modules: + Paths_accelerate_llvm_native + build-depends: - base >= 4.7 && < 4.11 - , accelerate == 1.1.* - , accelerate-llvm == 1.1.* + base >= 4.10 && < 5 + , accelerate == 1.4.* + , accelerate-llvm == 1.4.* , bytestring >= 0.10.4 - , Cabal >= 2.0 - , cereal >= 0.4 - , containers >= 0.5 && < 0.6 + , containers >= 0.5 && < 0.9 + , deepseq >= 1.4 , directory >= 1.0 , dlist >= 0.6 - , fclabels >= 2.0 , filepath >= 1.0 + , formatting >= 7.0 , ghc , hashable >= 1.0 , libffi >= 0.1 - , llvm-hs >= 4.1 && < 5.1 - , llvm-hs-pure >= 4.1 && < 5.1 + -- , llvm-pretty >= 0.12 + , lockfree-queue >= 0.2 , mtl >= 2.2.1 + -- only used to render llvm-pretty output + , pretty + , process >= 1.4.3 + -- TODO: These are only used for lifting ByteStrings. bytestring + -- 0.11.2.0 include its own, better lifting instances. Once + -- that's stable, we can remove this dependency and bump + -- bytestring's version bound. + , th-lift-instances , template-haskell - , time >= 1.4 + , text >= 1.2 , unique - - default-language: - Haskell2010 - - ghc-options: -O2 -Wall -fwarn-tabs - - if impl(ghc >= 8.0) - ghc-options: -Wmissed-specialisations - - if flag(debug) - cpp-options: -DACCELERATE_DEBUG - - if flag(bounds-checks) - cpp-options: -DACCELERATE_BOUNDS_CHECKS + , unordered-containers >= 0.2 + , vector >= 0.11 - if flag(unsafe-checks) - cpp-options: -DACCELERATE_UNSAFE_CHECKS + hs-source-dirs: + src - if flag(internal-checks) - cpp-options: -DACCELERATE_INTERNAL_CHECKS + default-language: + Haskell2010 - if os(darwin) - other-modules: - Data.Array.Accelerate.LLVM.Native.Link.MachO + ghc-options: + -O2 + -Wall + -fwarn-tabs + if os(windows) build-depends: - bytestring >= 0.10 - , cereal >= 0.4 - , ghc-prim - , unix >= 2.7 - , vector >= 0.11 + Win32 + else + build-depends: + unix >= 2.7 - build-tools: - c2hs >= 0.25 - if os(linux) - other-modules: - Data.Array.Accelerate.LLVM.Native.Link.ELF - - build-depends: - bytestring >= 0.10 - , cereal >= 0.4 - , ghc-prim - , unix >= 2.7 - , vector >= 0.11 +test-suite nofib-llvm-native + type: exitcode-stdio-1.0 + hs-source-dirs: test/nofib + main-is: Main.hs + other-modules: + Data.Array.Accelerate.LLVM.Native.NoFib.RunQ - build-tools: - c2hs >= 0.25 + build-depends: + base >= 4.10 + , accelerate + , accelerate-llvm-native + , tasty + , tasty-hunit - if os(windows) - other-modules: - Data.Array.Accelerate.LLVM.Native.Link.COFF + default-language: + Haskell2010 - build-depends: - bytestring >= 0.10 + ghc-options: + -Wall + -O2 + -threaded + -rtsopts + -with-rtsopts=-A128M + -with-rtsopts=-n4M + -with-rtsopts=-N source-repository head @@ -233,7 +177,7 @@ source-repository this type: git - tag: 1.1.0.1-native + tag: v1.4.0.0 location: https://github.com/AccelerateHS/accelerate-llvm.git -- vim: nospell diff --git a/src/Control/Concurrent/Extra.hs b/src/Control/Concurrent/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Extra.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# OPTIONS_GHC -fobject-code #-} +-- | +-- Module : Control.Concurrent.Extra +-- Copyright : [2021] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Control.Concurrent.Extra ( + + getThreadId, + +) where + +import Data.Int +import Foreign.C.Types +import GHC.Conc ( ThreadId(..) ) +import GHC.Exts ( ThreadId# ) + + +-- Stolen from GHC.Conc.Sync +-- +getThreadId :: ThreadId -> Int32 +getThreadId (ThreadId t#) = + case getThreadId# t# of + CInt i -> i + +foreign import ccall unsafe "rts_getThreadId" getThreadId# :: ThreadId# -> CInt + diff --git a/src/Data/Array/Accelerate/LLVM/Native.hs b/src/Data/Array/Accelerate/LLVM/Native.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native.hs @@ -0,0 +1,441 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native +-- Copyright : [2014..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- This module implements a backend for the /Accelerate/ language targeting +-- multicore CPUs. Expressions are on-line translated into LLVM code, which is +-- just-in-time executed in parallel over the available CPUs. Functions are +-- automatically parallelised over all available cores, unless you set the +-- environment variable 'ACCELERATE_LLVM_NATIVE_THREADS=N', in which case 'N' +-- threads will be used. +-- +-- Programs must be compiled with '-threaded', otherwise you will get a "Blocked +-- indefinitely on MVar" error. +-- + +module Data.Array.Accelerate.LLVM.Native ( + + Acc, Arrays, + Afunction, AfunctionR, + + -- * Synchronous execution + run, runWith, + run1, run1With, + runN, runNWith, + stream, streamWith, + + -- * Asynchronous execution + Async, + wait, poll, cancel, + + runAsync, runAsyncWith, + run1Async, run1AsyncWith, + runNAsync, runNAsyncWith, + + -- * Ahead-of-time compilation + runQ, runQWith, + runQAsync, runQAsyncWith, + + -- * Execution targets + Native, + createTarget, + +) where + +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.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.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.Native.Debug as Debug + +import Control.Monad.Trans +import System.IO.Unsafe +import qualified Data.Array.Accelerate.TH.Compat as TH +import qualified Language.Haskell.TH.Syntax as TH + +import GHC.Stack + + +-- Accelerate: LLVM backend for multicore CPUs +-- ------------------------------------------- + +-- | Compile and run a complete embedded array program. +-- +-- /NOTE:/ it is recommended to use 'runN' or 'runQ' whenever possible. +-- +run :: (Arrays a, HasCallStack) => Acc a -> a +run a = withFrozenCallStack $ runWith defaultTarget a + +-- | As 'run', but execute using the specified target (thread gang). +-- +runWith :: (Arrays a, HasCallStack) => Native -> Acc a -> a +runWith target a + = withFrozenCallStack + $ unsafePerformIO (runWithIO target a) + +-- | As 'run', but allow the computation to run asynchronously and return +-- immediately without waiting for the result. The status of the computation can +-- be queried using 'wait', 'poll', and 'cancel'. +-- +runAsync :: (Arrays a, HasCallStack) => Acc a -> IO (Async a) +runAsync a + = withFrozenCallStack + $ runAsyncWith defaultTarget a + +-- | As 'runAsync', but execute using the specified target (thread gang). +-- +runAsyncWith :: (Arrays a, HasCallStack) => Native -> Acc a -> IO (Async a) +runAsyncWith target a + = withFrozenCallStack + $ async (runWithIO target a) + +runWithIO :: (Arrays a, HasCallStack) => Native -> Acc a -> IO a +runWithIO target a = execute + where + !acc = convertAcc a + execute = do + dumpGraph acc + evalNative target $ do + build <- phase Compile elapsedS (compileAcc acc) >>= dumpStats + exec <- phase Link elapsedS (linkAcc build) + res <- phase Execute elapsedP (evalPar (executeAcc exec >>= getArrays (arraysR exec))) + return $ toArr res + + +-- | This is 'runN', specialised to an array program of one argument. +-- +run1 :: (Arrays a, Arrays b, HasCallStack) => (Acc a -> Acc b) -> a -> b +run1 = withFrozenCallStack $ run1With defaultTarget + +-- | As 'run1', but execute using the specified target (thread gang). +-- +run1With :: (Arrays a, Arrays b, HasCallStack) => Native -> (Acc a -> Acc b) -> a -> b +run1With = withFrozenCallStack $ runNWith + + +-- | Prepare and execute an embedded array program. +-- +-- This function can be used to improve performance in cases where the array +-- program is constant between invocations, because it enables us to bypass +-- front-end conversion stages and move directly to the execution phase. If you +-- have a computation applied repeatedly to different input data, use this, +-- specifying any changing aspects of the computation via the input parameters. +-- If the function is only evaluated once, this is equivalent to 'run'. +-- +-- In order to use 'runN' you must express your Accelerate program as a function +-- of array terms: +-- +-- > f :: (Arrays a, Arrays b, ... Arrays c) => Acc a -> Acc b -> ... -> Acc c +-- +-- This function then returns the compiled version of 'f': +-- +-- > runN f :: (Arrays a, Arrays b, ... Arrays c) => a -> b -> ... -> c +-- +-- At an example, rather than: +-- +-- > step :: Acc (Vector a) -> Acc (Vector b) +-- > step = ... +-- > +-- > simulate :: Vector a -> Vector b +-- > simulate xs = run $ step (use xs) +-- +-- Instead write: +-- +-- > simulate = runN step +-- +-- You can use the debugging options to check whether this is working +-- successfully. For example, running with the @-ddump-phases@ flag should show +-- that the compilation steps only happen once, not on the second and subsequent +-- invocations of 'simulate'. Note that this typically relies on GHC knowing +-- that it can lift out the function returned by 'runN' and reuse it. +-- +-- See the programs in the 'accelerate-examples' package for examples. +-- +-- See also 'runQ', which compiles the Accelerate program at _Haskell_ compile +-- time, thus eliminating the runtime overhead altogether. +-- +runN :: (Afunction f, HasCallStack) => f -> AfunctionR f +runN = withFrozenCallStack $ runNWith defaultTarget + +-- | As 'runN', but execute using the specified target (thread gang). +-- +runNWith :: forall f. (Afunction f, HasCallStack) => Native -> f -> AfunctionR f +runNWith target f + = withFrozenCallStack + $ go (afunctionRepr @f) afun (return Empty) + where + !acc = convertAfun f + !afun = unsafePerformIO $ do + dumpGraph acc + evalNative target $ do + build <- phase Compile elapsedS (compileAfun acc) >>= dumpStats + link <- phase Link elapsedS (linkAfun build) + return link + + 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. +-- +run1Async :: (Arrays a, Arrays b, HasCallStack) => (Acc a -> Acc b) -> a -> IO (Async b) +run1Async = withFrozenCallStack $ run1AsyncWith defaultTarget + +-- | As 'run1Async', but execute using the specified target (thread gang). +-- +run1AsyncWith :: (Arrays a, Arrays b, HasCallStack) => Native -> (Acc a -> Acc b) -> a -> IO (Async b) +run1AsyncWith = withFrozenCallStack runNAsyncWith + + +-- | As 'runN', but execute asynchronously. +-- +runNAsync :: (Afunction f, RunAsync r, ArraysFunctionR f ~ RunAsyncR r, HasCallStack) => f -> r +runNAsync = withFrozenCallStack $ runNAsyncWith defaultTarget + +-- | As 'runNWith', but execute asynchronously. +-- +runNAsyncWith :: (Afunction f, RunAsync r, ArraysFunctionR f ~ RunAsyncR r, HasCallStack) => Native -> f -> r +runNAsyncWith target f = withFrozenCallStack exec + where + !acc = convertAfun f + !afun = unsafePerformIO $ do + dumpGraph acc + evalNative target $ do + build <- phase Compile elapsedS (compileAfun acc) >>= dumpStats + link <- phase Link elapsedS (linkAfun build) + return link + !exec = runAsync' target afun (return Empty) + +class RunAsync f where + type RunAsyncR f + runAsync' :: Native -> ExecOpenAfun Native aenv (RunAsyncR f) -> Par Native (Val aenv) -> f + +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 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 Arrays b => RunAsync (IO (Async b)) where + type RunAsyncR (IO (Async b)) = ArraysR b + runAsync' _ Alam{} _ = error "runAsync: function not fully applied" + runAsync' target (Abody b) k = async . phase Execute elapsedP . evalNative target . evalPar $ do + 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, +-- collecting results as we go. +-- +stream :: (Arrays a, Arrays b, HasCallStack) => (Acc a -> Acc b) -> [a] -> [b] +stream = withFrozenCallStack $ streamWith defaultTarget + +-- | As 'stream', but execute using the specified target (thread gang). +-- +streamWith :: (Arrays a, Arrays b, HasCallStack) => Native -> (Acc a -> Acc b) -> [a] -> [b] +streamWith target f arrs = withFrozenCallStack $ map go arrs + where + !go = run1With target f + + +-- | Ahead-of-time compilation for an embedded array program. +-- +-- This function will generate, compile, and link into the final executable, +-- code to execute the given Accelerate computation /at Haskell compile time/. +-- This eliminates any runtime overhead associated with the other @run*@ +-- operations. The generated code will be optimised for the compiling +-- architecture. +-- +-- Since the Accelerate program will be generated at Haskell compile time, +-- construction of the Accelerate program, in particular via meta-programming, +-- will be limited to operations available to that phase. Also note that any +-- arrays which are embedded into the program via 'Data.Array.Accelerate.use' +-- will be stored as part of the final executable. +-- +-- Usage of this function in your program is similar to that of 'runN'. First, +-- express your Accelerate program as a function of array terms: +-- +-- > f :: (Arrays a, Arrays b, ... Arrays c) => Acc a -> Acc b -> ... -> Acc c +-- +-- This function then returns a compiled version of @f@ as a Template Haskell +-- splice, to be added into your program at Haskell compile time: +-- +-- > {-# LANGUAGE TemplateHaskell #-} +-- > +-- > f' :: a -> b -> ... -> c +-- > f' = $( runQ f ) +-- +-- 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. +-- +-- 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. +-- +-- The correct type of this function is similar to that of 'runN': +-- +-- > runQ :: Afunction f => f -> Q (TExp (AfunctionR f)) +-- +-- @since 1.1.0.0 +-- +runQ :: (Afunction f, HasCallStack) => f -> TH.ExpQ +runQ + = withFrozenCallStack + $ runQ' [| unsafePerformIO |] [| defaultTarget |] + +-- | Ahead-of-time analogue of 'runNWith'. See 'runQ' for more information. +-- +-- The correct type of this function is: +-- +-- > runQWith :: Afunction f => f -> Q (TExp (Native -> AfunctionR f)) +-- +-- @since 1.1.0.0 +-- +runQWith :: (Afunction f, HasCallStack) => f -> TH.ExpQ +runQWith f = + withFrozenCallStack $ do + target <- TH.newName "target" + TH.lamE [TH.varP target] (runQ' [| unsafePerformIO |] (TH.varE target) f) + + +-- | Ahead-of-time analogue of 'runNAsync'. See 'runQ' for more information. +-- +-- The correct type of this function is: +-- +-- > runQAsync :: (Afunction f, RunAsync r, AfunctionR f ~ RunAsyncR r) => f -> Q (TExp r) +-- +-- @since 1.1.0.0 +-- +runQAsync :: (Afunction f, HasCallStack) => f -> TH.ExpQ +runQAsync + = withFrozenCallStack + $ runQ' [| async |] [| defaultTarget |] + +-- | Ahead-of-time analogue of 'runNAsyncWith'. See 'runQ' for more information. +-- +-- The correct type of this function is: +-- +-- > runQAsyncWith :: (Afunction f, RunAsync r, AfunctionR f ~ RunAsyncR r) => f -> Q (TExp (Native -> r)) +-- +-- @since 1.1.0.0 +-- +runQAsyncWith :: (Afunction f, HasCallStack) => f -> TH.ExpQ +runQAsyncWith f = + withFrozenCallStack $ do + target <- TH.newName "target" + TH.lamE [TH.varP target] (runQ' [| async |] (TH.varE target) f) + + +runQ' :: forall f. (Afunction f, HasCallStack) => TH.ExpQ -> TH.ExpQ -> f -> TH.ExpQ +runQ' using target f = do +#if MIN_VERSION_template_haskell(2,13,0) + -- The plugin ensures that objects are loaded correctly into GHCi + TH.addCorePlugin "Data.Array.Accelerate.LLVM.Native.Plugin" +#endif + + afun <- let acc = convertAfun f + in TH.runIO $ do + dumpGraph acc + 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. + -- + -- 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 :: 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 + let s = TH.bindS (TH.varP a) [| useRemoteAsync $(TH.unTypeCode $ liftArraysR (lhsToTupR lhs)) (fromArr $(TH.varE x)) |] + go l (TH.varP x : xs) ([| ($(TH.unTypeCode $ liftALeftHandSide lhs), $(TH.varE a)) |] : as) (s : stmts) + + go (Abody b) xs as stmts = do + r <- TH.newName "r" -- result + 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.unTypeCode body) $aenv |] + , TH.bindS (TH.varP s) [| getArrays $(TH.unTypeCode (liftArraysR (arraysR b))) $(TH.varE r) |] + , TH.noBindS [| return $ toArr $(TH.varE s) |] + ])) + |] + -- + go afun [] [] [] + + +-- Debugging +-- ========= + +dumpStats :: MonadIO m => a -> m a +dumpStats x = liftIO dumpSimplStats >> return x + diff --git a/src/Data/Array/Accelerate/LLVM/Native/Array/Data.hs b/src/Data/Array/Accelerate/LLVM/Native/Array/Data.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Array/Data.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Array.Data +-- 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.Array.Data ( + + module Data.Array.Accelerate.LLVM.Array.Data, + cloneArray, + +) where + +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 Control.Monad.Trans +import Foreign.Ptr + + +-- | 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 where + {-# INLINE allocateRemote #-} + allocateRemote repr = liftIO . allocateArray repr + + +-- | Copy an array into a newly allocated array. This uses 'memcpy'. +-- +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 + n = size (arrayRshape repr) sh + + 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 :: 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 +-- -------------------- + +memcpy :: Ptr Word8 -> Ptr Word8 -> Int -> IO () +memcpy p q s = c_memcpy p q (fromIntegral s) >> return () + +foreign import ccall unsafe "string.h memcpy" c_memcpy + :: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8) + diff --git a/src/Data/Array/Accelerate/LLVM/Native/CodeGen.hs b/src/Data/Array/Accelerate/LLVM/Native/CodeGen.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/CodeGen.hs @@ -0,0 +1,44 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.CodeGen +-- 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 ( + + KernelMetadata(..), + +) where + +-- accelerate +import Data.Array.Accelerate.LLVM.CodeGen + +import Data.Array.Accelerate.LLVM.Native.CodeGen.Base +import Data.Array.Accelerate.LLVM.Native.CodeGen.Fold +import Data.Array.Accelerate.LLVM.Native.CodeGen.FoldSeg +import Data.Array.Accelerate.LLVM.Native.CodeGen.Generate +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 + 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 new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Base.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.Base +-- Copyright : [2015..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.CodeGen.Base + where + +import Data.Array.Accelerate.LLVM.CodeGen.Base +import Data.Array.Accelerate.LLVM.CodeGen.IR +import Data.Array.Accelerate.LLVM.CodeGen.Module +import Data.Array.Accelerate.LLVM.CodeGen.Monad +import Data.Array.Accelerate.LLVM.CodeGen.Profile +import Data.Array.Accelerate.LLVM.CodeGen.Sugar +import Data.Array.Accelerate.LLVM.Compile.Cache +import Data.Array.Accelerate.LLVM.Native.Target ( Native ) +import Data.Array.Accelerate.Representation.Shape + +import LLVM.AST.Type.Name +import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty as LP + +import Data.String +import qualified Data.ByteString.Short.Char8 as S8 + + +-- | Generate function parameters that will specify the first and last (linear) +-- index of the array this thread should evaluate. +-- +gangParam :: ShapeR sh -> (Operands sh, Operands sh, [LP.Typed LP.Ident]) +gangParam shr = + let start = "ix.start" + end = "ix.end" + tp = shapeType shr + in + (local tp start, local tp end, parameter tp start ++ parameter tp end) + + +-- -- | The worker ID of the calling thread +-- -- +-- gangId :: (Operands Int, [LLVM.Parameter]) +-- gangId = +-- let tid = "ix.tid" +-- in (local (TupRsingle scalarTypeInt) tid, [ downcast scalarTypeInt ] ) + + +-- Global function definitions +-- --------------------------- + +data instance KernelMetadata Native = KM_Native () + +-- | Combine kernels into a single program +-- +(+++) :: IROpenAcc Native aenv a -> IROpenAcc Native aenv a -> IROpenAcc Native aenv a +IROpenAcc k1 +++ IROpenAcc k2 = IROpenAcc (k1 ++ k2) + +-- | Create a single kernel program +-- +makeOpenAcc :: UID -> Label -> [LP.Typed LP.Ident] -> CodeGen Native () -> CodeGen Native (IROpenAcc Native aenv a) +makeOpenAcc uid name param kernel = do + body <- makeKernel (name <> fromString ('_' : show uid)) param kernel + return $ IROpenAcc [body] + +-- | Create a complete kernel function by running the code generation process +-- specified in the final parameter. +-- +makeKernel :: Label -> [LP.Typed LP.Ident] -> CodeGen Native () -> CodeGen Native (Kernel Native aenv a) +makeKernel name@(Label sbs) param kernel = do + zone <- zone_begin_alloc 0 [] (S8.unpack sbs) [] 0 + _ <- kernel + _ <- zone_end zone + return_ + code <- createBlocks + return $ Kernel + { kernelMetadata = KM_Native () + , unKernel = LP.Define + { LP.defLinkage = Just LP.DLLExport -- ensure the symbols are visible on Windows + , LP.defVisibility = Nothing + , LP.defRetType = LP.PrimType LP.Void + , LP.defName = labelToPrettyS name + , LP.defArgs = param + , LP.defVarArgs = False + , LP.defAttrs = [] + , LP.defSection = Nothing + , LP.defGC = Nothing + , LP.defBody = code + , LP.defMetadata = mempty + , LP.defComdat = Nothing + } + } + diff --git a/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Fold.hs b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Fold.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Fold.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.Fold +-- 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.Fold + where + +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.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 +import Data.Array.Accelerate.LLVM.Compile.Cache + +import Data.Array.Accelerate.LLVM.Native.CodeGen.Base +import Data.Array.Accelerate.LLVM.Native.CodeGen.Generate +import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop +import Data.Array.Accelerate.LLVM.Native.Target ( Native ) + +import Control.Applicative +import Prelude as P hiding ( length ) + + +-- Reduce an array along the innermost dimension. The reduction +-- function must be associative to allow for an efficient parallel +-- 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 + :: 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. +-- +-- For simplicity, each element of the output (reduction along the entire length +-- of an innermost-dimension index) is computed by a single thread. +-- +mkFoldDim + :: 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 shR + (arrOut, paramOut) = mutableArray aR "out" + (arrIn, paramIn) = delayedArray "in" mdelayed + paramEnv = envParam aenv + zero = liftInt 0 + in + makeOpenAcc uid "fold" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do + + 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 + + +-- Reduce an array to single element. +-- +-- Since reductions consume arrays that have been fused into them, +-- a parallel fold requires two passes. At an example, take vector dot +-- product: +-- +-- > dotp xs ys = fold (+) 0 (zipWith (*) xs ys) +-- +-- 1. The first pass reads in the fused array data, in this case corresponding +-- to the function (\i -> (xs!i) * (ys!i)). +-- +-- 2. The second pass reads in the manifest array data from the first step and +-- directly reduces the array. This second step should be small and so is +-- usually just done by a single core. +-- +-- Note that the first step is split into two kernels, the second of which +-- reads a carry-in value of that thread's partial reduction, so that +-- threads can still participate in work-stealing. These kernels must not +-- be invoked over empty ranges. +-- +-- The final step is sequential reduction of the partial results. If this +-- is an exclusive reduction, the seed element is included at this point. +-- +mkFoldAll + :: 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 + :: 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 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 ++ paramIn ++ paramEnv) $ do + r <- case mseed of + Just seed -> do z <- seed + 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 + + +-- Parallel reduction of an entire array to a single element, step 1. +-- +-- Threads reduce each stripe of the input into a temporary array, incorporating +-- any fused functions on the way. +-- +mkFoldAllP1 + :: 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 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 ++ 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. This method thus + -- supports non-commutative operators because the order of operations + -- remains left-to-right. + -- + r <- reduce1FromTo eR (indexHead start) (indexHead end) (app2 combine) (app1 (delayedLinearIndex arrIn)) + writeArray TypeInt arrTmp piece r + + +-- Parallel reduction of an entire array to a single element, step 2. +-- +-- A single thread reduces the temporary array to a single element. +-- +-- During execution, we choose a stripe size in phase 1 so that the temporary is +-- small-ish and thus suitable for sequential reduction. An alternative would be +-- to keep the stripe size constant and, for if the partial reductions array is +-- large, continuing reducing it in parallel. +-- +mkFoldAllP2 + :: 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 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 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 + + +-- Exclusive reductions over empty arrays (of any dimension) fill the lower +-- dimensions with the initial element +-- +mkFoldFill + :: UID + -> Gamma aenv + -> 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 +-- --------------- + +-- Reduction of a (possibly empty) index space. +-- +reduceFromTo + :: 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 + +-- Reduction of an array over a _non-empty_ index space. The array must +-- contain at least one element. +-- +reduce1FromTo + :: 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 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 new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/FoldSeg.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.FoldSeg +-- 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.FoldSeg + where + +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.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.CodeGen.Base +import Data.Array.Accelerate.LLVM.Native.CodeGen.Fold +import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop +import Data.Array.Accelerate.LLVM.Native.Target ( Native ) + +import Control.Monad +import Prelude as P + +{-- +-- 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) + -> 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 @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 ++ paramIn ++ paramSeg ++ paramEnv) $ do + + -- Number of segments, useful only if reducing DIM2 and higher + ss <- indexHead <$> delayedExtent arrSeg + + let test si = A.lt singleType (A.fst si) (indexHead end) + initial = A.pair (indexHead start) (lift 0) + + 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 @sh of + 0 -> return s + _ -> A.rem integralType s ss + + 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 arrIn)) + Nothing -> reduce1FromTo inf sup (app2 combine) (app1 (delayedLinearIndex arrIn)) + writeArray arrOut s r + + t <- A.add numType s (lift 1) + return $ A.pair t sup + + 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. +-- +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 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 ++ paramIn ++ paramSeg ++ paramEnv) $ do + + imapNestFromTo shR start end (irArrayShape arrOut) $ \ix ii -> do + + -- 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 eR u v (app2 combine) z (app1 (delayedIndex arrIn) . indexCons iz) + Nothing -> reduce1FromTo eR u v (app2 combine) (app1 (delayedIndex arrIn) . indexCons iz) + + writeArray TypeInt arrOut ii r + diff --git a/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Generate.hs b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Generate.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Generate.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.Generate +-- 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.Generate + where + +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.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 + + +-- Construct a new array by applying a function to each index. Each thread +-- processes multiple adjacent elements. +-- +mkGenerate + :: UID + -> Gamma aenv + -> 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 (arrayRshape repr) + (arrOut, paramOut) = mutableArray repr "out" + paramEnv = envParam aenv + shOut = irArrayShape arrOut + in + makeOpenAcc uid "generate" (paramGang ++ paramOut ++ 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 + diff --git a/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Loop.hs b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Loop.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Loop.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.CodeGen.Native.Loop +-- 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.Loop + where + +-- accelerate +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 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 + :: 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 (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 + :: 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 new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Map.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.Map +-- 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.Map + where + +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 + +import Data.Array.Accelerate.LLVM.Native.Target ( Native ) +import Data.Array.Accelerate.LLVM.Native.CodeGen.Base +import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop + + +-- C Code +-- ====== +-- +-- float f(float); +-- +-- void map(float* __restrict__ out, const float* __restrict__ in, const int n) +-- { +-- for (int i = 0; i < n; ++i) +-- out[i] = f(in[i]); +-- +-- return; +-- } + +-- Corresponding LLVM +-- ================== +-- +-- define void @map(float* noalias nocapture %out, float* noalias nocapture %in, i32 %n) nounwind uwtable ssp { +-- %1 = icmp sgt i32 %n, 0 +-- br i1 %1, label %.lr.ph, label %._crit_edge +-- +-- .lr.ph: ; preds = %0, %.lr.ph +-- %indvars.iv = phi i64 [ %indvars.iv.next, %.lr.ph ], [ 0, %0 ] +-- %2 = getelementptr inbounds float* %in, i64 %indvars.iv +-- %3 = load float* %2, align 4 +-- %4 = tail call float @apply(float %3) nounwind +-- %5 = getelementptr inbounds float* %out, i64 %indvars.iv +-- store float %4, float* %5, align 4 +-- %indvars.iv.next = add i64 %indvars.iv, 1 +-- %lftr.wideiv = trunc i64 %indvars.iv.next to i32 +-- %exitcond = icmp eq i32 %lftr.wideiv, %n +-- br i1 %exitcond, label %._crit_edge, label %.lr.ph +-- +-- ._crit_edge: ; preds = %.lr.ph, %0 +-- ret void +-- } +-- +-- declare float @apply(float) +-- + +-- Apply the given unary function to each element of an array. +-- +-- 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 dim1 + (arrIn, paramIn) = mutableArray (ArrayR shR aR) "in" + (arrOut, paramOut) = mutableArray (ArrayR shR bR) "out" + paramEnv = envParam aenv + in + makeOpenAcc uid "map" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do + + imapFromTo (indexHead start) (indexHead end) $ \i -> do + xs <- readArray TypeInt arrIn i + ys <- app1 apply xs + writeArray TypeInt arrOut i ys + diff --git a/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Permute.hs b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Permute.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Permute.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.Permute +-- Copyright : [2016..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.CodeGen.Permute + where + +import Data.Array.Accelerate.AST ( PrimMaybe ) +import Data.Array.Accelerate.Error +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 +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.Permute +import Data.Array.Accelerate.LLVM.CodeGen.Ptr +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 + +import LLVM.AST.Type.GetElementPtr +import LLVM.AST.Type.Instruction +import LLVM.AST.Type.Instruction.Atomic +import LLVM.AST.Type.Instruction.RMW as RMW +import LLVM.AST.Type.Instruction.Volatile +import LLVM.AST.Type.Representation + +import Control.Applicative +import Control.Monad ( void ) +import Prelude + + +-- Forward permutation specified by an indexing mapping. The resulting array is +-- initialised with the given defaults, and any further values that are permuted +-- into the result array are added to the current value using the combination +-- function. +-- +-- The combination function must be /associative/ and /commutative/. Elements +-- that are mapped to the magic index 'ignore' are dropped. +-- +mkPermute + :: HasCallStack + => UID + -> Gamma aenv + -> ArrayR (Array sh e) + -> ShapeR sh' + -> IRPermuteFun 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)) +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 +-- could be because we are executing sequentially with a single thread, or +-- because the default values are unused (e.g. for a filter). +-- +-- We could also use this method if we can prove that the mapping function is +-- injective (distinct elements in the domain map to distinct elements in the +-- co-domain). +-- +mkPermuteS + :: UID + -> Gamma aenv + -> ArrayR (Array sh e) + -> ShapeR sh' + -> IRPermuteFun 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)) +mkPermuteS uid aenv repr shr IRPermuteFun{..} project marr = + let + (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 ++ paramIn ++ paramEnv) $ do + + sh <- delayedExtent arrIn + + imapNestFromTo (arrayRshape repr) start end sh $ \ix _ -> do + + ix' <- app1 project ix + + when (isJust ix') $ do + i <- fromJust ix' + j <- intOfIndex shr (irArrayShape arrOut) i + + -- project element onto the destination array and update + x <- app1 (delayedIndex arrIn) ix + y <- readArray TypeInt arrOut j + r <- app2 combine x y + + writeArray TypeInt arrOut j r + + +-- Parallel forward permutation has to take special care because different +-- threads could concurrently try to update the same memory location. Where +-- available we make use of special atomic instructions and other optimisations, +-- but in the general case each element of the output array has a lock which +-- must be obtained by the thread before it can update that memory location. +-- +-- TODO: After too many failures to acquire the lock on an element, the thread +-- should back off and try a different element, adding this failed element to +-- a queue or some such. +-- +mkPermuteP + :: HasCallStack + => UID + -> Gamma aenv + -> ArrayR (Array sh e) + -> ShapeR sh' + -> IRPermuteFun 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 uid aenv repr shr IRPermuteFun{..} project arr = + case atomicRMW of + 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 + :: HasCallStack + => UID + -> Gamma aenv + -> ArrayR (Array sh e) + -> ShapeR sh' + -> RMWOperation + -> 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 (arrayRshape repr) + (arrOut, paramOut) = mutableArray (reprOut repr shr) "out" + (arrIn, paramIn) = delayedArray "in" marr + paramEnv = envParam aenv + in + makeOpenAcc uid "permuteP_rmw" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do + + sh <- delayedExtent arrIn + + imapNestFromTo (arrayRshape repr) start end sh $ \ix _ -> do + + ix' <- app1 project ix + + 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 TypeInt arrOut j r + -- + _ | TupRsingle (SingleScalarType s) <- arrayRtype repr + , adata <- irArrayData arrOut + -> do + addr <- instr' $ GetElementPtr $ GEP1 (SingleScalarType s) (asPtr defaultAddrSpace (op s adata)) (op integralType j) + -- + case s of + NumSingleType t -> void . instr' $ AtomicRMW t NonVolatile rmw addr (op t r) (CrossThread, AcquireRelease) + -- + _ -> internalError "unexpected transition" + + +-- Parallel forward permutation function which uses a spinlock to acquire +-- a mutex before updating the value at that location. +-- +mkPermuteP_mutex + :: 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 (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 ++ paramIn ++ paramEnv) $ do + + sh <- delayedExtent arrIn + + imapNestFromTo (arrayRshape repr) start end sh $ \ix _ -> do + + ix' <- app1 project ix + + -- project element onto the destination array and (atomically) update + when (isJust ix') $ do + i <- fromJust ix' + j <- intOfIndex shr (irArrayShape arrOut) i + x <- app1 (delayedIndex arrIn) ix + + atomically arrLock j $ do + y <- readArray TypeInt arrOut j + r <- app2 combine x y + writeArray TypeInt arrOut j r + + +-- Atomically execute the critical section only when the lock at the given array +-- index is obtained. The thread spins waiting for the lock to be released and +-- there is no backoff strategy in case the lock is contended. +-- +-- It is important that the thread loops trying to acquire the lock without +-- writing data anything until the lock value changes. Then, because of MESI +-- caching protocols there will be no bus traffic while the CPU waits for the +-- value to change. +-- +-- +-- +atomically + :: IRArray (Vector Word8) + -> Operands Int + -> CodeGen Native a + -> CodeGen Native a +atomically barriers i action = do + let + lock = integral integralType 1 + unlock = integral integralType 0 + unlocked = ir TypeWord8 unlock + -- + spin <- newBlock "spinlock.entry" + crit <- newBlock "spinlock.critical-section" + exit <- newBlock "spinlock.exit" + + addr <- instr' $ GetElementPtr $ GEP1 scalarTypeWord8 (asPtr defaultAddrSpace (op integralType (irArrayData barriers))) (op integralType i) + _ <- br spin + + -- Atomically (attempt to) set the lock slot to the locked state. If the slot + -- was unlocked we just acquired it, otherwise the state remains unchanged and + -- we spin until it becomes available. + setBlock spin + old <- instr $ AtomicRMW numType NonVolatile Exchange addr lock (CrossThread, Acquire) + ok <- A.eq singleType old unlocked + _ <- cbr ok crit spin + + -- We just acquired the lock; perform the critical section then release the + -- lock and exit. For ("some") x86 processors, an unlocked MOV instruction + -- could be used rather than the slower XCHG, due to subtle memory ordering + -- rules. + setBlock crit + r <- action + _ <- instr $ AtomicRMW numType NonVolatile Exchange addr unlock (CrossThread, Release) + _ <- br exit + + setBlock exit + return r + + +-- Helper functions +-- ---------------- + +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 new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/CodeGen/Scan.hs @@ -0,0 +1,698 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.CodeGen.Scan +-- 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.Scan + where + +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.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.Loop +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.CodeGen.Base +import Data.Array.Accelerate.LLVM.Native.CodeGen.Generate +import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop +import Data.Array.Accelerate.LLVM.Native.Target ( Native ) + +import Control.Applicative +import Control.Monad +import Data.String ( fromString ) +import Data.Coerce as Safe +import Prelude as P + + +-- '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] +-- +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. +-- +-- > scanr' (+) 10 (use $ fromList (Z :. 10) [0..]) +-- > +-- > ==> ( Array (Z :. 10) [10,10,11,13,16,20,25,31,38,46] +-- , Array Z [55] +-- ) +-- +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 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 + :: 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 + :: 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 +-- inclusive scans we can assume that the innermost-dimension is at least one +-- element. +-- +-- Note that we can use this both when there is a single thread, or in parallel +-- where threads are scheduled over the outer dimensions (segments). +-- +mkScanS + :: Direction + -> UID + -> 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 shR + (arrOut, paramOut) = mutableArray aR "out" + (arrIn, paramIn) = delayedArray "in" marr + paramEnv = envParam aenv + ShapeRsnoc shR = arrayRshape aR + -- + 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 ++ paramIn ++ paramEnv) $ do + + -- 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 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 + 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 + 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 (delayedIndex arrIn) (indexCons ix i0) <*> next i0 + + -- Write first element, then continue looping through the rest of + -- this innermost dimension + k0 <- intOfIndex (arrayRshape aR) shOut (indexCons ix j0) + j1 <- next j0 + writeArray TypeInt arrOut k0 v0 + + 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) + + +mkScan'S + :: Direction + -> UID + -> 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 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 + LeftToRight -> A.add numType i (liftInt 1) + RightToLeft -> A.sub numType i (liftInt 1) + in + makeOpenAcc uid "scanS" (paramGang ++ paramOut ++ paramSum ++ paramIn ++ paramEnv) $ do + + shIn <- delayedExtent arrIn + let sz = indexHead shIn + shOut = shIn + + imapNestFromTo shR start end (indexTail shIn) $ \ix ii -> do + + -- index to read data from + i0 <- case dir of + LeftToRight -> return (liftInt 0) + RightToLeft -> A.sub numType sz (liftInt 1) + + -- initial element + v0 <- seed + + -- 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 (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 + + 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) + + writeArray TypeInt arrSum ii (A.snd r) + + +mkScanP + :: Direction + -> UID + -> 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. +-- +-- Threads scan a stripe of the input into a temporary array, incorporating the +-- initial element and any fused functions on the way. The final reduction +-- result of this chunk is written to a separate array. +-- +mkScanP1 + :: Direction + -> UID + -> 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 + (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 (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 + 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 ++ 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. + -- + -- 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. + -- + -- index i* is the index that we read data from. Recall that the supremum + -- index is exclusive + i0 <- case dir of + 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 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 + 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 piece. Update the read-from + -- index appropriately + (v0,i1) <- A.unpair <$> case mseed of + 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 TypeInt arrOut j0 v0 + j1 <- next j0 + + -- Continue looping through the rest of the input + let cont i = + case dir of + LeftToRight -> A.lt singleType i (indexHead end) + RightToLeft -> A.gte singleType i (indexHead start) + + r <- while (TupRunit `TupRpair` TupRsingle scalarTypeInt `TupRpair` TupRsingle scalarTypeInt `TupRpair` eR) + (cont . A.fst3) + (\(A.untrip -> (i,j,v)) -> do + u <- app1 (delayedLinearIndex arrIn) i + v' <- case dir of + 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 piece + writeArray TypeInt arrTmp piece (A.thd3 r) + + +-- Parallel scan, step 2. +-- +-- A single thread performs an in-place inclusive scan of the partial block +-- sums. This forms the carry-in value which are added to the stripe partial +-- results in the final step. +-- +mkScanP2 + :: Direction + -> UID + -> 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 dim1 + (arrTmp, paramTmp) = mutableArray (ArrayR dim1 eR) "tmp" + paramEnv = envParam aenv + -- + cont i = case dir of + LeftToRight -> A.lt singleType i (indexHead end) + RightToLeft -> A.gte singleType i (indexHead start) + + 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 + LeftToRight -> return (indexHead start) + RightToLeft -> next (indexHead end) + + v0 <- readArray TypeInt arrTmp i0 + i1 <- next i0 + + void $ while (TupRsingle scalarTypeInt `TupRpair` eR) + (cont . A.fst) + (\(A.unpair -> (i,v)) -> do + u <- readArray TypeInt arrTmp i + i' <- next i + v' <- case dir of + LeftToRight -> app2 combine v u + RightToLeft -> app2 combine u v + writeArray TypeInt arrTmp i v' + return $ A.pair i' v') + (A.pair i1 v0) + + +-- Parallel scan, step 3. +-- +-- Threads combine every element of the partial block results with the carry-in +-- value computed from step 2. +-- +-- Note that first chunk does not need extra processing (has no carry-in value). +-- +mkScanP3 + :: Direction + -> UID + -> Gamma aenv + -> 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 + (start, end, paramGang) = gangParam dim1 + (arrOut, paramOut) = mutableArray (ArrayR dim1 eR) "out" + (arrTmp, paramTmp) = mutableArray (ArrayR dim1 eR) "tmp" + paramEnv = envParam aenv + -- + 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 + 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 ++ paramPiece ++ paramSteps ++ paramOut ++ paramTmp ++ paramEnv) $ do + + -- 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 + + -- 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) + + -- Read in the carry in value for this piece + c <- readArray TypeInt arrTmp =<< prev piece + + 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 + + +mkScan'P + :: Direction + -> UID + -> 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, the output indices are shifted by one relative to the input +-- indices to make space for the initial element. +-- +mkScan'P1 + :: Direction + -> UID + -> 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 + (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 (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 + 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 ++ paramPiece ++ paramSteps ++ paramOut ++ paramTmp ++ paramIn ++ paramEnv) $ do + + -- index i* is the index that we pull data from. + i0 <- case dir of + LeftToRight -> return (indexHead start) + RightToLeft -> next (indexHead end) + + -- 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 (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 (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 TypeInt arrOut j0 v0 + j1 <- next j0 + + -- Continue looping through the rest of the input + let cont i = + case dir of + LeftToRight -> A.lt singleType i (indexHead end) + RightToLeft -> A.gte singleType i (indexHead start) + + r <- while (TupRunit `TupRpair` TupRsingle scalarTypeInt `TupRpair` TupRsingle scalarTypeInt `TupRpair` eR) + (cont . A.fst3) + (\(A.untrip-> (i,j,v)) -> do + u <- app1 (delayedLinearIndex arrIn) i + v' <- case dir of + 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 piece + writeArray TypeInt arrTmp piece (A.thd3 r) + + +-- Parallel scan', step 2 +-- +-- Identical to mkScanP2, except we store the total scan result into a separate +-- array (rather than discard it). +-- +mkScan'P2 + :: Direction + -> UID + -> 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 dim1 + (arrTmp, paramTmp) = mutableArray (ArrayR dim1 eR) "tmp" + (arrSum, paramSum) = mutableArray (ArrayR dim0 eR) "sum" + paramEnv = envParam aenv + -- + cont i = case dir of + LeftToRight -> A.lt singleType i (indexHead end) + RightToLeft -> A.gte singleType i (indexHead start) + + 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 + LeftToRight -> return (indexHead start) + RightToLeft -> next (indexHead end) + + v0 <- readArray TypeInt arrTmp i0 + i1 <- next i0 + + r <- while (TupRpair (TupRsingle scalarTypeInt) eR) + (cont . A.fst) + (\(A.unpair -> (i,v)) -> do + u <- readArray TypeInt arrTmp i + i' <- next i + v' <- case dir of + 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 TypeInt arrSum (liftInt 0) (A.snd r) + + +-- Parallel scan', step 3 +-- +-- 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). +-- +-- Note that the first chunk does not need to do any extra processing (has no +-- carry-in value). +-- +mkScan'P3 + :: Direction + -> UID + -> 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 + (start, end, paramGang) = gangParam dim1 + (arrOut, paramOut) = mutableArray (ArrayR dim1 eR) "out" + (arrTmp, paramTmp) = mutableArray (ArrayR dim1 eR) "tmp" + paramEnv = envParam aenv + -- + 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 + 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 ++ paramPiece ++ paramSteps ++ paramOut ++ paramTmp ++ paramEnv) $ do + + -- TODO: don't schedule the "first" piece. + -- + A.when (neq singleType piece firstPiece) $ do + + -- Compute start and end indices, leaving space for the initial element + inf <- next (indexHead start) + sup <- next (indexHead end) + + -- Read the carry-in value for this piece + c <- readArray TypeInt arrTmp =<< prev piece + + -- 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 + 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,214 @@ +{-# 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 Data.Array.Accelerate.LLVM.Internal.LLVMPretty as LP + +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) + -> [LP.Typed LP.Ident] + -> 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 + + +mkBorder + :: UID + -> Gamma aenv + -> ArrayR (Array sh e) + -> IRFun1 Native aenv (sh -> e) + -> [LP.Typed LP.Ident] + -> 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 + + +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,61 @@ +{-# 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 + diff --git a/src/Data/Array/Accelerate/LLVM/Native/Compile.hs b/src/Data/Array/Accelerate/LLVM/Native/Compile.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Compile.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Compile +-- Copyright : [2014..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Compile ( + + module Data.Array.Accelerate.LLVM.Compile, + ObjectR(..), + +) where + +import Data.Array.Accelerate.AST ( PreOpenAcc ) +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Trafo.Delayed + +import Data.Array.Accelerate.LLVM.CodeGen +import Data.Array.Accelerate.LLVM.Compile +import Data.Array.Accelerate.LLVM.State +import Data.Array.Accelerate.LLVM.Target.ClangInfo ( hostLLVMVersion, llvmverFromTuple, clangExePath ) +import Data.Array.Accelerate.LLVM.CodeGen.Environment ( Gamma ) +import Data.Array.Accelerate.LLVM.CodeGen.Module ( Module(..) ) + +import Data.Array.Accelerate.LLVM.Native.CodeGen ( ) +import Data.Array.Accelerate.LLVM.Native.Compile.Cache +import Data.Array.Accelerate.LLVM.Native.Foreign ( ) +import Data.Array.Accelerate.LLVM.Native.Target +import qualified Data.Array.Accelerate.LLVM.Native.Debug as Debug + +import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty as P +import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty.PP as P +import qualified Text.PrettyPrint as P ( render ) + +import Control.Applicative +import Control.Monad.State +import Data.ByteString.Short ( ShortByteString ) +import Data.List ( intercalate ) +import Data.Foldable ( toList ) +import Data.Maybe +import Formatting +import System.Directory +import System.Environment +import System.FilePath ( (<.>) ) +import qualified System.Info as Info +import System.IO.Unsafe +import System.Process +import qualified Data.ByteString.Short.Char8 as SBS8 +import qualified Data.Map.Strict as Map + + +instance Compile Native where + data ObjectR Native = ObjectR + { objId :: {-# UNPACK #-} !UID + , objSyms :: ![ShortByteString] + , staticObjPath :: {- LAZY -} FilePath + , sharedObjPath :: {- LAZY -} FilePath + } + compileForTarget = compile + +instance Intrinsic Native + + +-- | Compile an Accelerate expression to object code. +-- +-- This compilation step creates a static object file and a shared object +-- file, on demand. The former is used in the case of @runQ@ to statically +-- link the compiled object into the executable and generate FFI imports so +-- that the compiled kernel can be embedded directly into the resulting +-- executable. The latter will convert the former into a shared object to +-- be loaded into the running executable using the system's dynamic linker. +-- +compile :: PreOpenAcc DelayedOpenAcc aenv a -> Gamma aenv -> LLVM Native (ObjectR Native) +compile pacc aenv = do + + -- Generate code for this Acc operation + -- + -- 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, cachePath) <- cacheOfPreOpenAcc pacc + Module ast md <- llvmOfPreOpenAcc uid pacc aenv + + let staticObjFile = cachePath <.> staticObjExt + sharedObjFile = cachePath <.> sharedObjExt + -- triple = fromMaybe BS.empty (moduleTargetTriple ast) + -- datalayout = moduleDataLayout ast + nms = [ SBS8.pack f | P.Symbol f <- Map.keys md ] + + -- Lower the generated LLVM and produce an object file. + -- + -- The 'staticObjPath' field is only lazily evaluated since the object + -- code might already have been loaded into memory from a different + -- function, in which case it will be found in the linker cache. + -- + o_file <- liftIO . unsafeInterleaveIO $ do + force_recomp <- if Debug.debuggingIsEnabled then Debug.getFlag Debug.force_recomp else return False + o_file_exists <- doesFileExist staticObjFile + if o_file_exists && not force_recomp + then + Debug.traceM Debug.dump_cc ("cc: found cached object " % shown) uid + + else do + -- print ast + + -- Detect LLVM version + -- Note: this LLVM version is incorporated in the cache path, so we're safe detecting it at runtime. + let prettyHostLLVMVersion = intercalate "." (Prelude.map show (toList hostLLVMVersion)) + llvmver <- case llvmverFromTuple hostLLVMVersion of + Just llvmver -> return llvmver + Nothing -> internalError ("accelerate-llvm-native: Unsupported LLVM version: " % string) + prettyHostLLVMVersion + Debug.traceM Debug.dump_cc ("Using Clang at " % string % " version " % shown) clangExePath prettyHostLLVMVersion + + -- Convert module to llvm-pretty format so that we can print it + let unoptimisedText = P.render (P.ppLLVM llvmver (P.ppModule ast)) + Debug.when Debug.verbose $ do + Debug.traceM Debug.dump_cc ("Unoptimised LLVM IR:\n" % string) unoptimisedText + + dVerbose <- Debug.getFlag Debug.verbose + dDumpCC <- Debug.getFlag Debug.dump_cc + dDumpAsm <- Debug.getFlag Debug.dump_asm + + let clangFlags inputType outputFlags output = + -- '-O3' is ignored when only assembling; let's avoid clang warning about that + (if inputType == "assembler" then [] else ["-O3"]) ++ + (case takeWhile (/= '-') (SBS8.unpack nativeTargetTriple) of + "aarch64" -> ["-mcpu=native"] -- e.g. Ampere + "arm64" -> ["-mcpu=native"] -- e.g. Apple + _ -> ["-march=native"]) ++ -- e.g. x86_64 + ["-c", "-o", output, "-x", inputType, "-" + -- clang knows better what the target triple (and the data + -- layout) should be than us, so let it override the triple, and + -- don't warn about it + -- TODO: change llvm-pretty so that it doesn't require us to give + -- it a target triple + ,"-Wno-override-module"] ++ + outputFlags + + let linkOutputFlags | Info.os == "mingw32" = [] + | otherwise = ["-fPIC"] + + -- Minimise the number of clang invocations (to 1) in the common case + -- of no verbose debug flags. If we need to print some intermediate + -- stages, run all stages separately for simplicity, and print only the + -- intermediate values that were requested. + -- See llvm-project/clang/include/clang/Driver/Types.def for "-x" argument values: + -- https://github.com/llvm/llvm-project/blob/da286c8bf69684d1612d1fc440bd9c6f1a4326df/clang/include/clang/Driver/Types.def + if dVerbose && (dDumpCC || dDumpAsm) + then do + optText <- readProcess clangExePath (clangFlags "ir" ["-S", "-emit-llvm"] "-") unoptimisedText + Debug.traceM Debug.dump_cc ("Optimised LLVM IR:\n" % string) optText + asmText <- readProcess clangExePath (clangFlags "ir" ["-S"] "-") optText + Debug.traceM Debug.dump_asm ("Optimised assembly:\n" % string) asmText + _ <- readProcess clangExePath (clangFlags "assembler" linkOutputFlags staticObjFile) asmText + return () + else do + _ <- readProcess clangExePath (clangFlags "ir" linkOutputFlags staticObjFile) unoptimisedText + return () + + Debug.traceM Debug.dump_cc ("cc: new object code " % shown) uid + + return staticObjFile + + -- Convert the relocatable object file (created above) into a shared + -- object file using the operating system's native linker. + -- + -- Once again, the 'sharedObjPath' is only lazily evaluated since the + -- object code might already have been loaded into memory from + -- a different function. + -- + so_file <- liftIO . unsafeInterleaveIO $ do + force_recomp <- if Debug.debuggingIsEnabled then Debug.getFlag Debug.force_recomp else return False + so_file_exists <- doesFileExist sharedObjFile + if so_file_exists && not force_recomp + then + Debug.traceM Debug.dump_cc ("cc: found cached shared object " % shown) uid + + else do + o_file_exists <- doesFileExist staticObjFile + objFile <- if o_file_exists && not force_recomp + then do + Debug.traceM Debug.dump_cc ("cc: found cached object " % shown) uid + return staticObjFile + else + return o_file + + -- LLVM doesn't seem to provide a way to build a shared object file + -- directly, so shell out to the system linker to do this. + -- + case Info.os of + "darwin" -> + -- TODO: Unclear if -lm is necessary on Darwin too; let's add it + -- just in case. (The -lm on Linux was added to properly declare + -- dependency on libm, so that it gets pulled in even if the main + -- executable is statically-linked and thus does not have a dynamic + -- libm in its address space.) + callProcess ld ["--shared", "-o", sharedObjFile, objFile, "-undefined", "dynamic_lookup", "-lm"] + "mingw32" -> -- windows + callProcess ld ["--shared", "-o", sharedObjFile, objFile] -- no -lm necessary on windows + _ -> -- linux etc. + callProcess ld ["--shared", "-o", sharedObjFile, objFile, "-lm"] + Debug.traceM Debug.dump_cc ("cc: new shared object " % shown) uid + + return sharedObjFile + + return $! ObjectR uid nms o_file so_file + + +-- Respect the common @LD@ and @CC@ environment variables, falling back to +-- search the path for @cc@ if neither of those exist. +-- +-- XXX: On Unixy systems, we use @cc@ as the default instead of @ld@ because +-- on macOS this will do the right thing, whereas 'ld --shared' will not. +-- On Windows, we just use clang as the driver to "do the right thing". +-- +ld :: FilePath +ld = unsafePerformIO $ do + let defProgram | Info.os == "mingw32" = clangExePath + | otherwise = "cc" + mfromEnv <- liftA2 (<|>) (lookupEnv "LD") (lookupEnv "CC") + return (fromMaybe defProgram mfromEnv) + +-- The file extension for static libraries +-- +staticObjExt :: String +staticObjExt | Info.os == "mingw32" = "obj" + | otherwise = "o" + +-- The file extension used for shared libraries +-- +sharedObjExt :: String +sharedObjExt = case Info.os of + "darwin" -> "dylib" + "mingw32" -> "dll" + _ -> "so" -- let's just default to the unixy ".so" diff --git a/src/Data/Array/Accelerate/LLVM/Native/Compile/Cache.hs b/src/Data/Array/Accelerate/LLVM/Native/Compile/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Compile/Cache.hs @@ -0,0 +1,42 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Compile.Cache +-- Copyright : [2017..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Compile.Cache ( + + module Data.Array.Accelerate.LLVM.Compile.Cache + +) where + +import Data.Array.Accelerate.LLVM.Compile.Cache +import Data.Array.Accelerate.LLVM.Native.Target +import Data.Array.Accelerate.LLVM.Target.ClangInfo ( hostLLVMVersion ) + +import Data.Foldable ( toList ) +import Data.List ( intercalate ) +import Data.Version +import System.FilePath +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Short.Char8 as S8 + +import Paths_accelerate_llvm_native + + +instance Persistent Native where + targetCacheTemplate = + -- The "llvmpr" is for "llvm-pretty". This is to ensure we still have a + -- sensible cache path to switch to should we ever move away from + -- llvm-pretty again. + return $ "accelerate-llvm-native-" ++ showVersion version + "llvmpr-" ++ intercalate "." (map show (toList hostLLVMVersion)) + S8.unpack nativeTargetTriple + B8.unpack nativeCPUName + "meep" + diff --git a/src/Data/Array/Accelerate/LLVM/Native/Debug.hs b/src/Data/Array/Accelerate/LLVM/Native/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Debug.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Debug +-- 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.Debug ( + + module Data.Array.Accelerate.Debug.Internal, + module Data.Array.Accelerate.LLVM.Native.Debug, + +) where + +import Data.Array.Accelerate.Debug.Internal hiding ( elapsed ) +import qualified Data.Array.Accelerate.Debug.Internal as Debug + +import Formatting +import Formatting.Internal +import Data.Text.Lazy.Builder + +import Control.Monad.Trans + + +-- | Display elapsed wall and CPU time, together with speedup fraction +-- +{-# INLINEABLE elapsedP #-} +elapsedP :: Format r (Double -> Double -> r) +elapsedP = Format $ \k cpuTime wallTime -> + k $ bformat (formatSIBase (Just 3) 1000 % "s (wall), " % formatSIBase (Just 3) 1000 % "s (cpu), " % fixed 2 % " x speedup") + wallTime + cpuTime + (wallTime/cpuTime) + +-- | Display elapsed wall and CPU time +-- +{-# INLINEABLE elapsedS #-} +elapsedS :: Format r (Double -> Double -> r) +elapsedS = Debug.elapsed + + +data Phase = Compile | Link | Execute + +buildPhase :: Phase -> Builder +buildPhase = \case + Compile -> "compile" + Link -> "link" + Execute -> "execute" + +phase :: MonadIO m => Phase -> Format Builder (Double -> Double -> Builder) -> m a -> m a +phase p fmt = timed dump_phases (now ("phase " <> buildPhase p <> ": ") % fmt) + +{-- +phase :: (MonadIO m, HasCallStack) => Phase -> (Double -> Double -> Builder) -> m a -> m a +phase p fmt go = do + let (p_phase, sz_phase) = case p of + Compile -> (Ptr $(litE (stringPrimL (map (fromIntegral . ord) "compile\0"))), 7) + Link -> (Ptr $(litE (stringPrimL (map (fromIntegral . ord) "link\0"))), 4) + Execute -> (Ptr $(litE (stringPrimL (map (fromIntegral . ord) "execute\0"))), 7) + (line, file, fun) = case getCallStack callStack of + [] -> (0, [], []) + ((f,l):_) -> (srcLocStartLine l, srcLocFile l, f) + -- + zone <- liftIO $ + withCStringLen file $ \(p_file, sz_file) -> + withCStringLen fun $ \(p_fun, sz_fun) -> do + srcloc <- alloc_srcloc_name (fromIntegral line) p_file (fromIntegral sz_file) p_fun (fromIntegral sz_fun) p_phase sz_phase + zone <- emit_zone_begin srcloc 1 + return zone + + result <- timed dump_phases (\wall cpu -> build "phase {}: {}" (p, fmt wall cpu)) go + _ <- liftIO $ emit_zone_end zone + + return result +--} + diff --git a/src/Data/Array/Accelerate/LLVM/Native/Embed.hs b/src/Data/Array/Accelerate/LLVM/Native/Embed.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Embed.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Embed +-- Copyright : [2017..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Embed ( + + module Data.Array.Accelerate.LLVM.Embed, + +) where + +import Data.ByteString.Short.Char8 as S8 +import Data.ByteString.Short.Extra as BS + +import Data.Array.Accelerate.Lifetime + +import Data.Array.Accelerate.LLVM.Compile +import Data.Array.Accelerate.LLVM.Embed + +import Data.Array.Accelerate.LLVM.Native.Compile +import Data.Array.Accelerate.LLVM.Native.Compile.Cache +import Data.Array.Accelerate.LLVM.Native.Link +import Data.Array.Accelerate.LLVM.Native.Plugin.Annotation +import Data.Array.Accelerate.LLVM.Native.State +import Data.Array.Accelerate.LLVM.Native.Target + +import Control.Concurrent.Unique +import Control.Monad +import Data.Hashable +import Foreign.Ptr +import Data.Array.Accelerate.TH.Compat ( Q, CodeQ ) +import Numeric +import System.FilePath ( (<.>) ) +import System.IO.Unsafe +import qualified Data.Array.Accelerate.TH.Compat as TH +import qualified Language.Haskell.TH.Syntax as TH + +import Data.Maybe +import qualified Data.Set as Set + + +instance Embed Native where + embedForTarget = embed + +-- Add the given object code to the set of files to link the executable with, +-- and generate FFI declarations to access the external functions of that file. +-- The returned ExecutableR references the new FFI declarations. +-- +embed :: Native -> ObjectR Native -> CodeQ (ExecutableR Native) +embed target (ObjectR uid nms !_ _) = + TH.bindCode getObjectFile $ \objFile -> + [|| NativeR (unsafePerformIO $ newLifetime (FunctionTable $$(listE $ makeTable objFile nms))) ||] + where + listE :: [CodeQ a] -> CodeQ [a] + listE xs = TH.unsafeCodeCoerce (TH.listE (map TH.unTypeCode xs)) + + makeTable :: FilePath -> [ShortByteString] -> [CodeQ (ShortByteString, FunPtr ())] + makeTable objFile = map (\fn -> [|| ( $$(liftSBS fn), $$(makeFFI fn objFile) ) ||]) + + makeFFI :: ShortByteString -> FilePath -> CodeQ (FunPtr ()) + makeFFI (S8.unpack -> fn) objFile = TH.bindCode go (TH.unsafeCodeCoerce . return) + where + go = do + i <- TH.runIO newUnique + fn' <- TH.newName ("__accelerate_llvm_native_" ++ showHex (hash i) []) + dec <- TH.forImpD TH.CCall TH.Unsafe ('&':fn) fn' [t| FunPtr () |] + ann <- TH.pragAnnD (TH.ValueAnnotation fn') [| (Object objFile) |] + TH.addTopDecls [dec, ann] + TH.varE fn' + + -- Note: [Template Haskell and raw object files] + -- + -- We can only addForeignFilePath once per object file, otherwise the + -- 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 + cachePath <- TH.runIO (evalNative target (cacheOfUID uid)) + let objFile = cachePath <.> staticObjExt +#if __GLASGOW_HASKELL__ >= 806 + objSet <- fromMaybe Set.empty <$> TH.getQ + unless (Set.member objFile objSet) $ do + TH.addForeignFilePath TH.RawObject objFile + TH.putQ (Set.insert objFile objSet) +#endif + return objFile + +-- The file extension for static libraries +-- +staticObjExt :: String +#if defined(mingw32_HOST_OS) +staticObjExt = "obj" +#else +staticObjExt = "o" +#endif + diff --git a/src/Data/Array/Accelerate/LLVM/Native/Execute.hs b/src/Data/Array/Accelerate/LLVM/Native/Execute.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Execute.hs @@ -0,0 +1,1018 @@ +{-# 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.Concurrent.Extra ( getThreadId ) +import Control.Monad.Reader ( asks ) +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 Formatting +import System.CPUTime ( getCPUTime ) +import qualified Data.ByteString.Short as S +import qualified Data.ByteString.Short.Extra as SE +import qualified Data.ByteString.Short.Char8 as S8 +import qualified Data.Sequence as Seq +import qualified Data.DList as DL +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{..} <- asks 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{..} <- asks 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{..} <- asks 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{..} <- asks llvmTarget + future <- new + result <- allocateRemote (ArrayR dim0 tp) () + let + minsize = 4096 + ranges = divideWork1 splits minsize ((), 0) sh (,,) + splits = numWorkers workers - 1 + 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{..} <- asks llvmTarget + future <- new + result <- allocateRemote repr sh + let + ArrayR shr tp = repr + fun = nativeExecutable !# "fold" + splits = numWorkers workers - 1 + 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 iR repr NativeR{..} gamma aenv input@(delayedShape -> (sh, _)) segments@(delayedShape -> ((), ss)) = do + Native{..} <- asks llvmTarget + future <- new + let + n = ss-1 + splits = numWorkers workers - 1 + minsize = 1 + shR = arrayRshape repr + segR = ArrayR dim1 $ TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType iR + param = TupRsingle (ParamRarray repr) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray segR) + -- + result <- allocateRemote repr (sh, n) + 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 -> sh@(_, n)) = + case n of + 0 -> newFull =<< allocateRemote repr sh + _ -> 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{..} <- asks 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 - 1 + 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 + minsize = 8192 + ranges = divideWork dim1 splits minsize ((), 0) ((), n) (,,) + splits = numWorkers workers - 1 + steps = Seq.length ranges + reprTmp = ArrayR dim1 $ arrayRtype repr + paramTmp = TupRsingle $ ParamRarray reprTmp + 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{..} <- asks 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 - 1 + 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 + minsize = 8192 + ranges = divideWork1 splits minsize ((), 0) ((), n) (,,) + splits = numWorkers workers - 1 + 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{..} <- asks llvmTarget + future <- new + result <- if inplace + then Debug.trace Debug.dump_exec "exec: permute/inplace" $ return defaults + else Debug.timed Debug.dump_exec ("exec: permute/clone " % Debug.elapsedS) $ liftPar (cloneArray repr' defaults) + let + splits = numWorkers workers - 1 + 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{..} <- asks llvmTarget + future <- new + result <- allocateRemote repr sh + let + shr = arrayRshape repr + inside = nativeExecutable !# "stencil_inside" + border = nativeExecutable !# "stencil_border" + + splits = numWorkers workers - 1 + 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 + -- TODO: add tracy marks + Debug.timed Debug.dump_exec (now ("exec: " <> bformat string name <> " ") % Debug.elapsedP) (asm arr) + + +-- Skeleton execution +-- ------------------ + +(!#) :: HasCallStack => Lifetime FunctionTable -> ShortByteString -> Function +(!#) exe name + = fromMaybe (internalError ("function not found: " % string) (S8.unpack name)) + $ lookupFunction name exe + +lookupFunction :: ShortByteString -> Lifetime FunctionTable -> Maybe Function +lookupFunction name nativeExecutable = do + find (\(n,_) -> SE.take (S.length n - 65) 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{..} <- asks llvmTarget + let + splits = numWorkers workers - 1 + 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{..} <- asks 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{..} <- asks 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 (string % " " % parenthesised string % " -> " % parenthesised string) (S8.unpack name) (showShape shr u) (showShape shr v) + let argU = marshalShape' @Native shr u + let argV = marshalShape' @Native shr v + callFFI f retVoid $ DL.toList $ argU `DL.append` argV `DL.append` arg + +{-# 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 (string % " " % parenthesised string % " -> " % parenthesised string) (S8.unpack name) (showShape shr u) (showShape shr v) + let argU = marshalShape' @Native shr u + let argV = marshalShape' @Native shr v + let argI = DL.singleton $ marshalInt @Native i + 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 <- Debug.getFlag Debug.dump_exec + verbose <- Debug.getFlag Debug.verbose + 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 + name' | verbose = name + | otherwise = SE.take (S.length name - 65) name + -- + Debug.traceM Debug.dump_exec ("exec: " % string % " " % Debug.elapsedP) (S8.unpack name') wallTime cpuTime + -- + return $ Job { jobTasks = start Seq.<| jobTasks job + , jobDone = case jobDone job of + 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 :: Format (IO ()) a -> a +sched fmt = + runFormat fmt $ \k -> + Debug.when Debug.verbose $ + Debug.when Debug.dump_sched $ do + tid <- myThreadId + Debug.putTraceMsg ("sched: Thread " % int % " " % builder) (getThreadId tid) k + diff --git a/src/Data/Array/Accelerate/LLVM/Native/Execute/Async.hs b/src/Data/Array/Accelerate/LLVM/Native/Execute/Async.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Execute/Async.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# 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..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Execute.Async ( + + Async(..), Future(..), IVar(..), getArrays, + evalPar, putIO, + +) where + +-- accelerate +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.Reader +import Data.IORef +import Data.Sequence ( Seq ) +import qualified Data.Sequence as Seq + + +-- | Evaluate a parallel computation +-- +-- 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 + + -- 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 + + +-- Implementation +-- -------------- + +data Future a = Future {-# UNPACK #-} !(IORef (IVar a)) + +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, MonadReader 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 <- asks 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{..} <- asks 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 !n !minsize ((), (!from)) ((), (!to)) action = + let + split 0 !u !v !i !f !s + | v - u < minsize = (i+1, f, s Seq.|> apply i u v) + | 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 n 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 !n !minsize !from !to action = + let + -- Is it worth checking whether the piece is full? Doing so ensures that + -- full pieces are assigned to threads first, with the non-full blocks + -- 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 n (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 new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Execute/Environment.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE GADTs #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Execute.Environment +-- 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.Environment ( + + module Data.Array.Accelerate.LLVM.Execute.Environment, + module Data.Array.Accelerate.LLVM.Native.Execute.Environment, + +) where + +import Data.Array.Accelerate.LLVM.Native.Target +import Data.Array.Accelerate.LLVM.Execute.Environment + +type Val = ValR Native + diff --git a/src/Data/Array/Accelerate/LLVM/Native/Execute/Marshal.hs b/src/Data/Array/Accelerate/LLVM/Native/Execute/Marshal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Execute/Marshal.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Execute.Marshal +-- 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.Marshal ( module M ) + where + +import Data.Array.Accelerate.LLVM.Execute.Marshal as M +import Data.Array.Accelerate.Array.Unique + +import Data.Array.Accelerate.LLVM.Native.Execute.Async () -- instance Async Native +import Data.Array.Accelerate.LLVM.Native.Target + +import Data.Bits +import qualified Data.DList as DL +import qualified Foreign.LibFFI as FFI + + +instance Marshal Native where + type ArgR Native = FFI.Arg + type MarshalCleanup Native = () + marshalInt = $( case finiteBitSize (undefined::Int) of + 32 -> [| FFI.argInt32 . fromIntegral |] + 64 -> [| FFI.argInt64 . fromIntegral |] + _ -> error "I don't know what architecture I am" ) + marshalScalarData' _ = return . (,()) . DL.singleton . FFI.argPtr . unsafeUniqueArrayPtr + diff --git a/src/Data/Array/Accelerate/LLVM/Native/Execute/Scheduler.hs b/src/Data/Array/Accelerate/LLVM/Native/Execute/Scheduler.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Execute/Scheduler.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# 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 Debug + +import Control.Concurrent +import Control.Concurrent.Extra +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 Formatting +import qualified Data.Sequence as Seq + +import GHC.Base hiding ( build ) + +#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 ("sched: Thread " % int % " sleeping") (getThreadId 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 ("sched: Thread " % int % " shutting down") (getThreadId 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 ("sched: fork Thread " % int % " on capability " % int) (getThreadId 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 +-- ----- + +{-# INLINE message #-} +message :: Format (IO ()) a -> a +message = Debug.traceM Debug.dump_sched + diff --git a/src/Data/Array/Accelerate/LLVM/Native/Foreign.hs b/src/Data/Array/Accelerate/LLVM/Native/Foreign.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Foreign.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Foreign +-- Copyright : [2016..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Foreign ( + + -- Foreign functions + ForeignAcc(..), + ForeignExp(..), + + -- useful re-exports + LLVM, + Native(..), + liftIO, + module Data.Array.Accelerate.LLVM.Native.Array.Data, + module Data.Array.Accelerate.LLVM.Native.Execute.Async, + +) where + +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 +import Data.Typeable + + +instance Foreign Native where + 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 + +instance S.Foreign ForeignExp where + strForeign (ForeignExp s _) = s + + +-- Foreign functions in the Native backend. +-- +-- This is just some arbitrary monadic computation. +-- +data ForeignAcc f where + ForeignAcc :: String + -> (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-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 + ForeignExp :: String + -> IRFun1 Native () (x -> y) + -> ForeignExp (x -> y) + +deriving instance Typeable ForeignAcc +deriving instance Typeable ForeignExp + diff --git a/src/Data/Array/Accelerate/LLVM/Native/Link.hs b/src/Data/Array/Accelerate/LLVM/Native/Link.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Link.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Link +-- Copyright : [2017..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Link ( + + module Data.Array.Accelerate.LLVM.Link, + module Data.Array.Accelerate.LLVM.Native.Link, + ExecutableR(..), FunctionTable(..), Function, ObjectCode, + +) where + +import Data.Array.Accelerate.Lifetime + +import Data.Array.Accelerate.LLVM.Compile +import Data.Array.Accelerate.LLVM.Link +import Data.Array.Accelerate.LLVM.State + +import Data.Array.Accelerate.LLVM.Native.Target +import Data.Array.Accelerate.LLVM.Native.Compile + +import Data.Array.Accelerate.LLVM.Native.Link.Cache +import Data.Array.Accelerate.LLVM.Native.Link.Object +import Data.Array.Accelerate.LLVM.Native.Link.Runtime + +import Control.Monad.Reader +import Prelude hiding ( lookup ) + + +instance Link Native where + data ExecutableR Native = NativeR { nativeExecutable :: {-# UNPACK #-} !(Lifetime FunctionTable) + } + linkForTarget = link + + +-- | Link to the generated shared object file, creating function pointers for +-- every kernel's entry point. +-- +link :: ObjectR Native -> LLVM Native (ExecutableR Native) +link (ObjectR uid nms _ so) = do + cache <- asks linkCache + funs <- liftIO $ dlsym uid cache (loadSharedObject nms so) + return $! NativeR funs + + +-- | Execute some operation with the supplied executable functions +-- +withExecutable :: MonadIO m => ExecutableR Native -> (FunctionTable -> m b) -> m b +withExecutable NativeR{..} f = do + r <- f (unsafeGetValue nativeExecutable) + liftIO $ touchLifetime nativeExecutable + return r + diff --git a/src/Data/Array/Accelerate/LLVM/Native/Link/Cache.hs b/src/Data/Array/Accelerate/LLVM/Native/Link/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Link/Cache.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Link.Cache +-- Copyright : [2017..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Link.Cache ( + + LinkCache, + new, LC.dlsym, + +) where + +import Data.Array.Accelerate.Debug.Internal ( tracyIsEnabled ) + +import Data.Array.Accelerate.LLVM.Native.Link.Object +import qualified Data.Array.Accelerate.LLVM.Link.Cache as LC + +import Control.Monad + +#if defined(mingw32_HOST_OS) +import System.Win32.DLL +#else +import System.Posix.DynamicLinker +#endif + +type LinkCache = LC.LinkCache FunctionTable ObjectCode + +new :: IO LinkCache +new = do + -- For whatever reason ghci isn't adding library dependencies to the + -- dynamic link state, which means that dynamic linking will fail in + -- tracy mode because we depend on tracy symbols exported by the + -- accelerate library. This brings those symbols into scope so that they + -- can be found by later calls to dlsym(). + -- + -- Additionally, the Accelerate library has been compiled with -rdynamic + -- in order to bring all exported symbols into the global symbol table. + -- This seems to be required so that dlsym() can find symbols from the + -- GHC RTS when we are in compiled (not interpreted) mode. In non-ghci + -- mode, loading the RTS dynamic library explicitly (as we do with the + -- Accelerate library) causes segfaults; possibly because the RTS was + -- otherwise linked statically into the executable. + -- + -- Because the accelerate library lives somewhere in ~/.cabal/..., this + -- hack prevents executables from running on any other machine than the + -- one they were built on. Fortunately, this happens only in tracy mode. + -- + when tracyIsEnabled $ void $ +#if defined(mingw32_HOST_OS) + loadLibrary ACCELERATE_DYLD_LIBRARY_PATH +#else + dlopen ACCELERATE_DYLD_LIBRARY_PATH [RTLD_LAZY, RTLD_GLOBAL] +#endif + LC.new diff --git a/src/Data/Array/Accelerate/LLVM/Native/Link/Object.hs b/src/Data/Array/Accelerate/LLVM/Native/Link/Object.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Link/Object.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Link.Object +-- Copyright : [2017..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Link.Object + where + +import Data.List +import Foreign.Ptr +import Formatting + +import Data.ByteString.Short.Char8 ( ShortByteString, unpack ) +import Data.Array.Accelerate.Lifetime + +#if defined(mingw32_HOST_OS) +import System.Win32.Types +#else +import System.Posix.DynamicLinker +#endif + + +-- | The function table is a list of function names together with a pointer in +-- the target address space containing the corresponding executable code. +-- +data FunctionTable = FunctionTable { functionTable :: [Function] } +type Function = (ShortByteString, FunPtr ()) + +instance Show FunctionTable where + showsPrec _ f + = showString "<<" + . showString (intercalate "," [ unpack n | (n,_) <- functionTable f ]) + . showString ">>" + +formatFunctionTable :: Format r (FunctionTable -> r) +formatFunctionTable = later $ \f -> + bformat (angled (angled (commaSep string))) [ unpack n | (n,_) <- functionTable f ] + +-- | Object code consists of a handle to dynamically loaded code, managed +-- by the system linker. +-- +type ObjectCode = Lifetime LibraryHandle + +#if defined(mingw32_HOST_OS) +type LibraryHandle = HINSTANCE +#else +type LibraryHandle = DL +#endif + diff --git a/src/Data/Array/Accelerate/LLVM/Native/Link/Runtime.hs b/src/Data/Array/Accelerate/LLVM/Native/Link/Runtime.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Link/Runtime.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Link.Runtime +-- Copyright : [2022] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Utilities for linking object code to shared objects and loading those +-- generated shared objects on Unix-like systems. +-- + +module Data.Array.Accelerate.LLVM.Native.Link.Runtime ( + + loadSharedObject + +) where + +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Lifetime + +import Data.Array.Accelerate.LLVM.Native.Link.Object +import qualified Data.Array.Accelerate.LLVM.Native.Debug as Debug + +import Control.Monad +import Data.ByteString.Short.Char8 ( ShortByteString ) +import Formatting +import qualified Data.ByteString.Short.Char8 as B8 + +#if defined(mingw32_HOST_OS) +import Foreign.Ptr ( castPtrToFunPtr ) +import System.Win32.DLL +#else +import System.Posix.DynamicLinker +#endif + + +-- Dynamic object loading +-- ---------------------- + +-- Load the shared object file and return pointers to the executable +-- functions defined within +-- +loadSharedObject :: HasCallStack => [ShortByteString] -> FilePath -> IO (FunctionTable, ObjectCode) +loadSharedObject nms path = do +#if defined(mingw32_HOST_OS) + -- shims for win32 api compatibility + let dlopen' path' = loadLibrary path' + dlsym dll sym = castPtrToFunPtr <$> getProcAddress dll sym + dlclose dll = freeLibrary dll +#else + let dlopen' path' = dlopen path' [RTLD_LAZY, RTLD_LOCAL] +#endif + -- + so <- dlopen' path + fun_tab <- fmap FunctionTable $ forM nms $ \nm -> do + let s = B8.unpack nm + Debug.traceM Debug.dump_ld ("ld: looking up symbol " % string) s + sym <- dlsym so s + return (nm, sym) + + object_code <- newLifetime so + addFinalizer object_code $ do + -- XXX: Should we disable unloading objects in tracy mode? Tracy might + -- still need access to e.g. embedded string data + Debug.traceM Debug.dump_gc ("gc: unload module: " % formatFunctionTable) fun_tab + dlclose so + + return (fun_tab, object_code) + diff --git a/src/Data/Array/Accelerate/LLVM/Native/Plugin.hs b/src/Data/Array/Accelerate/LLVM/Native/Plugin.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Plugin.hs @@ -0,0 +1,195 @@ +{-# 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..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Plugin ( + + plugin, + +) where + +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 + +#if __GLASGOW_HASKELL__ >= 902 +import GHC.Driver.Backend +#if __GLASGOW_HASKELL__ < 910 +import GHC.Linker +#endif +import GHC.Linker.Loader ( loadCmdLineLibs ) +import GHC.Plugins +import GHC.Runtime.Interpreter +#elif __GLASGOW_HASKELL__ >= 900 +import GHC.Plugins +import GHC.Runtime.Linker +#else +import GhcPlugins +import Linker +import SysTools +#endif + + +-- | This GHC plugin is required to support ahead-of-time compilation for the +-- accelerate-llvm-native backend. In particular, it tells GHC about the +-- additional object files generated by +-- 'Data.Array.Accelerate.LLVM.Native.runQ'* which must be linked into the final +-- executable. +-- +-- This plugin is automatically installed when using runQ. In older versions of +-- GHC, it was necessary to manually add the plugin using: +-- +-- > ghc-options: -fplugin=Data.Array.Accelerate.LLVM.Native.Plugin +-- +-- That is no longer needed. + +-- +plugin :: Plugin +plugin = defaultPlugin + { installCoreToDos = install +#if __GLASGOW_HASKELL__ >= 806 + , pluginRecompile = purePlugin +#endif + } + +install :: HasCallStack => [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install _ rest = do + let this (CoreDoPluginPass "accelerate-llvm-native" _) = True + this _ = False + -- + return $ CoreDoPluginPass "accelerate-llvm-native" pass : filter (not . this) rest + +pass :: HasCallStack => ModGuts -> CoreM ModGuts +pass guts = do + -- Gather annotations for the extra object files which must be supplied to the + -- linker in order to complete the current module. + -- + this <- getModule + paths <- nub . concat <$> mapM (objectPaths guts) (mg_binds guts) + + unless (null paths) + $ debugTraceMsg + $ hang (text "Data.Array.Accelerate.LLVM.Native.Plugin: linking module" <+> quotes (pprModule this) <+> text "with:") 2 (vcat (map text paths)) + + -- The linking method depends on the current build target + -- TODO: Need to update for ghc-8.6: the Backend data type is now abstract + -- + -- Determine the current build environment + -- + hscEnv <- getHscEnv + dynFlags <- getDynFlags + +#if __GLASGOW_HASKELL__ >= 902 + let target = backend dynFlags +#else + let target = hscTarget dynFlags +#endif + + when (backendGeneratesCode target) $ + if backendWritesFiles target + then do + -- The compiler will write files (interface files and object code). This + -- is true of "real" backends, i.e. not the interpreter. +#if __GLASGOW_HASKELL__ < 806 + -- Because of separate compilation, we will only encounter the annotation + -- pragmas on files which have changed between invocations. This applies to + -- both @ghc --make@ as well as the separate compile/link phases of building + -- with @cabal@ (and @stack@). Note that whenever _any_ file is updated we + -- must make sure that the linker options contains the complete list of + -- objects required to build the entire project. + -- + + -- Read the object file index and update (we may have added or removed + -- objects for the given module) + -- + let buildInfo = mkBuildInfoFileName (objectMapPath dynFlags) + abi <- readBuildInfo buildInfo + -- + let abi' = if null paths + then Map.delete this abi + else Map.insert this paths abi + allPaths = nub (concat (Map.elems abi')) + allObjs = map optionOfPath allPaths + -- + writeBuildInfo buildInfo abi' + + -- Make sure the linker flags are up-to-date. + -- + unless (isNoLink (ghcLink dynFlags)) $ do + linker_info <- getLinkerInfo dynFlags + writeIORef (rtldInfo dynFlags) + $ Just + $ case linker_info of + GnuLD opts -> GnuLD (nub (opts ++ allObjs)) + GnuGold opts -> GnuGold (nub (opts ++ allObjs)) + DarwinLD opts -> DarwinLD (nub (opts ++ allObjs)) + SolarisLD opts -> SolarisLD (nub (opts ++ allObjs)) + AixLD opts -> AixLD (nub (opts ++ allObjs)) + LlvmLLD opts -> LlvmLLD (nub (opts ++ allObjs)) + UnknownLD -> UnknownLD -- no linking performed? +#endif + return () + + else + -- We are in interactive mode (ghci) + -- + unless (null paths) . liftIO $ do + let opts = ldInputs dynFlags + objs = map optionOfPath paths + -- +#if __GLASGOW_HASKELL__ >= 902 + loadCmdLineLibs (hscInterp hscEnv) + $ hscEnv { hsc_dflags = dynFlags { ldInputs = opts ++ objs }} +#else + linkCmdLineLibs + $ hscEnv { hsc_dflags = dynFlags { ldInputs = opts ++ objs }} +#endif + return guts + +#if __GLASGOW_HASKELL__ < 906 +backendGeneratesCode :: Backend -> Bool +backendGeneratesCode NoBackend = False +backendGeneratesCode _ = True + +backendWritesFiles :: Backend -> Bool +backendWritesFiles Interpreter = False +backendWritesFiles _ = True +#endif + +objectPaths :: ModGuts -> CoreBind -> CoreM [FilePath] +objectPaths guts (NonRec b _) = objectAnns guts b +objectPaths guts (Rec bs) = concat <$> mapM (objectAnns guts . fst) bs + +objectAnns :: ModGuts -> CoreBndr -> CoreM [FilePath] +objectAnns guts bndr = do + anns <- getAnnotations deserializeWithData guts +#if __GLASGOW_HASKELL__ >= 900 + return [ path | Object path <- lookupWithDefaultUFM (snd anns) [] (varName bndr) ] +#else + return [ path | Object path <- lookupWithDefaultUFM anns [] (varUnique bndr) ] +#endif + +objectMapPath :: DynFlags -> FilePath +objectMapPath DynFlags{..} + | Just p <- objectDir = p + | Just p <- dumpDir = p + | otherwise = "." + +optionOfPath :: FilePath -> Option +optionOfPath = FileOption [] + diff --git a/src/Data/Array/Accelerate/LLVM/Native/Plugin/Annotation.hs b/src/Data/Array/Accelerate/LLVM/Native/Plugin/Annotation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Plugin/Annotation.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DeriveDataTypeable #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Plugin.Annotation +-- Copyright : [2017..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Plugin.Annotation ( + + Object(..), + +) where + +import Data.Data + +data Object = Object FilePath + deriving (Show, Data, Typeable) + diff --git a/src/Data/Array/Accelerate/LLVM/Native/Plugin/BuildInfo.hs b/src/Data/Array/Accelerate/LLVM/Native/Plugin/BuildInfo.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Plugin/BuildInfo.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Plugin.BuildInfo +-- Copyright : [2017..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Plugin.BuildInfo + where + +#if __GLASGOW_HASKELL__ >= 900 +import GHC.Unit +import GHC.Utils.Binary +#else +import Binary +import Module +#endif + +import Data.Map ( Map ) +import System.Directory +import System.FilePath +import qualified Data.Map as Map +import qualified Data.Map.Internal as Map + +import Data.Array.Accelerate.Error + + +mkBuildInfoFileName :: FilePath -> FilePath +mkBuildInfoFileName path = path "accelerate-llvm-native.buildinfo" + +readBuildInfo :: HasCallStack => FilePath -> IO (Map Module [FilePath]) +readBuildInfo path = do + exists <- doesFileExist path + if not exists + then return Map.empty + else get =<< readBinMem path + +writeBuildInfo :: FilePath -> Map Module [FilePath] -> IO () +writeBuildInfo path objs = do + h <- openBinMem 4096 + put_ h objs + writeBinMem h path + + +instance (Binary k, Binary v) => Binary (Map k v) where + get h = do + t <- getByte h + case t of + 0 -> return Map.Tip + _ -> do + s <- get h + k <- get h + a <- get h + l <- get h + r <- get h + return $ Map.Bin s k a l r + + put_ h Map.Tip = putByte h 0 + put_ h (Map.Bin s k a l r) = do + putByte h 1 + put_ h s + put_ h k + put_ h a + put_ h l + put_ h r + diff --git a/src/Data/Array/Accelerate/LLVM/Native/State.hs b/src/Data/Array/Accelerate/LLVM/Native/State.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/State.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.State +-- 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.State ( + + evalNative, + createTarget, defaultTarget, + +) where + +import Data.Array.Accelerate.Debug.Internal + +import Data.Array.Accelerate.LLVM.State +import Data.Array.Accelerate.LLVM.Native.Target +import Data.Array.Accelerate.LLVM.Native.Execute.Scheduler +import qualified Data.Array.Accelerate.LLVM.Native.Link.Cache as LC +import qualified Data.Array.Accelerate.LLVM.Native.Debug as Debug + +import Data.Char +import Data.Maybe +import Formatting +import Language.Haskell.TH +import System.Environment +import System.IO.Unsafe +import Text.Read + +import GHC.Conc +import GHC.Ptr + + +-- | Execute a computation in the Native backend +-- +evalNative :: Native -> LLVM Native a -> IO a +-- evalNative = evalLLVM + +-- XXX: This is correct for run, but for runN we'll use this operation to +-- do the compilation separately from execution, thus there will be an +-- empty "frame" with no (execution) trace +-- +evalNative target acc = do + let label = Ptr $(litE (stringPrimL (map (fromIntegral . ord) "Native.run\0"))) + emit_frame_mark_start label + !result <- evalLLVM target acc + emit_frame_mark_end label + return result + + +-- | Create a Native execution target by spawning a worker thread on each of the +-- given capabilities. +-- +createTarget + :: [Int] -- ^ CPUs to launch worker threads on + -> IO Native +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 + + +-- | Execute an operation sequentially on a single thread +-- +sequentialIO :: Strategy +sequentialIO gang = + Executable $ \name _ppt range fill -> + timed name $ runSeqIO gang range fill + + +-- | Execute a computation without load balancing. Each thread computes an +-- equally sized chunk of the input. No work stealing occurs. +-- +unbalancedParIO :: Strategy +unbalancedParIO gang = + Executable $ \name _ppt range fill -> + timed name $ runParIO Single.mkResource gang range fill + + +-- | Execute a computation where threads use work stealing (based on lazy +-- splitting of work stealing queues and exponential backoff) in order to +-- automatically balance the workload amongst themselves. +-- +balancedParIO + :: Int -- ^ number of steal attempts before backing off + -> Strategy +balancedParIO retries gang = + Executable $ \name ppt range fill -> + -- TLM: A suitable PPT should be chosen when invoking the continuation in + -- order to balance scheduler overhead with fine-grained function calls + -- + let resource = LBS.mkResource ppt (SMP.mkResource retries <> Backoff.mkResource) + in timed name $ runParIO resource gang range fill +--} + + +-- Top-level mutable state +-- ----------------------- +-- +-- It is important to keep some information alive for the entire run of the +-- program, not just a single execution. These tokens use 'unsafePerformIO' to +-- ensure they are executed only once, and reused for subsequent invocations. +-- + +-- | Initialise the gang of threads that will be used to execute computations. +-- This spawns one worker for each available processor, or as specified by the +-- value of the environment variable @ACCELERATE_LLVM_NATIVE_THREADS@. +-- +-- 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). +-- +-- 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 +defaultTarget = unsafePerformIO $ do + nproc <- getNumProcessors + ncaps <- getNumCapabilities + menv <- (readMaybe =<<) <$> lookupEnv "ACCELERATE_LLVM_NATIVE_THREADS" + + let nthreads = fromMaybe nproc menv + + -- Update the number of capabilities, but never set it lower than it already + -- is. This target will spawn a worker on each processor (as returned by + -- 'getNumProcessors', which includes SMT (hyperthreading) cores), but the + -- user may have requested more capabilities than this to handle, for example, + -- concurrent output. + -- + setNumCapabilities (max ncaps nthreads) + + Debug.traceM Debug.dump_gc ("gc: initialise native target with " % int % " worker threads") nthreads + createTarget [0 .. nthreads-1] + + +{-- +-- Debugging +-- --------- + +{-# INLINE timed #-} +timed :: ShortByteString -> IO a -> IO a +timed name f = Debug.timed Debug.dump_exec (elapsed name) f + +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Target.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE TypeApplications #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Target +-- 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.Target ( + + module Data.Array.Accelerate.LLVM.Target, + module Data.Array.Accelerate.LLVM.Native.Target, + nativeTargetTriple, + nativeCPUName, + +) where + +-- 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 Data.Array.Accelerate.LLVM.Target.ClangInfo + + +-- | Native machine code JIT execution target +-- +data Native = Native + { linkCache :: !LinkCache + , workers :: !Workers + } + +instance Target Native where + targetTriple = Just nativeTargetTriple + targetDataLayout = Nothing -- LLVM will fill it in just fine for CPU targets diff --git a/test/nofib/Data/Array/Accelerate/LLVM/Native/NoFib/RunQ.hs b/test/nofib/Data/Array/Accelerate/LLVM/Native/NoFib/RunQ.hs new file mode 100644 --- /dev/null +++ b/test/nofib/Data/Array/Accelerate/LLVM/Native/NoFib/RunQ.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TemplateHaskell #-} +module Data.Array.Accelerate.LLVM.Native.NoFib.RunQ where + +import qualified Data.Array.Accelerate as A +import qualified Data.Array.Accelerate.LLVM.Native as CPU + +import Test.Tasty +import Test.Tasty.HUnit + + +-- WARNING: This module is duplicated (apart from Native/PTX) between the +-- accelerate-llvm-native and accelerate-llvm-ptx backends. This code is not +-- included in the main Accelerate nofib testsuite because of staging issues: +-- the test can only be defined after runQ is known, and runQ is only built +-- after the 'accelerate' package has already finished building. It would be +-- possible to deduplicate the little Accelerate program in there, but that was +-- not deemed worth the effort. + + +test_runq :: TestTree +test_runq = + testGroup "runQ" + [ testCase "simple" test_simple ] + +test_simple :: Assertion +test_simple = do + let prog :: A.Vector Int -> A.Scalar Int + !prog = $(CPU.runQ $ \a -> A.sum (A.map (+1) (a :: A.Acc (A.Vector Int)))) + let n = 10000 + prog (A.fromList (A.Z A.:. 10000) [1..]) @=? A.fromList A.Z [n * (n + 1) `div` 2 + n] diff --git a/test/nofib/Main.hs b/test/nofib/Main.hs new file mode 100644 --- /dev/null +++ b/test/nofib/Main.hs @@ -0,0 +1,19 @@ +-- | +-- Module : nofib-llvm-native +-- Copyright : [2017..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Main where + +import Data.Array.Accelerate.Test.NoFib +import Data.Array.Accelerate.LLVM.Native +import Data.Array.Accelerate.LLVM.Native.NoFib.RunQ + +main :: IO () +main = nofib runN test_runq +