accelerate-llvm-native 1.0.0.0 → 1.1.0.0
raw patch · 33 files changed
+4030/−538 lines, 33 filesdep +Cabaldep +bytestringdep +cerealdep ~acceleratedep ~accelerate-llvmdep ~base
Dependencies added: Cabal, bytestring, cereal, filepath, ghc, ghc-prim, template-haskell, unix, vector
Dependency ranges changed: accelerate, accelerate-llvm, base, llvm-hs, llvm-hs-pure
Files
- CHANGELOG.md +31/−0
- Data/Array/Accelerate/LLVM/Native.hs +282/−35
- Data/Array/Accelerate/LLVM/Native/CodeGen/Base.hs +8/−3
- Data/Array/Accelerate/LLVM/Native/CodeGen/Fold.hs +39/−30
- Data/Array/Accelerate/LLVM/Native/CodeGen/FoldSeg.hs +19/−15
- Data/Array/Accelerate/LLVM/Native/CodeGen/Generate.hs +5/−3
- Data/Array/Accelerate/LLVM/Native/CodeGen/Map.hs +5/−3
- Data/Array/Accelerate/LLVM/Native/CodeGen/Permute.hs +23/−17
- Data/Array/Accelerate/LLVM/Native/CodeGen/Scan.hs +87/−68
- Data/Array/Accelerate/LLVM/Native/Compile.hs +53/−42
- Data/Array/Accelerate/LLVM/Native/Compile/Cache.hs +35/−0
- Data/Array/Accelerate/LLVM/Native/Compile/Link.hs +0/−56
- Data/Array/Accelerate/LLVM/Native/Compile/Module.hs +0/−153
- Data/Array/Accelerate/LLVM/Native/Distribution/Simple.hs +65/−0
- Data/Array/Accelerate/LLVM/Native/Distribution/Simple/Build.hs +451/−0
- Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC.hs +438/−0
- Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC/Internal.hs +115/−0
- Data/Array/Accelerate/LLVM/Native/Embed.hs +78/−0
- Data/Array/Accelerate/LLVM/Native/Execute.hs +62/−71
- Data/Array/Accelerate/LLVM/Native/Foreign.hs +1/−1
- Data/Array/Accelerate/LLVM/Native/Link.hs +70/−0
- Data/Array/Accelerate/LLVM/Native/Link/COFF.hs +35/−0
- Data/Array/Accelerate/LLVM/Native/Link/Cache.hs +22/−0
- Data/Array/Accelerate/LLVM/Native/Link/ELF.chs +710/−0
- Data/Array/Accelerate/LLVM/Native/Link/MachO.chs +746/−0
- Data/Array/Accelerate/LLVM/Native/Link/Object.hs +40/−0
- Data/Array/Accelerate/LLVM/Native/Plugin.hs +154/−0
- Data/Array/Accelerate/LLVM/Native/Plugin/Annotation.hs +22/−0
- Data/Array/Accelerate/LLVM/Native/Plugin/BuildInfo.hs +67/−0
- Data/Array/Accelerate/LLVM/Native/State.hs +29/−8
- Data/Array/Accelerate/LLVM/Native/Target.hs +18/−14
- README.md +188/−0
- accelerate-llvm-native.cabal +132/−19
+ CHANGELOG.md view
@@ -0,0 +1,31 @@+# Change Log++Notable changes to the project will be documented in this file.++The format is based on [Keep a Changelog](http://keepachangelog.com/) and the+project adheres to the [Haskell Package Versioning+Policy (PVP)](https://pvp.haskell.org)++## [1.1.0.0] - 2017-09-21+### Added+ * support for GHC-8.2+ * caching of compilation results ([accelerate-llvm#17])+ * new runtime linker; this fixes the annoying "forkOS_entry: interrupted" error. Note that currently this only supports x86_64 macOS and linux+ * support for ahead-of-time compilation (`runQ` and `runQAsync`)++### Changed+ * generalise `run1*` to polyvariadic `runN*`+ * programs run using all cores by default; the environment variable+ `ACCELERATE_LLVM_NATIVE_THREADS` is used to set the number of worker threads+ rather than `+RTS -N`+++## [1.0.0.0] - 2017-03-31+ * initial release+++[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++[accelerate-llvm#17]: https://github.com/AccelerateHS/accelerate-llvm/issues/17+
Data/Array/Accelerate/LLVM/Native.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native@@ -14,9 +17,13 @@ -- 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 parallel, provided you specify '+RTS -Nwhatever' on the command--- line when running the program.+-- 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 ( @@ -25,6 +32,7 @@ -- * Synchronous execution run, runWith, run1, run1With,+ runN, runNWith, stream, streamWith, -- * Asynchronous execution@@ -33,7 +41,12 @@ runAsync, runAsyncWith, run1Async, run1AsyncWith,+ runNAsync, runNAsyncWith, + -- * Ahead-of-time compilation+ runQ, runQWith,+ runQAsync, runQAsyncWith,+ -- * Execution targets Native, Strategy, createTarget, balancedParIO, unbalancedParIO,@@ -41,21 +54,33 @@ ) where -- accelerate-import Data.Array.Accelerate.Async-import Data.Array.Accelerate.Trafo 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.LLVM.Native.Debug as Debug+import Data.Array.Accelerate.Trafo -import Data.Array.Accelerate.LLVM.Native.Compile ( compileAcc, compileAfun )-import Data.Array.Accelerate.LLVM.Native.Execute ( executeAcc, executeAfun1 )+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@@ -63,7 +88,7 @@ -- | Compile and run a complete embedded array program. ----- NOTE: it is recommended to use 'run1' whenever possible.+-- /NOTE:/ it is recommended to use 'runN' or 'runQ' whenever possible. -- run :: Arrays a => Acc a -> a run = runWith defaultTarget@@ -73,6 +98,7 @@ 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'.@@ -92,28 +118,43 @@ execute = do dumpGraph acc evalNative target $ do- exec <- phase "compile" elapsedS (compileAcc acc) >>= dumpStats- res <- phase "execute" elapsedP (executeAcc exec)+ build <- phase "compile" elapsedS (compileAcc acc) >>= dumpStats+ exec <- phase "link" elapsedS (linkAcc build)+ res <- phase "execute" elapsedP (executeAcc exec) return res --- | Prepare and execute an embedded array program of one argument.+-- | 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 parameter.+-- specifying any changing aspects of the computation via the input parameters. -- If the function is only evaluated once, this is equivalent to 'run'. ----- To use 'run1' effectively you must express your program as a function of one--- argument. If your program takes more than one argument, you can use--- 'Data.Array.Accelerate.lift' and 'Data.Array.Accelerate.unlift' to tuple up--- the arguments.+-- In order to use 'runN' you must express your Accelerate program as a function+-- of array terms: ----- At an example, once your program is expressed as a function of one argument,--- instead of the usual:+-- > 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 = ... -- >@@ -122,22 +163,47 @@ -- -- Instead write: ----- > simulate xs = run1 step xs+-- > simulate = runN step -- -- You can use the debugging options to check whether this is working--- successfully by, for example, observing no output from the @-ddump-cc@ flag--- at the second and subsequent invocations.+-- 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. ---run1 :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> b-run1 = run1With defaultTarget+-- 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 'run1', but execute using the specified target (thread gang).+-- | As 'runN', but execute using the specified target (thread gang). ---run1With :: (Arrays a, Arrays b) => Native -> (Acc a -> Acc b) -> a -> b-run1With = run1' unsafePerformIO+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)@@ -146,18 +212,48 @@ -- | 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 = run1' async+run1AsyncWith = runNAsyncWith -run1' :: (Arrays a, Arrays b) => (IO b -> c) -> Native -> (Acc a -> Acc b) -> a -> c-run1' using target f = \a -> using (execute a)++-- | 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- phase "compile" elapsedS (evalNative target (compileAfun acc)) >>= dumpStats- execute a = phase "execute" elapsedP (evalNative target (executeAfun1 afun a))+ !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. --@@ -172,13 +268,164 @@ !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 = gangSize target > 1+ { convertOffsetOfSegment = segmentOffset target }
Data/Array/Accelerate/LLVM/Native/CodeGen/Base.hs view
@@ -22,13 +22,18 @@ 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. --@@ -63,9 +68,9 @@ -- | Create a single kernel program ---makeOpenAcc :: Label -> [LLVM.Parameter] -> CodeGen () -> CodeGen (IROpenAcc Native aenv a)-makeOpenAcc name param kernel = do- body <- makeKernel name param kernel+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
Data/Array/Accelerate/LLVM/Native/CodeGen/Fold.hs view
@@ -30,6 +30,7 @@ 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@@ -47,19 +48,20 @@ -- mkFold :: forall aenv sh e. (Shape sh, Elt e)- => Gamma aenv+ => 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 aenv f z acc+mkFold uid aenv f z acc | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)- = (+++) <$> mkFoldAll aenv f (Just z) acc- <*> mkFoldFill aenv z+ = (+++) <$> mkFoldAll uid aenv f (Just z) acc+ <*> mkFoldFill uid aenv z | otherwise- = (+++) <$> mkFoldDim aenv f (Just z) acc- <*> mkFoldFill aenv z+ = (+++) <$> mkFoldDim uid aenv f (Just z) acc+ <*> mkFoldFill uid aenv z -- Reduce a non-empty array along the innermost dimension. The reduction@@ -67,16 +69,17 @@ -- mkFold1 :: forall aenv sh e. (Shape sh, Elt e)- => Gamma aenv+ => UID+ -> Gamma aenv -> IRFun2 Native aenv (e -> e -> e) -> IRDelayed Native aenv (Array (sh :. Int) e) -> CodeGen (IROpenAcc Native aenv (Array sh e))-mkFold1 aenv f acc+mkFold1 uid aenv f acc | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)- = mkFoldAll aenv f Nothing acc+ = mkFoldAll uid aenv f Nothing acc | otherwise- = mkFoldDim aenv f Nothing acc+ = mkFoldDim uid aenv f Nothing acc -- Reduce a multidimensional (>1) array along the innermost dimension.@@ -86,12 +89,13 @@ -- mkFoldDim :: forall aenv sh e. (Shape sh, Elt e)- => Gamma aenv+ => 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 aenv combine mseed IRDelayed{..} =+mkFoldDim uid aenv combine mseed IRDelayed{..} = let (start, end, paramGang) = gangParam (arrOut, paramOut) = mutableArray ("out" :: Name (Array sh e))@@ -100,7 +104,7 @@ paramStride = scalarParameter scalarType ("ix.stride" :: Name Int) stride = local scalarType ("ix.stride" :: Name Int) in- makeOpenAcc "fold" (paramGang ++ paramStride : paramOut ++ paramEnv) $ do+ makeOpenAcc uid "fold" (paramGang ++ paramStride : paramOut ++ paramEnv) $ do imapFromTo start end $ \seg -> do from <- mul numType seg stride@@ -139,15 +143,16 @@ -- mkFoldAll :: forall aenv e. Elt e- => Gamma aenv -- ^ array environment+ => 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 aenv combine mseed arr =- foldr1 (+++) <$> sequence [ mkFoldAllS aenv combine mseed arr- , mkFoldAllP1 aenv combine arr- , mkFoldAllP2 aenv combine mseed+mkFoldAll uid aenv combine mseed arr =+ foldr1 (+++) <$> sequence [ mkFoldAllS uid aenv combine mseed arr+ , mkFoldAllP1 uid aenv combine arr+ , mkFoldAllP2 uid aenv combine mseed ] @@ -155,19 +160,20 @@ -- mkFoldAllS :: forall aenv e. Elt e- => Gamma aenv -- ^ array environment+ => 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 aenv combine mseed IRDelayed{..} =+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 "foldAllS" (paramGang ++ paramOut ++ paramEnv) $ do+ makeOpenAcc uid "foldAllS" (paramGang ++ paramOut ++ paramEnv) $ do r <- case mseed of Just seed -> do z <- seed reduceFromTo start end (app2 combine) z (app1 delayedLinearIndex)@@ -182,11 +188,12 @@ -- mkFoldAllP1 :: forall aenv e. Elt e- => Gamma aenv -- ^ array environment+ => 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 aenv combine IRDelayed{..} =+mkFoldAllP1 uid aenv combine IRDelayed{..} = let (start, end, paramGang) = gangParam paramEnv = envParam aenv@@ -196,7 +203,7 @@ paramLength = scalarParameter scalarType ("ix.length" :: Name Int) paramStride = scalarParameter scalarType ("ix.stride" :: Name Int) in- makeOpenAcc "foldAllP1" (paramGang ++ paramLength : paramStride : paramTmp ++ paramEnv) $ do+ 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@@ -224,11 +231,12 @@ -- mkFoldAllP2 :: forall aenv e. Elt e- => Gamma aenv -- ^ array environment+ => 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 aenv combine mseed =+mkFoldAllP2 uid aenv combine mseed = let (start, end, paramGang) = gangParam paramEnv = envParam aenv@@ -236,7 +244,7 @@ (arrOut, paramOut) = mutableArray ("out" :: Name (Scalar e)) zero = lift 0 :: IR Int in- makeOpenAcc "foldAllP2" (paramGang ++ paramTmp ++ paramOut ++ paramEnv) $ do+ 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)@@ -250,11 +258,12 @@ -- mkFoldFill :: (Shape sh, Elt e)- => Gamma aenv+ => UID+ -> Gamma aenv -> IRExp Native aenv e -> CodeGen (IROpenAcc Native aenv (Array sh e))-mkFoldFill aenv seed =- mkGenerate aenv (IRFun1 (const seed))+mkFoldFill uid aenv seed =+ mkGenerate uid aenv (IRFun1 (const seed)) -- Reduction loops -- ---------------
Data/Array/Accelerate/LLVM/Native/CodeGen/FoldSeg.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-}@@ -30,6 +29,7 @@ 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@@ -46,15 +46,16 @@ -- mkFoldSeg :: forall aenv sh i e. (Shape sh, IsIntegral i, Elt i, Elt e)- => Gamma aenv+ => 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 aenv combine seed arr seg =- (+++) <$> mkFoldSegS aenv combine (Just seed) arr seg- <*> mkFoldSegP aenv combine (Just seed) arr seg+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/@@ -62,14 +63,15 @@ -- mkFold1Seg :: forall aenv sh i e. (Shape sh, IsIntegral i, Elt i, Elt e)- => Gamma aenv+ => 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 aenv combine arr seg =- (+++) <$> mkFoldSegS aenv combine Nothing arr seg- <*> mkFoldSegP aenv combine Nothing arr seg+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@@ -77,19 +79,20 @@ -- mkFoldSegS :: forall aenv sh i e. (Shape sh, IsIntegral i, Elt i, Elt e)- => Gamma aenv+ => 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 aenv combine mseed arr seg =+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 "foldSegS" (paramGang ++ paramOut ++ paramEnv) $ do+ makeOpenAcc uid "foldSegS" (paramGang ++ paramOut ++ paramEnv) $ do -- Number of segments, useful only if reducing DIM2 and higher ss <- indexHead <$> delayedExtent seg@@ -128,19 +131,20 @@ -- mkFoldSegP :: forall aenv sh i e. (Shape sh, IsIntegral i, Elt i, Elt e)- => Gamma aenv+ => 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 aenv combine mseed arr seg =+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 "foldSegP" (paramGang ++ paramOut ++ paramEnv) $ do+ 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
Data/Array/Accelerate/LLVM/Native/CodeGen/Generate.hs view
@@ -23,6 +23,7 @@ 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@@ -34,16 +35,17 @@ -- mkGenerate :: forall aenv sh e. (Shape sh, Elt e)- => Gamma aenv+ => UID+ -> Gamma aenv -> IRFun1 Native aenv (sh -> e) -> CodeGen (IROpenAcc Native aenv (Array sh e))-mkGenerate aenv apply =+mkGenerate uid aenv apply = let (start, end, paramGang) = gangParam (arrOut, paramOut) = mutableArray ("out" :: Name (Array sh e)) paramEnv = envParam aenv in- makeOpenAcc "generate" (paramGang ++ paramOut ++ paramEnv) $ do+ makeOpenAcc uid "generate" (paramGang ++ paramOut ++ paramEnv) $ do imapFromTo start end $ \i -> do ix <- indexOfInt (irArrayShape arrOut) i -- convert to multidimensional index
Data/Array/Accelerate/LLVM/Native/CodeGen/Map.hs view
@@ -24,6 +24,7 @@ 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@@ -73,17 +74,18 @@ -- Apply the given unary function to each element of an array. -- mkMap :: forall aenv sh a b. Elt b- => Gamma aenv+ => UID+ -> Gamma aenv -> IRFun1 Native aenv (a -> b) -> IRDelayed Native aenv (Array sh a) -> CodeGen (IROpenAcc Native aenv (Array sh b))-mkMap aenv apply IRDelayed{..} =+mkMap uid aenv apply IRDelayed{..} = let (start, end, paramGang) = gangParam (arrOut, paramOut) = mutableArray ("out" :: Name (Array sh b)) paramEnv = envParam aenv in- makeOpenAcc "map" (paramGang ++ paramOut ++ paramEnv) $ do+ makeOpenAcc uid "map" (paramGang ++ paramOut ++ paramEnv) $ do imapFromTo start end $ \i -> do xs <- app1 delayedLinearIndex i
Data/Array/Accelerate/LLVM/Native/CodeGen/Permute.hs view
@@ -32,6 +32,7 @@ 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@@ -60,14 +61,15 @@ -- mkPermute :: (Shape sh, Shape sh', Elt e)- => Gamma aenv+ => 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 aenv combine project arr =- (+++) <$> mkPermuteS aenv combine project arr- <*> mkPermuteP aenv combine project arr+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@@ -80,18 +82,19 @@ -- mkPermuteS :: forall aenv sh sh' e. (Shape sh, Shape sh', Elt e)- => Gamma aenv+ => 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 aenv IRPermuteFun{..} project IRDelayed{..} =+mkPermuteS uid aenv IRPermuteFun{..} project IRDelayed{..} = let (start, end, paramGang) = gangParam (arrOut, paramOut) = mutableArray ("out" :: Name (Array sh' e)) paramEnv = envParam aenv in- makeOpenAcc "permuteS" (paramGang ++ paramOut ++ paramEnv) $ do+ makeOpenAcc uid "permuteS" (paramGang ++ paramOut ++ paramEnv) $ do sh <- delayedExtent @@ -125,15 +128,16 @@ -- mkPermuteP :: forall aenv sh sh' e. (Shape sh, Shape sh', Elt e)- => Gamma aenv+ => 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 aenv IRPermuteFun{..} project arr =+mkPermuteP uid aenv IRPermuteFun{..} project arr = case atomicRMW of- Nothing -> mkPermuteP_mutex aenv combine project arr- Just (rmw, f) -> mkPermuteP_rmw aenv rmw f project arr+ 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@@ -141,19 +145,20 @@ -- mkPermuteP_rmw :: forall aenv sh sh' e. (Shape sh, Shape sh', Elt e)- => Gamma aenv+ => 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 aenv rmw update project IRDelayed{..} =+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 "permuteP_rmw" (paramGang ++ paramOut ++ paramEnv) $ do+ makeOpenAcc uid "permuteP_rmw" (paramGang ++ paramOut ++ paramEnv) $ do sh <- delayedExtent @@ -196,19 +201,20 @@ -- mkPermuteP_mutex :: forall aenv sh sh' e. (Shape sh, Shape sh', Elt e)- => Gamma aenv+ => 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 aenv combine project IRDelayed{..} =+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 "permuteP_mutex" (paramGang ++ paramOut ++ paramLock ++ paramEnv) $ do+ makeOpenAcc uid "permuteP_mutex" (paramGang ++ paramOut ++ paramLock ++ paramEnv) $ do sh <- delayedExtent
Data/Array/Accelerate/LLVM/Native/CodeGen/Scan.hs view
@@ -33,6 +33,7 @@ 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@@ -58,21 +59,22 @@ -- mkScanl :: forall aenv sh e. (Shape sh, Elt e)- => Gamma aenv+ => 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 aenv combine seed arr+mkScanl uid aenv combine seed arr | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)- = foldr1 (+++) <$> sequence [ mkScanS L aenv combine (Just seed) arr- , mkScanP L aenv combine (Just seed) arr- , mkScanFill aenv seed+ = 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 aenv combine (Just seed) arr- <*> mkScanFill aenv seed+ = (+++) <$> mkScanS L uid aenv combine (Just seed) arr+ <*> mkScanFill uid aenv seed -- 'Data.List.scanl1' style left-to-right inclusive scan, but with the@@ -85,17 +87,18 @@ -- mkScanl1 :: forall aenv sh e. (Shape sh, Elt e)- => Gamma aenv+ => 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 aenv combine arr+mkScanl1 uid aenv combine arr | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)- = (+++) <$> mkScanS L aenv combine Nothing arr- <*> mkScanP L aenv combine Nothing arr+ = (+++) <$> mkScanS L uid aenv combine Nothing arr+ <*> mkScanP L uid aenv combine Nothing arr -- | otherwise- = mkScanS L aenv combine Nothing arr+ = mkScanS L uid aenv combine Nothing arr -- Variant of 'scanl' where the final result is returned in a separate array.@@ -108,21 +111,22 @@ -- mkScanl' :: forall aenv sh e. (Shape sh, Elt e)- => Gamma aenv+ => 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' aenv combine seed arr+mkScanl' uid aenv combine seed arr | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)- = foldr1 (+++) <$> sequence [ mkScan'S L aenv combine seed arr- , mkScan'P L aenv combine seed arr- , mkScan'Fill aenv seed+ = 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 aenv combine seed arr- <*> mkScan'Fill aenv seed+ = (+++) <$> 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@@ -135,21 +139,22 @@ -- mkScanr :: forall aenv sh e. (Shape sh, Elt e)- => Gamma aenv+ => 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 aenv combine seed arr+mkScanr uid aenv combine seed arr | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)- = foldr1 (+++) <$> sequence [ mkScanS R aenv combine (Just seed) arr- , mkScanP R aenv combine (Just seed) arr- , mkScanFill aenv seed+ = 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 aenv combine (Just seed) arr- <*> mkScanFill aenv seed+ = (+++) <$> mkScanS R uid aenv combine (Just seed) arr+ <*> mkScanFill uid aenv seed -- 'Data.List.scanr1' style right-to-left inclusive scan, but with the@@ -162,17 +167,18 @@ -- mkScanr1 :: forall aenv sh e. (Shape sh, Elt e)- => Gamma aenv+ => 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 aenv combine arr+mkScanr1 uid aenv combine arr | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)- = (+++) <$> mkScanS R aenv combine Nothing arr- <*> mkScanP R aenv combine Nothing arr+ = (+++) <$> mkScanS R uid aenv combine Nothing arr+ <*> mkScanP R uid aenv combine Nothing arr -- | otherwise- = mkScanS R aenv combine Nothing arr+ = mkScanS R uid aenv combine Nothing arr -- Variant of 'scanr' where the final result is returned in a separate array.@@ -185,21 +191,22 @@ -- mkScanr' :: forall aenv sh e. (Shape sh, Elt e)- => Gamma aenv+ => 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' aenv combine seed arr+mkScanr' uid aenv combine seed arr | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)- = foldr1 (+++) <$> sequence [ mkScan'S R aenv combine seed arr- , mkScan'P R aenv combine seed arr- , mkScan'Fill aenv seed+ = 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 aenv combine seed arr- <*> mkScan'Fill aenv seed+ = (+++) <$> 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@@ -207,19 +214,21 @@ -- mkScanFill :: (Shape sh, Elt e)- => Gamma aenv+ => UID+ -> Gamma aenv -> IRExp Native aenv e -> CodeGen (IROpenAcc Native aenv (Array sh e))-mkScanFill aenv seed =- mkGenerate aenv (IRFun1 (const seed))+mkScanFill uid aenv seed =+ mkGenerate uid aenv (IRFun1 (const seed)) mkScan'Fill :: forall aenv sh e. (Shape sh, Elt e)- => Gamma aenv+ => UID+ -> Gamma aenv -> IRExp Native aenv e -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e, Array sh e))-mkScan'Fill aenv seed =- Safe.coerce <$> (mkScanFill aenv seed :: CodeGen (IROpenAcc Native aenv (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@@ -232,12 +241,13 @@ 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 aenv combine mseed IRDelayed{..} =+mkScanS dir uid aenv combine mseed IRDelayed{..} = let (start, end, paramGang) = gangParam (arrOut, paramOut) = mutableArray ("out" :: Name (Array (sh:.Int) e))@@ -247,7 +257,7 @@ L -> A.add numType i (lift 1) R -> A.sub numType i (lift 1) in- makeOpenAcc "scanS" (paramGang ++ paramOut ++ paramEnv) $ do+ makeOpenAcc uid "scanS" (paramGang ++ paramOut ++ paramEnv) $ do sz <- indexHead <$> delayedExtent szp1 <- A.add numType sz (lift 1)@@ -308,12 +318,13 @@ 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 aenv combine seed IRDelayed{..} =+mkScan'S dir uid aenv combine seed IRDelayed{..} = let (start, end, paramGang) = gangParam (arrOut, paramOut) = mutableArray ("out" :: Name (Array (sh:.Int) e))@@ -324,7 +335,7 @@ L -> A.add numType i (lift 1) R -> A.sub numType i (lift 1) in- makeOpenAcc "scanS" (paramGang ++ paramOut ++ paramSum ++ paramEnv) $ do+ makeOpenAcc uid "scanS" (paramGang ++ paramOut ++ paramSum ++ paramEnv) $ do sz <- indexHead <$> delayedExtent szm1 <- A.sub numType sz (lift 1)@@ -374,15 +385,16 @@ 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 aenv combine mseed arr =- foldr1 (+++) <$> sequence [ mkScanP1 dir aenv combine mseed arr- , mkScanP2 dir aenv combine- , mkScanP3 dir aenv combine mseed+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.@@ -394,12 +406,13 @@ 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 aenv combine mseed IRDelayed{..} =+mkScanP1 dir uid aenv combine mseed IRDelayed{..} = let (chunk, _, paramGang) = gangParam (arrOut, paramOut) = mutableArray ("out" :: Name (Vector e))@@ -418,7 +431,7 @@ L -> lift 0 R -> steps in- makeOpenAcc "scanP1" (paramGang ++ paramStride : paramSteps : paramOut ++ paramTmp ++ paramEnv) $ do+ makeOpenAcc uid "scanP1" (paramGang ++ paramStride : paramSteps : paramOut ++ paramTmp ++ paramEnv) $ do len <- indexHead <$> delayedExtent @@ -494,10 +507,11 @@ mkScanP2 :: forall aenv e. Elt e => Direction+ -> UID -> Gamma aenv -> IRFun2 Native aenv (e -> e -> e) -> CodeGen (IROpenAcc Native aenv (Vector e))-mkScanP2 dir aenv combine =+mkScanP2 dir uid aenv combine = let (start, end, paramGang) = gangParam (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e))@@ -511,7 +525,7 @@ L -> A.add numType i (lift 1) R -> A.sub numType i (lift 1) in- makeOpenAcc "scanP2" (paramGang ++ paramTmp ++ paramEnv) $ do+ makeOpenAcc uid "scanP2" (paramGang ++ paramTmp ++ paramEnv) $ do i0 <- case dir of L -> return start@@ -545,11 +559,12 @@ 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 aenv combine mseed =+mkScanP3 dir uid aenv combine mseed = let (chunk, _, paramGang) = gangParam (arrOut, paramOut) = mutableArray ("out" :: Name (Vector e))@@ -566,7 +581,7 @@ L -> A.sub numType i (lift 1) R -> A.add numType i (lift 1) in- makeOpenAcc "scanP3" (paramGang ++ paramStride : paramOut ++ paramTmp ++ paramEnv) $ do+ makeOpenAcc uid "scanP3" (paramGang ++ paramStride : paramOut ++ paramTmp ++ paramEnv) $ do -- Determine which chunk will be carrying in values for. Compute appropriate -- start and end indices.@@ -601,15 +616,16 @@ 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 aenv combine seed arr =- foldr1 (+++) <$> sequence [ mkScan'P1 dir aenv combine seed arr- , mkScan'P2 dir aenv combine- , mkScan'P3 dir aenv combine+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@@ -621,12 +637,13 @@ 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 aenv combine seed IRDelayed{..} =+mkScan'P1 dir uid aenv combine seed IRDelayed{..} = let (chunk, _, paramGang) = gangParam (arrOut, paramOut) = mutableArray ("out" :: Name (Vector e))@@ -646,7 +663,7 @@ L -> lift 0 R -> steps in- makeOpenAcc "scanP1" (paramGang ++ paramStride : paramSteps : paramOut ++ paramTmp ++ paramEnv) $ do+ makeOpenAcc uid "scanP1" (paramGang ++ paramStride : paramSteps : paramOut ++ paramTmp ++ paramEnv) $ do -- Compute the start and end indices for this non-empty chunk of the input. --@@ -707,10 +724,11 @@ 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 aenv combine =+mkScan'P2 dir uid aenv combine = let (start, end, paramGang) = gangParam (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e))@@ -725,7 +743,7 @@ L -> A.add numType i (lift 1) R -> A.sub numType i (lift 1) in- makeOpenAcc "scanP2" (paramGang ++ paramSum ++ paramTmp ++ paramEnv) $ do+ makeOpenAcc uid "scanP2" (paramGang ++ paramSum ++ paramTmp ++ paramEnv) $ do i0 <- case dir of L -> return start@@ -761,10 +779,11 @@ 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 aenv combine =+mkScan'P3 dir uid aenv combine = let (chunk, _, paramGang) = gangParam (arrOut, paramOut) = mutableArray ("out" :: Name (Vector e))@@ -781,7 +800,7 @@ L -> A.sub numType i (lift 1) R -> A.add numType i (lift 1) in- makeOpenAcc "scanP3" (paramGang ++ paramStride : paramOut ++ paramTmp ++ paramEnv) $ do+ 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
Data/Array/Accelerate/LLVM/Native/Compile.hs view
@@ -15,87 +15,98 @@ module Data.Array.Accelerate.LLVM.Native.Compile ( module Data.Array.Accelerate.LLVM.Compile,- module Data.Array.Accelerate.LLVM.Native.Compile.Module,- ExecutableR(..),+ ObjectR(..), ) where --- llvm-general+-- llvm-hs import LLVM.AST hiding ( Module ) import LLVM.Module as LLVM hiding ( Module ) import LLVM.Context import LLVM.Target-import LLVM.ExecutionEngine -- accelerate-import Data.Array.Accelerate.Error ( internalError ) 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 ( unModule )--import Data.Array.Accelerate.LLVM.Native.Compile.Link-import Data.Array.Accelerate.LLVM.Native.Compile.Module-import Data.Array.Accelerate.LLVM.Native.Compile.Optimise+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.Except ( runExceptT ) 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 ExecutableR Native = NativeR { executableR :: Module }- compileForTarget = compileForNativeTarget+ data ObjectR Native = ObjectR { objId :: {-# UNPACK #-} !UID+ , objSyms :: {- LAZY -} [ShortByteString]+ , objData :: {- LAZY -} ByteString+ }+ compileForTarget = compile instance Intrinsic Native --- Compile an Accelerate expression for the native CPU target.+-- | Compile an Accelerate expression to object code ---compileForNativeTarget :: DelayedOpenAcc aenv a -> Gamma aenv -> LLVM Native (ExecutableR Native)-compileForNativeTarget acc aenv = do- target <- gets llvmTarget+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 ast = unModule (llvmOfOpenAcc target acc aenv)- triple = fromMaybe "" (moduleTargetTriple ast)- datalayout = moduleDataLayout ast+ 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 to an executable function(s)+ -- Lower the generated LLVM and produce an object file. --- mdl <- liftIO .- compileModule $ \k ->- withContext $ \ctx ->- runExcept $ withModuleFromAST ctx ast $ \mdl ->- runExcept $ withNativeTargetMachine $ \machine ->- withTargetLibraryInfo triple $ \libinfo -> do- optimiseModule datalayout (Just machine) (Just libinfo) mdl-- Debug.when Debug.verbose $ do- Debug.traceIO Debug.dump_cc =<< moduleLLVMAssembly mdl- Debug.traceIO Debug.dump_asm =<< runExcept (moduleTargetAssembly machine mdl)+ -- 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 - withMCJIT ctx opt model ptrelim fast $ \mcjit -> do- withModuleInEngine mcjit mdl $ \exe -> do- k =<< getGlobalFunctions ast exe+ else+ withContext $ \ctx ->+ withModuleFromAST ctx ast $ \mdl ->+ withNativeTargetMachine $ \machine ->+ withTargetLibraryInfo triple $ \libinfo -> do+ optimiseModule datalayout (Just machine) (Just libinfo) mdl - return $ NativeR 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 - where- runExcept = either ($internalError "compileForNativeTarget") return <=< runExceptT+ obj <- moduleObject machine mdl+ B.writeFile cacheFile obj+ return obj - opt = Just 3 -- optimisation level- model = Nothing -- code model?- ptrelim = Nothing -- True to disable frame pointer elimination- fast = Just True -- True to enable fast instruction selection+ return $! ObjectR uid nms obj
+ Data/Array/Accelerate/LLVM/Native/Compile/Cache.hs view
@@ -0,0 +1,35 @@+{-# 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/Link.hs
@@ -1,56 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}--- |--- Module : Data.Array.Accelerate.LLVM.Native.Compile.Link--- 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.Link- where---- llvm-hs-import LLVM.AST-import LLVM.AST.Global-import LLVM.ExecutionEngine---- accelerate-import Data.Array.Accelerate.Error---- standard library-import Data.Maybe----- | Return function pointers to all of the global function definitions in the--- given executable module.----getGlobalFunctions- :: ExecutionEngine e f- => Module- -> ExecutableModule e- -> IO [(String, f)]-getGlobalFunctions ast exe- = mapM (\f -> (f,) `fmap` link f)- $ globalFunctions (moduleDefinitions ast)- where- link f = fromMaybe ($internalError "link" "function not found") `fmap` getFunction exe (Name f)----- | Extract the names of the function definitions from a module------ TLM: move this somewhere it can be shared between Native/NVVM backend----globalFunctions :: [Definition] -> [String]-globalFunctions defs =- [ n | GlobalDefinition Function{..} <- defs- , not (null basicBlocks)- , let Name n = name- ]-
− Data/Array/Accelerate/LLVM/Native/Compile/Module.hs
@@ -1,153 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}--- |--- Module : Data.Array.Accelerate.LLVM.Native.Compile.Module--- 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.Compile.Module (-- Module,- compileModule,- execute, executeMain,- nm,--) where---- accelerate-import Data.Array.Accelerate.Error-import Data.Array.Accelerate.Lifetime-import qualified Data.Array.Accelerate.LLVM.Native.Debug as Debug---- library-import Control.Exception-import Control.Concurrent-import Data.List-import Foreign.LibFFI-import Foreign.Ptr-import Text.Printf----- | An encapsulation of the callable functions resulting from compiling--- a module.----data Module = Module {-# UNPACK #-} !(Lifetime FunctionTable)--data FunctionTable = FunctionTable { functionTable :: [Function] }-type Function = (String, FunPtr ())--instance Show Module where- showsPrec p (Module m)- = showsPrec p (unsafeGetValue m)--instance Show FunctionTable where- showsPrec _ f- = showString "<<"- . showString (intercalate "," [ n | (n,_) <- functionTable f ])- . showString ">>"----- | Execute a named function that was defined in the module. An error is thrown--- if the requested function is not define in the module.------ The final argument is a continuation to which we pass a function you can call--- to actually execute the foreign function.----{-# INLINEABLE execute #-}-execute- :: Module- -> String- -> ((String, [Arg] -> IO ()) -> IO a)- -> IO a-execute mdl@(Module ft) name k =- withLifetime ft $ \FunctionTable{..} ->- case lookup name functionTable of- Just f -> k (name, \argv -> callFFI f retVoid argv)- Nothing -> $internalError "execute" (printf "function '%s' not found in module: %s\n" name (show mdl))----- | Execute the 'main' function of a module, which is just the first function--- defined in the module.----{-# INLINEABLE executeMain #-}-executeMain- :: Module- -> ((String, [Arg] -> IO ()) -> IO a)- -> IO a-executeMain (Module ft) k =- withLifetime ft $ \FunctionTable{..} ->- case functionTable of- [] -> $internalError "executeMain" "no functions defined in module"- (name,f):_ -> k (name, \argv -> callFFI f retVoid argv)----- | Display the global (external) symbol table for this module.----nm :: Module -> IO [String]-nm (Module ft) =- withLifetime ft $ \FunctionTable{..} ->- return $ map fst functionTable----- Compile a given module into executable code.------ Note: [Executing JIT-compiled functions]------ We have the problem that the llvm-general functions dealing with the FFI are--- exposed as bracketed 'with*' operations, rather than as separate--- 'create*'/'destroy*' pairs. This is a good design that guarantees that--- functions clean up their resources on exit, but also means that we can't--- return a function pointer to the compiled code from within the bracketed--- expression, because it will no longer be valid once we get around to--- executing it, as it has already been deallocated!------ This function provides a wrapper that does the compilation step (first--- argument) in a separate thread, returns the compiled functions, then waits--- until they are no longer needed before allowing the finalisation routines to--- proceed.----compileModule :: (([Function] -> IO ()) -> IO ()) -> IO Module-compileModule compile = mask $ \restore -> do- main <- myThreadId- mfuns <- newEmptyMVar- mdone <- newEmptyMVar- _ <- forkIO . reflectExceptionsTo main . restore . compile $ \funs -> do- putMVar mfuns funs- takeMVar mdone -- thread blocks, keeping 'funs' alive- message "worker thread shutting down" -- we better have a matching message from 'finalise'- --- funs <- takeMVar mfuns- ftab <- newLifetime (FunctionTable funs)- addFinalizer ftab (finalise mdone)- return (Module ftab)--reflectExceptionsTo :: ThreadId -> IO () -> IO ()-reflectExceptionsTo tid action =- catchNonThreadKilled action (throwTo tid)--catchNonThreadKilled :: IO a -> (SomeException -> IO a) -> IO a-catchNonThreadKilled action handler =- action `catch` \e ->- case fromException e of- Just ThreadKilled -> throwIO e- _ -> handler e--finalise :: MVar () -> IO ()-finalise done = do- message "finalising function table"- putMVar done ()----- Debug--- -------{-# INLINE message #-}-message :: String -> IO ()-message msg = Debug.traceIO Debug.dump_exec ("exec: " ++ msg)-
+ 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)+
+ 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."++
+ Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC.hs view
@@ -0,0 +1,438 @@+-- |+-- 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 view
@@ -0,0 +1,115 @@+{-# 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 view
@@ -0,0 +1,78 @@+{-# 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.Monad+import Foreign.Ptr+import GHC.Ptr ( Ptr(..) )+import Language.Haskell.TH ( Q, TExp )+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+ fn' <- TH.newName ("__accelerate_llvm_native_" ++ fn)+ 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 view
@@ -20,21 +20,22 @@ module Data.Array.Accelerate.LLVM.Native.Execute ( - executeAcc, executeAfun1,+ executeAcc, executeAfun,+ executeOpenAcc ) where -- accelerate-import Data.Array.Accelerate.Error-import Data.Array.Accelerate.Array.Sugar 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.Compile+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@@ -47,14 +48,18 @@ import Data.Array.Accelerate.LLVM.Native.Execute.LBS -- library-import Data.Word ( Word8 ) 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 ( Arg )+import Foreign.LibFFI import Foreign.Ptr @@ -107,29 +112,31 @@ -> Stream -> sh -> LLVM Native (Array sh e)-simpleOp NativeR{..} gamma aenv () sh = do+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- executeMain executableR $ \f ->- executeOp defaultLargePPT fillP f gamma aenv (IE 0 (size sh)) out+ executeOp defaultLargePPT fillP fun gamma aenv (IE 0 (size sh)) out return out simpleNamed :: (Shape sh, Elt e)- => String+ => ShortByteString -> ExecutableR Native -> Gamma aenv -> Aval aenv -> Stream -> sh -> LLVM Native (Array sh e)-simpleNamed fun NativeR{..} gamma aenv () sh = do+simpleNamed name exe gamma aenv () sh = withExecutable exe $ \nativeExecutable -> do Native{..} <- gets llvmTarget liftIO $ do out <- allocateArray sh- execute executableR fun $ \f ->- executeOp defaultLargePPT fillP f gamma aenv (IE 0 (size sh)) out+ executeOp defaultLargePPT fillP (nativeExecutable !# name) gamma aenv (IE 0 (size sh)) out return out @@ -205,7 +212,7 @@ -> Stream -> DIM1 -> LLVM Native (Scalar e)-foldAllOp NativeR{..} gamma aenv () (Z :. sz) = do+foldAllOp exe gamma aenv () (Z :. sz) = withExecutable exe $ \nativeExecutable -> do Native{..} <- gets llvmTarget let ncpu = gangSize@@ -216,20 +223,15 @@ then liftIO $ do -- Sequential reduction out <- allocateArray Z- execute executableR "foldAllS" $ \f ->- executeOp 1 fillS f gamma aenv (IE 0 sz) out+ 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)- --- execute executableR "foldAllP1" $ \f1 -> do- execute executableR "foldAllP2" $ \f2 -> do- executeOp 1 fillP f1 gamma aenv (IE 0 steps) (sz, stride, tmp)- executeOp 1 fillS f2 gamma aenv (IE 0 steps) (tmp, out)- --+ 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@@ -240,13 +242,12 @@ -> Stream -> (sh :. Int) -> LLVM Native (Array sh e)-foldDimOp NativeR{..} gamma aenv () (sh :. sz) = do+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- executeMain executableR $ \f ->- executeOp ppt fillP f gamma aenv (IE 0 (size sh)) (sz, out)+ executeOp ppt fillP (nativeExecutable !# "fold") gamma aenv (IE 0 (size sh)) (sz, out) return out foldSegOp@@ -258,20 +259,19 @@ -> (sh :. Int) -> (Z :. Int) -> LLVM Native (Array (sh :. Int) e)-foldSegOp NativeR{..} gamma aenv () (sh :. _) (Z :. ss) = do+foldSegOp exe gamma aenv () (sh :. _) (Z :. ss) = withExecutable exe $ \nativeExecutable -> do Native{..} <- gets llvmTarget let- ncpu = gangSize- kernel | ncpu == 1 = "foldSegS"- | otherwise = "foldSegP"- n | ncpu == 1 = ss- | otherwise = ss - 1 -- segments array has been 'scanl (+) 0'`ed- ppt = n -- for 1D distribute evenly over threads; otherwise- -- -- compute all segments on an innermost dimension+ 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)- execute executableR kernel $ \f ->- executeOp ppt fillP f gamma aenv (IE 0 (size (sh :. n))) out+ executeOp ppt fillP (nativeExecutable !# kernel) gamma aenv (IE 0 (size (sh :. n))) out return out @@ -310,7 +310,7 @@ -> Int -> Int -> LLVM Native (Array (sh:.Int) e)-scanCore NativeR{..} gamma aenv () sz n m = do+scanCore exe gamma aenv () sz n m = withExecutable exe $ \nativeExecutable -> do Native{..} <- gets llvmTarget let ncpu = gangSize@@ -333,22 +333,16 @@ -- the extra cores can offset the increased bandwidth requirements. -- out <- allocateArray (sz :. m)- execute executableR "scanS" $ \f ->- executeOp 1 fillP f gamma aenv (IE 0 (size sz)) out+ 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)- --- execute executableR "scanP1" $ \f1 -> do- execute executableR "scanP2" $ \f2 -> do- execute executableR "scanP3" $ \f3 -> do- executeOp 1 fillP f1 gamma aenv (IE 0 steps) (stride, steps', out, tmp)- executeOp 1 fillS f2 gamma aenv (IE 0 steps) tmp- executeOp 1 fillP f3 gamma aenv (IE 0 steps') (stride, out, tmp)- --+ 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 @@ -377,7 +371,7 @@ -> Stream -> sh :. Int -> LLVM Native (Array (sh:.Int) e, Array sh e)-scan'Core NativeR{..} gamma aenv () sh@(sz :. n) = do+scan'Core exe gamma aenv () sh@(sz :. n) = withExecutable exe $ \nativeExecutable -> do Native{..} <- gets llvmTarget let ncpu = gangSize@@ -389,22 +383,16 @@ then liftIO $ do out <- allocateArray sh sum <- allocateArray sz- execute executableR "scanS" $ \f ->- executeOp 1 fillP f gamma aenv (IE 0 (size sz)) (out,sum)+ 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-- execute executableR "scanP1" $ \f1 -> do- execute executableR "scanP2" $ \f2 -> do- execute executableR "scanP3" $ \f3 -> do- executeOp 1 fillP f1 gamma aenv (IE 0 steps) (stride, steps', out, tmp)- executeOp 1 fillS f2 gamma aenv (IE 0 steps) (sum, tmp)- executeOp 1 fillP f3 gamma aenv (IE 0 steps') (stride, out, tmp)-+ 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) @@ -421,7 +409,7 @@ -> sh -> Array sh' e -> LLVM Native (Array sh' e)-permuteOp NativeR{..} gamma aenv () inplace shIn dfs = do+permuteOp exe gamma aenv () inplace shIn dfs = withExecutable exe $ \nativeExecutable -> do Native{..} <- gets llvmTarget out <- if inplace then return dfs@@ -434,22 +422,16 @@ if ncpu == 1 || n <= defaultLargePPT then liftIO $ do -- sequential permutation- execute executableR "permuteS" $ \f ->- executeOp 1 fillS f gamma aenv (IE 0 n) out+ executeOp 1 fillS (nativeExecutable !# "permuteS") gamma aenv (IE 0 n) out else liftIO $ do -- parallel permutation- symbols <- nm executableR- if "permuteP_rmw" `elem` symbols- then do- execute executableR "permuteP_rmw" $ \f ->- executeOp defaultLargePPT fillP f gamma aenv (IE 0 n) out-- else do+ 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- execute executableR "permuteP_mutex" $ \f ->- executeOp defaultLargePPT fillP f gamma aenv (IE 0 n) (out, barrier)+ executeOp defaultLargePPT fillP (nativeExecutable !# "permuteP_mutex") gamma aenv (IE 0 n) (out, barrier) return out @@ -481,13 +463,22 @@ -- 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- -> (String, [Arg] -> IO ())+ -> Function -> Gamma aenv -> Aval aenv -> Range@@ -496,7 +487,7 @@ executeOp ppt exe (name, f) gamma aenv r args = runExecutable exe name ppt r $ \start end _tid -> monitorProcTime $- f =<< marshal (undefined::Native) () (start, end, args, (gamma, aenv))+ callFFI f retVoid =<< marshal (undefined::Native) () (start, end, args, (gamma, aenv)) -- Standard C functions
Data/Array/Accelerate/LLVM/Native/Foreign.hs view
@@ -21,7 +21,7 @@ -- useful re-exports LLVM,- Native,+ Native(..), liftIO, module Data.Array.Accelerate.LLVM.Native.Array.Data,
+ 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+
+ 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"+
+ 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+
+ Data/Array/Accelerate/LLVM/Native/Link/ELF.chs view
@@ -0,0 +1,710 @@+{-# 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 view
@@ -0,0 +1,746 @@+{-# 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 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+
+ Data/Array/Accelerate/LLVM/Native/Plugin.hs view
@@ -0,0 +1,154 @@+{-# 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 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)+
+ 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+
Data/Array/Accelerate/LLVM/Native/State.hs view
@@ -30,13 +30,17 @@ 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 @@ -56,8 +60,10 @@ -> Strategy -- ^ Strategy to balance parallel workloads -> IO Native createTarget caps parallelIO = do+ let size = length caps gang <- forkGangOn caps- return $! Native (length caps) (sequentialIO gang) (parallelIO gang)+ linker <- LC.new+ return $! Native size linker (sequentialIO gang) (parallelIO gang) (size > 1) -- | The strategy for balancing work amongst the available worker threads.@@ -107,7 +113,8 @@ -- -- | Initialise the gang of threads that will be used to execute computations.--- This spawns one worker on each capability, which can be set via +RTS -Nn.+-- 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).@@ -121,8 +128,22 @@ {-# NOINLINE defaultTarget #-} defaultTarget :: Native defaultTarget = unsafePerformIO $ do- Debug.traceIO Debug.dump_gc (printf "gc: initialise native target with %d CPUs" numCapabilities)- case numCapabilities of+ 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) @@ -131,10 +152,10 @@ -- --------- {-# INLINE timed #-}-timed :: String -> IO a -> IO a+timed :: ShortByteString -> IO a -> IO a timed name f = Debug.timed Debug.dump_exec (elapsed name) f {-# INLINE elapsed #-}-elapsed :: String -> Double -> Double -> String-elapsed name x y = printf "exec: %s %s" name (Debug.elapsedP x y)+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 view
@@ -1,6 +1,3 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-} -- | -- Module : Data.Array.Accelerate.LLVM.Native.Target -- Copyright : [2014..2017] Trevor L. McDonell@@ -24,22 +21,24 @@ import LLVM.AST.DataLayout ( DataLayout ) -- accelerate-import Data.Array.Accelerate.Error ( internalError )-+import Data.Array.Accelerate.LLVM.Native.Link.Cache ( LinkCache ) import Data.Array.Accelerate.LLVM.Target ( Target(..) ) import Control.Parallel.Meta ( Executable ) -- standard library-import Control.Monad.Except+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- , fillS :: {-# UNPACK #-} !Executable- , fillP :: {-# UNPACK #-} !Executable+data Native = Native+ { gangSize :: {-# UNPACK #-} !Int+ , linkCache :: {-# UNPACK #-} !LinkCache+ , fillS :: {-# UNPACK #-} !Executable+ , fillP :: {-# UNPACK #-} !Executable+ , segmentOffset :: !Bool } instance Target Native where@@ -50,7 +49,7 @@ -- | String that describes the native target -- {-# NOINLINE nativeTargetTriple #-}-nativeTargetTriple :: String+nativeTargetTriple :: ShortByteString nativeTargetTriple = unsafePerformIO $ -- A target triple suitable for loading code into the current process getProcessTargetTriple@@ -62,15 +61,20 @@ nativeDataLayout :: DataLayout nativeDataLayout = unsafePerformIO- $ fmap (either ($internalError "nativeDataLayout") id)- $ runExceptT (withNativeTargetMachine getTargetMachineDataLayout)+ $ 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)- -> ExceptT String IO a+ -> IO a withNativeTargetMachine = withHostTargetMachine
+ README.md view
@@ -0,0 +1,188 @@+An LLVM backend for the Accelerate Array Language+=================================================++[](https://travis-ci.org/AccelerateHS/accelerate-llvm)+[](https://hackage.haskell.org/package/accelerate-llvm)+[](https://hub.docker.com/r/tmcdonell/accelerate-llvm/)+[](https://microbadger.com/images/tmcdonell/accelerate-llvm)++This package compiles Accelerate code to LLVM IR, and executes that code on+multicore CPUs as well as NVIDIA GPUs. This avoids the need to go through `nvcc`+or `clang`. For details on Accelerate, refer to the [main repository][GitHub].++We love all kinds of contributions, so feel free to open issues for missing+features as well as report (or fix!) bugs on the [issue tracker][Issues].++ [GitHub]: https://github.com/AccelerateHS/accelerate+ [Issues]: https://github.com/AccelerateHS/accelerate/issues+++ * [Dependencies](#dependencies)+ * [Docker](#docker)+ * [Installing LLVM](#installing-llvm)+ * [Homebrew](#homebrew)+ * [Debian/Ubuntu](#debianubuntu)+ * [Building from source](#building-from-source)+ * [Installing Accelerate-LLVM](#installing-accelerate-llvm)+ * [libNVVM](#libNVVM)+++Dependencies+------------++Haskell dependencies are available from Hackage, but there are several external+library dependencies that you will need to install as well:++ * [`LLVM`](http://llvm.org)+ * [`libFFI`](http://sourceware.org/libffi/) (if using the `accelerate-llvm-native` backend for multicore CPUs)+ * [`CUDA`](https://developer.nvidia.com/cuda-downloads) (if using the `accelerate-llvm-ptx` backend for NVIDIA GPUs)+++Docker+------++A [docker](https://www.docker.com) container is provided with this package+preinstalled (via stack) at `/opt/accelerate-llvm`. Note that if you wish to use+the `accelerate-llvm-ptx` GPU backend, you will need to install the [NVIDIA+docker](https://github.com/NVIDIA/nvidia-docker) plugin; see that page for more+information.++```sh+$ docker run -it tmcdonell/accelerate-llvm+```+++Installing LLVM+---------------++When installing LLVM, make sure that it includes the `libLLVM` shared library.+If you want to use the GPU targeting `accelerate-llvm-ptx` backend, make sure+you install (or build) LLVM with the 'nvptx' target.++## Homebrew++Example using [Homebrew](http://brew.sh) on macOS:++```sh+$ brew install llvm-hs/homebrew-llvm/llvm-4.0+```++## Debian/Ubuntu++For Debian/Ubuntu based Linux distributions, the LLVM.org website provides+binary distribution packages. Check [apt.llvm.org](http://apt.llvm.org) for+instructions for adding the correct package database for your OS version, and+then:++```sh+$ apt-get install llvm-4.0-dev+```++## Building from source++If your OS does not have an appropriate LLVM distribution available, you can also build from source. Detailed build instructions are available on the [LLVM.org website](http://releases.llvm.org/4.0.0/docs/CMake.html). Note that you will require at least [CMake 3.4.3](http://www.cmake.org/cmake/resources/software.html) and a recent C++ compiler; at least Clang 3.1, GCC 4.8, or Visual Studio 2015 (update 3).++ 1. Download and unpack the [LLVM-4.0 source code](http://releases.llvm.org/4.0.0/llvm-4.0.0.src.tar.xz). We'll refer to+ the path that the source tree was unpacked to as `LLVM_SRC`. Only the main+ LLVM source tree is required, but you can optionally add other components+ such as the Clang compiler or Polly loop optimiser. See the [LLVM releases](http://releases.llvm.org/download.html#4.0.0)+ page for the complete list.++ 2. Create a temporary build directory and `cd` into it, for example:+ ```sh+ $ mkdir /tmp/build+ $ cd /tmp/build+ ```++ 3. Execute the following to configure the build. Here `INSTALL_PREFIX` is+ where LLVM is to be installed, for example `/usr/local` or+ `$HOME/opt/llvm`:+ ```sh+ $ cmake $LLVM_SRC -DCMAKE_INSTALL_PREFIX=$INSTALL_PREFIX -DCMAKE_BUILD_TYPE=Release -DLLVM_ENABLE_ASSERTIONS=ON -DLLVM_BUILD_LLVM_DYLIB=ON -DLLVM_LINK_LLVM_DYLIB=ON+ ```+ See [options and variables](http://llvm.org/docs/CMake.html#options-and-variables)+ for a list of additional build parameters you can specify.++ 4. Build and install:+ ```sh+ $ cmake --build .+ $ cmake --build . --target install+ ```++ 5. For macOS only, some additional steps are useful to work around issues related+ to [System Integrity Protection](https://en.wikipedia.org/wiki/System_Integrity_Protection):+ ```sh+ cd $INSTALL_PREFIX/lib+ ln -s libLLVM.dylib libLLVM-4.0.dylib+ install_name_tool -id $PWD/libLTO.dylib libLTO.dylib+ install_name_tool -id $PWD/libLLVM.dylib libLLVM.dylib+ install_name_tool -change '@rpath/libLLVM.dylib' $PWD/libLLVM.dylib libLTO.dylib+ ```+++Installing Accelerate-LLVM+--------------------------++Once the dependencies are installed, we are ready to install `accelerate-llvm`.++For example, installation using [`stack`](http://docs.haskellstack.org/en/stable/README.html)+just requires you to point it to the appropriate configuration file:+```sh+$ ln -s stack-8.0.yaml stack.yaml+$ stack setup+$ stack install+```++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.+++## libNVVM++The `accelerate-llvm-ptx` backend can optionally be compiled to generate GPU+code using the `libNVVM` library, rather than LLVM's inbuilt NVPTX code+generator. `libNVVM` is a closed-source library distributed as part of the+NVIDIA CUDA toolkit, and is what the `nvcc` compiler itself uses internally when+compiling CUDA C code.++Using `libNVVM` _may_ improve GPU performance compared to the code generator+built in to LLVM. One difficulty with using it however is that since `libNVVM`+is also based on LLVM, and typically lags LLVM by several releases, you must+install `accelerate-llvm` with a "compatible" version of LLVM, which will depend+on the version of the CUDA toolkit you have installed. The following table shows+some combinations:++| | 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** | | | ⭕ | ⭕ | ❌ | ❌ |++Where ⭕ = Works, and ❌ = Does not work.++Note that the above restrictions on CUDA and LLVM version exist _only_ if you+want to use the NVVM component. Otherwise, you should be free to use any+combination of CUDA and LLVM.++Also note that `accelerate-llvm-ptx` itself currently requires at least LLVM-3.5.++Using `stack`, either edit the `stack.yaml` and add the following section:++```yaml+flags:+ accelerate-llvm-ptx:+ nvvm: true+```++Or install using the following option on the command line:++```sh+$ stack install accelerate-llvm-ptx --flag accelerate-llvm-ptx:nvvm+```++If installing via `cabal`:++```sh+$ cabal install accelerate-llvm-ptx -fnvvm+```+
accelerate-llvm-native.cabal view
@@ -1,15 +1,67 @@ name: accelerate-llvm-native-version: 1.0.0.0+version: 1.1.0.0 cabal-version: >= 1.10-tested-with: GHC == 7.8.*+tested-with: GHC >= 7.10 build-type: Simple -synopsis: Accelerate backend generating LLVM+synopsis: Accelerate backend for multicore CPUs description: This library implements a backend for the /Accelerate/ language which generates LLVM-IR targeting multicore CPUs. For further information, refer- to the main /Accelerate/ package:- <http://hackage.haskell.org/package/accelerate>+ to the main <http://hackage.haskell.org/package/accelerate accelerate>+ package.+ .+ [/Dependencies/]+ .+ Haskell dependencies are available from Hackage. The following external+ libraries are alse required:+ .+ * <http://llvm.org LLVM>+ .+ * <http://sourceware.org/libffi/ libFFI>+ .+ [/Installing LLVM/]+ .+ /Homebrew/+ .+ Example using Homebrew on macOS:+ .+ > brew install llvm-hs/homebrew-llvm/llvm-5.0+ .+ /Debian & Ubuntu/+ .+ For Debian/Ubuntu based Linux distributions, the LLVM.org website provides+ binary distribution packages. Check <http://apt.llvm.org apt.llvm.org> for+ instructions for adding the correct package database for your OS version,+ and then:+ .+ > apt-get install llvm-5.0-dev+ .+ /Building from source/+ .+ If your OS does not have an appropriate LLVM distribution available, you can+ also build from source. Detailed build instructions are available on+ <http://releases.llvm.org/5.0.0/docs/CMake.html LLVM.org>. Make sure to+ include the cmake build options+ @-DLLVM_BUILD_LLVM_DYLIB=ON -DLLVM_LINK_LLVM_DYLIB=ON@ so that the @libLLVM@+ shared library will be built.+ .+ [/Installing accelerate-llvm/]+ .+ To use @accelerate-llvm@ it is important that the @llvm-hs@ package is+ installed against the @libLLVM@ shared library, rather than statically+ linked, so that we can use LLVM from GHCi and Template Haskell. This is the+ default configuration, but you can also enforce this explicitly by adding+ the following to your @stack.yaml@ file:+ .+ > flags:+ > llvm-hs:+ > shared-llvm: true+ .+ Or by specifying the @shared-llvm@ flag to cabal:+ .+ > cabal install llvm-hs -fshared-llvm+ . license: BSD3 license-file: LICENSE@@ -18,12 +70,16 @@ bug-reports: https://github.com/AccelerateHS/accelerate/issues category: Compilers/Interpreters, Concurrency, Data, Parallelism +extra-source-files:+ CHANGELOG.md+ README.md + -- Configuration flags -- ------------------- Flag debug- Default: True+ 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@@ -34,11 +90,11 @@ Description: Enable bounds checking Flag unsafe-checks- Default: True+ Default: False Description: Enable bounds checking in unsafe operations Flag internal-checks- Default: True+ Default: False Description: Enable internal consistency checks @@ -48,7 +104,9 @@ Library exposed-modules: Data.Array.Accelerate.LLVM.Native+ Data.Array.Accelerate.LLVM.Native.Plugin Data.Array.Accelerate.LLVM.Native.Foreign+ Data.Array.Accelerate.LLVM.Native.Distribution.Simple other-modules: Data.Array.Accelerate.LLVM.Native.Array.Data@@ -57,11 +115,6 @@ Data.Array.Accelerate.LLVM.Native.State Data.Array.Accelerate.LLVM.Native.Target - Data.Array.Accelerate.LLVM.Native.Compile- Data.Array.Accelerate.LLVM.Native.Compile.Module- Data.Array.Accelerate.LLVM.Native.Compile.Link- Data.Array.Accelerate.LLVM.Native.Compile.Optimise- Data.Array.Accelerate.LLVM.Native.CodeGen Data.Array.Accelerate.LLVM.Native.CodeGen.Base Data.Array.Accelerate.LLVM.Native.CodeGen.Fold@@ -72,23 +125,48 @@ Data.Array.Accelerate.LLVM.Native.CodeGen.Permute Data.Array.Accelerate.LLVM.Native.CodeGen.Scan + Data.Array.Accelerate.LLVM.Native.Compile+ Data.Array.Accelerate.LLVM.Native.Compile.Cache+ Data.Array.Accelerate.LLVM.Native.Compile.Optimise++ Data.Array.Accelerate.LLVM.Native.Link+ Data.Array.Accelerate.LLVM.Native.Link.Cache+ Data.Array.Accelerate.LLVM.Native.Link.Object++ Data.Array.Accelerate.LLVM.Native.Embed+ Data.Array.Accelerate.LLVM.Native.Execute.Async Data.Array.Accelerate.LLVM.Native.Execute.Environment Data.Array.Accelerate.LLVM.Native.Execute.LBS Data.Array.Accelerate.LLVM.Native.Execute.Marshal + Data.Array.Accelerate.LLVM.Native.Plugin.Annotation+ Data.Array.Accelerate.LLVM.Native.Plugin.BuildInfo++ Data.Array.Accelerate.LLVM.Native.Distribution.Simple.Build+ Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC+ Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC.Internal++ Paths_accelerate_llvm_native+ build-depends:- base >= 4.7 && < 4.10- , accelerate == 1.0.*- , accelerate-llvm == 1.0.*+ base >= 4.7 && < 4.11+ , accelerate == 1.1.*+ , accelerate-llvm == 1.1.*+ , 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 , libffi >= 0.1- , llvm-hs >= 3.9- , llvm-hs-pure >= 3.9+ , llvm-hs >= 4.1 && < 5.1+ , llvm-hs-pure >= 4.1 && < 5.1 , mtl >= 2.2.1+ , template-haskell , time >= 1.4 default-language:@@ -111,14 +189,49 @@ if flag(internal-checks) cpp-options: -DACCELERATE_INTERNAL_CHECKS + if os(darwin)+ other-modules:+ Data.Array.Accelerate.LLVM.Native.Link.MachO + build-depends:+ bytestring >= 0.10+ , cereal >= 0.4+ , ghc-prim+ , unix >= 2.7+ , vector >= 0.11++ build-tools:+ c2hs >= 0.25++ if os(linux)+ other-modules:+ Data.Array.Accelerate.LLVM.Native.Link.ELF++ build-depends:+ bytestring >= 0.10+ , cereal >= 0.4+ , ghc-prim+ , unix >= 2.7+ , vector >= 0.11++ build-tools:+ c2hs >= 0.25++ if os(windows)+ other-modules:+ Data.Array.Accelerate.LLVM.Native.Link.COFF++ build-depends:+ bytestring >= 0.10++ source-repository head type: git location: https://github.com/AccelerateHS/accelerate-llvm.git source-repository this type: git- tag: 1.0.0.0+ tag: 1.1.0.0 location: https://github.com/AccelerateHS/accelerate-llvm.git -- vim: nospell