packages feed

accelerate-llvm-native 1.1.0.1 → 1.2.0.0

raw patch · 78 files changed

+7103/−6956 lines, 78 filesdep +accelerate-llvm-nativedep −fclabelsdep ~acceleratedep ~accelerate-llvmdep ~base

Dependencies added: accelerate-llvm-native

Dependencies removed: fclabels

Dependency ranges changed: accelerate, accelerate-llvm, base, llvm-hs, llvm-hs-pure

Files

CHANGELOG.md view
@@ -6,10 +6,32 @@ project adheres to the [Haskell Package Versioning Policy (PVP)](https://pvp.haskell.org) +## [1.2.0.0] - 2018-04-03+### Fixed+ * LLVM native throws "SIGSEGV: invalid address" due to fused FP operation ([#409])++### Added+ * support for half-precision floats+ * support for struct-of-array-of-struct representations+ * support for LLVM-6.0+ * support for GHC-8.4++### Contributors++Special thanks to those who contributed patches as part of this release:++ * Trevor L. McDonell (@tmcdonell)+ * @samft+ * Ryan Scott (@ryanglscott)+ * Jesse Sigal (@jasigal)+ * Moritz Kiefer (@cocreature)++ ## [1.1.0.1] - 2017-10-04 ### Fixed  * fix for `runQ*` generating multiple declarations with the same name + ## [1.1.0.0] - 2017-09-21 ### Added  * support for GHC-8.2@@ -25,12 +47,14 @@   ## [1.0.0.0] - 2017-03-31-  * initial release+ * initial release  +[1.2.0.0]:              https://github.com/AccelerateHS/accelerate-llvm/compare/1.1.0.1-native...v1.2.0.0 [1.1.0.1]:              https://github.com/AccelerateHS/accelerate-llvm/compare/1.1.0.0...1.1.0.1-native [1.1.0.0]:              https://github.com/AccelerateHS/accelerate-llvm/compare/1.0.0.0...1.1.0.0 [1.0.0.0]:              https://github.com/AccelerateHS/accelerate-llvm/compare/be7f91295f77434b2103c70aa1cabb6a4f2b09a8...1.0.0.0 +[#409]:                 https://github.com/AccelerateHS/accelerate/issues/409 [accelerate-llvm#17]:   https://github.com/AccelerateHS/accelerate-llvm/issues/17
− 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-
README.md view
@@ -1,7 +1,10 @@ An LLVM backend for the Accelerate Array Language ================================================= -[![Build Status](https://travis-ci.org/AccelerateHS/accelerate-llvm.svg)](https://travis-ci.org/AccelerateHS/accelerate-llvm)+[![Travis](https://img.shields.io/travis/AccelerateHS/accelerate-llvm/master.svg?label=linux)](https://travis-ci.org/AccelerateHS/accelerate-llvm)+[![AppVeyor](https://img.shields.io/appveyor/ci/tmcdonell/accelerate-llvm/master.svg?label=windows)](https://ci.appveyor.com/project/tmcdonell/accelerate-llvm)+[![Stackage LTS](https://stackage.org/package/accelerate-llvm/badge/lts)](https://stackage.org/lts/package/accelerate-llvm)+[![Stackage Nightly](https://stackage.org/package/accelerate-llvm/badge/nightly)](https://stackage.org/nightly/package/accelerate-llvm) [![Hackage](https://img.shields.io/hackage/v/accelerate-llvm.svg)](https://hackage.haskell.org/package/accelerate-llvm) [![Docker Automated build](https://img.shields.io/docker/automated/tmcdonell/accelerate-llvm.svg)](https://hub.docker.com/r/tmcdonell/accelerate-llvm/) [![Docker status](https://images.microbadger.com/badges/image/tmcdonell/accelerate-llvm.svg)](https://microbadger.com/images/tmcdonell/accelerate-llvm)@@ -64,7 +67,7 @@ Example using [Homebrew](http://brew.sh) on macOS:  ```sh-$ brew install llvm-hs/homebrew-llvm/llvm-4.0+$ brew install llvm-hs/homebrew-llvm/llvm-6.0 ```  ## Debian/Ubuntu@@ -75,17 +78,17 @@ then:  ```sh-$ apt-get install llvm-4.0-dev+$ apt-get install llvm-6.0-dev ```  ## Building from source -If your OS does not have an appropriate LLVM distribution available, you can also build from source. Detailed build instructions are available on the [LLVM.org website](http://releases.llvm.org/4.0.0/docs/CMake.html). Note that you will require at least [CMake 3.4.3](http://www.cmake.org/cmake/resources/software.html) and a recent C++ compiler; at least Clang 3.1, GCC 4.8, or Visual Studio 2015 (update 3).+If your OS does not have an appropriate LLVM distribution available, you can also build from source. Detailed build instructions are available on the [LLVM.org website](http://releases.llvm.org/6.0.0/docs/CMake.html). Note that you will require at least [CMake 3.4.3](http://www.cmake.org/cmake/resources/software.html) and a recent C++ compiler; at least Clang 3.1, GCC 4.8, or Visual Studio 2015 (update 3). -  1. Download and unpack the [LLVM-4.0 source code](http://releases.llvm.org/4.0.0/llvm-4.0.0.src.tar.xz). We'll refer to+  1. Download and unpack the [LLVM-6.0 source code](http://releases.llvm.org/6.0.0/llvm-6.0.0.src.tar.xz). We'll refer to      the path that the source tree was unpacked to as `LLVM_SRC`. Only the main      LLVM source tree is required, but you can optionally add other components-     such as the Clang compiler or Polly loop optimiser. See the [LLVM releases](http://releases.llvm.org/download.html#4.0.0)+     such as the Clang compiler or Polly loop optimiser. See the [LLVM releases](http://releases.llvm.org/download.html#6.0.0)      page for the complete list.    2. Create a temporary build directory and `cd` into it, for example:@@ -113,7 +116,7 @@      to [System Integrity Protection](https://en.wikipedia.org/wiki/System_Integrity_Protection):      ```sh      cd $INSTALL_PREFIX/lib-     ln -s libLLVM.dylib libLLVM-4.0.dylib+     ln -s libLLVM.dylib libLLVM-6.0.dylib      install_name_tool -id $PWD/libLTO.dylib libLTO.dylib      install_name_tool -id $PWD/libLLVM.dylib libLLVM.dylib      install_name_tool -change '@rpath/libLLVM.dylib' $PWD/libLLVM.dylib libLTO.dylib@@ -128,13 +131,13 @@ For example, installation using [`stack`](http://docs.haskellstack.org/en/stable/README.html) just requires you to point it to the appropriate configuration file: ```sh-$ ln -s stack-8.0.yaml stack.yaml+$ ln -s stack-8.2.yaml stack.yaml $ stack setup $ stack install ```  Note that the version of [`llvm-hs`](https://hackage.haskell.org/package/llvm-hs)-used must match the installed version of LLVM, which is currently 4.0.+used must match the installed version of LLVM, which is currently 6.0.   ## libNVVM@@ -152,11 +155,12 @@ on the version of the CUDA toolkit you have installed. The following table shows some combinations: -|              | LLVM-3.3 | LLVM-3.4 | LLVM-3.5 | LLVM-3.8 | LLVM-3.9 | LLVM-4.0 |-|:------------:|:--------:|:--------:|:--------:|:--------:|:--------:|:--------:|-| **CUDA-7.0** |     ⭕    |     ❌    |          |          |          |          |-| **CUDA-7.5** |          |     ⭕    |     ⭕    |     ❌    |          |          |-| **CUDA-8.0** |          |          |     ⭕    |     ⭕    |     ❌    |     ❌    |+|              | LLVM-3.3 | LLVM-3.4 | LLVM-3.5 | LLVM-3.8 | LLVM-3.9 | LLVM-4.0 | LLVM-5.0 |+|:------------:|:--------:|:--------:|:--------:|:--------:|:--------:|:--------:|:--------:|+| **CUDA-7.0** |     ⭕    |     ❌    |          |          |          |          |          |+| **CUDA-7.5** |          |     ⭕    |     ⭕    |     ❌    |          |          |          |+| **CUDA-8.0** |          |          |     ⭕    |     ⭕    |     ❌    |     ❌    |          |+| **CUDA-9.0** |          |          |          |          |          |     ❌    |     ❌    |  Where ⭕ = Works, and ❌ = Does not work.
accelerate-llvm-native.cabal view
@@ -1,5 +1,5 @@ name:                   accelerate-llvm-native-version:                1.1.0.1+version:                1.2.0.0 cabal-version:          >= 1.10 tested-with:            GHC >= 7.10 build-type:             Simple@@ -26,7 +26,7 @@     .     Example using Homebrew on macOS:     .-    > brew install llvm-hs/homebrew-llvm/llvm-5.0+    > brew install llvm-hs/homebrew-llvm/llvm-6.0     .     /Debian & Ubuntu/     .@@ -35,13 +35,13 @@     instructions for adding the correct package database for your OS version,     and then:     .-    > apt-get install llvm-5.0-dev+    > apt-get install llvm-6.0-dev     .     /Building from source/     .     If your OS does not have an appropriate LLVM distribution available, you can     also build from source. Detailed build instructions are available on-    <http://releases.llvm.org/5.0.0/docs/CMake.html LLVM.org>. Make sure to+    <http://releases.llvm.org/6.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.@@ -75,29 +75,6 @@     README.md  --- Configuration flags--- ---------------------Flag debug-  Default:              False-  Description:-    Enable debug tracing message flags. Note that 'debug' must be enabled in the-    base 'accelerate' package as well. See the 'accelerate' package for usage-    and available options.--Flag bounds-checks-  Default:              True-  Description:          Enable bounds checking--Flag unsafe-checks-  Default:              False-  Description:          Enable bounds checking in unsafe operations--Flag internal-checks-  Default:              False-  Description:          Enable internal consistency checks-- -- Build configuration -- ------------------- @@ -111,7 +88,6 @@   other-modules:     Data.Array.Accelerate.LLVM.Native.Array.Data     Data.Array.Accelerate.LLVM.Native.Debug-    Data.Array.Accelerate.LLVM.Native.Execute     Data.Array.Accelerate.LLVM.Native.State     Data.Array.Accelerate.LLVM.Native.Target @@ -135,6 +111,7 @@      Data.Array.Accelerate.LLVM.Native.Embed +    Data.Array.Accelerate.LLVM.Native.Execute     Data.Array.Accelerate.LLVM.Native.Execute.Async     Data.Array.Accelerate.LLVM.Native.Execute.Environment     Data.Array.Accelerate.LLVM.Native.Execute.LBS@@ -150,46 +127,44 @@     Paths_accelerate_llvm_native    build-depends:-          base                          >= 4.7 && < 4.11-        , accelerate                    == 1.1.*-        , accelerate-llvm               == 1.1.*+          base                          >= 4.7 && < 4.12+        , accelerate                    == 1.2.*+        , accelerate-llvm               == 1.2.*         , bytestring                    >= 0.10.4         , Cabal                         >= 2.0         , cereal                        >= 0.4         , containers                    >= 0.5 && < 0.6         , directory                     >= 1.0         , dlist                         >= 0.6-        , fclabels                      >= 2.0         , filepath                      >= 1.0         , ghc         , hashable                      >= 1.0         , libffi                        >= 0.1-        , llvm-hs                       >= 4.1 && < 5.1-        , llvm-hs-pure                  >= 4.1 && < 5.1+        , llvm-hs                       >= 4.1 && < 6.1+        , llvm-hs-pure                  >= 4.1 && < 6.1         , mtl                           >= 2.2.1         , template-haskell         , time                          >= 1.4         , unique -  default-language:-    Haskell2010--  ghc-options:                  -O2 -Wall -fwarn-tabs--  if impl(ghc >= 8.0)-    ghc-options:                -Wmissed-specialisations+  hs-source-dirs:+        src -  if flag(debug)-    cpp-options:                -DACCELERATE_DEBUG+  default-language:+        Haskell2010 -  if flag(bounds-checks)-    cpp-options:                -DACCELERATE_BOUNDS_CHECKS+  ghc-options:+        -O2+        -Wall+        -fwarn-tabs -  if flag(unsafe-checks)-    cpp-options:                -DACCELERATE_UNSAFE_CHECKS+  ghc-prof-options:+        -caf-all+        -auto-all -  if flag(internal-checks)-    cpp-options:                -DACCELERATE_INTERNAL_CHECKS+  if impl(ghc >= 8.0)+    ghc-options:+        -Wmissed-specialisations    if os(darwin)     other-modules:@@ -227,13 +202,35 @@           bytestring                    >= 0.10  +test-suite nofib-llvm-native+  type:                 exitcode-stdio-1.0+  hs-source-dirs:       test/nofib+  main-is:              Main.hs++  build-depends:+          base                          >= 4.7+        , accelerate+        , accelerate-llvm-native++  default-language:+        Haskell2010++  ghc-options:+        -Wall+        -O2+        -threaded+        -rtsopts+        -with-rtsopts=-A128M+        -with-rtsopts=-n4M++ source-repository head   type:                 git   location:             https://github.com/AccelerateHS/accelerate-llvm.git  source-repository this   type:                 git-  tag:                  1.1.0.1-native+  tag:                  1.2.0.0   location:             https://github.com/AccelerateHS/accelerate-llvm.git  -- vim: nospell
+ src/Data/Array/Accelerate/LLVM/Native.hs view
@@ -0,0 +1,441 @@+{-# LANGUAGE BangPatterns         #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeSynonymInstances #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native+-- Copyright   : [2014..2017] Trevor L. McDonell+--               [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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,+  Afunction, AfunctionR,++  -- * Synchronous execution+  run, runWith,+  run1, run1With,+  runN, runNWith,+  stream, streamWith,++  -- * Asynchronous execution+  Async,+  wait, poll, cancel,++  runAsync, runAsyncWith,+  run1Async, run1AsyncWith,+  runNAsync, runNAsyncWith,++  -- * Ahead-of-time compilation+  runQ, runQWith,+  runQAsync, runQAsyncWith,++  -- * Execution targets+  Native, Strategy,+  createTarget, balancedParIO, unbalancedParIO,++) where++-- accelerate+import Data.Array.Accelerate.Array.Sugar                            ( Arrays )+import Data.Array.Accelerate.AST                                    ( PreOpenAfun(..) )+import Data.Array.Accelerate.Async+import Data.Array.Accelerate.Smart                                  ( Acc )+import Data.Array.Accelerate.Trafo++import Data.Array.Accelerate.LLVM.Execute.Async                     ( AsyncR(..) )+import Data.Array.Accelerate.LLVM.Execute.Environment               ( AvalR(..) )+import Data.Array.Accelerate.LLVM.Native.Array.Data                 ( useRemoteAsync )+import Data.Array.Accelerate.LLVM.Native.Compile                    ( CompiledOpenAfun, compileAcc, compileAfun )+import Data.Array.Accelerate.LLVM.Native.Embed                      ( embedOpenAcc )+import Data.Array.Accelerate.LLVM.Native.Execute                    ( executeAcc, executeOpenAcc )+import Data.Array.Accelerate.LLVM.Native.Execute.Environment        ( Aval )+import Data.Array.Accelerate.LLVM.Native.Link                       ( ExecOpenAfun, linkAcc, linkAfun )+import Data.Array.Accelerate.LLVM.Native.State+import Data.Array.Accelerate.LLVM.Native.Target+import Data.Array.Accelerate.LLVM.State                             ( LLVM )+import Data.Array.Accelerate.LLVM.Native.Debug                      as Debug+import qualified Data.Array.Accelerate.LLVM.Native.Execute.Async    as E++-- standard library+import Data.Typeable+import Control.Monad.Trans+import System.IO.Unsafe+import Text.Printf+import qualified Language.Haskell.TH                                as TH+import qualified Language.Haskell.TH.Syntax                         as TH+++-- Accelerate: LLVM backend for multicore CPUs+-- -------------------------------------------++-- | Compile and run a complete embedded array program.+--+-- /NOTE:/ it is recommended to use 'runN' or 'runQ' whenever possible.+--+run :: Arrays a => Acc a -> a+run = runWith defaultTarget++-- | As 'run', but execute using the specified target (thread gang).+--+runWith :: Arrays a => Native -> Acc a -> a+runWith target a = unsafePerformIO (run' target a)+++-- | As 'run', but allow the computation to run asynchronously and return+-- immediately without waiting for the result. The status of the computation can+-- be queried using 'wait', 'poll', and 'cancel'.+--+runAsync :: Arrays a => Acc a -> IO (Async a)+runAsync = runAsyncWith defaultTarget++-- | As 'runAsync', but execute using the specified target (thread gang).+--+runAsyncWith :: Arrays a => Native -> Acc a -> IO (Async a)+runAsyncWith target a = async (run' target a)++run' :: Arrays a => Native -> Acc a -> IO a+run' target a = execute+  where+    !acc        = convertAccWith (config target) a+    execute     = do+      dumpGraph acc+      evalNative target $ do+        build <- phase "compile" elapsedS (compileAcc acc) >>= dumpStats+        exec  <- phase "link"    elapsedS (linkAcc build)+        res   <- phase "execute" elapsedP (executeAcc exec)+        return res+++-- | This is 'runN', specialised to an array program of one argument.+--+run1 :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> b+run1 = run1With defaultTarget++-- | As 'run1', but execute using the specified target (thread gang).+--+run1With :: (Arrays a, Arrays b) => Native -> (Acc a -> Acc b) -> a -> b+run1With = runNWith+++-- | Prepare and execute an embedded array program.+--+-- This function can be used to improve performance in cases where the array+-- program is constant between invocations, because it enables us to bypass+-- front-end conversion stages and move directly to the execution phase. If you+-- have a computation applied repeatedly to different input data, use this,+-- specifying any changing aspects of the computation via the input parameters.+-- If the function is only evaluated once, this is equivalent to 'run'.+--+-- In order to use 'runN' you must express your Accelerate program as a function+-- of array terms:+--+-- > f :: (Arrays a, Arrays b, ... Arrays c) => Acc a -> Acc b -> ... -> Acc c+--+-- This function then returns the compiled version of 'f':+--+-- > runN f :: (Arrays a, Arrays b, ... Arrays c) => a -> b -> ... -> c+--+-- At an example, rather than:+--+-- > step :: Acc (Vector a) -> Acc (Vector b)+-- > step = ...+-- >+-- > simulate :: Vector a -> Vector b+-- > simulate xs = run $ step (use xs)+--+-- Instead write:+--+-- > simulate = runN step+--+-- You can use the debugging options to check whether this is working+-- successfully. For example, running with the @-ddump-phases@ flag should show+-- that the compilation steps only happen once, not on the second and subsequent+-- invocations of 'simulate'. Note that this typically relies on GHC knowing+-- that it can lift out the function returned by 'runN' and reuse it.+--+-- See the programs in the 'accelerate-examples' package for examples.+--+-- See also 'runQ', which compiles the Accelerate program at _Haskell_ compile+-- time, thus eliminating the runtime overhead altogether.+--+runN :: Afunction f => f -> AfunctionR f+runN = runNWith defaultTarget++-- | As 'runN', but execute using the specified target (thread gang).+--+runNWith :: Afunction f => Native -> f -> AfunctionR f+runNWith target f = exec+  where+    !acc  = convertAfunWith (config target) f+    !afun = unsafePerformIO $ do+              dumpGraph acc+              evalNative target $ do+                build <- phase "compile" elapsedS (compileAfun acc) >>= dumpStats+                link  <- phase "link"    elapsedS (linkAfun build)+                return link+    !exec = go afun (return Aempty)++    go :: ExecOpenAfun Native aenv t -> LLVM Native (Aval aenv) -> t+    go (Alam l) k = \arrs ->+      let k' = do aenv       <- k+                  AsyncR _ a <- E.async (useRemoteAsync arrs)+                  return (aenv `Apush` a)+      in go l k'+    go (Abody b) k = unsafePerformIO . phase "execute" elapsedP . evalNative target $ do+      aenv   <- k+      E.get =<< E.async (executeOpenAcc b aenv)+++-- | As 'run1', but execute asynchronously.+--+run1Async :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> IO (Async b)+run1Async = run1AsyncWith defaultTarget++-- | As 'run1Async', but execute using the specified target (thread gang).+--+run1AsyncWith :: (Arrays a, Arrays b) => Native -> (Acc a -> Acc b) -> a -> IO (Async b)+run1AsyncWith = runNAsyncWith+++-- | As 'runN', but execute asynchronously.+--+runNAsync :: (Afunction f, RunAsync r, AfunctionR f ~ RunAsyncR r) => f -> r+runNAsync = runNAsyncWith defaultTarget++-- | As 'runNWith', but execute asynchronously.+--+runNAsyncWith :: (Afunction f, RunAsync r, AfunctionR f ~ RunAsyncR r) => Native -> f -> r+runNAsyncWith target f = runAsync' target afun (return Aempty)+  where+    !acc  = convertAfunWith (config target) f+    !afun = unsafePerformIO $ do+              dumpGraph acc+              evalNative target $ do+                build <- phase "compile" elapsedS (compileAfun acc) >>= dumpStats+                link  <- phase "link"    elapsedS (linkAfun build)+                return link++class RunAsync f where+  type RunAsyncR f+  runAsync' :: Native -> ExecOpenAfun Native aenv (RunAsyncR f) -> LLVM Native (Aval aenv) -> f++instance RunAsync b => RunAsync (a -> b) where+  type RunAsyncR (a -> b) = a -> RunAsyncR b+  runAsync' _      Abody{}  _ _    = error "runAsync: function oversaturated"+  runAsync' target (Alam l) k arrs =+    let k' = do aenv       <- k+                AsyncR _ a <- E.async (useRemoteAsync arrs)+                return (aenv `Apush` a)+    in runAsync' target l k'++instance RunAsync (IO (Async b)) where+  type RunAsyncR  (IO (Async b)) = b+  runAsync' _      Alam{}    _ = error "runAsync: function not fully applied"+  runAsync' target (Abody b) k = async . phase "execute" elapsedP . evalNative target $ do+    aenv   <- k+    E.get =<< E.async (executeOpenAcc b aenv)+++-- | Stream a lazily read list of input arrays through the given program,+-- collecting results as we go.+--+stream :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> [a] -> [b]+stream = streamWith defaultTarget++-- | As 'stream', but execute using the specified target (thread gang).+--+streamWith :: (Arrays a, Arrays b) => Native -> (Acc a -> Acc b) -> [a] -> [b]+streamWith target f arrs = map go arrs+  where+    !go = run1With target f+++-- | Ahead-of-time compilation for an embedded array program.+--+-- This function will generate, compile, and link into the final executable,+-- code to execute the given Accelerate computation /at Haskell compile time/.+-- This eliminates any runtime overhead associated with the other @run*@+-- operations. The generated code will be optimised for the compiling+-- architecture.+--+-- Since the Accelerate program will be generated at Haskell compile time,+-- construction of the Accelerate program, in particular via meta-programming,+-- will be limited to operations available to that phase. Also note that any+-- arrays which are embedded into the program via 'Data.Array.Accelerate.use'+-- will be stored as part of the final executable.+--+-- Usage of this function in your program is similar to that of 'runN'. First,+-- express your Accelerate program as a function of array terms:+--+-- > f :: (Arrays a, Arrays b, ... Arrays c) => Acc a -> Acc b -> ... -> Acc c+--+-- This function then returns a compiled version of @f@ as a Template Haskell+-- splice, to be added into your program at Haskell compile time:+--+-- > {-# LANGUAGE TemplateHaskell #-}+-- >+-- > f' :: a -> b -> ... -> c+-- > f' = $( runQ f )+--+-- Note that at the splice point the usage of @f@ must monomorphic; i.e. the+-- types @a@, @b@ and @c@ must be at some known concrete type.+--+-- In order to link the final program together, the included GHC plugin must be+-- used when compiling and linking the program. Add the following option to the+-- .cabal file of your project:+--+-- > ghc-options: -fplugin=Data.Array.Accelerate.LLVM.Native.Plugin+--+-- Similarly, the plugin must also run when loading modules in @ghci@.+--+-- Additionally, when building a _library_ with Cabal which utilises 'runQ', you+-- will need to use the following custom build @Setup.hs@ to ensure that the+-- library is linked together properly:+--+-- > import Data.Array.Accelerate.LLVM.Native.Distribution.Simple+-- > main = defaultMain+--+-- And in the .cabal file:+--+-- > build-type: Custom+-- > custom-setup+-- >   setup-depends:+-- >       base+-- >     , Cabal+-- >     , accelerate-llvm-native+--+-- The custom @Setup.hs@ is only required when building a library with Cabal.+-- Building executables with cabal requires only the GHC plugin.+--+-- See the <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+
+ src/Data/Array/Accelerate/LLVM/Native/Array/Data.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Array.Data+-- Copyright   : [2014..2017] Trevor L. McDonell+--               [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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 (ArrayEltRvec2 aeR)  (AD_V2 ad1)  (AD_V2 ad2)   = copyR aeR ad1 ad2+    copyR (ArrayEltRvec3 aeR)  (AD_V3 ad1)  (AD_V3 ad3)   = copyR aeR ad1 ad3+    copyR (ArrayEltRvec4 aeR)  (AD_V4 ad1)  (AD_V4 ad4)   = copyR aeR ad1 ad4+    copyR (ArrayEltRvec8 aeR)  (AD_V8 ad1)  (AD_V8 ad8)   = copyR aeR ad1 ad8+    copyR (ArrayEltRvec16 aeR) (AD_V16 ad1) (AD_V16 ad16) = copyR aeR ad1 ad16+    --+    copyR ArrayEltRint              ad1 ad2 = copyPrim ad1 ad2+    copyR ArrayEltRint8             ad1 ad2 = copyPrim ad1 ad2+    copyR ArrayEltRint16            ad1 ad2 = copyPrim ad1 ad2+    copyR ArrayEltRint32            ad1 ad2 = copyPrim ad1 ad2+    copyR ArrayEltRint64            ad1 ad2 = copyPrim ad1 ad2+    copyR ArrayEltRword             ad1 ad2 = copyPrim ad1 ad2+    copyR ArrayEltRword8            ad1 ad2 = copyPrim ad1 ad2+    copyR ArrayEltRword16           ad1 ad2 = copyPrim ad1 ad2+    copyR ArrayEltRword32           ad1 ad2 = copyPrim ad1 ad2+    copyR ArrayEltRword64           ad1 ad2 = copyPrim ad1 ad2+    copyR ArrayEltRhalf             ad1 ad2 = copyPrim ad1 ad2+    copyR ArrayEltRfloat            ad1 ad2 = copyPrim ad1 ad2+    copyR ArrayEltRdouble           ad1 ad2 = copyPrim ad1 ad2+    copyR ArrayEltRbool             ad1 ad2 = copyPrim ad1 ad2+    copyR ArrayEltRchar             ad1 ad2 = copyPrim ad1 ad2+    copyR ArrayEltRcshort           ad1 ad2 = copyPrim ad1 ad2+    copyR ArrayEltRcushort          ad1 ad2 = copyPrim ad1 ad2+    copyR ArrayEltRcint             ad1 ad2 = copyPrim ad1 ad2+    copyR ArrayEltRcuint            ad1 ad2 = copyPrim ad1 ad2+    copyR ArrayEltRclong            ad1 ad2 = copyPrim ad1 ad2+    copyR ArrayEltRculong           ad1 ad2 = copyPrim ad1 ad2+    copyR ArrayEltRcllong           ad1 ad2 = copyPrim ad1 ad2+    copyR ArrayEltRcullong          ad1 ad2 = copyPrim ad1 ad2+    copyR ArrayEltRcfloat           ad1 ad2 = copyPrim ad1 ad2+    copyR ArrayEltRcdouble          ad1 ad2 = copyPrim ad1 ad2+    copyR ArrayEltRcchar            ad1 ad2 = copyPrim ad1 ad2+    copyR ArrayEltRcschar           ad1 ad2 = copyPrim ad1 ad2+    copyR ArrayEltRcuchar           ad1 ad2 = copyPrim ad1 ad2++    copyPrim :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Storable a) => ArrayData e -> ArrayData e -> IO ()+    copyPrim a1 a2 = do+      let p1 = ptrsOfArrayData a1+          p2 = ptrsOfArrayData a2+      memcpy (castPtr p2) (castPtr p1) (n * sizeOf (undefined :: a))+++-- Standard C functions+-- --------------------++memcpy :: Ptr Word8 -> Ptr Word8 -> Int -> IO ()+memcpy p q s = c_memcpy p q (fromIntegral s) >> return ()++foreign import ccall unsafe "string.h memcpy" c_memcpy+    :: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8)+
+ src/Data/Array/Accelerate/LLVM/Native/CodeGen.hs view
@@ -0,0 +1,46 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen+-- Copyright   : [2014..2017] Trevor L. McDonell+--               [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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+
+ src/Data/Array/Accelerate/LLVM/Native/CodeGen/Base.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE TypeOperators       #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen.Base+-- Copyright   : [2015..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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+import Prelude                                                      as P+++-- | Generate function parameters that will specify the first and last (linear)+-- index of the array this thread should evaluate.+--+gangParam :: (IR Int, IR Int, [LLVM.Parameter])+gangParam =+  let t         = scalarType+      start     = "ix.start"+      end       = "ix.end"+  in+  (local t start, local t end, [ scalarParameter t start, scalarParameter t end ] )+++-- | The thread ID of a gang worker+--+gangId :: (IR Int, [LLVM.Parameter])+gangId =+  let t         = scalarType+      tid       = "ix.tid"+  in+  (local t tid, [ scalarParameter t tid ] )+++-- Global function definitions+-- ---------------------------++data instance KernelMetadata Native = KM_Native ()++-- | Combine kernels into a single program+--+(+++) :: IROpenAcc Native aenv a -> IROpenAcc Native aenv a -> IROpenAcc Native aenv a+IROpenAcc k1 +++ IROpenAcc k2 = IROpenAcc (k1 ++ k2)++-- | Create a single kernel program+--+makeOpenAcc :: UID -> Label -> [LLVM.Parameter] -> CodeGen () -> CodeGen (IROpenAcc Native aenv a)+makeOpenAcc uid name param kernel = do+  body  <- makeKernel (name <> fromString (printf "_%s" (show uid))) param kernel+  return $ IROpenAcc [body]++-- | Create a complete kernel function by running the code generation process+-- specified in the final parameter.+--+makeKernel :: Label -> [LLVM.Parameter] -> CodeGen () -> CodeGen (Kernel Native aenv a)+makeKernel name param kernel = do+  _    <- kernel+  code <- createBlocks+  return $ Kernel+    { kernelMetadata = KM_Native ()+    , unKernel       = LLVM.functionDefaults+                     { LLVM.returnType  = LLVM.VoidType+                     , LLVM.name        = downcast name+                     , LLVM.parameters  = (param, False)+                     , LLVM.basicBlocks = code+                     }+    }+
+ src/Data/Array/Accelerate/LLVM/Native/CodeGen/Fold.hs view
@@ -0,0 +1,301 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen.Fold+-- Copyright   : [2014..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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 singleType a   length+      r   <- reduce1FromTo inf sup (app2 combine) (app1 delayedLinearIndex)+      writeArray arrTmp i r++    return_++-- Parallel reduction of an entire array to a single element, step 2.+--+-- A single thread reduces the temporary array to a single element.+--+-- During execution, we choose a stripe size in phase 1 so that the temporary is+-- small-ish and thus suitable for sequential reduction. An alternative would be+-- to keep the stripe size constant and, for if the partial reductions array is+-- large, continuing reducing it in parallel.+--+mkFoldAllP2+    :: forall aenv e. Elt e+    =>          UID+    ->          Gamma            aenv                           -- ^ array environment+    ->          IRFun2    Native aenv (e -> e -> e)             -- ^ combination function+    -> Maybe   (IRExp     Native aenv e)                        -- ^ seed element, if this is an exclusive reduction+    -> CodeGen (IROpenAcc Native aenv (Scalar e))+mkFoldAllP2 uid aenv combine mseed =+  let+      (start, end, paramGang)   = gangParam+      paramEnv                  = envParam aenv+      (arrTmp, paramTmp)        = mutableArray ("tmp" :: Name (Vector e))+      (arrOut, paramOut)        = mutableArray ("out" :: Name (Scalar e))+      zero                      = lift 0 :: IR Int+  in+  makeOpenAcc uid "foldAllP2" (paramGang ++ paramTmp ++ paramOut ++ paramEnv) $ do+    r <- case mseed of+           Just seed -> do z <- seed+                           reduceFromTo  start end (app2 combine) z (readArray arrTmp)+           Nothing   ->    reduce1FromTo start end (app2 combine)   (readArray arrTmp)+    writeArray arrOut zero r+    return_+++-- Exclusive reductions over empty arrays (of any dimension) fill the lower+-- dimensions with the initial element+--+mkFoldFill+    :: (Shape sh, Elt e)+    => UID+    -> Gamma aenv+    -> IRExp Native aenv e+    -> CodeGen (IROpenAcc Native aenv (Array sh e))+mkFoldFill uid aenv seed =+  mkGenerate uid aenv (IRFun1 (const seed))++-- Reduction loops+-- ---------------++-- Reduction of a (possibly empty) index space.+--+reduceFromTo+    :: Elt a+    => IR Int                                   -- ^ starting index+    -> IR Int                                   -- ^ final index (exclusive)+    -> (IR a -> IR a -> CodeGen (IR a))         -- ^ combination function+    -> IR a                                     -- ^ initial value+    -> (IR Int -> CodeGen (IR a))               -- ^ function to retrieve element at index+    -> CodeGen (IR a)+reduceFromTo m n f z get =+  iterFromTo m n z $ \i acc -> do+    x <- get i+    y <- f acc x+    return y++-- Reduction of an array over a _non-empty_ index space. The array must+-- contain at least one element.+--+reduce1FromTo+    :: Elt a+    => IR Int                                   -- ^ starting index+    -> IR Int                                   -- ^ final index+    -> (IR a -> IR a -> CodeGen (IR a))         -- ^ combination function+    -> (IR Int -> CodeGen (IR a))               -- ^ function to retrieve element at index+    -> CodeGen (IR a)+reduce1FromTo m n f get = do+  z  <- get m+  m1 <- add numType m (ir numType (num numType 1))+  reduceFromTo m1 n f z get+
+ src/Data/Array/Accelerate/LLVM/Native/CodeGen/FoldSeg.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE ViewPatterns        #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen.FoldSeg+-- Copyright   : [2014..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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 singleType (A.fst si) end+        initial = A.pair start (lift 0)++        body :: IR (Int,Int) -> CodeGen (IR (Int,Int))+        body (A.unpair -> (s,inf)) = do+          -- We can avoid an extra division if this is a DIM1 array. Higher+          -- dimensional reductions need to wrap around the segment array at+          -- each new lower-dimensional index.+          s'  <- case rank (undefined::sh) of+                   0 -> return s+                   _ -> A.rem integralType s ss++          len <- A.fromIntegral integralType numType =<< app1 (delayedLinearIndex seg) s'+          sup <- A.add numType inf len++          r   <- case mseed of+                   Just seed -> do z <- seed+                                   reduceFromTo  inf sup (app2 combine) z (app1 (delayedLinearIndex arr))+                   Nothing   ->    reduce1FromTo inf sup (app2 combine)   (app1 (delayedLinearIndex arr))+          writeArray arrOut s r++          t <- A.add numType s (lift 1)+          return $ A.pair t sup++    void $ while test body initial+    return_+++-- This implementation assumes that the segments array represents the offset+-- indices to the source array, rather than the lengths of each segment. The+-- segment-offset approach is required for parallel implementations.+--+mkFoldSegP+    :: forall aenv sh i e. (Shape sh, IsIntegral i, Elt i, Elt e)+    =>          UID+    ->          Gamma            aenv+    ->          IRFun2    Native aenv (e -> e -> e)+    -> Maybe   (IRExp     Native aenv e)+    ->          IRDelayed Native aenv (Array (sh :. Int) e)+    ->          IRDelayed Native aenv (Segments i)+    -> CodeGen (IROpenAcc Native aenv (Array (sh :. Int) e))+mkFoldSegP uid aenv combine mseed arr seg =+  let+      (start, end, paramGang)   = gangParam+      (arrOut, paramOut)        = mutableArray ("out" :: Name (Array (sh :. Int) e))+      paramEnv                  = envParam aenv+  in+  makeOpenAcc uid "foldSegP" (paramGang ++ paramOut ++ paramEnv) $ do++    -- Number of segments and size of the innermost dimension. These are+    -- required if we are reducing a DIM2 or higher array, to properly compute+    -- the start and end indices of the portion of the array to reduce. Note+    -- that this is a segment-offset array computed by 'scanl (+) 0' of the+    -- segment length array, so its size has increased by one.+    sz <- indexHead <$> delayedExtent arr+    ss <- do n <- indexHead <$> delayedExtent seg+             A.sub numType n (lift 1)++    imapFromTo start end $ \s -> do++      i   <- case rank (undefined::sh) of+               0 -> return s+               _ -> A.rem integralType s ss+      j   <- A.add numType i (lift 1)+      u   <- A.fromIntegral integralType numType =<< app1 (delayedLinearIndex seg) i+      v   <- A.fromIntegral integralType numType =<< app1 (delayedLinearIndex seg) j++      (inf,sup) <- A.unpair <$> case rank (undefined::sh) of+                     0 -> return (A.pair u v)+                     _ -> do q <- A.quot integralType s ss+                             a <- A.mul numType q sz+                             A.pair <$> A.add numType u a <*> A.add numType v a++      r   <- case mseed of+               Just seed -> do z <- seed+                               reduceFromTo  inf sup (app2 combine) z (app1 (delayedLinearIndex arr))+               Nothing   ->    reduce1FromTo inf sup (app2 combine)   (app1 (delayedLinearIndex arr))++      writeArray arrOut s r++    return_+
+ src/Data/Array/Accelerate/LLVM/Native/CodeGen/Generate.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen.Generate+-- Copyright   : [2014..2017] Trevor L. McDonell+--               [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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_+
+ src/Data/Array/Accelerate/LLVM/Native/CodeGen/Loop.hs view
@@ -0,0 +1,46 @@+-- |+-- 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+
+ src/Data/Array/Accelerate/LLVM/Native/CodeGen/Map.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen.Map+-- Copyright   : [2014..2017] Trevor L. McDonell+--               [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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_+
+ src/Data/Array/Accelerate/LLVM/Native/CodeGen/Permute.hs view
@@ -0,0 +1,306 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen.Permute+-- Copyright   : [2016..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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+          --+          _ | TypeRscalar (SingleScalarType s)  <- eltType (undefined::e)+            , Just adata                        <- gcast (irArrayData arrOut)+            , Just r'                           <- gcast r+            -> do+                  addr <- instr' $ GetElementPtr (asPtr defaultAddrSpace (op s adata)) [op integralType j]+                  --+                  case s of+                    NumSingleType (IntegralNumType t) -> void . instr' $ AtomicRMW t NonVolatile rmw addr (op t r') (CrossThread, AcquireRelease)+                    NumSingleType t | RMW.Add <- rmw  -> atomicCAS_rmw s (A.add t r') addr+                    NumSingleType t | RMW.Sub <- rmw  -> atomicCAS_rmw s (A.sub t r') addr+                    _ -> case rmw of+                           RMW.Min                    -> atomicCAS_cmp s A.lt addr (op s r')+                           RMW.Max                    -> atomicCAS_cmp s A.gt addr (op s r')+                           _                          -> $internalError "mkPermute_rmw" "unexpected transition"+          --+          _ -> $internalError "mkPermute_rmw" "unexpected transition"++    return_+++-- Parallel forward permutation function which uses a spinlock to acquire+-- a mutex before updating the value at that location.+--+mkPermuteP_mutex+    :: forall aenv sh sh' e. (Shape sh, Shape sh', Elt e)+    => UID+    -> Gamma aenv+    -> IRFun2    Native aenv (e -> e -> e)+    -> IRFun1    Native aenv (sh -> sh')+    -> IRDelayed Native aenv (Array sh e)+    -> CodeGen (IROpenAcc Native aenv (Array sh' e))+mkPermuteP_mutex uid aenv combine project IRDelayed{..} =+  let+      (start, end, paramGang)   = gangParam+      (arrOut, paramOut)        = mutableArray ("out"  :: Name (Array sh' e))+      (arrLock, paramLock)      = mutableArray ("lock" :: Name (Vector Word8))+      paramEnv                  = envParam aenv+  in+  makeOpenAcc uid "permuteP_mutex" (paramGang ++ paramOut ++ paramLock ++ paramEnv) $ do++    sh <- delayedExtent++    imapFromTo start end $ \i -> do++      ix  <- indexOfInt sh i+      ix' <- app1 project ix++      -- project element onto the destination array and (atomically) update+      unless (ignore ix') $ do+        j <- intOfIndex (irArrayShape arrOut) ix'+        x <- app1 delayedLinearIndex i++        atomically arrLock j $ do+          y <- readArray arrOut j+          r <- app2 combine x y+          writeArray arrOut j r++    return_+++-- Atomically execute the critical section only when the lock at the given array+-- index is obtained. The thread spins waiting for the lock to be released and+-- there is no backoff strategy in case the lock is contended.+--+-- It is important that the thread loops trying to acquire the lock without+-- writing data anything until the lock value changes. Then, because of MESI+-- caching protocols there will be no bus traffic while the CPU waits for the+-- value to change.+--+-- <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 singleType old unlocked+  _    <- cbr ok crit spin++  -- We just acquired the lock; perform the critical section then release the+  -- lock and exit. For ("some") x86 processors, an unlocked MOV instruction+  -- could be used rather than the slower XCHG, due to subtle memory ordering+  -- rules.+  setBlock crit+  r    <- action+  _    <- instr $ AtomicRMW integralType NonVolatile Exchange addr unlock (CrossThread, Release)+  _    <- br exit++  setBlock exit+  return r+++-- Helper functions+-- ----------------++-- Test whether the given index is the magic value 'ignore'. This operates+-- strictly rather than performing short-circuit (&&).+--+ignore :: forall ix. Shape ix => IR ix -> CodeGen (IR Bool)+ignore (IR ix) = go (S.eltType (undefined::ix)) (S.fromElt (S.ignore::ix)) ix+  where+    go :: TupleType t -> t -> Operands t -> CodeGen (IR Bool)+    go TypeRunit           ()          OP_Unit        = return (lift True)+    go (TypeRpair tsh tsz) (ish, isz) (OP_Pair sh sz) = do x <- go tsh ish sh+                                                           y <- go tsz isz sz+                                                           land' x y+    go (TypeRscalar s)     ig         sz              = case s of+                                                          SingleScalarType t -> A.eq t (ir t (single t ig)) (ir t (op' t sz))+                                                          VectorScalarType{} -> $internalError "ignore" "unexpected shape type"+
+ src/Data/Array/Accelerate/LLVM/Native/CodeGen/Scan.hs view
@@ -0,0 +1,833 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE ViewPatterns        #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen.Scan+-- Copyright   : [2014..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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 singleType i iz+                     R -> A.gt singleType i iz++      void $ while (cont . A.fst3)+                   (\(A.untrip -> (i,j,v)) -> do+                       u  <- app1 delayedLinearIndex i+                       v' <- case dir of+                               L -> app2 combine v u+                               R -> app2 combine u v+                       writeArray arrOut j v'+                       A.trip <$> next i <*> next j <*> pure v')+                   (A.trip i1 j1 v0)++    return_+++mkScan'S+    :: forall aenv sh e. (Shape sh, Elt e)+    => Direction+    -> UID+    -> Gamma aenv+    -> IRFun2 Native aenv (e -> e -> e)+    -> IRExp Native aenv e+    -> IRDelayed Native aenv (Array (sh:.Int) e)+    -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e, Array sh e))+mkScan'S dir uid aenv combine seed IRDelayed{..} =+  let+      (start, end, paramGang)   = gangParam+      (arrOut, paramOut)        = mutableArray ("out" :: Name (Array (sh:.Int) e))+      (arrSum, paramSum)        = mutableArray ("sum" :: Name (Array sh e))+      paramEnv                  = envParam aenv+      --+      next i                    = case dir of+                                    L -> A.add numType i (lift 1)+                                    R -> A.sub numType i (lift 1)+  in+  makeOpenAcc uid "scanS" (paramGang ++ paramOut ++ paramSum ++ paramEnv) $ do++    sz    <- indexHead <$> delayedExtent+    szm1  <- A.sub numType sz (lift 1)++    -- iterate over each lower-dimensional index (segment)+    imapFromTo start end $ \seg -> do++      -- index to read data from+      i0 <- case dir of+              L -> A.mul numType seg sz+              R -> do x <- A.mul numType sz seg+                      y <- A.add numType x szm1+                      return y++      -- initial element+      v0 <- seed++      iz <- case dir of+              L -> A.add numType i0 sz+              R -> A.sub numType i0 sz++      let cont i  = case dir of+                      L -> A.lt singleType i iz+                      R -> A.gt singleType i iz++      -- Loop through the input. Only at the top of the loop to we write the+      -- carry-in value (i.e. value from the last loop iteration) to the output+      -- array. This ensures correct behaviour if the input array was empty.+      r  <- while (cont . A.fst)+                  (\(A.unpair -> (i,v)) -> do+                      writeArray arrOut i v++                      u  <- app1 delayedLinearIndex i+                      v' <- case dir of+                              L -> app2 combine v u+                              R -> app2 combine u v+                      i' <- next i+                      return $ A.pair i' v')+                  (A.pair i0 v0)++      -- write final reduction result+      writeArray arrSum seg (A.snd r)++    return_+++mkScanP+    :: forall aenv e. Elt e+    => Direction+    -> UID+    -> Gamma aenv+    -> IRFun2 Native aenv (e -> e -> e)+    -> Maybe (IRExp Native aenv e)+    -> IRDelayed Native aenv (Vector e)+    -> CodeGen (IROpenAcc Native aenv (Vector e))+mkScanP dir uid aenv combine mseed arr =+  foldr1 (+++) <$> sequence [ mkScanP1 dir uid aenv combine mseed arr+                            , mkScanP2 dir uid aenv combine+                            , mkScanP3 dir uid aenv combine mseed+                            ]++-- Parallel scan, step 1.+--+-- Threads scan a stripe of the input into a temporary array, incorporating the+-- initial element and any fused functions on the way. The final reduction+-- result of this chunk is written to a separate array.+--+mkScanP1+    :: forall aenv e. Elt e+    => Direction+    -> UID+    -> Gamma aenv+    -> IRFun2 Native aenv (e -> e -> e)+    -> Maybe (IRExp Native aenv e)+    -> IRDelayed Native aenv (Vector e)+    -> CodeGen (IROpenAcc Native aenv (Vector e))+mkScanP1 dir uid aenv combine mseed IRDelayed{..} =+  let+      (chunk, _, paramGang)     = gangParam+      (arrOut, paramOut)        = mutableArray ("out" :: Name (Vector e))+      (arrTmp, paramTmp)        = mutableArray ("tmp" :: Name (Vector e))+      paramEnv                  = envParam aenv+      --+      steps                     = local           scalarType ("ix.steps"  :: Name Int)+      paramSteps                = scalarParameter scalarType ("ix.steps"  :: Name Int)+      stride                    = local           scalarType ("ix.stride" :: Name Int)+      paramStride               = scalarParameter scalarType ("ix.stride" :: Name Int)+      --+      next i                    = case dir of+                                    L -> A.add numType i (lift 1)+                                    R -> A.sub numType i (lift 1)+      firstChunk                = case dir of+                                    L -> lift 0+                                    R -> steps+  in+  makeOpenAcc uid "scanP1" (paramGang ++ paramStride : paramSteps : paramOut ++ paramTmp ++ paramEnv) $ do++    len <- indexHead <$> delayedExtent++    -- A thread scans a non-empty stripe of the input, storing the final+    -- reduction result into a separate array.+    --+    -- For exclusive scans the first chunk must incorporate the initial element+    -- into the input and output, while all other chunks increment their output+    -- index by one.+    inf <- A.mul numType    chunk stride+    a   <- A.add numType    inf   stride+    sup <- A.min singleType a     len++    -- index i* is the index that we read data from. Recall that the supremum+    -- index is exclusive+    i0  <- case dir of+             L -> return inf+             R -> next sup++    -- index j* is the index that we write to. Recall that for exclusive scan+    -- the output array is one larger than the input; the first chunk uses+    -- this spot to write the initial element, all other chunks shift by one.+    j0  <- case mseed of+             Nothing -> return i0+             Just _  -> case dir of+                          L -> if A.eq singleType chunk firstChunk+                                 then return i0+                                 else next i0+                          R -> if A.eq singleType chunk firstChunk+                                 then return sup+                                 else return i0++    -- Evaluate/read the initial element for this chunk. Update the read-from+    -- index appropriately+    (v0,i1) <- A.unpair <$> case mseed of+                 Just seed -> if A.eq singleType chunk firstChunk+                                then A.pair <$> seed                       <*> pure i0+                                else A.pair <$> app1 delayedLinearIndex i0 <*> next i0+                 Nothing   ->        A.pair <$> app1 delayedLinearIndex i0 <*> next i0++    -- Write first element+    writeArray arrOut j0 v0+    j1  <- next j0++    -- Continue looping through the rest of the input+    let cont i =+           case dir of+             L -> A.lt  singleType i sup+             R -> A.gte singleType i inf++    r   <- while (cont . A.fst3)+                 (\(A.untrip -> (i,j,v)) -> do+                     u  <- app1 delayedLinearIndex i+                     v' <- case dir of+                             L -> app2 combine v u+                             R -> app2 combine u v+                     writeArray arrOut j v'+                     A.trip <$> next i <*> next j <*> pure v')+                 (A.trip i1 j1 v0)++    -- Final reduction result of this chunk+    writeArray arrTmp chunk (A.thd3 r)++    return_+++-- Parallel scan, step 2.+--+-- A single thread performs an in-place inclusive scan of the partial block+-- sums. This forms the carry-in value which are added to the stripe partial+-- results in the final step.+--+mkScanP2+    :: forall aenv e. Elt e+    => Direction+    -> UID+    -> Gamma aenv+    -> IRFun2 Native aenv (e -> e -> e)+    -> CodeGen (IROpenAcc Native aenv (Vector e))+mkScanP2 dir uid aenv combine =+  let+      (start, end, paramGang)   = gangParam+      (arrTmp, paramTmp)        = mutableArray ("tmp" :: Name (Vector e))+      paramEnv                  = envParam aenv+      --+      cont i                    = case dir of+                                    L -> A.lt  singleType i end+                                    R -> A.gte singleType i start++      next i                    = case dir of+                                    L -> A.add numType i (lift 1)+                                    R -> A.sub numType i (lift 1)+  in+  makeOpenAcc uid "scanP2" (paramGang ++ paramTmp ++ paramEnv) $ do++    i0 <- case dir of+            L -> return start+            R -> next end++    v0 <- readArray arrTmp i0+    i1 <- next i0++    void $ while (cont . A.fst)+                 (\(A.unpair -> (i,v)) -> do+                    u  <- readArray arrTmp i+                    i' <- next i+                    v' <- case dir of+                            L -> app2 combine v u+                            R -> app2 combine u v+                    writeArray arrTmp i v'+                    return $ A.pair i' v')+                 (A.pair i1 v0)++    return_+++-- Parallel scan, step 3.+--+-- Threads combine every element of the partial block results with the carry-in+-- value computed from step 2.+--+-- Note that we launch (chunks-1) threads, because the first chunk does not need+-- extra processing (has no carry-in value).+--+mkScanP3+    :: forall aenv e. Elt e+    => Direction+    -> UID+    -> Gamma aenv+    -> IRFun2 Native aenv (e -> e -> e)+    -> Maybe (IRExp Native aenv e)+    -> CodeGen (IROpenAcc Native aenv (Vector e))+mkScanP3 dir uid aenv combine mseed =+  let+      (chunk, _, paramGang)     = gangParam+      (arrOut, paramOut)        = mutableArray ("out" :: Name (Vector e))+      (arrTmp, paramTmp)        = mutableArray ("tmp" :: Name (Vector e))+      paramEnv                  = envParam aenv+      --+      stride                    = local           scalarType ("ix.stride" :: Name Int)+      paramStride               = scalarParameter scalarType ("ix.stride" :: Name Int)+      --+      next i                    = case dir of+                                    L -> A.add numType i (lift 1)+                                    R -> A.sub numType i (lift 1)+      prev i                    = case dir of+                                    L -> A.sub numType i (lift 1)+                                    R -> A.add numType i (lift 1)+  in+  makeOpenAcc uid "scanP3" (paramGang ++ paramStride : paramOut ++ paramTmp ++ paramEnv) $ do++    -- Determine which chunk will be carrying in values for. Compute appropriate+    -- start and end indices.+    a     <- case dir of+               L -> next chunk+               R -> pure chunk++    b     <- A.mul numType    a stride+    c     <- A.add numType    b stride+    d     <- A.min singleType c (indexHead (irArrayShape arrOut))++    (inf,sup) <- case (dir,mseed) of+                   (L,Just _) -> (,) <$> next b <*> next d+                   _          -> (,) <$> pure b <*> pure d++    -- Carry in value from the previous chunk+    e     <- case dir of+               L -> pure chunk+               R -> prev chunk+    carry <- readArray arrTmp e++    imapFromTo inf sup $ \i -> do+      x <- readArray arrOut i+      y <- case dir of+             L -> app2 combine carry x+             R -> app2 combine x carry+      writeArray arrOut i y++    return_+++mkScan'P+    :: forall aenv e. Elt e+    => Direction+    -> UID+    -> Gamma aenv+    -> IRFun2 Native aenv (e -> e -> e)+    -> IRExp Native aenv e+    -> IRDelayed Native aenv (Vector e)+    -> CodeGen (IROpenAcc Native aenv (Vector e, Scalar e))+mkScan'P dir uid aenv combine seed arr =+  foldr1 (+++) <$> sequence [ mkScan'P1 dir uid aenv combine seed arr+                            , mkScan'P2 dir uid aenv combine+                            , mkScan'P3 dir uid aenv combine+                            ]++-- Parallel scan', step 1+--+-- Threads scan a stripe of the input into a temporary array. Similar to+-- exclusive scan, but since the size of the output array is the same as the+-- input, input and output indices are shifted by one.+--+mkScan'P1+    :: forall aenv e. Elt e+    => Direction+    -> UID+    -> Gamma aenv+    -> IRFun2 Native aenv (e -> e -> e)+    -> IRExp Native aenv e+    -> IRDelayed Native aenv (Vector e)+    -> CodeGen (IROpenAcc Native aenv (Vector e, Scalar e))+mkScan'P1 dir uid aenv combine seed IRDelayed{..} =+  let+      (chunk, _, paramGang)     = gangParam+      (arrOut, paramOut)        = mutableArray ("out" :: Name (Vector e))+      (arrTmp, paramTmp)        = mutableArray ("tmp" :: Name (Vector e))+      paramEnv                  = envParam aenv+      --+      steps                     = local           scalarType ("ix.steps"  :: Name Int)+      paramSteps                = scalarParameter scalarType ("ix.steps"  :: Name Int)+      stride                    = local           scalarType ("ix.stride" :: Name Int)+      paramStride               = scalarParameter scalarType ("ix.stride" :: Name Int)+      --+      next i                    = case dir of+                                    L -> A.add numType i (lift 1)+                                    R -> A.sub numType i (lift 1)++      firstChunk                = case dir of+                                    L -> lift 0+                                    R -> steps+  in+  makeOpenAcc uid "scanP1" (paramGang ++ paramStride : paramSteps : paramOut ++ paramTmp ++ paramEnv) $ do++    -- Compute the start and end indices for this non-empty chunk of the input.+    --+    len <- indexHead <$> delayedExtent+    inf <- A.mul numType    chunk stride+    a   <- A.add numType    inf   stride+    sup <- A.min singleType a     len++    -- index i* is the index that we pull data from.+    i0 <- case dir of+            L -> return inf+            R -> next sup++    -- index j* is the index that we write results to. The first chunk needs to+    -- include the initial element, and all other chunks shift their results+    -- across by one to make space.+    j0      <- if A.eq singleType chunk firstChunk+                 then pure i0+                 else next i0++    -- Evaluate/read the initial element. Update the read-from index+    -- appropriately.+    (v0,i1) <- A.unpair <$> if A.eq singleType chunk firstChunk+                              then A.pair <$> seed                       <*> pure i0+                              else A.pair <$> app1 delayedLinearIndex i0 <*> pure j0++    -- Write the first element+    writeArray arrOut j0 v0+    j1 <- next j0++    -- Continue looping through the rest of the input+    let cont i =+           case dir of+             L -> A.lt  singleType i sup+             R -> A.gte singleType i inf++    r  <- while (cont . A.fst3)+                (\(A.untrip-> (i,j,v)) -> do+                    u  <- app1 delayedLinearIndex i+                    v' <- case dir of+                            L -> app2 combine v u+                            R -> app2 combine u v+                    writeArray arrOut j v'+                    A.trip <$> next i <*> next j <*> pure v')+                (A.trip i1 j1 v0)++    -- Write the final reduction result of this chunk+    writeArray arrTmp chunk (A.thd3 r)++    return_+++-- Parallel scan', step 2+--+-- Identical to mkScanP2, except we store the total scan result into a separate+-- array (rather than discard it).+--+mkScan'P2+    :: forall aenv e. Elt e+    => Direction+    -> UID+    -> Gamma aenv+    -> IRFun2 Native aenv (e -> e -> e)+    -> CodeGen (IROpenAcc Native aenv (Vector e, Scalar e))+mkScan'P2 dir uid aenv combine =+  let+      (start, end, paramGang)   = gangParam+      (arrTmp, paramTmp)        = mutableArray ("tmp" :: Name (Vector e))+      (arrSum, paramSum)        = mutableArray ("sum" :: Name (Scalar e))+      paramEnv                  = envParam aenv+      --+      cont i                    = case dir of+                                    L -> A.lt  singleType i end+                                    R -> A.gte singleType i start++      next i                    = case dir of+                                    L -> A.add numType i (lift 1)+                                    R -> A.sub numType i (lift 1)+  in+  makeOpenAcc uid "scanP2" (paramGang ++ paramSum ++ paramTmp ++ paramEnv) $ do++    i0 <- case dir of+            L -> return start+            R -> next end++    v0 <- readArray arrTmp i0+    i1 <- next i0++    r  <- while (cont . A.fst)+                (\(A.unpair -> (i,v)) -> do+                   u  <- readArray arrTmp i+                   i' <- next i+                   v' <- case dir of+                           L -> app2 combine v u+                           R -> app2 combine u v+                   writeArray arrTmp i v'+                   return $ A.pair i' v')+                (A.pair i1 v0)++    writeArray arrSum (lift 0 :: IR Int) (A.snd r)++    return_+++-- Parallel scan', step 3+--+-- Similar to mkScanP3, except that indices are shifted by one since the output+-- array is the same size as the input (despite being an exclusive scan).+--+-- Launch (chunks-1) threads, because the first chunk does not need extra+-- processing.+--+mkScan'P3+    :: forall aenv e. Elt e+    => Direction+    -> UID+    -> Gamma aenv+    -> IRFun2 Native aenv (e -> e -> e)+    -> CodeGen (IROpenAcc Native aenv (Vector e, Scalar e))+mkScan'P3 dir uid aenv combine =+  let+      (chunk, _, paramGang)     = gangParam+      (arrOut, paramOut)        = mutableArray ("out" :: Name (Vector e))+      (arrTmp, paramTmp)        = mutableArray ("tmp" :: Name (Vector e))+      paramEnv                  = envParam aenv+      --+      stride                    = local           scalarType ("ix.stride" :: Name Int)+      paramStride               = scalarParameter scalarType ("ix.stride" :: Name Int)+      --+      next i                    = case dir of+                                    L -> A.add numType i (lift 1)+                                    R -> A.sub numType i (lift 1)+      prev i                    = case dir of+                                    L -> A.sub numType i (lift 1)+                                    R -> A.add numType i (lift 1)+  in+  makeOpenAcc uid "scanP3" (paramGang ++ paramStride : paramOut ++ paramTmp ++ paramEnv) $ do++    -- Determine which chunk we will be carrying in the values of, and compute+    -- the appropriate start and end indices+    a     <- case dir of+               L -> next chunk+               R -> pure chunk++    b     <- A.mul numType a stride+    c     <- A.add numType b stride+    d     <- A.min singleType c (indexHead (irArrayShape arrOut))++    inf   <- next b+    sup   <- next d++    -- Carry-value from the previous chunk+    e     <- case dir of+               L -> pure chunk+               R -> prev chunk++    carry <- readArray arrTmp e++    imapFromTo inf sup $ \i -> do+      x <- readArray arrOut i+      y <- case dir of+             L -> app2 combine carry x+             R -> app2 combine x carry+      writeArray arrOut i y++    return_+
+ src/Data/Array/Accelerate/LLVM/Native/Compile.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies    #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Compile+-- Copyright   : [2014..2017] Trevor L. McDonell+--               [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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 <- if Debug.debuggingIsEnabled then Debug.getFlag Debug.force_recomp else return False+    if exists && not recomp+      then do+        Debug.traceIO Debug.dump_cc (printf "cc: found cached object code %s" (show uid))+        B.readFile cacheFile++      else+        withContext                  $ \ctx     ->+        withModuleFromAST ctx ast    $ \mdl     ->+        withNativeTargetMachine      $ \machine ->+        withTargetLibraryInfo triple $ \libinfo -> do+          optimiseModule datalayout (Just machine) (Just libinfo) mdl++          Debug.when Debug.verbose $ do+            Debug.traceIO Debug.dump_cc  . B8.unpack =<< moduleLLVMAssembly mdl+            Debug.traceIO Debug.dump_asm . B8.unpack =<< moduleTargetAssembly machine mdl++          obj <- moduleObject machine mdl+          Debug.traceIO Debug.dump_cc (printf "cc: new object code %s" (show uid))+          B.writeFile cacheFile obj+          return obj++  return $! ObjectR uid nms obj+
+ src/Data/Array/Accelerate/LLVM/Native/Compile/Cache.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Compile.Cache+-- Copyright   : [2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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+         </> "llvm-hs-" ++ VERSION_llvm_hs+         </> S8.unpack nativeTargetTriple+         </> B8.unpack nativeCPUName+         </> "meep.o"+
+ src/Data/Array/Accelerate/LLVM/Native/Compile/Optimise.hs view
@@ -0,0 +1,143 @@+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Compile.Optimise+-- Copyright   : [2014..2017] Trevor L. McDonell+--               [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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+  ]+--}+
+ src/Data/Array/Accelerate/LLVM/Native/Debug.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE CPP           #-}+{-# LANGUAGE TypeOperators #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Debug+-- Copyright   : [2014..2017] Trevor L. McDonell+--               [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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+
+ src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple.hs view
@@ -0,0 +1,65 @@+-- |+-- 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)+
+ src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/Build.hs view
@@ -0,0 +1,451 @@+-- |+-- 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."++
+ src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC.hs view
@@ -0,0 +1,437 @@+-- |+-- 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 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)+        Internal.combineObjectFiles verbosity lbi ldProg+          ghciLibFilePath ghciObjFiles++      whenSharedLib False $+        runGhcProg ghcSharedLinkArgs+++-- | Returns True if the modification date of the given source file is newer than+-- the object file we last compiled for it, or if no object file exists yet.+checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool+checkNeedsRecompilation filename opts = filename `moreRecentFile` oname+    where oname = getObjectFileName filename opts++-- | Finds the object file name of the given source file+getObjectFileName :: FilePath -> GhcOptions -> FilePath+getObjectFileName filename opts = oname+    where odir  = fromFlag (ghcOptObjDir opts)+          oext  = fromFlagOrDefault "o" (ghcOptObjSuffix opts)+          oname = odir </> replaceExtension filename oext++-- | Calculate the RPATHs for the component we are building.+--+-- Calculates relative RPATHs when 'relocatable' is set.+getRPaths :: LocalBuildInfo+          -> ComponentLocalBuildInfo -- ^ Component we are building+          -> IO (NubListR FilePath)+getRPaths lbi clbi | supportRPaths hostOS = do+    libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi+    let hostPref = case hostOS of+                     OSX -> "@loader_path"+                     _   -> "$ORIGIN"+        relPath p = if isRelative p then hostPref </> p else p+        rpaths    = toNubListR (map relPath libraryPaths)+    return rpaths+  where+    (Platform _ hostOS) = hostPlatform lbi++    -- The list of RPath-supported operating systems below reflects the+    -- platforms on which Cabal's RPATH handling is tested. It does _NOT_+    -- reflect whether the OS supports RPATH.++    -- E.g. when this comment was written, the *BSD operating systems were+    -- untested with regards to Cabal RPATH handling, and were hence set to+    -- 'False', while those operating systems themselves do support RPATH.+    supportRPaths Linux       = True+    supportRPaths Windows     = False+    supportRPaths OSX         = True+    supportRPaths FreeBSD     = False+    supportRPaths OpenBSD     = False+    supportRPaths NetBSD      = False+    supportRPaths DragonFly   = False+    supportRPaths Solaris     = False+    supportRPaths AIX         = False+    supportRPaths HPUX        = False+    supportRPaths IRIX        = False+    supportRPaths HaLVM       = False+    supportRPaths IOS         = False+    supportRPaths Android     = False+    supportRPaths Ghcjs       = False+    supportRPaths Hurd        = False+    supportRPaths (OtherOS _) = False+    -- Do _not_ add a default case so that we get a warning here when a new OS+    -- is added.++getRPaths _ _ = return mempty++-- | Filter the "-threaded" flag when profiling as it does not+--   work with ghc-6.8 and older.+hackThreadedFlag :: Verbosity -> Compiler -> Bool -> BuildInfo -> IO BuildInfo+hackThreadedFlag _ _ _ = return++-- -----------------------------------------------------------------------------+-- Utils++supportsDynamicToo :: Compiler -> Bool+supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too"+
+ src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC/Internal.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE CPP #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC.Internal+-- Copyright   : [2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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,+  combineObjectFiles++) where++#if MIN_VERSION_Cabal(2,0,0)+import Distribution.Backpack+#endif+import Distribution.PackageDescription as PD hiding (Flag)+import Distribution.Simple.Compiler hiding (Flag)+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Program (ConfiguredProgram)+import Distribution.Simple.Program.GHC+import qualified Distribution.Simple.Program.Ld as Ld+import Distribution.Simple.Setup+import Distribution.Simple+import Distribution.Verbosity (Verbosity)+import qualified Distribution.ModuleName as ModuleName++import qualified Data.Map as Map+import System.Directory ( getDirectoryContents )+import System.FilePath ( (</>), (<.>), takeExtension )+++-- | Strip out flags that are not supported in ghci+filterGhciFlags :: [String] -> [String]+filterGhciFlags = filter supported+  where+    supported ('-':'O':_) = False+    supported "-debug"    = False+    supported "-threaded" = False+    supported "-ticky"    = False+    supported "-eventlog" = False+    supported "-prof"     = False+    supported "-unreg"    = False+    supported _           = True++#if MIN_VERSION_Cabal(1,24,0)+mkGHCiLibName :: UnitId -> String+mkGHCiLibName lib = getHSLibraryName lib <.> "o"+#else+mkGHCiLibName :: LibraryName -> String+mkGHCiLibName (LibraryName lib) = lib <.> "o"+#endif++ghcLookupProperty :: String -> Compiler -> Bool+ghcLookupProperty prop comp =+  case Map.lookup prop (compilerProperties comp) of+    Just "YES" -> True+    _          -> False++-- when using -split-objs, we need to search for object files in the+-- Module_split directory for each module.+getHaskellObjects :: _GhcImplInfo -> Library -> LocalBuildInfo+                  -> ComponentLocalBuildInfo+                  -> FilePath -> String -> Bool -> IO [FilePath]+getHaskellObjects _implInfo lib lbi clbi pref wanted_obj_ext allow_split_objs+  | splitObjs lbi && allow_split_objs = do+        let splitSuffix = "_" ++ wanted_obj_ext ++ "_split"+            dirs = [ pref </> (ModuleName.toFilePath x ++ splitSuffix)+                   | x <- allLibModules lib clbi ]+        objss <- traverse getDirectoryContents dirs+        let objs = [ dir </> obj+                   | (objs',dir) <- zip objss dirs, obj <- objs',+                     let obj_ext = takeExtension obj,+                     '.':wanted_obj_ext == obj_ext ]+        return objs+  | otherwise  =+        return [ pref </> ModuleName.toFilePath x <.> wanted_obj_ext+               | x <- allLibModules lib clbi ]++#if MIN_VERSION_Cabal(2,0,0)+mkGhcOptPackages :: ComponentLocalBuildInfo+                 -> [(OpenUnitId, ModuleRenaming)]+mkGhcOptPackages = componentIncludes+#else+mkGhcOptPackages :: ComponentLocalBuildInfo+                 -> [(InstalledPackageId, PackageId, ModuleRenaming)]+mkGhcOptPackages clbi =+  map (\(i,p) -> (i,p,lookupRenaming p (componentPackageRenaming clbi)))+      (componentPackageDeps clbi)+#endif++profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto+profDetailLevelFlag forLib mpl =+    case mpl of+      ProfDetailNone                -> mempty+      ProfDetailDefault | forLib    -> toFlag GhcProfAutoExported+                        | otherwise -> toFlag GhcProfAutoToplevel+      ProfDetailExportedFunctions   -> toFlag GhcProfAutoExported+      ProfDetailToplevelFunctions   -> toFlag GhcProfAutoToplevel+      ProfDetailAllFunctions        -> toFlag GhcProfAutoAll+      ProfDetailOther _             -> mempty++#if !MIN_VERSION_Cabal(2,0,0)+allLibModules :: Library -> ComponentLocalBuildInfo -> [ModuleName.ModuleName]+allLibModules lib _ = libModules lib+#endif++combineObjectFiles :: Verbosity -> LocalBuildInfo -> ConfiguredProgram+                   -> FilePath -> [FilePath] -> IO ()+#if MIN_VERSION_Cabal(2,1,0)+combineObjectFiles = Ld.combineObjectFiles+#else+combineObjectFiles v _ = Ld.combineObjectFiles v+#endif
+ src/Data/Array/Accelerate/LLVM/Native/Embed.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE BangPatterns    #-}+{-# LANGUAGE QuasiQuotes     #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns    #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Embed+-- Copyright   : [2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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 - 65) fn)), $$(makeFFI fn objFile) ) ||]+  --+  [|| NativeR (unsafePerformIO $ newLifetime (FunctionTable $$(listE funtab))) ||]+  where+    listE :: [Q (TExp a)] -> Q (TExp [a])+    listE xs = TH.unsafeTExpCoerce (TH.listE (map TH.unTypeQ xs))++    liftSBS :: ShortByteString -> Q (TExp ShortByteString)+    liftSBS bs =+      let bytes = BS.unpack bs+          len   = BS.length bs+      in+      [|| unsafePerformIO $ BS.createFromPtr $$( TH.unsafeTExpCoerce [| Ptr $(TH.litE (TH.StringPrimL bytes)) |]) len ||]++    makeFFI :: ShortByteString -> FilePath -> Q (TExp (FunPtr ()))+    makeFFI (S8.unpack -> fn) objFile = do+      i   <- TH.runIO newUnique+      fn' <- TH.newName ("__accelerate_llvm_native_" ++ showHex (hash i) [])+      dec <- TH.forImpD TH.CCall TH.Unsafe ('&':fn) fn' [t| FunPtr () |]+      ann <- TH.pragAnnD (TH.ValueAnnotation fn') [| (Object objFile) |]+      TH.addTopDecls [dec, ann]+      TH.unsafeTExpCoerce (TH.varE fn')+
+ src/Data/Array/Accelerate/LLVM/Native/Execute.hs view
@@ -0,0 +1,517 @@+{-# LANGUAGE FlexibleContexts         #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE GADTs                    #-}+{-# LANGUAGE OverloadedStrings        #-}+{-# LANGUAGE RecordWildCards          #-}+{-# LANGUAGE ScopedTypeVariables      #-}+{-# LANGUAGE TemplateHaskell          #-}+{-# LANGUAGE TypeOperators            #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Execute+-- Copyright   : [2014..2017] Trevor L. McDonell+--               [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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(..) )+import Control.Parallel.Meta                                        ( Executable(..) )+import Data.Array.Accelerate.LLVM.Native.Execute.LBS++-- library+import Control.Monad.State                                          ( gets )+import Control.Monad.Trans                                          ( liftIO )+import Data.ByteString.Short                                        ( ShortByteString )+import Data.List                                                    ( find )+import Data.Maybe                                                   ( fromMaybe )+import Data.Time.Clock                                              ( getCurrentTime, diffUTCTime )+import Data.Word                                                    ( Word8 )+import Text.Printf                                                  ( printf )+import Prelude                                                      hiding ( map, sum, scanl, scanr, init )+import qualified Data.ByteString.Short.Char8                        as S8+import qualified Prelude                                            as P++import Foreign.C+import Foreign.LibFFI+import Foreign.Ptr+++-- Array expression evaluation+-- ---------------------------++-- Computations are evaluated by traversing the AST bottom up, and for each node+-- distinguishing between three cases:+--+--  1. If it is a Use node, we return a reference to the array data. Even though+--     we execute with multiple cores, we assume a shared memory multiprocessor+--     machine.+--+--  2. If it is a non-skeleton node, such as a let binding or shape conversion,+--     then execute directly by updating the environment or similar.+--+--  3. If it is a skeleton node, then we need to execute the generated LLVM+--     code.+--+instance Execute Native where+  map           = simpleOp+  generate      = simpleOp+  transform     = simpleOp+  backpermute   = simpleOp+  fold          = foldOp+  fold1         = fold1Op+  foldSeg       = foldSegOp+  fold1Seg      = foldSegOp+  scanl         = scanOp+  scanl1        = scan1Op+  scanl'        = scan'Op+  scanr         = scanOp+  scanr1        = scan1Op+  scanr'        = scan'Op+  permute       = permuteOp+  stencil1      = simpleOp+  stencil2      = stencil2Op+  aforeign      = aforeignOp+++-- Skeleton implementation+-- -----------------------++-- Simple kernels just needs to know the shape of the output array.+--+simpleOp+    :: (Shape sh, Elt e)+    => ExecutableR Native+    -> Gamma aenv+    -> Aval aenv+    -> Stream+    -> sh+    -> LLVM Native (Array sh e)+simpleOp exe gamma aenv () sh = withExecutable exe $ \nativeExecutable -> do+  let fun = case functionTable nativeExecutable of+              f:_ -> f+              _   -> $internalError "simpleOp" "no functions found"+  --+  Native{..} <- gets llvmTarget+  liftIO $ do+    out <- allocateArray sh+    executeOp defaultLargePPT fillP fun gamma aenv (IE 0 (size sh)) out+    return out++simpleNamed+    :: (Shape sh, Elt e)+    => ShortByteString+    -> ExecutableR Native+    -> Gamma aenv+    -> Aval aenv+    -> Stream+    -> sh+    -> LLVM Native (Array sh e)+simpleNamed name exe gamma aenv () sh = withExecutable exe $ \nativeExecutable -> do+  Native{..} <- gets llvmTarget+  liftIO $ do+    out <- allocateArray sh+    executeOp defaultLargePPT fillP (nativeExecutable !# name) gamma aenv (IE 0 (size sh)) out+    return out+++-- Note: [Reductions]+--+-- There are two flavours of reduction:+--+--   1. If we are collapsing to a single value, then threads reduce strips of+--      the input in parallel, and then a single thread reduces the partial+--      reductions to a single value. Load balancing occurs over the input+--      stripes.+--+--   2. If this is a multidimensional reduction, then each inner dimension is+--      handled by a single thread. Load balancing occurs over the outer+--      dimension indices.+--+-- The entry points to executing the reduction are 'foldOp' and 'fold1Op', for+-- exclusive and inclusive reductions respectively. These functions handle+-- whether the input array is empty. If the input and output arrays are+-- non-empty, we then further dispatch (via 'foldCore') to 'foldAllOp' or+-- 'foldDimOp' for single or multidimensional reductions, respectively.+-- 'foldAllOp' in particular must execute specially whether the gang has+-- multiple worker threads which can process the array in parallel.+--++fold1Op+    :: (Shape sh, Elt e)+    => ExecutableR Native+    -> Gamma aenv+    -> Aval aenv+    -> Stream+    -> (sh :. Int)+    -> LLVM Native (Array sh e)+fold1Op kernel gamma aenv stream sh@(sx :. sz)+  = $boundsCheck "fold1" "empty array" (sz > 0)+  $ case size sh of+      0 -> liftIO $ allocateArray sx   -- empty, but possibly with non-zero dimensions+      _ -> foldCore kernel gamma aenv stream sh++foldOp+    :: (Shape sh, Elt e)+    => ExecutableR Native+    -> Gamma aenv+    -> Aval aenv+    -> Stream+    -> (sh :. Int)+    -> LLVM Native (Array sh e)+foldOp kernel gamma aenv stream sh@(sx :. _) =+  case size sh of+    0 -> simpleNamed "generate" kernel gamma aenv stream sx+    _ -> foldCore kernel gamma aenv stream sh++foldCore+    :: (Shape sh, Elt e)+    => ExecutableR Native+    -> Gamma aenv+    -> Aval aenv+    -> Stream+    -> (sh :. Int)+    -> LLVM Native (Array sh e)+foldCore kernel gamma aenv stream sh+  | Just Refl <- matchShapeType sh (undefined::DIM1)+  = foldAllOp kernel gamma aenv stream sh+  --+  | otherwise+  = foldDimOp kernel gamma aenv stream sh++foldAllOp+    :: forall aenv e. Elt e+    => ExecutableR Native+    -> Gamma aenv+    -> Aval aenv+    -> Stream+    -> DIM1+    -> LLVM Native (Scalar e)+foldAllOp exe gamma aenv () (Z :. sz) = withExecutable exe $ \nativeExecutable -> do+  Native{..} <- gets llvmTarget+  let+      ncpu    = gangSize+      stride  = defaultLargePPT `min` ((sz + ncpu - 1) `quot` ncpu)+      steps   = (sz + stride - 1) `quot` stride+  --+  if ncpu == 1 || sz <= defaultLargePPT+    then liftIO $ do+      -- Sequential reduction+      out <- allocateArray Z+      executeOp 1 fillS (nativeExecutable !# "foldAllS") gamma aenv (IE 0 sz) out+      return out++    else liftIO $ do+      -- Parallel reduction+      out <- allocateArray Z+      tmp <- allocateArray (Z :. steps) :: IO (Vector e)+      executeOp 1 fillP (nativeExecutable !# "foldAllP1") gamma aenv (IE 0 steps) (sz, stride, tmp)+      executeOp 1 fillS (nativeExecutable !# "foldAllP2") gamma aenv (IE 0 steps) (tmp, out)+      return out++foldDimOp+    :: (Shape sh, Elt e)+    => ExecutableR Native+    -> Gamma aenv+    -> Aval aenv+    -> Stream+    -> (sh :. Int)+    -> LLVM Native (Array sh e)+foldDimOp exe gamma aenv () (sh :. sz) = withExecutable exe $ \nativeExecutable -> do+  Native{..} <- gets llvmTarget+  let ppt = defaultSmallPPT `max` (defaultLargePPT `quot` (max 1 sz))+  liftIO $ do+    out <- allocateArray sh+    executeOp ppt fillP (nativeExecutable !# "fold") gamma aenv (IE 0 (size sh)) (sz, out)+    return out++foldSegOp+    :: (Shape sh, Elt e)+    => ExecutableR Native+    -> Gamma aenv+    -> Aval aenv+    -> Stream+    -> (sh :. Int)+    -> (Z  :. Int)+    -> LLVM Native (Array (sh :. Int) e)+foldSegOp exe gamma aenv () (sh :. _) (Z :. ss) = withExecutable exe $ \nativeExecutable -> do+  Native{..} <- gets llvmTarget+  let+      kernel | segmentOffset  = "foldSegP"+             | otherwise      = "foldSegS"+      n      | segmentOffset  = ss - 1            -- segments array has been 'scanl (+) 0'`ed+             | otherwise      = ss+      ppt    | rank sh == 0   = defaultLargePPT   -- work-steal over the single dimension+             | otherwise      = n                 -- a thread computes all segments along an index+  --+  liftIO $ do+    out <- allocateArray (sh :. n)+    executeOp ppt fillP (nativeExecutable !# kernel) gamma aenv (IE 0 (size (sh :. n))) out+    return out+++scanOp+    :: (Shape sh, Elt e)+    => ExecutableR Native+    -> Gamma aenv+    -> Aval aenv+    -> Stream+    -> sh :. Int+    -> LLVM Native (Array (sh:.Int) e)+scanOp kernel gamma aenv stream (sz :. n) =+  case n of+    0 -> simpleNamed "generate" kernel gamma aenv stream (sz :. 1)+    _ -> scanCore kernel gamma aenv stream sz n (n+1)++scan1Op+    :: (Shape sh, Elt e)+    => ExecutableR Native+    -> Gamma aenv+    -> Aval aenv+    -> Stream+    -> sh :. Int+    -> LLVM Native (Array (sh:.Int) e)+scan1Op kernel gamma aenv stream (sz :. n)+  = $boundsCheck "scan1" "empty array" (n > 0)+  $ scanCore kernel gamma aenv stream sz n n++scanCore+    :: forall aenv sh e. (Shape sh, Elt e)+    => ExecutableR Native+    -> Gamma aenv+    -> Aval aenv+    -> Stream+    -> sh+    -> Int+    -> Int+    -> LLVM Native (Array (sh:.Int) e)+scanCore exe gamma aenv () sz n m = withExecutable exe $ \nativeExecutable -> do+  Native{..} <- gets llvmTarget+  let+      ncpu    = gangSize+      stride  = defaultLargePPT `min` ((n + ncpu - 1) `quot` ncpu)+      steps   = (n + stride - 1) `quot` stride+      steps'  = steps - 1+  --+  if ncpu == 1 || rank sz > 0 || n <= 2 * defaultLargePPT+    then liftIO $ do+      -- Either:+      --+      --  1. Sequential scan of an array of any rank+      --+      --  2. Parallel scan of multidimensional array: threads scan along the+      --     length of the innermost dimension. Threads are scheduled over the+      --     inner dimensions.+      --+      --  3. Small 1D array. Since parallel scan requires ~4n data transfer+      --     compared to ~2n in the sequential case, it is only worthwhile if+      --     the extra cores can offset the increased bandwidth requirements.+      --+      out <- allocateArray (sz :. m)+      executeOp 1 fillP (nativeExecutable !# "scanS") gamma aenv (IE 0 (size sz)) out+      return out++    else liftIO $ do+      -- parallel one-dimensional scan+      out <- allocateArray (sz :. m)+      tmp <- allocateArray (Z  :. steps) :: IO (Vector e)+      executeOp 1 fillP (nativeExecutable !# "scanP1") gamma aenv (IE 0 steps) (stride, steps', out, tmp)+      executeOp 1 fillS (nativeExecutable !# "scanP2") gamma aenv (IE 0 steps) tmp+      executeOp 1 fillP (nativeExecutable !# "scanP3") gamma aenv (IE 0 steps') (stride, out, tmp)+      return out+++scan'Op+    :: forall aenv sh e. (Shape sh, Elt e)+    => ExecutableR Native+    -> Gamma aenv+    -> Aval aenv+    -> Stream+    -> sh :. Int+    -> LLVM Native (Array (sh:.Int) e, Array sh e)+scan'Op native gamma aenv stream sh@(sz :. n) =+  case n of+    0 -> do+      out <- liftIO $ allocateArray (sz :. 0)+      sum <- simpleNamed "generate" native gamma aenv stream sz+      return (out, sum)+    --+    _ -> scan'Core native gamma aenv stream sh++scan'Core+    :: forall aenv sh e. (Shape sh, Elt e)+    => ExecutableR Native+    -> Gamma aenv+    -> Aval aenv+    -> Stream+    -> sh :. Int+    -> LLVM Native (Array (sh:.Int) e, Array sh e)+scan'Core exe gamma aenv () sh@(sz :. n) = withExecutable exe $ \nativeExecutable -> do+  Native{..} <- gets llvmTarget+  let+      ncpu    = gangSize+      stride  = defaultLargePPT `min` ((n + ncpu - 1) `quot` ncpu)+      steps   = (n + stride - 1) `quot` stride+      steps'  = steps - 1+  --+  if ncpu == 1 || rank sz > 0 || n <= 2 * defaultLargePPT+    then liftIO $ do+      out <- allocateArray sh+      sum <- allocateArray sz+      executeOp 1 fillP (nativeExecutable !# "scanS") gamma aenv (IE 0 (size sz)) (out,sum)+      return (out,sum)++    else liftIO $ do+      tmp <- allocateArray (Z :. steps) :: IO (Vector e)+      out <- allocateArray sh+      sum <- allocateArray sz+      executeOp 1 fillP (nativeExecutable !# "scanP1") gamma aenv (IE 0 steps)  (stride, steps', out, tmp)+      executeOp 1 fillS (nativeExecutable !# "scanP2") gamma aenv (IE 0 steps)  (sum, tmp)+      executeOp 1 fillP (nativeExecutable !# "scanP3") gamma aenv (IE 0 steps') (stride, out, tmp)+      return (out,sum)+++-- Forward permutation, specified by an indexing mapping into an array and a+-- combination function to combine elements.+--+permuteOp+    :: (Shape sh, Shape sh', Elt e)+    => ExecutableR Native+    -> Gamma aenv+    -> Aval aenv+    -> Stream+    -> Bool+    -> sh+    -> Array sh' e+    -> LLVM Native (Array sh' e)+permuteOp exe gamma aenv () inplace shIn dfs = withExecutable exe $ \nativeExecutable -> do+  Native{..} <- gets llvmTarget+  out        <- if inplace+                  then return dfs+                  else cloneArray dfs+  let+      ncpu    = gangSize+      n       = size shIn+      m       = size (shape out)+  --+  if ncpu == 1 || n <= defaultLargePPT+    then liftIO $ do+      -- sequential permutation+      executeOp 1 fillS (nativeExecutable !# "permuteS") gamma aenv (IE 0 n) out++    else liftIO $ do+      -- parallel permutation+      case lookupFunction "permuteP_rmw" nativeExecutable of+        Just f  -> executeOp defaultLargePPT fillP f gamma aenv (IE 0 n) out+        Nothing -> do+          barrier@(Array _ adb) <- allocateArray (Z :. m) :: IO (Vector Word8)+          memset (ptrsOfArrayData adb) 0 m+          executeOp defaultLargePPT fillP (nativeExecutable !# "permuteP_mutex") gamma aenv (IE 0 n) (out, barrier)++  return out+++stencil2Op+    :: (Shape sh, Elt e)+    => ExecutableR Native+    -> Gamma aenv+    -> Aval aenv+    -> Stream+    -> sh+    -> sh+    -> LLVM Native (Array sh e)+stencil2Op kernel gamma aenv stream sh1 sh2 =+  simpleOp kernel gamma aenv stream (sh1 `intersect` sh2)+++aforeignOp+    :: (Arrays as, Arrays bs)+    => String+    -> (Stream -> as -> LLVM Native bs)+    -> Stream+    -> as+    -> LLVM Native bs+aforeignOp name asm stream arr = do+  wallBegin <- liftIO $ getCurrentTime+  result    <- Debug.timed Debug.dump_exec (\wall cpu -> printf "exec: %s %s" name (Debug.elapsedP wall cpu)) (asm stream arr)+  wallEnd   <- liftIO $ getCurrentTime+  liftIO $ Debug.addProcessorTime Debug.Native (realToFrac (diffUTCTime wallEnd wallBegin))+  return result+++-- Skeleton execution+-- ------------------++(!#) :: FunctionTable -> ShortByteString -> Function+(!#) exe name+  = fromMaybe ($internalError "lookupFunction" ("function not found: " ++ S8.unpack name))+  $ lookupFunction name exe++lookupFunction :: ShortByteString -> FunctionTable -> Maybe Function+lookupFunction name nativeExecutable = do+  find (\(n,_) -> n == name) (functionTable nativeExecutable)++-- Execute the given function distributed over the available threads.+--+executeOp+    :: Marshalable args+    => Int+    -> Executable+    -> Function+    -> Gamma aenv+    -> Aval aenv+    -> Range+    -> args+    -> IO ()+executeOp ppt exe (name, f) gamma aenv r args = do+  args' <- marshal (undefined::Native) () (args, (gamma, aenv))+  --+  runExecutable exe name ppt r $ \start end _tid -> do+   monitorProcTime             $+    callFFI f retVoid (argInt start : argInt end : args')+++-- Standard C functions+-- --------------------++memset :: Ptr Word8 -> Word8 -> Int -> IO ()+memset p w s = c_memset p (fromIntegral w) (fromIntegral s) >> return ()++foreign import ccall unsafe "string.h memset" c_memset+    :: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8)+++-- Debugging+-- ---------++monitorProcTime :: IO a -> IO a+monitorProcTime = Debug.withProcessor Debug.Native+
+ src/Data/Array/Accelerate/LLVM/Native/Execute/Async.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Execute.Async+-- Copyright   : [2014..2017] Trevor L. McDonell+--               [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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 ()+
+ src/Data/Array/Accelerate/LLVM/Native/Execute/Environment.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE CPP   #-}+{-# LANGUAGE GADTs #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Execute.Environment+-- Copyright   : [2014..2017] Trevor L. McDonell+--               [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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+
+ src/Data/Array/Accelerate/LLVM/Native/Execute/LBS.hs view
@@ -0,0 +1,34 @@+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Execute.LBS+-- Copyright   : [2014..2017] Trevor L. McDonell+--               [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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+
+ src/Data/Array/Accelerate/LLVM/Native/Execute/Marshal.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+#if __GLASGOW_HASKELL__ <= 708+{-# LANGUAGE OverlappingInstances  #-}+{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}+#endif+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Execute.Marshal+-- Copyright   : [2014..2017] Trevor L. McDonell+--               [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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 (ArrayEltRvec2 ae)  (AD_V2 ad)  = marshalR ae ad+      marshalR (ArrayEltRvec3 ae)  (AD_V3 ad)  = marshalR ae ad+      marshalR (ArrayEltRvec4 ae)  (AD_V4 ad)  = marshalR ae ad+      marshalR (ArrayEltRvec8 ae)  (AD_V8 ad)  = marshalR ae ad+      marshalR (ArrayEltRvec16 ae) (AD_V16 ad) = marshalR ae ad+      --+      marshalR ArrayEltRint     ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+      marshalR ArrayEltRint8    ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+      marshalR ArrayEltRint16   ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+      marshalR ArrayEltRint32   ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+      marshalR ArrayEltRint64   ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+      marshalR ArrayEltRword    ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+      marshalR ArrayEltRword8   ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+      marshalR ArrayEltRword16  ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+      marshalR ArrayEltRword32  ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+      marshalR ArrayEltRword64  ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+      marshalR ArrayEltRhalf    ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+      marshalR ArrayEltRfloat   ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+      marshalR ArrayEltRdouble  ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+      marshalR ArrayEltRchar    ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+      marshalR ArrayEltRcshort  ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+      marshalR ArrayEltRcushort ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+      marshalR ArrayEltRcint    ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+      marshalR ArrayEltRcuint   ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+      marshalR ArrayEltRclong   ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+      marshalR ArrayEltRculong  ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+      marshalR ArrayEltRcllong  ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+      marshalR ArrayEltRcullong ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+      marshalR ArrayEltRcchar   ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+      marshalR ArrayEltRcschar  ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+      marshalR ArrayEltRcuchar  ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+      marshalR ArrayEltRcfloat  ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+      marshalR ArrayEltRcdouble ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+      marshalR ArrayEltRbool    ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+
+ src/Data/Array/Accelerate/LLVM/Native/Foreign.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving  #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Foreign+-- Copyright   : [2016..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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+
+ src/Data/Array/Accelerate/LLVM/Native/Link.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE CPP             #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies    #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Link+-- Copyright   : [2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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+
+ src/Data/Array/Accelerate/LLVM/Native/Link/COFF.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE TemplateHaskell #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Link.COFF+-- Copyright   : [2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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"+
+ src/Data/Array/Accelerate/LLVM/Native/Link/Cache.hs view
@@ -0,0 +1,22 @@+-- |+-- 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+
+ src/Data/Array/Accelerate/LLVM/Native/Link/ELF.chs view
@@ -0,0 +1,752 @@+{-# LANGUAGE CPP                      #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE MagicHash                #-}+{-# LANGUAGE RecordWildCards          #-}+{-# LANGUAGE TemplateHaskell          #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Link.ELF+-- Copyright   : [2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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.Prim                                           ( addr2Int#, int2Word#, int2Addr# )+import GHC.Ptr                                            ( Ptr(..) )+import GHC.Word                                           ( Word64(..) )+import System.IO.Unsafe+import System.Posix.DynamicLinker+import System.Posix.Types                                 ( COff(..) )+import Text.Printf+import qualified Data.ByteString                          as B+import qualified Data.ByteString.Char8                    as B8+import qualified Data.ByteString.Internal                 as B+import qualified Data.ByteString.Short                    as BS+import qualified Data.ByteString.Unsafe                   as B+import qualified Data.Vector                              as V+import Prelude                                            as P++#include <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++      -- Unmap the executable pages when they are no longer required+      --+      objectcode <- newLifetime [oc]+      addFinalizer objectcode $ do+        Debug.traceIO Debug.dump_gc ("gc: unload module: " ++ show funtab)+        case oc of+          Segment vmsize oc_fp ->+            withForeignPtr oc_fp $ \oc_p ->+              munmap oc_p vmsize++      return (funtab, objectcode)+++-- Load the sections into memory.+--+-- Extra jump islands are added directly after the section data. On x86_64+-- PC-relative jumps and accesses to the global offset table are limited to+-- 32-bits (+-2GB). If we need to go outside of this range than we must do so+-- via the jump islands.+--+-- NOTE: This puts all the sections into a single block of memory. Technically+-- this is incorrect because we then have both text and data sections together,+-- meaning that data sections are marked as execute when they really shouldn't+-- be. These would need to live in different pages in order to be mprotect-ed+-- properly.+--+loadSegment+    :: ByteString+    -> ByteString+    -> Vector SectionHeader+    -> Vector Symbol+    -> Vector Relocation+    -> IO (FunctionTable, Segment)+loadSegment obj strtab secs symtab relocs = do+  let+      pagesize    = fromIntegral c_getpagesize++      -- round up to next multiple of given alignment+      pad align n = (n + align - 1) .&. (complement (align - 1))++      -- determine where each section should be placed in memory, respecting+      -- alignment requirements. SectionHeaders which do not correspond to+      -- program data (e.g. systab) just carry along the previous offset value.+      -- This is to avoid filtering the list of sections, so that section+      -- indices (e.g. in relocations) remain valid.+      --+      nsecs       = V.length secs+      offsets     = V.constructN (nsecs + 1) $ \v ->+                      case V.length v of+                        0 -> 0+                        n -> let this     = secs V.! n+                                 prev     = secs V.! (n-1)+                                 alloc s  = testBit (sh_flags s) 1  -- SHF_ALLOC: section occupies memory at execution?+                                 --+                                 align | n >= nsecs       = 16+                                       | not (alloc this) = 1+                                       | otherwise        = sh_align this+                                 --+                                 size  | alloc prev       = sh_size prev+                                       | otherwise        = 0+                             in+                             pad align (size + v V.! (n-1))++      -- The section at index `i` should place its data beginning at page boundary+      -- offset given by offsets!i.+      --+      vmsize'     = V.last offsets                                  -- bytes required to store all sections+      vmsize      = pad pagesize (vmsize' + (V.length symtab * 16)) -- sections + jump tables++  -- Allocate new pages to store the executable code. This is allocated in+  -- the lower 2GB so that 32-bit relocations should work without needing+  -- to go via the jump tables.+  --+  -- The memory is implicitly initialised to zero (corresponding to NOP).+  -- This also takes care of .bss sections.+  --+  seg_p   <- mmap vmsize+  seg_fp  <- newForeignPtr_ seg_p++  -- Jump tables are placed directly after the segment data+  let jump_p = seg_p `plusPtr` vmsize'+  V.imapM_ (makeJumpIsland jump_p) symtab++  -- Copy over section data+  V.izipWithM_ (loadSection obj strtab seg_p) offsets secs++  -- Process relocations+  V.mapM_ (processRelocation symtab offsets seg_p jump_p) relocs++  -- Mark the page as executable and read-only+  mprotect seg_p vmsize ({#const PROT_READ#} .|. {#const PROT_EXEC#})++  -- Resolve external symbols defined in the sections into function+  -- pointers.+  --+  -- Note that in order to support ahead-of-time compilation, the generated+  -- functions are given unique names by appending with an underscore followed+  -- by a unique ID. The execution phase doesn't need to know about this+  -- however, so un-mangle the name to the basic "map", "fold", etc.+  --+  let funtab              = FunctionTable $ V.toList (V.map resolve (V.filter extern symtab))+      extern Symbol{..}   = sym_binding == Global && sym_type == Func+      resolve Symbol{..}  =+        let name  = BS.toShort (B8.take (B8.length sym_name - 65) sym_name)+            addr  = castPtrToFunPtr (seg_p `plusPtr` (fromIntegral sym_value + offsets V.! sym_section))+        in+        (name, addr)+  --+  return (funtab, Segment vmsize seg_fp)+++-- Add the jump-table entries directly to each external undefined symbol.+--+makeJumpIsland :: Ptr Word8 -> Int -> Symbol -> IO ()+makeJumpIsland jump_p symbolnum Symbol{..} = do+#ifdef x86_64_HOST_ARCH+  when (sym_binding == Global && sym_section == 0) $ do+    let+        target  = jump_p `plusPtr` (symbolnum * 16) :: Ptr Word64   -- addr+        instr   = target `plusPtr` 8                :: Ptr Word8    -- jumpIsland+    --+    poke target sym_value+    pokeArray instr [ 0xFF, 0x25, 0xF2, 0xFF, 0xFF, 0xFF ]  -- jmp *-14(%rip)+#endif+  return ()+++-- Load the section at the correct offset into the given segment+--+loadSection :: ByteString -> ByteString -> Ptr Word8 -> Int -> Int -> SectionHeader -> IO ()+loadSection obj strtab seg_p sec_num sec_addr SectionHeader{..} =+  when (sh_type == ProgBits && sh_size > 0) $ do+    message (printf "section %d: Mem: 0x%09x-0x%09x         %s" sec_num sec_addr (sec_addr+sh_size) (B8.unpack (indexStringTable strtab sh_name)))+    let (obj_fp, obj_offset, _) = B.toForeignPtr obj+    --+    withForeignPtr obj_fp $ \obj_p -> do+      -- Copy this section's data to the appropriate place in the segment+      let src = obj_p `plusPtr` (obj_offset + sh_offset)+          dst = seg_p `plusPtr` sec_addr+      --+      copyBytes dst src sh_size+++-- Process local and external relocations.+--+processRelocation :: Vector Symbol -> Vector Int -> Ptr Word8 -> Ptr Word8 -> Relocation -> IO ()+#ifdef x86_64_HOST_ARCH+processRelocation symtab sec_offset seg_p jump_p Relocation{..} = do+  message (printf "relocation: 0x%04x to symbol %d in section %d, type=%-14s value=%s%+d" r_offset r_symbol r_section (show r_type) (B8.unpack sym_name) r_addend)+  case r_type of+    R_X86_64_None -> return ()+    R_X86_64_64   -> relocate value++    R_X86_64_PC32 ->+      let offset :: Int64+          offset = fromIntegral (value - pc')+      in+      if offset >= 0x7fffffff || offset < -0x80000000+        then+          let jump'   = castPtrToWord64 (jump_p `plusPtr` (r_symbol * 16 + 8))+              offset' = fromIntegral jump' + r_addend - fromIntegral pc'+          in+          relocate (fromIntegral offset' :: Word32)+        else+          relocate (fromIntegral offset  :: Word32)++    R_X86_64_PC64 ->+      let offset :: Int64+          offset = fromIntegral (value - pc')+      in+      relocate (fromIntegral offset :: Word32)++    R_X86_64_32 ->+      if value >= 0x7fffffff+        then+          let jump'   = castPtrToWord64 (jump_p `plusPtr` (r_symbol * 16 + 8))+              value'  = fromIntegral jump' + r_addend+          in+          relocate (fromIntegral value' :: Word32)+        else+          relocate (fromIntegral value  :: Word32)++    R_X86_64_32S ->+      let values :: Int64+          values = fromIntegral value+      in+      if values > 0x7fffffff || values < -0x80000000+        then+          let jump'   = castPtrToWord64 (jump_p `plusPtr` (r_symbol * 16 + 8))+              value'  = fromIntegral jump' + r_addend+          in+          relocate (fromIntegral value' :: Int32)+        else+          relocate (fromIntegral value  :: Int32)++    R_X86_64_PLT32 ->+      let offset :: Int64+          offset  = fromIntegral (value - pc')+      in+      if offset >= 0x7fffffff || offset < -0x80000000+        then+          let jump'   = castPtrToWord64 (jump_p `plusPtr` (r_symbol * 16 + 8))+              offset' = fromIntegral jump' + r_addend - fromIntegral pc'+          in+          relocate (fromIntegral offset' :: Word32)+        else+          relocate (fromIntegral offset  :: Word32)++  where+    pc :: Ptr Word8+    pc  = seg_p `plusPtr` (fromIntegral r_offset + sec_offset V.! r_section)+    pc' = castPtrToWord64 pc++    value :: Word64+    value = symval + fromIntegral r_addend++    symval :: Word64+    symval =+      case sym_binding of+        Local   -> castPtrToWord64 (seg_p `plusPtr` (sec_offset V.! sym_section + fromIntegral sym_value))+        Global  -> sym_value+        Weak    -> $internalError "processRelocation" "unhandled weak symbol"++    Symbol{..} = symtab V.! r_symbol++    relocate :: Storable a => a -> IO ()+    relocate x = poke (castPtr pc) x++#else+precessRelocation =+  $internalError "processRelocation" "not defined for non-x86_64 architectures yet"+#endif+++-- Object file parser+-- ------------------++-- Parse an ELF object file and return the set of section load commands, as well+-- as the symbols defined within the sections of the object.+--+-- Actually loading the sections into executable memory happens separately.+--+parseObject :: ByteString -> Either String (Vector SectionHeader, Vector Symbol, Vector Relocation, ByteString)+parseObject obj = do+  (p, tph, tsec, strix) <- runGet readHeader obj++  -- As this is an object file, we do not expect any program headers+  unless (tb_entries tph == 0) $ fail "unhandled program header(s)"++  -- Read the object file headers+  secs    <- runGet (V.replicateM (tb_entries tsec) (readSectionHeader p)) (B.drop (tb_fileoff tsec) obj)+  strtab  <- readStringTable obj (secs V.! strix)++  let symtab  = V.toList . V.filter (\s -> sh_type s == SymTab)+      reloc   = V.toList . V.filter (\s -> sh_type s == Rel || sh_type s == RelA)++  symbols <- V.concat <$> sequence [ readSymbolTable p secs obj sh | sh <- symtab secs ]+  relocs  <- V.concat <$> sequence [ readRelocations p      obj sh | sh <- reloc secs ]++  return (secs, symbols, relocs, strtab)+++-- Parsing depends on whether the ELF file is 64-bit and whether it should be+-- read as big- or little-endian.+--+data Peek = Peek+    { is64Bit   :: !Bool+    , getWord16 :: !(Get Word16)+    , getWord32 :: !(Get Word32)+    , getWord64 :: !(Get Word64)+    }++data Table = Table+    { tb_fileoff    :: {-# UNPACK #-} !Int    -- byte offset to start of table (array)+    , tb_entries    :: {-# UNPACK #-} !Int    -- number of entries in the table (array)+    , tb_entrysize  :: {-# UNPACK #-} !Int    -- size in bytes per entry+    }++{--+data ProgramHeader = ProgramHeader+    { prog_vmaddr   :: {-# UNPACK #-} !Int    -- virtual address+    , prog_vmsize   :: {-# UNPACK #-} !Int    -- size in memory+    , prog_fileoff  :: {-# UNPACK #-} !Int    -- file offset+    , prog_filesize :: {-# UNPACK #-} !Int    -- size in file+    , prog_align    :: {-# UNPACK #-} !Int    -- alignment+    , prog_paddr    :: {-# UNPACK #-} !Int    -- physical address+    }+--}++data SectionHeader = SectionHeader+    { sh_name       :: {-# UNPACK #-} !Int    -- string table index+    , sh_addr       :: {-# UNPACK #-} !Word64 -- virtual memory address+    , sh_size       :: {-# UNPACK #-} !Int    -- section size in bytes+    , sh_offset     :: {-# UNPACK #-} !Int    -- file offset in bytes+    , sh_align      :: {-# UNPACK #-} !Int+    , sh_link       :: {-# UNPACK #-} !Int+    , sh_info       :: {-# UNPACK #-} !Int    -- additional section info+    , sh_entsize    :: {-# UNPACK #-} !Int    -- entry size, if section holds table+    , sh_flags      :: {-# UNPACK #-} !Word64+    , sh_type       :: !SectionType+    }+    deriving Show++{#enum define SectionType+    { SHT_NULL      as NullSection+    , SHT_PROGBITS  as ProgBits+    , SHT_SYMTAB    as SymTab+    , SHT_STRTAB    as StrTab+    , SHT_RELA      as RelA+    , SHT_HASH      as Hash+    , SHT_DYNAMIC   as Dynamic+    , SHT_NOTE      as Note+    , SHT_NOBITS    as NoBits+    , SHT_REL       as Rel+    , SHT_DYNSYM    as DynSym+    }+    deriving (Eq, Show)+#}++data Symbol = Symbol+    { sym_name      :: {-# UNPACK #-} !ByteString+    , sym_value     :: {-# UNPACK #-} !Word64+    , sym_section   :: {-# UNPACK #-} !Int+    , sym_binding   :: !SymbolBinding+    , sym_type      :: !SymbolType+    }+    deriving Show++{#enum define SymbolBinding+    { STB_LOCAL     as Local+    , STB_GLOBAL    as Global+    , STB_WEAK      as Weak+    }+    deriving (Eq, Show)+#}++{#enum define SymbolType+    { STT_NOTYPE    as NoType+    , STT_OBJECT    as Object     -- data object+    , STT_FUNC      as Func       -- function object+    , STT_SECTION   as Section+    , STT_FILE      as File+    , STT_COMMON    as Common+    , STT_TLS       as TLS+    }+    deriving (Eq, Show)+#}++data Relocation = Relocation+    { r_offset      :: {-# UNPACK #-} !Word64+    , r_symbol      :: {-# UNPACK #-} !Int+    , r_section     :: {-# UNPACK #-} !Int+    , r_addend      :: {-# UNPACK #-} !Int64+    , r_type        :: !RelocationType+    }+    deriving Show++#ifdef i386_HOST_ARCH+{#enum define RelocationType+    { R_386_NONE    as R_386_None+    , R_386_32      as R_386_32+    , R_386_PC32    as R_386_PC32+    }+    deriving (Eq, Show)+#}+#endif+#ifdef x86_64_HOST_ARCH+{#enum define RelocationType+    { R_X86_64_NONE   as R_X86_64_None      -- no relocation+    , R_X86_64_64     as R_X86_64_64        -- direct 64-bit+    , R_X86_64_PC32   as R_X86_64_PC32      -- PC relative 32-bit signed+    , R_X86_64_PC64   as R_X86_64_PC64      -- PC relative 64-bit+    , R_X86_64_32     as R_X86_64_32        -- direct 32-bit zero extended+    , R_X86_64_32S    as R_X86_64_32S       -- direct 32-bit sign extended+    , R_X86_64_PLT32  as R_X86_64_PLT32     -- 32-bit PLT address+    -- ... many more relocation types+    }+    deriving (Eq, Show)+#}+#endif++-- The ELF file header appears at the start of every file.+--+readHeader :: Get (Peek, Table, Table, Int)+readHeader = do+  p@Peek{..}            <- readIdent+  (_, phs, secs, shstr) <- case is64Bit of+                             True  -> readHeader64 p+                             False -> readHeader32 p+  return (p, phs, secs, shstr)+++readHeader32 :: Peek -> Get (Int, Table, Table, Int)+readHeader32 _ = fail "TODO: readHeader32"++readHeader64 :: Peek -> Get (Int, Table, Table, Int)+readHeader64 p@Peek{..} = do+  readType p+  readMachine p+  skip {#sizeof Elf64_Word#}      -- e_version+  e_entry     <- getWord64        -- entry point virtual address (page offset?)+  e_phoff     <- getWord64        -- program header table file offset+  e_shoff     <- getWord64        -- section header table file offset+  skip ({#sizeof Elf64_Word#}+{#sizeof Elf64_Half#})    -- e_flags + e_ehsize+  e_phentsize <- getWord16        -- byte size per program header entry+  e_phnum     <- getWord16        -- #program header entries+  e_shentsize <- getWord16+  e_shnum     <- getWord16+  e_shstrndx  <- getWord16+  return ( fromIntegral e_entry+         , Table { tb_fileoff = fromIntegral e_phoff, tb_entries = fromIntegral e_phnum, tb_entrysize = fromIntegral e_phentsize }+         , Table { tb_fileoff = fromIntegral e_shoff, tb_entries = fromIntegral e_shnum, tb_entrysize = fromIntegral e_shentsize }+         , fromIntegral e_shstrndx+         )+++readIdent :: Get Peek+readIdent = do+  ei_magic    <- getBytes 4+  unless (ei_magic == B8.pack [chr {#const ELFMAG0#}, {#const ELFMAG1#}, {#const ELFMAG2#}, {#const ELFMAG3#}]) $+    fail "invalid magic number"++  ei_class    <- getWord8+  is64Bit     <- case ei_class of+                   {#const ELFCLASS32#} -> return False+                   {#const ELFCLASS64#} -> return True+                   _                    -> fail "invalid class"+  ei_data     <- getWord8+  p           <- case ei_data of+                   {#const ELFDATA2LSB#} -> return $ Peek { getWord16 = getWord16le, getWord32 = getWord32le, getWord64 = getWord64le, .. }+                   {#const ELFDATA2MSB#} -> return $ Peek { getWord16 = getWord16be, getWord32 = getWord32be, getWord64 = getWord64be, .. }+                   _                     -> fail "invalid data layout"+  ei_version  <- getWord8+  unless (ei_version == {#const EV_CURRENT#}) $ fail "invalid version"+  skip (1+1+{#const EI_NIDENT#}-{#const EI_PAD#}) -- ABI, ABI version, padding+  return p+++readType :: Peek -> Get ()+readType Peek{..} = do+  e_type    <- getWord16+  case e_type of+    {#const ET_REL#}  -> return ()+    _                 -> fail "expected relocatable object file"++readMachine :: Peek -> Get ()+readMachine Peek{..} = do+  e_machine <- getWord16+  case e_machine of+#ifdef i386_HOST_ARCH+    {#const EM_386#}    -> return ()+#endif+#ifdef x86_64_HOST_ARCH+    {#const EM_X86_64#} -> return ()+#endif+    _                   -> fail "expected host architecture object file"+++{--+-- Program headers define how the ELF program behaves once it has been loaded,+-- as well as runtime linking information.+--+-- TLM: Since we are loading object files we shouldn't get any program headers.+--+readProgramHeader :: Peek -> Get ProgramHeader+readProgramHeader p@Peek{..} =+  case is64Bit of+    True  -> readProgramHeader64 p+    False -> readProgramHeader32 p++readProgramHeader32 :: Peek -> Get ProgramHeader+readProgramHeader32 _ = fail "TODO: readProgramHeader32"++readProgramHeader64 :: Peek -> Get ProgramHeader+readProgramHeader64 _ = fail "TODO: readProgramHeader64"+--}++-- Section headers contain information such as the section name, size, and+-- location in the object file. The list of all the section headers in the ELF+-- file is known as the section header table.+--+readSectionHeader :: Peek -> Get SectionHeader+readSectionHeader p@Peek{..} =+  case is64Bit of+    True  -> readSectionHeader64 p+    False -> readSectionHeader32 p++readSectionHeader32 :: Peek -> Get SectionHeader+readSectionHeader32 _ = fail "TODO: readSectionHeader32"++readSectionHeader64 :: Peek -> Get SectionHeader+readSectionHeader64 Peek{..} = do+  sh_name     <- fromIntegral <$> getWord32+  sh_type     <- toEnum . fromIntegral <$> getWord32+  sh_flags    <- getWord64+  sh_addr     <- getWord64+  sh_offset   <- fromIntegral <$> getWord64+  sh_size     <- fromIntegral <$> getWord64+  sh_link     <- fromIntegral <$> getWord32+  sh_info     <- fromIntegral <$> getWord32+  sh_align    <- fromIntegral <$> getWord64+  sh_entsize  <- fromIntegral <$> getWord64+  return SectionHeader {..}+++indexStringTable :: ByteString -> Int -> ByteString+indexStringTable strtab ix = B.takeWhile (/= 0) (B.drop ix strtab)++readStringTable :: ByteString -> SectionHeader -> Either String ByteString+readStringTable obj SectionHeader{..} =+  case sh_type of+    StrTab -> Right $ B.take sh_size (B.drop sh_offset obj)+    _      -> Left "expected string table"+++readRelocations :: Peek -> ByteString -> SectionHeader -> Either String (Vector Relocation)+readRelocations p@Peek{..} obj SectionHeader{..} = do+  unless (sh_type == Rel || sh_type == RelA) $ fail "expected relocation section"+  --+  let nrel = sh_size `quot` sh_entsize+  runGet (V.replicateM nrel (readRel p sh_type sh_info)) (B.drop sh_offset obj)+++readRel :: Peek -> SectionType -> Int -> Get Relocation+readRel p@Peek{..} sh_type r_section =+  case is64Bit of+    True  -> readRel64 p sh_type r_section+    False -> readRel32 p sh_type r_section++readRel32 :: Peek -> SectionType -> Int -> Get Relocation+readRel32 _ _ _ = fail "TODO: readRel32"++readRel64 :: Peek -> SectionType -> Int -> Get Relocation+readRel64 Peek{..} sh_type r_section = do+  r_offset  <- getWord64+  r_info    <- getWord64+  r_addend  <- case sh_type of+                 RelA -> fromIntegral <$> getWord64+                 _    -> return 0+  let r_type    = toEnum (fromIntegral (r_info .&. 0xffffffff))+      r_symbol  = fromIntegral (r_info `shiftR` 32) - 1+  --+  return Relocation {..}+++readSymbolTable :: Peek -> Vector SectionHeader -> ByteString -> SectionHeader -> Either String (Vector Symbol)+readSymbolTable p@Peek{..} secs obj SectionHeader{..} = do+  unless (sh_type == SymTab) $ fail "expected symbol table"++  let nsym    = sh_size `quot` sh_entsize+      offset  = sh_offset + sh_entsize  -- First symbol in the table is always null; skip it.+                                        -- Make sure to update relocation indices+  strtab  <- readStringTable obj (secs V.! sh_link)+  symbols <- runGet (V.replicateM (nsym-1) (readSymbol p secs strtab)) (B.drop offset obj)+  return symbols++readSymbol :: Peek -> Vector SectionHeader -> ByteString -> Get Symbol+readSymbol p@Peek{..} secs strtab =+  case is64Bit of+    True  -> readSymbol64 p secs strtab+    False -> readSymbol32 p secs strtab++readSymbol32 :: Peek -> Vector SectionHeader -> ByteString -> Get Symbol+readSymbol32 _ _ _ = fail "TODO: readSymbol32"++readSymbol64 :: Peek -> Vector SectionHeader -> ByteString -> Get Symbol+readSymbol64 Peek{..} secs strtab = do+  st_strx     <- fromIntegral <$> getWord32+  st_info     <- getWord8+  skip 1 -- st_other  <- getWord8+  sym_section <- fromIntegral <$> getWord16+  sym_value   <- getWord64+  skip 8 -- st_size   <- getWord64++  let sym_name+        | sym_type == Section = indexStringTable strtab (sh_name (secs V.! sym_section))+        | st_strx == 0        = B.empty+        | otherwise           = indexStringTable strtab st_strx++      sym_binding = toEnum $ fromIntegral ((st_info .&. 0xF0) `shiftR` 4)+      sym_type    = toEnum $ fromIntegral (st_info .&. 0x0F)++  case sym_section of+    -- External symbol; lookup value+    {#const SHN_UNDEF#} | not (B.null sym_name) -> do+        funptr <- resolveSymbol sym_name+        message (printf "%s: external symbol found at %s" (B8.unpack sym_name) (show funptr))+        return Symbol { sym_value = castPtrToWord64 (castFunPtrToPtr funptr), .. }++    -- Internally defined symbol+    n | n < {#const SHN_LORESERVE#} -> do+        message (printf "%s: local symbol in section %d at 0x%02x" (B8.unpack sym_name) sym_section sym_value)+        return Symbol {..}++    {#const SHN_ABS#} | sym_type == File -> return Symbol {..}+    {#const SHN_ABS#} -> fail "unhandled absolute symbol"+    _                 -> fail "unhandled symbol section"+++-- Return the address binding the named symbol+--+resolveSymbol :: ByteString -> Get (FunPtr ())+resolveSymbol name+  = unsafePerformIO+  $ B.unsafeUseAsCString name $ \c_name -> do+      addr <- c_dlsym (packDL Default) c_name+      if addr == nullFunPtr+        then do+          err <- dlerror+          return (fail $ printf "failed to resolve symbol %s: %s" (B8.unpack name) err)+        else do+          return (return addr)+++-- Utilities+-- ---------++-- Get the address of a pointer as a Word64+--+castPtrToWord64 :: Ptr a -> Word64+castPtrToWord64 (Ptr addr#) = W64# (int2Word# (addr2Int# addr#))+++-- c-bits+-- ------++-- Control the protection of pages+--+mprotect :: Ptr Word8 -> Int -> Int -> IO ()+mprotect addr len prot+  = throwErrnoIfMinus1_ "mprotect"+  $ c_mprotect addr (fromIntegral len) (fromIntegral prot)++-- Allocate memory pages in the lower 2GB+--+mmap :: Int -> IO (Ptr Word8)+mmap len+  = throwErrnoIf (== _MAP_FAILED) "mmap"+  $ c_mmap nullPtr (fromIntegral len) prot flags (-1) 0+  where+    prot        = {#const PROT_READ#} .|. {#const PROT_WRITE#}+    flags       = {#const MAP_ANONYMOUS#} .|. {#const MAP_PRIVATE#} .|. {#const MAP_32BIT#}+    _MAP_FAILED = Ptr (int2Addr# (-1#))++-- Remove a memory mapping+--+munmap :: Ptr Word8 -> Int -> IO ()+munmap addr len+  = throwErrnoIfMinus1_ "munmap"+  $ c_munmap addr (fromIntegral len)++foreign import ccall unsafe "mprotect"+  c_mprotect :: Ptr a -> CSize -> CInt -> IO CInt++foreign import ccall unsafe "mmap"+  c_mmap :: Ptr a -> CSize -> CInt -> CInt -> CInt -> COff -> IO (Ptr a)++foreign import ccall unsafe "munmap"+  c_munmap :: Ptr a -> CSize -> IO CInt++foreign import ccall unsafe "getpagesize"+  c_getpagesize :: CInt+++-- Debug+-- -----++{-# INLINE trace #-}+trace :: String -> a -> a+trace msg = Debug.trace Debug.dump_ld ("ld: " ++ msg)++{-# INLINE message #-}+message :: Monad m => String -> m ()+message msg = trace msg (return ())+
+ src/Data/Array/Accelerate/LLVM/Native/Link/MachO.chs view
@@ -0,0 +1,744 @@+{-# LANGUAGE CPP                      #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE MagicHash                #-}+{-# LANGUAGE RecordWildCards          #-}+{-# LANGUAGE TemplateHaskell          #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Link.MachO+-- Copyright   : [2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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 unique ID. The execution phase doesn't need to know about this+  -- however, so un-mangle the name to the basic "map", "fold", etc.+  --+  let extern Symbol{..}   = sym_extern && sym_segment > 0+      resolve Symbol{..}  =+        let Segment _ fp  = segs V.! (fromIntegral (sym_segment-1))+            name          = BS.toShort (B8.take (B8.length sym_name - 65) sym_name)+            addr          = castPtrToFunPtr (unsafeForeignPtrToPtr fp `plusPtr` fromIntegral sym_value)+        in+        (name, addr)+      --+      funtab              = FunctionTable $ V.toList $ V.map resolve (V.filter extern symtab)+      objectcode          = V.toList segs++  -- The executable pages were allocated on the GC heap. When the pages are+  -- finalised, unset the executable bit and mark them as read/write so that+  -- they can be reused.+  --+  objectcode' <- newLifetime objectcode+  addFinalizer objectcode' $ do+    Debug.traceIO Debug.dump_gc ("gc: unload module: " ++ show funtab)+    forM_ objectcode $ \(Segment vmsize oc_fp) -> do+      withForeignPtr oc_fp $ \oc_p -> do+        mprotect oc_p vmsize ({#const PROT_READ#} .|. {#const PROT_WRITE#})++  return (funtab, objectcode')+++-- Load a segment and all its sections into memory.+--+-- Extra jump islands are added directly after the segment. On x86_64+-- PC-relative jumps and accesses to the global offset table (GOT) are limited+-- to 32-bit (+-2GB). If we need to go outside of this range then we must do so+-- via the jump islands.+--+-- NOTE: This puts all the sections into a single block of memory. Technically+-- this is incorrect because we then have both text and data sections together,+-- meaning that data sections are marked as execute when they really shouldn't+-- be. These would need to live in different pages in order to be mprotect-ed+-- properly.+--+loadSegment :: ByteString -> Vector Symbol -> LoadSegment -> IO Segment+loadSegment obj symtab seg@LoadSegment{..} = do+  let+      pagesize    = fromIntegral c_getpagesize++      -- round up to next multiple of given alignment+      pad align n = (n + align - 1) .&. (complement (align - 1))++      seg_vmsize' = pad 16 seg_vmsize                                   -- align jump islands to 16 bytes+      segsize     = pad pagesize (seg_vmsize' + (V.length symtab * 16)) -- jump entries are 16 bytes each (x86_64)+  --+  seg_fp  <- mallocPlainForeignPtrAlignedBytes segsize pagesize+  _       <- withForeignPtr seg_fp $ \seg_p -> do+              -- Just in case, clear out the segment data (corresponds to NOP)+              fillBytes seg_p 0 segsize++              -- Jump tables are placed directly after the segment data+              let jump_p = seg_p `plusPtr` seg_vmsize'+              V.imapM_ (makeJumpIsland jump_p) symtab++              -- Process each of the sections of this segment+              V.mapM_ (loadSection obj symtab seg seg_p jump_p) seg_sections++              -- Mark the page as executable and read-only+              mprotect seg_p segsize ({#const PROT_READ#} .|. {#const PROT_EXEC#})+  --+  return (Segment segsize seg_fp)+++-- Add the jump-table entries directly to each external undefined symbol.+--+makeJumpIsland :: Ptr Word8 -> Int -> Symbol -> IO ()+makeJumpIsland jump_p symbolnum Symbol{..} = do+#ifdef x86_64_HOST_ARCH+  when (sym_extern && sym_segment == 0) $ do+    let+        target  = jump_p `plusPtr` (symbolnum * 16) :: Ptr Word64+        instr   = target `plusPtr` 8                :: Ptr Word8+    --+    poke target sym_value+    pokeArray instr [ 0xFF, 0x25, 0xF2, 0xFF, 0xFF, 0xFF ]  -- jmp *-14(%rip)+#endif+  return ()+++-- Load a section at the correct offset into the given segment, and apply+-- relocations.+--+loadSection :: ByteString -> Vector Symbol -> LoadSegment -> Ptr Word8 -> Ptr Word8 -> LoadSection -> IO ()+loadSection obj symtab seg seg_p jump_p sec@LoadSection{..} = do+  let (obj_fp, obj_offset, _) = B.toForeignPtr obj+  --+  withForeignPtr obj_fp $ \obj_p -> do+    -- Copy this section's data to the appropriate place in the segment+    let src = obj_p `plusPtr` (obj_offset + sec_offset)+        dst = seg_p `plusPtr` sec_addr+    --+    copyBytes dst src sec_size+    V.mapM_ (processRelocation symtab seg seg_p jump_p sec) sec_relocs+++-- Process both local and external relocations. The former are probably not+-- necessary since we load all sections into the same memory segment at the+-- correct offsets.+--+processRelocation :: Vector Symbol -> LoadSegment -> Ptr Word8 -> Ptr Word8 -> LoadSection -> RelocationInfo -> IO ()+#ifdef x86_64_HOST_ARCH+processRelocation symtab LoadSegment{..} seg_p jump_p sec RelocationInfo{..}+  -- Relocation through global offset table+  --+  | ri_type == X86_64_RELOC_GOT ||+    ri_type == X86_64_RELOC_GOT_LOAD+  = $internalError "processRelocation" "Global offset table relocations not handled yet"++  -- External symbols, both those defined in the sections of this object, and+  -- undefined externals. For the latter, the symbol might be outside of the+  -- range of 32-bit pc-relative addressing, in which case we need to go via the+  -- jump tables.+  --+  | ri_extern+  = let value     = sym_value (symtab V.! ri_symbolnum)+        value_rel = value - pc' - 2 ^ ri_length -- also subtract size of instruction from PC+    in+    case ri_pcrel of+      False -> relocate value+      True  -> if (fromIntegral (fromIntegral value_rel::Word32) :: Word64) == value_rel+                 then relocate value_rel+                 else do+                   let value'     = castPtrToWord64 (jump_p `plusPtr` (ri_symbolnum * 16 + 8))+                       value'_rel = value' - pc' - 2 ^ ri_length+                   --+                   -- message (printf "relocating %s via jump table" (B8.unpack (sym_name (symtab V.! ri_symbolnum))))+                   relocate value'_rel++  -- Internal relocation (to constant sections, for example). Since the sections+  -- are loaded at the appropriate offsets in a single contiguous segment, this+  -- is unnecessary.+  --+  | otherwise+  = return ()++  where+    pc :: Ptr Word8+    pc  = seg_p `plusPtr` (sec_addr sec + ri_address)+    pc' = castPtrToWord64 pc++    -- Include the addend value already encoded in the instruction+    addend :: (Integral a, Storable a) => Ptr a -> Word64 -> IO a+    addend p x = do+      base <- peek p+      case ri_type of+        X86_64_RELOC_SUBTRACTOR -> return $ fromIntegral (fromIntegral base - x)+        _                       -> return $ fromIntegral (fromIntegral base + x)++    -- Write the new relocated address+    relocate :: Word64 -> IO ()+    relocate x =+      case ri_length of+        0 -> let p' = castPtr pc :: Ptr Word8  in poke p' =<< addend p' x+        1 -> let p' = castPtr pc :: Ptr Word16 in poke p' =<< addend p' x+        2 -> let p' = castPtr pc :: Ptr Word32 in poke p' =<< addend p' x+        _ -> $internalError "processRelocation" "unhandled relocation size"++#else+precessRelocation =+  $internalError "processRelocation" "not defined for non-x86_64 architectures yet"+#endif+++-- Object file parser+-- ------------------++-- Parsing depends on whether the Mach-O file is 64-bit and whether it should be+-- read as big- or little-endian.+--+data Peek = Peek+    { is64Bit   :: !Bool+    , getWord16 :: !(Get Word16)+    , getWord32 :: !(Get Word32)+    , getWord64 :: !(Get Word64)+    }++-- Load commands directly follow the Mach-O header.+--+data LoadCommand+    = LC_Segment     {-# UNPACK #-} !LoadSegment+    | LC_SymbolTable {-# UNPACK #-} !(Vector Symbol)++-- Indicates that a part of this file is to be mapped into the task's+-- address space. The size of the segment in memory, vmsize, must be equal+-- to or larger than the amount to map from this file, filesize. The file is+-- mapped starting at fileoff to the beginning of the segment in memory,+-- vmaddr. If the segment has sections then the section structures directly+-- follow the segment command.+--+-- For compactness object files contain only one (unnamed) segment, which+-- contains all the sections.+--+data LoadSegment = LoadSegment+    { seg_name      :: {-# UNPACK #-} !ByteString+    , seg_vmaddr    :: {-# UNPACK #-} !Int                      -- starting virtual memory address of the segment+    , seg_vmsize    :: {-# UNPACK #-} !Int                      -- size (bytes) of virtual memory occupied by the segment+    , seg_fileoff   :: {-# UNPACK #-} !Int                      -- offset in the file for the data mapped at 'seg_vmaddr'+    , seg_filesize  :: {-# UNPACK #-} !Int                      -- size (bytes) of the segment in the file+    , seg_sections  :: {-# UNPACK #-} !(Vector LoadSection)     -- the sections of this segment+    }+    deriving Show++data LoadSection = LoadSection+    { sec_secname   :: {-# UNPACK #-} !ByteString+    , sec_segname   :: {-# UNPACK #-} !ByteString+    , sec_addr      :: {-# UNPACK #-} !Int                      -- virtual memory address of this section+    , sec_size      :: {-# UNPACK #-} !Int                      -- size in bytes+    , sec_offset    :: {-# UNPACK #-} !Int                      -- offset of this section in the file+    , sec_align     :: {-# UNPACK #-} !Int+    , sec_relocs    :: {-# UNPACK #-} !(Vector RelocationInfo)+    }+    deriving Show++data RelocationInfo = RelocationInfo+    { ri_address    :: {-# UNPACK #-} !Int                      -- offset from start of the section+    , ri_symbolnum  :: {-# UNPACK #-} !Int                      -- index into the symbol table (when ri_extern=True) else section number (??)+    , ri_length     :: {-# UNPACK #-} !Int                      -- length of address (bytes) to be relocated+    , ri_pcrel      :: !Bool                                    -- item containing the address to be relocated uses PC-relative addressing+    , ri_extern     :: !Bool+    , ri_type       :: !RelocationType                          -- type of relocation+    }+    deriving Show++-- A symbol defined in the sections of this object+--+data Symbol = Symbol+    { sym_name      :: {-# UNPACK #-} !ByteString+    , sym_value     :: {-# UNPACK #-} !Word64+    , sym_segment   :: {-# UNPACK #-} !Word8+    , sym_extern    :: !Bool+    }+    deriving Show++#ifdef i386_HOST_ARCH+{# enum reloc_type_generic as RelocationType { } deriving (Eq, Show) #}+#endif+#ifdef x86_64_HOST_ARCH+{# enum reloc_type_x86_64  as RelocationType { } deriving (Eq, Show) #}+#endif+#ifdef powerpc_HOST_ARCH+{# enum reloc_type_ppc     as RelocationType { } deriving (Eq, Show) #}+#endif+++-- Parse the Mach-O object file and return the set of section load commands, as+-- well as the symbols defined within the sections of this object.+--+-- Actually _executing_ the load commands, which entails copying the pointed-to+-- segments into an appropriate VM image in the target address space, happens+-- separately.+--+parseObject :: ByteString -> Either String (Vector Symbol, Vector LoadSegment)+parseObject obj = do+  ((p, ncmd, _), rest)  <- runGetState readHeader obj 0+  cmds                  <- catMaybes <$> runGet (replicateM ncmd (readLoadCommand p obj)) rest+  let+      lc = [ x | LC_Segment     x <- cmds ]+      st = [ x | LC_SymbolTable x <- cmds ]+  --+  return (V.concat st, V.fromListN ncmd lc)+++-- The Mach-O file consists of a header block, a number of load commands,+-- followed by the segment data.+--+--   +-------------------++--   |   Mach-O header   |+--   +-------------------+  <- sizeofheader+--   |   Load command    |+--   |   Load command    |+--   |        ...        |+--   +-------------------+  <- sizeofcmds + sizeofheader+--   |   Segment data    |+--   |   Segment data    |+--   |        ...        |+--   +-------------------++--+readHeader :: Get (Peek, Int, Int)+readHeader = do+  magic       <- getWord32le+  p@Peek{..}  <- case magic of+                   {#const MH_MAGIC#}    -> return $ Peek False getWord16le getWord32le getWord64le+                   {#const MH_CIGAM#}    -> return $ Peek False getWord16be getWord32be getWord64be+                   {#const MH_MAGIC_64#} -> return $ Peek True  getWord16le getWord32le getWord64le+                   {#const MH_CIGAM_64#} -> return $ Peek True  getWord16be getWord32be getWord64be+                   m                     -> fail (printf "unknown magic: %x" m)+  cpu_type    <- getWord32+  -- c2HS has trouble with the CPU_TYPE_* macros due to the type cast+#ifdef i386_HOST_ARCH+  when (cpu_type /= 0x0000007) $ fail "expected i386 object file"+#endif+#ifdef x86_64_HOST_ARCH+  when (cpu_type /= 0x1000007) $ fail "expected x86_64 object file"+#endif+#ifdef powerpc_HOST_ARCH+  case is64Bit of+    False -> when (cpu_type /= 0x0000012) $ fail "expected PPC object file"+    True  -> when (cpu_type /= 0x1000012) $ fail "expected PPC64 object file"+#endif+  skip {#sizeof cpu_subtype_t#}+  filetype    <- getWord32+  case filetype of+    {#const MH_OBJECT#} -> return ()+    _                   -> fail "expected object file"+  ncmds       <- fromIntegral <$> getWord32+  sizeofcmds  <- fromIntegral <$> getWord32+  skip $ case is64Bit of+           True  -> 8 -- flags + reserved+           False -> 4 -- flags+  return (p, ncmds, sizeofcmds)+++-- Read a segment load command from the Mach-O file.+--+-- The only thing we are interested in are the symbol table, which tell us which+-- external symbols are defined by this object, and the load commands, which+-- indicate part of the file is to be mapped into the target address space.+-- These will tell us everything we need to know about the generated machine+-- code in order to execute it.+--+-- Since we are only concerned with loading object files, there should really+-- only be one of each of these.+--+readLoadCommand :: Peek -> ByteString -> Get (Maybe LoadCommand)+readLoadCommand p@Peek{..} obj = do+  cmd     <- getWord32+  cmdsize <- fromIntegral <$> getWord32+  --+  let required = toBool $ cmd .&. {#const LC_REQ_DYLD#}+  --+  case cmd .&. (complement {#const LC_REQ_DYLD#}) of+    {#const LC_SEGMENT#}    -> Just . LC_Segment     <$> readLoadSegment p obj+    {#const LC_SEGMENT_64#} -> Just . LC_Segment     <$> readLoadSegment p obj+    {#const LC_SYMTAB#}     -> Just . LC_SymbolTable <$> readLoadSymbolTable p obj+    {#const LC_DYSYMTAB#}   -> const Nothing         <$> readDynamicSymbolTable p obj+    {#const LC_LOAD_DYLIB#} -> fail "unhandled LC_LOAD_DYLIB"+    this                    -> do if required+                                    then fail    (printf "unknown load command required for execution: 0x%x" this)+                                    else message (printf "skipping load command: 0x%x" this)+                                  skip (cmdsize - 8)+                                  return Nothing+++-- Read a load segment command, including any relocation entries.+--+readLoadSegment :: Peek -> ByteString -> Get LoadSegment+readLoadSegment p@Peek{..} obj =+  if is64Bit+    then readLoadSegment64 p obj+    else readLoadSegment32 p obj++readLoadSegment32 :: Peek -> ByteString -> Get LoadSegment+readLoadSegment32 p@Peek{..} obj = do+  name      <- B.takeWhile (/= 0) <$> getBytes 16+  vmaddr    <- fromIntegral <$> getWord32+  vmsize    <- fromIntegral <$> getWord32+  fileoff   <- fromIntegral <$> getWord32+  filesize  <- fromIntegral <$> getWord32+  skip (2 * {#sizeof vm_prot_t#}) -- maxprot, initprot+  nsect     <- fromIntegral <$> getWord32+  skip 4    -- flags+  --+  message (printf "LC_SEGMENT:            Mem: 0x%09x-0x09%x" vmaddr (vmaddr + vmsize))+  secs      <- V.replicateM nsect (readLoadSection32 p obj)+  --+  return LoadSegment+          { seg_name     = name+          , seg_vmaddr   = vmaddr+          , seg_vmsize   = vmsize+          , seg_fileoff  = fileoff+          , seg_filesize = filesize+          , seg_sections = secs+          }++readLoadSegment64 :: Peek -> ByteString -> Get LoadSegment+readLoadSegment64 p@Peek{..} obj = do+  name      <- B.takeWhile (/= 0) <$> getBytes 16+  vmaddr    <- fromIntegral <$> getWord64+  vmsize    <- fromIntegral <$> getWord64+  fileoff   <- fromIntegral <$> getWord64+  filesize  <- fromIntegral <$> getWord64+  skip (2 * {#sizeof vm_prot_t#}) -- maxprot, initprot+  nsect     <- fromIntegral <$> getWord32+  skip 4    -- flags+  --+  message (printf "LC_SEGMENT_64:         Mem: 0x%09x-0x%09x" vmaddr (vmaddr + vmsize))+  secs      <- V.replicateM nsect (readLoadSection64 p obj)+  --+  return LoadSegment+          { seg_name     = name+          , seg_vmaddr   = vmaddr+          , seg_vmsize   = vmsize+          , seg_fileoff  = fileoff+          , seg_filesize = filesize+          , seg_sections = secs+          }++readLoadSection32 :: Peek -> ByteString -> Get LoadSection+readLoadSection32 p@Peek{..} obj = do+  secname   <- B.takeWhile (/= 0) <$> getBytes 16+  segname   <- B.takeWhile (/= 0) <$> getBytes 16+  addr      <- fromIntegral <$> getWord32+  size      <- fromIntegral <$> getWord32+  offset    <- fromIntegral <$> getWord32+  align     <- fromIntegral <$> getWord32+  reloff    <- fromIntegral <$> getWord32+  nreloc    <- fromIntegral <$> getWord32+  skip 12   -- flags, reserved1, reserved2+  --+  message (printf "  Mem: 0x%09x-0x%09x         %s.%s" addr (addr+size) (B8.unpack segname) (B8.unpack secname))+  relocs    <- either fail return $ runGet (V.replicateM nreloc (loadRelocation p)) (B.drop reloff obj)+  --+  return LoadSection+          { sec_secname = secname+          , sec_segname = segname+          , sec_addr    = addr+          , sec_size    = size+          , sec_offset  = offset+          , sec_align   = align+          , sec_relocs  = relocs+          }++readLoadSection64 :: Peek -> ByteString -> Get LoadSection+readLoadSection64 p@Peek{..} obj = do+  secname   <- B.takeWhile (/= 0) <$> getBytes 16+  segname   <- B.takeWhile (/= 0) <$> getBytes 16+  addr      <- fromIntegral <$> getWord64+  size      <- fromIntegral <$> getWord64+  offset    <- fromIntegral <$> getWord32+  align     <- fromIntegral <$> getWord32+  reloff    <- fromIntegral <$> getWord32+  nreloc    <- fromIntegral <$> getWord32+  skip 16   -- flags, reserved1, reserved2, reserved3+  message (printf "  Mem: 0x%09x-0x%09x         %s.%s" addr (addr+size) (B8.unpack segname) (B8.unpack secname))+  relocs    <- either fail return $ runGet (V.replicateM nreloc (loadRelocation p)) (B.drop reloff obj)+  --+  return LoadSection+          { sec_secname = secname+          , sec_segname = segname+          , sec_addr    = addr+          , sec_size    = size+          , sec_offset  = offset+          , sec_align   = align+          , sec_relocs  = relocs+          }++loadRelocation :: Peek -> Get RelocationInfo+loadRelocation Peek{..} = do+  addr    <- fromIntegral <$> getWord32+  val     <- getWord32+  let symbol  = val .&. 0xFFFFFF+      pcrel   = testBit val 24+      extern  = testBit val 27+      len     = (val `shiftR` 25) .&. 0x3+      rtype   = (val `shiftR` 28) .&. 0xF+      rtype'  = toEnum (fromIntegral rtype)+  --+  when (toBool $ addr .&. {#const R_SCATTERED#}) $ fail "unhandled scatted relocation info"+  message (printf "    Reloc: 0x%04x to %s %d: length=%d, pcrel=%s, type=%s" addr (if extern then "symbol" else "section") symbol len (show pcrel) (show rtype'))+  --+  return RelocationInfo+          { ri_address   = addr+          , ri_symbolnum = fromIntegral symbol+          , ri_pcrel     = pcrel+          , ri_extern    = extern+          , ri_length    = fromIntegral len+          , ri_type      = rtype'+          }+++readLoadSymbolTable :: Peek -> ByteString -> Get (Vector Symbol)+readLoadSymbolTable p@Peek{..} obj = do+  symoff  <- fromIntegral <$> getWord32+  nsyms   <- fromIntegral <$> getWord32+  stroff  <- fromIntegral <$> getWord32+  strsize <- getWord32+  message "LC_SYMTAB"+  message (printf "  symbol table is at offset 0x%x (%d), %d entries" symoff symoff nsyms)+  message (printf "  string table is at offset 0x%x (%d), %d bytes" stroff stroff strsize)+  --+  let symbols = B.drop symoff obj+      strtab  = B.drop stroff obj+  --+  either fail return $ runGet (V.replicateM nsyms (loadSymbol p strtab)) symbols+++readDynamicSymbolTable :: Peek -> ByteString -> Get ()+readDynamicSymbolTable Peek{..} _obj = do+  if not Debug.debuggingIsEnabled+    then skip ({#sizeof dysymtab_command#} - 8)+    else do+      ilocalsym     <- getWord32+      nlocalsym     <- getWord32+      iextdefsym    <- getWord32+      nextdefsym    <- getWord32+      iundefsym     <- getWord32+      nundefsym     <- getWord32+      skip 4        -- tocoff+      ntoc          <- getWord32+      skip 4        -- modtaboff+      nmodtab       <- getWord32+      skip 12       -- extrefsymoff, nextrefsyms, indirectsymoff,+      nindirectsyms <- getWord32+      skip 16       -- extreloff, nextrel, locreloff, nlocrel,+      message "LC_DYSYMTAB:"+      --+      if nlocalsym > 0+        then message (printf "  %d local symbols at index %d" nlocalsym ilocalsym)+        else message (printf "  No local symbols")+      if nextdefsym > 0+        then message (printf "  %d external symbols at index %d" nextdefsym iextdefsym)+        else message (printf "  No external symbols")+      if nundefsym > 0+        then message (printf "  %d undefined symbols at index %d" nundefsym iundefsym)+        else message (printf "  No undefined symbols")+      if ntoc > 0+        then message (printf "  %d table of contents entries" ntoc)+        else message (printf "  No table of contents")+      if nmodtab > 0+        then message (printf "  %d module table entries" nmodtab)+        else message (printf "  No module table")+      if nindirectsyms > 0+        then message (printf "  %d indirect symbols" nindirectsyms)+        else message (printf "  No indirect symbols")++loadSymbol :: Peek -> ByteString -> Get Symbol+loadSymbol Peek{..} strtab = do+  n_strx  <- fromIntegral <$> getWord32+  n_flag  <- getWord8+  n_sect  <- getWord8+  skip 2  -- n_desc+  n_value <- case is64Bit of+               True  -> fromIntegral <$> getWord64+               False -> fromIntegral <$> getWord32++  let -- Symbols with string table index zero are defined to have a null+      -- name (""). Otherwise, drop the leading underscore.+      str | n_strx == 0 = B.empty+          | otherwise   = B.takeWhile (/= 0) (B.drop n_strx strtab)+      name+          | B.length str > 0 && B8.head str == '_'  = B.tail str+          | otherwise                               = str++      -- Extract the four bit fields of the type flag+      -- n_pext  = n_flag .&. {#const N_PEXT#}  -- private external symbol bit+      n_stab  = n_flag .&. {#const N_STAB#}  -- if any bits set, a symbolic debugging entry+      n_type  = n_flag .&. {#const N_TYPE#}  -- mask for type bits+      n_ext   = n_flag .&. {#const N_EXT#}   -- external symbol bit++  unless (n_stab == 0) $ fail "unhandled symbolic debugging entry (stab)"++  case n_type of+    {#const N_UNDF#} -> do+        funptr <- resolveSymbol name+        message (printf "    %s: external symbol found at %s" (B8.unpack name) (show funptr))+        return Symbol+                { sym_name    = name+                , sym_extern  = toBool n_ext+                , sym_segment = n_sect+                , sym_value   = castPtrToWord64 (castFunPtrToPtr funptr)+                }++    {#const N_SECT#} -> do+        message (printf "    %s: local symbol in section %d at 0x%02x" (B8.unpack name) n_sect n_value)+        return Symbol+                { sym_name    = name+                , sym_extern  = toBool n_ext+                , sym_segment = n_sect+                , sym_value   = n_value+                }++    {#const N_ABS#}  -> fail "unhandled absolute symbol"+    {#const N_PBUD#} -> fail "unhandled prebound (dylib) symbol"+    {#const N_INDR#} -> fail "unhandled indirect symbol"+    _                -> fail "unknown symbol type"+++-- Return the address binding the named symbol+--+resolveSymbol :: ByteString -> Get (FunPtr ())+resolveSymbol name+  = unsafePerformIO+  $ B.unsafeUseAsCString name $ \c_name -> do+      addr <- c_dlsym (packDL Default) c_name+      if addr == nullFunPtr+        then do+          err <- dlerror+          return (fail $ printf "failed to resolve symbol %s: %s" (B8.unpack name) err)+        else do+          return (return addr)+++-- Utilities+-- ---------++-- Get the address of a pointer as a Word64+--+castPtrToWord64 :: Ptr a -> Word64+castPtrToWord64 (Ptr addr#) = W64# (int2Word# (addr2Int# addr#))+++-- C-bits+-- ------++-- Control the protection of pages+--+mprotect :: Ptr Word8 -> Int -> Int -> IO ()+mprotect addr len prot+  = throwErrnoIfMinus1_ "mprotect"+  $ c_mprotect (castPtr addr) (fromIntegral len) (fromIntegral prot)++foreign import ccall unsafe "mprotect"+  c_mprotect :: Ptr () -> CSize -> CInt -> IO CInt++foreign import ccall unsafe "getpagesize"+  c_getpagesize :: CInt++#if __GLASGOW_HASKELL__ <= 708+-- Fill a given number of bytes in memory. Added in base-4.8.0.0.+--+fillBytes :: Ptr a -> Word8 -> Int -> IO ()+fillBytes dest char size = do+  _ <- memset dest (fromIntegral char) (fromIntegral size)+  return ()++foreign import ccall unsafe "string.h" memset  :: Ptr a -> CInt  -> CSize -> IO (Ptr a)+#endif+++-- Debug+-- -----++{-# INLINE trace #-}+trace :: String -> a -> a+trace msg = Debug.trace Debug.dump_ld ("ld: " ++ msg)++{-# INLINE message #-}+message :: Monad m => String -> m ()+message msg = trace msg (return ())+
+ src/Data/Array/Accelerate/LLVM/Native/Link/Object.hs view
@@ -0,0 +1,40 @@+-- |+-- 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+
+ src/Data/Array/Accelerate/LLVM/Native/Plugin.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE CPP             #-}+{-# LANGUAGE RecordWildCards #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Plugin+-- Copyright   : [2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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+#if __GLASGOW_HASKELL__ >= 804+              LlvmLLD   opts -> LlvmLLD   (nub (opts ++ allObjs))+#endif+              UnknownLD      -> UnknownLD  -- no linking performed?++      return ()++  return guts++objectPaths :: ModGuts -> CoreBind -> CoreM [FilePath]+objectPaths guts (NonRec b _) = objectAnns guts b+objectPaths guts (Rec bs)     = concat <$> mapM (objectAnns guts) (map fst bs)++objectAnns :: ModGuts -> CoreBndr -> CoreM [FilePath]+objectAnns guts bndr = do+  anns  <- getAnnotations deserializeWithData guts+  return [ path | Object path <- lookupWithDefaultUFM anns [] (varUnique bndr) ]++objectMapPath :: DynFlags -> FilePath+objectMapPath DynFlags{..}+  | Just p <- objectDir = p+  | Just p <- dumpDir   = p+  | otherwise           = "."++optionOfPath :: FilePath -> Option+optionOfPath = FileOption []+
+ 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] 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)+
+ src/Data/Array/Accelerate/LLVM/Native/Plugin/BuildInfo.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE CPP             #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Plugin.BuildInfo+-- Copyright   : [2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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+
+ src/Data/Array/Accelerate/LLVM/Native/State.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE CPP #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.State+-- Copyright   : [2014..2017] Trevor L. McDonell+--               [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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 Prelude                                                  as P++import GHC.Conc+++-- | Execute a computation in the Native backend+--+evalNative :: Native -> LLVM Native a -> IO a+evalNative = evalLLVM+++-- | Create a Native execution target by spawning a worker thread on each of the+-- given capabilities, and using the given strategy to load balance the workers+-- when executing parallel operations.+--+createTarget+    :: [Int]              -- ^ CPU IDs to launch worker threads on+    -> Strategy           -- ^ Strategy to balance parallel workloads+    -> IO Native+createTarget caps parallelIO = do+  let size = length caps+  gang   <- forkGangOn caps+  linker <- LC.new+  return $! Native size linker (sequentialIO gang) (parallelIO gang) (size > 1)+++-- | The strategy for balancing work amongst the available worker threads.+--+type Strategy = Gang -> Executable+++-- | Execute an operation sequentially on a single thread+--+sequentialIO :: Strategy+sequentialIO gang =+  Executable $ \name _ppt range fill ->+    timed name $ runSeqIO gang range fill+++-- | Execute a computation without load balancing. Each thread computes an+-- equally sized chunk of the input. No work stealing occurs.+--+unbalancedParIO :: Strategy+unbalancedParIO gang =+  Executable $ \name _ppt range fill ->+    timed name $ runParIO Single.mkResource gang range fill+++-- | Execute a computation where threads use work stealing (based on lazy+-- splitting of work stealing queues and exponential backoff) in order to+-- automatically balance the workload amongst themselves.+--+balancedParIO+    :: Int                -- ^ number of steal attempts before backing off+    -> Strategy+balancedParIO retries gang =+  Executable $ \name ppt range fill ->+    -- TLM: A suitable PPT should be chosen when invoking the continuation in+    --      order to balance scheduler overhead with fine-grained function calls+    --+    let resource = LBS.mkResource ppt (SMP.mkResource retries <> Backoff.mkResource)+    in  timed name $ runParIO resource gang range fill+++-- Top-level mutable state+-- -----------------------+--+-- It is important to keep some information alive for the entire run of the+-- program, not just a single execution. These tokens use 'unsafePerformIO' to+-- ensure they are executed only once, and reused for subsequent invocations.+--++-- | Initialise the gang of threads that will be used to execute computations.+-- This spawns one worker for each available processor, or as specified by the+-- value of the environment variable @ACCELERATE_LLVM_NATIVE_THREADS@.+--+-- This globally shared thread gang is auto-initialised on startup and shared by+-- all computations (unless the user chooses to 'run' with a different gang).+--+-- In a data parallel setting, it does not help to have multiple gangs running+-- at the same time. This is because a single data parallel computation should+-- already be able to keep all threads busy. If we had multiple gangs running at+-- the same time, then the system as a whole would run slower as the gangs+-- contend for cache and thrash the scheduler.+--+{-# NOINLINE defaultTarget #-}+defaultTarget :: Native+defaultTarget = unsafePerformIO $ do+  nproc <- getNumProcessors+  ncaps <- getNumCapabilities+  menv  <- (readMaybe =<<) <$> lookupEnv "ACCELERATE_LLVM_NATIVE_THREADS"++  let nthreads = fromMaybe nproc menv++  -- Update the number of capabilities, but never set it lower than it already+  -- is. This target will spawn a worker on each processor (as returned by+  -- 'getNumProcessors', which includes SMT (hyperthreading) cores), but the+  -- user may have requested more capabilities than this to handle, for example,+  -- concurrent output.+  --+  setNumCapabilities (max ncaps nthreads)++  Debug.traceIO Debug.dump_gc (printf "gc: initialise native target with %d worker threads" nthreads)+  case nthreads of+    1 -> createTarget [0]        sequentialIO+    n -> createTarget [0 .. n-1] (balancedParIO n)+++-- Debugging+-- ---------++{-# INLINE timed #-}+timed :: ShortByteString -> IO a -> IO a+timed name f = Debug.timed Debug.dump_exec (elapsed name) f++{-# INLINE elapsed #-}+elapsed :: ShortByteString -> Double -> Double -> String+elapsed name x y = printf "exec: %s %s" (unpack name) (Debug.elapsedP x y)+
+ src/Data/Array/Accelerate/LLVM/Native/Target.hs view
@@ -0,0 +1,97 @@+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Target+-- Copyright   : [2014..2017] Trevor L. McDonell+--               [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <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 )+import qualified LLVM.Relocation                                    as RelocationModel+import qualified LLVM.CodeModel                                     as CodeModel+import qualified LLVM.CodeGenOpt                                    as CodeOptimisation++-- accelerate+import Data.Array.Accelerate.LLVM.Native.Link.Cache                 ( LinkCache )+import Data.Array.Accelerate.LLVM.Target                            ( Target(..) )+import Control.Parallel.Meta                                        ( Executable )++-- standard library+import Data.ByteString                                              ( ByteString )+import Data.ByteString.Short                                        ( ShortByteString )+import System.IO.Unsafe+++-- | Native machine code JIT execution target+--+data Native = Native+  { gangSize      :: {-# UNPACK #-} !Int+  , linkCache     :: {-# UNPACK #-} !LinkCache+  , fillS         :: {-# UNPACK #-} !Executable+  , fillP         :: {-# UNPACK #-} !Executable+  , segmentOffset :: !Bool+  }++instance Target Native where+  targetTriple     _ = Just nativeTargetTriple+  targetDataLayout _ = Just nativeDataLayout+++-- | String that describes the native target+--+{-# NOINLINE nativeTargetTriple #-}+nativeTargetTriple :: ShortByteString+nativeTargetTriple = unsafePerformIO $+    -- A target triple suitable for loading code into the current process+    getProcessTargetTriple++-- | A description of the various data layout properties that may be used during+-- optimisation.+--+{-# NOINLINE nativeDataLayout #-}+nativeDataLayout :: DataLayout+nativeDataLayout+  = unsafePerformIO+  $ withNativeTargetMachine getTargetMachineDataLayout++-- | String that describes the host CPU+--+{-# NOINLINE nativeCPUName #-}+nativeCPUName :: ByteString+nativeCPUName = unsafePerformIO $ getHostCPUName+++-- | Bracket the creation and destruction of a target machine for the native+-- backend running on this host.+--+withNativeTargetMachine+    :: (TargetMachine -> IO a)+    -> IO a+withNativeTargetMachine k = do+  initializeNativeTarget+  nativeCPUFeatures <- getHostCPUFeatures+  (nativeTarget, _) <- lookupTarget Nothing nativeTargetTriple+  withTargetOptions $ \targetOptions ->+    withTargetMachine+        nativeTarget+        nativeTargetTriple+        nativeCPUName+        nativeCPUFeatures+        targetOptions+        RelocationModel.DynamicNoPIC+        CodeModel.Default+        CodeOptimisation.Default+        k+
+ test/nofib/Main.hs view
@@ -0,0 +1,21 @@+-- |+-- Module      : nofib-llvm-native+-- Copyright   : [2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Main where++import Data.Array.Accelerate.Test.NoFib+import Data.Array.Accelerate.LLVM.Native+import Data.Array.Accelerate.Debug++main :: IO ()+main = do+  beginMonitoring+  nofib runN+