diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,10 +6,32 @@ project adheres to the [Haskell Package Versioning Policy (PVP)](https://pvp.haskell.org) +## [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 + ## [1.1.0.0] - 2017-09-21 ### Added * support for GHC-8.2 @@ -25,12 +47,14 @@ ## [1.0.0.0] - 2017-03-31 - * initial release + * initial release +[1.2.0.0]: https://github.com/AccelerateHS/accelerate-llvm/compare/1.1.0.1-native...v1.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 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/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,10 @@ An LLVM backend for the Accelerate Array Language ================================================= -[![Build Status](https://travis-ci.org/AccelerateHS/accelerate-llvm.svg)](https://travis-ci.org/AccelerateHS/accelerate-llvm) +[![Travis](https://img.shields.io/travis/AccelerateHS/accelerate-llvm/master.svg?label=linux)](https://travis-ci.org/AccelerateHS/accelerate-llvm) +[![AppVeyor](https://img.shields.io/appveyor/ci/tmcdonell/accelerate-llvm/master.svg?label=windows)](https://ci.appveyor.com/project/tmcdonell/accelerate-llvm) +[![Stackage LTS](https://stackage.org/package/accelerate-llvm/badge/lts)](https://stackage.org/lts/package/accelerate-llvm) +[![Stackage Nightly](https://stackage.org/package/accelerate-llvm/badge/nightly)](https://stackage.org/nightly/package/accelerate-llvm) [![Hackage](https://img.shields.io/hackage/v/accelerate-llvm.svg)](https://hackage.haskell.org/package/accelerate-llvm) [![Docker Automated build](https://img.shields.io/docker/automated/tmcdonell/accelerate-llvm.svg)](https://hub.docker.com/r/tmcdonell/accelerate-llvm/) [![Docker status](https://images.microbadger.com/badges/image/tmcdonell/accelerate-llvm.svg)](https://microbadger.com/images/tmcdonell/accelerate-llvm) @@ -64,7 +67,7 @@ Example using [Homebrew](http://brew.sh) on macOS: ```sh -$ brew install llvm-hs/homebrew-llvm/llvm-4.0 +$ brew install llvm-hs/homebrew-llvm/llvm-6.0 ``` ## Debian/Ubuntu @@ -75,17 +78,17 @@ then: ```sh -$ apt-get install llvm-4.0-dev +$ apt-get install llvm-6.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). +If your OS does not have an appropriate LLVM distribution available, you can also build from source. Detailed build instructions are available on the [LLVM.org website](http://releases.llvm.org/6.0.0/docs/CMake.html). Note that you will require at least [CMake 3.4.3](http://www.cmake.org/cmake/resources/software.html) and a recent C++ compiler; at least Clang 3.1, GCC 4.8, or Visual Studio 2015 (update 3). - 1. Download and unpack the [LLVM-4.0 source code](http://releases.llvm.org/4.0.0/llvm-4.0.0.src.tar.xz). We'll refer to + 1. Download and unpack the [LLVM-6.0 source code](http://releases.llvm.org/6.0.0/llvm-6.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) + such as the Clang compiler or Polly loop optimiser. See the [LLVM releases](http://releases.llvm.org/download.html#6.0.0) page for the complete list. 2. Create a temporary build directory and `cd` into it, for example: @@ -113,7 +116,7 @@ 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 + ln -s libLLVM.dylib libLLVM-6.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 @@ -128,13 +131,13 @@ For example, installation using [`stack`](http://docs.haskellstack.org/en/stable/README.html) just requires you to point it to the appropriate configuration file: ```sh -$ ln -s stack-8.0.yaml stack.yaml +$ ln -s stack-8.2.yaml stack.yaml $ stack setup $ stack install ``` Note that the version of [`llvm-hs`](https://hackage.haskell.org/package/llvm-hs) -used must match the installed version of LLVM, which is currently 4.0. +used must match the installed version of LLVM, which is currently 6.0. ## libNVVM @@ -152,11 +155,12 @@ on the version of the CUDA toolkit you have installed. The following table shows some combinations: -| | 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** | | | ⭕ | ⭕ | ❌ | ❌ | +| | LLVM-3.3 | LLVM-3.4 | LLVM-3.5 | LLVM-3.8 | LLVM-3.9 | LLVM-4.0 | LLVM-5.0 | +|:------------:|:--------:|:--------:|:--------:|:--------:|:--------:|:--------:|:--------:| +| **CUDA-7.0** | ⭕ | ❌ | | | | | | +| **CUDA-7.5** | | ⭕ | ⭕ | ❌ | | | | +| **CUDA-8.0** | | | ⭕ | ⭕ | ❌ | ❌ | | +| **CUDA-9.0** | | | | | | ❌ | ❌ | Where ⭕ = Works, and ❌ = Does not work. diff --git a/accelerate-llvm-native.cabal b/accelerate-llvm-native.cabal --- a/accelerate-llvm-native.cabal +++ b/accelerate-llvm-native.cabal @@ -1,5 +1,5 @@ name: accelerate-llvm-native -version: 1.1.0.1 +version: 1.2.0.0 cabal-version: >= 1.10 tested-with: GHC >= 7.10 build-type: Simple @@ -26,7 +26,7 @@ . Example using Homebrew on macOS: . - > brew install llvm-hs/homebrew-llvm/llvm-5.0 + > brew install llvm-hs/homebrew-llvm/llvm-6.0 . /Debian & Ubuntu/ . @@ -35,13 +35,13 @@ instructions for adding the correct package database for your OS version, and then: . - > apt-get install llvm-5.0-dev + > apt-get install llvm-6.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 + . 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. @@ -75,29 +75,6 @@ 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 - - -- Build configuration -- ------------------- @@ -111,7 +88,6 @@ 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 @@ -135,6 +111,7 @@ 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.Environment Data.Array.Accelerate.LLVM.Native.Execute.LBS @@ -150,46 +127,44 @@ Paths_accelerate_llvm_native build-depends: - base >= 4.7 && < 4.11 - , accelerate == 1.1.* - , accelerate-llvm == 1.1.* + base >= 4.7 && < 4.12 + , accelerate == 1.2.* + , accelerate-llvm == 1.2.* , bytestring >= 0.10.4 , Cabal >= 2.0 , cereal >= 0.4 , containers >= 0.5 && < 0.6 , directory >= 1.0 , dlist >= 0.6 - , fclabels >= 2.0 , filepath >= 1.0 , ghc , hashable >= 1.0 , libffi >= 0.1 - , llvm-hs >= 4.1 && < 5.1 - , llvm-hs-pure >= 4.1 && < 5.1 + , llvm-hs >= 4.1 && < 6.1 + , llvm-hs-pure >= 4.1 && < 6.1 , mtl >= 2.2.1 , template-haskell , time >= 1.4 , unique - default-language: - Haskell2010 - - ghc-options: -O2 -Wall -fwarn-tabs - - if impl(ghc >= 8.0) - ghc-options: -Wmissed-specialisations + hs-source-dirs: + src - if flag(debug) - cpp-options: -DACCELERATE_DEBUG + default-language: + Haskell2010 - if flag(bounds-checks) - cpp-options: -DACCELERATE_BOUNDS_CHECKS + ghc-options: + -O2 + -Wall + -fwarn-tabs - if flag(unsafe-checks) - cpp-options: -DACCELERATE_UNSAFE_CHECKS + ghc-prof-options: + -caf-all + -auto-all - if flag(internal-checks) - cpp-options: -DACCELERATE_INTERNAL_CHECKS + if impl(ghc >= 8.0) + ghc-options: + -Wmissed-specialisations if os(darwin) other-modules: @@ -227,13 +202,35 @@ bytestring >= 0.10 +test-suite nofib-llvm-native + type: exitcode-stdio-1.0 + hs-source-dirs: test/nofib + main-is: Main.hs + + build-depends: + base >= 4.7 + , accelerate + , accelerate-llvm-native + + default-language: + Haskell2010 + + ghc-options: + -Wall + -O2 + -threaded + -rtsopts + -with-rtsopts=-A128M + -with-rtsopts=-n4M + + source-repository head type: git location: https://github.com/AccelerateHS/accelerate-llvm.git source-repository this type: git - tag: 1.1.0.1-native + tag: 1.2.0.0 location: https://github.com/AccelerateHS/accelerate-llvm.git -- vim: nospell diff --git a/src/Data/Array/Accelerate/LLVM/Native.hs b/src/Data/Array/Accelerate/LLVM/Native.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native.hs @@ -0,0 +1,441 @@ +{-# 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, + 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, 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/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,111 @@ +{-# 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 (ArrayEltRvec2 aeR) (AD_V2 ad1) (AD_V2 ad2) = copyR aeR ad1 ad2 + copyR (ArrayEltRvec3 aeR) (AD_V3 ad1) (AD_V3 ad3) = copyR aeR ad1 ad3 + copyR (ArrayEltRvec4 aeR) (AD_V4 ad1) (AD_V4 ad4) = copyR aeR ad1 ad4 + copyR (ArrayEltRvec8 aeR) (AD_V8 ad1) (AD_V8 ad8) = copyR aeR ad1 ad8 + copyR (ArrayEltRvec16 aeR) (AD_V16 ad1) (AD_V16 ad16) = copyR aeR ad1 ad16 + -- + copyR ArrayEltRint ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRint8 ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRint16 ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRint32 ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRint64 ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRword ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRword8 ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRword16 ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRword32 ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRword64 ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRhalf ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRfloat ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRdouble ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRbool ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRchar ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRcshort ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRcushort ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRcint ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRcuint ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRclong ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRculong ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRcllong ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRcullong ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRcfloat ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRcdouble ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRcchar ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRcschar ad1 ad2 = copyPrim ad1 ad2 + copyR ArrayEltRcuchar ad1 ad2 = copyPrim ad1 ad2 + + 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/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,46 @@ +{-# 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/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,93 @@ +{-# 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 +import Prelude as P + + +-- | 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 "_%s" (show uid))) param kernel + return $ IROpenAcc [body] + +-- | Create a complete kernel function by running the code generation process +-- specified in the final parameter. +-- +makeKernel :: Label -> [LLVM.Parameter] -> CodeGen () -> 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/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,301 @@ +{-# 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 singleType 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/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,181 @@ +{-# 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 singleType (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/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,56 @@ +{-# 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/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,46 @@ +-- | +-- 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/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,96 @@ +{-# 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/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,306 @@ +{-# 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 + -- + _ | TypeRscalar (SingleScalarType 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 + NumSingleType (IntegralNumType t) -> void . instr' $ AtomicRMW t NonVolatile rmw addr (op t r') (CrossThread, AcquireRelease) + NumSingleType t | RMW.Add <- rmw -> atomicCAS_rmw s (A.add t r') addr + NumSingleType t | RMW.Sub <- rmw -> atomicCAS_rmw s (A.sub t r') addr + _ -> case rmw of + RMW.Min -> atomicCAS_cmp s A.lt addr (op s r') + RMW.Max -> atomicCAS_cmp s A.gt addr (op s r') + _ -> $internalError "mkPermute_rmw" "unexpected transition" + -- + _ -> $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 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 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 TypeRunit () OP_Unit = return (lift True) + go (TypeRpair tsh tsz) (ish, isz) (OP_Pair sh sz) = do x <- go tsh ish sh + y <- go tsz isz sz + land' x y + go (TypeRscalar s) ig sz = case s of + SingleScalarType t -> A.eq t (ir t (single t ig)) (ir t (op' t sz)) + VectorScalarType{} -> $internalError "ignore" "unexpected shape type" + 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,833 @@ +{-# 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 singleType i iz + R -> A.gt singleType 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 singleType i iz + R -> A.gt singleType i iz + + -- Loop through the input. Only at the top of the loop to we write the + -- carry-in value (i.e. value from the last loop iteration) to the output + -- array. This ensures correct behaviour if the input array was empty. + r <- while (cont . A.fst) + (\(A.unpair -> (i,v)) -> do + writeArray arrOut i v + + 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 singleType a len + + -- index i* is the index that we read data from. Recall that the supremum + -- index is exclusive + i0 <- case dir of + L -> return inf + R -> next sup + + -- 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 singleType chunk firstChunk + then return i0 + else next i0 + R -> if A.eq singleType 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 singleType chunk firstChunk + then A.pair <$> seed <*> pure i0 + else A.pair <$> app1 delayedLinearIndex i0 <*> next i0 + Nothing -> A.pair <$> app1 delayedLinearIndex i0 <*> next i0 + + -- 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 singleType i sup + R -> A.gte singleType 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 singleType i end + R -> A.gte singleType 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 singleType 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 singleType 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 singleType 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 singleType 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 singleType i sup + R -> A.gte singleType 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 singleType i end + R -> A.gte singleType 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 singleType 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/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,113 @@ +{-# 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 <- if Debug.debuggingIsEnabled then Debug.getFlag Debug.force_recomp else return False + if exists && not recomp + then do + Debug.traceIO Debug.dump_cc (printf "cc: found cached object code %s" (show uid)) + B.readFile cacheFile + + 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 + Debug.traceIO Debug.dump_cc (printf "cc: new object code %s" (show uid)) + B.writeFile cacheFile obj + return obj + + return $! ObjectR uid nms obj + 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,37 @@ +{-# LANGUAGE CPP #-} +{-# 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 + "llvm-hs-" ++ VERSION_llvm_hs + S8.unpack nativeTargetTriple + B8.unpack nativeCPUName + "meep.o" + diff --git a/src/Data/Array/Accelerate/LLVM/Native/Compile/Optimise.hs b/src/Data/Array/Accelerate/LLVM/Native/Compile/Optimise.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Compile/Optimise.hs @@ -0,0 +1,143 @@ +-- | +-- 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/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,42 @@ +{-# 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/src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple.hs b/src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple.hs @@ -0,0 +1,65 @@ +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Distribution.Simple +-- Copyright : [2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Distribution.Simple ( + + defaultMain, + simpleUserHooks, + module Distribution.Simple, + +) where + +import Data.Array.Accelerate.LLVM.Native.Distribution.Simple.Build + +import Distribution.PackageDescription ( PackageDescription ) +import Distribution.Simple.Setup ( BuildFlags ) +import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo ) +import Distribution.Simple.PreProcess ( PPSuffixHandler, knownSuffixHandlers ) +import Distribution.Simple hiding ( defaultMain, simpleUserHooks ) +import qualified Distribution.Simple as Cabal + +import Data.List ( unionBy ) + + +-- | A simple implementation of @main@ for a Cabal setup script. This is the +-- same as 'Distribution.Simple.defaultMain', with added support for building +-- libraries utilising 'Data.Array.Accelerate.LLVM.Native.runQ'*. +-- +defaultMain :: IO () +defaultMain = Cabal.defaultMainWithHooks simpleUserHooks + + +-- | Hooks that correspond to a plain instantiation of the \"simple\" build +-- system. +-- +simpleUserHooks :: UserHooks +simpleUserHooks = + Cabal.simpleUserHooks + { buildHook = accelerateBuildHook + } + +accelerateBuildHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> BuildFlags + -> IO () +accelerateBuildHook pkg_descr localbuildinfo hooks flags = + build pkg_descr localbuildinfo flags (allSuffixHandlers hooks) + +-- | Combine the preprocessors in the given hooks with the +-- preprocessors built into cabal. +allSuffixHandlers :: UserHooks -> [PPSuffixHandler] +allSuffixHandlers hooks + = overridesPP (hookedPreProcessors hooks) knownSuffixHandlers + where + overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler] + overridesPP = unionBy (\x y -> fst x == fst y) + diff --git a/src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/Build.hs b/src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/Build.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/Build.hs @@ -0,0 +1,451 @@ +-- | +-- 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/src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC.hs b/src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC.hs @@ -0,0 +1,437 @@ +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC +-- Copyright : [2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Copied from: https://github.com/haskell/cabal/blob/2.0/Cabal/Distribution/Simple/GHC.hs +-- + +module Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC ( + + buildLib, + replLib, + +) where + +import qualified Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC.Internal as Internal +import qualified Data.Array.Accelerate.LLVM.Native.Plugin.BuildInfo as Internal + +import qualified Distribution.Simple.GHC as Cabal +import Distribution.PackageDescription as PD +import Distribution.Simple.LocalBuildInfo +import Distribution.Types.ComponentLocalBuildInfo +import qualified Distribution.Simple.Hpc as Hpc +import Distribution.Simple.BuildPaths +import Distribution.Simple.Utils +import qualified Distribution.ModuleName as ModuleName +import Distribution.Simple.Program +import qualified Distribution.Simple.Program.Ar as Ar +import Distribution.Simple.Program.GHC +import Distribution.Simple.Setup +import qualified Distribution.Simple.Setup as Cabal +import Distribution.Simple.Compiler hiding (Flag) +import Distribution.Version +import Distribution.System +import Distribution.Verbosity +import Distribution.Text +import Distribution.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) + Internal.combineObjectFiles verbosity lbi ldProg + ghciLibFilePath ghciObjFiles + + whenSharedLib False $ + runGhcProg ghcSharedLinkArgs + + +-- | Returns True if the modification date of the given source file is newer than +-- the object file we last compiled for it, or if no object file exists yet. +checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool +checkNeedsRecompilation filename opts = filename `moreRecentFile` oname + where oname = getObjectFileName filename opts + +-- | Finds the object file name of the given source file +getObjectFileName :: FilePath -> GhcOptions -> FilePath +getObjectFileName filename opts = oname + where odir = fromFlag (ghcOptObjDir opts) + oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts) + oname = odir replaceExtension filename oext + +-- | Calculate the RPATHs for the component we are building. +-- +-- Calculates relative RPATHs when 'relocatable' is set. +getRPaths :: LocalBuildInfo + -> ComponentLocalBuildInfo -- ^ Component we are building + -> IO (NubListR FilePath) +getRPaths lbi clbi | supportRPaths hostOS = do + libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi + let hostPref = case hostOS of + OSX -> "@loader_path" + _ -> "$ORIGIN" + relPath p = if isRelative p then hostPref p else p + rpaths = toNubListR (map relPath libraryPaths) + return rpaths + where + (Platform _ hostOS) = hostPlatform lbi + + -- The list of RPath-supported operating systems below reflects the + -- platforms on which Cabal's RPATH handling is tested. It does _NOT_ + -- reflect whether the OS supports RPATH. + + -- E.g. when this comment was written, the *BSD operating systems were + -- untested with regards to Cabal RPATH handling, and were hence set to + -- 'False', while those operating systems themselves do support RPATH. + supportRPaths Linux = True + supportRPaths Windows = False + supportRPaths OSX = True + supportRPaths FreeBSD = False + supportRPaths OpenBSD = False + supportRPaths NetBSD = False + supportRPaths DragonFly = False + supportRPaths Solaris = False + supportRPaths AIX = False + supportRPaths HPUX = False + supportRPaths IRIX = False + supportRPaths HaLVM = False + supportRPaths IOS = False + supportRPaths Android = False + supportRPaths Ghcjs = False + supportRPaths Hurd = False + supportRPaths (OtherOS _) = False + -- Do _not_ add a default case so that we get a warning here when a new OS + -- is added. + +getRPaths _ _ = return mempty + +-- | Filter the "-threaded" flag when profiling as it does not +-- work with ghc-6.8 and older. +hackThreadedFlag :: Verbosity -> Compiler -> Bool -> BuildInfo -> IO BuildInfo +hackThreadedFlag _ _ _ = return + +-- ----------------------------------------------------------------------------- +-- Utils + +supportsDynamicToo :: Compiler -> Bool +supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too" + diff --git a/src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC/Internal.hs b/src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC/Internal.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC.Internal +-- Copyright : [2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Copied from: https://github.com/haskell/cabal/blob/2.0/Cabal/Distribution/Simple/GHC/Internal.hs +-- + +module Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC.Internal ( + + mkGHCiLibName, + ghcLookupProperty, + filterGhciFlags, + getHaskellObjects, + mkGhcOptPackages, + profDetailLevelFlag, + combineObjectFiles + +) where + +#if MIN_VERSION_Cabal(2,0,0) +import Distribution.Backpack +#endif +import Distribution.PackageDescription as PD hiding (Flag) +import Distribution.Simple.Compiler hiding (Flag) +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Program (ConfiguredProgram) +import Distribution.Simple.Program.GHC +import qualified Distribution.Simple.Program.Ld as Ld +import Distribution.Simple.Setup +import Distribution.Simple +import Distribution.Verbosity (Verbosity) +import qualified Distribution.ModuleName as ModuleName + +import qualified Data.Map as Map +import System.Directory ( getDirectoryContents ) +import System.FilePath ( (), (<.>), takeExtension ) + + +-- | Strip out flags that are not supported in ghci +filterGhciFlags :: [String] -> [String] +filterGhciFlags = filter supported + where + supported ('-':'O':_) = False + supported "-debug" = False + supported "-threaded" = False + supported "-ticky" = False + supported "-eventlog" = False + supported "-prof" = False + supported "-unreg" = False + supported _ = True + +#if MIN_VERSION_Cabal(1,24,0) +mkGHCiLibName :: UnitId -> String +mkGHCiLibName lib = getHSLibraryName lib <.> "o" +#else +mkGHCiLibName :: LibraryName -> String +mkGHCiLibName (LibraryName lib) = lib <.> "o" +#endif + +ghcLookupProperty :: String -> Compiler -> Bool +ghcLookupProperty prop comp = + case Map.lookup prop (compilerProperties comp) of + Just "YES" -> True + _ -> False + +-- when using -split-objs, we need to search for object files in the +-- Module_split directory for each module. +getHaskellObjects :: _GhcImplInfo -> Library -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> FilePath -> String -> Bool -> IO [FilePath] +getHaskellObjects _implInfo lib lbi clbi pref wanted_obj_ext allow_split_objs + | splitObjs lbi && allow_split_objs = do + let splitSuffix = "_" ++ wanted_obj_ext ++ "_split" + dirs = [ pref (ModuleName.toFilePath x ++ splitSuffix) + | x <- allLibModules lib clbi ] + objss <- traverse getDirectoryContents dirs + let objs = [ dir obj + | (objs',dir) <- zip objss dirs, obj <- objs', + let obj_ext = takeExtension obj, + '.':wanted_obj_ext == obj_ext ] + return objs + | otherwise = + return [ pref ModuleName.toFilePath x <.> wanted_obj_ext + | x <- allLibModules lib clbi ] + +#if MIN_VERSION_Cabal(2,0,0) +mkGhcOptPackages :: ComponentLocalBuildInfo + -> [(OpenUnitId, ModuleRenaming)] +mkGhcOptPackages = componentIncludes +#else +mkGhcOptPackages :: ComponentLocalBuildInfo + -> [(InstalledPackageId, PackageId, ModuleRenaming)] +mkGhcOptPackages clbi = + map (\(i,p) -> (i,p,lookupRenaming p (componentPackageRenaming clbi))) + (componentPackageDeps clbi) +#endif + +profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto +profDetailLevelFlag forLib mpl = + case mpl of + ProfDetailNone -> mempty + ProfDetailDefault | forLib -> toFlag GhcProfAutoExported + | otherwise -> toFlag GhcProfAutoToplevel + ProfDetailExportedFunctions -> toFlag GhcProfAutoExported + ProfDetailToplevelFunctions -> toFlag GhcProfAutoToplevel + ProfDetailAllFunctions -> toFlag GhcProfAutoAll + ProfDetailOther _ -> mempty + +#if !MIN_VERSION_Cabal(2,0,0) +allLibModules :: Library -> ComponentLocalBuildInfo -> [ModuleName.ModuleName] +allLibModules lib _ = libModules lib +#endif + +combineObjectFiles :: Verbosity -> LocalBuildInfo -> ConfiguredProgram + -> FilePath -> [FilePath] -> IO () +#if MIN_VERSION_Cabal(2,1,0) +combineObjectFiles = Ld.combineObjectFiles +#else +combineObjectFiles v _ = Ld.combineObjectFiles v +#endif diff --git a/src/Data/Array/Accelerate/LLVM/Native/Embed.hs b/src/Data/Array/Accelerate/LLVM/Native/Embed.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Embed.hs @@ -0,0 +1,82 @@ +{-# 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 - 65) 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/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,517 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Execute +-- Copyright : [2014..2017] Trevor L. McDonell +-- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Execute ( + + executeAcc, executeAfun, + executeOpenAcc + +) where + +-- accelerate +import Data.Array.Accelerate.Analysis.Match +import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Error + +import Data.Array.Accelerate.LLVM.Analysis.Match +import Data.Array.Accelerate.LLVM.Execute +import Data.Array.Accelerate.LLVM.State + +import Data.Array.Accelerate.LLVM.Native.Array.Data +import Data.Array.Accelerate.LLVM.Native.Link +import Data.Array.Accelerate.LLVM.Native.Execute.Async +import Data.Array.Accelerate.LLVM.Native.Execute.Environment +import Data.Array.Accelerate.LLVM.Native.Execute.Marshal +import Data.Array.Accelerate.LLVM.Native.Target +import qualified Data.Array.Accelerate.LLVM.Native.Debug as Debug + +-- Use work-stealing scheduler +import Data.Range ( Range(..) ) +import Control.Parallel.Meta ( Executable(..) ) +import Data.Array.Accelerate.LLVM.Native.Execute.LBS + +-- library +import Control.Monad.State ( gets ) +import Control.Monad.Trans ( liftIO ) +import Data.ByteString.Short ( ShortByteString ) +import Data.List ( find ) +import Data.Maybe ( fromMaybe ) +import Data.Time.Clock ( getCurrentTime, diffUTCTime ) +import Data.Word ( Word8 ) +import Text.Printf ( printf ) +import Prelude hiding ( map, sum, scanl, scanr, init ) +import qualified Data.ByteString.Short.Char8 as S8 +import 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 = simpleOp + stencil2 = stencil2Op + aforeign = aforeignOp + + +-- Skeleton implementation +-- ----------------------- + +-- Simple kernels just needs to know the shape of the output array. +-- +simpleOp + :: (Shape sh, Elt e) + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> sh + -> LLVM Native (Array sh e) +simpleOp exe gamma aenv () sh = withExecutable exe $ \nativeExecutable -> do + let fun = case functionTable nativeExecutable of + f:_ -> f + _ -> $internalError "simpleOp" "no functions found" + -- + Native{..} <- gets llvmTarget + liftIO $ do + out <- allocateArray sh + executeOp defaultLargePPT fillP fun gamma aenv (IE 0 (size sh)) out + return out + +simpleNamed + :: (Shape sh, Elt e) + => ShortByteString + -> ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> sh + -> LLVM Native (Array sh e) +simpleNamed name exe gamma aenv () sh = withExecutable exe $ \nativeExecutable -> do + Native{..} <- gets llvmTarget + liftIO $ do + out <- allocateArray sh + executeOp defaultLargePPT fillP (nativeExecutable !# name) gamma aenv (IE 0 (size sh)) out + return out + + +-- Note: [Reductions] +-- +-- There are two flavours of reduction: +-- +-- 1. If we are collapsing to a single value, then threads reduce strips of +-- the input in parallel, and then a single thread reduces the partial +-- reductions to a single value. Load balancing occurs over the input +-- stripes. +-- +-- 2. If this is a multidimensional reduction, then each inner dimension is +-- handled by a single thread. Load balancing occurs over the outer +-- dimension indices. +-- +-- The entry points to executing the reduction are 'foldOp' and 'fold1Op', for +-- exclusive and inclusive reductions respectively. These functions handle +-- whether the input array is empty. If the input and output arrays are +-- non-empty, we then further dispatch (via 'foldCore') to 'foldAllOp' or +-- 'foldDimOp' for single or multidimensional reductions, respectively. +-- 'foldAllOp' in particular must execute specially whether the gang has +-- multiple worker threads which can process the array in parallel. +-- + +fold1Op + :: (Shape sh, Elt e) + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> (sh :. Int) + -> LLVM Native (Array sh e) +fold1Op kernel gamma aenv stream sh@(sx :. sz) + = $boundsCheck "fold1" "empty array" (sz > 0) + $ case size sh of + 0 -> liftIO $ allocateArray sx -- empty, but possibly with non-zero dimensions + _ -> foldCore kernel gamma aenv stream sh + +foldOp + :: (Shape sh, Elt e) + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> (sh :. Int) + -> LLVM Native (Array sh e) +foldOp kernel gamma aenv stream sh@(sx :. _) = + case size sh of + 0 -> simpleNamed "generate" kernel gamma aenv stream sx + _ -> foldCore kernel gamma aenv stream sh + +foldCore + :: (Shape sh, Elt e) + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> (sh :. Int) + -> LLVM Native (Array sh e) +foldCore kernel gamma aenv stream sh + | Just Refl <- matchShapeType sh (undefined::DIM1) + = foldAllOp kernel gamma aenv stream sh + -- + | otherwise + = foldDimOp kernel gamma aenv stream sh + +foldAllOp + :: forall aenv e. Elt e + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> DIM1 + -> LLVM Native (Scalar e) +foldAllOp exe gamma aenv () (Z :. sz) = withExecutable exe $ \nativeExecutable -> do + Native{..} <- gets llvmTarget + let + ncpu = gangSize + stride = defaultLargePPT `min` ((sz + ncpu - 1) `quot` ncpu) + steps = (sz + stride - 1) `quot` stride + -- + if ncpu == 1 || sz <= defaultLargePPT + then liftIO $ do + -- Sequential reduction + out <- allocateArray Z + executeOp 1 fillS (nativeExecutable !# "foldAllS") gamma aenv (IE 0 sz) out + return out + + else liftIO $ do + -- Parallel reduction + out <- allocateArray Z + tmp <- allocateArray (Z :. steps) :: IO (Vector e) + executeOp 1 fillP (nativeExecutable !# "foldAllP1") gamma aenv (IE 0 steps) (sz, stride, tmp) + executeOp 1 fillS (nativeExecutable !# "foldAllP2") gamma aenv (IE 0 steps) (tmp, out) + return out + +foldDimOp + :: (Shape sh, Elt e) + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> (sh :. Int) + -> LLVM Native (Array sh e) +foldDimOp exe gamma aenv () (sh :. sz) = withExecutable exe $ \nativeExecutable -> do + Native{..} <- gets llvmTarget + let ppt = defaultSmallPPT `max` (defaultLargePPT `quot` (max 1 sz)) + liftIO $ do + out <- allocateArray sh + executeOp ppt fillP (nativeExecutable !# "fold") gamma aenv (IE 0 (size sh)) (sz, out) + return out + +foldSegOp + :: (Shape sh, Elt e) + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> (sh :. Int) + -> (Z :. Int) + -> LLVM Native (Array (sh :. Int) e) +foldSegOp exe gamma aenv () (sh :. _) (Z :. ss) = withExecutable exe $ \nativeExecutable -> do + Native{..} <- gets llvmTarget + let + kernel | segmentOffset = "foldSegP" + | otherwise = "foldSegS" + n | segmentOffset = ss - 1 -- segments array has been 'scanl (+) 0'`ed + | otherwise = ss + ppt | rank sh == 0 = defaultLargePPT -- work-steal over the single dimension + | otherwise = n -- a thread computes all segments along an index + -- + liftIO $ do + out <- allocateArray (sh :. n) + executeOp ppt fillP (nativeExecutable !# kernel) gamma aenv (IE 0 (size (sh :. n))) out + return out + + +scanOp + :: (Shape sh, Elt e) + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> sh :. Int + -> LLVM Native (Array (sh:.Int) e) +scanOp kernel gamma aenv stream (sz :. n) = + case n of + 0 -> simpleNamed "generate" kernel gamma aenv stream (sz :. 1) + _ -> scanCore kernel gamma aenv stream sz n (n+1) + +scan1Op + :: (Shape sh, Elt e) + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> sh :. Int + -> LLVM Native (Array (sh:.Int) e) +scan1Op kernel gamma aenv stream (sz :. n) + = $boundsCheck "scan1" "empty array" (n > 0) + $ scanCore kernel gamma aenv stream sz n n + +scanCore + :: forall aenv sh e. (Shape sh, Elt e) + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> sh + -> Int + -> Int + -> LLVM Native (Array (sh:.Int) e) +scanCore exe gamma aenv () sz n m = withExecutable exe $ \nativeExecutable -> do + Native{..} <- gets llvmTarget + let + ncpu = gangSize + stride = defaultLargePPT `min` ((n + ncpu - 1) `quot` ncpu) + steps = (n + stride - 1) `quot` stride + steps' = steps - 1 + -- + if ncpu == 1 || rank sz > 0 || n <= 2 * defaultLargePPT + then liftIO $ do + -- Either: + -- + -- 1. Sequential scan of an array of any rank + -- + -- 2. Parallel scan of multidimensional array: threads scan along the + -- length of the innermost dimension. Threads are scheduled over the + -- inner dimensions. + -- + -- 3. Small 1D array. Since parallel scan requires ~4n data transfer + -- compared to ~2n in the sequential case, it is only worthwhile if + -- the extra cores can offset the increased bandwidth requirements. + -- + out <- allocateArray (sz :. m) + executeOp 1 fillP (nativeExecutable !# "scanS") gamma aenv (IE 0 (size sz)) out + return out + + else liftIO $ do + -- parallel one-dimensional scan + out <- allocateArray (sz :. m) + tmp <- allocateArray (Z :. steps) :: IO (Vector e) + executeOp 1 fillP (nativeExecutable !# "scanP1") gamma aenv (IE 0 steps) (stride, steps', out, tmp) + executeOp 1 fillS (nativeExecutable !# "scanP2") gamma aenv (IE 0 steps) tmp + executeOp 1 fillP (nativeExecutable !# "scanP3") gamma aenv (IE 0 steps') (stride, out, tmp) + return out + + +scan'Op + :: forall aenv sh e. (Shape sh, Elt e) + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> sh :. Int + -> LLVM Native (Array (sh:.Int) e, Array sh e) +scan'Op native gamma aenv stream sh@(sz :. n) = + case n of + 0 -> do + out <- liftIO $ allocateArray (sz :. 0) + sum <- simpleNamed "generate" native gamma aenv stream sz + return (out, sum) + -- + _ -> scan'Core native gamma aenv stream sh + +scan'Core + :: forall aenv sh e. (Shape sh, Elt e) + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> sh :. Int + -> LLVM Native (Array (sh:.Int) e, Array sh e) +scan'Core exe gamma aenv () sh@(sz :. n) = withExecutable exe $ \nativeExecutable -> do + Native{..} <- gets llvmTarget + let + ncpu = gangSize + stride = defaultLargePPT `min` ((n + ncpu - 1) `quot` ncpu) + steps = (n + stride - 1) `quot` stride + steps' = steps - 1 + -- + if ncpu == 1 || rank sz > 0 || n <= 2 * defaultLargePPT + then liftIO $ do + out <- allocateArray sh + sum <- allocateArray sz + executeOp 1 fillP (nativeExecutable !# "scanS") gamma aenv (IE 0 (size sz)) (out,sum) + return (out,sum) + + else liftIO $ do + tmp <- allocateArray (Z :. steps) :: IO (Vector e) + out <- allocateArray sh + sum <- allocateArray sz + executeOp 1 fillP (nativeExecutable !# "scanP1") gamma aenv (IE 0 steps) (stride, steps', out, tmp) + executeOp 1 fillS (nativeExecutable !# "scanP2") gamma aenv (IE 0 steps) (sum, tmp) + executeOp 1 fillP (nativeExecutable !# "scanP3") gamma aenv (IE 0 steps') (stride, out, tmp) + return (out,sum) + + +-- Forward permutation, specified by an indexing mapping into an array and a +-- combination function to combine elements. +-- +permuteOp + :: (Shape sh, Shape sh', Elt e) + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> Bool + -> sh + -> Array sh' e + -> LLVM Native (Array sh' e) +permuteOp exe gamma aenv () inplace shIn dfs = withExecutable exe $ \nativeExecutable -> do + Native{..} <- gets llvmTarget + out <- if inplace + then return dfs + else cloneArray dfs + let + ncpu = gangSize + n = size shIn + m = size (shape out) + -- + if ncpu == 1 || n <= defaultLargePPT + then liftIO $ do + -- sequential permutation + executeOp 1 fillS (nativeExecutable !# "permuteS") gamma aenv (IE 0 n) out + + else liftIO $ do + -- parallel permutation + case lookupFunction "permuteP_rmw" nativeExecutable of + Just f -> executeOp defaultLargePPT fillP f gamma aenv (IE 0 n) out + Nothing -> do + barrier@(Array _ adb) <- allocateArray (Z :. m) :: IO (Vector Word8) + memset (ptrsOfArrayData adb) 0 m + executeOp defaultLargePPT fillP (nativeExecutable !# "permuteP_mutex") gamma aenv (IE 0 n) (out, barrier) + + return out + + +stencil2Op + :: (Shape sh, Elt e) + => ExecutableR Native + -> Gamma aenv + -> Aval aenv + -> Stream + -> sh + -> sh + -> LLVM Native (Array sh e) +stencil2Op kernel gamma aenv stream sh1 sh2 = + simpleOp kernel gamma aenv stream (sh1 `intersect` sh2) + + +aforeignOp + :: (Arrays as, Arrays bs) + => String + -> (Stream -> as -> LLVM Native bs) + -> Stream + -> as + -> LLVM Native bs +aforeignOp name asm stream arr = do + wallBegin <- liftIO $ getCurrentTime + result <- Debug.timed Debug.dump_exec (\wall cpu -> printf "exec: %s %s" name (Debug.elapsedP wall cpu)) (asm stream arr) + wallEnd <- liftIO $ getCurrentTime + liftIO $ Debug.addProcessorTime Debug.Native (realToFrac (diffUTCTime wallEnd wallBegin)) + return result + + +-- Skeleton execution +-- ------------------ + +(!#) :: FunctionTable -> ShortByteString -> Function +(!#) exe name + = fromMaybe ($internalError "lookupFunction" ("function not found: " ++ S8.unpack name)) + $ lookupFunction name exe + +lookupFunction :: ShortByteString -> FunctionTable -> Maybe Function +lookupFunction name nativeExecutable = do + find (\(n,_) -> n == name) (functionTable nativeExecutable) + +-- Execute the given function distributed over the available threads. +-- +executeOp + :: Marshalable args + => Int + -> Executable + -> Function + -> Gamma aenv + -> Aval aenv + -> Range + -> args + -> IO () +executeOp ppt exe (name, f) gamma aenv r args = do + args' <- marshal (undefined::Native) () (args, (gamma, aenv)) + -- + runExecutable exe name ppt r $ \start end _tid -> do + monitorProcTime $ + callFFI f retVoid (argInt start : argInt end : args') + + +-- Standard C functions +-- -------------------- + +memset :: Ptr Word8 -> Word8 -> Int -> IO () +memset p w s = c_memset p (fromIntegral w) (fromIntegral s) >> return () + +foreign import ccall unsafe "string.h memset" c_memset + :: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8) + + +-- Debugging +-- --------- + +monitorProcTime :: IO a -> IO a +monitorProcTime = Debug.withProcessor Debug.Native + 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,52 @@ +{-# 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/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,25 @@ +{-# 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/src/Data/Array/Accelerate/LLVM/Native/Execute/LBS.hs b/src/Data/Array/Accelerate/LLVM/Native/Execute/LBS.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Execute/LBS.hs @@ -0,0 +1,34 @@ +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Execute.LBS +-- Copyright : [2014..2017] Trevor L. McDonell +-- [2014..2014] Vinod Grover (NVIDIA Corporation) +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Execute.LBS + where + +-- Some default values for the profitable parallelism threshold (PPT). These are +-- chosen as to reduce the frequency of deque checks. Since a deque check also +-- requires returning from the foreign LLVM function back to the scheduler code, +-- it is important to combine fine-grained iterations via the PPT. +-- +-- The large PPT is meant for operations such as @map@ and @generate@, where the +-- input length equates the total number of elements to process. The small PPT +-- is meant for operations such as multidimensional reduction, where each input +-- index corresponds to a non-unit amount of work. +-- +-- These should really be dynamic values based on how long it took to execute +-- the last chunk, increase or decrease the chunk size to ensure quick +-- turnaround and also low scheduler overhead. +-- +defaultLargePPT :: Int +defaultLargePPT = 4096 + +defaultSmallPPT :: Int +defaultSmallPPT = 64 + diff --git a/src/Data/Array/Accelerate/LLVM/Native/Execute/Marshal.hs b/src/Data/Array/Accelerate/LLVM/Native/Execute/Marshal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Execute/Marshal.hs @@ -0,0 +1,108 @@ +{-# 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 (ArrayEltRvec2 ae) (AD_V2 ad) = marshalR ae ad + marshalR (ArrayEltRvec3 ae) (AD_V3 ad) = marshalR ae ad + marshalR (ArrayEltRvec4 ae) (AD_V4 ad) = marshalR ae ad + marshalR (ArrayEltRvec8 ae) (AD_V8 ad) = marshalR ae ad + marshalR (ArrayEltRvec16 ae) (AD_V16 ad) = marshalR ae ad + -- + marshalR ArrayEltRint ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRint8 ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRint16 ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRint32 ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRint64 ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRword ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRword8 ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRword16 ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRword32 ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRword64 ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRhalf ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRfloat ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRdouble ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRchar ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRcshort ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRcushort ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRcint ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRcuint ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRclong ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRculong ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRcllong ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRcullong ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRcchar ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRcschar ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRcuchar ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRcfloat ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRcdouble ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + marshalR ArrayEltRbool ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad) + 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,82 @@ +{-# 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/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,70 @@ +{-# 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/src/Data/Array/Accelerate/LLVM/Native/Link/COFF.hs b/src/Data/Array/Accelerate/LLVM/Native/Link/COFF.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Link/COFF.hs @@ -0,0 +1,35 @@ +{-# 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/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,22 @@ +-- | +-- 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/src/Data/Array/Accelerate/LLVM/Native/Link/ELF.chs b/src/Data/Array/Accelerate/LLVM/Native/Link/ELF.chs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Link/ELF.chs @@ -0,0 +1,752 @@ +{-# 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.Prim ( addr2Int#, int2Word#, int2Addr# ) +import GHC.Ptr ( Ptr(..) ) +import GHC.Word ( Word64(..) ) +import System.IO.Unsafe +import System.Posix.DynamicLinker +import System.Posix.Types ( COff(..) ) +import Text.Printf +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +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 + + -- Unmap the executable pages when they are no longer required + -- + objectcode <- newLifetime [oc] + addFinalizer objectcode $ do + Debug.traceIO Debug.dump_gc ("gc: unload module: " ++ show funtab) + case oc of + Segment vmsize oc_fp -> + withForeignPtr oc_fp $ \oc_p -> + munmap oc_p vmsize + + 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 + + -- Allocate new pages to store the executable code. This is allocated in + -- the lower 2GB so that 32-bit relocations should work without needing + -- to go via the jump tables. + -- + -- The memory is implicitly initialised to zero (corresponding to NOP). + -- This also takes care of .bss sections. + -- + seg_p <- mmap vmsize + seg_fp <- newForeignPtr_ seg_p + + -- Jump tables are placed directly after the segment data + let jump_p = seg_p `plusPtr` vmsize' + V.imapM_ (makeJumpIsland jump_p) symtab + + -- Copy over section data + V.izipWithM_ (loadSection obj strtab seg_p) offsets secs + + -- Process relocations + V.mapM_ (processRelocation symtab offsets seg_p jump_p) relocs + + -- Mark the page as executable and read-only + mprotect seg_p vmsize ({#const PROT_READ#} .|. {#const PROT_EXEC#}) + + -- Resolve external symbols defined in the sections into function + -- pointers. + -- + -- Note that in order to support ahead-of-time compilation, the generated + -- functions are given unique names by appending with an underscore followed + -- by a unique ID. The execution phase doesn't need to know about this + -- however, so un-mangle the name to the basic "map", "fold", etc. + -- + let funtab = FunctionTable $ V.toList (V.map resolve (V.filter extern symtab)) + extern Symbol{..} = sym_binding == Global && sym_type == Func + resolve Symbol{..} = + let name = BS.toShort (B8.take (B8.length sym_name - 65) sym_name) + addr = castPtrToFunPtr (seg_p `plusPtr` (fromIntegral sym_value + offsets V.! sym_section)) + in + (name, addr) + -- + return (funtab, 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=%-14s value=%s%+d" r_offset r_symbol r_section (show r_type) (B8.unpack sym_name) r_addend) + case r_type of + R_X86_64_None -> return () + R_X86_64_64 -> relocate value + + R_X86_64_PC32 -> + let offset :: Int64 + offset = fromIntegral (value - pc') + in + if offset >= 0x7fffffff || offset < -0x80000000 + then + let jump' = castPtrToWord64 (jump_p `plusPtr` (r_symbol * 16 + 8)) + offset' = fromIntegral jump' + r_addend - fromIntegral pc' + in + relocate (fromIntegral offset' :: Word32) + else + relocate (fromIntegral offset :: Word32) + + R_X86_64_PC64 -> + let offset :: Int64 + offset = fromIntegral (value - pc') + in + relocate (fromIntegral offset :: Word32) + + R_X86_64_32 -> + if value >= 0x7fffffff + then + let jump' = castPtrToWord64 (jump_p `plusPtr` (r_symbol * 16 + 8)) + value' = fromIntegral jump' + r_addend + in + relocate (fromIntegral value' :: Word32) + else + relocate (fromIntegral value :: Word32) + + R_X86_64_32S -> + let values :: Int64 + values = fromIntegral value + in + if values > 0x7fffffff || values < -0x80000000 + then + let jump' = castPtrToWord64 (jump_p `plusPtr` (r_symbol * 16 + 8)) + value' = fromIntegral jump' + r_addend + in + relocate (fromIntegral value' :: Int32) + else + relocate (fromIntegral value :: Int32) + + R_X86_64_PLT32 -> + let offset :: Int64 + offset = fromIntegral (value - pc') + in + if offset >= 0x7fffffff || offset < -0x80000000 + then + let jump' = castPtrToWord64 (jump_p `plusPtr` (r_symbol * 16 + 8)) + offset' = fromIntegral jump' + r_addend - fromIntegral pc' + in + relocate (fromIntegral offset' :: Word32) + else + relocate (fromIntegral offset :: Word32) + + where + pc :: Ptr Word8 + pc = seg_p `plusPtr` (fromIntegral r_offset + sec_offset V.! r_section) + pc' = castPtrToWord64 pc + + value :: Word64 + value = symval + fromIntegral r_addend + + symval :: Word64 + symval = + case sym_binding of + Local -> castPtrToWord64 (seg_p `plusPtr` (sec_offset V.! sym_section + fromIntegral sym_value)) + Global -> sym_value + Weak -> $internalError "processRelocation" "unhandled weak symbol" + + Symbol{..} = symtab V.! r_symbol + + relocate :: Storable a => a -> IO () + relocate x = poke (castPtr pc) 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 + , R_X86_64_PLT32 as R_X86_64_PLT32 -- 32-bit PLT address + -- ... many more relocation types + } + deriving (Eq, Show) +#} +#endif + +-- The ELF file header appears at the start of every file. +-- +readHeader :: Get (Peek, Table, Table, Int) +readHeader = do + p@Peek{..} <- readIdent + (_, phs, secs, shstr) <- case is64Bit of + True -> readHeader64 p + False -> readHeader32 p + return (p, phs, secs, shstr) + + +readHeader32 :: Peek -> Get (Int, Table, Table, Int) +readHeader32 _ = fail "TODO: readHeader32" + +readHeader64 :: Peek -> Get (Int, Table, Table, Int) +readHeader64 p@Peek{..} = do + readType p + readMachine p + skip {#sizeof Elf64_Word#} -- e_version + e_entry <- getWord64 -- entry point virtual address (page offset?) + e_phoff <- getWord64 -- program header table file offset + e_shoff <- getWord64 -- section header table file offset + skip ({#sizeof Elf64_Word#}+{#sizeof Elf64_Half#}) -- e_flags + e_ehsize + e_phentsize <- getWord16 -- byte size per program header entry + e_phnum <- getWord16 -- #program header entries + e_shentsize <- getWord16 + e_shnum <- getWord16 + e_shstrndx <- getWord16 + return ( fromIntegral e_entry + , Table { tb_fileoff = fromIntegral e_phoff, tb_entries = fromIntegral e_phnum, tb_entrysize = fromIntegral e_phentsize } + , Table { tb_fileoff = fromIntegral e_shoff, tb_entries = fromIntegral e_shnum, tb_entrysize = fromIntegral e_shentsize } + , fromIntegral e_shstrndx + ) + + +readIdent :: Get Peek +readIdent = do + ei_magic <- getBytes 4 + unless (ei_magic == B8.pack [chr {#const ELFMAG0#}, {#const ELFMAG1#}, {#const ELFMAG2#}, {#const ELFMAG3#}]) $ + fail "invalid magic number" + + ei_class <- getWord8 + is64Bit <- case ei_class of + {#const ELFCLASS32#} -> return False + {#const ELFCLASS64#} -> return True + _ -> fail "invalid class" + ei_data <- getWord8 + p <- case ei_data of + {#const ELFDATA2LSB#} -> return $ Peek { getWord16 = getWord16le, getWord32 = getWord32le, getWord64 = getWord64le, .. } + {#const ELFDATA2MSB#} -> return $ Peek { getWord16 = getWord16be, getWord32 = getWord32be, getWord64 = getWord64be, .. } + _ -> fail "invalid data layout" + ei_version <- getWord8 + unless (ei_version == {#const EV_CURRENT#}) $ fail "invalid version" + skip (1+1+{#const EI_NIDENT#}-{#const EI_PAD#}) -- ABI, ABI version, padding + return p + + +readType :: Peek -> Get () +readType Peek{..} = do + e_type <- getWord16 + case e_type of + {#const ET_REL#} -> return () + _ -> fail "expected relocatable object file" + +readMachine :: Peek -> Get () +readMachine Peek{..} = do + e_machine <- getWord16 + case e_machine of +#ifdef i386_HOST_ARCH + {#const EM_386#} -> return () +#endif +#ifdef x86_64_HOST_ARCH + {#const EM_X86_64#} -> return () +#endif + _ -> fail "expected host architecture object file" + + +{-- +-- Program headers define how the ELF program behaves once it has been loaded, +-- as well as runtime linking information. +-- +-- TLM: Since we are loading object files we shouldn't get any program headers. +-- +readProgramHeader :: Peek -> Get ProgramHeader +readProgramHeader p@Peek{..} = + case is64Bit of + True -> readProgramHeader64 p + False -> readProgramHeader32 p + +readProgramHeader32 :: Peek -> Get ProgramHeader +readProgramHeader32 _ = fail "TODO: readProgramHeader32" + +readProgramHeader64 :: Peek -> Get ProgramHeader +readProgramHeader64 _ = fail "TODO: readProgramHeader64" +--} + +-- Section headers contain information such as the section name, size, and +-- location in the object file. The list of all the section headers in the ELF +-- file is known as the section header table. +-- +readSectionHeader :: Peek -> Get SectionHeader +readSectionHeader p@Peek{..} = + case is64Bit of + True -> readSectionHeader64 p + False -> readSectionHeader32 p + +readSectionHeader32 :: Peek -> Get SectionHeader +readSectionHeader32 _ = fail "TODO: readSectionHeader32" + +readSectionHeader64 :: Peek -> Get SectionHeader +readSectionHeader64 Peek{..} = do + sh_name <- fromIntegral <$> getWord32 + sh_type <- toEnum . fromIntegral <$> getWord32 + sh_flags <- getWord64 + sh_addr <- getWord64 + sh_offset <- fromIntegral <$> getWord64 + sh_size <- fromIntegral <$> getWord64 + sh_link <- fromIntegral <$> getWord32 + sh_info <- fromIntegral <$> getWord32 + sh_align <- fromIntegral <$> getWord64 + sh_entsize <- fromIntegral <$> getWord64 + return SectionHeader {..} + + +indexStringTable :: ByteString -> Int -> ByteString +indexStringTable strtab ix = B.takeWhile (/= 0) (B.drop ix strtab) + +readStringTable :: ByteString -> SectionHeader -> Either String ByteString +readStringTable obj SectionHeader{..} = + case sh_type of + StrTab -> Right $ B.take sh_size (B.drop sh_offset obj) + _ -> Left "expected string table" + + +readRelocations :: Peek -> ByteString -> SectionHeader -> Either String (Vector Relocation) +readRelocations p@Peek{..} obj SectionHeader{..} = do + unless (sh_type == Rel || sh_type == RelA) $ 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 secs strtab)) (B.drop offset obj) + return symbols + +readSymbol :: Peek -> Vector SectionHeader -> ByteString -> Get Symbol +readSymbol p@Peek{..} secs strtab = + case is64Bit of + True -> readSymbol64 p secs strtab + False -> readSymbol32 p secs strtab + +readSymbol32 :: Peek -> Vector SectionHeader -> ByteString -> Get Symbol +readSymbol32 _ _ _ = fail "TODO: readSymbol32" + +readSymbol64 :: Peek -> Vector SectionHeader -> ByteString -> Get Symbol +readSymbol64 Peek{..} secs strtab = do + st_strx <- fromIntegral <$> getWord32 + st_info <- getWord8 + skip 1 -- st_other <- getWord8 + sym_section <- fromIntegral <$> getWord16 + sym_value <- getWord64 + skip 8 -- st_size <- getWord64 + + let sym_name + | sym_type == Section = indexStringTable strtab (sh_name (secs V.! sym_section)) + | st_strx == 0 = B.empty + | otherwise = indexStringTable strtab st_strx + + sym_binding = toEnum $ fromIntegral ((st_info .&. 0xF0) `shiftR` 4) + sym_type = toEnum $ fromIntegral (st_info .&. 0x0F) + + case sym_section of + -- External symbol; lookup value + {#const SHN_UNDEF#} | not (B.null sym_name) -> do + funptr <- resolveSymbol sym_name + message (printf "%s: external symbol found at %s" (B8.unpack sym_name) (show funptr)) + return Symbol { sym_value = castPtrToWord64 (castFunPtrToPtr funptr), .. } + + -- Internally defined symbol + n | n < {#const SHN_LORESERVE#} -> do + message (printf "%s: local symbol in section %d at 0x%02x" (B8.unpack sym_name) sym_section sym_value) + return Symbol {..} + + {#const SHN_ABS#} | sym_type == File -> return Symbol {..} + {#const SHN_ABS#} -> fail "unhandled absolute symbol" + _ -> fail "unhandled symbol section" + + +-- Return the address binding the named symbol +-- +resolveSymbol :: ByteString -> Get (FunPtr ()) +resolveSymbol name + = unsafePerformIO + $ B.unsafeUseAsCString name $ \c_name -> do + addr <- c_dlsym (packDL Default) c_name + if addr == nullFunPtr + then do + err <- dlerror + return (fail $ printf "failed to resolve symbol %s: %s" (B8.unpack name) err) + else do + return (return addr) + + +-- Utilities +-- --------- + +-- Get the address of a pointer as a Word64 +-- +castPtrToWord64 :: Ptr a -> Word64 +castPtrToWord64 (Ptr addr#) = W64# (int2Word# (addr2Int# addr#)) + + +-- c-bits +-- ------ + +-- Control the protection of pages +-- +mprotect :: Ptr Word8 -> Int -> Int -> IO () +mprotect addr len prot + = throwErrnoIfMinus1_ "mprotect" + $ c_mprotect addr (fromIntegral len) (fromIntegral prot) + +-- Allocate memory pages in the lower 2GB +-- +mmap :: Int -> IO (Ptr Word8) +mmap len + = throwErrnoIf (== _MAP_FAILED) "mmap" + $ c_mmap nullPtr (fromIntegral len) prot flags (-1) 0 + where + prot = {#const PROT_READ#} .|. {#const PROT_WRITE#} + flags = {#const MAP_ANONYMOUS#} .|. {#const MAP_PRIVATE#} .|. {#const MAP_32BIT#} + _MAP_FAILED = Ptr (int2Addr# (-1#)) + +-- Remove a memory mapping +-- +munmap :: Ptr Word8 -> Int -> IO () +munmap addr len + = throwErrnoIfMinus1_ "munmap" + $ c_munmap addr (fromIntegral len) + +foreign import ccall unsafe "mprotect" + c_mprotect :: Ptr a -> CSize -> CInt -> IO CInt + +foreign import ccall unsafe "mmap" + c_mmap :: Ptr a -> CSize -> CInt -> CInt -> CInt -> COff -> IO (Ptr a) + +foreign import ccall unsafe "munmap" + c_munmap :: Ptr a -> CSize -> IO CInt + +foreign import ccall unsafe "getpagesize" + c_getpagesize :: CInt + + +-- Debug +-- ----- + +{-# INLINE trace #-} +trace :: String -> a -> a +trace msg = Debug.trace Debug.dump_ld ("ld: " ++ msg) + +{-# INLINE message #-} +message :: Monad m => String -> m () +message msg = trace msg (return ()) + diff --git a/src/Data/Array/Accelerate/LLVM/Native/Link/MachO.chs b/src/Data/Array/Accelerate/LLVM/Native/Link/MachO.chs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Native/Link/MachO.chs @@ -0,0 +1,744 @@ +{-# 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 unique ID. The execution phase doesn't need to know about this + -- however, so un-mangle the name to the basic "map", "fold", etc. + -- + let extern Symbol{..} = sym_extern && sym_segment > 0 + resolve Symbol{..} = + let Segment _ fp = segs V.! (fromIntegral (sym_segment-1)) + name = BS.toShort (B8.take (B8.length sym_name - 65) sym_name) + addr = castPtrToFunPtr (unsafeForeignPtrToPtr fp `plusPtr` fromIntegral sym_value) + in + (name, addr) + -- + funtab = FunctionTable $ V.toList $ V.map resolve (V.filter extern symtab) + objectcode = V.toList segs + + -- The executable pages were allocated on the GC heap. When the pages are + -- finalised, unset the executable bit and mark them as read/write so that + -- they can be reused. + -- + objectcode' <- newLifetime objectcode + addFinalizer objectcode' $ do + Debug.traceIO Debug.dump_gc ("gc: unload module: " ++ show funtab) + forM_ objectcode $ \(Segment vmsize oc_fp) -> do + withForeignPtr oc_fp $ \oc_p -> do + mprotect oc_p vmsize ({#const PROT_READ#} .|. {#const PROT_WRITE#}) + + return (funtab, objectcode') + + +-- Load a segment and all its sections into memory. +-- +-- Extra jump islands are added directly after the segment. On x86_64 +-- PC-relative jumps and accesses to the global offset table (GOT) are limited +-- to 32-bit (+-2GB). If we need to go outside of this range then we must do so +-- via the jump islands. +-- +-- NOTE: This puts all the sections into a single block of memory. Technically +-- this is incorrect because we then have both text and data sections together, +-- meaning that data sections are marked as execute when they really shouldn't +-- be. These would need to live in different pages in order to be mprotect-ed +-- properly. +-- +loadSegment :: 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 + if not Debug.debuggingIsEnabled + then skip ({#sizeof dysymtab_command#} - 8) + else do + ilocalsym <- getWord32 + nlocalsym <- getWord32 + iextdefsym <- getWord32 + nextdefsym <- getWord32 + iundefsym <- getWord32 + nundefsym <- getWord32 + skip 4 -- tocoff + ntoc <- getWord32 + skip 4 -- modtaboff + nmodtab <- getWord32 + skip 12 -- extrefsymoff, nextrefsyms, indirectsymoff, + nindirectsyms <- getWord32 + skip 16 -- extreloff, nextrel, locreloff, nlocrel, + message "LC_DYSYMTAB:" + -- + if nlocalsym > 0 + then message (printf " %d local symbols at index %d" nlocalsym ilocalsym) + else message (printf " No local symbols") + if nextdefsym > 0 + then message (printf " %d external symbols at index %d" nextdefsym iextdefsym) + else message (printf " No external symbols") + if nundefsym > 0 + then message (printf " %d undefined symbols at index %d" nundefsym iundefsym) + else message (printf " No undefined symbols") + if ntoc > 0 + then message (printf " %d table of contents entries" ntoc) + else message (printf " No table of contents") + if nmodtab > 0 + then message (printf " %d module table entries" nmodtab) + else message (printf " No module table") + if nindirectsyms > 0 + then message (printf " %d indirect symbols" nindirectsyms) + else message (printf " No indirect symbols") + +loadSymbol :: Peek -> ByteString -> Get Symbol +loadSymbol Peek{..} strtab = do + n_strx <- fromIntegral <$> getWord32 + n_flag <- getWord8 + n_sect <- getWord8 + skip 2 -- n_desc + n_value <- case is64Bit of + True -> fromIntegral <$> getWord64 + False -> fromIntegral <$> getWord32 + + let -- Symbols with string table index zero are defined to have a null + -- name (""). Otherwise, drop the leading underscore. + str | n_strx == 0 = B.empty + | otherwise = B.takeWhile (/= 0) (B.drop n_strx strtab) + name + | B.length str > 0 && B8.head str == '_' = B.tail str + | otherwise = str + + -- Extract the four bit fields of the type flag + -- n_pext = n_flag .&. {#const N_PEXT#} -- private external symbol bit + n_stab = n_flag .&. {#const N_STAB#} -- if any bits set, a symbolic debugging entry + n_type = n_flag .&. {#const N_TYPE#} -- mask for type bits + n_ext = n_flag .&. {#const N_EXT#} -- external symbol bit + + unless (n_stab == 0) $ fail "unhandled symbolic debugging entry (stab)" + + case n_type of + {#const N_UNDF#} -> do + funptr <- resolveSymbol name + message (printf " %s: external symbol found at %s" (B8.unpack name) (show funptr)) + return Symbol + { sym_name = name + , sym_extern = toBool n_ext + , sym_segment = n_sect + , sym_value = castPtrToWord64 (castFunPtrToPtr funptr) + } + + {#const N_SECT#} -> do + message (printf " %s: local symbol in section %d at 0x%02x" (B8.unpack name) n_sect n_value) + return Symbol + { sym_name = name + , sym_extern = toBool n_ext + , sym_segment = n_sect + , sym_value = n_value + } + + {#const N_ABS#} -> fail "unhandled absolute symbol" + {#const N_PBUD#} -> fail "unhandled prebound (dylib) symbol" + {#const N_INDR#} -> fail "unhandled indirect symbol" + _ -> fail "unknown symbol type" + + +-- Return the address binding the named symbol +-- +resolveSymbol :: ByteString -> Get (FunPtr ()) +resolveSymbol name + = unsafePerformIO + $ B.unsafeUseAsCString name $ \c_name -> do + addr <- c_dlsym (packDL Default) c_name + if addr == nullFunPtr + then do + err <- dlerror + return (fail $ printf "failed to resolve symbol %s: %s" (B8.unpack name) err) + else do + return (return addr) + + +-- Utilities +-- --------- + +-- Get the address of a pointer as a Word64 +-- +castPtrToWord64 :: Ptr a -> Word64 +castPtrToWord64 (Ptr addr#) = W64# (int2Word# (addr2Int# addr#)) + + +-- C-bits +-- ------ + +-- Control the protection of pages +-- +mprotect :: Ptr Word8 -> Int -> Int -> IO () +mprotect addr len prot + = throwErrnoIfMinus1_ "mprotect" + $ c_mprotect (castPtr addr) (fromIntegral len) (fromIntegral prot) + +foreign import ccall unsafe "mprotect" + c_mprotect :: Ptr () -> CSize -> CInt -> IO CInt + +foreign import ccall unsafe "getpagesize" + c_getpagesize :: CInt + +#if __GLASGOW_HASKELL__ <= 708 +-- Fill a given number of bytes in memory. Added in base-4.8.0.0. +-- +fillBytes :: Ptr a -> Word8 -> Int -> IO () +fillBytes dest char size = do + _ <- memset dest (fromIntegral char) (fromIntegral size) + return () + +foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO (Ptr a) +#endif + + +-- Debug +-- ----- + +{-# INLINE trace #-} +trace :: String -> a -> a +trace msg = Debug.trace Debug.dump_ld ("ld: " ++ msg) + +{-# INLINE message #-} +message :: Monad m => String -> m () +message msg = trace msg (return ()) + diff --git a/src/Data/Array/Accelerate/LLVM/Native/Link/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,40 @@ +-- | +-- 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/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,157 @@ +{-# 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 +#if __GLASGOW_HASKELL__ >= 804 + LlvmLLD opts -> LlvmLLD (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/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] 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/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,67 @@ +{-# 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/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 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 Prelude as P + +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/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,97 @@ +-- | +-- 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 ) +import qualified LLVM.Relocation as RelocationModel +import qualified LLVM.CodeModel as CodeModel +import qualified LLVM.CodeGenOpt as CodeOptimisation + +-- accelerate +import Data.Array.Accelerate.LLVM.Native.Link.Cache ( LinkCache ) +import Data.Array.Accelerate.LLVM.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 k = do + initializeNativeTarget + nativeCPUFeatures <- getHostCPUFeatures + (nativeTarget, _) <- lookupTarget Nothing nativeTargetTriple + withTargetOptions $ \targetOptions -> + withTargetMachine + nativeTarget + nativeTargetTriple + nativeCPUName + nativeCPUFeatures + targetOptions + RelocationModel.DynamicNoPIC + CodeModel.Default + CodeOptimisation.Default + k + 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,21 @@ +-- | +-- Module : nofib-llvm-native +-- Copyright : [2017] Trevor L. McDonell +-- 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.Debug + +main :: IO () +main = do + beginMonitoring + nofib runN +