packages feed

accelerate-llvm-native 1.1.0.1 → 1.4.0.0

raw patch · 79 files changed

Files

CHANGELOG.md view
@@ -6,31 +6,101 @@ project adheres to the [Haskell Package Versioning Policy (PVP)](https://pvp.haskell.org) +## [1.4.0.0] - ?+### Changed+  * Support for LLVM-15 to 22.+  * Wider platform support (including support for Apple silicon and other ARM systems) by using the system linker.+  * Support for the Tracy profiler, under the tracy and debug flags.++### Fixed+  * Undefined symbols for math functions ([accelerate-llvm#104])++### Contributors++Special thanks to those who contributed patches as part of this release:++  * Trevor L. McDonell (@tmcdonell)+  * Tom Smeding (@tomsmeding)+  * David van Balen (@dpvanbalen)+  * Ivo Gabe de Wolff (@ivogabe)+  * Robbert van der Helm (@robbert-vdh)+  * Mirek Kratochvil (@exaexa)+  * Tao He (@sighingnow)+  * Patsakula Nikita (@npatsakula)+  * Noah Williams (@noahmartinwilliams)++## [1.3.0.0] - 2018-08-27+### Changed+  * Switch the thread scheduler to static, rather than dynamic, work stealing+  * Thread scheduler is no longer block-synchronous+  * Code generation improvements, in particular for >=2-dimensional operations++### Fixed+  * Stability improvements+  * Race condition in thread scheduler ([accelerate-llvm#49])+ +### Contributors++Special thanks to those who contributed patches as part of this release:++  * Trevor L. McDonell (@tmcdonell)+  * Josh Meredith (@JoshMeredith)+  * Ivo Gabe de Wolff (@ivogabe)+  * Lars van den Haak (@sakehl)+  * Joshua Meredith (@JoshMeredith)+ ++## [1.2.0.0] - 2018-04-03+### Fixed+  * LLVM native throws "SIGSEGV: invalid address" due to fused FP operation ([#409])++### Added+  * support for half-precision floats+  * support for struct-of-array-of-struct representations+  * support for LLVM-6.0+  * support for GHC-8.4++### Contributors++Special thanks to those who contributed patches as part of this release:++  * Trevor L. McDonell (@tmcdonell)+  * @samft+  * Ryan Scott (@ryanglscott)+  * Jesse Sigal (@jasigal)+  * Moritz Kiefer (@cocreature)++ ## [1.1.0.1] - 2017-10-04 ### Fixed- * fix for `runQ*` generating multiple declarations with the same name+  * fix for `runQ*` generating multiple declarations with the same name + ## [1.1.0.0] - 2017-09-21 ### Added- * support for GHC-8.2- * caching of compilation results ([accelerate-llvm#17])- * new runtime linker; this fixes the annoying "forkOS_entry: interrupted" error. Note that currently this only supports x86_64 macOS and linux- * support for ahead-of-time compilation (`runQ` and `runQAsync`)+  * support for GHC-8.2+  * caching of compilation results ([accelerate-llvm#17])+  * new runtime linker; this fixes the annoying "forkOS_entry: interrupted" error. Note that currently this only supports x86_64 macOS and linux+  * support for ahead-of-time compilation (`runQ` and `runQAsync`)  ### Changed- * generalise `run1*` to polyvariadic `runN*`- * programs run using all cores by default; the environment variable-   `ACCELERATE_LLVM_NATIVE_THREADS` is used to set the number of worker threads-   rather than `+RTS -N`+  * generalise `run1*` to polyvariadic `runN*`+  * programs run using all cores by default; the environment variable+    `ACCELERATE_LLVM_NATIVE_THREADS` is used to set the number of worker threads+    rather than `+RTS -N`   ## [1.0.0.0] - 2017-03-31   * initial release  +[1.3.0.0]:              https://github.com/AccelerateHS/accelerate-llvm/compare/1.2.0.0...v1.3.0.0+[1.2.0.0]:              https://github.com/AccelerateHS/accelerate-llvm/compare/1.1.0.1-native...1.2.0.0 [1.1.0.1]:              https://github.com/AccelerateHS/accelerate-llvm/compare/1.1.0.0...1.1.0.1-native [1.1.0.0]:              https://github.com/AccelerateHS/accelerate-llvm/compare/1.0.0.0...1.1.0.0 [1.0.0.0]:              https://github.com/AccelerateHS/accelerate-llvm/compare/be7f91295f77434b2103c70aa1cabb6a4f2b09a8...1.0.0.0 +[#409]:                 https://github.com/AccelerateHS/accelerate/issues/409 [accelerate-llvm#17]:   https://github.com/AccelerateHS/accelerate-llvm/issues/17-+[accelerate-llvm#49]:   https://github.com/AccelerateHS/accelerate-llvm/pull/49+[accelerate-llvm#104]:  https://github.com/AccelerateHS/accelerate-llvm/pull/104
− Data/Array/Accelerate/LLVM/Native.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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 <https://github.com/tmcdonell/lulesh-accelerate lulesh-accelerate>--- project for an example.------ [/Note:/]------ Due to <https://ghc.haskell.org/trac/ghc/ticket/13587 GHC#13587>, 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-
− Data/Array/Accelerate/LLVM/Native/Array/Data.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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)-
− Data/Array/Accelerate/LLVM/Native/CodeGen.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/Native/CodeGen/Base.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-                     }-    }-
− Data/Array/Accelerate/LLVM/Native/CodeGen/Fold.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/Native/CodeGen/FoldSeg.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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_-
− Data/Array/Accelerate/LLVM/Native/CodeGen/Generate.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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_-
− Data/Array/Accelerate/LLVM/Native/CodeGen/Loop.hs 
@@ -1,46 +0,0 @@--- |--- Module      : Data.Array.Accelerate.LLVM.CodeGen.Native.Loop--- Copyright   : [2014..2017] Trevor L. McDonell--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/Native/CodeGen/Map.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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_-
− Data/Array/Accelerate/LLVM/Native/CodeGen/Permute.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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.------ <https://en.wikipedia.org/wiki/Spinlock#Significant_optimizations>----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))-
− Data/Array/Accelerate/LLVM/Native/CodeGen/Scan.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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_-
− Data/Array/Accelerate/LLVM/Native/Compile.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/Native/Compile/Cache.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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"-
− Data/Array/Accelerate/LLVM/Native/Compile/Optimise.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-  ]---}-
− Data/Array/Accelerate/LLVM/Native/Debug.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/Native/Distribution/Simple.hs 
@@ -1,65 +0,0 @@--- |--- Module      : Data.Array.Accelerate.LLVM.Native.Distribution.Simple--- Copyright   : [2017] Trevor L. McDonell--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- 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)-
− Data/Array/Accelerate/LLVM/Native/Distribution/Simple/Build.hs 
@@ -1,451 +0,0 @@--- |--- Module      : Data.Array.Accelerate.LLVM.Native.Distribution.Simple.Build--- Copyright   : [2017] Trevor L. McDonell--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- 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."--
− Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC.hs 
@@ -1,438 +0,0 @@--- |--- Module      : Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC--- Copyright   : [2017] Trevor L. McDonell--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- 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----- <https://github.com/haskell/cabal/blob/2.0/Cabal/Distribution/Simple/GHC.hs#L505>----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"-
− Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC/Internal.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/Native/Embed.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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')-
− Data/Array/Accelerate/LLVM/Native/Execute.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/Native/Execute/Async.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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 ()-
− Data/Array/Accelerate/LLVM/Native/Execute/Environment.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/Native/Execute/LBS.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/Native/Execute/Marshal.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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)-
− Data/Array/Accelerate/LLVM/Native/Foreign.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/Native/Link.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/Native/Link/COFF.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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"-
− Data/Array/Accelerate/LLVM/Native/Link/Cache.hs 
@@ -1,22 +0,0 @@--- |--- Module      : Data.Array.Accelerate.LLVM.Native.Link.Cache--- Copyright   : [2017] Trevor L. McDonell--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/Native/Link/ELF.chs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)-----module Data.Array.Accelerate.LLVM.Native.Link.ELF (--  loadObject,--) where--import Data.Array.Accelerate.Error-import Data.Array.Accelerate.LLVM.Native.Link.Object-import Data.Array.Accelerate.Lifetime-import qualified Data.Array.Accelerate.Debug              as Debug--import Control.Applicative-import Control.Monad-import Data.Bits-import Data.ByteString                                    ( ByteString )-import Data.Char-import Data.Int-import Data.List-import Data.Serialize.Get-import Data.Vector                                        ( Vector )-import Data.Word-import Foreign.C-import Foreign.ForeignPtr-import Foreign.Marshal-import Foreign.Ptr-import Foreign.Storable-import GHC.ForeignPtr                                     ( mallocPlainForeignPtrAlignedBytes )-import GHC.Prim                                           ( addr2Int#, int2Word# )-import GHC.Ptr                                            ( Ptr(..) )-import GHC.Word                                           ( Word64(..) )-import System.IO.Unsafe-import System.Posix.DynamicLinker-import Text.Printf-import qualified Data.ByteString                          as B-import qualified Data.ByteString.Char8                    as B8-import qualified Data.ByteString.Internal                 as B-import qualified Data.ByteString.Short                    as BS-import qualified Data.ByteString.Unsafe                   as B-import qualified Data.Vector                              as V-import Prelude                                            as P--#include <elf.h>-#include <sys/mman.h>----- Dynamic object loading--- -------------------------- Load an ELF object file and return pointers to the executable functions--- defined within. The executable sections are aligned appropriately, as--- specified in the object file, and are ready to be executed on the target--- architecture.----loadObject :: 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 ())-
− Data/Array/Accelerate/LLVM/Native/Link/MachO.chs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)-----module Data.Array.Accelerate.LLVM.Native.Link.MachO (--  loadObject,--) where--import Data.Array.Accelerate.Error-import Data.Array.Accelerate.LLVM.Native.Link.Object-import Data.Array.Accelerate.Lifetime-import qualified Data.Array.Accelerate.Debug              as Debug--import Control.Applicative-import Control.Monad-import Data.Bits-import Data.ByteString                                    ( ByteString )-import Data.Maybe                                         ( catMaybes )-import Data.Serialize.Get-import Data.Vector                                        ( Vector )-import Data.Word-import Foreign.C-import Foreign.ForeignPtr-import Foreign.ForeignPtr.Unsafe-import Foreign.Marshal-import Foreign.Ptr-import Foreign.Storable-import GHC.ForeignPtr                                     ( mallocPlainForeignPtrAlignedBytes )-import GHC.Prim                                           ( addr2Int#, int2Word# )-import GHC.Ptr                                            ( Ptr(..) )-import GHC.Word                                           ( Word64(..) )-import System.IO.Unsafe-import System.Posix.DynamicLinker-import Text.Printf-import qualified Data.ByteString                          as B-import qualified Data.ByteString.Char8                    as B8-import qualified Data.ByteString.Internal                 as B-import qualified Data.ByteString.Short                    as BS-import qualified Data.ByteString.Unsafe                   as B-import qualified Data.Vector                              as V-import Prelude                                            as P--#include <mach-o/loader.h>-#include <mach-o/nlist.h>-#include <mach-o/reloc.h>-#include <mach/machine.h>-#include <sys/mman.h>-#ifdef x86_64_HOST_ARCH-#include <mach-o/x86_64/reloc.h>-#endif-#ifdef powerpc_HOST_ARCH-#include <mach-o/ppc/reloc.h>-#endif----- Dynamic object loading--- -------------------------- Load a Mach-O object file and return pointers to the executable functions--- defined within. The executable sections are aligned appropriately, as--- specified in the object file, and are ready to be executed on the target--- architecture.----loadObject :: 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 ())-
− Data/Array/Accelerate/LLVM/Native/Link/Object.hs 
@@ -1,40 +0,0 @@--- |--- Module      : Data.Array.Accelerate.LLVM.Native.Link.Object--- Copyright   : [2017] Trevor L. McDonell--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/Native/Plugin.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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 []-
− Data/Array/Accelerate/LLVM/Native/Plugin/Annotation.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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)-
− Data/Array/Accelerate/LLVM/Native/Plugin/BuildInfo.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/Native/State.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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)-
− Data/Array/Accelerate/LLVM/Native/Target.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) [2014..2017] The Accelerate Team.  All rights reserved.+Copyright (c) [2014..2020] The Accelerate Team.  All rights reserved.  Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
README.md view
@@ -1,14 +1,18 @@-An LLVM backend for the Accelerate Array Language-=================================================+<div align="center">+<img width="450" src="https://github.com/AccelerateHS/accelerate/raw/master/images/accelerate-logo-text-v.png?raw=true" alt="henlo, my name is Theia"/> -[![Build Status](https://travis-ci.org/AccelerateHS/accelerate-llvm.svg)](https://travis-ci.org/AccelerateHS/accelerate-llvm)+# LLVM backends for the Accelerate array language++[![CI](https://github.com/AccelerateHS/accelerate-llvm/actions/workflows/ci.yml/badge.svg)](https://github.com/AccelerateHS/accelerate-llvm/actions/workflows/ci.yml)+[![Gitter](https://img.shields.io/gitter/room/nwjs/nw.js.svg)](https://gitter.im/AccelerateHS/Lobby) [![Hackage](https://img.shields.io/hackage/v/accelerate-llvm.svg)](https://hackage.haskell.org/package/accelerate-llvm)-[![Docker Automated build](https://img.shields.io/docker/automated/tmcdonell/accelerate-llvm.svg)](https://hub.docker.com/r/tmcdonell/accelerate-llvm/)-[![Docker status](https://images.microbadger.com/badges/image/tmcdonell/accelerate-llvm.svg)](https://microbadger.com/images/tmcdonell/accelerate-llvm) +</div>+ This package compiles Accelerate code to LLVM IR, and executes that code on-multicore CPUs as well as NVIDIA GPUs. This avoids the need to go through `nvcc`-or `clang`. For details on Accelerate, refer to the [main repository][GitHub].+multicore CPUs as well as NVIDIA GPUs. This avoids the need to go through+`nvcc` or write C++ code. For details on Accelerate, refer to the [main+repository][GitHub].  We love all kinds of contributions, so feel free to open issues for missing features as well as report (or fix!) bugs on the [issue tracker][Issues].@@ -18,171 +22,143 @@    * [Dependencies](#dependencies)- * [Docker](#docker)- * [Installing LLVM](#installing-llvm)-   * [Homebrew](#homebrew)+   * [macOS](#macos)    * [Debian/Ubuntu](#debianubuntu)-   * [Building from source](#building-from-source)- * [Installing Accelerate-LLVM](#installing-accelerate-llvm)-   * [libNVVM](#libNVVM)+   * [Arch Linux](#archlinux)+   * [Windows](#windows)   Dependencies ------------ -Haskell dependencies are available from Hackage, but there are several external+Haskell dependencies are available from Hackage, but there are some external library dependencies that you will need to install as well: - * [`LLVM`](http://llvm.org)- * [`libFFI`](http://sourceware.org/libffi/) (if using the `accelerate-llvm-native` backend for multicore CPUs)- * [`CUDA`](https://developer.nvidia.com/cuda-downloads) (if using the `accelerate-llvm-ptx` backend for NVIDIA GPUs)---Docker---------A [docker](https://www.docker.com) container is provided with this package-preinstalled (via stack) at `/opt/accelerate-llvm`. Note that if you wish to use-the `accelerate-llvm-ptx` GPU backend, you will need to install the [NVIDIA-docker](https://github.com/NVIDIA/nvidia-docker) plugin; see that page for more-information.--```sh-$ docker run -it tmcdonell/accelerate-llvm-```---Installing LLVM------------------When installing LLVM, make sure that it includes the `libLLVM` shared library.-If you want to use the GPU targeting `accelerate-llvm-ptx` backend, make sure-you install (or build) LLVM with the 'nvptx' target.+- if using `accelerate-llvm-native` for multicore CPU:+  [`libFFI`](http://sourceware.org/libffi/)+- if using `accelerate-llvm-ptx` for GPU:+  [`CUDA`](https://developer.nvidia.com/cuda-downloads);+  [Note that not all versions of CUDA support all NVIDIA GPUs](https://en.wikipedia.org/wiki/CUDA#GPUs_supported)+- [`clang`](https://clang.llvm.org/) (if using `accelerate-llvm-ptx`: version+  16 or higher, built with support for the `nvptx` backend). `accelerate-llvm`+  uses the command-line tool as a way to be compatible with many different LLVM+  versions, not to compile C code. (Accelerate passes LLVM IR to `clang`.) -## Homebrew+Below are some OS-specific instructions. If anything here is wrong or out of+date, please file an issue. -Example using [Homebrew](http://brew.sh) on macOS:+## macOS -```sh-$ brew install llvm-hs/homebrew-llvm/llvm-4.0-```+To get `libFFI`, run `brew install libffi`. `clang` is already provided with+macOS (you may need to `xcode-select --install`), and CUDA is not supported on+macOS.  ## Debian/Ubuntu -For Debian/Ubuntu based Linux distributions, the LLVM.org website provides-binary distribution packages. Check [apt.llvm.org](http://apt.llvm.org) for-instructions for adding the correct package database for your OS version, and-then:--```sh-$ apt-get install llvm-4.0-dev-```--## Building from source--If your OS does not have an appropriate LLVM distribution available, you can also build from source. Detailed build instructions are available on the [LLVM.org website](http://releases.llvm.org/4.0.0/docs/CMake.html). Note that you will require at least [CMake 3.4.3](http://www.cmake.org/cmake/resources/software.html) and a recent C++ compiler; at least Clang 3.1, GCC 4.8, or Visual Studio 2015 (update 3).--  1. Download and unpack the [LLVM-4.0 source code](http://releases.llvm.org/4.0.0/llvm-4.0.0.src.tar.xz). We'll refer to-     the path that the source tree was unpacked to as `LLVM_SRC`. Only the main-     LLVM source tree is required, but you can optionally add other components-     such as the Clang compiler or Polly loop optimiser. See the [LLVM releases](http://releases.llvm.org/download.html#4.0.0)-     page for the complete list.--  2. Create a temporary build directory and `cd` into it, for example:-     ```sh-     $ mkdir /tmp/build-     $ cd /tmp/build-     ```--  3. Execute the following to configure the build. Here `INSTALL_PREFIX` is-     where LLVM is to be installed, for example `/usr/local` or-     `$HOME/opt/llvm`:-     ```sh-     $ cmake $LLVM_SRC -DCMAKE_INSTALL_PREFIX=$INSTALL_PREFIX -DCMAKE_BUILD_TYPE=Release -DLLVM_ENABLE_ASSERTIONS=ON -DLLVM_BUILD_LLVM_DYLIB=ON -DLLVM_LINK_LLVM_DYLIB=ON-     ```-     See [options and variables](http://llvm.org/docs/CMake.html#options-and-variables)-     for a list of additional build parameters you can specify.--  4. Build and install:-     ```sh-     $ cmake --build .-     $ cmake --build . --target install-     ```--  5. For macOS only, some additional steps are useful to work around issues related-     to [System Integrity Protection](https://en.wikipedia.org/wiki/System_Integrity_Protection):-     ```sh-     cd $INSTALL_PREFIX/lib-     ln -s libLLVM.dylib libLLVM-4.0.dylib-     install_name_tool -id $PWD/libLTO.dylib libLTO.dylib-     install_name_tool -id $PWD/libLLVM.dylib libLLVM.dylib-     install_name_tool -change '@rpath/libLLVM.dylib' $PWD/libLLVM.dylib libLTO.dylib-     ```+For `clang`:+- On Ubuntu 24.04 (noble) / Debian trixie or higher: `sudo apt install clang`.+- Otherwise, if you need only the CPU backend (`accelerate-llvm-native`):+  `sudo apt install clang` will give you an old version of `clang`, but the CPU+   backend is likely to work fine.+- If you are on an older distro and need the GPU backend+  (`accelerate-llvm-ptx`): `clang` version 16 or higher is required.+  Add the apt source from [apt.llvm.org](https://apt.llvm.org/). The neatest+  way to do this is to create a file `/etc/apt/sources.list.d/llvm.list` (the+  precise file name does not matter) and put in it, for Ubuntu (change "jammy"+  as appropriate): +      deb http://apt.llvm.org/jammy/ llvm-toolchain-jammy main+      deb-src http://apt.llvm.org/jammy/ llvm-toolchain-jammy main -Installing Accelerate-LLVM---------------------------+  or for Debian (change "bookworm" as appropriate): -Once the dependencies are installed, we are ready to install `accelerate-llvm`.+      deb http://apt.llvm.org/bookworm/ llvm-toolchain-bookworm main+      deb-src http://apt.llvm.org/bookworm/ llvm-toolchain-bookworm main -For example, installation using [`stack`](http://docs.haskellstack.org/en/stable/README.html)-just requires you to point it to the appropriate configuration file:-```sh-$ ln -s stack-8.0.yaml stack.yaml-$ stack setup-$ stack install-```+  and `sudo apt update; sudo apt install clang`. This gets you the latest+  version of `clang`; different sources are also available for specific+  versions (see [apt.llvm.org](https://apt.llvm.org)). -Note that the version of [`llvm-hs`](https://hackage.haskell.org/package/llvm-hs)-used must match the installed version of LLVM, which is currently 4.0.+To use the CPU backend (`accelerate-llvm-native`), install `libFFI` using+`sudo apt install libffi-dev`. +To use the GPU backend (`accelerate-llvm-ptx`), install CUDA from+[here](https://developer.nvidia.com/cuda-downloads?target_os=Linux)+("deb (network)" is smoother than the "deb (local)" option). -## libNVVM+## Arch Linux -The `accelerate-llvm-ptx` backend can optionally be compiled to generate GPU-code using the `libNVVM` library, rather than LLVM's inbuilt NVPTX code-generator. `libNVVM` is a closed-source library distributed as part of the-NVIDIA CUDA toolkit, and is what the `nvcc` compiler itself uses internally when-compiling CUDA C code.+Run `sudo pacman -S clang`. To use the CPU backend (`accelerate-llvm-native`),+additionally run `sudo pacman -S libffi`. To use the GPU backend+(`accelerate-llvm-ptx`), additionally run `sudo pacman -S cuda`. -Using `libNVVM` _may_ improve GPU performance compared to the code generator-built in to LLVM. One difficulty with using it however is that since `libNVVM`-is also based on LLVM, and typically lags LLVM by several releases, you must-install `accelerate-llvm` with a "compatible" version of LLVM, which will depend-on the version of the CUDA toolkit you have installed. The following table shows-some combinations:+## Windows -|              | LLVM-3.3 | LLVM-3.4 | LLVM-3.5 | LLVM-3.8 | LLVM-3.9 | LLVM-4.0 |-|:------------:|:--------:|:--------:|:--------:|:--------:|:--------:|:--------:|-| **CUDA-7.0** |     ⭕    |     ❌    |          |          |          |          |-| **CUDA-7.5** |          |     ⭕    |     ⭕    |     ❌    |          |          |-| **CUDA-8.0** |          |          |     ⭕    |     ⭕    |     ❌    |     ❌    |+We recommend WSL2 (not WSL1, WSL2!) and following the Ubuntu instructions+above. The remainder of this text attemps to give you a working system on+Windows native. -Where ⭕ = Works, and ❌ = Does not work.+Install `clang`; you have two options:+1. Using+   [WinGet](https://learn.microsoft.com/en-us/windows/package-manager/winget/):+   `winget install LLVM.LLVM`+2. By downloading the installer directly (WinGet just runs the same installer)+   from [here](https://github.com/llvm/llvm-project/releases) (choose+   "LLVM-&lt;version>-win64.exe" from the latest release; you may need to click+   "Show all 57 assets").+This will also give you `libFFI`. -Note that the above restrictions on CUDA and LLVM version exist _only_ if you-want to use the NVVM component. Otherwise, you should be free to use any-combination of CUDA and LLVM.+<details><summary>Optionally, add <code>clang</code> (and more) to your system path. Click to see how.</summary> -Also note that `accelerate-llvm-ptx` itself currently requires at least LLVM-3.5.+Accelerate should be able to find `clang` automatically even if you do not do+this. However, for easy access to `clang` and all other LLVM executables, add+`C:\Program Files\LLVM\bin` to the system path as follows:+1. Search for "environment variables" in the start menu+2. Click "Edit the system environment variables"+3. Click on "Environment Variables..."+4. Double-click on the user variable called "Path"+5. And add a new entry containing `C:\Program Files\LLVM\bin`. -Using `stack`, either edit the `stack.yaml` and add the following section:+Note that if you add an entry here manually, it is a good idea to clean it up+again if you uninstall LLVM/clang. (Leaving it there is not very harmful,+however.) -```yaml-flags:-  accelerate-llvm-ptx:-    nvvm: true-```+You may find that the LLVM/clang installer has already added the Path entry+automatically (it did not for us); if so, no need to add a second entry. -Or install using the following option on the command line:+&mdash;&mdash;+</details> -```sh-$ stack install accelerate-llvm-ptx --flag accelerate-llvm-ptx:nvvm-```+You may additionally need the VS Build Tools, if you have not yet installed and+set up Visual Studio otherwise. You need this if `clang` complains that it is+`unable to find a Visual Studio installation; try running Clang from a developer command prompt`. -If installing via `cabal`:+1. If you already have the Visual Studio Installer on your system, open it and+   check if you already have Visual Studio (Community) installed. Note that+   this is completely unrelated to VS _Code_.+   - If you already have VS (Community): inside the Visual Studio Installer,+     click on "Modify" in the VS (Community) box. This should get you a screen+     with "workloads" you can select.+   - If you do not yet have VS (Community), install the VS Build Tools: go to+     https://visualstudio.microsoft.com/downloads, scroll down to "All+     Downloads", open "Tools for Visual Studio", and select "Build Tools for+     Visual Studio". If you run the installer, you should get a screen with+     "workloads" you can select.+2. Under the Workloads tab, choose the "Desktop development with C++" workload.+   If you want to save a bit of disk space (not much), keep only the following+   two options selected:+   - "MSVC v143 - VE 2022 C++ x64/x86 build tools (Latest)"+   - "Windows 11 SDK (…)" (choose the latest option). The attentive reader may+     note that the wizard also offers Clang; we recommend a separate Clang+     install for Accelerate because the one from VS somehow doesn’t seem to+     work properly with Accelerate. If you find out why, please let us know.+3. Install that. This takes a while. -```sh-$ cabal install accelerate-llvm-ptx -fnvvm-```+It turns out that having both Visual Studio and the Build Tools installed+results in Clang getting confused between the two (it appears that Visual+Studio is 64-bit (x64) and the Build Tools are 32-bit (x86)). If Clang+complains about the bit-ness of your system libraries, double-check that you+haven’t installed both simultaneously. +The GPU backend (`accelerate-llvm-ptx`) probably doesn't work on Windows; in+any case, it is untested.
Setup.hs view
@@ -1,2 +1,128 @@+{-# LANGUAGE CPP       #-}+{-# LANGUAGE DataKinds #-}++module Main where++import Distribution.PackageDescription+import Distribution.PackageDescription.PrettyPrint import Distribution.Simple-main = defaultMain+import Distribution.Simple.BuildPaths+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.PackageIndex+import Distribution.Simple.Setup                                    as Setup+import Distribution.Verbosity+import qualified Distribution.InstalledPackageInfo                  as Installed++#if MIN_VERSION_Cabal(3,8,0)+import Distribution.Simple.PackageDescription+#elif MIN_VERSION_Cabal(2,2,0)+import Distribution.PackageDescription.Parsec+#else+import Distribution.PackageDescription.Parse+#endif+#if MIN_VERSION_Cabal(3,14,0)+-- Note [Cabal 3.14]+--+-- If you change any path stuff, either test that the package still works with+-- Cabal 3.12 or stop declaring support for it in cuda.cabal. (If you do the+-- latter, also remove all of the other conditionals in this file.)+-- Note that supporting old versions of Cabal is useful for being able to run+-- e.g. Accelerate on old GPU clusters, which is nice.+import Distribution.Utils.Path (SymbolicPath, FileOrDir(File, Dir), Lib, Include, Pkg, CWD, makeSymbolicPath)+import qualified Distribution.Types.LocalBuildConfig as LBC+#endif++import System.FilePath+++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+  { postConf    = postConfHook+  , preBuild    = readHook buildVerbosity workingDirFlag+  , preRepl     = readHook replVerbosity workingDirFlag+  , preCopy     = readHook copyVerbosity workingDirFlag+  , preInst     = readHook installVerbosity workingDirFlag+  , preHscolour = readHook hscolourVerbosity workingDirFlag+  , preHaddock  = readHook haddockVerbosity workingDirFlag+  , preReg      = readHook regVerbosity workingDirFlag+  , preUnreg    = readHook regVerbosity workingDirFlag+  }+  where+    readHook :: (a -> Setup.Flag Verbosity) -> (a -> Setup.Flag CWDPath) -> Args -> a -> IO HookedBuildInfo+    readHook verbosity cwd _ flags = readHookedBuildInfoWithCWD (fromFlag (verbosity flags)) (flagToMaybe (cwd flags)) (makeSymbolicPath buildinfo_file)++    postConfHook :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ()+    postConfHook args flags pkg_desc lbi = do+      let accelerate_pkg     = case searchByName (installedPkgs lbi) "accelerate" of+                                 Unambiguous [x] -> x+                                 _               -> error "accelerate package was not found or is ambiguous"++          dyld_library_name  = mkSharedLibName (hostPlatform lbi) (compilerId (compiler lbi)) (installedUnitId accelerate_pkg)+          dyld_install_dir:_ = case Installed.libraryDynDirs accelerate_pkg of+                                 [] -> Installed.libraryDirs accelerate_pkg+                                 ds -> ds++          buildinfo        = emptyBuildInfo { cppOptions = [ "-DACCELERATE_DYLD_LIBRARY_PATH=" ++ quote (dyld_install_dir </> dyld_library_name) ] }+          hooked_buildinfo = (Just buildinfo, [])+          pkg_desc'        = updatePackageDescription hooked_buildinfo pkg_desc+++      writeHookedBuildInfo buildinfo_file hooked_buildinfo+      postConf simpleUserHooks args flags pkg_desc' lbi++buildinfo_file :: FilePath+buildinfo_file = "accelerate-llvm-native.buildinfo"++quote :: String -> String+#ifdef mingw32_HOST_OS+quote s = "\"" ++ (s >>= escape) ++ "\""+  where+    escape '\\' = "\\\\"+    escape '"' = "\\\""+    escape c   = [c]+#else+quote = show+#endif+++-- Compatibility across Cabal 3.14 symbolic paths.+-- If we want to drop pre-Cabal-3.14 compatibility at some point, this should all be merged in above.++#if MIN_VERSION_Cabal(3,14,0)+type CWDPath = SymbolicPath CWD ('Dir Pkg)++regVerbosity :: RegisterFlags -> Flag Verbosity+regVerbosity = setupVerbosity . registerCommonFlags++workingDirFlag :: HasCommonFlags flags => flags -> Flag CWDPath+workingDirFlag = setupWorkingDir . getCommonFlags++-- makeSymbolicPath is an actual useful function in Cabal 3.14++class HasCommonFlags flags where getCommonFlags :: flags -> CommonSetupFlags+instance HasCommonFlags BuildFlags where getCommonFlags = buildCommonFlags+instance HasCommonFlags CleanFlags where getCommonFlags = cleanCommonFlags+instance HasCommonFlags ConfigFlags where getCommonFlags = configCommonFlags+instance HasCommonFlags CopyFlags where getCommonFlags = copyCommonFlags+instance HasCommonFlags InstallFlags where getCommonFlags = installCommonFlags+instance HasCommonFlags HscolourFlags where getCommonFlags = hscolourCommonFlags+instance HasCommonFlags HaddockFlags where getCommonFlags = haddockCommonFlags+instance HasCommonFlags RegisterFlags where getCommonFlags = registerCommonFlags+instance HasCommonFlags ReplFlags where getCommonFlags = replCommonFlags++readHookedBuildInfoWithCWD :: Verbosity -> Maybe CWDPath -> SymbolicPath Pkg 'File -> IO HookedBuildInfo+readHookedBuildInfoWithCWD = readHookedBuildInfo+#else+type CWDPath = ()++-- regVerbosity is still present as an actual field in Cabal 3.12++workingDirFlag :: flags -> Flag CWDPath+workingDirFlag _ = NoFlag++makeSymbolicPath :: FilePath -> FilePath+makeSymbolicPath = id++readHookedBuildInfoWithCWD :: Verbosity -> Maybe CWDPath -> FilePath -> IO HookedBuildInfo+readHookedBuildInfoWithCWD verb _ path = readHookedBuildInfo verb path+#endif
+ SetupHooks.hs view
@@ -0,0 +1,29 @@+module SetupHooks where++import Distribution.Simple.SetupHooks++setupHooks :: SetupHooks+setupHooks =+  noSetupHooks+    { configureHooks = noConfigureHooks { preConfPackageHook = Just hook } }+  where+    hook :: PreConfPackageInputs -> IO PreConfPackageOutputs+    hook inputs = _++    -- postConfHook args flags pkg_desc lbi = do+    --   let accelerate_pkg     = case searchByName (installedPkgs lbi) "accelerate" of+    --                              Unambiguous [x] -> x+    --                              _               -> error "accelerate package was not found or is ambiguous"++    --       dyld_library_name  = mkSharedLibName (hostPlatform lbi) (compilerId (compiler lbi)) (installedUnitId accelerate_pkg)+    --       dyld_install_dir:_ = case Installed.libraryDynDirs accelerate_pkg of+    --                              [] -> Installed.libraryDirs accelerate_pkg+    --                              ds -> ds++    --       buildinfo        = emptyBuildInfo { cppOptions = [ "-DACCELERATE_DYLD_LIBRARY_PATH=" ++ quote (dyld_install_dir </> dyld_library_name) ] }+    --       hooked_buildinfo = (Just buildinfo, [])+    --       pkg_desc'        = updatePackageDescription hooked_buildinfo pkg_desc+++    --   writeHookedBuildInfo buildinfo_file hooked_buildinfo+    --   postConf simpleUserHooks args flags pkg_desc' lbi
accelerate-llvm-native.cabal view
@@ -1,101 +1,43 @@+cabal-version:          2.2+ name:                   accelerate-llvm-native-version:                1.1.0.1-cabal-version:          >= 1.10-tested-with:            GHC >= 7.10-build-type:             Simple+version:                1.4.0.0+tested-with:            GHC >= 9.4+build-type:             Custom  synopsis:               Accelerate backend for multicore CPUs description:     This library implements a backend for the /Accelerate/ language which-    generates LLVM-IR targeting multicore CPUs. For further information, refer+    generates LLVM IR targeting multicore CPUs. For further information, refer     to the main <http://hackage.haskell.org/package/accelerate accelerate>     package.     .     [/Dependencies/]     .     Haskell dependencies are available from Hackage. The following external-    libraries are alse required:-    .-      * <http://llvm.org LLVM>-    .-      * <http://sourceware.org/libffi/ libFFI>-    .-    [/Installing LLVM/]-    .-    /Homebrew/-    .-    Example using Homebrew on macOS:-    .-    > brew install llvm-hs/homebrew-llvm/llvm-5.0-    .-    /Debian & Ubuntu/-    .-    For Debian/Ubuntu based Linux distributions, the LLVM.org website provides-    binary distribution packages. Check <http://apt.llvm.org apt.llvm.org> for-    instructions for adding the correct package database for your OS version,-    and then:-    .-    > apt-get install llvm-5.0-dev-    .-    /Building from source/-    .-    If your OS does not have an appropriate LLVM distribution available, you can-    also build from source. Detailed build instructions are available on-    <http://releases.llvm.org/5.0.0/docs/CMake.html LLVM.org>. Make sure to-    include the cmake build options-    @-DLLVM_BUILD_LLVM_DYLIB=ON -DLLVM_LINK_LLVM_DYLIB=ON@ so that the @libLLVM@-    shared library will be built.-    .-    [/Installing accelerate-llvm/]-    .-    To use @accelerate-llvm@ it is important that the @llvm-hs@ package is-    installed against the @libLLVM@ shared library, rather than statically-    linked, so that we can use LLVM from GHCi and Template Haskell. This is the-    default configuration, but you can also enforce this explicitly by adding-    the following to your @stack.yaml@ file:-    .-    > flags:-    >   llvm-hs:-    >     shared-llvm: true-    .-    Or by specifying the @shared-llvm@ flag to cabal:+    dependencies are also required:     .-    > cabal install llvm-hs -fshared-llvm+    * <https://clang.llvm.org/ clang> (not used to compile C code, but to compile generated LLVM IR via a mostly LLVM-version-independent interface)+    * <https://sourceware.org/libffi/ libFFI>     .+    For installation instructions, see the <https://github.com/AccelerateHS/accelerate-llvm#readme README>. -license:                BSD3+license:                BSD-3-Clause license-file:           LICENSE author:                 Trevor L. McDonell-maintainer:             Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+maintainer:             Trevor L. McDonell <trevor.mcdonell@gmail.com> bug-reports:            https://github.com/AccelerateHS/accelerate/issues-category:               Compilers/Interpreters, Concurrency, Data, Parallelism+category:               Accelerate, Compilers/Interpreters, Concurrency, Data, Parallelism -extra-source-files:+extra-doc-files:     CHANGELOG.md     README.md ---- Configuration flags--- ---------------------Flag debug-  Default:              False-  Description:-    Enable debug tracing message flags. Note that 'debug' must be enabled in the-    base 'accelerate' package as well. See the 'accelerate' package for usage-    and available options.--Flag bounds-checks-  Default:              True-  Description:          Enable bounds checking--Flag unsafe-checks-  Default:              False-  Description:          Enable bounds checking in unsafe operations--Flag internal-checks-  Default:              False-  Description:          Enable internal consistency checks+custom-setup+  setup-depends:+      base              >= 4.10 && < 5+    , Cabal             >= 2 && < 3.18+    , filepath   -- Build configuration@@ -106,12 +48,10 @@     Data.Array.Accelerate.LLVM.Native     Data.Array.Accelerate.LLVM.Native.Plugin     Data.Array.Accelerate.LLVM.Native.Foreign-    Data.Array.Accelerate.LLVM.Native.Distribution.Simple    other-modules:     Data.Array.Accelerate.LLVM.Native.Array.Data     Data.Array.Accelerate.LLVM.Native.Debug-    Data.Array.Accelerate.LLVM.Native.Execute     Data.Array.Accelerate.LLVM.Native.State     Data.Array.Accelerate.LLVM.Native.Target @@ -124,107 +64,111 @@     Data.Array.Accelerate.LLVM.Native.CodeGen.Map     Data.Array.Accelerate.LLVM.Native.CodeGen.Permute     Data.Array.Accelerate.LLVM.Native.CodeGen.Scan+    Data.Array.Accelerate.LLVM.Native.CodeGen.Stencil+    Data.Array.Accelerate.LLVM.Native.CodeGen.Transform      Data.Array.Accelerate.LLVM.Native.Compile     Data.Array.Accelerate.LLVM.Native.Compile.Cache-    Data.Array.Accelerate.LLVM.Native.Compile.Optimise      Data.Array.Accelerate.LLVM.Native.Link     Data.Array.Accelerate.LLVM.Native.Link.Cache     Data.Array.Accelerate.LLVM.Native.Link.Object+    Data.Array.Accelerate.LLVM.Native.Link.Runtime      Data.Array.Accelerate.LLVM.Native.Embed +    Data.Array.Accelerate.LLVM.Native.Execute     Data.Array.Accelerate.LLVM.Native.Execute.Async+    Data.Array.Accelerate.LLVM.Native.Execute.Divide     Data.Array.Accelerate.LLVM.Native.Execute.Environment-    Data.Array.Accelerate.LLVM.Native.Execute.LBS     Data.Array.Accelerate.LLVM.Native.Execute.Marshal+    Data.Array.Accelerate.LLVM.Native.Execute.Scheduler      Data.Array.Accelerate.LLVM.Native.Plugin.Annotation     Data.Array.Accelerate.LLVM.Native.Plugin.BuildInfo -    Data.Array.Accelerate.LLVM.Native.Distribution.Simple.Build-    Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC-    Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC.Internal+    Control.Concurrent.Extra      Paths_accelerate_llvm_native +  autogen-modules:+    Paths_accelerate_llvm_native+   build-depends:-          base                          >= 4.7 && < 4.11-        , accelerate                    == 1.1.*-        , accelerate-llvm               == 1.1.*+          base                          >= 4.10 && < 5+        , accelerate                    == 1.4.*+        , accelerate-llvm               == 1.4.*         , bytestring                    >= 0.10.4-        , Cabal                         >= 2.0-        , cereal                        >= 0.4-        , containers                    >= 0.5 && < 0.6+        , containers                    >= 0.5 && < 0.9+        , deepseq                       >= 1.4         , directory                     >= 1.0         , dlist                         >= 0.6-        , fclabels                      >= 2.0         , filepath                      >= 1.0+        , formatting                    >= 7.0         , ghc         , hashable                      >= 1.0         , libffi                        >= 0.1-        , llvm-hs                       >= 4.1 && < 5.1-        , llvm-hs-pure                  >= 4.1 && < 5.1+        -- , llvm-pretty                   >= 0.12+        , lockfree-queue                >= 0.2         , mtl                           >= 2.2.1+          -- only used to render llvm-pretty output+        , pretty+        , process                       >= 1.4.3+          -- TODO: These are only used for lifting ByteStrings. bytestring+          --       0.11.2.0 include its own, better lifting instances. Once+          --       that's stable, we can remove this dependency and bump+          --       bytestring's version bound.+        , th-lift-instances         , template-haskell-        , time                          >= 1.4+        , text                          >= 1.2         , unique--  default-language:-    Haskell2010--  ghc-options:                  -O2 -Wall -fwarn-tabs--  if impl(ghc >= 8.0)-    ghc-options:                -Wmissed-specialisations--  if flag(debug)-    cpp-options:                -DACCELERATE_DEBUG--  if flag(bounds-checks)-    cpp-options:                -DACCELERATE_BOUNDS_CHECKS+        , unordered-containers          >= 0.2+        , vector                        >= 0.11 -  if flag(unsafe-checks)-    cpp-options:                -DACCELERATE_UNSAFE_CHECKS+  hs-source-dirs:+        src -  if flag(internal-checks)-    cpp-options:                -DACCELERATE_INTERNAL_CHECKS+  default-language:+        Haskell2010 -  if os(darwin)-    other-modules:-      Data.Array.Accelerate.LLVM.Native.Link.MachO+  ghc-options:+        -O2+        -Wall+        -fwarn-tabs +  if os(windows)     build-depends:-          bytestring                    >= 0.10-        , cereal                        >= 0.4-        , ghc-prim-        , unix                          >= 2.7-        , vector                        >= 0.11+          Win32+  else+    build-depends:+          unix                          >= 2.7 -    build-tools:-          c2hs                          >= 0.25 -  if os(linux)-    other-modules:-      Data.Array.Accelerate.LLVM.Native.Link.ELF--    build-depends:-          bytestring                    >= 0.10-        , cereal                        >= 0.4-        , ghc-prim-        , unix                          >= 2.7-        , vector                        >= 0.11+test-suite nofib-llvm-native+  type:                 exitcode-stdio-1.0+  hs-source-dirs:       test/nofib+  main-is:              Main.hs+  other-modules:+    Data.Array.Accelerate.LLVM.Native.NoFib.RunQ -    build-tools:-          c2hs                          >= 0.25+  build-depends:+          base                          >= 4.10+        , accelerate+        , accelerate-llvm-native+        , tasty+        , tasty-hunit -  if os(windows)-    other-modules:-      Data.Array.Accelerate.LLVM.Native.Link.COFF+  default-language:+        Haskell2010 -    build-depends:-          bytestring                    >= 0.10+  ghc-options:+        -Wall+        -O2+        -threaded+        -rtsopts+        -with-rtsopts=-A128M+        -with-rtsopts=-n4M+        -with-rtsopts=-N   source-repository head@@ -233,7 +177,7 @@  source-repository this   type:                 git-  tag:                  1.1.0.1-native+  tag:                  v1.4.0.0   location:             https://github.com/AccelerateHS/accelerate-llvm.git  -- vim: nospell
+ src/Control/Concurrent/Extra.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE MagicHash        #-}+{-# LANGUAGE UnliftedFFITypes #-}+{-# OPTIONS_GHC -fobject-code #-}+-- |+-- Module      : Control.Concurrent.Extra+-- Copyright   : [2021] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Control.Concurrent.Extra (++  getThreadId,++) where++import Data.Int+import Foreign.C.Types+import GHC.Conc                                                     ( ThreadId(..) )+import GHC.Exts                                                     ( ThreadId# )+++-- Stolen from GHC.Conc.Sync+--+getThreadId :: ThreadId -> Int32+getThreadId (ThreadId t#) =+  case getThreadId# t# of+    CInt i -> i++foreign import ccall unsafe "rts_getThreadId" getThreadId# :: ThreadId# -> CInt+
+ src/Data/Array/Accelerate/LLVM/Native.hs view
@@ -0,0 +1,441 @@+{-# LANGUAGE BangPatterns         #-}+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE RankNTypes           #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE TypeSynonymInstances #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- This module implements a backend for the /Accelerate/ language targeting+-- multicore CPUs. Expressions are on-line translated into LLVM code, which is+-- just-in-time executed in parallel over the available CPUs. Functions are+-- automatically parallelised over all available cores, unless you set the+-- environment variable 'ACCELERATE_LLVM_NATIVE_THREADS=N', in which case 'N'+-- threads will be used.+--+-- Programs must be compiled with '-threaded', otherwise you will get a "Blocked+-- indefinitely on MVar" error.+--++module Data.Array.Accelerate.LLVM.Native (++  Acc, Arrays,+  Afunction, AfunctionR,++  -- * Synchronous execution+  run, runWith,+  run1, run1With,+  runN, runNWith,+  stream, streamWith,++  -- * Asynchronous execution+  Async,+  wait, poll, cancel,++  runAsync, runAsyncWith,+  run1Async, run1AsyncWith,+  runNAsync, runNAsyncWith,++  -- * Ahead-of-time compilation+  runQ, runQWith,+  runQAsync, runQAsyncWith,++  -- * Execution targets+  Native,+  createTarget,++) where++import Data.Array.Accelerate.AST                                    ( PreOpenAfun(..), arraysR, liftALeftHandSide )+import Data.Array.Accelerate.AST.LeftHandSide+import Data.Array.Accelerate.Async                                  ( Async, async, wait, poll, cancel )+import Data.Array.Accelerate.Representation.Array                   ( liftArraysR )+import Data.Array.Accelerate.Smart                                  ( Acc )+import Data.Array.Accelerate.Sugar.Array                            ( Arrays, toArr, fromArr, ArraysR )+import Data.Array.Accelerate.Trafo+import Data.Array.Accelerate.Trafo.Sharing                          ( Afunction(..), AfunctionRepr(..), afunctionRepr )+import qualified Data.Array.Accelerate.Sugar.Array                  as Sugar++import Data.Array.Accelerate.LLVM.Native.Array.Data                 ( useRemoteAsync )+import Data.Array.Accelerate.LLVM.Native.Compile                    ( CompiledOpenAfun, compileAcc, compileAfun )+import Data.Array.Accelerate.LLVM.Native.Embed                      ( embedOpenAcc )+import Data.Array.Accelerate.LLVM.Native.Execute                    ( executeAcc, executeOpenAcc )+import Data.Array.Accelerate.LLVM.Native.Execute.Async              ( Par, evalPar, getArrays )+import Data.Array.Accelerate.LLVM.Native.Execute.Environment        ( Val, ValR(..), push )+import Data.Array.Accelerate.LLVM.Native.Link                       ( ExecOpenAfun, linkAcc, linkAfun )+import Data.Array.Accelerate.LLVM.Native.State+import Data.Array.Accelerate.LLVM.Native.Target+import Data.Array.Accelerate.LLVM.Native.Debug                      as Debug++import Control.Monad.Trans+import System.IO.Unsafe+import qualified Data.Array.Accelerate.TH.Compat                    as TH+import qualified Language.Haskell.TH.Syntax                         as TH++import GHC.Stack+++-- Accelerate: LLVM backend for multicore CPUs+-- -------------------------------------------++-- | Compile and run a complete embedded array program.+--+-- /NOTE:/ it is recommended to use 'runN' or 'runQ' whenever possible.+--+run :: (Arrays a, HasCallStack) => Acc a -> a+run a = withFrozenCallStack $ runWith defaultTarget a++-- | As 'run', but execute using the specified target (thread gang).+--+runWith :: (Arrays a, HasCallStack) => Native -> Acc a -> a+runWith target a+  = withFrozenCallStack+  $ unsafePerformIO (runWithIO target a)++-- | As 'run', but allow the computation to run asynchronously and return+-- immediately without waiting for the result. The status of the computation can+-- be queried using 'wait', 'poll', and 'cancel'.+--+runAsync :: (Arrays a, HasCallStack) => Acc a -> IO (Async a)+runAsync a+  = withFrozenCallStack+  $ runAsyncWith defaultTarget a++-- | As 'runAsync', but execute using the specified target (thread gang).+--+runAsyncWith :: (Arrays a, HasCallStack) => Native -> Acc a -> IO (Async a)+runAsyncWith target a+  = withFrozenCallStack+  $ async (runWithIO target a)++runWithIO :: (Arrays a, HasCallStack) => Native -> Acc a -> IO a+runWithIO target a = execute+  where+    !acc    = convertAcc a+    execute = do+      dumpGraph acc+      evalNative target $ do+        build <- phase Compile elapsedS (compileAcc acc) >>= dumpStats+        exec  <- phase Link    elapsedS (linkAcc build)+        res   <- phase Execute elapsedP (evalPar (executeAcc exec >>= getArrays (arraysR exec)))+        return $ toArr res+++-- | This is 'runN', specialised to an array program of one argument.+--+run1 :: (Arrays a, Arrays b, HasCallStack) => (Acc a -> Acc b) -> a -> b+run1 = withFrozenCallStack $ run1With defaultTarget++-- | As 'run1', but execute using the specified target (thread gang).+--+run1With :: (Arrays a, Arrays b, HasCallStack) => Native -> (Acc a -> Acc b) -> a -> b+run1With = withFrozenCallStack $ runNWith+++-- | Prepare and execute an embedded array program.+--+-- This function can be used to improve performance in cases where the array+-- program is constant between invocations, because it enables us to bypass+-- front-end conversion stages and move directly to the execution phase. If you+-- have a computation applied repeatedly to different input data, use this,+-- specifying any changing aspects of the computation via the input parameters.+-- If the function is only evaluated once, this is equivalent to 'run'.+--+-- In order to use 'runN' you must express your Accelerate program as a function+-- of array terms:+--+-- > f :: (Arrays a, Arrays b, ... Arrays c) => Acc a -> Acc b -> ... -> Acc c+--+-- This function then returns the compiled version of 'f':+--+-- > runN f :: (Arrays a, Arrays b, ... Arrays c) => a -> b -> ... -> c+--+-- At an example, rather than:+--+-- > step :: Acc (Vector a) -> Acc (Vector b)+-- > step = ...+-- >+-- > simulate :: Vector a -> Vector b+-- > simulate xs = run $ step (use xs)+--+-- Instead write:+--+-- > simulate = runN step+--+-- You can use the debugging options to check whether this is working+-- successfully. For example, running with the @-ddump-phases@ flag should show+-- that the compilation steps only happen once, not on the second and subsequent+-- invocations of 'simulate'. Note that this typically relies on GHC knowing+-- that it can lift out the function returned by 'runN' and reuse it.+--+-- See the programs in the 'accelerate-examples' package for examples.+--+-- See also 'runQ', which compiles the Accelerate program at _Haskell_ compile+-- time, thus eliminating the runtime overhead altogether.+--+runN :: (Afunction f, HasCallStack) => f -> AfunctionR f+runN = withFrozenCallStack $ runNWith defaultTarget++-- | As 'runN', but execute using the specified target (thread gang).+--+runNWith :: forall f. (Afunction f, HasCallStack) => Native -> f -> AfunctionR f+runNWith target f+  = withFrozenCallStack+  $ go (afunctionRepr @f) afun (return Empty)+  where+    !acc  = convertAfun f+    !afun = unsafePerformIO $ do+              dumpGraph acc+              evalNative target $ do+                build <- phase Compile elapsedS (compileAfun acc) >>= dumpStats+                link  <- phase Link    elapsedS (linkAfun build)+                return link++    go :: AfunctionRepr t (AfunctionR t) (ArraysFunctionR t)+       -> ExecOpenAfun Native aenv (ArraysFunctionR t)+       -> Par Native (Val aenv)+       -> AfunctionR t+    go (AfunctionReprLam repr) (Alam lhs l) k = \(arrs :: a) ->+      let k' = do aenv  <- k+                  a     <- useRemoteAsync (Sugar.arraysR @a) $ fromArr arrs+                  return (aenv `push` (lhs, a))+      in go repr l k'+    go AfunctionReprBody (Abody b) k = unsafePerformIO . phase Execute elapsedP . evalNative target . evalPar $ do+      aenv <- k+      res  <- executeOpenAcc b aenv+      arrs <- getArrays (arraysR b) res+      return $ toArr arrs+    go _ _ _ = error "The moon is hanging upside down"+++-- | As 'run1', but execute asynchronously.+--+run1Async :: (Arrays a, Arrays b, HasCallStack) => (Acc a -> Acc b) -> a -> IO (Async b)+run1Async = withFrozenCallStack $ run1AsyncWith defaultTarget++-- | As 'run1Async', but execute using the specified target (thread gang).+--+run1AsyncWith :: (Arrays a, Arrays b, HasCallStack) => Native -> (Acc a -> Acc b) -> a -> IO (Async b)+run1AsyncWith = withFrozenCallStack runNAsyncWith+++-- | As 'runN', but execute asynchronously.+--+runNAsync :: (Afunction f, RunAsync r, ArraysFunctionR f ~ RunAsyncR r, HasCallStack) => f -> r+runNAsync = withFrozenCallStack $ runNAsyncWith defaultTarget++-- | As 'runNWith', but execute asynchronously.+--+runNAsyncWith :: (Afunction f, RunAsync r, ArraysFunctionR f ~ RunAsyncR r, HasCallStack) => Native -> f -> r+runNAsyncWith target f = withFrozenCallStack exec+  where+    !acc  = convertAfun f+    !afun = unsafePerformIO $ do+              dumpGraph acc+              evalNative target $ do+                build <- phase Compile elapsedS (compileAfun acc) >>= dumpStats+                link  <- phase Link    elapsedS (linkAfun build)+                return link+    !exec = runAsync' target afun (return Empty)++class RunAsync f where+  type RunAsyncR f+  runAsync' :: Native -> ExecOpenAfun Native aenv (RunAsyncR f) -> Par Native (Val aenv) -> f++instance (Arrays a, RunAsync b) => RunAsync (a -> b) where+  type RunAsyncR (a -> b) = ArraysR a -> RunAsyncR b+  runAsync' _      Abody{}  _ _    = error "runAsync: function oversaturated"+  runAsync' target (Alam lhs l) k arrs =+    let k' = do aenv  <- k+                a     <- useRemoteAsync (Sugar.arraysR @a) $ fromArr arrs+                return (aenv `push` (lhs, a))+    in runAsync' target l k'++instance Arrays b => RunAsync (IO (Async b)) where+  type RunAsyncR  (IO (Async b)) = ArraysR b+  runAsync' _      Alam{}    _ = error "runAsync: function not fully applied"+  runAsync' target (Abody b) k = async . phase Execute elapsedP . evalNative target . evalPar $ do+    aenv  <- k+    ans   <- executeOpenAcc b aenv+    arrs  <- getArrays (arraysR b) ans+    return $ toArr arrs+++-- | Stream a lazily read list of input arrays through the given program,+-- collecting results as we go.+--+stream :: (Arrays a, Arrays b, HasCallStack) => (Acc a -> Acc b) -> [a] -> [b]+stream = withFrozenCallStack $ streamWith defaultTarget++-- | As 'stream', but execute using the specified target (thread gang).+--+streamWith :: (Arrays a, Arrays b, HasCallStack) => Native -> (Acc a -> Acc b) -> [a] -> [b]+streamWith target f arrs = withFrozenCallStack $ map go arrs+  where+    !go = run1With target f+++-- | Ahead-of-time compilation for an embedded array program.+--+-- This function will generate, compile, and link into the final executable,+-- code to execute the given Accelerate computation /at Haskell compile time/.+-- This eliminates any runtime overhead associated with the other @run*@+-- operations. The generated code will be optimised for the compiling+-- architecture.+--+-- Since the Accelerate program will be generated at Haskell compile time,+-- construction of the Accelerate program, in particular via meta-programming,+-- will be limited to operations available to that phase. Also note that any+-- arrays which are embedded into the program via 'Data.Array.Accelerate.use'+-- will be stored as part of the final executable.+--+-- Usage of this function in your program is similar to that of 'runN'. First,+-- express your Accelerate program as a function of array terms:+--+-- > f :: (Arrays a, Arrays b, ... Arrays c) => Acc a -> Acc b -> ... -> Acc c+--+-- This function then returns a compiled version of @f@ as a Template Haskell+-- splice, to be added into your program at Haskell compile time:+--+-- > {-# LANGUAGE TemplateHaskell #-}+-- >+-- > f' :: a -> b -> ... -> c+-- > f' = $( runQ f )+--+-- Note that at the splice point the usage of @f@ must monomorphic; i.e. the+-- types @a@, @b@ and @c@ must be at some known concrete type.+--+-- See the <https://github.com/tmcdonell/lulesh-accelerate lulesh-accelerate>+-- project for an example.+--+-- [/Note:/]+--+-- It is recommended to use GHC-8.6 or later. Earlier GHC versions can+-- successfully build executables utilising 'runQ', but fail to correctly link+-- libraries containing this function.+--+-- [/Note:/]+--+-- Due to <https://ghc.haskell.org/trac/ghc/ticket/13587 GHC#13587>, this+-- currently must be as an /untyped/ splice.+--+-- The correct type of this function is similar to that of 'runN':+--+-- > runQ :: Afunction f => f -> Q (TExp (AfunctionR f))+--+-- @since 1.1.0.0+--+runQ :: (Afunction f, HasCallStack) => f -> TH.ExpQ+runQ+  = withFrozenCallStack+  $ runQ' [| unsafePerformIO |] [| defaultTarget |]++-- | Ahead-of-time analogue of 'runNWith'. See 'runQ' for more information.+--+-- The correct type of this function is:+--+-- > runQWith :: Afunction f => f -> Q (TExp (Native -> AfunctionR f))+--+-- @since 1.1.0.0+--+runQWith :: (Afunction f, HasCallStack) => f -> TH.ExpQ+runQWith f =+  withFrozenCallStack $ do+    target <- TH.newName "target"+    TH.lamE [TH.varP target] (runQ' [| unsafePerformIO |] (TH.varE target) f)+++-- | Ahead-of-time analogue of 'runNAsync'. See 'runQ' for more information.+--+-- The correct type of this function is:+--+-- > runQAsync :: (Afunction f, RunAsync r, AfunctionR f ~ RunAsyncR r) => f -> Q (TExp r)+--+-- @since 1.1.0.0+--+runQAsync :: (Afunction f, HasCallStack) => f -> TH.ExpQ+runQAsync+  = withFrozenCallStack+  $ runQ' [| async |] [| defaultTarget |]++-- | Ahead-of-time analogue of 'runNAsyncWith'. See 'runQ' for more information.+--+-- The correct type of this function is:+--+-- > runQAsyncWith :: (Afunction f, RunAsync r, AfunctionR f ~ RunAsyncR r) => f -> Q (TExp (Native -> r))+--+-- @since 1.1.0.0+--+runQAsyncWith :: (Afunction f, HasCallStack) => f -> TH.ExpQ+runQAsyncWith f =+  withFrozenCallStack $ do+    target <- TH.newName "target"+    TH.lamE [TH.varP target] (runQ' [| async |] (TH.varE target) f)+++runQ' :: forall f. (Afunction f, HasCallStack) => TH.ExpQ -> TH.ExpQ -> f -> TH.ExpQ+runQ' using target f = do+#if MIN_VERSION_template_haskell(2,13,0)+  -- The plugin ensures that objects are loaded correctly into GHCi+  TH.addCorePlugin "Data.Array.Accelerate.LLVM.Native.Plugin"+#endif++  afun  <- let acc = convertAfun f+            in TH.runIO $ do+                 dumpGraph acc+                 evalNative defaultTarget $+                  phase Compile elapsedS (compileAfun acc) >>= dumpStats++  -- generate a lambda function with the correct number of arguments and+  -- apply directly to the body expression.+  --+  -- XXX: remove use of 'getArrays', 'toArr', and 'fromArr' in the embedded+  -- code; we should be able to generate all bindings directly and assemble+  -- the pieces directly.+  --+  let+      go :: CompiledOpenAfun Native aenv t -> [TH.PatQ] -> [TH.ExpQ] -> [TH.StmtQ] -> TH.ExpQ+      go (Alam lhs l) xs as stmts = do+        x <- TH.newName "x" -- lambda bound variable+        a <- TH.newName "a" -- local array name+        let s = TH.bindS (TH.varP a) [| useRemoteAsync $(TH.unTypeCode $ liftArraysR (lhsToTupR lhs)) (fromArr $(TH.varE x)) |]+        go l (TH.varP x : xs) ([| ($(TH.unTypeCode $ liftALeftHandSide lhs), $(TH.varE a)) |] : as) (s : stmts)++      go (Abody b) xs as stmts = do+        r <- TH.newName "r" -- result+        s <- TH.newName "s"+        let+            aenv  = foldr (\a gamma -> [| $gamma `push` $a |]) [| Empty |] as+            body  = embedOpenAcc defaultTarget b+        --+        TH.lamE (reverse xs)+                [| $using . phase Execute elapsedP . evalNative $target . evalPar $+                      $(TH.doE ( reverse stmts +++                               [ TH.bindS (TH.varP r) [| executeOpenAcc $(TH.unTypeCode body) $aenv |]+                               , TH.bindS (TH.varP s) [| getArrays $(TH.unTypeCode (liftArraysR (arraysR b))) $(TH.varE r) |]+                               , TH.noBindS [| return $ toArr $(TH.varE s) |]+                               ]))+                 |]+  --+  go afun [] [] []+++-- Debugging+-- =========++dumpStats :: MonadIO m => a -> m a+dumpStats x = liftIO dumpSimplStats >> return x+
+ src/Data/Array/Accelerate/LLVM/Native/Array/Data.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE MagicHash           #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Array.Data+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.Array.Data (++  module Data.Array.Accelerate.LLVM.Array.Data,+  cloneArray,++) where++import Data.Array.Accelerate.Array.Data+import Data.Array.Accelerate.Array.Unique+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Elt+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.LLVM.State+import Data.Array.Accelerate.LLVM.Array.Data+import Data.Array.Accelerate.LLVM.Native.Execute.Async              ()  -- Async Native+import Data.Array.Accelerate.LLVM.Native.Target++import Control.Monad.Trans+import Foreign.Ptr+++-- | Data instance for arrays in the native backend. We assume a shared-memory+-- machine, and just manipulate the underlying Haskell array directly.+--+instance Remote Native where+  {-# INLINE allocateRemote #-}+  allocateRemote repr = liftIO . allocateArray repr+++-- | Copy an array into a newly allocated array. This uses 'memcpy'.+--+cloneArray :: ArrayR (Array sh e) -> Array sh e -> LLVM Native (Array sh e)+cloneArray repr (Array sh src) = liftIO $ do+  out@(Array _ dst) <- allocateArray repr sh+  copyR (arrayRtype repr) src dst+  return out+  where+    n = size (arrayRshape repr) sh++    copyR :: TypeR e -> ArrayData e -> ArrayData e -> IO ()+    copyR TupRunit          !_          !_          = return ()+    copyR (TupRsingle t)    !ad1        !ad2        = copyPrim t ad1 ad2+    copyR (TupRpair !t !t') (ad1, ad1') (ad2, ad2') = do+      copyR t  ad1  ad2+      copyR t' ad1' ad2'++    copyPrim :: ScalarType e -> ArrayData e -> ArrayData e -> IO ()+    copyPrim !tp !a1 !a2+      | ScalarArrayDict{} <- scalarArrayDict tp = do+      let p1 = unsafeUniqueArrayPtr a1+          p2 = unsafeUniqueArrayPtr a2+      memcpy (castPtr p2) (castPtr p1) (n * bytesElt (TupRsingle tp))+++-- Standard C functions+-- --------------------++memcpy :: Ptr Word8 -> Ptr Word8 -> Int -> IO ()+memcpy p q s = c_memcpy p q (fromIntegral s) >> return ()++foreign import ccall unsafe "string.h memcpy" c_memcpy+    :: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8)+
+ src/Data/Array/Accelerate/LLVM/Native/CodeGen.hs view
@@ -0,0 +1,44 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.CodeGen (++  KernelMetadata(..),++) where++-- accelerate+import Data.Array.Accelerate.LLVM.CodeGen++import Data.Array.Accelerate.LLVM.Native.CodeGen.Base+import Data.Array.Accelerate.LLVM.Native.CodeGen.Fold+import Data.Array.Accelerate.LLVM.Native.CodeGen.FoldSeg+import Data.Array.Accelerate.LLVM.Native.CodeGen.Generate+import Data.Array.Accelerate.LLVM.Native.CodeGen.Map+import Data.Array.Accelerate.LLVM.Native.CodeGen.Permute+import Data.Array.Accelerate.LLVM.Native.CodeGen.Scan+import Data.Array.Accelerate.LLVM.Native.CodeGen.Stencil+import Data.Array.Accelerate.LLVM.Native.CodeGen.Transform+import Data.Array.Accelerate.LLVM.Native.Target+++instance Skeleton Native where+  map         = mkMap+  generate    = mkGenerate+  transform   = mkTransform+  fold        = mkFold+  foldSeg     = mkFoldSeg+  scan        = mkScan+  scan'       = mkScan'+  permute     = mkPermute+  stencil1    = mkStencil1+  stencil2    = mkStencil2+
+ src/Data/Array/Accelerate/LLVM/Native/CodeGen/Base.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE TypeOperators       #-}+{-# OPTIONS_GHC -Wno-orphans     #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen.Base+-- Copyright   : [2015..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.CodeGen.Base+  where++import Data.Array.Accelerate.LLVM.CodeGen.Base+import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.LLVM.CodeGen.Module+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Profile+import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.LLVM.Compile.Cache+import Data.Array.Accelerate.LLVM.Native.Target                     ( Native )+import Data.Array.Accelerate.Representation.Shape++import LLVM.AST.Type.Name+import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty     as LP++import Data.String+import qualified Data.ByteString.Short.Char8                        as S8+++-- | Generate function parameters that will specify the first and last (linear)+-- index of the array this thread should evaluate.+--+gangParam :: ShapeR sh -> (Operands sh, Operands sh, [LP.Typed LP.Ident])+gangParam shr =+  let start = "ix.start"+      end   = "ix.end"+      tp    = shapeType shr+  in+  (local tp start, local tp end, parameter tp start ++ parameter tp end)+++-- -- | The worker ID of the calling thread+-- --+-- gangId :: (Operands Int, [LLVM.Parameter])+-- gangId =+--   let tid = "ix.tid"+--   in (local (TupRsingle scalarTypeInt) tid, [ downcast scalarTypeInt ] )+++-- Global function definitions+-- ---------------------------++data instance KernelMetadata Native = KM_Native ()++-- | Combine kernels into a single program+--+(+++) :: IROpenAcc Native aenv a -> IROpenAcc Native aenv a -> IROpenAcc Native aenv a+IROpenAcc k1 +++ IROpenAcc k2 = IROpenAcc (k1 ++ k2)++-- | Create a single kernel program+--+makeOpenAcc :: UID -> Label -> [LP.Typed LP.Ident] -> CodeGen Native () -> CodeGen Native (IROpenAcc Native aenv a)+makeOpenAcc uid name param kernel = do+  body  <- makeKernel (name <> fromString ('_' : show uid)) param kernel+  return $ IROpenAcc [body]++-- | Create a complete kernel function by running the code generation process+-- specified in the final parameter.+--+makeKernel :: Label -> [LP.Typed LP.Ident] -> CodeGen Native () -> CodeGen Native (Kernel Native aenv a)+makeKernel name@(Label sbs) param kernel = do+  zone <- zone_begin_alloc 0 [] (S8.unpack sbs) [] 0+  _    <- kernel+  _    <- zone_end zone+  return_+  code <- createBlocks+  return  $ Kernel+    { kernelMetadata = KM_Native ()+    , unKernel       = LP.Define+        { LP.defLinkage = Just LP.DLLExport  -- ensure the symbols are visible on Windows+        , LP.defVisibility = Nothing+        , LP.defRetType = LP.PrimType LP.Void+        , LP.defName = labelToPrettyS name+        , LP.defArgs = param+        , LP.defVarArgs = False+        , LP.defAttrs = []+        , LP.defSection = Nothing+        , LP.defGC = Nothing+        , LP.defBody = code+        , LP.defMetadata = mempty+        , LP.defComdat = Nothing+        }+    }+
+ src/Data/Array/Accelerate/LLVM/Native/CodeGen/Fold.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen.Fold+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.CodeGen.Fold+  where++import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic                as A+import Data.Array.Accelerate.LLVM.CodeGen.Array+import Data.Array.Accelerate.LLVM.CodeGen.Base+import Data.Array.Accelerate.LLVM.CodeGen.Constant+import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.CodeGen.Exp+import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.LLVM.Compile.Cache++import Data.Array.Accelerate.LLVM.Native.CodeGen.Base+import Data.Array.Accelerate.LLVM.Native.CodeGen.Generate+import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop+import Data.Array.Accelerate.LLVM.Native.Target                     ( Native )++import Control.Applicative+import Prelude                                                      as P hiding ( length )+++-- Reduce an array along the innermost dimension. The reduction+-- function must be associative to allow for an efficient parallel+-- implementation. When an initial value is given, the input can be+-- empty. The initial element does not need to be a neutral element of+-- the operator. When no initial value is given, the array must be+-- non-empty+--+mkFold+    :: UID+    -> Gamma             aenv+    -> ArrayR (Array sh e)+    -> IRFun2       Native aenv (e -> e -> e)+    -> Maybe (IRExp Native aenv e)+    -> MIRDelayed   Native aenv (Array (sh, Int) e)+    -> CodeGen      Native      (IROpenAcc Native aenv (Array sh e))+mkFold uid aenv aR f z arr =+  (+++) <$> case aR of+              ArrayR ShapeRz eR -> mkFoldAll uid aenv eR f z arr+              _                 -> mkFoldDim uid aenv aR f z arr+        <*> case z of+              Just z' -> mkFoldFill uid aenv aR z'+              Nothing -> return (IROpenAcc [])+++-- Reduce a multidimensional (>1) array along the innermost dimension.+--+-- For simplicity, each element of the output (reduction along the entire length+-- of an innermost-dimension index) is computed by a single thread.+--+mkFoldDim+  :: UID+  -> Gamma aenv+  -> ArrayR (Array sh e)+  -> IRFun2     Native aenv (e -> e -> e)+  -> MIRExp     Native aenv e+  -> MIRDelayed Native aenv (Array (sh, Int) e)+  -> CodeGen    Native      (IROpenAcc Native aenv (Array sh e))+mkFoldDim uid aenv aR@(ArrayR shR eR) combine mseed mdelayed =+  let+      (start, end, paramGang) = gangParam shR+      (arrOut, paramOut)      = mutableArray aR "out"+      (arrIn,  paramIn)       = delayedArray    "in"  mdelayed+      paramEnv                = envParam aenv+      zero                    = liftInt 0+  in+  makeOpenAcc uid "fold" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do++    sz <- indexHead <$> delayedExtent arrIn++    imapNestFromTo shR start end (irArrayShape arrOut) $ \ix i -> do+      r <- case mseed of+             Just seed -> do z <- seed+                             reduceFromTo  eR zero sz (app2 combine) z (app1 (delayedIndex arrIn) . indexCons ix)+             Nothing   ->    reduce1FromTo eR zero sz (app2 combine)   (app1 (delayedIndex arrIn) . indexCons ix)++      writeArray TypeInt arrOut i r+++-- Reduce an array to single element.+--+-- Since reductions consume arrays that have been fused into them,+-- a parallel fold requires two passes. At an example, take vector dot+-- product:+--+-- > dotp xs ys = fold (+) 0 (zipWith (*) xs ys)+--+--   1. The first pass reads in the fused array data, in this case corresponding+--   to the function (\i -> (xs!i) * (ys!i)).+--+--   2. The second pass reads in the manifest array data from the first step and+--   directly reduces the array. This second step should be small and so is+--   usually just done by a single core.+--+-- Note that the first step is split into two kernels, the second of which+-- reads a carry-in value of that thread's partial reduction, so that+-- threads can still participate in work-stealing. These kernels must not+-- be invoked over empty ranges.+--+-- The final step is sequential reduction of the partial results. If this+-- is an exclusive reduction, the seed element is included at this point.+--+mkFoldAll+    :: UID+    -> Gamma aenv                                   -- ^ array environment+    -> TypeR e+    -> IRFun2     Native aenv (e -> e -> e)         -- ^ combination function+    -> MIRExp     Native aenv e                     -- ^ seed element, if this is an exclusive reduction+    -> MIRDelayed Native aenv (Vector e)            -- ^ input data+    -> CodeGen    Native      (IROpenAcc Native aenv (Scalar e))+mkFoldAll uid aenv eR combine mseed mdelayed =+  foldr1 (+++) <$> sequence [ mkFoldAllS  uid aenv eR combine mseed mdelayed+                            , mkFoldAllP1 uid aenv eR combine       mdelayed+                            , mkFoldAllP2 uid aenv eR combine mseed+                            ]+++-- Sequential reduction of an entire array to a single element+--+mkFoldAllS+    :: UID+    -> Gamma aenv                                   -- ^ array environment+    -> TypeR e+    -> IRFun2     Native aenv (e -> e -> e)         -- ^ combination function+    -> MIRExp     Native aenv e                     -- ^ seed element, if this is an exclusive reduction+    -> MIRDelayed Native aenv (Vector e)            -- ^ input data+    -> CodeGen    Native      (IROpenAcc Native aenv (Scalar e))+mkFoldAllS uid aenv eR combine mseed mdelayed  =+  let+      (start, end, paramGang) = gangParam    dim1+      (arrOut, paramOut)      = mutableArray (ArrayR dim0 eR) "out"+      (arrIn,  paramIn)       = delayedArray                  "in" mdelayed+      paramEnv                = envParam aenv+      zero                    = liftInt 0+  in+  makeOpenAcc uid "foldAllS" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do+    r <- case mseed of+           Just seed -> do z <- seed+                           reduceFromTo  eR (indexHead start) (indexHead end) (app2 combine) z (app1 (delayedLinearIndex arrIn))+           Nothing   ->    reduce1FromTo eR (indexHead start) (indexHead end) (app2 combine)   (app1 (delayedLinearIndex arrIn))+    writeArray TypeInt arrOut zero r+++-- Parallel reduction of an entire array to a single element, step 1.+--+-- Threads reduce each stripe of the input into a temporary array, incorporating+-- any fused functions on the way.+--+mkFoldAllP1+    :: UID+    -> Gamma             aenv                       -- ^ array environment+    -> TypeR e+    -> IRFun2     Native aenv (e -> e -> e)         -- ^ combination function+    -> MIRDelayed Native aenv (Vector e)            -- ^ input data+    -> CodeGen    Native      (IROpenAcc Native aenv (Scalar e))+mkFoldAllP1 uid aenv eR combine mdelayed =+  let+      (start, end, paramGang) = gangParam    dim1+      (arrTmp, paramTmp)      = mutableArray (ArrayR dim1 eR) "tmp"+      (arrIn,  paramIn)       = delayedArray                  "in" mdelayed+      piece                   = local     (TupRsingle scalarTypeInt) "ix.piece"+      paramPiece              = parameter (TupRsingle scalarTypeInt) "ix.piece"+      paramEnv                = envParam aenv+  in+  makeOpenAcc uid "foldAllP1" (paramGang ++ paramPiece ++ paramTmp ++ paramIn ++ paramEnv) $ do++    -- A thread reduces a sequential (non-empty) stripe of the input and stores+    -- that value into a temporary array at a specific index. This method thus+    -- supports non-commutative operators because the order of operations+    -- remains left-to-right.+    --+    r <- reduce1FromTo eR (indexHead start) (indexHead end) (app2 combine) (app1 (delayedLinearIndex arrIn))+    writeArray TypeInt arrTmp piece r+++-- Parallel reduction of an entire array to a single element, step 2.+--+-- A single thread reduces the temporary array to a single element.+--+-- During execution, we choose a stripe size in phase 1 so that the temporary is+-- small-ish and thus suitable for sequential reduction. An alternative would be+-- to keep the stripe size constant and, for if the partial reductions array is+-- large, continuing reducing it in parallel.+--+mkFoldAllP2+    :: UID+    -> Gamma          aenv                          -- ^ array environment+    -> TypeR e+    -> IRFun2  Native aenv (e -> e -> e)            -- ^ combination function+    -> MIRExp  Native aenv e                        -- ^ seed element, if this is an exclusive reduction+    -> CodeGen Native      (IROpenAcc Native aenv (Scalar e))+mkFoldAllP2 uid aenv eR combine mseed =+  let+      (start, end, paramGang) = gangParam    dim1+      (arrTmp, paramTmp)      = mutableArray (ArrayR dim1 eR) "tmp"+      (arrOut, paramOut)      = mutableArray (ArrayR dim0 eR) "out"+      paramEnv                = envParam aenv+      zero                    = liftInt 0+  in+  makeOpenAcc uid "foldAllP2" (paramGang ++ paramTmp ++ paramOut ++ paramEnv) $ do+    r <- case mseed of+           Just seed -> do z <- seed+                           reduceFromTo  eR (indexHead start) (indexHead end) (app2 combine) z (readArray TypeInt arrTmp)+           Nothing   ->    reduce1FromTo eR (indexHead start) (indexHead end) (app2 combine)   (readArray TypeInt arrTmp)+    writeArray TypeInt arrOut zero r+++-- Exclusive reductions over empty arrays (of any dimension) fill the lower+-- dimensions with the initial element+--+mkFoldFill+    :: UID+    -> Gamma aenv+    -> ArrayR (Array sh e)+    -> IRExp   Native aenv e+    -> CodeGen Native      (IROpenAcc Native aenv (Array sh e))+mkFoldFill uid aenv aR seed =+  mkGenerate uid aenv aR (IRFun1 (const seed))++-- Reduction loops+-- ---------------++-- Reduction of a (possibly empty) index space.+--+reduceFromTo+    :: TypeR e+    -> Operands Int                                              -- ^ starting index+    -> Operands Int                                              -- ^ final index (exclusive)+    -> (Operands e -> Operands e -> CodeGen Native (Operands e)) -- ^ combination function+    -> Operands e                                                -- ^ initial value+    -> (Operands Int -> CodeGen Native (Operands e))             -- ^ function to retrieve element at index+    -> CodeGen Native (Operands e)+reduceFromTo eR m n f z get =+  iterFromTo eR m n z $ \i acc -> do+    x <- get i+    y <- f acc x+    return y++-- Reduction of an array over a _non-empty_ index space. The array must+-- contain at least one element.+--+reduce1FromTo+    :: TypeR e+    -> Operands Int                                              -- ^ starting index+    -> Operands Int                                              -- ^ final index+    -> (Operands e -> Operands e -> CodeGen Native (Operands e)) -- ^ combination function+    -> (Operands Int -> CodeGen Native (Operands e))             -- ^ function to retrieve element at index+    -> CodeGen Native (Operands e)+reduce1FromTo eR m n f get = do+  z  <- get m+  m1 <- add numType m (ir numType (num numType 1))+  reduceFromTo eR m1 n f z get+
+ src/Data/Array/Accelerate/LLVM/Native/CodeGen/FoldSeg.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE ViewPatterns        #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen.FoldSeg+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.CodeGen.FoldSeg+  where++import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic                as A+import Data.Array.Accelerate.LLVM.CodeGen.Array+import Data.Array.Accelerate.LLVM.CodeGen.Base+import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.CodeGen.Exp+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.LLVM.Compile.Cache++import Data.Array.Accelerate.LLVM.Native.CodeGen.Base+import Data.Array.Accelerate.LLVM.Native.CodeGen.Fold+import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop+import Data.Array.Accelerate.LLVM.Native.Target                     ( Native )++import Control.Monad+import Prelude                                                      as P++{--+-- Segmented reduction where a single processor reduces the entire array. The+-- segments array contains the length of each segment.+--+mkFoldSegS+    :: forall aenv sh i e. (Shape sh, IsIntegral i, Elt i, Elt e)+    => UID+    -> Gamma             aenv+    -> IRFun2     Native aenv (e -> e -> e)+    -> MIRExp     Native aenv e+    -> MIRDelayed Native aenv (Array (sh :. Int) e)+    -> MIRDelayed Native aenv (Segments i)+    -> CodeGen    Native      (IROpenAcc Native aenv (Array (sh :. Int) e))+mkFoldSegS uid aenv combine mseed marr mseg =+  let+      (start, end, paramGang) = gangParam @DIM1+      (arrOut, paramOut)      = mutableArray @(sh:.Int) "out"+      (arrIn,  paramIn)       = delayedArray @(sh:.Int) "in"  marr+      (arrSeg, paramSeg)      = delayedArray @DIM1      "seg" mseg+      paramEnv                = envParam aenv+  in+  makeOpenAcc uid "foldSegS" (paramGang ++ paramOut ++ paramIn ++ paramSeg ++ paramEnv) $ do++    -- Number of segments, useful only if reducing DIM2 and higher+    ss <- indexHead <$> delayedExtent arrSeg++    let test si = A.lt singleType (A.fst si) (indexHead end)+        initial = A.pair (indexHead start) (lift 0)++        body :: IR (Int,Int) -> CodeGen Native (IR (Int,Int))+        body (A.unpair -> (s,inf)) = do+          -- We can avoid an extra division if this is a DIM1 array. Higher+          -- dimensional reductions need to wrap around the segment array at+          -- each new lower-dimensional index.+          s'  <- case rank @sh of+                   0 -> return s+                   _ -> A.rem integralType s ss++          len <- A.fromIntegral integralType numType =<< app1 (delayedLinearIndex arrSeg) s'+          sup <- A.add numType inf len++          r   <- case mseed of+                   Just seed -> do z <- seed+                                   reduceFromTo  inf sup (app2 combine) z (app1 (delayedLinearIndex arrIn))+                   Nothing   ->    reduce1FromTo inf sup (app2 combine)   (app1 (delayedLinearIndex arrIn))+          writeArray arrOut s r++          t <- A.add numType s (lift 1)+          return $ A.pair t sup++    void $ while test body initial+    return_+--}+++-- Segmented reduction along the innermost dimension of an array. Performs one+-- reduction per segment of the source array. When no seed is given, assumes+-- that /all/ segments are non-empty.+--+-- This implementation assumes that the segments array represents the offset+-- indices to the source array, rather than the lengths of each segment. The+-- segment-offset approach is required for parallel implementations.+--+mkFoldSeg+    :: UID+    -> Gamma             aenv+    -> ArrayR (Array (sh, Int) e)+    -> IntegralType i+    -> IRFun2     Native aenv (e -> e -> e)+    -> MIRExp     Native aenv e+    -> MIRDelayed Native aenv (Array (sh, Int) e)+    -> MIRDelayed Native aenv (Segments i)+    -> CodeGen    Native      (IROpenAcc Native aenv (Array (sh, Int) e))+mkFoldSeg uid aenv aR@(ArrayR shR eR) int combine mseed marr mseg =+  let+      (start, end, paramGang) = gangParam shR+      (arrOut, paramOut)      = mutableArray aR "out"+      (arrIn,  paramIn)       = delayedArray    "in"  marr+      (arrSeg, paramSeg)      = delayedArray    "seg" mseg+      paramEnv                = envParam aenv+  in+  makeOpenAcc uid "foldSegP" (paramGang ++ paramOut ++ paramIn ++ paramSeg ++ paramEnv) $ do++    imapNestFromTo shR start end (irArrayShape arrOut) $ \ix ii -> do++      -- Determine the start and end indices of the innermost portion of+      -- the array to reduce. This is a segment-offset array computed by+      -- 'scanl (+) 0' of the segment length array.+      --+      let iz = indexTail ix+          i  = indexHead ix+      --+      j <- A.add numType i (liftInt 1)+      u <- A.fromIntegral int numType =<< app1 (delayedLinearIndex arrSeg) i+      v <- A.fromIntegral int numType =<< app1 (delayedLinearIndex arrSeg) j++      r <- case mseed of+             Just seed -> do z <- seed+                             reduceFromTo  eR u v (app2 combine) z (app1 (delayedIndex arrIn) . indexCons iz)+             Nothing   ->    reduce1FromTo eR u v (app2 combine)   (app1 (delayedIndex arrIn) . indexCons iz)++      writeArray TypeInt arrOut ii r+
+ src/Data/Array/Accelerate/LLVM/Native/CodeGen/Generate.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen.Generate+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.CodeGen.Generate+  where++import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.LLVM.CodeGen.Array+import Data.Array.Accelerate.LLVM.CodeGen.Base+import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.LLVM.Compile.Cache++import Data.Array.Accelerate.LLVM.Native.Target                     ( Native )+import Data.Array.Accelerate.LLVM.Native.CodeGen.Base+import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop+++-- Construct a new array by applying a function to each index. Each thread+-- processes multiple adjacent elements.+--+mkGenerate+    :: UID+    -> Gamma aenv+    -> ArrayR (Array sh e)+    -> IRFun1  Native aenv (sh -> e)+    -> CodeGen Native      (IROpenAcc Native aenv (Array sh e))+mkGenerate uid aenv repr apply =+  let+      (start, end, paramGang)   = gangParam (arrayRshape repr)+      (arrOut, paramOut)        = mutableArray repr "out"+      paramEnv                  = envParam aenv+      shOut                     = irArrayShape arrOut+  in+  makeOpenAcc uid "generate" (paramGang ++ paramOut ++ paramEnv) $ do++    imapNestFromTo (arrayRshape repr) start end shOut $ \ix i -> do+      r <- app1 apply ix                        -- apply generator function+      writeArray TypeInt arrOut i r             -- store result+
+ src/Data/Array/Accelerate/LLVM/Native/CodeGen/Loop.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TypeApplications    #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.CodeGen.Native.Loop+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.CodeGen.Loop+  where++-- accelerate+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Representation.Shape++import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic+import Data.Array.Accelerate.LLVM.CodeGen.Exp+import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import qualified Data.Array.Accelerate.LLVM.CodeGen.Loop            as Loop++import Data.Array.Accelerate.LLVM.Native.Target                     ( Native )+++-- | A standard 'for' loop, that steps from the start to end index executing the+-- given function at each index.+--+imapFromTo+    :: Operands Int                                   -- ^ starting index (inclusive)+    -> Operands Int                                   -- ^ final index (exclusive)+    -> (Operands Int -> CodeGen Native ())            -- ^ apply at each index+    -> CodeGen Native ()+imapFromTo start end body =+  Loop.imapFromStepTo start (liftInt 1) end body+++-- | Generate a series of nested 'for' loops which iterate between the start and+-- end indices of a given hyper-rectangle. LLVM is very good at vectorising+-- these kinds of nested loops, but not so good at vectorising the flattened+-- representation utilising to/from index.+--+imapNestFromTo+    :: ShapeR sh+    -> Operands sh                                          -- ^ initial index (inclusive)+    -> Operands sh                                          -- ^ final index (exclusive)+    -> Operands sh                                          -- ^ total array extent+    -> (Operands sh -> Operands Int -> CodeGen Native ())   -- ^ apply at each index+    -> CodeGen Native ()+imapNestFromTo shr start end extent body =+  go shr start end body'+  where+    body' ix = body ix =<< intOfIndex shr extent ix++    go :: ShapeR t -> Operands t -> Operands t -> (Operands t -> CodeGen Native ()) -> CodeGen Native ()+    go ShapeRz OP_Unit OP_Unit k+      = k OP_Unit++    go (ShapeRsnoc shr') (OP_Pair ssh ssz) (OP_Pair esh esz) k+      = go shr' ssh esh+      $ \sz      -> imapFromTo ssz esz+      $ \i       -> k (OP_Pair sz i)+++{--+-- TLM: this version (seems to) compute the corresponding linear index as it+--      goes. We need to compare it against the above implementation to see if+--      there are any advantages.+--+imapNestFromTo'+    :: forall sh. Shape sh+    => Operands sh+    -> Operands sh+    -> Operands sh+    -> (Operands sh -> Operands Int -> CodeGen Native ())+    -> CodeGen Native ()+imapNestFromTo' start end extent body = do+  startl <- intOfIndex extent start+  void $ go (eltType @sh) start end extent (int 1) startl body'+  where+    body' :: Operands (EltRepr sh) -> Operands Int -> CodeGen Native (Operands Int)+    body' ix l = body ix l >> add numType (int 1) l++    go :: TupleType t+       -> Operands t+       -> Operands t+       -> Operands t+       -> Operands Int+       -> Operands Int+       -> (Operands t -> Operands Int -> CodeGen Native (Operands Int))+       -> CodeGen Native (Operands Int)+    go TypeRunit OP_Unit OP_Unit OP_Unit _delta l k+      = k OP_Unit l++    go (TypeRpair tsh tsz) (OP_Pair ssh ssz) (OP_Pair esh esz) (OP_Pair exh exz) delta l k+      | TypeRscalar t <- tsz+      , Just Refl     <- matchScalarType t (scalarType :: ScalarType Int)+      = do+          delta' <- mul numType delta exz+          go tsh ssh esh exh delta' l $ \sz ll -> do+            Loop.iterFromStepTo ssz (int 1) esz ll $ \i l' ->+              k (OP_Pair sz i) l'+            add numType ll delta'++    go _ _ _ _ _ _ _+      = $internalError "imapNestFromTo'" "expected shape with Int components"+--}++{--+-- | Generate a series of nested 'for' loops which iterate between the start and+-- end indices of a given hyper-rectangle. LLVM is very good at vectorising+-- these kinds of nested loops, but not so good at vectorising the flattened+-- representation utilising to/from index.+--+imapNestFromStepTo+    :: forall sh. Shape sh+    => Operands sh                                    -- ^ initial index (inclusive)+    -> Operands sh                                    -- ^ steps+    -> Operands sh                                    -- ^ final index (exclusive)+    -> Operands sh                                    -- ^ total array extent+    -> (Operands sh -> Operands Int -> CodeGen Native ())   -- ^ apply at each index+    -> CodeGen Native ()+imapNestFromStepTo start steps end extent body =+  go (eltType @sh) start steps end (body' . IR)+  where+    body' ix = body ix =<< intOfIndex extent ix++    go :: TupleType t -> Operands t -> Operands t -> Operands t -> (Operands t -> CodeGen Native ()) -> CodeGen Native ()+    go TypeRunit OP_Unit OP_Unit OP_Unit k+      = k OP_Unit++    go (TypeRpair tsh tsz) (OP_Pair ssh ssz) (OP_Pair sts stz) (OP_Pair esh esz) k+      | TypeRscalar t <- tsz+      , Just Refl     <- matchScalarType t (scalarType :: ScalarType Int)+      = go tsh ssh sts esh+      $ \sz      -> Loop.imapFromStepTo ssz stz esz+      $ \i       -> k (OP_Pair sz i)++    go _ _ _ _ _+      = $internalError "imapNestFromTo" "expected shape with Int components"+--}++-- | Iterate with an accumulator between the start and end index, executing the+-- given function at each.+--+iterFromTo+    :: TypeR a+    -> Operands Int                                       -- ^ starting index (inclusive)+    -> Operands Int                                       -- ^ final index (exclusive)+    -> Operands a                                         -- ^ initial value+    -> (Operands Int -> Operands a -> CodeGen Native (Operands a))    -- ^ apply at each index+    -> CodeGen Native (Operands a)+iterFromTo tp start end seed body =+  Loop.iterFromStepTo tp start (liftInt 1) end seed body+
+ src/Data/Array/Accelerate/LLVM/Native/CodeGen/Map.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen.Map+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.CodeGen.Map+  where++import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.LLVM.CodeGen.Array+import Data.Array.Accelerate.LLVM.CodeGen.Base+import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.CodeGen.Exp+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.LLVM.Compile.Cache++import Data.Array.Accelerate.LLVM.Native.Target                     ( Native )+import Data.Array.Accelerate.LLVM.Native.CodeGen.Base+import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop+++-- C Code+-- ======+--+-- float f(float);+--+-- void map(float* __restrict__ out, const float* __restrict__ in, const int n)+-- {+--     for (int i = 0; i < n; ++i)+--         out[i] = f(in[i]);+--+--     return;+-- }++-- Corresponding LLVM+-- ==================+--+-- define void @map(float* noalias nocapture %out, float* noalias nocapture %in, i32 %n) nounwind uwtable ssp {+--   %1 = icmp sgt i32 %n, 0+--   br i1 %1, label %.lr.ph, label %._crit_edge+--+-- .lr.ph:                                           ; preds = %0, %.lr.ph+--   %indvars.iv = phi i64 [ %indvars.iv.next, %.lr.ph ], [ 0, %0 ]+--   %2 = getelementptr inbounds float* %in, i64 %indvars.iv+--   %3 = load float* %2, align 4+--   %4 = tail call float @apply(float %3) nounwind+--   %5 = getelementptr inbounds float* %out, i64 %indvars.iv+--   store float %4, float* %5, align 4+--   %indvars.iv.next = add i64 %indvars.iv, 1+--   %lftr.wideiv = trunc i64 %indvars.iv.next to i32+--   %exitcond = icmp eq i32 %lftr.wideiv, %n+--   br i1 %exitcond, label %._crit_edge, label %.lr.ph+--+-- ._crit_edge:                                      ; preds = %.lr.ph, %0+--   ret void+-- }+--+-- declare float @apply(float)+--++-- Apply the given unary function to each element of an array.+--+-- The map operation can always treat an array of any dimension in its flat+-- underlying representation, which simplifies code generation.+--+mkMap :: UID+      -> Gamma aenv+      -> ArrayR (Array sh a)+      -> TypeR b+      -> IRFun1  Native aenv (a -> b)+      -> CodeGen Native      (IROpenAcc Native aenv (Array sh b))+mkMap uid aenv (ArrayR shR aR) bR apply =+  let+      (start, end, paramGang)   = gangParam dim1+      (arrIn,  paramIn)         = mutableArray (ArrayR shR aR) "in"+      (arrOut, paramOut)        = mutableArray (ArrayR shR bR) "out"+      paramEnv                  = envParam aenv+  in+  makeOpenAcc uid "map" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do++    imapFromTo (indexHead start) (indexHead end) $ \i -> do+      xs <- readArray TypeInt arrIn i+      ys <- app1 apply xs+      writeArray TypeInt arrOut i ys+
+ src/Data/Array/Accelerate/LLVM/Native/CodeGen/Permute.hs view
@@ -0,0 +1,295 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen.Permute+-- Copyright   : [2016..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.CodeGen.Permute+  where++import Data.Array.Accelerate.AST                                    ( PrimMaybe )+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Type++import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic                as A+import Data.Array.Accelerate.LLVM.CodeGen.Array+import Data.Array.Accelerate.LLVM.CodeGen.Base+import Data.Array.Accelerate.LLVM.CodeGen.Constant+import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.CodeGen.Exp+import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Permute+import Data.Array.Accelerate.LLVM.CodeGen.Ptr+import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.LLVM.Compile.Cache++import Data.Array.Accelerate.LLVM.Native.Target                     ( Native )+import Data.Array.Accelerate.LLVM.Native.CodeGen.Base+import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop++import LLVM.AST.Type.GetElementPtr+import LLVM.AST.Type.Instruction+import LLVM.AST.Type.Instruction.Atomic+import LLVM.AST.Type.Instruction.RMW                                as RMW+import LLVM.AST.Type.Instruction.Volatile+import LLVM.AST.Type.Representation++import Control.Applicative+import Control.Monad                                                ( void )+import Prelude+++-- Forward permutation specified by an indexing mapping. The resulting array is+-- initialised with the given defaults, and any further values that are permuted+-- into the result array are added to the current value using the combination+-- function.+--+-- The combination function must be /associative/ and /commutative/. Elements+-- that are mapped to the magic index 'ignore' are dropped.+--+mkPermute+    :: HasCallStack+    => UID+    -> Gamma               aenv+    -> ArrayR (Array sh e)+    -> ShapeR sh'+    -> IRPermuteFun Native aenv (e -> e -> e)+    -> IRFun1       Native aenv (sh -> PrimMaybe sh')+    -> MIRDelayed   Native aenv (Array sh e)+    -> CodeGen      Native      (IROpenAcc Native aenv (Array sh' e))+mkPermute uid aenv repr shr combine project arr =+  (+++) <$> mkPermuteS uid aenv repr shr combine project arr+        <*> mkPermuteP uid aenv repr shr combine project arr+++-- Forward permutation which does not require locking the output array. This+-- could be because we are executing sequentially with a single thread, or+-- because the default values are unused (e.g. for a filter).+--+-- We could also use this method if we can prove that the mapping function is+-- injective (distinct elements in the domain map to distinct elements in the+-- co-domain).+--+mkPermuteS+    :: UID+    -> Gamma               aenv+    -> ArrayR (Array sh e)+    -> ShapeR sh'+    -> IRPermuteFun Native aenv (e -> e -> e)+    -> IRFun1       Native aenv (sh -> PrimMaybe sh')+    -> MIRDelayed   Native aenv (Array sh e)+    -> CodeGen      Native      (IROpenAcc Native aenv (Array sh' e))+mkPermuteS uid aenv repr shr IRPermuteFun{..} project marr =+  let+      (start, end, paramGang) = gangParam    (arrayRshape repr)+      (arrOut, paramOut)      = mutableArray (reprOut repr shr) "out"+      (arrIn,  paramIn)       = delayedArray "in" marr+      paramEnv                = envParam aenv+  in+  makeOpenAcc uid "permuteS" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do++    sh <- delayedExtent arrIn++    imapNestFromTo (arrayRshape repr) start end sh $ \ix _ -> do++      ix' <- app1 project ix++      when (isJust ix') $ do+        i <- fromJust ix'+        j <- intOfIndex shr (irArrayShape arrOut) i++        -- project element onto the destination array and update+        x <- app1 (delayedIndex arrIn) ix+        y <- readArray TypeInt arrOut j+        r <- app2 combine x y++        writeArray TypeInt arrOut j r+++-- Parallel forward permutation has to take special care because different+-- threads could concurrently try to update the same memory location. Where+-- available we make use of special atomic instructions and other optimisations,+-- but in the general case each element of the output array has a lock which+-- must be obtained by the thread before it can update that memory location.+--+-- TODO: After too many failures to acquire the lock on an element, the thread+-- should back off and try a different element, adding this failed element to+-- a queue or some such.+--+mkPermuteP+    :: HasCallStack+    => UID+    -> Gamma               aenv+    -> ArrayR (Array sh e)+    -> ShapeR sh'+    -> IRPermuteFun Native aenv (e -> e -> e)+    -> IRFun1       Native aenv (sh -> PrimMaybe sh')+    -> MIRDelayed   Native aenv (Array sh e)+    -> CodeGen      Native      (IROpenAcc Native aenv (Array sh' e))+mkPermuteP uid aenv repr shr IRPermuteFun{..} project arr =+  case atomicRMW of+    Nothing       -> mkPermuteP_mutex uid aenv repr shr combine project arr+    Just (rmw, f) -> mkPermuteP_rmw   uid aenv repr shr rmw f   project arr+++-- Parallel forward permutation function which uses atomic instructions to+-- implement lock-free array updates.+--+mkPermuteP_rmw+    :: HasCallStack+    => UID+    -> Gamma aenv+    -> ArrayR (Array sh e)+    -> ShapeR sh'+    -> RMWOperation+    -> IRFun1     Native aenv (e -> e)+    -> IRFun1     Native aenv (sh -> PrimMaybe sh')+    -> MIRDelayed Native aenv (Array sh e)+    -> CodeGen    Native      (IROpenAcc Native aenv (Array sh' e))+mkPermuteP_rmw uid aenv repr shr rmw update project marr =+  let+      (start, end, paramGang) = gangParam    (arrayRshape repr)+      (arrOut, paramOut)      = mutableArray (reprOut repr shr) "out"+      (arrIn,  paramIn)       = delayedArray "in" marr+      paramEnv                = envParam aenv+  in+  makeOpenAcc uid "permuteP_rmw" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do++    sh <- delayedExtent arrIn++    imapNestFromTo (arrayRshape repr) start end sh $ \ix _ -> do++      ix' <- app1 project ix++      when (isJust ix') $ do+        i <- fromJust ix'+        j <- intOfIndex shr (irArrayShape arrOut) i+        x <- app1 (delayedIndex arrIn) ix+        r <- app1 update x++        case rmw of+          Exchange+            -> writeArray TypeInt arrOut j r+          --+          _ | TupRsingle (SingleScalarType s)   <- arrayRtype repr+            , adata                             <- irArrayData arrOut+            -> do+                  addr <- instr' $ GetElementPtr $ GEP1 (SingleScalarType s) (asPtr defaultAddrSpace (op s adata)) (op integralType j)+                  --+                  case s of+                    NumSingleType t             -> void . instr' $ AtomicRMW t NonVolatile rmw addr (op t r) (CrossThread, AcquireRelease)+          --+          _ -> internalError "unexpected transition"+++-- Parallel forward permutation function which uses a spinlock to acquire+-- a mutex before updating the value at that location.+--+mkPermuteP_mutex+    :: UID+    -> Gamma             aenv+    -> ArrayR (Array sh e)+    -> ShapeR sh'+    -> IRFun2     Native aenv (e -> e -> e)+    -> IRFun1     Native aenv (sh -> PrimMaybe sh')+    -> MIRDelayed Native aenv (Array sh e)+    -> CodeGen    Native      (IROpenAcc Native aenv (Array sh' e))+mkPermuteP_mutex uid aenv repr shr combine project marr =+  let+      (start, end, paramGang) = gangParam    (arrayRshape repr)+      (arrOut,  paramOut)     = mutableArray (reprOut repr shr)  "out"+      (arrLock, paramLock)    = mutableArray reprLock "lock"+      (arrIn,   paramIn)      = delayedArray "in" marr+      paramEnv                = envParam aenv+  in+  makeOpenAcc uid "permuteP_mutex" (paramGang ++ paramOut ++ paramLock ++ paramIn ++ paramEnv) $ do++    sh <- delayedExtent arrIn++    imapNestFromTo (arrayRshape repr) start end sh $ \ix _ -> do++      ix' <- app1 project ix++      -- project element onto the destination array and (atomically) update+      when (isJust ix') $ do+        i <- fromJust ix'+        j <- intOfIndex shr (irArrayShape arrOut) i+        x <- app1 (delayedIndex arrIn) ix++        atomically arrLock j $ do+          y <- readArray TypeInt arrOut j+          r <- app2 combine x y+          writeArray TypeInt arrOut j r+++-- Atomically execute the critical section only when the lock at the given array+-- index is obtained. The thread spins waiting for the lock to be released and+-- there is no backoff strategy in case the lock is contended.+--+-- It is important that the thread loops trying to acquire the lock without+-- writing data anything until the lock value changes. Then, because of MESI+-- caching protocols there will be no bus traffic while the CPU waits for the+-- value to change.+--+-- <https://en.wikipedia.org/wiki/Spinlock#Significant_optimizations>+--+atomically+    :: IRArray (Vector Word8)+    -> Operands Int+    -> CodeGen Native a+    -> CodeGen Native a+atomically barriers i action = do+  let+      lock      = integral integralType 1+      unlock    = integral integralType 0+      unlocked  = ir TypeWord8 unlock+  --+  spin <- newBlock "spinlock.entry"+  crit <- newBlock "spinlock.critical-section"+  exit <- newBlock "spinlock.exit"++  addr <- instr' $ GetElementPtr $ GEP1 scalarTypeWord8 (asPtr defaultAddrSpace (op integralType (irArrayData barriers))) (op integralType i)+  _    <- br spin++  -- Atomically (attempt to) set the lock slot to the locked state. If the slot+  -- was unlocked we just acquired it, otherwise the state remains unchanged and+  -- we spin until it becomes available.+  setBlock spin+  old  <- instr $ AtomicRMW numType NonVolatile Exchange addr lock   (CrossThread, Acquire)+  ok   <- A.eq singleType old unlocked+  _    <- cbr ok crit spin++  -- We just acquired the lock; perform the critical section then release the+  -- lock and exit. For ("some") x86 processors, an unlocked MOV instruction+  -- could be used rather than the slower XCHG, due to subtle memory ordering+  -- rules.+  setBlock crit+  r    <- action+  _    <- instr $ AtomicRMW numType NonVolatile Exchange addr unlock (CrossThread, Release)+  _    <- br exit++  setBlock exit+  return r+++-- Helper functions+-- ----------------++reprOut :: ArrayR (Array sh e) -> ShapeR sh' -> ArrayR (Array sh' e)+reprOut (ArrayR _ tp) shr = ArrayR shr tp++reprLock :: ArrayR (Array ((), Int) Word8)+reprLock = ArrayR (ShapeRsnoc ShapeRz) $ TupRsingle scalarTypeWord8+
+ src/Data/Array/Accelerate/LLVM/Native/CodeGen/Scan.hs view
@@ -0,0 +1,698 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE ViewPatterns        #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen.Scan+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.CodeGen.Scan+  where++import Data.Array.Accelerate.AST                                    ( Direction(..) )+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic                as A+import Data.Array.Accelerate.LLVM.CodeGen.Array+import Data.Array.Accelerate.LLVM.CodeGen.Base+import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.CodeGen.Exp+import Data.Array.Accelerate.LLVM.CodeGen.Loop+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.LLVM.Compile.Cache++import Data.Array.Accelerate.LLVM.Native.CodeGen.Base+import Data.Array.Accelerate.LLVM.Native.CodeGen.Generate+import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop+import Data.Array.Accelerate.LLVM.Native.Target                     ( Native )++import Control.Applicative+import Control.Monad+import Data.String                                                  ( fromString )+import Data.Coerce                                                  as Safe+import Prelude                                                      as P+++-- 'Data.List.scanl' or 'Data.List.scanl1' style exclusive scan,+-- but with the restriction that the combination function must be associative+-- to enable efficient parallel implementation.+--+-- > scanl (+) 10 (use $ fromList (Z :. 10) [0..])+-- >+-- > ==> Array (Z :. 11) [10,10,11,13,16,20,25,31,38,46,55]+--+mkScan+    :: UID+    -> Gamma             aenv+    -> ArrayR                   (Array (sh, Int) e)+    -> Direction+    -> IRFun2       Native aenv (e -> e -> e)+    -> Maybe (IRExp Native aenv e)+    -> MIRDelayed   Native aenv (Array (sh, Int) e)+    -> CodeGen      Native      (IROpenAcc Native aenv (Array (sh, Int) e))+mkScan uid aenv aR dir combine seed arr+  = foldr1 (+++) <$> sequence (codeScanS ++ codeScanP ++ codeScanFill)+  where+    codeScanS = [ mkScanS dir uid aenv aR combine seed arr ]+    codeScanP = case aR of+      ArrayR (ShapeRsnoc ShapeRz) eR -> [ mkScanP dir uid aenv eR combine seed arr ]+      _                              -> []+    -- Input can be empty iff a seed is given. We then need to compile a fill kernel+    codeScanFill = case seed of+      Just s  -> [ mkScanFill uid aenv aR s ]+      Nothing -> []++-- Variant of 'scanl' where the final result is returned in a separate array.+--+-- > scanr' (+) 10 (use $ fromList (Z :. 10) [0..])+-- >+-- > ==> ( Array (Z :. 10) [10,10,11,13,16,20,25,31,38,46]+--       , Array Z [55]+--       )+--+mkScan'+    :: UID+    -> Gamma             aenv+    -> ArrayR                 (Array (sh, Int) e)+    -> Direction+    -> IRFun2     Native aenv (e -> e -> e)+    -> IRExp      Native aenv e+    -> MIRDelayed Native aenv (Array (sh, Int) e)+    -> CodeGen    Native      (IROpenAcc Native aenv (Array (sh, Int) e, Array sh e))+mkScan' uid aenv aR dir combine seed arr+  | ArrayR (ShapeRsnoc ShapeRz) eR <- aR+  = foldr1 (+++) <$> sequence [ mkScan'S dir uid aenv aR combine seed arr+                              , mkScan'P dir uid aenv eR combine seed arr+                              , mkScan'Fill uid aenv aR seed+                              ]+  --+  | otherwise+  = (+++) <$> mkScan'S dir uid aenv aR combine seed arr+          <*> mkScan'Fill uid aenv aR seed++-- If the innermost dimension of an exclusive scan is empty, then we just fill+-- the result with the seed element.+--+mkScanFill+    :: UID+    -> Gamma          aenv+    -> ArrayR (Array sh e)+    -> IRExp   Native aenv e+    -> CodeGen Native      (IROpenAcc Native aenv (Array sh e))+mkScanFill uid aenv aR seed =+  mkGenerate uid aenv aR (IRFun1 (const seed))++mkScan'Fill+    :: UID+    -> Gamma          aenv+    -> ArrayR (Array (sh, Int) e)+    -> IRExp   Native aenv e+    -> CodeGen Native     (IROpenAcc Native aenv (Array (sh, Int) e, Array sh e))+mkScan'Fill uid aenv aR seed =+  Safe.coerce <$> mkScanFill uid aenv (reduceRank aR) seed+++-- A single thread sequentially scans along an entire innermost dimension. For+-- inclusive scans we can assume that the innermost-dimension is at least one+-- element.+--+-- Note that we can use this both when there is a single thread, or in parallel+-- where threads are scheduled over the outer dimensions (segments).+--+mkScanS+    :: Direction+    -> UID+    -> Gamma             aenv+    -> ArrayR (Array (sh, Int) e)+    -> IRFun2     Native aenv (e -> e -> e)+    -> MIRExp     Native aenv e+    -> MIRDelayed Native aenv (Array (sh, Int) e)+    -> CodeGen    Native      (IROpenAcc Native aenv (Array (sh, Int) e))+mkScanS dir uid aenv aR combine mseed marr =+  let+      (start, end, paramGang) = gangParam shR+      (arrOut, paramOut)      = mutableArray aR "out"+      (arrIn,  paramIn)       = delayedArray    "in"  marr+      paramEnv                = envParam aenv+      ShapeRsnoc shR          = arrayRshape aR+      --+      next i                  = case dir of+                                  LeftToRight -> A.add numType i (liftInt 1)+                                  RightToLeft -> A.sub numType i (liftInt 1)+  in+  makeOpenAcc uid "scanS" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do++    -- The dimensions of the input and output arrays are (almost) the same+    -- but LLVM can't know that so make it explicit so that we reuse loop+    -- variables and index calculations+    shIn <- delayedExtent arrIn+    let sz    = indexHead shIn+        shOut = case mseed of+                  Nothing -> shIn+                  Just{}  -> indexCons (indexTail shIn) (indexHead (irArrayShape arrOut))++    -- Loop over the outer dimensions+    imapNestFromTo shR start end (indexTail shIn) $ \ix _ -> do++      -- index i* is the index that we will read data from. Recall that the+      -- supremum index is exclusive+      i0 <- case dir of+              LeftToRight -> return (liftInt 0)+              RightToLeft -> A.sub numType sz (liftInt 1)++      -- index j* is the index that we write to. Recall that for exclusive scans+      -- the output array inner dimension is one larger than the input.+      j0 <- case mseed of+              Nothing -> return i0        -- merge 'i' and 'j' indices whenever we can+              Just{}  -> case dir of+                           LeftToRight -> return i0+                           RightToLeft -> return sz++      -- Evaluate or read the initial element. Update the read-from index+      -- appropriately.+      (v0,i1) <- case mseed of+                   Just seed -> (,) <$> seed                                        <*> pure i0+                   Nothing   -> (,) <$> app1 (delayedIndex arrIn) (indexCons ix i0) <*> next i0++      -- Write first element, then continue looping through the rest of+      -- this innermost dimension+      k0 <- intOfIndex (arrayRshape aR) shOut (indexCons ix j0)+      j1 <- next j0+      writeArray TypeInt arrOut k0 v0++      void $ while (TupRunit `TupRpair` TupRsingle scalarTypeInt `TupRpair` TupRsingle scalarTypeInt `TupRpair` arrayRtype aR)+                   (\(A.untrip -> (i,_,_)) -> do+                       case dir of+                         LeftToRight -> A.lt  singleType i sz+                         RightToLeft -> A.gte singleType i (liftInt 0))+                   (\(A.untrip -> (i,j,u)) -> do+                       v <- app1 (delayedIndex arrIn) (indexCons ix i)+                       w <- case dir of+                              LeftToRight -> app2 combine u v+                              RightToLeft -> app2 combine v u+                       k <- intOfIndex (arrayRshape aR) shOut (indexCons ix j)+                       writeArray TypeInt arrOut k w+                       A.trip <$> next i <*> next j <*> pure w)+                   (A.trip i1 j1 v0)+++mkScan'S+    :: Direction+    -> UID+    -> Gamma             aenv+    -> ArrayR (Array (sh, Int) e)+    -> IRFun2     Native aenv (e -> e -> e)+    -> IRExp      Native aenv e+    -> MIRDelayed Native aenv (Array (sh, Int) e)+    -> CodeGen    Native      (IROpenAcc Native aenv (Array (sh, Int) e, Array sh e))+mkScan'S dir uid aenv aR combine seed marr =+  let+      (start, end, paramGang) = gangParam    shR+      (arrOut, paramOut)      = mutableArray aR              "out"+      (arrSum, paramSum)      = mutableArray (reduceRank aR) "sum"+      (arrIn,  paramIn)       = delayedArray "in" marr+      paramEnv                = envParam aenv+      ShapeRsnoc shR          = arrayRshape aR+      --+      next i                  = case dir of+                                  LeftToRight -> A.add numType i (liftInt 1)+                                  RightToLeft -> A.sub numType i (liftInt 1)+  in+  makeOpenAcc uid "scanS" (paramGang ++ paramOut ++ paramSum ++ paramIn ++ paramEnv) $ do++    shIn  <- delayedExtent arrIn+    let sz    = indexHead shIn+        shOut = shIn++    imapNestFromTo shR start end (indexTail shIn) $ \ix ii -> do++      -- index to read data from+      i0 <- case dir of+              LeftToRight -> return (liftInt 0)+              RightToLeft -> A.sub numType sz (liftInt 1)++      -- initial element+      v0 <- seed++      -- Loop through the input. Only at the top of the loop to we write the+      -- carry-in value (i.e. value from the last loop iteration) to the output+      -- array. This ensures correct behaviour if the input array was empty.+      r  <- while (TupRsingle scalarTypeInt `TupRpair` arrayRtype aR)+                  (\(A.unpair -> (i,_)) -> do+                      case dir of+                        LeftToRight -> A.lt  singleType i sz+                        RightToLeft -> A.gte singleType i (liftInt 0))+                  (\(A.unpair -> (i,u)) -> do+                      k <- intOfIndex (arrayRshape aR) shOut (indexCons ix i)+                      writeArray TypeInt arrOut k u++                      v <- app1 (delayedIndex arrIn) (indexCons ix i)+                      w <- case dir of+                             LeftToRight -> app2 combine u v+                             RightToLeft -> app2 combine v u+                      A.pair <$> next i <*> pure w)+                  (A.pair i0 v0)++      writeArray TypeInt arrSum ii (A.snd r)+++mkScanP+    :: Direction+    -> UID+    -> Gamma             aenv+    -> TypeR e+    -> IRFun2     Native aenv (e -> e -> e)+    -> MIRExp     Native aenv e+    -> MIRDelayed Native aenv (Vector e)+    -> CodeGen    Native      (IROpenAcc Native aenv (Vector e))+mkScanP dir uid aenv eR combine mseed marr =+  foldr1 (+++) <$> sequence [ mkScanP1 dir uid aenv eR combine mseed marr+                            , mkScanP2 dir uid aenv eR combine+                            , mkScanP3 dir uid aenv eR combine mseed+                            ]++-- Parallel scan, step 1.+--+-- Threads scan a stripe of the input into a temporary array, incorporating the+-- initial element and any fused functions on the way. The final reduction+-- result of this chunk is written to a separate array.+--+mkScanP1+    :: Direction+    -> UID+    -> Gamma             aenv+    -> TypeR e+    -> IRFun2     Native aenv (e -> e -> e)+    -> MIRExp     Native aenv e+    -> MIRDelayed Native aenv (Vector e)+    -> CodeGen    Native      (IROpenAcc Native aenv (Vector e))+mkScanP1 dir uid aenv eR combine mseed marr =+  let+      (start, end, paramGang) = gangParam    dim1+      (arrOut, paramOut)      = mutableArray (ArrayR dim1 eR) "out"+      (arrTmp, paramTmp)      = mutableArray (ArrayR dim1 eR) "tmp"+      (arrIn,  paramIn)       = delayedArray "in" marr+      paramEnv                = envParam aenv+      --+      steps                   = local     (TupRsingle scalarTypeInt) "ix.steps"+      paramSteps              = parameter (TupRsingle scalarTypeInt) "ix.steps"+      piece                   = local     (TupRsingle scalarTypeInt) "ix.piece"+      paramPiece              = parameter (TupRsingle scalarTypeInt) "ix.piece"+      --+      next i                  = case dir of+                                  LeftToRight -> A.add numType i (liftInt 1)+                                  RightToLeft -> A.sub numType i (liftInt 1)+      firstPiece              = case dir of+                                  LeftToRight -> liftInt 0+                                  RightToLeft -> steps+  in+  makeOpenAcc uid "scanP1" (paramGang ++ paramPiece ++ paramSteps ++ paramOut ++ paramTmp ++ paramIn ++ paramEnv) $ do++    -- A thread scans a non-empty stripe of the input, storing the final+    -- reduction result into a separate array.+    --+    -- For exclusive scans the first chunk must incorporate the initial element+    -- into the input and output, while all other chunks increment their output+    -- index by one.+    --+    -- index i* is the index that we read data from. Recall that the supremum+    -- index is exclusive+    i0  <- case dir of+             LeftToRight -> return (indexHead start)+             RightToLeft -> next (indexHead end)++    -- index j* is the index that we write to. Recall that for exclusive scan+    -- the output array is one larger than the input; the first piece uses+    -- this spot to write the initial element, all other chunks shift by one.+    j0  <- case mseed of+             Nothing -> return i0+             Just _  -> case dir of+                          LeftToRight -> if (TupRsingle scalarTypeInt, A.eq singleType piece firstPiece)+                                         then return i0+                                         else next i0+                          RightToLeft -> if (TupRsingle scalarTypeInt, A.eq singleType piece firstPiece)+                                         then return (indexHead end)+                                         else return i0++    -- Evaluate/read the initial element for this piece. Update the read-from+    -- index appropriately+    (v0,i1) <- A.unpair <$> case mseed of+                 Just seed -> if (eR `TupRpair` TupRsingle scalarTypeInt, A.eq singleType piece firstPiece)+                                then A.pair <$> seed                               <*> pure i0+                                else A.pair <$> app1 (delayedLinearIndex arrIn) i0 <*> next i0+                 Nothing   ->        A.pair <$> app1 (delayedLinearIndex arrIn) i0 <*> next i0++    -- Write first element+    writeArray TypeInt arrOut j0 v0+    j1  <- next j0++    -- Continue looping through the rest of the input+    let cont i =+           case dir of+             LeftToRight -> A.lt  singleType i (indexHead end)+             RightToLeft -> A.gte singleType i (indexHead start)++    r   <- while (TupRunit `TupRpair` TupRsingle scalarTypeInt `TupRpair` TupRsingle scalarTypeInt `TupRpair` eR)+                 (cont . A.fst3)+                 (\(A.untrip -> (i,j,v)) -> do+                     u  <- app1 (delayedLinearIndex arrIn) i+                     v' <- case dir of+                             LeftToRight -> app2 combine v u+                             RightToLeft -> app2 combine u v+                     writeArray TypeInt arrOut j v'+                     A.trip <$> next i <*> next j <*> pure v')+                 (A.trip i1 j1 v0)++    -- Final reduction result of this piece+    writeArray TypeInt arrTmp piece (A.thd3 r)+++-- Parallel scan, step 2.+--+-- A single thread performs an in-place inclusive scan of the partial block+-- sums. This forms the carry-in value which are added to the stripe partial+-- results in the final step.+--+mkScanP2+    :: Direction+    -> UID+    -> Gamma          aenv+    -> TypeR e+    -> IRFun2  Native aenv (e -> e -> e)+    -> CodeGen Native      (IROpenAcc Native aenv (Vector e))+mkScanP2 dir uid aenv eR combine =+  let+      (start, end, paramGang) = gangParam    dim1+      (arrTmp, paramTmp)      = mutableArray (ArrayR dim1 eR) "tmp"+      paramEnv                = envParam aenv+      --+      cont i                  = case dir of+                                  LeftToRight -> A.lt  singleType i (indexHead end)+                                  RightToLeft -> A.gte singleType i (indexHead start)++      next i                  = case dir of+                                  LeftToRight -> A.add numType i (liftInt 1)+                                  RightToLeft -> A.sub numType i (liftInt 1)+  in+  makeOpenAcc uid "scanP2" (paramGang ++ paramTmp ++ paramEnv) $ do++    i0 <- case dir of+            LeftToRight -> return (indexHead start)+            RightToLeft -> next (indexHead end)++    v0 <- readArray TypeInt arrTmp i0+    i1 <- next i0++    void $ while (TupRsingle scalarTypeInt `TupRpair` eR)+                 (cont . A.fst)+                 (\(A.unpair -> (i,v)) -> do+                    u  <- readArray TypeInt arrTmp i+                    i' <- next i+                    v' <- case dir of+                            LeftToRight -> app2 combine v u+                            RightToLeft -> app2 combine u v+                    writeArray TypeInt arrTmp i v'+                    return $ A.pair i' v')+                 (A.pair i1 v0)+++-- Parallel scan, step 3.+--+-- Threads combine every element of the partial block results with the carry-in+-- value computed from step 2.+--+-- Note that first chunk does not need extra processing (has no carry-in value).+--+mkScanP3+    :: Direction+    -> UID+    -> Gamma aenv+    -> TypeR e+    -> IRFun2  Native aenv (e -> e -> e)+    -> MIRExp  Native aenv e+    -> CodeGen Native      (IROpenAcc Native aenv (Vector e))+mkScanP3 dir uid aenv eR combine mseed =+  let+      (start, end, paramGang) = gangParam    dim1+      (arrOut, paramOut)      = mutableArray (ArrayR dim1 eR) "out"+      (arrTmp, paramTmp)      = mutableArray (ArrayR dim1 eR) "tmp"+      paramEnv                = envParam aenv+      --+      steps                   = local     (TupRsingle scalarTypeInt) "ix.steps"+      paramSteps              = parameter (TupRsingle scalarTypeInt) "ix.steps"+      piece                   = local     (TupRsingle scalarTypeInt) "ix.piece"+      paramPiece              = parameter (TupRsingle scalarTypeInt) "ix.piece"+      --+      next i                  = case dir of+                                  LeftToRight -> A.add numType i (liftInt 1)+                                  RightToLeft -> A.sub numType i (liftInt 1)+      prev i                  = case dir of+                                  LeftToRight -> A.sub numType i (liftInt 1)+                                  RightToLeft -> A.add numType i (liftInt 1)+      firstPiece              = case dir of+                                  LeftToRight -> liftInt 0+                                  RightToLeft -> steps+  in+  makeOpenAcc uid "scanP3" (paramGang ++ paramPiece ++ paramSteps ++ paramOut ++ paramTmp ++ paramEnv) $ do++    -- TODO: Don't schedule the "first" piece. In the scheduler this corresponds+    -- to the split range with the smallest/largest linear index for left/right+    -- scans respectively. For right scans this is not necessarily the last piece(?).+    --+    A.when (neq singleType piece firstPiece) $ do++      -- Compute start and end indices, leaving space for the initial element+      (inf,sup) <- case (dir, mseed) of+                     (LeftToRight, Just{}) -> (,) <$> next (indexHead start) <*> next (indexHead end)+                     _                     -> (,) <$> pure (indexHead start) <*> pure (indexHead end)++      -- Read in the carry in value for this piece+      c <- readArray TypeInt arrTmp =<< prev piece++      imapFromTo inf sup $ \i -> do+        x <- readArray TypeInt arrOut i+        y <- case dir of+               LeftToRight -> app2 combine c x+               RightToLeft -> app2 combine x c+        writeArray TypeInt arrOut i y+++mkScan'P+    :: Direction+    -> UID+    -> Gamma             aenv+    -> TypeR e+    -> IRFun2     Native aenv (e -> e -> e)+    -> IRExp      Native aenv e+    -> MIRDelayed Native aenv (Vector e)+    -> CodeGen    Native      (IROpenAcc Native aenv (Vector e, Scalar e))+mkScan'P dir uid aenv eR combine seed arr =+  foldr1 (+++) <$> sequence [ mkScan'P1 dir uid aenv eR combine seed arr+                            , mkScan'P2 dir uid aenv eR combine+                            , mkScan'P3 dir uid aenv eR combine+                            ]++-- Parallel scan', step 1+--+-- Threads scan a stripe of the input into a temporary array. Similar to+-- exclusive scan, the output indices are shifted by one relative to the input+-- indices to make space for the initial element.+--+mkScan'P1+    :: Direction+    -> UID+    -> Gamma             aenv+    -> TypeR e+    -> IRFun2     Native aenv (e -> e -> e)+    -> IRExp      Native aenv e+    -> MIRDelayed Native aenv (Vector e)+    -> CodeGen    Native      (IROpenAcc Native aenv (Vector e, Scalar e))+mkScan'P1 dir uid aenv eR combine seed marr =+  let+      (start, end, paramGang) = gangParam    dim1+      (arrOut, paramOut)      = mutableArray (ArrayR dim1 eR) "out"+      (arrTmp, paramTmp)      = mutableArray (ArrayR dim1 eR) "tmp"+      (arrIn,  paramIn)       = delayedArray "in" marr+      paramEnv                = envParam aenv+      --+      steps                   = local     (TupRsingle scalarTypeInt) "ix.steps"+      paramSteps              = parameter (TupRsingle scalarTypeInt) "ix.steps"+      piece                   = local     (TupRsingle scalarTypeInt) "ix.piece"+      paramPiece              = parameter (TupRsingle scalarTypeInt) "ix.piece"+      --+      next i                  = case dir of+                                  LeftToRight -> A.add numType i (liftInt 1)+                                  RightToLeft -> A.sub numType i (liftInt 1)++      firstPiece              = case dir of+                                  LeftToRight -> liftInt 0+                                  RightToLeft -> steps+  in+  makeOpenAcc uid "scanP1" (paramGang ++ paramPiece ++ paramSteps ++ paramOut ++ paramTmp ++ paramIn ++ paramEnv) $ do++    -- index i* is the index that we pull data from.+    i0 <- case dir of+            LeftToRight -> return (indexHead start)+            RightToLeft -> next (indexHead end)++    -- index j* is the index that we write results to. The first piece needs to+    -- include the initial element, and all other chunks shift their results+    -- across by one to make space.+    j0      <- if (TupRsingle scalarTypeInt, A.eq singleType piece firstPiece)+                 then pure i0+                 else next i0++    -- Evaluate/read the initial element. Update the read-from index+    -- appropriately.+    (v0,i1) <- A.unpair <$> if (eR `TupRpair` TupRsingle scalarTypeInt, A.eq singleType piece firstPiece)+                              then A.pair <$> seed                               <*> pure i0+                              else A.pair <$> app1 (delayedLinearIndex arrIn) i0 <*> pure j0++    -- Write the first element+    writeArray TypeInt arrOut j0 v0+    j1 <- next j0++    -- Continue looping through the rest of the input+    let cont i =+           case dir of+             LeftToRight -> A.lt  singleType i (indexHead end)+             RightToLeft -> A.gte singleType i (indexHead start)++    r  <- while (TupRunit `TupRpair` TupRsingle scalarTypeInt `TupRpair` TupRsingle scalarTypeInt `TupRpair` eR)+                (cont . A.fst3)+                (\(A.untrip-> (i,j,v)) -> do+                    u  <- app1 (delayedLinearIndex arrIn) i+                    v' <- case dir of+                            LeftToRight -> app2 combine v u+                            RightToLeft -> app2 combine u v+                    writeArray TypeInt arrOut j v'+                    A.trip <$> next i <*> next j <*> pure v')+                (A.trip i1 j1 v0)++    -- Write the final reduction result of this piece+    writeArray TypeInt arrTmp piece (A.thd3 r)+++-- Parallel scan', step 2+--+-- Identical to mkScanP2, except we store the total scan result into a separate+-- array (rather than discard it).+--+mkScan'P2+    :: Direction+    -> UID+    -> Gamma          aenv+    -> TypeR e+    -> IRFun2  Native aenv (e -> e -> e)+    -> CodeGen Native      (IROpenAcc Native aenv (Vector e, Scalar e))+mkScan'P2 dir uid aenv eR combine =+  let+      (start, end, paramGang) = gangParam    dim1+      (arrTmp, paramTmp)      = mutableArray (ArrayR dim1 eR) "tmp"+      (arrSum, paramSum)      = mutableArray (ArrayR dim0 eR) "sum"+      paramEnv                = envParam aenv+      --+      cont i                  = case dir of+                                  LeftToRight -> A.lt  singleType i (indexHead end)+                                  RightToLeft -> A.gte singleType i (indexHead start)++      next i                  = case dir of+                                  LeftToRight -> A.add numType i (liftInt 1)+                                  RightToLeft -> A.sub numType i (liftInt 1)+  in+  makeOpenAcc uid "scanP2" (paramGang ++ paramSum ++ paramTmp ++ paramEnv) $ do++    i0 <- case dir of+            LeftToRight -> return (indexHead start)+            RightToLeft -> next (indexHead end)++    v0 <- readArray TypeInt arrTmp i0+    i1 <- next i0++    r  <- while (TupRpair (TupRsingle scalarTypeInt) eR)+                (cont . A.fst)+                (\(A.unpair -> (i,v)) -> do+                   u  <- readArray TypeInt arrTmp i+                   i' <- next i+                   v' <- case dir of+                           LeftToRight -> app2 combine v u+                           RightToLeft -> app2 combine u v+                   writeArray TypeInt arrTmp i v'+                   return $ A.pair i' v')+                (A.pair i1 v0)++    writeArray TypeInt arrSum (liftInt 0) (A.snd r)+++-- Parallel scan', step 3+--+-- Similar to mkScanP3, except that indices are shifted by one since the output+-- array is the same size as the input (despite being an exclusive scan).+--+-- Note that the first chunk does not need to do any extra processing (has no+-- carry-in value).+--+mkScan'P3+    :: Direction+    -> UID+    -> Gamma          aenv+    -> TypeR e+    -> IRFun2  Native aenv (e -> e -> e)+    -> CodeGen Native      (IROpenAcc Native aenv (Vector e, Scalar e))+mkScan'P3 dir uid aenv eR combine =+  let+      (start, end, paramGang) = gangParam    dim1+      (arrOut, paramOut)      = mutableArray (ArrayR dim1 eR) "out"+      (arrTmp, paramTmp)      = mutableArray (ArrayR dim1 eR) "tmp"+      paramEnv                = envParam aenv+      --+      steps                   = local     (TupRsingle scalarTypeInt) "ix.steps"+      paramSteps              = parameter (TupRsingle scalarTypeInt) "ix.steps"+      piece                   = local     (TupRsingle scalarTypeInt) "ix.piece"+      paramPiece              = parameter (TupRsingle scalarTypeInt) "ix.piece"+      --+      next i                  = case dir of+                                  LeftToRight -> A.add numType i (liftInt 1)+                                  RightToLeft -> A.sub numType i (liftInt 1)+      prev i                  = case dir of+                                  LeftToRight -> A.sub numType i (liftInt 1)+                                  RightToLeft -> A.add numType i (liftInt 1)+      firstPiece              = case dir of+                                  LeftToRight -> liftInt 0+                                  RightToLeft -> steps+  in+  makeOpenAcc uid "scanP3" (paramGang ++ paramPiece ++ paramSteps ++ paramOut ++ paramTmp ++ paramEnv) $ do++    -- TODO: don't schedule the "first" piece.+    --+    A.when (neq singleType piece firstPiece) $ do++      -- Compute start and end indices, leaving space for the initial element+      inf <- next (indexHead start)+      sup <- next (indexHead end)++      -- Read the carry-in value for this piece+      c   <- readArray TypeInt arrTmp =<< prev piece++      -- Apply the carry-in value to all elements of the output+      imapFromTo inf sup $ \i -> do+        x <- readArray TypeInt arrOut i+        y <- case dir of+               LeftToRight -> app2 combine c x+               RightToLeft -> app2 combine x c+        writeArray TypeInt arrOut i y+
+ src/Data/Array/Accelerate/LLVM/Native/CodeGen/Stencil.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TypeApplications    #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen.Stencil+-- Copyright   : [2018..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.CodeGen.Stencil (++  mkStencil1,+  mkStencil2,++) where++import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Stencil+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic+import Data.Array.Accelerate.LLVM.CodeGen.Array+import Data.Array.Accelerate.LLVM.CodeGen.Base+import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.CodeGen.Exp+import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.LLVM.CodeGen.Loop                      hiding ( imapFromStepTo )+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Stencil+import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.LLVM.Compile.Cache++import Data.Array.Accelerate.LLVM.Native.CodeGen.Base+import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop+import Data.Array.Accelerate.LLVM.Native.Target                     ( Native )++import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty     as LP++import Control.Monad+++-- The stencil function is similar to a map, but has access to surrounding+-- elements as specified by the stencil pattern.+--+-- This generates two functions:+--+--  * stencil_inside: does not apply boundary conditions, assumes all element+--                    accesses are valid+--+--  * stencil_border: applies boundary condition check to each array access+--+mkStencil1+    :: UID+    -> Gamma              aenv+    -> StencilR sh a stencil+    -> TypeR b+    -> IRFun1      Native aenv (stencil -> b)+    -> IRBoundary  Native aenv (Array sh a)+    -> MIRDelayed  Native aenv (Array sh a)+    -> CodeGen     Native      (IROpenAcc Native aenv (Array sh b))+mkStencil1 uid aenv sr tp f bnd marr =+  let (arrIn, paramIn) = delayedArray "in" marr+      repr = ArrayR (stencilShapeR sr) tp+   in (+++) <$> mkInside uid aenv repr (IRFun1 $ app1 f <=< stencilAccess sr Nothing    arrIn) paramIn+            <*> mkBorder uid aenv repr (IRFun1 $ app1 f <=< stencilAccess sr (Just bnd) arrIn) paramIn++mkStencil2+    :: UID+    -> Gamma              aenv+    -> StencilR sh a stencil1+    -> StencilR sh b stencil2+    -> TypeR c+    -> IRFun2      Native aenv (stencil1 -> stencil2 -> c)+    -> IRBoundary  Native aenv (Array sh a)+    -> MIRDelayed  Native aenv (Array sh a)+    -> IRBoundary  Native aenv (Array sh b)+    -> MIRDelayed  Native aenv (Array sh b)+    -> CodeGen     Native      (IROpenAcc Native aenv (Array sh c))+mkStencil2 uid aenv sr1 sr2 tp f bnd1 marr1 bnd2 marr2 =+  let+      (arrIn1, paramIn1)  = delayedArray "in1" marr1+      (arrIn2, paramIn2)  = delayedArray "in2" marr2++      repr = ArrayR (stencilShapeR sr1) tp++      inside  = IRFun1 $ \ix -> do+        stencil1 <- stencilAccess sr1 Nothing arrIn1 ix+        stencil2 <- stencilAccess sr2 Nothing arrIn2 ix+        app2 f stencil1 stencil2+      --+      border  = IRFun1 $ \ix -> do+        stencil1 <- stencilAccess sr1 (Just bnd1) arrIn1 ix+        stencil2 <- stencilAccess sr2 (Just bnd2) arrIn2 ix+        app2 f stencil1 stencil2+  in+  (+++) <$> mkInside uid aenv repr inside (paramIn1 ++ paramIn2)+        <*> mkBorder uid aenv repr border (paramIn1 ++ paramIn2)+++mkInside+    :: UID+    -> Gamma aenv+    -> ArrayR (Array sh e)+    -> IRFun1  Native aenv (sh -> e)+    -> [LP.Typed LP.Ident]+    -> CodeGen Native      (IROpenAcc Native aenv (Array sh e))+mkInside uid aenv repr apply paramIn =+  let+      (start, end, paramGang)   = gangParam    (arrayRshape repr)+      (arrOut, paramOut)        = mutableArray repr "out"+      paramEnv                  = envParam aenv+      shOut                     = irArrayShape arrOut+  in+  makeOpenAcc uid "stencil_inside" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do++    imapNestFromToTile (arrayRshape repr) 4 start end shOut $ \ix i -> do+      r <- app1 apply ix                        -- apply generator function+      writeArray TypeInt arrOut i r             -- store result+++mkBorder+    :: UID+    -> Gamma aenv+    -> ArrayR (Array sh e)+    -> IRFun1  Native aenv (sh -> e)+    -> [LP.Typed LP.Ident]+    -> CodeGen Native      (IROpenAcc Native aenv (Array sh e))+mkBorder uid aenv repr apply paramIn =+  let+      (start, end, paramGang)   = gangParam    (arrayRshape repr)+      (arrOut, paramOut)        = mutableArray repr "out"+      paramEnv                  = envParam aenv+      shOut                     = irArrayShape arrOut+  in+  makeOpenAcc uid "stencil_border" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do++    imapNestFromTo (arrayRshape repr) start end shOut $ \ix i -> do+      r <- app1 apply ix                        -- apply generator function+      writeArray TypeInt arrOut i r             -- store result+++imapNestFromToTile+    :: ShapeR sh+    -> Int                                                  -- ^ unroll amount (tile height)+    -> Operands sh                                          -- ^ initial index (inclusive)+    -> Operands sh                                          -- ^ final index (exclusive)+    -> Operands sh                                          -- ^ total array extent+    -> (Operands sh -> Operands Int -> CodeGen Native ())   -- ^ apply at each index+    -> CodeGen Native ()+imapNestFromToTile shr unroll start end extent body =+  go shr start end body'+  where+    body' ix = body ix =<< intOfIndex shr extent ix++    go :: ShapeR t+       -> Operands t+       -> Operands t+       -> (Operands t -> CodeGen Native ())+       -> CodeGen Native ()+    go ShapeRz OP_Unit OP_Unit k+      = k OP_Unit++    -- To correctly generate the unrolled loop nest we need to explicitly match+    -- on the last two dimensions.+    --+    go (ShapeRsnoc (ShapeRsnoc ShapeRz)) (OP_Pair (OP_Pair OP_Unit sy) sx) (OP_Pair (OP_Pair OP_Unit ey) ex) k+      = do+          -- Tile the stencil operator in the xy-plane by unrolling in the+          -- y-dimension and vectorising in the x-dimension.+          --+          sy' <- imapFromStepTo sy (liftInt unroll) ey $ \iy ->+                  imapFromTo    sx                  ex $ \ix ->+                    forM_ [0 .. unroll-1] $ \n -> do+                    iy' <- add numType iy (liftInt n)+                    k (OP_Pair (OP_Pair OP_Unit iy') ix)++          -- Take care of any remaining loop iterations in the y-dimension+          --+          _       <- imapFromTo  sy' ey $ \iy ->+                      imapFromTo sx  ex $ \ix ->+                        k (OP_Pair (OP_Pair OP_Unit iy) ix)+          return ()++    -- The 1- and 3+-dimensional cases can recurse normally+    --+    go (ShapeRsnoc shr') (OP_Pair ssh ssz) (OP_Pair esh esz) k+      = go shr' ssh esh+      $ \sz      -> imapFromTo ssz esz+      $ \i       -> k (OP_Pair sz i)++imapFromStepTo+    :: Operands Int+    -> Operands Int+    -> Operands Int+    -> (Operands Int -> CodeGen Native ())+    -> CodeGen Native (Operands Int)+imapFromStepTo start step end body =+  let+      incr i = add numType i step+      test i = do i' <- incr i+                  lt singleType i' end+  in+  while (TupRsingle scalarTypeInt) test+        (\i -> body i >> incr i)+        start+
+ src/Data/Array/Accelerate/LLVM/Native/CodeGen/Transform.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen.Transform+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.CodeGen.Transform+  where++-- accelerate+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.LLVM.CodeGen.Array+import Data.Array.Accelerate.LLVM.CodeGen.Base+import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.CodeGen.Exp+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.LLVM.Compile.Cache++import Data.Array.Accelerate.LLVM.Native.Target                     ( Native )+import Data.Array.Accelerate.LLVM.Native.CodeGen.Base+import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop+++-- Hybrid map/backpermute operation+--+mkTransform+    :: UID+    -> Gamma aenv+    -> ArrayR (Array sh  a)+    -> ArrayR (Array sh' b)+    -> IRFun1  Native aenv (sh' -> sh)+    -> IRFun1  Native aenv (a -> b)+    -> CodeGen Native      (IROpenAcc Native aenv (Array sh' b))+mkTransform uid aenv reprIn reprOut p f =+  let+      (start, end, paramGang)   = gangParam (arrayRshape reprOut)+      (arrIn,  paramIn)         = mutableArray reprIn  "in"+      (arrOut, paramOut)        = mutableArray reprOut "out"+      paramEnv                  = envParam aenv+      shIn                      = irArrayShape arrIn+      shOut                     = irArrayShape arrOut+  in+  makeOpenAcc uid "transform" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do++    imapNestFromTo (arrayRshape reprOut) start end shOut $ \ix' i' -> do+      ix  <- app1 p ix'+      i   <- intOfIndex (arrayRshape reprIn) shIn ix+      a   <- readArray TypeInt arrIn i+      b   <- app1 f a+      writeArray TypeInt arrOut i' b+
+ src/Data/Array/Accelerate/LLVM/Native/Compile.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE TypeFamilies      #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Compile+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.Compile (++  module Data.Array.Accelerate.LLVM.Compile,+  ObjectR(..),++) where++import Data.Array.Accelerate.AST                                    ( PreOpenAcc )+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Trafo.Delayed++import Data.Array.Accelerate.LLVM.CodeGen+import Data.Array.Accelerate.LLVM.Compile+import Data.Array.Accelerate.LLVM.State+import Data.Array.Accelerate.LLVM.Target.ClangInfo                  ( hostLLVMVersion, llvmverFromTuple, clangExePath )+import Data.Array.Accelerate.LLVM.CodeGen.Environment               ( Gamma )+import Data.Array.Accelerate.LLVM.CodeGen.Module                    ( Module(..) )++import Data.Array.Accelerate.LLVM.Native.CodeGen                    ( )+import Data.Array.Accelerate.LLVM.Native.Compile.Cache+import Data.Array.Accelerate.LLVM.Native.Foreign                    ( )+import Data.Array.Accelerate.LLVM.Native.Target+import qualified Data.Array.Accelerate.LLVM.Native.Debug            as Debug++import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty     as P+import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty.PP  as P+import qualified Text.PrettyPrint                                   as P ( render )++import Control.Applicative+import Control.Monad.State+import Data.ByteString.Short                                        ( ShortByteString )+import Data.List                                                    ( intercalate )+import Data.Foldable                                                ( toList )+import Data.Maybe+import Formatting+import System.Directory+import System.Environment+import System.FilePath                                              ( (<.>) )+import qualified System.Info                                        as Info+import System.IO.Unsafe+import System.Process+import qualified Data.ByteString.Short.Char8                        as SBS8+import qualified Data.Map.Strict                                    as Map+++instance Compile Native where+  data ObjectR Native = ObjectR+    { objId         :: {-# UNPACK #-} !UID+    , objSyms       :: ![ShortByteString]+    , staticObjPath :: {- LAZY -} FilePath+    , sharedObjPath :: {- LAZY -} FilePath+    }+  compileForTarget    = compile++instance Intrinsic Native+++-- | Compile an Accelerate expression to object code.+--+-- This compilation step creates a static object file and a shared object+-- file, on demand. The former is used in the case of @runQ@ to statically+-- link the compiled object into the executable and generate FFI imports so+-- that the compiled kernel can be embedded directly into the resulting+-- executable. The latter will convert the former into a shared object to+-- be loaded into the running executable using the system's dynamic linker.+--+compile :: PreOpenAcc DelayedOpenAcc aenv a -> Gamma aenv -> LLVM Native (ObjectR Native)+compile pacc aenv = do++  -- Generate code for this Acc operation+  --+  -- We require the metadata result, which will give us the names of the+  -- functions which will be contained in the object code, but the actual+  -- code generation step is executed lazily.+  --+  (uid, cachePath) <- cacheOfPreOpenAcc pacc+  Module ast md    <- llvmOfPreOpenAcc uid pacc aenv++  let staticObjFile = cachePath <.> staticObjExt+      sharedObjFile = cachePath <.> sharedObjExt+      -- triple        = fromMaybe BS.empty (moduleTargetTriple ast)+      -- datalayout    = moduleDataLayout ast+      nms           = [ SBS8.pack f | P.Symbol f <- Map.keys md ]++  -- Lower the generated LLVM and produce an object file.+  --+  -- The 'staticObjPath' field is only lazily evaluated since the object+  -- code might already have been loaded into memory from a different+  -- function, in which case it will be found in the linker cache.+  --+  o_file <- liftIO . unsafeInterleaveIO $ do+    force_recomp  <- if Debug.debuggingIsEnabled then Debug.getFlag Debug.force_recomp else return False+    o_file_exists <- doesFileExist staticObjFile+    if o_file_exists && not force_recomp+      then+        Debug.traceM Debug.dump_cc ("cc: found cached object " % shown) uid++      else do+        -- print ast++        -- Detect LLVM version+        -- Note: this LLVM version is incorporated in the cache path, so we're safe detecting it at runtime.+        let prettyHostLLVMVersion = intercalate "." (Prelude.map show (toList hostLLVMVersion))+        llvmver <- case llvmverFromTuple hostLLVMVersion of+                     Just llvmver -> return llvmver+                     Nothing -> internalError ("accelerate-llvm-native: Unsupported LLVM version: " % string)+                                              prettyHostLLVMVersion+        Debug.traceM Debug.dump_cc ("Using Clang at " % string % " version " % shown) clangExePath prettyHostLLVMVersion++        -- Convert module to llvm-pretty format so that we can print it+        let unoptimisedText = P.render (P.ppLLVM llvmver (P.ppModule ast))+        Debug.when Debug.verbose $ do+          Debug.traceM Debug.dump_cc ("Unoptimised LLVM IR:\n" % string) unoptimisedText++        dVerbose <- Debug.getFlag Debug.verbose+        dDumpCC <- Debug.getFlag Debug.dump_cc+        dDumpAsm <- Debug.getFlag Debug.dump_asm++        let clangFlags inputType outputFlags output =+              -- '-O3' is ignored when only assembling; let's avoid clang warning about that+              (if inputType == "assembler" then [] else ["-O3"]) +++              (case takeWhile (/= '-') (SBS8.unpack nativeTargetTriple) of+                 "aarch64" -> ["-mcpu=native"]  -- e.g. Ampere+                 "arm64" -> ["-mcpu=native"]  -- e.g. Apple+                 _ -> ["-march=native"]) ++  -- e.g. x86_64+              ["-c", "-o", output, "-x", inputType, "-"+              -- clang knows better what the target triple (and the data+              -- layout) should be than us, so let it override the triple, and+              -- don't warn about it+              -- TODO: change llvm-pretty so that it doesn't require us to give+              -- it a target triple+              ,"-Wno-override-module"] +++              outputFlags++        let linkOutputFlags | Info.os == "mingw32" = []+                            | otherwise = ["-fPIC"]++        -- Minimise the number of clang invocations (to 1) in the common case+        -- of no verbose debug flags. If we need to print some intermediate+        -- stages, run all stages separately for simplicity, and print only the+        -- intermediate values that were requested.+        -- See llvm-project/clang/include/clang/Driver/Types.def for "-x" argument values:+        --   https://github.com/llvm/llvm-project/blob/da286c8bf69684d1612d1fc440bd9c6f1a4326df/clang/include/clang/Driver/Types.def+        if dVerbose && (dDumpCC || dDumpAsm)+          then do+            optText <- readProcess clangExePath (clangFlags "ir" ["-S", "-emit-llvm"] "-") unoptimisedText+            Debug.traceM Debug.dump_cc ("Optimised LLVM IR:\n" % string) optText+            asmText <- readProcess clangExePath (clangFlags "ir" ["-S"] "-") optText+            Debug.traceM Debug.dump_asm ("Optimised assembly:\n" % string) asmText+            _ <- readProcess clangExePath (clangFlags "assembler" linkOutputFlags staticObjFile) asmText+            return ()+          else do+            _ <- readProcess clangExePath (clangFlags "ir" linkOutputFlags staticObjFile) unoptimisedText+            return ()++        Debug.traceM Debug.dump_cc ("cc: new object code " % shown) uid++    return staticObjFile++  -- Convert the relocatable object file (created above) into a shared+  -- object file using the operating system's native linker.+  --+  -- Once again, the 'sharedObjPath' is only lazily evaluated since the+  -- object code might already have been loaded into memory from+  -- a different function.+  --+  so_file <- liftIO . unsafeInterleaveIO $ do+    force_recomp   <- if Debug.debuggingIsEnabled then Debug.getFlag Debug.force_recomp else return False+    so_file_exists <- doesFileExist sharedObjFile+    if so_file_exists && not force_recomp+      then+        Debug.traceM Debug.dump_cc ("cc: found cached shared object " % shown) uid++      else do+        o_file_exists <- doesFileExist staticObjFile+        objFile       <- if o_file_exists && not force_recomp+                           then do+                             Debug.traceM Debug.dump_cc ("cc: found cached object " % shown) uid+                             return staticObjFile+                           else+                             return o_file++        -- LLVM doesn't seem to provide a way to build a shared object file+        -- directly, so shell out to the system linker to do this.+        --+        case Info.os of+          "darwin" ->+            -- TODO: Unclear if -lm is necessary on Darwin too; let's add it+            -- just in case. (The -lm on Linux was added to properly declare+            -- dependency on libm, so that it gets pulled in even if the main+            -- executable is statically-linked and thus does not have a dynamic+            -- libm in its address space.)+            callProcess ld ["--shared", "-o", sharedObjFile, objFile, "-undefined", "dynamic_lookup", "-lm"]+          "mingw32" ->  -- windows+            callProcess ld ["--shared", "-o", sharedObjFile, objFile]  -- no -lm necessary on windows+          _ ->  -- linux etc.+            callProcess ld ["--shared", "-o", sharedObjFile, objFile, "-lm"]+        Debug.traceM Debug.dump_cc ("cc: new shared object " % shown) uid++    return sharedObjFile++  return $! ObjectR uid nms o_file so_file+++-- Respect the common @LD@ and @CC@ environment variables, falling back to+-- search the path for @cc@ if neither of those exist.+--+-- XXX: On Unixy systems, we use @cc@ as the default instead of @ld@ because+-- on macOS this will do the right thing, whereas 'ld --shared' will not.+-- On Windows, we just use clang as the driver to "do the right thing".+--+ld :: FilePath+ld = unsafePerformIO $ do+  let defProgram | Info.os == "mingw32" = clangExePath+                 | otherwise = "cc"+  mfromEnv <- liftA2 (<|>) (lookupEnv "LD") (lookupEnv "CC")+  return (fromMaybe defProgram mfromEnv)++-- The file extension for static libraries+--+staticObjExt :: String+staticObjExt | Info.os == "mingw32" = "obj"+             | otherwise = "o"++-- The file extension used for shared libraries+--+sharedObjExt :: String+sharedObjExt = case Info.os of+  "darwin" -> "dylib"+  "mingw32" -> "dll"+  _ -> "so"  -- let's just default to the unixy ".so"
+ src/Data/Array/Accelerate/LLVM/Native/Compile/Cache.hs view
@@ -0,0 +1,42 @@+{-# OPTIONS_GHC -Wno-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Compile.Cache+-- Copyright   : [2017..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.Compile.Cache (++  module Data.Array.Accelerate.LLVM.Compile.Cache++) where++import Data.Array.Accelerate.LLVM.Compile.Cache+import Data.Array.Accelerate.LLVM.Native.Target+import Data.Array.Accelerate.LLVM.Target.ClangInfo                  ( hostLLVMVersion )++import Data.Foldable                                                ( toList )+import Data.List                                                    ( intercalate )+import Data.Version+import System.FilePath+import qualified Data.ByteString.Char8                              as B8+import qualified Data.ByteString.Short.Char8                        as S8++import Paths_accelerate_llvm_native+++instance Persistent Native where+  targetCacheTemplate =+    -- The "llvmpr" is for "llvm-pretty". This is to ensure we still have a+    -- sensible cache path to switch to should we ever move away from+    -- llvm-pretty again.+    return $ "accelerate-llvm-native-" ++ showVersion version+         </> "llvmpr-" ++ intercalate "." (map show (toList hostLLVMVersion))+         </> S8.unpack nativeTargetTriple+         </> B8.unpack nativeCPUName+         </> "meep"+
+ src/Data/Array/Accelerate/LLVM/Native/Debug.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE TypeOperators     #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Debug+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.Debug (++  module Data.Array.Accelerate.Debug.Internal,+  module Data.Array.Accelerate.LLVM.Native.Debug,++) where++import Data.Array.Accelerate.Debug.Internal                         hiding ( elapsed )+import qualified Data.Array.Accelerate.Debug.Internal               as Debug++import Formatting+import Formatting.Internal+import Data.Text.Lazy.Builder++import Control.Monad.Trans+++-- | Display elapsed wall and CPU time, together with speedup fraction+--+{-# INLINEABLE elapsedP #-}+elapsedP :: Format r (Double -> Double -> r)+elapsedP = Format $ \k cpuTime wallTime ->+  k $ bformat (formatSIBase (Just 3) 1000 % "s (wall), " % formatSIBase (Just 3) 1000 % "s (cpu), " % fixed 2 % " x speedup")+        wallTime+        cpuTime+        (wallTime/cpuTime)++-- | Display elapsed wall and CPU time+--+{-# INLINEABLE elapsedS #-}+elapsedS :: Format r (Double -> Double -> r)+elapsedS = Debug.elapsed+++data Phase = Compile | Link | Execute++buildPhase :: Phase -> Builder+buildPhase = \case+  Compile -> "compile"+  Link    -> "link"+  Execute -> "execute"++phase :: MonadIO m => Phase -> Format Builder (Double -> Double -> Builder) -> m a -> m a+phase p fmt = timed dump_phases (now ("phase " <> buildPhase p <> ": ") % fmt)++{--+phase :: (MonadIO m, HasCallStack) => Phase -> (Double -> Double -> Builder) -> m a -> m a+phase p fmt go = do+  let (p_phase, sz_phase) = case p of+                              Compile -> (Ptr $(litE (stringPrimL (map (fromIntegral . ord) "compile\0"))), 7)+                              Link    -> (Ptr $(litE (stringPrimL (map (fromIntegral . ord) "link\0"))),    4)+                              Execute -> (Ptr $(litE (stringPrimL (map (fromIntegral . ord) "execute\0"))), 7)+      (line, file, fun)   = case getCallStack callStack of+                              []        -> (0, [], [])+                              ((f,l):_) -> (srcLocStartLine l, srcLocFile l, f)+  --+  zone   <- liftIO $+    withCStringLen file $ \(p_file, sz_file) ->+    withCStringLen fun  $ \(p_fun,  sz_fun)  -> do+      srcloc <- alloc_srcloc_name (fromIntegral line) p_file (fromIntegral sz_file) p_fun (fromIntegral sz_fun) p_phase sz_phase+      zone   <- emit_zone_begin srcloc 1+      return zone++  result <- timed dump_phases (\wall cpu -> build "phase {}: {}" (p, fmt wall cpu)) go+  _      <- liftIO $ emit_zone_end zone++  return result+--}+
+ src/Data/Array/Accelerate/LLVM/Native/Embed.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE BangPatterns    #-}+{-# LANGUAGE CPP             #-}+{-# LANGUAGE QuasiQuotes     #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns    #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Embed+-- Copyright   : [2017..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.Embed (++  module Data.Array.Accelerate.LLVM.Embed,++) where++import Data.ByteString.Short.Char8                                  as S8+import Data.ByteString.Short.Extra                                  as BS++import Data.Array.Accelerate.Lifetime++import Data.Array.Accelerate.LLVM.Compile+import Data.Array.Accelerate.LLVM.Embed++import Data.Array.Accelerate.LLVM.Native.Compile+import Data.Array.Accelerate.LLVM.Native.Compile.Cache+import Data.Array.Accelerate.LLVM.Native.Link+import Data.Array.Accelerate.LLVM.Native.Plugin.Annotation+import Data.Array.Accelerate.LLVM.Native.State+import Data.Array.Accelerate.LLVM.Native.Target++import Control.Concurrent.Unique+import Control.Monad+import Data.Hashable+import Foreign.Ptr+import Data.Array.Accelerate.TH.Compat                              ( Q, CodeQ )+import Numeric+import System.FilePath                                              ( (<.>) )+import System.IO.Unsafe+import qualified Data.Array.Accelerate.TH.Compat                    as TH+import qualified Language.Haskell.TH.Syntax                         as TH++import Data.Maybe+import qualified Data.Set                                           as Set+++instance Embed Native where+  embedForTarget = embed++-- Add the given object code to the set of files to link the executable with,+-- and generate FFI declarations to access the external functions of that file.+-- The returned ExecutableR references the new FFI declarations.+--+embed :: Native -> ObjectR Native -> CodeQ (ExecutableR Native)+embed target (ObjectR uid nms !_ _) =+  TH.bindCode getObjectFile $ \objFile ->+    [|| NativeR (unsafePerformIO $ newLifetime (FunctionTable $$(listE $ makeTable objFile nms))) ||]+  where+    listE :: [CodeQ a] -> CodeQ [a]+    listE xs = TH.unsafeCodeCoerce (TH.listE (map TH.unTypeCode xs))++    makeTable :: FilePath -> [ShortByteString] -> [CodeQ (ShortByteString, FunPtr ())]+    makeTable objFile = map (\fn -> [|| ( $$(liftSBS fn), $$(makeFFI fn objFile) ) ||])++    makeFFI :: ShortByteString -> FilePath -> CodeQ (FunPtr ())+    makeFFI (S8.unpack -> fn) objFile = TH.bindCode go (TH.unsafeCodeCoerce . return)+      where+        go = do+          i   <- TH.runIO newUnique+          fn' <- TH.newName ("__accelerate_llvm_native_" ++ showHex (hash i) [])+          dec <- TH.forImpD TH.CCall TH.Unsafe ('&':fn) fn' [t| FunPtr () |]+          ann <- TH.pragAnnD (TH.ValueAnnotation fn') [| (Object objFile) |]+          TH.addTopDecls [dec, ann]+          TH.varE fn'++    -- Note: [Template Haskell and raw object files]+    --+    -- We can only addForeignFilePath once per object file, otherwise the+    -- linker will complain about duplicate symbols. To work around this,+    -- we use putQ/getQ to keep track of which object files have already+    -- been encountered during compilation _of the current module_. This+    -- means that we might still run into problems if runQ is invoked at+    -- multiple modules.+    --+    getObjectFile :: Q FilePath+    getObjectFile = do+      cachePath  <- TH.runIO (evalNative target (cacheOfUID uid))+      let objFile = cachePath <.> staticObjExt+#if __GLASGOW_HASKELL__ >= 806+      objSet     <- fromMaybe Set.empty <$> TH.getQ+      unless (Set.member objFile objSet) $ do+        TH.addForeignFilePath TH.RawObject objFile+        TH.putQ (Set.insert objFile objSet)+#endif+      return objFile++-- The file extension for static libraries+--+staticObjExt :: String+#if   defined(mingw32_HOST_OS)+staticObjExt = "obj"+#else+staticObjExt = "o"+#endif+
+ src/Data/Array/Accelerate/LLVM/Native/Execute.hs view
@@ -0,0 +1,1018 @@+{-# LANGUAGE BangPatterns             #-}+{-# LANGUAGE FlexibleContexts         #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE GADTs                    #-}+{-# LANGUAGE LambdaCase               #-}+{-# LANGUAGE OverloadedStrings        #-}+{-# LANGUAGE RecordWildCards          #-}+{-# LANGUAGE ScopedTypeVariables      #-}+{-# LANGUAGE TemplateHaskell          #-}+{-# LANGUAGE TypeApplications         #-}+{-# LANGUAGE TypeOperators            #-}+{-# LANGUAGE ViewPatterns             #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Execute+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.Execute (++  executeAcc,+  executeOpenAcc++) where++import Data.Array.Accelerate.Analysis.Match+import Data.Array.Accelerate.Array.Unique+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Lifetime+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.LLVM.Execute+import Data.Array.Accelerate.LLVM.Execute.Async (FutureArraysR)+import Data.Array.Accelerate.LLVM.State++import Data.Array.Accelerate.LLVM.Native.Array.Data+import Data.Array.Accelerate.LLVM.Native.Execute.Async+import Data.Array.Accelerate.LLVM.Native.Execute.Divide+import Data.Array.Accelerate.LLVM.Native.Execute.Environment        ( Val )+import Data.Array.Accelerate.LLVM.Native.Execute.Marshal+import Data.Array.Accelerate.LLVM.Native.Execute.Scheduler+import Data.Array.Accelerate.LLVM.Native.Link+import Data.Array.Accelerate.LLVM.Native.Target+import qualified Data.Array.Accelerate.LLVM.Native.Debug            as Debug++import Control.Concurrent                                           ( myThreadId )+import Control.Concurrent.Extra                                     ( getThreadId )+import Control.Monad.Reader                                         ( asks )+import Control.Monad.Trans                                          ( liftIO )+import Data.ByteString.Short                                        ( ShortByteString )+import Data.IORef                                                   ( newIORef, readIORef, writeIORef )+import Data.List                                                    ( find )+import Data.Maybe                                                   ( fromMaybe )+import Data.Sequence                                                ( Seq )+import Data.Foldable                                                ( asum )+import Formatting+import System.CPUTime                                               ( getCPUTime )+import qualified Data.ByteString.Short                              as S+import qualified Data.ByteString.Short.Extra                        as SE+import qualified Data.ByteString.Short.Char8                        as S8+import qualified Data.Sequence                                      as Seq+import qualified Data.DList                                         as DL+import Prelude                                                      hiding ( map, sum, scanl, scanr, init )++import Foreign.LibFFI+import Foreign.Ptr++{-# SPECIALISE INLINE executeAcc     :: ExecAcc     Native      a ->             Par Native (FutureArraysR Native a) #-}+{-# SPECIALISE INLINE executeOpenAcc :: ExecOpenAcc Native aenv a -> Val aenv -> Par Native (FutureArraysR Native a) #-}++-- Array expression evaluation+-- ---------------------------++-- Computations are evaluated by traversing the AST bottom up, and for each node+-- distinguishing between three cases:+--+--  1. If it is a Use node, we return a reference to the array data. Even though+--     we execute with multiple cores, we assume a shared memory multiprocessor+--     machine.+--+--  2. If it is a non-skeleton node, such as a let binding or shape conversion,+--     then execute directly by updating the environment or similar.+--+--  3. If it is a skeleton node, then we need to execute the generated LLVM+--     code.+--+instance Execute Native where+  {-# INLINE map         #-}+  {-# INLINE generate    #-}+  {-# INLINE transform   #-}+  {-# INLINE backpermute #-}+  {-# INLINE fold        #-}+  {-# INLINE foldSeg     #-}+  {-# INLINE scan        #-}+  {-# INLINE scan'       #-}+  {-# INLINE permute     #-}+  {-# INLINE stencil1    #-}+  {-# INLINE stencil2    #-}+  {-# INLINE aforeign    #-}+  map           = mapOp+  generate      = generateOp+  transform     = transformOp+  backpermute   = backpermuteOp+  fold True     = foldOp+  fold False    = fold1Op+  foldSeg i _   = foldSegOp i+  scan _ True   = scanOp+  scan _ False  = scan1Op+  scan' _       = scan'Op+  permute       = permuteOp+  stencil1      = stencil1Op+  stencil2      = stencil2Op+  aforeign      = aforeignOp+++-- Skeleton implementation+-- -----------------------++-- Simple kernels just needs to know the shape of the output array.+--+{-# INLINE simpleOp #-}+simpleOp+    :: HasCallStack+    => ShortByteString+    -> ArrayR (Array sh e)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> sh+    -> Par Native (Future (Array sh e))+simpleOp name repr NativeR{..} gamma aenv sh = do+  let fun   = nativeExecutable !# name+      param = TupRsingle $ ParamRarray repr+  Native{..} <- asks llvmTarget+  future     <- new+  result     <- allocateRemote repr sh+  scheduleOp fun gamma aenv (arrayRshape repr) sh param result+    `andThen` do putIO workers future result+                 touchLifetime nativeExecutable   -- XXX: must not unload the object code early+  return future++-- Mapping over an array can ignore the dimensionality of the array and+-- treat it as its underlying linear representation.+--+{-# INLINE mapOp #-}+mapOp+    :: HasCallStack+    => Maybe (a :~: b)+    -> ArrayR (Array sh a)+    -> TypeR b+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Array sh a+    -> Par Native (Future (Array sh b))+mapOp inplace repr tp NativeR{..} gamma aenv input = do+  let fun   = nativeExecutable !# "map"+      sh    = shape input+      shr   = arrayRshape repr+      repr' = ArrayR shr tp+      param = TupRsingle (ParamRarray repr') `TupRpair` TupRsingle (ParamRarray repr)+  Native{..} <- asks llvmTarget+  future     <- new+  result     <- case inplace of+                  Just Refl -> return input+                  Nothing   -> allocateRemote repr' sh+  scheduleOp fun gamma aenv dim1 ((), size shr sh) param (result, input)+    `andThen` do putIO workers future result+                 touchLifetime nativeExecutable+  return future++{-# INLINE generateOp #-}+generateOp+    :: HasCallStack+    => ArrayR (Array sh e)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> sh+    -> Par Native (Future (Array sh e))+generateOp = simpleOp "generate"++{-# INLINE transformOp #-}+transformOp+    :: HasCallStack+    => ArrayR (Array sh  a)+    -> ArrayR (Array sh' b)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> sh'+    -> Array sh a+    -> Par Native (Future (Array sh' b))+transformOp repr repr' NativeR{..} gamma aenv sh' input = do+  let fun = nativeExecutable !# "transform"+  Native{..} <- asks llvmTarget+  future     <- new+  result     <- allocateRemote repr' sh'+  let param = TupRsingle (ParamRarray repr') `TupRpair` TupRsingle (ParamRarray repr)+  scheduleOp fun gamma aenv (arrayRshape repr') sh' param (result, input)+    `andThen` do putIO workers future result+                 touchLifetime nativeExecutable+  return future++{-# INLINE backpermuteOp #-}+backpermuteOp+    :: HasCallStack+    => ArrayR (Array sh e)+    -> ShapeR sh'+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> sh'+    -> Array sh e+    -> Par Native (Future (Array sh' e))+backpermuteOp (ArrayR shr tp) shr' = transformOp (ArrayR shr tp) (ArrayR shr' tp)++-- Note: [Reductions]+--+-- There are two flavours of reduction:+--+--   1. If we are collapsing to a single value, then threads reduce strips of+--      the input in parallel, and then a single thread reduces the partial+--      reductions to a single value. Load balancing occurs over the input+--      stripes.+--+--   2. If this is a multidimensional reduction, then each inner dimension is+--      handled by a single thread. Load balancing occurs over the outer+--      dimension indices.+--+-- The entry points to executing the reduction are 'foldOp' and 'fold1Op', for+-- exclusive and inclusive reductions respectively. These functions handle+-- whether the input array is empty. If the input and output arrays are+-- non-empty, we then further dispatch (via 'foldCore') to 'foldAllOp' or+-- 'foldDimOp' for single or multidimensional reductions, respectively.+-- 'foldAllOp' in particular behaves differently whether we are evaluating the+-- array in parallel or sequentially.+--++{-# INLINE fold1Op #-}+fold1Op+    :: HasCallStack+    => ArrayR (Array sh e)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Par Native (Future (Array sh e))+fold1Op repr exe gamma aenv arr@(delayedShape -> sh@(sx, sz))+  = boundsCheck "empty array" (sz > 0)+  $ case size (ShapeRsnoc $ arrayRshape repr) sh of+      0 -> newFull =<< allocateRemote repr sx    -- empty, but possibly with non-zero dimensions+      _ -> foldCore repr exe gamma aenv arr++{-# INLINE foldOp #-}+foldOp+    :: HasCallStack+    => ArrayR (Array sh e)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Par Native (Future (Array sh e))+foldOp repr exe gamma aenv arr@(delayedShape -> sh@(sx, _)) =+  case size (ShapeRsnoc $ arrayRshape repr) sh of+    0 -> generateOp repr exe gamma aenv sx+    _ -> foldCore repr exe gamma aenv arr++{-# INLINE foldCore #-}+foldCore+    :: HasCallStack+    => ArrayR (Array sh e)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Par Native (Future (Array sh e))+foldCore repr exe gamma aenv arr+  | ArrayR ShapeRz tp <- repr+  = foldAllOp tp exe gamma aenv arr+  --+  | otherwise+  = foldDimOp repr exe gamma aenv arr++{-# INLINE foldAllOp #-}+foldAllOp+    :: HasCallStack+    => TypeR e+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Vector e)+    -> Par Native (Future (Scalar e))+foldAllOp tp NativeR{..} gamma aenv arr = do+  Native{..}  <- asks llvmTarget+  future      <- new+  result      <- allocateRemote (ArrayR dim0 tp) ()+  let+      minsize = 4096+      ranges  = divideWork1 splits minsize ((), 0) sh (,,)+      splits  = numWorkers workers - 1+      steps   = Seq.length ranges+      sh      = delayedShape arr+  --+  if steps <= 1+    then+      let param = TupRsingle (ParamRarray $ ArrayR dim0 tp) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray $ ArrayR dim1 tp)+      in  scheduleOpUsing ranges (nativeExecutable !# "foldAllS") gamma aenv dim1 param (result, manifest arr)+            `andThen` do putIO workers future result+                         touchLifetime nativeExecutable++    else do+      let param1 = TupRsingle (ParamRarray $ ArrayR dim1 tp) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray $ ArrayR dim1 tp)+      let param2 = TupRsingle (ParamRarray $ ArrayR dim1 tp) `TupRpair` TupRsingle (ParamRarray $ ArrayR dim0 tp)+      tmp   <- allocateRemote (ArrayR dim1 tp) ((), steps)+      job2  <- mkJobUsing (Seq.singleton (0, ((), 0), ((), steps))) (nativeExecutable !# "foldAllP2") gamma aenv dim1 param2 (tmp, result)+                 `andThen` do putIO workers future result+                              touchLifetime nativeExecutable++      job1  <- mkJobUsingIndex ranges (nativeExecutable !# "foldAllP1") gamma aenv dim1 param1 (tmp, manifest arr)+                 `andThen` do schedule workers job2++      liftIO $ schedule workers job1+  --+  return future+++{-# INLINE foldDimOp #-}+foldDimOp+    :: HasCallStack+    => ArrayR (Array sh e)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Par Native (Future (Array sh e))+foldDimOp repr NativeR{..} gamma aenv arr@(delayedShape -> (sh, _)) = do+  Native{..}  <- asks llvmTarget+  future      <- new+  result      <- allocateRemote repr sh+  let+      ArrayR shr tp = repr+      fun     = nativeExecutable !# "fold"+      splits  = numWorkers workers - 1+      minsize = 1+      param   = TupRsingle (ParamRarray repr) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray $ ArrayR (ShapeRsnoc shr) tp)+  --+  scheduleOpWith splits minsize fun gamma aenv shr sh param (result, manifest arr)+    `andThen` do putIO workers future result+                 touchLifetime nativeExecutable+  return future+++{-# INLINE foldSegOp #-}+foldSegOp+    :: HasCallStack+    => IntegralType i+    -> ArrayR (Array (sh, Int) e)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Delayed (Segments i)+    -> Par Native (Future (Array (sh, Int) e))+foldSegOp iR repr NativeR{..} gamma aenv input@(delayedShape -> (sh, _)) segments@(delayedShape -> ((), ss)) = do+  Native{..}  <- asks llvmTarget+  future      <- new+  let+      n       = ss-1+      splits  = numWorkers workers - 1+      minsize = 1+      shR     = arrayRshape repr+      segR    = ArrayR dim1 $ TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType iR+      param   = TupRsingle (ParamRarray repr) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray segR)+  --+  result  <- allocateRemote repr (sh, n)+  scheduleOpWith splits minsize (nativeExecutable !# "foldSegP") gamma aenv shR (sh, n) param ((result, manifest input), manifest segments)+    `andThen` do putIO workers future result+                 touchLifetime nativeExecutable++  return future+++{-# INLINE scanOp #-}+scanOp+    :: HasCallStack+    => ArrayR (Array (sh, Int) e)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Par Native (Future (Array (sh, Int) e))+scanOp repr exe gamma aenv arr@(delayedShape -> (sz, n)) =+  case n of+    0 -> generateOp repr exe gamma aenv (sz, 1)+    _ -> scanCore   repr exe gamma aenv (n+1) arr++{-# INLINE scan1Op #-}+scan1Op+    :: HasCallStack+    => ArrayR (Array (sh, Int) e)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Par Native (Future (Array (sh, Int) e))+scan1Op repr exe gamma aenv arr@(delayedShape -> sh@(_, n)) =+  case n of+    0 -> newFull =<< allocateRemote repr sh+    _ -> scanCore repr exe gamma aenv n arr++{-# INLINE scanCore #-}+scanCore+    :: HasCallStack+    => ArrayR (Array (sh, Int) e)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Int        -- output size of innermost dimension+    -> Delayed (Array (sh, Int) e)+    -> Par Native (Future (Array (sh, Int) e))+scanCore repr NativeR{..} gamma aenv m input@(delayedShape -> (sz, n)) = do+  Native{..}  <- asks llvmTarget+  future      <- new+  result      <- allocateRemote repr (sz, m)+  --+  let paramA = TupRsingle $ ParamRarray repr+      param  = paramA `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr)+      shR    = arrayRshape (reduceRank repr)++  if isMultiDim $ arrayRshape repr+    -- This is a multidimensional scan. Each partial scan result is evaluated+    -- individually by a thread, so no inter-thread communication is required.+    then+      let+          fun     = nativeExecutable !# "scanS"+          splits  = numWorkers workers - 1+          minsize = 1+      in+      scheduleOpWith splits minsize fun gamma aenv shR sz param (result, manifest input)+        `andThen` do putIO workers future result+                     touchLifetime nativeExecutable++    -- This is a one-dimensional scan. If the array is small just compute it+    -- sequentially using a single thread, otherwise we require multiple steps+    -- to execute it in parallel.+    else+      if n < 8192+        -- sequential execution+        then+          scheduleOpUsing (Seq.singleton (0, (), ())) (nativeExecutable !# "scanS") gamma aenv dim0 param (result, manifest input)+            `andThen` do putIO workers future result+                         touchLifetime nativeExecutable++        -- parallel execution+        else do+          let+              minsize  = 8192+              ranges   = divideWork dim1 splits minsize ((), 0) ((), n) (,,)+              splits   = numWorkers workers - 1+              steps    = Seq.length ranges+              reprTmp  = ArrayR dim1 $ arrayRtype repr+              paramTmp = TupRsingle $ ParamRarray reprTmp+              param1   = TupRsingle ParamRint `TupRpair` paramA `TupRpair` paramTmp `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr)+              param3   = TupRsingle ParamRint `TupRpair` paramA `TupRpair` paramTmp+          --+          -- XXX: Should the sequential scan of the carry-in values just be+          -- executed immediately as part of the finalisation action?+          --+          tmp   <- allocateRemote (ArrayR dim1 $ arrayRtype repr) ((), steps)+          job3  <- mkJobUsingIndex ranges (nativeExecutable !# "scanP3") gamma aenv dim1 param3 ((steps, result), tmp)+                     `andThen` do putIO workers future result+                                  touchLifetime nativeExecutable+          job2  <- mkJobUsing (Seq.singleton (0, ((), 0), ((), steps))) (nativeExecutable !# "scanP2") gamma aenv dim1 paramTmp tmp+                     `andThen` schedule workers job3+          job1  <- mkJobUsingIndex ranges (nativeExecutable !# "scanP1") gamma aenv dim1 param1 (((steps, result), tmp), manifest input)+                     `andThen` schedule workers job2++          liftIO $ schedule workers job1+  --+  return future+++{-# INLINE scan'Op #-}+scan'Op+    :: HasCallStack+    => ArrayR (Array (sh, Int) e)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Par Native (Future (Array (sh, Int) e, Array sh e))+scan'Op repr exe gamma aenv arr@(delayedShape -> (sz, n)) = do+  case n of+    0 -> do+      out     <- allocateRemote repr (sz, 0)+      sum     <- generateOp (reduceRank repr) exe gamma aenv sz+      future  <- new+      fork $ do sum' <- get sum+                put future (out, sum')+      return future+    --+    _ -> scan'Core repr exe gamma aenv arr++{-# INLINE scan'Core #-}+scan'Core+    :: forall aenv sh e. HasCallStack+    => ArrayR (Array (sh, Int) e)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Par Native (Future (Array (sh, Int) e, Array sh e))+scan'Core repr NativeR{..} gamma aenv input@(delayedShape -> sh@(sz, n)) = do+  let+      ArrayR shR eR   = repr+      ShapeRsnoc shR' = shR+      repr'           = ArrayR shR' eR+      paramA          = TupRsingle $ ParamRarray repr+      paramA'         = TupRsingle $ ParamRarray repr'+  --+  Native{..}  <- asks llvmTarget+  future      <- new+  result      <- allocateRemote repr  sh+  sums        <- allocateRemote repr' sz+  --+  if isMultiDim shR+    -- This is a multidimensional scan. Each partial scan result is evaluated+    -- individually by a thread, so no inter-thread communication is required.+    --+    then+      let fun     = nativeExecutable !# "scanS"+          splits  = numWorkers workers - 1+          minsize = 1+          param   = paramA `TupRpair` paramA' `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr)+      in+      scheduleOpWith splits minsize fun gamma aenv shR' sz param ((result, sums), manifest input)+        `andThen` do putIO workers future (result, sums)+                     touchLifetime nativeExecutable++    -- One dimensional scan. If the array is small just compute it sequentially+    -- with a single thread, otherwise we require multiple steps to execute it+    -- in parallel.+    --+    else+      if n < 8192+        -- sequential execution+        then+          let param = paramA `TupRpair` paramA' `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr)+          in  scheduleOpUsing (Seq.singleton (0, (), ())) (nativeExecutable !# "scanS") gamma aenv dim0 param ((result, sums), manifest input)+                `andThen` do putIO workers future (result, sums)+                             touchLifetime nativeExecutable++        -- parallel execution+        else do+          let+              minsize  = 8192+              ranges   = divideWork1 splits minsize ((), 0) ((), n) (,,)+              splits   = numWorkers workers - 1+              steps    = Seq.length ranges+              reprTmp  = ArrayR dim1 eR+              paramTmp = TupRsingle $ ParamRarray reprTmp+              param1   = TupRsingle ParamRint `TupRpair` paramA `TupRpair` paramTmp `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr)+              param2   = paramA' `TupRpair` paramTmp+              param3   = TupRsingle ParamRint `TupRpair` paramA `TupRpair` paramTmp+          --+          tmp   <- allocateRemote reprTmp ((), steps)+          job3  <- mkJobUsingIndex ranges (nativeExecutable !# "scanP3") gamma aenv dim1 param3 ((steps, result), tmp)+                     `andThen` do putIO workers future (result, sums)+                                  touchLifetime nativeExecutable+          job2  <- mkJobUsing (Seq.singleton (0, ((), 0), ((), steps))) (nativeExecutable !# "scanP2") gamma aenv dim1 param2 (sums, tmp)+                     `andThen` schedule workers job3+          job1  <- mkJobUsingIndex ranges (nativeExecutable !# "scanP1") gamma aenv dim1 param1 (((steps, result), tmp), manifest input)+                     `andThen` schedule workers job2++          liftIO $ schedule workers job1+  --+  return future++isMultiDim :: ShapeR sh -> Bool+isMultiDim (ShapeRsnoc ShapeRz) = False+isMultiDim _                    = True++-- Forward permutation, specified by an indexing mapping into an array and a+-- combination function to combine elements.+--+{-# INLINE permuteOp #-}+permuteOp+    :: forall sh e sh' aenv. HasCallStack+    => Bool+    -> ArrayR (Array sh e)+    -> ShapeR sh'+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Array sh' e+    -> Delayed (Array sh e)+    -> Par Native (Future (Array sh' e))+permuteOp inplace repr shr' NativeR{..} gamma aenv defaults@(shape -> shOut) input@(delayedShape -> shIn) = do+  let+      ArrayR shr tp = repr+      repr' = ArrayR shr' tp+  Native{..}  <- asks llvmTarget+  future      <- new+  result      <- if inplace+                   then Debug.trace Debug.dump_exec  "exec: permute/inplace"                  $ return defaults+                   else Debug.timed Debug.dump_exec ("exec: permute/clone " % Debug.elapsedS) $ liftPar (cloneArray repr' defaults)+  let+      splits  = numWorkers workers - 1+      minsize = case shr of+                  ShapeRsnoc ShapeRz              -> 4096+                  ShapeRsnoc (ShapeRsnoc ShapeRz) -> 64+                  _                               -> 16+      ranges  = divideWork shr splits minsize (empty shr) shIn (,,)+      steps   = Seq.length ranges+      paramR = TupRsingle (ParamRarray repr') `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr)+  --+  if steps <= 1+    -- sequential execution does not require handling critical sections+    then+      scheduleOpUsing ranges (nativeExecutable !# "permuteS") gamma aenv shr paramR (result, manifest input)+        `andThen` do putIO workers future result+                     touchLifetime nativeExecutable++    -- parallel execution+    else+      case lookupFunction "permuteP_rmw" nativeExecutable of+        -- using atomic operations+        Just f ->+          scheduleOpUsing ranges f gamma aenv shr paramR (result, manifest input)+            `andThen` do putIO workers future result+                         touchLifetime nativeExecutable++        -- uses a temporary array of spin-locks to guard the critical section+        Nothing -> do+          let m           = size shr' shOut+              reprBarrier = ArrayR dim1 $ TupRsingle scalarTypeWord8+              paramR'     = TupRsingle (ParamRarray repr') `TupRpair` TupRsingle (ParamRarray reprBarrier) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr)+          --+          barrier@(Array _ adb) <- allocateRemote reprBarrier ((), m) :: Par Native (Vector Word8)+          liftIO $ memset (unsafeUniqueArrayPtr adb) 0 m+          scheduleOpUsing ranges (nativeExecutable !# "permuteP_mutex") gamma aenv shr paramR' ((result, barrier), manifest input)+            `andThen` do putIO workers future result+                         touchLifetime nativeExecutable+  --+  return future+++{-# INLINE stencil1Op #-}+stencil1Op+    :: HasCallStack+    => TypeR a+    -> ArrayR (Array sh b)+    -> sh+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array sh a)+    -> Par Native (Future (Array sh b))+stencil1Op tp repr halo exe gamma aenv input@(delayedShape -> sh) =+  stencilCore repr exe gamma aenv halo sh (TupRsingle $ ParamRmaybe $ ParamRarray $ ArrayR (arrayRshape repr) tp) (manifest input)++{-# INLINE stencil2Op #-}+stencil2Op+    :: forall aenv sh a b c. HasCallStack+    => TypeR a+    -> TypeR b+    -> ArrayR (Array sh c)+    -> sh+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array sh a)+    -> Delayed (Array sh b)+    -> Par Native (Future (Array sh c))+stencil2Op t1 t2 repr halo exe gamma aenv input1@(delayedShape -> sh1) input2@(delayedShape -> sh2) =+  stencilCore repr exe gamma aenv halo (intersect (arrayRshape repr) sh1 sh2) (param t1 `TupRpair` param t2) (manifest input1, manifest input2)+  where+    shr = arrayRshape repr+    param :: TypeR t -> ParamsR Native (Maybe (Array sh t))+    param = TupRsingle . ParamRmaybe . ParamRarray . ArrayR shr++{-# INLINE stencilCore #-}+stencilCore+    :: forall aenv sh e params. HasCallStack+    => ArrayR (Array sh e)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> sh                       -- border dimensions (i.e. index of first interior element)+    -> sh                       -- output array size+    -> ParamsR Native params+    -> params+    -> Par Native (Future (Array sh e))+stencilCore repr NativeR{..} gamma aenv halo sh paramsR params = do+  Native{..} <- asks llvmTarget+  future     <- new+  result     <- allocateRemote repr sh+  let+      shr     = arrayRshape repr+      inside  = nativeExecutable !# "stencil_inside"+      border  = nativeExecutable !# "stencil_border"++      splits  = numWorkers workers - 1+      minsize = case shr of+                  ShapeRsnoc ShapeRz              -> 4096+                  ShapeRsnoc (ShapeRsnoc ShapeRz) -> 64+                  _                               -> 16++      ins     = divideWork shr splits minsize halo (sub sh halo) (,,)+      outs    = asum . flip fmap (stencilBorders shr sh halo) $ \(u,v) -> divideWork shr splits minsize u v (,,)++      sub :: sh -> sh -> sh+      sub a b = go shr a b+        where+          go :: ShapeR t -> t -> t -> t+          go ShapeRz          ()      ()      = ()+          go (ShapeRsnoc shr') (xa,xb) (ya,yb) = (go shr' xa ya, xb - yb)++      paramsR' = TupRsingle (ParamRarray repr) `TupRpair` paramsR+  --+  jobsInside <- mkTasksUsing ins  inside gamma aenv shr paramsR' (result, params)+  jobsBorder <- mkTasksUsing outs border gamma aenv shr paramsR' (result, params)+  let jobTasks  = jobsInside Seq.>< jobsBorder+      jobDone   = Just $ do putIO workers future result+                            touchLifetime nativeExecutable+  --+  liftIO $ schedule workers =<< timed "stencil" Job{..}+  return future++-- Compute the stencil border regions, where we may need to evaluate the+-- boundary conditions.+--+{-# INLINE stencilBorders #-}+stencilBorders+    :: forall sh. HasCallStack+    => ShapeR sh+    -> sh+    -> sh+    -> Seq (sh, sh)+stencilBorders shr sh halo = Seq.fromFunction (2 * rank shr) face+  where+    face :: Int -> (sh, sh)+    face n = go n shr sh halo++    go :: Int -> ShapeR t -> t -> t -> (t, t)+    go _ ShapeRz          ()         ()         = ((), ())+    go n (ShapeRsnoc shr') (sha, sza) (shb, szb)+      = let+            (sha', shb')  = go (n-2) shr' sha shb+            (sza', szb')+              | n <  0    = (0,       sza)+              | n == 0    = (0,       szb)+              | n == 1    = (sza-szb, sza)+              | otherwise = (szb,     sza-szb)+        in+        ((sha', sza'), (shb', szb'))++{-# INLINE aforeignOp #-}+aforeignOp+    :: HasCallStack+    => String+    -> ArraysR as+    -> ArraysR bs+    -> (as -> Par Native (Future bs))+    -> as+    -> Par Native (Future bs)+aforeignOp name _ _ asm arr = do+  -- TODO: add tracy marks+  Debug.timed Debug.dump_exec (now ("exec: " <> bformat string name <> " ") % Debug.elapsedP) (asm arr)+++-- Skeleton execution+-- ------------------++(!#) :: HasCallStack => Lifetime FunctionTable -> ShortByteString -> Function+(!#) exe name+  = fromMaybe (internalError ("function not found: " % string) (S8.unpack name))+  $ lookupFunction name exe++lookupFunction :: ShortByteString -> Lifetime FunctionTable -> Maybe Function+lookupFunction name nativeExecutable = do+  find (\(n,_) -> SE.take (S.length n - 65) n == name) (functionTable (unsafeGetValue nativeExecutable))++andThen :: (Maybe a -> t) -> a -> t+andThen f g = f (Just g)++delayedShape :: Delayed (Array sh e) -> sh+delayedShape (Delayed sh) = sh+delayedShape (Manifest a) = shape a++manifest :: Delayed (Array sh e) -> Maybe (Array sh e)+manifest (Manifest a) = Just a+manifest Delayed{}    = Nothing+++{-# INLINABLE scheduleOp #-}+scheduleOp+    :: HasCallStack+    => Function+    -> Gamma aenv+    -> Val aenv+    -> ShapeR sh+    -> sh+    -> ParamsR Native params+    -> params+    -> Maybe Action+    -> Par Native ()+scheduleOp fun gamma aenv shr sz paramsR params done = do+  Native{..} <- asks llvmTarget+  let+      splits  = numWorkers workers - 1+      minsize = case shr of+                  ShapeRsnoc ShapeRz              -> 4096+                  ShapeRsnoc (ShapeRsnoc ShapeRz) -> 64+                  _                               -> 16+  --+  scheduleOpWith splits minsize fun gamma aenv shr sz paramsR params done++-- Schedule an operation over the entire iteration space, specifying the number+-- of partitions and minimum dimension size.+--+{-# INLINABLE scheduleOpWith #-}+scheduleOpWith+    :: Int            -- # subdivisions (hint)+    -> Int            -- minimum size of a dimension (must be a power of two)+    -> Function       -- function to execute+    -> Gamma aenv+    -> Val aenv+    -> ShapeR sh+    -> sh+    -> ParamsR Native params+    -> params+    -> Maybe Action   -- run after the last piece completes+    -> Par Native ()+scheduleOpWith splits minsize fun gamma aenv shr sz paramsR params done = do+  Native{..} <- asks llvmTarget+  job        <- mkJob splits minsize fun gamma aenv shr (empty shr) sz paramsR params done+  liftIO $ schedule workers job++{-# INLINABLE scheduleOpUsing #-}+scheduleOpUsing+    :: Seq (Int, sh, sh)+    -> Function+    -> Gamma aenv+    -> Val aenv+    -> ShapeR sh+    -> ParamsR Native params+    -> params+    -> Maybe Action+    -> Par Native ()+scheduleOpUsing ranges fun gamma aenv shr paramsR params jobDone = do+  Native{..} <- asks llvmTarget+  job        <- mkJobUsing ranges fun gamma aenv shr paramsR params jobDone+  liftIO $ schedule workers job++{-# INLINABLE mkJob #-}+mkJob :: Int+      -> Int+      -> Function+      -> Gamma aenv+      -> Val aenv+      -> ShapeR sh+      -> sh+      -> sh+      -> ParamsR Native params+      -> params+      -> Maybe Action+      -> Par Native Job+mkJob splits minsize fun gamma aenv shr from to paramsR params jobDone =+  mkJobUsing (divideWork shr splits minsize from to (,,)) fun gamma aenv shr paramsR params jobDone++{-# INLINABLE mkJobUsing #-}+mkJobUsing+      :: Seq (Int, sh, sh)+      -> Function+      -> Gamma aenv+      -> Val aenv+      -> ShapeR sh+      -> ParamsR Native params+      -> params+      -> Maybe Action+      -> Par Native Job+mkJobUsing ranges fun@(name,_) gamma aenv shr paramsR params jobDone = do+  jobTasks <- mkTasksUsing ranges fun gamma aenv shr paramsR params+  liftIO    $ timed name Job {..}++{-# INLINABLE mkJobUsingIndex #-}+mkJobUsingIndex+      :: Seq (Int, sh, sh)+      -> Function+      -> Gamma aenv+      -> Val aenv+      -> ShapeR sh+      -> ParamsR Native params+      -> params+      -> Maybe Action+      -> Par Native Job+mkJobUsingIndex ranges fun@(name,_) gamma aenv shr paramsR params jobDone = do+  jobTasks <- mkTasksUsingIndex ranges fun gamma aenv shr paramsR params+  liftIO    $ timed name Job {..}++{-# INLINABLE mkTasksUsing #-}+mkTasksUsing+      :: Seq (Int, sh, sh)+      -> Function+      -> Gamma aenv+      -> Val aenv+      -> ShapeR sh+      -> ParamsR Native params+      -> params+      -> Par Native (Seq Action)+mkTasksUsing ranges (name, f) gamma aenv shr paramsR params = do+  (arg, ()) <- marshalParams' @Native (paramsR `TupRpair` TupRsingle (ParamRenv gamma)) (params, aenv)+  return $ flip fmap ranges $ \(_,u,v) -> do+    sched (string % " " % parenthesised string % " -> " % parenthesised string) (S8.unpack name) (showShape shr u) (showShape shr v)+    let argU = marshalShape' @Native shr u+    let argV = marshalShape' @Native shr v+    callFFI f retVoid $ DL.toList $ argU `DL.append` argV `DL.append` arg++{-# INLINABLE mkTasksUsingIndex #-}+mkTasksUsingIndex+      :: Seq (Int, sh, sh)+      -> Function+      -> Gamma aenv+      -> Val aenv+      -> ShapeR sh+      -> ParamsR Native params+      -> params+      -> Par Native (Seq Action)+mkTasksUsingIndex ranges (name, f) gamma aenv shr paramsR params = do+  (arg, ()) <- marshalParams' @Native (paramsR `TupRpair` TupRsingle (ParamRenv gamma)) (params, aenv)+  return $ flip fmap ranges $ \(i,u,v) -> do+    sched (string % " " % parenthesised string % " -> " % parenthesised string) (S8.unpack name) (showShape shr u) (showShape shr v)+    let argU = marshalShape' @Native shr u+    let argV = marshalShape' @Native shr v+    let argI = DL.singleton $ marshalInt @Native i+    callFFI f retVoid $ DL.toList $ argU `DL.append` argV `DL.append` argI `DL.append` arg+++-- Standard C functions+-- --------------------++memset :: Ptr Word8 -> Word8 -> Int -> IO ()+memset p w s = c_memset p (fromIntegral w) (fromIntegral s) >> return ()++foreign import ccall unsafe "string.h memset" c_memset+    :: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8)+++-- Debugging+-- ---------++-- Since the (new) thread scheduler does not operate in block-synchronous mode,+-- it is a bit more difficult to track how long an individual operation took to+-- execute as we won't know when exactly it will begin. The following method+-- (where initial timing information is recorded as the first task) should give+-- reasonable results.+--+-- TLM: missing GC stats information (verbose mode) since we aren't using the+--      the default 'timed' helper.+--+timed :: ShortByteString -> Job -> IO Job+timed name job =+  case Debug.debuggingIsEnabled of+    False -> return job+    True  -> do+      yes     <- Debug.getFlag Debug.dump_exec+      verbose <- Debug.getFlag Debug.verbose+      if yes+        then do+          ref1 <- newIORef 0+          ref2 <- newIORef 0+          let start = do !wall0 <- getMonotonicTime+                         !cpu0  <- getCPUTime+                         writeIORef ref1 wall0+                         writeIORef ref2 cpu0++              end   = do !cpu1  <- getCPUTime+                         !wall1 <- getMonotonicTime+                         !wall0 <- readIORef ref1+                         !cpu0  <- readIORef ref2+                         --+                         let wallTime = wall1 - wall0+                             cpuTime  = fromIntegral (cpu1 - cpu0) * 1E-12+                             name' | verbose   = name+                                   | otherwise = SE.take (S.length name - 65) name+                         --+                         Debug.traceM Debug.dump_exec ("exec: " % string % " " % Debug.elapsedP) (S8.unpack name') wallTime cpuTime+              --+          return $ Job { jobTasks = start Seq.<| jobTasks job+                       , jobDone  = case jobDone job of+                                      Nothing       -> Just end+                                      Just finished -> Just (finished >> end)+                       }+        else+          return job++-- accelerate/cbits/clock.c+foreign import ccall unsafe "clock_gettime_monotonic_seconds" getMonotonicTime :: IO Double+++sched :: Format (IO ()) a -> a+sched fmt =+  runFormat fmt $ \k ->+    Debug.when Debug.verbose $+    Debug.when Debug.dump_sched $ do+      tid <- myThreadId+      Debug.putTraceMsg ("sched: Thread " % int % " " % builder) (getThreadId tid) k+
+ src/Data/Array/Accelerate/LLVM/Native/Execute/Async.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Execute.Async+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.Execute.Async (++  Async(..), Future(..), IVar(..), getArrays,+  evalPar, putIO,++) where++-- accelerate+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.LLVM.Execute.Async+import Data.Array.Accelerate.LLVM.Native.Execute.Scheduler+import Data.Array.Accelerate.LLVM.Native.Target+import Data.Array.Accelerate.LLVM.State++-- standard library+import Control.Concurrent+import Control.Monad.Cont+import Control.Monad.Reader+import Data.IORef+import Data.Sequence                                                ( Seq )+import qualified Data.Sequence                                      as Seq+++-- | Evaluate a parallel computation+--+-- The worker threads execute the computation, while the calling thread+-- effectively sleeps waiting for the result.+--+{-# INLINEABLE evalPar #-}+evalPar :: Par Native a -> LLVM Native a+evalPar work = do+  result <- liftIO newEmptyMVar+  runContT (runPar work) (liftIO . putMVar result)+  liftIO $ takeMVar result++  -- XXX: Running the initial computation on the worker threads can lead to the+  -- workers becoming blocked, possibly waiting for the result MVars to be+  -- filled from previous (lazily evaluated) computations (speculation). This+  -- happened for example with the code from Issue255, when extracting the+  -- result at index > number of worker threads.+  --+  -- liftIO  $ do+  --   schedule (workers native)+  --     Job { jobTasks = Seq.singleton $ evalLLVM native (runContT (runPar work) (liftIO . putMVar result))+  --         , jobDone  = Nothing+  --         }+  --   takeMVar result+++-- Implementation+-- --------------++data Future a = Future {-# UNPACK #-} !(IORef (IVar a))++data IVar a+    = Full    !a+    | Blocked !(Seq (a -> IO ()))+    | Empty++instance Async Native where+  type FutureR Native  = Future+  newtype Par Native a = Par { runPar :: ContT () (LLVM Native) a }+    deriving ( Functor, Applicative, Monad, MonadIO, MonadCont, MonadReader Native )++  {-# INLINE new     #-}+  {-# INLINE newFull #-}+  new       = Future <$> liftIO (newIORef Empty)+  newFull v = Future <$> liftIO (newIORef (Full v))++  {-# INLINE fork  #-}+  {-# INLINE spawn #-}+  fork  = id+  spawn = id++  {-# INLINE get #-}+  get (Future ref) =+    callCC $ \k -> do+      native <- asks llvmTarget+      next   <- liftIO . atomicModifyIORef' ref $ \case+                  Empty      -> (Blocked (Seq.singleton (evalParIO native . k)), reschedule)+                  Blocked ks -> (Blocked (ks Seq.|>      evalParIO native . k),  reschedule)+                  Full a     -> (Full a,                                         return a)+      next++  {-# INLINE put #-}+  put future ref = do+    Native{..} <- asks llvmTarget+    liftIO (putIO workers future ref)++  {-# INLINE liftPar #-}+  liftPar = Par . lift++-- | Evaluate a continuation+--+{-# INLINE evalParIO #-}+evalParIO :: Native -> Par Native () -> IO ()+evalParIO native@Native{} work =+  evalLLVM native (runContT (runPar work) return)++-- | The value represented by a future is now available. Push any blocked+-- continuations to the worker threads.+--+{-# INLINEABLE putIO #-}+putIO :: HasCallStack => Workers -> Future a -> a -> IO ()+putIO workers (Future ref) v = do+  ks <- atomicModifyIORef' ref $ \case+          Empty      -> (Full v, Seq.empty)+          Blocked ks -> (Full v, ks)+          _          -> internalError "multiple put"+  --+  schedule workers Job { jobTasks = fmap ($ v) ks+                       , jobDone  = Nothing+                       }++-- | The worker threads should search for other work to execute+--+{-# INLINE reschedule #-}+reschedule :: Par Native a+reschedule = Par $ ContT (\_ -> return ())+++-- reschedule :: Par Native a+-- reschedule = Par $ ContT (const loop)+--   where+--     loop :: ReaderT Schedule (LLVM Native) ()+--     loop = do+--       queue <- ask+--       mwork <- liftIO $ tryPopR queue+--       case mwork of+--         Just work -> runContT (runPar work) (const loop)+--         Nothing   -> liftIO yield >> loop++-- pushL :: MVar (Seq a) -> a -> IO ()+-- pushL ref a =+--   mask_ $ do+--     ma <- tryTakeMVar ref+--     case ma of+--       Nothing -> putMVar ref (Seq.singleton a)+--       Just as -> putMVar ref (a Seq.<| as)++-- popR :: MVar (Seq a) -> IO a+-- popR ref = do+--   q <- takeMVar ref+--   case Seq.viewr q of+--     Seq.EmptyR  -> popR ref   -- should be impossible+--     as Seq.:> a -> putMVar ref as >> return a+
+ src/Data/Array/Accelerate/LLVM/Native/Execute/Divide.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE PatternGuards       #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Execute.Divide+-- Copyright   : [2018..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.Execute.Divide (++  divideWork, divideWork1++) where++import Data.Array.Accelerate.Representation.Shape++import Data.Bits+import Data.Sequence                                                ( Seq )+import qualified Data.Sequence                                      as Seq+import qualified Data.Vector.Unboxed                                as U+import qualified Data.Vector.Unboxed.Mutable                        as M+++-- Divide the given multidimensional index range into a sequence of work pieces.+-- Splits will be made on the outermost (left-most) index preferentially, so+-- that spans are longest on the innermost dimension (because caches).+--+-- No dimension will be made smaller than the given minimum.+--+-- The number of subdivisions a hint (at most, it should generate a number of+-- pieces rounded up to the next power-of-two).+--+-- Full pieces will occur first in the resulting sequence, with smaller pieces+-- at the end (suitable for work-stealing). Note that the pieces are not sorted+-- according by size, and are ordered in the resulting sequence depending only+-- on whether all dimensions are above the minimum threshold or not. The integer+-- parameter to the apply action can be used to access the chunks linearly (for+-- example, this is useful when evaluating non-commutative operations).+--+-- {-# INLINABLE divideWork #-}+divideWork+    :: ShapeR sh+    -> Int                        -- #subdivisions (hint)+    -> Int                        -- minimum size of a dimension (must be a power of two)+    -> sh                         -- start index (e.g. top-left)+    -> sh                         -- end index   (e.g. bottom-right)+    -> (Int -> sh -> sh -> a)     -- action given start/end index range, and split number in the range [0..]+    -> Seq a+divideWork ShapeRz              = divideWork0+divideWork (ShapeRsnoc ShapeRz) = divideWork1+divideWork shr                  = divideWorkN shr+  --+  -- It is slightly faster to use lists instead of a Sequence here (though the+  -- difference is <1us on 'divideWork empty (Z:.2000) nop 8 32'). However,+  -- later operations will benefit from more efficient append, etc.++divideWork0 :: Int -> Int -> DIM0 -> DIM0 -> (Int -> DIM0 -> DIM0 -> a) -> Seq a+divideWork0 _ _ () () action = Seq.singleton (action 0 () ())++divideWork1 :: Int -> Int -> DIM1 -> DIM1 -> (Int -> DIM1 -> DIM1 -> a) -> Seq a+divideWork1 !n !minsize ((), (!from)) ((), (!to)) action =+  let+      split 0 !u !v !i !f !s+        | v - u < minsize = (i+1, f, s Seq.|> apply i u v)+        | otherwise       = (i+1, f Seq.|> apply i u v, s)+      --+      split !s !u !v !i0 !f0 !s0 =+        case findSplitPoint1 u v minsize of+          Nothing       -> (i0+1, f0, s0 Seq.|> apply i0 u v)+          Just (u', v') ->+            let s'         = unsafeShiftR s 1+                (i1,f1,s1) = split s' u  v' i0 f0 s0+                (i2,f2,s2) = split s' u' v  i1 f1 s1+            in+            (i2, f2, s2)++      apply i u v = action i ((), u) ((), v)+      (_, fs, ss) = split n from to 0 Seq.empty Seq.empty+  in+  fs Seq.>< ss++{-# INLINE findSplitPoint1 #-}+findSplitPoint1+    :: Int+    -> Int+    -> Int+    -> Maybe (Int, Int)+findSplitPoint1 !u !v !minsize =+  let a = v - u in+  if a <= minsize+    then Nothing+    else+      let b = unsafeShiftR (a+1) 1+          c = minsize - 1+          d = (b+c) .&. complement c+      in+      Just (d+u, v-a+d)+++divideWorkN :: ShapeR sh -> Int -> Int -> sh -> sh -> (Int -> sh -> sh -> a) -> Seq a+divideWorkN !shr !n !minsize !from !to action =+  let+      -- Is it worth checking whether the piece is full? Doing so ensures that+      -- full pieces are assigned to threads first, with the non-full blocks+      -- being the ones at the end of the work queue to be stolen.+      --+      split 0 !u !v !i !f !s+        | U.any (< minsize) (U.zipWith (-) v u) = (i+1, f, s Seq.|> apply i u v)+        | otherwise                             = (i+1, f Seq.|> apply i u v, s)+      --+      split !s !u !v !i0 !f0 !s0 =+        case findSplitPointN u v minsize of+          Nothing       -> (i0+1, f0, s0 Seq.|> apply i0 u v)+          Just (u', v') ->+            let s'      = unsafeShiftR s 1+                (i1,f1,s1) = split s' u  v' i0 f0 s0+                (i2,f2,s2) = split s' u' v  i1 f1 s1+            in+            (i2, f2, s2)++      apply i u v = action i (vecToShape shr u) (vecToShape shr v)+      (_, fs, ss) = split n (shapeToVec shr from) (shapeToVec shr to) 0 Seq.empty Seq.empty+  in+  fs Seq.>< ss+++-- Determine if and where to split the given index range. Returns new start and+-- end indices if found.+--+{-# INLINE findSplitPointN #-}+findSplitPointN+    :: U.Vector Int           -- start+    -> U.Vector Int           -- end+    -> Int                    -- minimum size of a dimension (must be power of 2)+    -> Maybe (U.Vector Int, U.Vector Int)+findSplitPointN !from !to !minsize =+  let+      mix = U.ifoldr' combine Nothing+          $ U.zipWith (-) to from++      combine i v old =+        if v <= minsize+          then old+          else case old of+                 Nothing    -> Just (i,v)+                 Just (_,u) -> if v < u+                                 then Just (i,v)+                                 else old+  in+  case mix of+    Nothing     -> Nothing+    Just (i,a)  ->+      let b     = unsafeShiftR (a+1) 1    -- divide by 2 (rounded up)+          c     = minsize - 1+          d     = (b+c) .&. complement c  -- round up to next multiple of chunk size+          e     = U.unsafeIndex from i+          f     = U.unsafeIndex to   i+          --+          from' = U.modify (\mv -> M.unsafeWrite mv i (d+e))   from+          to'   = U.modify (\mv -> M.unsafeWrite mv i (f-a+d)) to+      in+      Just (from', to')++{-# INLINE vecToShape #-}+vecToShape :: ShapeR sh -> U.Vector Int -> sh+vecToShape shr = listToShape shr . U.toList++{-# INLINE shapeToVec #-}+shapeToVec :: ShapeR sh -> sh -> U.Vector Int+shapeToVec shr sh = U.fromListN (rank shr) (shapeToList shr sh)+
+ src/Data/Array/Accelerate/LLVM/Native/Execute/Environment.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE GADTs #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Execute.Environment+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.Execute.Environment (++  module Data.Array.Accelerate.LLVM.Execute.Environment,+  module Data.Array.Accelerate.LLVM.Native.Execute.Environment,++) where++import Data.Array.Accelerate.LLVM.Native.Target+import Data.Array.Accelerate.LLVM.Execute.Environment++type Val = ValR Native+
+ src/Data/Array/Accelerate/LLVM/Native/Execute/Marshal.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TupleSections         #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Execute.Marshal+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.Execute.Marshal ( module M )+  where++import Data.Array.Accelerate.LLVM.Execute.Marshal               as M+import Data.Array.Accelerate.Array.Unique++import Data.Array.Accelerate.LLVM.Native.Execute.Async          () -- instance Async Native+import Data.Array.Accelerate.LLVM.Native.Target++import Data.Bits+import qualified Data.DList                                     as DL+import qualified Foreign.LibFFI                                 as FFI+++instance Marshal Native where+  type ArgR Native = FFI.Arg+  type MarshalCleanup Native = ()+  marshalInt = $( case finiteBitSize (undefined::Int) of+                    32 -> [| FFI.argInt32 . fromIntegral |]+                    64 -> [| FFI.argInt64 . fromIntegral |]+                    _  -> error "I don't know what architecture I am" )+  marshalScalarData' _ = return . (,()) . DL.singleton . FFI.argPtr . unsafeUniqueArrayPtr+
+ src/Data/Array/Accelerate/LLVM/Native/Execute/Scheduler.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE MagicHash           #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE UnboxedTuples       #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Execute.Scheduler+-- Copyright   : [2018..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.Execute.Scheduler (++  Action, Job(..), Workers,++  schedule,+  hireWorkers, hireWorkersOn, retireWorkers, fireWorkers, numWorkers,++) where++import qualified Data.Array.Accelerate.LLVM.Native.Debug            as Debug++import Control.Concurrent+import Control.Concurrent.Extra+import Control.DeepSeq+import Control.Exception+import Control.Monad+import Data.Concurrent.Queue.MichaelScott+import Data.IORef+import Data.Int+import Data.Sequence                                                ( Seq )+import Formatting+import qualified Data.Sequence                                      as Seq++import GHC.Base                                                     hiding ( build )++#include "MachDeps.h"+++-- An individual computation is a job consisting of a sequence of actions to be+-- executed by the worker threads in parallel.+--+type Action = IO ()++data Task+  = Work Action+  | Retire++data Job = Job+  { jobTasks  :: !(Seq Action)    -- actions required to complete this job+  , jobDone   :: !(Maybe Action)  -- execute after the last action is completed+  }++data Workers = Workers+  { workerCount       :: {-# UNPACK #-} !Int                      -- number of worker threads (length workerThreadIds)+  , workerActive      :: {-# UNPACK #-} !(IORef (MVar ()))        -- fill to signal to the threads to wake up+  , workerTaskQueue   :: {-# UNPACK #-} !(LinkedQueue Task)       -- tasks currently being executed; may be from different jobs+  , workerThreadIds   :: ![ThreadId]                              -- to send signals to / kill+  , workerException   :: !(MVar (Seq (ThreadId, SomeException)))  -- XXX: what should we do with these?+  }+++-- Schedule a job to be executed by the worker threads. May be called+-- concurrently.+--+{-# INLINEABLE schedule #-}+schedule :: Workers -> Job -> IO ()+schedule workers Job{..} = do+  -- Generate the work list. If there is a finalisation action, there is a bit+  -- of extra work to do at each step.+  --+  tasks <- case jobDone of+             Nothing    -> return $ fmap Work jobTasks+             Just done  -> do+                -- The thread which finishes the last task runs the finalisation+                -- action, so keep track of how many items have been completed.+                --+                count <- newAtomic (Seq.length jobTasks)+                return $ flip fmap jobTasks $ \io -> Work $ do+                  _result   <- io+                  remaining <- fetchSubAtomic count -- returns old value+                  when (remaining == 1) done++  -- Submit the tasks to the queue to be executed by the worker threads.+  --+  pushTasks workers tasks+++-- Workers can either be executing tasks (real work), waiting for work, or+-- going into retirement (whence the thread will exit).+--+-- So that threads don't spin endlessly on an empty queue waiting for work,+-- they will automatically sleep waiting on the signal MVar after several+-- failed retries. Note that 'readMVar' is multiple wake up, so all threads+-- will be efficiently woken up when new work is added via 'submit'.+--+-- The MVar is stored in an IORef. When scheduling new work, we resolve the+-- old MVar by putting a value in it, and we put a new, at that moment+-- unresolved, MVar in the IORef. If the queue is empty in runWorker, then+-- we will after some attempts wait on an MVar. It is essential that we+-- first get the MVar out of the IORef, before trying to read from the+-- queue. If this would have been done the other way around, we could have+-- a race condition, where new work is pushed after we tried to dequeue+-- work and before we wait on an MVar. We then wait on the new MVar, which+-- may cause that this thread stalls forever.+--+runWorker :: ThreadId -> IORef (MVar ()) -> LinkedQueue Task -> IO ()+runWorker tid ref queue = loop 0+  where+    loop :: Int16 -> IO ()+    loop !retries = do+      -- Extract the activation MVar from the IORef, before trying to claim+      -- an item from the work queue+      var <- readIORef ref+      req <- tryPopR queue+      case req of+        -- The number of retries and thread delay on failure are knobs which can+        -- be tuned. Having these values too high results in busy work which+        -- will detract from time spent adding new work thus reducing+        -- productivity, whereas low values will reduce responsiveness and thus+        -- also reduce productivity.+        --+        -- TODO: Tune these values a bit+        --+        Nothing   -> if retries < 16+                       then loop (retries+1)+                       else do+                         -- This thread will sleep, by waiting on the MVar (var) we previously+                         -- extracted from the IORef (ref)+                         --+                         -- When some other thread pushes new work, it will also write to that MVar+                         -- and this thread will wake up.+                         message ("sched: Thread " % int % " sleeping") (getThreadId tid)++                         -- blocking, wake-up when new work is available+                         () <- readMVar var+                         loop 0+        --+        Just task -> case task of+                       Work io -> io >> loop 0+                       Retire  -> message ("sched: Thread " % int % " shutting down") (getThreadId tid)+++-- Spawn a new worker thread for each capability+--+hireWorkers :: IO Workers+hireWorkers = do+  ncpu    <- getNumCapabilities+  workers <- hireWorkersOn [0 .. ncpu-1]+  return workers++-- Spawn worker threads on the specified capabilities+--+hireWorkersOn :: [Int] -> IO Workers+hireWorkersOn caps = do+  active          <- newEmptyMVar+  workerActive    <- newIORef active+  workerException <- newEmptyMVar+  workerTaskQueue <- newQ+  workerThreadIds <- forM caps $ \cpu -> do+                       tid <- mask_ $ forkOnWithUnmask cpu $ \restore -> do+                                tid <- myThreadId+                                catch+                                  (restore $ runWorker tid workerActive workerTaskQueue)+                                  (appendMVar workerException . (tid,))+                       --+                       message ("sched: fork Thread " % int % " on capability " % int) (getThreadId tid) cpu+                       return tid+  --+  workerThreadIds `deepseq` return Workers { workerCount = length workerThreadIds, ..}+++-- Submit a job telling every worker to retire. Currently pending tasks will be+-- completed first.+--+retireWorkers :: Workers -> IO ()+retireWorkers workers@Workers{..} =+  pushTasks workers (Seq.replicate workerCount Retire)+++-- Pushes work to the task queue+--+-- Wakes up the worker threads if needed, by writing to the old MVar in+-- workerActive. We replace workerActive with a new, empty MVar, such that+-- we can wake them up later when we again have new work.+--+pushTasks :: Workers -> Seq Task -> IO ()+pushTasks Workers{..} tasks = do+  -- Push work to the queue+  mapM_ (pushL workerTaskQueue) tasks++  -- Create a new MVar, which we use in a later call to pushTasks to wake+  -- up the threads, then swap the MVar in the IORef workerActive, with the+  -- new MVar.+  --+  -- This must be atomic, to prevent race conditions when two threads are+  -- adding new work. Without the atomic, it may occur that some MVar is+  -- never resolved, causing that a worker thread which waits on that MVar+  -- to stall.+  new <- newEmptyMVar+  old <- atomicModifyIORef' workerActive (new,)++  -- Resolve the old MVar to wake up all waiting threads+  putMVar old ()+++-- Kill worker threads immediately.+--+fireWorkers :: Workers -> IO ()+fireWorkers Workers{..} =+  mapM_ killThread workerThreadIds++-- Number of workers+--+numWorkers :: Workers -> Int+numWorkers = workerCount+++-- Utility+-- -------++data Atomic = Atomic !(MutableByteArray# RealWorld)++{-# INLINE newAtomic #-}+newAtomic :: Int -> IO Atomic+newAtomic (I# n#) = IO $ \s0 ->+  case SIZEOF_HSINT                 of { I# size#       ->+  case newByteArray# size# s0       of { (# s1, mba# #) ->+  case writeIntArray# mba# 0# n# s1 of { s2             ->  -- non-atomic is ok+    (# s2, Atomic mba# #) }}}++{-# INLINE fetchSubAtomic #-}+fetchSubAtomic :: Atomic -> IO Int+fetchSubAtomic (Atomic mba#) = IO $ \s0 ->+  case fetchSubIntArray# mba# 0# 1# s0 of { (# s1, old# #) ->+    (# s1, I# old# #) }++{-# INLINE appendMVar #-}+appendMVar :: MVar (Seq a) -> a -> IO ()+appendMVar mvar a =+  mask_ $ do+    ma <- tryTakeMVar mvar+    case ma of+      Nothing -> putMVar mvar (Seq.singleton a)+      Just as -> putMVar mvar (as Seq.|> a)+++-- Debug+-- -----++{-# INLINE message #-}+message :: Format (IO ()) a -> a+message = Debug.traceM Debug.dump_sched+
+ src/Data/Array/Accelerate/LLVM/Native/Foreign.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving  #-}+{-# LANGUAGE TypeApplications    #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Foreign+-- Copyright   : [2016..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.Foreign (++  -- Foreign functions+  ForeignAcc(..),+  ForeignExp(..),++  -- useful re-exports+  LLVM,+  Native(..),+  liftIO,+  module Data.Array.Accelerate.LLVM.Native.Array.Data,+  module Data.Array.Accelerate.LLVM.Native.Execute.Async,++) where++import qualified Data.Array.Accelerate.Sugar.Foreign                as S++import Data.Array.Accelerate.LLVM.State+import Data.Array.Accelerate.LLVM.CodeGen.Sugar++import Data.Array.Accelerate.LLVM.Foreign+import Data.Array.Accelerate.LLVM.Native.Array.Data+import Data.Array.Accelerate.LLVM.Native.Execute.Async+import Data.Array.Accelerate.LLVM.Native.Target++import Control.Monad.State+import Data.Typeable+++instance Foreign Native where+  foreignAcc (ff :: asm (a -> b))+    | Just Refl        <- eqT @asm @ForeignAcc+    , ForeignAcc _ asm <- ff = Just asm+    | otherwise              = Nothing++  foreignExp (ff :: asm (x -> y))+    | Just Refl        <- eqT @asm @ForeignExp+    , ForeignExp _ asm <- ff = Just asm+    | otherwise              = Nothing++instance S.Foreign ForeignAcc where+  strForeign (ForeignAcc s _) = s++instance S.Foreign ForeignExp where+  strForeign (ForeignExp s _) = s+++-- Foreign functions in the Native backend.+--+-- This is just some arbitrary monadic computation.+--+data ForeignAcc f where+  ForeignAcc :: String+             -> (a -> Par Native (Future b))+             -> ForeignAcc (a -> b)++-- Foreign expressions in the Native backend.+--+-- I'm not sure how useful this is; perhaps we want a way to splice in an+-- arbitrary llvm-hs term, which would give us access to instructions not+-- currently encoded in Accelerate (i.e. SIMD operations, struct types, etc.)+--+data ForeignExp f where+  ForeignExp :: String+             -> IRFun1 Native () (x -> y)+             -> ForeignExp (x -> y)++deriving instance Typeable ForeignAcc+deriving instance Typeable ForeignExp+
+ src/Data/Array/Accelerate/LLVM/Native/Link.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TypeFamilies      #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Link+-- Copyright   : [2017..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.Link (++  module Data.Array.Accelerate.LLVM.Link,+  module Data.Array.Accelerate.LLVM.Native.Link,+  ExecutableR(..), FunctionTable(..), Function, ObjectCode,++) where++import Data.Array.Accelerate.Lifetime++import Data.Array.Accelerate.LLVM.Compile+import Data.Array.Accelerate.LLVM.Link+import Data.Array.Accelerate.LLVM.State++import Data.Array.Accelerate.LLVM.Native.Target+import Data.Array.Accelerate.LLVM.Native.Compile++import Data.Array.Accelerate.LLVM.Native.Link.Cache+import Data.Array.Accelerate.LLVM.Native.Link.Object+import Data.Array.Accelerate.LLVM.Native.Link.Runtime++import Control.Monad.Reader+import Prelude                                                      hiding ( lookup )+++instance Link Native where+  data ExecutableR Native = NativeR { nativeExecutable :: {-# UNPACK #-} !(Lifetime FunctionTable)+                                    }+  linkForTarget = link+++-- | Link to the generated shared object file, creating function pointers for+-- every kernel's entry point.+--+link :: ObjectR Native -> LLVM Native (ExecutableR Native)+link (ObjectR uid nms _ so) = do+  cache <- asks linkCache+  funs  <- liftIO $ dlsym uid cache (loadSharedObject nms so)+  return $! NativeR funs+++-- | Execute some operation with the supplied executable functions+--+withExecutable :: MonadIO m => ExecutableR Native -> (FunctionTable -> m b) -> m b+withExecutable NativeR{..} f = do+  r <- f (unsafeGetValue nativeExecutable)+  liftIO $ touchLifetime nativeExecutable+  return r+
+ src/Data/Array/Accelerate/LLVM/Native/Link/Cache.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE CPP #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Link.Cache+-- Copyright   : [2017..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.Link.Cache (++  LinkCache,+  new, LC.dlsym,++) where++import Data.Array.Accelerate.Debug.Internal                         ( tracyIsEnabled )++import Data.Array.Accelerate.LLVM.Native.Link.Object+import qualified Data.Array.Accelerate.LLVM.Link.Cache              as LC++import Control.Monad++#if defined(mingw32_HOST_OS)+import System.Win32.DLL+#else+import System.Posix.DynamicLinker+#endif++type LinkCache = LC.LinkCache FunctionTable ObjectCode++new :: IO LinkCache+new = do+  -- For whatever reason ghci isn't adding library dependencies to the+  -- dynamic link state, which means that dynamic linking will fail in+  -- tracy mode because we depend on tracy symbols exported by the+  -- accelerate library. This brings those symbols into scope so that they+  -- can be found by later calls to dlsym().+  --+  -- Additionally, the Accelerate library has been compiled with -rdynamic+  -- in order to bring all exported symbols into the global symbol table.+  -- This seems to be required so that dlsym() can find symbols from the+  -- GHC RTS when we are in compiled (not interpreted) mode. In non-ghci+  -- mode, loading the RTS dynamic library explicitly (as we do with the+  -- Accelerate library) causes segfaults; possibly because the RTS was+  -- otherwise linked statically into the executable.+  --+  -- Because the accelerate library lives somewhere in ~/.cabal/..., this+  -- hack prevents executables from running on any other machine than the+  -- one they were built on. Fortunately, this happens only in tracy mode.+  --+  when tracyIsEnabled $ void $+#if defined(mingw32_HOST_OS)+    loadLibrary ACCELERATE_DYLD_LIBRARY_PATH+#else+    dlopen ACCELERATE_DYLD_LIBRARY_PATH [RTLD_LAZY, RTLD_GLOBAL]+#endif+  LC.new
+ src/Data/Array/Accelerate/LLVM/Native/Link/Object.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE CPP #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Link.Object+-- Copyright   : [2017..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.Link.Object+  where++import Data.List+import Foreign.Ptr+import Formatting++import Data.ByteString.Short.Char8                                  ( ShortByteString, unpack )+import Data.Array.Accelerate.Lifetime++#if defined(mingw32_HOST_OS)+import System.Win32.Types+#else+import System.Posix.DynamicLinker+#endif+++-- | The function table is a list of function names together with a pointer in+-- the target address space containing the corresponding executable code.+--+data FunctionTable  = FunctionTable { functionTable :: [Function] }+type Function       = (ShortByteString, FunPtr ())++instance Show FunctionTable where+  showsPrec _ f+    = showString "<<"+    . showString (intercalate "," [ unpack n | (n,_) <- functionTable f ])+    . showString ">>"++formatFunctionTable :: Format r (FunctionTable -> r)+formatFunctionTable = later $ \f ->+  bformat (angled (angled (commaSep string))) [ unpack n | (n,_) <- functionTable f ]++-- | Object code consists of a handle to dynamically loaded code, managed+-- by the system linker.+--+type ObjectCode    = Lifetime LibraryHandle++#if defined(mingw32_HOST_OS)+type LibraryHandle = HINSTANCE+#else+type LibraryHandle = DL+#endif+
+ src/Data/Array/Accelerate/LLVM/Native/Link/Runtime.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Link.Runtime+-- Copyright   : [2022] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- Utilities for linking object code to shared objects and loading those+-- generated shared objects on Unix-like systems.+--++module Data.Array.Accelerate.LLVM.Native.Link.Runtime (++  loadSharedObject++) where++import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Lifetime++import Data.Array.Accelerate.LLVM.Native.Link.Object+import qualified Data.Array.Accelerate.LLVM.Native.Debug            as Debug++import Control.Monad+import Data.ByteString.Short.Char8                                  ( ShortByteString )+import Formatting+import qualified Data.ByteString.Short.Char8                        as B8++#if defined(mingw32_HOST_OS)+import Foreign.Ptr                                                  ( castPtrToFunPtr )+import System.Win32.DLL+#else+import System.Posix.DynamicLinker+#endif+++-- Dynamic object loading+-- ----------------------++-- Load the shared object file and return pointers to the executable+-- functions defined within+--+loadSharedObject :: HasCallStack => [ShortByteString] -> FilePath -> IO (FunctionTable, ObjectCode)+loadSharedObject nms path = do+#if defined(mingw32_HOST_OS)+  -- shims for win32 api compatibility+  let dlopen' path' = loadLibrary path'+      dlsym dll sym = castPtrToFunPtr <$> getProcAddress dll sym+      dlclose dll   = freeLibrary dll+#else+  let dlopen' path' = dlopen path' [RTLD_LAZY, RTLD_LOCAL]+#endif+  --+  so      <- dlopen' path+  fun_tab <- fmap FunctionTable $ forM nms $ \nm -> do+    let s = B8.unpack nm+    Debug.traceM Debug.dump_ld ("ld: looking up symbol " % string) s+    sym <- dlsym so s+    return (nm, sym)++  object_code <- newLifetime so+  addFinalizer object_code $ do+    -- XXX: Should we disable unloading objects in tracy mode? Tracy might+    -- still need access to e.g. embedded string data+    Debug.traceM Debug.dump_gc ("gc: unload module: " % formatFunctionTable) fun_tab+    dlclose so++  return (fun_tab, object_code)+
+ src/Data/Array/Accelerate/LLVM/Native/Plugin.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE CPP             #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-unused-imports   #-}+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Plugin+-- Copyright   : [2017..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.Plugin (++  plugin,++) where++import Data.Array.Accelerate.Error+import Data.Array.Accelerate.LLVM.Native.Plugin.Annotation+import Data.Array.Accelerate.LLVM.Native.Plugin.BuildInfo++import Control.Monad+import Data.IORef+import Data.List+import qualified Data.Map                                           as Map++#if __GLASGOW_HASKELL__ >= 902+import GHC.Driver.Backend+#if __GLASGOW_HASKELL__ < 910+import GHC.Linker+#endif+import GHC.Linker.Loader                                            ( loadCmdLineLibs )+import GHC.Plugins+import GHC.Runtime.Interpreter+#elif __GLASGOW_HASKELL__ >= 900+import GHC.Plugins+import GHC.Runtime.Linker+#else+import GhcPlugins+import Linker+import SysTools+#endif+++-- | This GHC plugin is required to support ahead-of-time compilation for the+-- accelerate-llvm-native backend. In particular, it tells GHC about the+-- additional object files generated by+-- 'Data.Array.Accelerate.LLVM.Native.runQ'* which must be linked into the final+-- executable.+--+-- This plugin is automatically installed when using runQ. In older versions of+-- GHC, it was necessary to manually add the plugin using:+--+-- > ghc-options: -fplugin=Data.Array.Accelerate.LLVM.Native.Plugin+--+-- That is no longer needed.++--+plugin :: Plugin+plugin = defaultPlugin+  { installCoreToDos = install+#if __GLASGOW_HASKELL__ >= 806+  , pluginRecompile  = purePlugin+#endif+  }++install :: HasCallStack => [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]+install _ rest = do+  let this (CoreDoPluginPass "accelerate-llvm-native" _) = True+      this _                                             = False+  --+  return $ CoreDoPluginPass "accelerate-llvm-native" pass : filter (not . this) rest++pass :: HasCallStack => ModGuts -> CoreM ModGuts+pass guts = do+  -- Gather annotations for the extra object files which must be supplied to the+  -- linker in order to complete the current module.+  --+  this  <- getModule+  paths <- nub . concat <$> mapM (objectPaths guts) (mg_binds guts)++  unless (null paths)+    $ debugTraceMsg+    $ hang (text "Data.Array.Accelerate.LLVM.Native.Plugin: linking module" <+> quotes (pprModule this) <+> text "with:") 2 (vcat (map text paths))++  -- The linking method depends on the current build target+  -- TODO: Need to update for ghc-8.6: the Backend data type is now abstract+  --+  -- Determine the current build environment+  --+  hscEnv   <- getHscEnv+  dynFlags <- getDynFlags++#if __GLASGOW_HASKELL__ >= 902+  let target = backend dynFlags+#else+  let target = hscTarget dynFlags+#endif++  when (backendGeneratesCode target) $+    if backendWritesFiles target+      then do+        -- The compiler will write files (interface files and object code). This+        -- is true of "real" backends, i.e. not the interpreter.+#if __GLASGOW_HASKELL__ < 806+        -- Because of separate compilation, we will only encounter the annotation+        -- pragmas on files which have changed between invocations. This applies to+        -- both @ghc --make@ as well as the separate compile/link phases of building+        -- with @cabal@ (and @stack@). Note that whenever _any_ file is updated we+        -- must make sure that the linker options contains the complete list of+        -- objects required to build the entire project.+        --++        -- Read the object file index and update (we may have added or removed+        -- objects for the given module)+        --+        let buildInfo = mkBuildInfoFileName (objectMapPath dynFlags)+        abi <- readBuildInfo buildInfo+        --+        let abi'      = if null paths+                          then Map.delete this       abi+                          else Map.insert this paths abi+            allPaths  = nub (concat (Map.elems abi'))+            allObjs   = map optionOfPath allPaths+        --+        writeBuildInfo buildInfo abi'++        -- Make sure the linker flags are up-to-date.+        --+        unless (isNoLink (ghcLink dynFlags)) $ do+          linker_info <- getLinkerInfo dynFlags+          writeIORef (rtldInfo dynFlags)+            $ Just+            $ case linker_info of+                GnuLD     opts -> GnuLD     (nub (opts ++ allObjs))+                GnuGold   opts -> GnuGold   (nub (opts ++ allObjs))+                DarwinLD  opts -> DarwinLD  (nub (opts ++ allObjs))+                SolarisLD opts -> SolarisLD (nub (opts ++ allObjs))+                AixLD     opts -> AixLD     (nub (opts ++ allObjs))+                LlvmLLD   opts -> LlvmLLD   (nub (opts ++ allObjs))+                UnknownLD      -> UnknownLD  -- no linking performed?+#endif+        return ()++      else+        -- We are in interactive mode (ghci)+        --+        unless (null paths) . liftIO $ do+          let opts  = ldInputs dynFlags+              objs  = map optionOfPath paths+          --+#if __GLASGOW_HASKELL__ >= 902+          loadCmdLineLibs (hscInterp hscEnv)+                 $ hscEnv { hsc_dflags = dynFlags { ldInputs = opts ++ objs }}+#else+          linkCmdLineLibs+                 $ hscEnv { hsc_dflags = dynFlags { ldInputs = opts ++ objs }}+#endif+  return guts++#if __GLASGOW_HASKELL__ < 906+backendGeneratesCode :: Backend -> Bool+backendGeneratesCode NoBackend = False+backendGeneratesCode _         = True++backendWritesFiles :: Backend -> Bool+backendWritesFiles Interpreter = False+backendWritesFiles _           = True+#endif++objectPaths :: ModGuts -> CoreBind -> CoreM [FilePath]+objectPaths guts (NonRec b _) = objectAnns guts b+objectPaths guts (Rec bs)     = concat <$> mapM (objectAnns guts . fst) bs++objectAnns :: ModGuts -> CoreBndr -> CoreM [FilePath]+objectAnns guts bndr = do+  anns  <- getAnnotations deserializeWithData guts+#if __GLASGOW_HASKELL__ >= 900+  return [ path | Object path <- lookupWithDefaultUFM (snd anns) [] (varName bndr) ]+#else+  return [ path | Object path <- lookupWithDefaultUFM anns       [] (varUnique bndr) ]+#endif++objectMapPath :: DynFlags -> FilePath+objectMapPath DynFlags{..}+  | Just p <- objectDir = p+  | Just p <- dumpDir   = p+  | otherwise           = "."++optionOfPath :: FilePath -> Option+optionOfPath = FileOption []+
+ src/Data/Array/Accelerate/LLVM/Native/Plugin/Annotation.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE DeriveDataTypeable #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Plugin.Annotation+-- Copyright   : [2017..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- 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)+
+ src/Data/Array/Accelerate/LLVM/Native/Plugin/BuildInfo.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Plugin.BuildInfo+-- Copyright   : [2017..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.Plugin.BuildInfo+  where++#if __GLASGOW_HASKELL__ >= 900+import GHC.Unit+import GHC.Utils.Binary+#else+import Binary+import Module+#endif++import Data.Map                                                     ( Map )+import System.Directory+import System.FilePath+import qualified Data.Map                                           as Map+import qualified Data.Map.Internal                                  as Map++import Data.Array.Accelerate.Error+++mkBuildInfoFileName :: FilePath -> FilePath+mkBuildInfoFileName path = path </> "accelerate-llvm-native.buildinfo"++readBuildInfo :: HasCallStack => FilePath -> IO (Map Module [FilePath])+readBuildInfo path = do+  exists <- doesFileExist path+  if not exists+    then return Map.empty+    else get =<< readBinMem path++writeBuildInfo :: FilePath -> Map Module [FilePath] -> IO ()+writeBuildInfo path objs = do+  h <- openBinMem 4096+  put_ h objs+  writeBinMem h path+++instance (Binary k, Binary v) => Binary (Map k v) where+  get h = do+    t <- getByte h+    case t of+      0 -> return Map.Tip+      _ -> do+        s <- get h+        k <- get h+        a <- get h+        l <- get h+        r <- get h+        return $ Map.Bin s k a l r++  put_ h Map.Tip             = putByte h 0+  put_ h (Map.Bin s k a l r) = do+    putByte h 1+    put_ h s+    put_ h k+    put_ h a+    put_ h l+    put_ h r+
+ src/Data/Array/Accelerate/LLVM/Native/State.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.State+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.State (++  evalNative,+  createTarget, defaultTarget,++) where++import Data.Array.Accelerate.Debug.Internal++import Data.Array.Accelerate.LLVM.State+import Data.Array.Accelerate.LLVM.Native.Target+import Data.Array.Accelerate.LLVM.Native.Execute.Scheduler+import qualified Data.Array.Accelerate.LLVM.Native.Link.Cache       as LC+import qualified Data.Array.Accelerate.LLVM.Native.Debug            as Debug++import Data.Char+import Data.Maybe+import Formatting+import Language.Haskell.TH+import System.Environment+import System.IO.Unsafe+import Text.Read++import GHC.Conc+import GHC.Ptr+++-- | Execute a computation in the Native backend+--+evalNative :: Native -> LLVM Native a -> IO a+-- evalNative = evalLLVM++-- XXX: This is correct for run, but for runN we'll use this operation to+-- do the compilation separately from execution, thus there will be an+-- empty "frame" with no (execution) trace+--+evalNative target acc = do+  let label = Ptr $(litE (stringPrimL (map (fromIntegral . ord) "Native.run\0")))+  emit_frame_mark_start label+  !result <- evalLLVM target acc+  emit_frame_mark_end label+  return result+++-- | Create a Native execution target by spawning a worker thread on each of the+-- given capabilities.+--+createTarget+    :: [Int]              -- ^ CPUs to launch worker threads on+    -> IO Native+createTarget cpus = do+  gang    <- hireWorkersOn cpus+  linker  <- LC.new+  return  $! Native linker gang++{--+-- | The strategy for balancing work amongst the available worker threads.+--+type Strategy = Gang -> Executable+++-- | Execute an operation sequentially on a single thread+--+sequentialIO :: Strategy+sequentialIO gang =+  Executable $ \name _ppt range fill ->+    timed name $ runSeqIO gang range fill+++-- | Execute a computation without load balancing. Each thread computes an+-- equally sized chunk of the input. No work stealing occurs.+--+unbalancedParIO :: Strategy+unbalancedParIO gang =+  Executable $ \name _ppt range fill ->+    timed name $ runParIO Single.mkResource gang range fill+++-- | Execute a computation where threads use work stealing (based on lazy+-- splitting of work stealing queues and exponential backoff) in order to+-- automatically balance the workload amongst themselves.+--+balancedParIO+    :: Int                -- ^ number of steal attempts before backing off+    -> Strategy+balancedParIO retries gang =+  Executable $ \name ppt range fill ->+    -- TLM: A suitable PPT should be chosen when invoking the continuation in+    --      order to balance scheduler overhead with fine-grained function calls+    --+    let resource = LBS.mkResource ppt (SMP.mkResource retries <> Backoff.mkResource)+    in  timed name $ runParIO resource gang range fill+--}+++-- Top-level mutable state+-- -----------------------+--+-- It is important to keep some information alive for the entire run of the+-- program, not just a single execution. These tokens use 'unsafePerformIO' to+-- ensure they are executed only once, and reused for subsequent invocations.+--++-- | Initialise the gang of threads that will be used to execute computations.+-- This spawns one worker for each available processor, or as specified by the+-- value of the environment variable @ACCELERATE_LLVM_NATIVE_THREADS@.+--+-- This globally shared thread gang is auto-initialised on startup and shared by+-- all computations (unless the user chooses to 'run' with a different gang).+--+-- It does not help to have multiple gangs running at the same time, as then the+-- system as a whole may run slower as the threads contend for cache. The+-- scheduler is able to execute operations from multiple sources concurrently,+-- so multiple gangs should not be necessary.+--+{-# NOINLINE defaultTarget #-}+defaultTarget :: Native+defaultTarget = unsafePerformIO $ do+  nproc <- getNumProcessors+  ncaps <- getNumCapabilities+  menv  <- (readMaybe =<<) <$> lookupEnv "ACCELERATE_LLVM_NATIVE_THREADS"++  let nthreads = fromMaybe nproc menv++  -- Update the number of capabilities, but never set it lower than it already+  -- is. This target will spawn a worker on each processor (as returned by+  -- 'getNumProcessors', which includes SMT (hyperthreading) cores), but the+  -- user may have requested more capabilities than this to handle, for example,+  -- concurrent output.+  --+  setNumCapabilities (max ncaps nthreads)++  Debug.traceM Debug.dump_gc ("gc: initialise native target with " % int % " worker threads") nthreads+  createTarget [0 .. nthreads-1]+++{--+-- Debugging+-- ---------++{-# INLINE timed #-}+timed :: ShortByteString -> IO a -> IO a+timed name f = Debug.timed Debug.dump_exec (elapsed name) f++{-# INLINE elapsed #-}+elapsed :: ShortByteString -> Double -> Double -> String+elapsed name x y = printf "exec: %s %s" (unpack name) (Debug.elapsedP x y)+--}+
+ src/Data/Array/Accelerate/LLVM/Native/Target.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE TypeApplications #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Target+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.Target (++  module Data.Array.Accelerate.LLVM.Target,+  module Data.Array.Accelerate.LLVM.Native.Target,+  nativeTargetTriple,+  nativeCPUName,++) where++-- accelerate+import Data.Array.Accelerate.LLVM.Native.Link.Cache                 ( LinkCache )+import Data.Array.Accelerate.LLVM.Native.Execute.Scheduler          ( Workers )+import Data.Array.Accelerate.LLVM.Target                            ( Target(..) )+import Data.Array.Accelerate.LLVM.Target.ClangInfo+++-- | Native machine code JIT execution target+--+data Native = Native+  { linkCache     :: !LinkCache+  , workers       :: !Workers+  }++instance Target Native where+  targetTriple     = Just nativeTargetTriple+  targetDataLayout = Nothing  -- LLVM will fill it in just fine for CPU targets
+ test/nofib/Data/Array/Accelerate/LLVM/Native/NoFib/RunQ.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TemplateHaskell #-}+module Data.Array.Accelerate.LLVM.Native.NoFib.RunQ where++import qualified Data.Array.Accelerate as A+import qualified Data.Array.Accelerate.LLVM.Native as CPU++import Test.Tasty+import Test.Tasty.HUnit+++-- WARNING: This module is duplicated (apart from Native/PTX) between the+-- accelerate-llvm-native and accelerate-llvm-ptx backends. This code is not+-- included in the main Accelerate nofib testsuite because of staging issues:+-- the test can only be defined after runQ is known, and runQ is only built+-- after the 'accelerate' package has already finished building. It would be+-- possible to deduplicate the little Accelerate program in there, but that was+-- not deemed worth the effort.+++test_runq :: TestTree+test_runq =+  testGroup "runQ"+    [ testCase "simple" test_simple ]++test_simple :: Assertion+test_simple = do+  let prog :: A.Vector Int -> A.Scalar Int+      !prog = $(CPU.runQ $ \a -> A.sum (A.map (+1) (a :: A.Acc (A.Vector Int))))+  let n = 10000+  prog (A.fromList (A.Z A.:. 10000) [1..]) @=? A.fromList A.Z [n * (n + 1) `div` 2 + n]
+ test/nofib/Main.hs view
@@ -0,0 +1,19 @@+-- |+-- Module      : nofib-llvm-native+-- Copyright   : [2017..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Main where++import Data.Array.Accelerate.Test.NoFib+import Data.Array.Accelerate.LLVM.Native+import Data.Array.Accelerate.LLVM.Native.NoFib.RunQ++main :: IO ()+main = nofib runN test_runq+