diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 + diff --git a/Data/Array/Accelerate/LLVM/Native.hs b/Data/Array/Accelerate/LLVM/Native.hs --- a/Data/Array/Accelerate/LLVM/Native.hs +++ b/Data/Array/Accelerate/LLVM/Native.hs @@ -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 +-- project for an example. +-- +-- [/Note:/] +-- +-- Due to , this +-- currently must be as an /untyped/ splice. +-- +-- The correct type of this function is similar to that of 'runN': +-- +-- > runQ :: Afunction f => f -> Q (TExp (AfunctionR f)) +-- +-- @since 1.1.0.0 +-- +runQ :: Afunction f => f -> TH.ExpQ +runQ = runQ' [| unsafePerformIO |] [| defaultTarget |] + +-- | Ahead-of-time analogue of 'runNWith'. See 'runQ' for more information. +-- +-- The correct type of this function is: +-- +-- > runQWith :: Afunction f => f -> Q (TExp (Native -> AfunctionR f)) +-- +-- @since 1.1.0.0 +-- +runQWith :: Afunction f => f -> TH.ExpQ +runQWith f = do + target <- TH.newName "target" + TH.lamE [TH.varP target] (runQ' [| unsafePerformIO |] (TH.varE target) f) + + +-- | Ahead-of-time analogue of 'runNAsync'. See 'runQ' for more information. +-- +-- The correct type of this function is: +-- +-- > runQAsync :: (Afunction f, RunAsync r, AfunctionR f ~ RunAsyncR r) => f -> Q (TExp r) +-- +-- @since 1.1.0.0 +-- +runQAsync :: Afunction f => f -> TH.ExpQ +runQAsync = runQ' [| async |] [| defaultTarget |] + +-- | Ahead-of-time analogue of 'runNAsyncWith'. See 'runQ' for more information. +-- +-- The correct type of this function is: +-- +-- > runQAsyncWith :: (Afunction f, RunAsync r, AfunctionR f ~ RunAsyncR r) => f -> Q (TExp (Native -> r)) +-- +-- @since 1.1.0.0 +-- +runQAsyncWith :: Afunction f => f -> TH.ExpQ +runQAsyncWith f = do + target <- TH.newName "target" + TH.lamE [TH.varP target] (runQ' [| async |] (TH.varE target) f) + + +runQ' :: Afunction f => TH.ExpQ -> TH.ExpQ -> f -> TH.ExpQ +runQ' using target f = do + -- Reification of the program for segmented folds depends on whether we are + -- executing in parallel or sequentially, where the parallel case requires + -- some extra work to convert the segments descriptor into a segment offset + -- array. Also do this conversion, so that the program can be run both in + -- parallel as well as sequentially (albeit with some additional work that + -- could have been avoided). + -- + -- TLM: We could also just reify the program twice and select at runtime which + -- version to execute. + -- + afun <- let acc = convertAfunWith (phases { convertOffsetOfSegment = True }) f + in TH.runIO $ do + dumpGraph acc + evalNative (defaultTarget { segmentOffset = True }) $ + phase "compile" elapsedS (compileAfun acc) >>= dumpStats + + -- generate a lambda function with the correct number of arguments and apply + -- directly to the body expression. + let + go :: Typeable aenv => CompiledOpenAfun Native aenv t -> [TH.PatQ] -> [TH.ExpQ] -> [TH.StmtQ] -> TH.ExpQ + go (Alam lam) xs as stmts = do + x <- TH.newName "x" -- lambda bound variable + a <- TH.newName "a" -- local array name + s <- TH.bindS (TH.conP 'AsyncR [TH.wildP, TH.varP a]) [| E.async (useRemoteAsync $(TH.varE x)) |] + go lam (TH.varP x : xs) (TH.varE a : as) (return s : stmts) + + go (Abody body) xs as stmts = + let aenv = foldr (\a gamma -> [| $gamma `Apush` $a |] ) [| Aempty |] as + eval = TH.noBindS [| E.get =<< E.async (executeOpenAcc $(TH.unTypeQ (embedOpenAcc (defaultTarget { segmentOffset = True }) body)) $aenv) |] + in + TH.lamE (reverse xs) [| $using . phase "execute" elapsedP . evalNative ($target { segmentOffset = True }) $ + $(TH.doE (reverse (eval : stmts))) |] + -- + go afun [] [] [] + + -- How the Accelerate program should be evaluated. -- -- TODO: make sharing/fusion runtime configurable via debug flags or otherwise. -- config :: Native -> Phase config target = phases - { convertOffsetOfSegment = gangSize target > 1 + { convertOffsetOfSegment = segmentOffset target } diff --git a/Data/Array/Accelerate/LLVM/Native/CodeGen/Base.hs b/Data/Array/Accelerate/LLVM/Native/CodeGen/Base.hs --- a/Data/Array/Accelerate/LLVM/Native/CodeGen/Base.hs +++ b/Data/Array/Accelerate/LLVM/Native/CodeGen/Base.hs @@ -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 diff --git a/Data/Array/Accelerate/LLVM/Native/CodeGen/Fold.hs b/Data/Array/Accelerate/LLVM/Native/CodeGen/Fold.hs --- a/Data/Array/Accelerate/LLVM/Native/CodeGen/Fold.hs +++ b/Data/Array/Accelerate/LLVM/Native/CodeGen/Fold.hs @@ -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 -- --------------- diff --git a/Data/Array/Accelerate/LLVM/Native/CodeGen/FoldSeg.hs b/Data/Array/Accelerate/LLVM/Native/CodeGen/FoldSeg.hs --- a/Data/Array/Accelerate/LLVM/Native/CodeGen/FoldSeg.hs +++ b/Data/Array/Accelerate/LLVM/Native/CodeGen/FoldSeg.hs @@ -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 diff --git a/Data/Array/Accelerate/LLVM/Native/CodeGen/Generate.hs b/Data/Array/Accelerate/LLVM/Native/CodeGen/Generate.hs --- a/Data/Array/Accelerate/LLVM/Native/CodeGen/Generate.hs +++ b/Data/Array/Accelerate/LLVM/Native/CodeGen/Generate.hs @@ -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 diff --git a/Data/Array/Accelerate/LLVM/Native/CodeGen/Map.hs b/Data/Array/Accelerate/LLVM/Native/CodeGen/Map.hs --- a/Data/Array/Accelerate/LLVM/Native/CodeGen/Map.hs +++ b/Data/Array/Accelerate/LLVM/Native/CodeGen/Map.hs @@ -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 diff --git a/Data/Array/Accelerate/LLVM/Native/CodeGen/Permute.hs b/Data/Array/Accelerate/LLVM/Native/CodeGen/Permute.hs --- a/Data/Array/Accelerate/LLVM/Native/CodeGen/Permute.hs +++ b/Data/Array/Accelerate/LLVM/Native/CodeGen/Permute.hs @@ -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 diff --git a/Data/Array/Accelerate/LLVM/Native/CodeGen/Scan.hs b/Data/Array/Accelerate/LLVM/Native/CodeGen/Scan.hs --- a/Data/Array/Accelerate/LLVM/Native/CodeGen/Scan.hs +++ b/Data/Array/Accelerate/LLVM/Native/CodeGen/Scan.hs @@ -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 diff --git a/Data/Array/Accelerate/LLVM/Native/Compile.hs b/Data/Array/Accelerate/LLVM/Native/Compile.hs --- a/Data/Array/Accelerate/LLVM/Native/Compile.hs +++ b/Data/Array/Accelerate/LLVM/Native/Compile.hs @@ -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 diff --git a/Data/Array/Accelerate/LLVM/Native/Compile/Cache.hs b/Data/Array/Accelerate/LLVM/Native/Compile/Cache.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Compile/Cache.hs @@ -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 +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Compile.Cache ( + + module Data.Array.Accelerate.LLVM.Compile.Cache + +) where + +import Data.Array.Accelerate.LLVM.Compile.Cache +import Data.Array.Accelerate.LLVM.Native.Target + +import Data.Version +import System.FilePath +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Short.Char8 as S8 + +import Paths_accelerate_llvm_native + + +instance Persistent Native where + targetCacheTemplate = + return $ "accelerate-llvm-native-" ++ showVersion version + S8.unpack nativeTargetTriple + B8.unpack nativeCPUName + "meep.o" + diff --git a/Data/Array/Accelerate/LLVM/Native/Compile/Link.hs b/Data/Array/Accelerate/LLVM/Native/Compile/Link.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/Compile/Link.hs +++ /dev/null @@ -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 --- 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 - ] - diff --git a/Data/Array/Accelerate/LLVM/Native/Compile/Module.hs b/Data/Array/Accelerate/LLVM/Native/Compile/Module.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/Native/Compile/Module.hs +++ /dev/null @@ -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 --- 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) - diff --git a/Data/Array/Accelerate/LLVM/Native/Distribution/Simple.hs b/Data/Array/Accelerate/LLVM/Native/Distribution/Simple.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Distribution/Simple.hs @@ -0,0 +1,65 @@ +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Distribution.Simple +-- Copyright : [2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Distribution.Simple ( + + defaultMain, + simpleUserHooks, + module Distribution.Simple, + +) where + +import Data.Array.Accelerate.LLVM.Native.Distribution.Simple.Build + +import Distribution.PackageDescription ( PackageDescription ) +import Distribution.Simple.Setup ( BuildFlags ) +import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo ) +import Distribution.Simple.PreProcess ( PPSuffixHandler, knownSuffixHandlers ) +import Distribution.Simple hiding ( defaultMain, simpleUserHooks ) +import qualified Distribution.Simple as Cabal + +import Data.List ( unionBy ) + + +-- | A simple implementation of @main@ for a Cabal setup script. This is the +-- same as 'Distribution.Simple.defaultMain', with added support for building +-- libraries utilising 'Data.Array.Accelerate.LLVM.Native.runQ'*. +-- +defaultMain :: IO () +defaultMain = Cabal.defaultMainWithHooks simpleUserHooks + + +-- | Hooks that correspond to a plain instantiation of the \"simple\" build +-- system. +-- +simpleUserHooks :: UserHooks +simpleUserHooks = + Cabal.simpleUserHooks + { buildHook = accelerateBuildHook + } + +accelerateBuildHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> BuildFlags + -> IO () +accelerateBuildHook pkg_descr localbuildinfo hooks flags = + build pkg_descr localbuildinfo flags (allSuffixHandlers hooks) + +-- | Combine the preprocessors in the given hooks with the +-- preprocessors built into cabal. +allSuffixHandlers :: UserHooks -> [PPSuffixHandler] +allSuffixHandlers hooks + = overridesPP (hookedPreProcessors hooks) knownSuffixHandlers + where + overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler] + overridesPP = unionBy (\x y -> fst x == fst y) + diff --git a/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/Build.hs b/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/Build.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/Build.hs @@ -0,0 +1,451 @@ +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Distribution.Simple.Build +-- Copyright : [2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Copied from: https://github.com/haskell/cabal/blob/2.0/Cabal/Distribution/Simple/Build.hs +-- + +module Data.Array.Accelerate.LLVM.Native.Distribution.Simple.Build ( + + build, + +) where + +import qualified Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC as Acc + +import qualified Distribution.Simple.Build as Cabal + +import Distribution.Types.Dependency +import Distribution.Types.LocalBuildInfo +import Distribution.Types.TargetInfo +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.ForeignLib +import Distribution.Types.MungedPackageId +import Distribution.Types.MungedPackageName +import Distribution.Types.UnqualComponentName +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.ExecutableScope + +import Distribution.Package +import Distribution.Backpack +import Distribution.Backpack.DescribeUnitId +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHCJS as GHCJS +import qualified Distribution.Simple.JHC as JHC +import qualified Distribution.Simple.LHC as LHC +import qualified Distribution.Simple.UHC as UHC +import qualified Distribution.Simple.HaskellSuite as HaskellSuite +import qualified Distribution.Simple.PackageIndex as Index + +import qualified Distribution.Simple.Program.HcPkg as HcPkg + +import Distribution.Simple.Compiler hiding (Flag) +import Distribution.PackageDescription hiding (Flag) +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.InstalledPackageInfo (InstalledPackageInfo) + +import Distribution.Simple.Setup +import Distribution.Simple.BuildTarget +import Distribution.Simple.BuildToolDepends +import Distribution.Simple.PreProcess +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Program.Types +import Distribution.Simple.Program.Db +import Distribution.Simple.BuildPaths +import Distribution.Simple.Configure +import Distribution.Simple.Register +import Distribution.Simple.Test.LibV09 +import Distribution.Simple.Utils + +import Distribution.Text +import Distribution.Verbosity + +import Distribution.Compat.Graph (IsNode(..)) + +import Control.Monad +import qualified Data.Set as Set +import System.FilePath ( (), (<.>) ) +import System.Directory ( getCurrentDirectory ) + + +build :: PackageDescription -- ^ Mostly information from the .cabal file + -> LocalBuildInfo -- ^ Configuration information + -> BuildFlags -- ^ Flags that the user passed to build + -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling + -> IO () +build pkg_descr lbi flags suffixes = do + targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs flags) + let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) + info verbosity $ "Component build order: " + ++ intercalate ", " + (map (showComponentName . componentLocalName . targetCLBI) + componentsToBuild) + + when (null targets) $ + -- Only bother with this message if we're building the whole package + setupMessage verbosity "Building" (packageId pkg_descr) + + internalPackageDB <- createInternalPackageDB verbosity lbi distPref + + (\f -> foldM_ f (installedPkgs lbi) componentsToBuild) $ \index target -> do + let comp = targetComponent target + clbi = targetCLBI target + Cabal.componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity + let bi = componentBuildInfo comp + progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi) + lbi' = lbi { + withPrograms = progs', + withPackageDB = withPackageDB lbi ++ [internalPackageDB], + installedPkgs = index + } + mb_ipi <- buildComponent verbosity (buildNumJobs flags) pkg_descr + lbi' suffixes comp clbi distPref + return (maybe index (Index.insert `flip` index) mb_ipi) + return () + where + distPref = fromFlag (buildDistPref flags) + verbosity = fromFlag (buildVerbosity flags) + + +buildComponent :: Verbosity + -> Flag (Maybe Int) + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> Component + -> ComponentLocalBuildInfo + -> FilePath + -> IO (Maybe InstalledPackageInfo) +buildComponent verbosity numJobs pkg_descr lbi suffixes + comp@(CLib lib) clbi distPref = do + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + extras <- preprocessExtras verbosity comp lbi + setupMessage' verbosity "Building" (packageId pkg_descr) + (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) + let libbi = libBuildInfo lib + lib' = lib { libBuildInfo = addExtraCSources libbi extras } + buildLib verbosity numJobs pkg_descr lbi lib' clbi + + let oneComponentRequested (OneComponentRequestedSpec _) = True + oneComponentRequested _ = False + -- Don't register inplace if we're only building a single component; + -- it's not necessary because there won't be any subsequent builds + -- that need to tag us + if (not (oneComponentRequested (componentEnabledSpec lbi))) + then do + -- Register the library in-place, so exes can depend + -- on internally defined libraries. + pwd <- getCurrentDirectory + let -- The in place registration uses the "-inplace" suffix, not an ABI hash + installedPkgInfo = inplaceInstalledPackageInfo pwd distPref pkg_descr + -- NB: Use a fake ABI hash to avoid + -- needing to recompute it every build. + (mkAbiHash "inplace") lib' lbi clbi + + debug verbosity $ "Registering inplace:\n" ++ (IPI.showInstalledPackageInfo installedPkgInfo) + registerPackage verbosity (compiler lbi) (withPrograms lbi) + (withPackageDB lbi) installedPkgInfo + HcPkg.defaultRegisterOptions { + HcPkg.registerMultiInstance = True + } + return (Just installedPkgInfo) + else return Nothing + +buildComponent verbosity numJobs pkg_descr lbi suffixes + comp@(CFLib flib) clbi _distPref = do + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + setupMessage' verbosity "Building" (packageId pkg_descr) + (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) + buildFLib verbosity numJobs pkg_descr lbi flib clbi + return Nothing + +buildComponent verbosity numJobs pkg_descr lbi suffixes + comp@(CExe exe) clbi _ = do + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + extras <- preprocessExtras verbosity comp lbi + setupMessage' verbosity "Building" (packageId pkg_descr) + (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) + let ebi = buildInfo exe + exe' = exe { buildInfo = addExtraCSources ebi extras } + buildExe verbosity numJobs pkg_descr lbi exe' clbi + return Nothing + + +buildComponent verbosity numJobs pkg_descr lbi suffixes + comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} }) + clbi _distPref = do + let exe = testSuiteExeV10AsExe test + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + extras <- preprocessExtras verbosity comp lbi + setupMessage' verbosity "Building" (packageId pkg_descr) + (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) + let ebi = buildInfo exe + exe' = exe { buildInfo = addExtraCSources ebi extras } + buildExe verbosity numJobs pkg_descr lbi exe' clbi + return Nothing + + +buildComponent verbosity numJobs pkg_descr lbi0 suffixes + comp@(CTest + test@TestSuite { testInterface = TestSuiteLibV09{} }) + clbi -- This ComponentLocalBuildInfo corresponds to a detailed + -- test suite and not a real component. It should not + -- be used, except to construct the CLBIs for the + -- library and stub executable that will actually be + -- built. + distPref = do + pwd <- getCurrentDirectory + let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) = + testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + extras <- preprocessExtras verbosity comp lbi + setupMessage' verbosity "Building" (packageId pkg_descr) + (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) + buildLib verbosity numJobs pkg lbi lib libClbi + -- NB: need to enable multiple instances here, because on 7.10+ + -- the package name is the same as the library, and we still + -- want the registration to go through. + registerPackage verbosity (compiler lbi) (withPrograms lbi) + (withPackageDB lbi) ipi + HcPkg.defaultRegisterOptions { + HcPkg.registerMultiInstance = True + } + let ebi = buildInfo exe + exe' = exe { buildInfo = addExtraCSources ebi extras } + buildExe verbosity numJobs pkg_descr lbi exe' exeClbi + return Nothing -- Can't depend on test suite + + +buildComponent verbosity _ _ _ _ + (CTest TestSuite { testInterface = TestSuiteUnsupported tt }) + _ _ = + die' verbosity $ "No support for building test suite type " ++ display tt + + +buildComponent verbosity numJobs pkg_descr lbi suffixes + comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} }) + clbi _ = do + let (exe, exeClbi) = benchmarkExeV10asExe bm clbi + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + extras <- preprocessExtras verbosity comp lbi + setupMessage' verbosity "Building" (packageId pkg_descr) + (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) + let ebi = buildInfo exe + exe' = exe { buildInfo = addExtraCSources ebi extras } + buildExe verbosity numJobs pkg_descr lbi exe' exeClbi + return Nothing + + +buildComponent verbosity _ _ _ _ + (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt }) + _ _ = + die' verbosity $ "No support for building benchmark type " ++ display tt + + + +-- | Add extra C sources generated by preprocessing to build +-- information. +addExtraCSources :: BuildInfo -> [FilePath] -> BuildInfo +addExtraCSources bi extras = bi { cSources = new } + where new = Set.toList $ old `Set.union` exs + old = Set.fromList $ cSources bi + exs = Set.fromList extras + + +-- | Translate a exe-style 'TestSuite' component into an exe for building +testSuiteExeV10AsExe :: TestSuite -> Executable +testSuiteExeV10AsExe test@TestSuite { testInterface = TestSuiteExeV10 _ mainFile } = + Executable { + exeName = testName test, + modulePath = mainFile, + exeScope = ExecutablePublic, + buildInfo = testBuildInfo test + } +testSuiteExeV10AsExe TestSuite{} = error "testSuiteExeV10AsExe: wrong kind" + + +-- | Translate a lib-style 'TestSuite' component into a lib + exe for building +testSuiteLibV09AsLibAndExe :: PackageDescription + -> TestSuite + -> ComponentLocalBuildInfo + -> LocalBuildInfo + -> FilePath + -> FilePath + -> (PackageDescription, + Library, ComponentLocalBuildInfo, + LocalBuildInfo, + IPI.InstalledPackageInfo, + Executable, ComponentLocalBuildInfo) +testSuiteLibV09AsLibAndExe pkg_descr + test@TestSuite { testInterface = TestSuiteLibV09 _ m } + clbi lbi distPref pwd = + (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) + where + bi = testBuildInfo test + lib = Library { + libName = Nothing, + exposedModules = [ m ], + reexportedModules = [], + signatures = [], + libExposed = True, + libBuildInfo = bi + } + -- This is, like, the one place where we use a CTestName for a library. + -- Should NOT use library name, since that could conflict! + PackageIdentifier pkg_name pkg_ver = package pkg_descr + compat_name = computeCompatPackageName pkg_name (Just (testName test)) + compat_key = computeCompatPackageKey (compiler lbi) compat_name pkg_ver (componentUnitId clbi) + libClbi = LibComponentLocalBuildInfo + { componentPackageDeps = componentPackageDeps clbi + , componentInternalDeps = componentInternalDeps clbi + , componentIsIndefinite_ = False + , componentExeDeps = componentExeDeps clbi + , componentLocalName = CSubLibName (testName test) + , componentIsPublic = False + , componentIncludes = componentIncludes clbi + , componentUnitId = componentUnitId clbi + , componentComponentId = componentComponentId clbi + , componentInstantiatedWith = [] + , componentCompatPackageName = compat_name + , componentCompatPackageKey = compat_key + , componentExposedModules = [IPI.ExposedModule m Nothing] + } + pkg = pkg_descr { + package = (package pkg_descr) { pkgName = mkPackageName $ unMungedPackageName compat_name } + , buildDepends = targetBuildDepends $ testBuildInfo test + , executables = [] + , testSuites = [] + , subLibraries = [lib] + } + ipi = inplaceInstalledPackageInfo pwd distPref pkg (mkAbiHash "") lib lbi libClbi + testDir = buildDir lbi stubName test + stubName test ++ "-tmp" + testLibDep = thisPackageVersion $ package pkg + exe = Executable { + exeName = mkUnqualComponentName $ stubName test, + modulePath = stubFilePath test, + exeScope = ExecutablePublic, + buildInfo = (testBuildInfo test) { + hsSourceDirs = [ testDir ], + targetBuildDepends = testLibDep + : (targetBuildDepends $ testBuildInfo test) + } + } + -- | The stub executable needs a new 'ComponentLocalBuildInfo' + -- that exposes the relevant test suite library. + deps = (IPI.installedUnitId ipi, mungedId ipi) + : (filter (\(_, x) -> let name = unMungedPackageName $ mungedName x + in name == "Cabal" || name == "base") + (componentPackageDeps clbi)) + exeClbi = ExeComponentLocalBuildInfo { + -- TODO: this is a hack, but as long as this is unique + -- (doesn't clobber something) we won't run into trouble + componentUnitId = mkUnitId (stubName test), + componentComponentId = mkComponentId (stubName test), + componentInternalDeps = [componentUnitId clbi], + componentExeDeps = [], + componentLocalName = CExeName $ mkUnqualComponentName $ stubName test, + componentPackageDeps = deps, + -- Assert DefUnitId invariant! + -- Executable can't be indefinite, so dependencies must + -- be definite packages. + componentIncludes = zip (map (DefiniteUnitId . unsafeMkDefUnitId . fst) deps) + (repeat defaultRenaming) + } +testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind" + + +-- | Translate a exe-style 'Benchmark' component into an exe for building +benchmarkExeV10asExe :: Benchmark -> ComponentLocalBuildInfo + -> (Executable, ComponentLocalBuildInfo) +benchmarkExeV10asExe bm@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f } + clbi = + (exe, exeClbi) + where + exe = Executable { + exeName = benchmarkName bm, + modulePath = f, + exeScope = ExecutablePublic, + buildInfo = benchmarkBuildInfo bm + } + exeClbi = ExeComponentLocalBuildInfo { + componentUnitId = componentUnitId clbi, + componentComponentId = componentComponentId clbi, + componentLocalName = CExeName (benchmarkName bm), + componentInternalDeps = componentInternalDeps clbi, + componentExeDeps = componentExeDeps clbi, + componentPackageDeps = componentPackageDeps clbi, + componentIncludes = componentIncludes clbi + } +benchmarkExeV10asExe Benchmark{} _ = error "benchmarkExeV10asExe: wrong kind" + + +-- | Initialize a new package db file for libraries defined +-- internally to the package. +createInternalPackageDB :: Verbosity -> LocalBuildInfo -> FilePath + -> IO PackageDB +createInternalPackageDB verbosity lbi distPref = do + existsAlready <- doesPackageDBExist dbPath + when existsAlready $ deletePackageDB dbPath + createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath + return (SpecificPackageDB dbPath) + where + dbPath = internalPackageDBPath lbi distPref + +addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo + -> ProgramDb -> ProgramDb +addInternalBuildTools pkg lbi bi progs = + foldr updateProgram progs internalBuildTools + where + internalBuildTools = + [ simpleConfiguredProgram toolName' (FoundOnSystem toolLocation) + | toolName <- getAllInternalToolDependencies pkg bi + , let toolName' = unUnqualComponentName toolName + , let toolLocation = buildDir lbi toolName' toolName' <.> exeExtension ] + + +-- TODO: build separate libs in separate dirs so that we can build +-- multiple libs, e.g. for 'LibTest' library-style test suites +buildLib :: Verbosity -> Flag (Maybe Int) + -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity numJobs pkg_descr lbi lib clbi = + case compilerFlavor (compiler lbi) of + GHC -> Acc.buildLib verbosity numJobs pkg_descr lbi lib clbi -- XXX only change here + GHCJS -> GHCJS.buildLib verbosity numJobs pkg_descr lbi lib clbi + JHC -> JHC.buildLib verbosity pkg_descr lbi lib clbi + LHC -> LHC.buildLib verbosity pkg_descr lbi lib clbi + UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi + HaskellSuite {} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi + _ -> die' verbosity "Building is not supported with this compiler." + +-- | Build a foreign library +-- +-- NOTE: We assume that we already checked that we can actually build the +-- foreign library in configure. +buildFLib :: Verbosity -> Flag (Maybe Int) + -> PackageDescription -> LocalBuildInfo + -> ForeignLib -> ComponentLocalBuildInfo -> IO () +buildFLib verbosity numJobs pkg_descr lbi flib clbi = + case compilerFlavor (compiler lbi) of + GHC -> GHC.buildFLib verbosity numJobs pkg_descr lbi flib clbi + _ -> die' verbosity "Building is not supported with this compiler." + +buildExe :: Verbosity -> Flag (Maybe Int) + -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe verbosity numJobs pkg_descr lbi exe clbi = + case compilerFlavor (compiler lbi) of + GHC -> GHC.buildExe verbosity numJobs pkg_descr lbi exe clbi + GHCJS -> GHCJS.buildExe verbosity numJobs pkg_descr lbi exe clbi + JHC -> JHC.buildExe verbosity pkg_descr lbi exe clbi + LHC -> LHC.buildExe verbosity pkg_descr lbi exe clbi + UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi + _ -> die' verbosity "Building is not supported with this compiler." + + diff --git a/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC.hs b/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC.hs @@ -0,0 +1,438 @@ +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC +-- Copyright : [2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Copied from: https://github.com/haskell/cabal/blob/2.0/Cabal/Distribution/Simple/GHC.hs +-- + +module Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC ( + + buildLib, + replLib, + +) where + +import qualified Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC.Internal as Internal +import qualified Data.Array.Accelerate.LLVM.Native.Plugin.BuildInfo as Internal + +import qualified Distribution.Simple.GHC as Cabal +import Distribution.PackageDescription as PD +import Distribution.Simple.LocalBuildInfo +import Distribution.Types.ComponentLocalBuildInfo +import qualified Distribution.Simple.Hpc as Hpc +import Distribution.Simple.BuildPaths +import Distribution.Simple.Utils +import qualified Distribution.ModuleName as ModuleName +import Distribution.Simple.Program +import qualified Distribution.Simple.Program.Ar as Ar +import qualified Distribution.Simple.Program.Ld as Ld +import Distribution.Simple.Program.GHC +import Distribution.Simple.Setup +import qualified Distribution.Simple.Setup as Cabal +import Distribution.Simple.Compiler hiding (Flag) +import Distribution.Version +import Distribution.System +import Distribution.Verbosity +import Distribution.Text +import Distribution.Utils.NubList +import Language.Haskell.Extension + +import Control.Monad (when, unless) +import Data.List (nub) +import Data.Maybe (catMaybes) +import System.FilePath ( (), replaceExtension, isRelative ) +import qualified Data.Map as Map + + +-- +-- +buildLib, replLib :: Verbosity -> Cabal.Flag (Maybe Int) + -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib = buildOrReplLib False +replLib = buildOrReplLib True + +buildOrReplLib :: Bool -> Verbosity -> Cabal.Flag (Maybe Int) + -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do + let uid = componentUnitId clbi + libTargetDir = componentBuildDir lbi clbi + whenVanillaLib forceVanilla = + when (forceVanilla || withVanillaLib lbi) + whenProfLib = when (withProfLib lbi) + whenSharedLib forceShared = + when (forceShared || withSharedLib lbi) + whenGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi) + ifReplLib = when forRepl + comp = compiler lbi + ghcVersion = compilerVersion comp + implInfo = Cabal.getImplInfo comp + platform@(Platform _hostArch hostOS) = hostPlatform lbi + has_code = not (componentIsIndefinite clbi) + + (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) + let runGhcProg = runGHC verbosity ghcProg comp platform + + libBi <- hackThreadedFlag verbosity + comp (withProfLib lbi) (libBuildInfo lib) + + let isGhcDynamic = Cabal.isDynamic comp + dynamicTooSupported = supportsDynamicToo comp + doingTH = EnableExtension TemplateHaskell `elem` allExtensions libBi + forceVanillaLib = doingTH && not isGhcDynamic + forceSharedLib = doingTH && isGhcDynamic + -- TH always needs default libs, even when building for profiling + + -- Determine if program coverage should be enabled and if so, what + -- '-hpcdir' should be. + let isCoverageEnabled = libCoverage lbi + -- TODO: Historically HPC files have been put into a directory which + -- has the package name. I'm going to avoid changing this for + -- now, but it would probably be better for this to be the + -- component ID instead... + pkg_name = display (PD.package pkg_descr) + distPref = fromFlag $ configDistPref $ configFlags lbi + hpcdir way + | forRepl = mempty -- HPC is not supported in ghci + | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name + | otherwise = mempty + + createDirectoryIfMissingVerbose verbosity True libTargetDir + -- TODO: do we need to put hs-boot files into place for mutually recursive + -- modules? + let cObjs = map (`replaceExtension` objExtension) (cSources libBi) + baseOpts = Cabal.componentGhcOptions verbosity lbi libBi clbi libTargetDir + vanillaOpts = baseOpts `mappend` mempty { + ghcOptMode = toFlag GhcModeMake, + ghcOptNumJobs = numJobs, + ghcOptInputModules = toNubListR $ allLibModules lib clbi, + ghcOptHPCDir = hpcdir Hpc.Vanilla + } + + profOpts = vanillaOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptProfilingAuto = Internal.profDetailLevelFlag True + (withProfLibDetail lbi), + ghcOptHiSuffix = toFlag "p_hi", + ghcOptObjSuffix = toFlag "p_o", + ghcOptExtra = toNubListR $ hcProfOptions GHC libBi, + ghcOptHPCDir = hpcdir Hpc.Prof + } + + sharedOpts = vanillaOpts `mappend` mempty { + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptFPic = toFlag True, + ghcOptHiSuffix = toFlag "dyn_hi", + ghcOptObjSuffix = toFlag "dyn_o", + ghcOptExtra = toNubListR $ hcSharedOptions GHC libBi, + ghcOptHPCDir = hpcdir Hpc.Dyn + } + linkerOpts = mempty { + ghcOptLinkOptions = toNubListR $ PD.ldOptions libBi, + ghcOptLinkLibs = toNubListR $ extraLibs libBi, + ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, + ghcOptLinkFrameworks = toNubListR $ + PD.frameworks libBi, + ghcOptLinkFrameworkDirs = toNubListR $ + PD.extraFrameworkDirs libBi, + ghcOptInputFiles = toNubListR + [libTargetDir x | x <- cObjs] + } + replOpts = vanillaOpts { + ghcOptExtra = overNubListR + Internal.filterGhciFlags $ + ghcOptExtra vanillaOpts, + ghcOptNumJobs = mempty + } + `mappend` linkerOpts + `mappend` mempty { + ghcOptMode = toFlag GhcModeInteractive, + ghcOptOptimisation = toFlag GhcNoOptimisation + } + + vanillaSharedOpts = vanillaOpts `mappend` mempty { + ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, + ghcOptDynHiSuffix = toFlag "dyn_hi", + ghcOptDynObjSuffix = toFlag "dyn_o", + ghcOptHPCDir = hpcdir Hpc.Dyn + } + + unless (forRepl || null (allLibModules lib clbi)) $ + do let vanilla = whenVanillaLib forceVanillaLib (runGhcProg vanillaOpts) + shared = whenSharedLib forceSharedLib (runGhcProg sharedOpts) + useDynToo = dynamicTooSupported && + (forceVanillaLib || withVanillaLib lbi) && + (forceSharedLib || withSharedLib lbi) && + null (hcSharedOptions GHC libBi) + if not has_code + then vanilla + else + if useDynToo + then do + runGhcProg vanillaSharedOpts + case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of + (Cabal.Flag dynDir, Cabal.Flag vanillaDir) -> + -- When the vanilla and shared library builds are done + -- in one pass, only one set of HPC module interfaces + -- are generated. This set should suffice for both + -- static and dynamically linked executables. We copy + -- the modules interfaces so they are available under + -- both ways. + copyDirectoryRecursive verbosity dynDir vanillaDir + _ -> return () + else if isGhcDynamic + then do shared; vanilla + else do vanilla; shared + when has_code $ whenProfLib (runGhcProg profOpts) + + -- build any C sources + unless (not has_code || null (cSources libBi)) $ do + info verbosity "Building C Sources..." + sequence_ + [ do let baseCcOpts = Cabal.componentCcGhcOptions verbosity + lbi libBi clbi libTargetDir filename + vanillaCcOpts = if isGhcDynamic + -- Dynamic GHC requires C sources to be built + -- with -fPIC for REPL to work. See #2207. + then baseCcOpts { ghcOptFPic = toFlag True } + else baseCcOpts + profCcOpts = vanillaCcOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptObjSuffix = toFlag "p_o" + } + sharedCcOpts = vanillaCcOpts `mappend` mempty { + ghcOptFPic = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptObjSuffix = toFlag "dyn_o" + } + odir = fromFlag (ghcOptObjDir vanillaCcOpts) + createDirectoryIfMissingVerbose verbosity True odir + let runGhcProgIfNeeded ccOpts = do + needsRecomp <- checkNeedsRecompilation filename ccOpts + when needsRecomp $ runGhcProg ccOpts + runGhcProgIfNeeded vanillaCcOpts + unless forRepl $ + whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts) + unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts) + | filename <- cSources libBi] + + -- TODO: problem here is we need the .c files built first, so we can load them + -- with ghci, but .c files can depend on .h files generated by ghc by ffi + -- exports. + + when has_code . ifReplLib $ do + when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules" + ifReplLib (runGhcProg replOpts) + + -- link: + when has_code . unless forRepl $ do + info verbosity "Linking..." + let cProfObjs = map (`replaceExtension` ("p_" ++ objExtension)) + (cSources libBi) + cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) + (cSources libBi) + compiler_id = compilerId (compiler lbi) + vanillaLibFilePath = libTargetDir mkLibName uid + profileLibFilePath = libTargetDir mkProfLibName uid + sharedLibFilePath = libTargetDir mkSharedLibName compiler_id uid + ghciLibFilePath = libTargetDir Internal.mkGHCiLibName uid + libInstallPath = libdir $ absoluteComponentInstallDirs pkg_descr lbi uid NoCopyDest + sharedLibInstallPath = libInstallPath mkSharedLibName compiler_id uid + + stubObjs <- catMaybes <$> sequenceA + [ findFileWithExtension [objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files + , x <- allLibModules lib clbi ] + stubProfObjs <- catMaybes <$> sequenceA + [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files + , x <- allLibModules lib clbi ] + stubSharedObjs <- catMaybes <$> sequenceA + [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files + , x <- allLibModules lib clbi ] + + hObjs <- Internal.getHaskellObjects implInfo lib lbi clbi + libTargetDir objExtension True + hProfObjs <- + if withProfLib lbi + then Internal.getHaskellObjects implInfo lib lbi clbi + libTargetDir ("p_" ++ objExtension) True + else return [] + hSharedObjs <- + if withSharedLib lbi + then Internal.getHaskellObjects implInfo lib lbi clbi + libTargetDir ("dyn_" ++ objExtension) False + else return [] + + -- XXX: This is the only change; determine if there are any + -- accelerate-generated object files which need to linked into the final + -- libraries. + accObjs <- fmap (nub . concat . Map.elems) + $ Internal.readBuildInfo + $ Internal.mkBuildInfoFileName libTargetDir + + unless (null accObjs && null hObjs && null cObjs && null stubObjs) $ do + rpaths <- getRPaths lbi clbi + + let staticObjectFiles = + hObjs + ++ accObjs + ++ map (libTargetDir ) cObjs + ++ stubObjs + profObjectFiles = + hProfObjs + ++ accObjs + ++ map (libTargetDir ) cProfObjs + ++ stubProfObjs + ghciObjFiles = + hObjs + ++ accObjs + ++ map (libTargetDir ) cObjs + ++ stubObjs + dynamicObjectFiles = + hSharedObjs + ++ accObjs + ++ map (libTargetDir ) cSharedObjs + ++ stubSharedObjs + -- After the relocation lib is created we invoke ghc -shared + -- with the dependencies spelled out as -package arguments + -- and ghc invokes the linker with the proper library paths + ghcSharedLinkArgs = + mempty { + ghcOptShared = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptInputFiles = toNubListR dynamicObjectFiles, + ghcOptOutputFile = toFlag sharedLibFilePath, + ghcOptExtra = toNubListR $ + hcSharedOptions GHC libBi, + -- For dynamic libs, Mac OS/X needs to know the install location + -- at build time. This only applies to GHC < 7.8 - see the + -- discussion in #1660. + ghcOptDylibName = if hostOS == OSX + && ghcVersion < mkVersion [7,8] + then toFlag sharedLibInstallPath + else mempty, + ghcOptHideAllPackages = toFlag True, + ghcOptNoAutoLinkPackages = toFlag True, + ghcOptPackageDBs = withPackageDB lbi, + ghcOptThisUnitId = case clbi of + LibComponentLocalBuildInfo { componentCompatPackageKey = pk } + -> toFlag pk + _ -> mempty, + ghcOptThisComponentId = case clbi of + LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> + if null insts + then mempty + else toFlag (componentComponentId clbi) + _ -> mempty, + ghcOptInstantiatedWith = case clbi of + LibComponentLocalBuildInfo { componentInstantiatedWith = insts } + -> insts + _ -> [], + ghcOptPackages = toNubListR $ + Internal.mkGhcOptPackages clbi , + ghcOptLinkLibs = toNubListR $ extraLibs libBi, + ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, + ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, + ghcOptLinkFrameworkDirs = + toNubListR $ PD.extraFrameworkDirs libBi, + ghcOptRPaths = rpaths + } + + info verbosity (show (ghcOptPackages ghcSharedLinkArgs)) + + whenVanillaLib False $ + Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles + + whenProfLib $ + Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles + + whenGHCiLib $ do + (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) + Ld.combineObjectFiles verbosity ldProg + ghciLibFilePath ghciObjFiles + + whenSharedLib False $ + runGhcProg ghcSharedLinkArgs + + +-- | Returns True if the modification date of the given source file is newer than +-- the object file we last compiled for it, or if no object file exists yet. +checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool +checkNeedsRecompilation filename opts = filename `moreRecentFile` oname + where oname = getObjectFileName filename opts + +-- | Finds the object file name of the given source file +getObjectFileName :: FilePath -> GhcOptions -> FilePath +getObjectFileName filename opts = oname + where odir = fromFlag (ghcOptObjDir opts) + oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts) + oname = odir replaceExtension filename oext + +-- | Calculate the RPATHs for the component we are building. +-- +-- Calculates relative RPATHs when 'relocatable' is set. +getRPaths :: LocalBuildInfo + -> ComponentLocalBuildInfo -- ^ Component we are building + -> IO (NubListR FilePath) +getRPaths lbi clbi | supportRPaths hostOS = do + libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi + let hostPref = case hostOS of + OSX -> "@loader_path" + _ -> "$ORIGIN" + relPath p = if isRelative p then hostPref p else p + rpaths = toNubListR (map relPath libraryPaths) + return rpaths + where + (Platform _ hostOS) = hostPlatform lbi + + -- The list of RPath-supported operating systems below reflects the + -- platforms on which Cabal's RPATH handling is tested. It does _NOT_ + -- reflect whether the OS supports RPATH. + + -- E.g. when this comment was written, the *BSD operating systems were + -- untested with regards to Cabal RPATH handling, and were hence set to + -- 'False', while those operating systems themselves do support RPATH. + supportRPaths Linux = True + supportRPaths Windows = False + supportRPaths OSX = True + supportRPaths FreeBSD = False + supportRPaths OpenBSD = False + supportRPaths NetBSD = False + supportRPaths DragonFly = False + supportRPaths Solaris = False + supportRPaths AIX = False + supportRPaths HPUX = False + supportRPaths IRIX = False + supportRPaths HaLVM = False + supportRPaths IOS = False + supportRPaths Android = False + supportRPaths Ghcjs = False + supportRPaths Hurd = False + supportRPaths (OtherOS _) = False + -- Do _not_ add a default case so that we get a warning here when a new OS + -- is added. + +getRPaths _ _ = return mempty + +-- | Filter the "-threaded" flag when profiling as it does not +-- work with ghc-6.8 and older. +hackThreadedFlag :: Verbosity -> Compiler -> Bool -> BuildInfo -> IO BuildInfo +hackThreadedFlag _ _ _ = return + +-- ----------------------------------------------------------------------------- +-- Utils + +supportsDynamicToo :: Compiler -> Bool +supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too" + diff --git a/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC/Internal.hs b/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC/Internal.hs @@ -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 +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Copied from: https://github.com/haskell/cabal/blob/2.0/Cabal/Distribution/Simple/GHC/Internal.hs +-- + +module Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC.Internal ( + + mkGHCiLibName, + ghcLookupProperty, + filterGhciFlags, + getHaskellObjects, + mkGhcOptPackages, + profDetailLevelFlag, + +) where + +#if MIN_VERSION_Cabal(2,0,0) +import Distribution.Backpack +#endif +import Distribution.PackageDescription as PD hiding (Flag) +import Distribution.Simple.Compiler hiding (Flag) +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Program.GHC +import Distribution.Simple.Setup +import Distribution.Simple +import qualified Distribution.ModuleName as ModuleName + +import qualified Data.Map as Map +import System.Directory ( getDirectoryContents ) +import System.FilePath ( (), (<.>), takeExtension ) + + +-- | Strip out flags that are not supported in ghci +filterGhciFlags :: [String] -> [String] +filterGhciFlags = filter supported + where + supported ('-':'O':_) = False + supported "-debug" = False + supported "-threaded" = False + supported "-ticky" = False + supported "-eventlog" = False + supported "-prof" = False + supported "-unreg" = False + supported _ = True + +#if MIN_VERSION_Cabal(1,24,0) +mkGHCiLibName :: UnitId -> String +mkGHCiLibName lib = getHSLibraryName lib <.> "o" +#else +mkGHCiLibName :: LibraryName -> String +mkGHCiLibName (LibraryName lib) = lib <.> "o" +#endif + +ghcLookupProperty :: String -> Compiler -> Bool +ghcLookupProperty prop comp = + case Map.lookup prop (compilerProperties comp) of + Just "YES" -> True + _ -> False + +-- when using -split-objs, we need to search for object files in the +-- Module_split directory for each module. +getHaskellObjects :: _GhcImplInfo -> Library -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> FilePath -> String -> Bool -> IO [FilePath] +getHaskellObjects _implInfo lib lbi clbi pref wanted_obj_ext allow_split_objs + | splitObjs lbi && allow_split_objs = do + let splitSuffix = "_" ++ wanted_obj_ext ++ "_split" + dirs = [ pref (ModuleName.toFilePath x ++ splitSuffix) + | x <- allLibModules lib clbi ] + objss <- traverse getDirectoryContents dirs + let objs = [ dir obj + | (objs',dir) <- zip objss dirs, obj <- objs', + let obj_ext = takeExtension obj, + '.':wanted_obj_ext == obj_ext ] + return objs + | otherwise = + return [ pref ModuleName.toFilePath x <.> wanted_obj_ext + | x <- allLibModules lib clbi ] + +#if MIN_VERSION_Cabal(2,0,0) +mkGhcOptPackages :: ComponentLocalBuildInfo + -> [(OpenUnitId, ModuleRenaming)] +mkGhcOptPackages = componentIncludes +#else +mkGhcOptPackages :: ComponentLocalBuildInfo + -> [(InstalledPackageId, PackageId, ModuleRenaming)] +mkGhcOptPackages clbi = + map (\(i,p) -> (i,p,lookupRenaming p (componentPackageRenaming clbi))) + (componentPackageDeps clbi) +#endif + +profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto +profDetailLevelFlag forLib mpl = + case mpl of + ProfDetailNone -> mempty + ProfDetailDefault | forLib -> toFlag GhcProfAutoExported + | otherwise -> toFlag GhcProfAutoToplevel + ProfDetailExportedFunctions -> toFlag GhcProfAutoExported + ProfDetailToplevelFunctions -> toFlag GhcProfAutoToplevel + ProfDetailAllFunctions -> toFlag GhcProfAutoAll + ProfDetailOther _ -> mempty + +#if !MIN_VERSION_Cabal(2,0,0) +allLibModules :: Library -> ComponentLocalBuildInfo -> [ModuleName.ModuleName] +allLibModules lib _ = libModules lib +#endif + diff --git a/Data/Array/Accelerate/LLVM/Native/Embed.hs b/Data/Array/Accelerate/LLVM/Native/Embed.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Embed.hs @@ -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 +-- 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') + diff --git a/Data/Array/Accelerate/LLVM/Native/Execute.hs b/Data/Array/Accelerate/LLVM/Native/Execute.hs --- a/Data/Array/Accelerate/LLVM/Native/Execute.hs +++ b/Data/Array/Accelerate/LLVM/Native/Execute.hs @@ -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 diff --git a/Data/Array/Accelerate/LLVM/Native/Foreign.hs b/Data/Array/Accelerate/LLVM/Native/Foreign.hs --- a/Data/Array/Accelerate/LLVM/Native/Foreign.hs +++ b/Data/Array/Accelerate/LLVM/Native/Foreign.hs @@ -21,7 +21,7 @@ -- useful re-exports LLVM, - Native, + Native(..), liftIO, module Data.Array.Accelerate.LLVM.Native.Array.Data, diff --git a/Data/Array/Accelerate/LLVM/Native/Link.hs b/Data/Array/Accelerate/LLVM/Native/Link.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Link.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Link +-- Copyright : [2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Link ( + + module Data.Array.Accelerate.LLVM.Link, + module Data.Array.Accelerate.LLVM.Native.Link, + ExecutableR(..), FunctionTable(..), Function, ObjectCode, + +) where + +import Data.Array.Accelerate.Lifetime + +import Data.Array.Accelerate.LLVM.Compile +import Data.Array.Accelerate.LLVM.Link +import Data.Array.Accelerate.LLVM.State + +import Data.Array.Accelerate.LLVM.Native.Target +import Data.Array.Accelerate.LLVM.Native.Compile + +import Data.Array.Accelerate.LLVM.Native.Link.Object +import Data.Array.Accelerate.LLVM.Native.Link.Cache +#if defined(darwin_HOST_OS) +import Data.Array.Accelerate.LLVM.Native.Link.MachO +#elif defined(linux_HOST_OS) +import Data.Array.Accelerate.LLVM.Native.Link.ELF +#elif defined(mingw32_HOST_OS) +import Data.Array.Accelerate.LLVM.Native.Link.COFF +#else +#error "Runtime linking not supported on this platform" +#endif + +import Control.Monad.State +import Prelude hiding ( lookup ) + + +instance Link Native where + data ExecutableR Native = NativeR { nativeExecutable :: {-# UNPACK #-} !(Lifetime FunctionTable) + } + linkForTarget = link + + +-- | Load the generated object file into the target address space +-- +link :: ObjectR Native -> LLVM Native (ExecutableR Native) +link (ObjectR uid _ obj) = do + cache <- gets linkCache + funs <- liftIO $ dlsym uid cache (loadObject obj) + return $! NativeR funs + + +-- | Execute some operation with the supplied executable functions +-- +withExecutable :: ExecutableR Native -> (FunctionTable -> LLVM Native b) -> LLVM Native b +withExecutable NativeR{..} f = do + r <- f (unsafeGetValue nativeExecutable) + liftIO $ touchLifetime nativeExecutable + return r + diff --git a/Data/Array/Accelerate/LLVM/Native/Link/COFF.hs b/Data/Array/Accelerate/LLVM/Native/Link/COFF.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Link/COFF.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Link.COFF +-- Copyright : [2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Link.COFF ( + + loadObject, + +) where + +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.LLVM.Native.Link.Object + +import Data.ByteString ( ByteString ) + + +-- Dynamic object loading +-- ---------------------- + +-- Load a COFF object file and return pointers to the executable functions +-- defined within. The executable sections are aligned appropriately, as +-- specified in the object file, and are ready to be executed on the target +-- architecture. +-- +loadObject :: ByteString -> IO (FunctionTable, ObjectCode) +loadObject _obj = + $internalError "loadObject" "not implemented yet: https://github.com/AccelerateHS/accelerate/issues/395" + diff --git a/Data/Array/Accelerate/LLVM/Native/Link/Cache.hs b/Data/Array/Accelerate/LLVM/Native/Link/Cache.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Link/Cache.hs @@ -0,0 +1,22 @@ +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Link.Cache +-- Copyright : [2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Link.Cache ( + + LinkCache, + LC.new, LC.dlsym, + +) where + +import Data.Array.Accelerate.LLVM.Native.Link.Object +import qualified Data.Array.Accelerate.LLVM.Link.Cache as LC + +type LinkCache = LC.LinkCache FunctionTable ObjectCode + diff --git a/Data/Array/Accelerate/LLVM/Native/Link/ELF.chs b/Data/Array/Accelerate/LLVM/Native/Link/ELF.chs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Link/ELF.chs @@ -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 +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Link.ELF ( + + loadObject, + +) where + +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.LLVM.Native.Link.Object +import Data.Array.Accelerate.Lifetime +import qualified Data.Array.Accelerate.Debug as Debug + +import Control.Applicative +import Control.Monad +import Data.Bits +import Data.ByteString ( ByteString ) +import Data.Char +import Data.Int +import Data.List +import Data.Serialize.Get +import Data.Vector ( Vector ) +import Data.Word +import Foreign.C +import Foreign.ForeignPtr +import Foreign.Marshal +import Foreign.Ptr +import Foreign.Storable +import GHC.ForeignPtr ( mallocPlainForeignPtrAlignedBytes ) +import GHC.Prim ( addr2Int#, int2Word# ) +import GHC.Ptr ( Ptr(..) ) +import GHC.Word ( Word64(..) ) +import System.IO.Unsafe +import System.Posix.DynamicLinker +import Text.Printf +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Short as BS +import qualified Data.ByteString.Unsafe as B +import qualified Data.Vector as V +import Prelude as P + +#include +#include + + +-- Dynamic object loading +-- ---------------------- + +-- Load an ELF object file and return pointers to the executable functions +-- defined within. The executable sections are aligned appropriately, as +-- specified in the object file, and are ready to be executed on the target +-- architecture. +-- +loadObject :: ByteString -> IO (FunctionTable, ObjectCode) +loadObject obj = + case parseObject obj of + Left err -> $internalError "loadObject" err + Right (secs, symbols, relocs, strtab) -> do + -- Load the sections into executable memory + -- + (funtab, oc) <- loadSegment obj strtab secs symbols relocs + + -- The executable pages are allocated on the GC heap. When the pages are + -- finalised, unset the executable bit and mark them as read/write so that + -- they can be reused + -- + objectcode <- newLifetime [oc] + addFinalizer objectcode $ do + Debug.traceIO Debug.dump_gc ("gc: unload module: " ++ show funtab) + case oc of + Segment vmsize oc_fp -> do + withForeignPtr oc_fp $ \oc_p -> do + mprotect oc_p vmsize ({#const PROT_READ#} .|. {#const PROT_WRITE#}) + + return (funtab, objectcode) + + +-- Load the sections into memory. +-- +-- Extra jump islands are added directly after the section data. On x86_64 +-- PC-relative jumps and accesses to the global offset table are limited to +-- 32-bits (+-2GB). If we need to go outside of this range than we must do so +-- via the jump islands. +-- +-- NOTE: This puts all the sections into a single block of memory. Technically +-- this is incorrect because we then have both text and data sections together, +-- meaning that data sections are marked as execute when they really shouldn't +-- be. These would need to live in different pages in order to be mprotect-ed +-- properly. +-- +loadSegment + :: ByteString + -> ByteString + -> Vector SectionHeader + -> Vector Symbol + -> Vector Relocation + -> IO (FunctionTable, Segment) +loadSegment obj strtab secs symtab relocs = do + let + pagesize = fromIntegral c_getpagesize + + -- round up to next multiple of given alignment + pad align n = (n + align - 1) .&. (complement (align - 1)) + + -- determine where each section should be placed in memory, respecting + -- alignment requirements. SectionHeaders which do not correspond to + -- program data (e.g. systab) just carry along the previous offset value. + -- This is to avoid filtering the list of sections, so that section + -- indices (e.g. in relocations) remain valid. + -- + nsecs = V.length secs + offsets = V.constructN (nsecs + 1) $ \v -> + case V.length v of + 0 -> 0 + n -> let this = secs V.! n + prev = secs V.! (n-1) + alloc s = testBit (sh_flags s) 1 -- SHF_ALLOC: section occupies memory at execution? + -- + align | n >= nsecs = 16 + | not (alloc this) = 1 + | otherwise = sh_align this + -- + size | alloc prev = sh_size prev + | otherwise = 0 + in + pad align (size + v V.! (n-1)) + + -- The section at index `i` should place its data beginning at page boundary + -- offset given by offsets!i. + -- + vmsize' = V.last offsets -- bytes required to store all sections + vmsize = pad pagesize (vmsize' + (V.length symtab * 16)) -- sections + jump tables + -- + seg_fp <- mallocPlainForeignPtrAlignedBytes vmsize pagesize + funtab <- withForeignPtr seg_fp $ \seg_p -> do + -- Just in case, clear out the segment data (corresponds to NOP). + -- This also takes care of .bss sections + fillBytes seg_p 0 vmsize + + -- Jump tables are placed directly after the segment data + let jump_p = seg_p `plusPtr` vmsize' + V.imapM_ (makeJumpIsland jump_p) symtab + + -- Copy over section data + V.izipWithM_ (loadSection obj strtab seg_p) offsets secs + + -- Process relocations + V.mapM_ (processRelocation symtab offsets seg_p jump_p) relocs + + -- Mark the page as executable and read-only + mprotect seg_p vmsize ({#const PROT_READ#} .|. {#const PROT_EXEC#}) + + -- Resolve external symbols defined in the sections into function + -- pointers. + -- + -- Note that in order to support ahead-of-time compilation, the + -- generated functions are given unique names by appending with an + -- underscore followed by a 16-digit unique ID. The execution + -- phase doesn't need to know about this however, so un-mangle the + -- name to the basic "map", "fold", etc. + -- + let extern Symbol{..} = sym_binding == Global && sym_type == Func + resolve Symbol{..} = + let name = BS.toShort (B8.take (B8.length sym_name - 17) sym_name) + addr = castPtrToFunPtr (seg_p `plusPtr` (fromIntegral sym_value + offsets V.! sym_section)) + in + (name, addr) + return $ FunctionTable $ V.toList (V.map resolve (V.filter extern symtab)) + -- + return (funtab, Segment vmsize seg_fp) + + +-- Add the jump-table entries directly to each external undefined symbol. +-- +makeJumpIsland :: Ptr Word8 -> Int -> Symbol -> IO () +makeJumpIsland jump_p symbolnum Symbol{..} = do +#ifdef x86_64_HOST_ARCH + when (sym_binding == Global && sym_section == 0) $ do + let + target = jump_p `plusPtr` (symbolnum * 16) :: Ptr Word64 -- addr + instr = target `plusPtr` 8 :: Ptr Word8 -- jumpIsland + -- + poke target sym_value + pokeArray instr [ 0xFF, 0x25, 0xF2, 0xFF, 0xFF, 0xFF ] -- jmp *-14(%rip) +#endif + return () + + +-- Load the section at the correct offset into the given segment +-- +loadSection :: ByteString -> ByteString -> Ptr Word8 -> Int -> Int -> SectionHeader -> IO () +loadSection obj strtab seg_p sec_num sec_addr SectionHeader{..} = + when (sh_type == ProgBits && sh_size > 0) $ do + message (printf "section %d: Mem: 0x%09x-0x%09x %s" sec_num sec_addr (sec_addr+sh_size) (B8.unpack (indexStringTable strtab sh_name))) + let (obj_fp, obj_offset, _) = B.toForeignPtr obj + -- + withForeignPtr obj_fp $ \obj_p -> do + -- Copy this section's data to the appropriate place in the segment + let src = obj_p `plusPtr` (obj_offset + sh_offset) + dst = seg_p `plusPtr` sec_addr + -- + copyBytes dst src sh_size + + +-- Process local and external relocations. +-- +processRelocation :: Vector Symbol -> Vector Int -> Ptr Word8 -> Ptr Word8 -> Relocation -> IO () +#ifdef x86_64_HOST_ARCH +processRelocation symtab sec_offset seg_p jump_p Relocation{..} = do + message (printf "relocation: 0x%04x to symbol %d in section %d, type=%s, value=%s%+d" r_offset r_symbol r_section (show r_type) (B8.unpack sym_name) r_addend) + case r_type of + R_X86_64_None -> return () + R_X86_64_64 -> relocate (fromIntegral symval + r_addend) + R_X86_64_PC32 -> + let offset = fromIntegral symval + r_addend - fromIntegral pc' in + if offset >= 0x7fffffff || offset < -0x80000000 + then do + let jump' = castPtrToWord64 (jump_p `plusPtr` (r_symbol * 16 + 8)) + offset' = fromIntegral jump' + r_addend - fromIntegral pc' + relocate offset' + else + relocate offset + + R_X86_64_PC64 -> + let offset = fromIntegral symval + r_addend - fromIntegral pc' in + relocate offset + + R_X86_64_32 -> + let value = symval + fromIntegral r_addend in + if value >= 0x7fffffff + then do + let jump' = castPtrToWord64 (jump_p `plusPtr` (r_symbol * 16 + 8)) + value' = fromIntegral jump' + r_addend + relocate value' + else + relocate (fromIntegral value) + + R_X86_64_32S -> + let value = fromIntegral symval + r_addend in + if value >= 0x7fffffff || value < -0x80000000 + then do + let jump' = castPtrToWord64 (jump_p `plusPtr` (r_symbol * 16 + 8)) + value' = fromIntegral jump' + r_addend + relocate value' + else + relocate value + + where + pc :: Ptr Word8 + pc = seg_p `plusPtr` (fromIntegral r_offset + sec_offset V.! r_section) + pc' = castPtrToWord64 pc + + symval :: Word64 + symval = + case sym_binding of + Local -> castPtrToWord64 (seg_p `plusPtr` (sec_offset V.! sym_section + fromIntegral sym_value)) + Global -> sym_value + Weak -> $internalError "processRelocation" "unhandled weak symbol" + + Symbol{..} = symtab V.! r_symbol + + relocate :: Int64 -> IO () + relocate x = poke (castPtr pc :: Ptr Word32) (fromIntegral x) + +#else +precessRelocation = + $internalError "processRelocation" "not defined for non-x86_64 architectures yet" +#endif + + +-- Object file parser +-- ------------------ + +-- Parse an ELF object file and return the set of section load commands, as well +-- as the symbols defined within the sections of the object. +-- +-- Actually loading the sections into executable memory happens separately. +-- +parseObject :: ByteString -> Either String (Vector SectionHeader, Vector Symbol, Vector Relocation, ByteString) +parseObject obj = do + (p, tph, tsec, strix) <- runGet readHeader obj + + -- As this is an object file, we do not expect any program headers + unless (tb_entries tph == 0) $ fail "unhandled program header(s)" + + -- Read the object file headers + secs <- runGet (V.replicateM (tb_entries tsec) (readSectionHeader p)) (B.drop (tb_fileoff tsec) obj) + strtab <- readStringTable obj (secs V.! strix) + + let symtab = V.toList . V.filter (\s -> sh_type s == SymTab) + reloc = V.toList . V.filter (\s -> sh_type s == Rel || sh_type s == RelA) + + symbols <- V.concat <$> sequence [ readSymbolTable p secs obj sh | sh <- symtab secs ] + relocs <- V.concat <$> sequence [ readRelocations p obj sh | sh <- reloc secs ] + + return (secs, symbols, relocs, strtab) + + +-- Parsing depends on whether the ELF file is 64-bit and whether it should be +-- read as big- or little-endian. +-- +data Peek = Peek + { is64Bit :: !Bool + , getWord16 :: !(Get Word16) + , getWord32 :: !(Get Word32) + , getWord64 :: !(Get Word64) + } + +data Table = Table + { tb_fileoff :: {-# UNPACK #-} !Int -- byte offset to start of table (array) + , tb_entries :: {-# UNPACK #-} !Int -- number of entries in the table (array) + , tb_entrysize :: {-# UNPACK #-} !Int -- size in bytes per entry + } + +{-- +data ProgramHeader = ProgramHeader + { prog_vmaddr :: {-# UNPACK #-} !Int -- virtual address + , prog_vmsize :: {-# UNPACK #-} !Int -- size in memory + , prog_fileoff :: {-# UNPACK #-} !Int -- file offset + , prog_filesize :: {-# UNPACK #-} !Int -- size in file + , prog_align :: {-# UNPACK #-} !Int -- alignment + , prog_paddr :: {-# UNPACK #-} !Int -- physical address + } +--} + +data SectionHeader = SectionHeader + { sh_name :: {-# UNPACK #-} !Int -- string table index + , sh_addr :: {-# UNPACK #-} !Word64 -- virtual memory address + , sh_size :: {-# UNPACK #-} !Int -- section size in bytes + , sh_offset :: {-# UNPACK #-} !Int -- file offset in bytes + , sh_align :: {-# UNPACK #-} !Int + , sh_link :: {-# UNPACK #-} !Int + , sh_info :: {-# UNPACK #-} !Int -- additional section info + , sh_entsize :: {-# UNPACK #-} !Int -- entry size, if section holds table + , sh_flags :: {-# UNPACK #-} !Word64 + , sh_type :: !SectionType + } + deriving Show + +{#enum define SectionType + { SHT_NULL as NullSection + , SHT_PROGBITS as ProgBits + , SHT_SYMTAB as SymTab + , SHT_STRTAB as StrTab + , SHT_RELA as RelA + , SHT_HASH as Hash + , SHT_DYNAMIC as Dynamic + , SHT_NOTE as Note + , SHT_NOBITS as NoBits + , SHT_REL as Rel + , SHT_DYNSYM as DynSym + } + deriving (Eq, Show) +#} + +data Symbol = Symbol + { sym_name :: {-# UNPACK #-} !ByteString + , sym_value :: {-# UNPACK #-} !Word64 + , sym_section :: {-# UNPACK #-} !Int + , sym_binding :: !SymbolBinding + , sym_type :: !SymbolType + } + deriving Show + +{#enum define SymbolBinding + { STB_LOCAL as Local + , STB_GLOBAL as Global + , STB_WEAK as Weak + } + deriving (Eq, Show) +#} + +{#enum define SymbolType + { STT_NOTYPE as NoType + , STT_OBJECT as Object -- data object + , STT_FUNC as Func -- function object + , STT_SECTION as Section + , STT_FILE as File + , STT_COMMON as Common + , STT_TLS as TLS + } + deriving (Eq, Show) +#} + +data Relocation = Relocation + { r_offset :: {-# UNPACK #-} !Word64 + , r_symbol :: {-# UNPACK #-} !Int + , r_section :: {-# UNPACK #-} !Int + , r_addend :: {-# UNPACK #-} !Int64 + , r_type :: !RelocationType + } + deriving Show + +#ifdef i386_HOST_ARCH +{#enum define RelocationType + { R_386_NONE as R_386_None + , R_386_32 as R_386_32 + , R_386_PC32 as R_386_PC32 + } + deriving (Eq, Show) +#} +#endif +#ifdef x86_64_HOST_ARCH +{#enum define RelocationType + { R_X86_64_NONE as R_X86_64_None -- no relocation + , R_X86_64_64 as R_X86_64_64 -- direct 64-bit + , R_X86_64_PC32 as R_X86_64_PC32 -- PC relative 32-bit signed + , R_X86_64_PC64 as R_X86_64_PC64 -- PC relative 64-bit + , R_X86_64_32 as R_X86_64_32 -- direct 32-bit zero extended + , R_X86_64_32S as R_X86_64_32S -- direct 32-bit sign extended + -- ... many more relocation types + } + deriving (Eq, Show) +#} +#endif + +-- The ELF file header appears at the start of every file. +-- +readHeader :: Get (Peek, Table, Table, Int) +readHeader = do + p@Peek{..} <- readIdent + (_, phs, secs, shstr) <- case is64Bit of + True -> readHeader64 p + False -> readHeader32 p + return (p, phs, secs, shstr) + + +readHeader32 :: Peek -> Get (Int, Table, Table, Int) +readHeader32 _ = fail "TODO: readHeader32" + +readHeader64 :: Peek -> Get (Int, Table, Table, Int) +readHeader64 p@Peek{..} = do + readType p + readMachine p + skip {#sizeof Elf64_Word#} -- e_version + e_entry <- getWord64 -- entry point virtual address (page offset?) + e_phoff <- getWord64 -- program header table file offset + e_shoff <- getWord64 -- section header table file offset + skip ({#sizeof Elf64_Word#}+{#sizeof Elf64_Half#}) -- e_flags + e_ehsize + e_phentsize <- getWord16 -- byte size per program header entry + e_phnum <- getWord16 -- #program header entries + e_shentsize <- getWord16 + e_shnum <- getWord16 + e_shstrndx <- getWord16 + return ( fromIntegral e_entry + , Table { tb_fileoff = fromIntegral e_phoff, tb_entries = fromIntegral e_phnum, tb_entrysize = fromIntegral e_phentsize } + , Table { tb_fileoff = fromIntegral e_shoff, tb_entries = fromIntegral e_shnum, tb_entrysize = fromIntegral e_shentsize } + , fromIntegral e_shstrndx + ) + + +readIdent :: Get Peek +readIdent = do + ei_magic <- getBytes 4 + unless (ei_magic == B8.pack [chr {#const ELFMAG0#}, {#const ELFMAG1#}, {#const ELFMAG2#}, {#const ELFMAG3#}]) $ + fail "invalid magic number" + + ei_class <- getWord8 + is64Bit <- case ei_class of + {#const ELFCLASS32#} -> return False + {#const ELFCLASS64#} -> return True + _ -> fail "invalid class" + ei_data <- getWord8 + p <- case ei_data of + {#const ELFDATA2LSB#} -> return $ Peek { getWord16 = getWord16le, getWord32 = getWord32le, getWord64 = getWord64le, .. } + {#const ELFDATA2MSB#} -> return $ Peek { getWord16 = getWord16be, getWord32 = getWord32be, getWord64 = getWord64be, .. } + _ -> fail "invalid data layout" + ei_version <- getWord8 + unless (ei_version == {#const EV_CURRENT#}) $ fail "invalid version" + skip (1+1+{#const EI_NIDENT#}-{#const EI_PAD#}) -- ABI, ABI version, padding + return p + + +readType :: Peek -> Get () +readType Peek{..} = do + e_type <- getWord16 + case e_type of + {#const ET_REL#} -> return () + _ -> fail "expected relocatable object file" + +readMachine :: Peek -> Get () +readMachine Peek{..} = do + e_machine <- getWord16 + case e_machine of +#ifdef i386_HOST_ARCH + {#const EM_386#} -> return () +#endif +#ifdef x86_64_HOST_ARCH + {#const EM_X86_64#} -> return () +#endif + _ -> fail "expected host architecture object file" + + +{-- +-- Program headers define how the ELF program behaves once it has been loaded, +-- as well as runtime linking information. +-- +-- TLM: Since we are loading object files we shouldn't get any program headers. +-- +readProgramHeader :: Peek -> Get ProgramHeader +readProgramHeader p@Peek{..} = + case is64Bit of + True -> readProgramHeader64 p + False -> readProgramHeader32 p + +readProgramHeader32 :: Peek -> Get ProgramHeader +readProgramHeader32 _ = fail "TODO: readProgramHeader32" + +readProgramHeader64 :: Peek -> Get ProgramHeader +readProgramHeader64 _ = fail "TODO: readProgramHeader64" +--} + +-- Section headers contain information such as the section name, size, and +-- location in the object file. The list of all the section headers in the ELF +-- file is known as the section header table. +-- +readSectionHeader :: Peek -> Get SectionHeader +readSectionHeader p@Peek{..} = + case is64Bit of + True -> readSectionHeader64 p + False -> readSectionHeader32 p + +readSectionHeader32 :: Peek -> Get SectionHeader +readSectionHeader32 _ = fail "TODO: readSectionHeader32" + +readSectionHeader64 :: Peek -> Get SectionHeader +readSectionHeader64 Peek{..} = do + sh_name <- fromIntegral <$> getWord32 + sh_type <- toEnum . fromIntegral <$> getWord32 + sh_flags <- getWord64 + sh_addr <- getWord64 + sh_offset <- fromIntegral <$> getWord64 + sh_size <- fromIntegral <$> getWord64 + sh_link <- fromIntegral <$> getWord32 + sh_info <- fromIntegral <$> getWord32 + sh_align <- fromIntegral <$> getWord64 + sh_entsize <- fromIntegral <$> getWord64 + return SectionHeader {..} + + +indexStringTable :: ByteString -> Int -> ByteString +indexStringTable strtab ix = B.takeWhile (/= 0) (B.drop ix strtab) + +readStringTable :: ByteString -> SectionHeader -> Either String ByteString +readStringTable obj SectionHeader{..} = + case sh_type of + StrTab -> Right $ B.take sh_size (B.drop sh_offset obj) + _ -> Left "expected string table" + + +readRelocations :: Peek -> ByteString -> SectionHeader -> Either String (Vector Relocation) +readRelocations p@Peek{..} obj SectionHeader{..} = do + unless (sh_type == Rel || sh_type == RelA) $ fail "expected relocation section" + -- + let nrel = sh_size `quot` sh_entsize + runGet (V.replicateM nrel (readRel p sh_type sh_info)) (B.drop sh_offset obj) + + +readRel :: Peek -> SectionType -> Int -> Get Relocation +readRel p@Peek{..} sh_type r_section = + case is64Bit of + True -> readRel64 p sh_type r_section + False -> readRel32 p sh_type r_section + +readRel32 :: Peek -> SectionType -> Int -> Get Relocation +readRel32 _ _ _ = fail "TODO: readRel32" + +readRel64 :: Peek -> SectionType -> Int -> Get Relocation +readRel64 Peek{..} sh_type r_section = do + r_offset <- getWord64 + r_info <- getWord64 + r_addend <- case sh_type of + RelA -> fromIntegral <$> getWord64 + _ -> return 0 + let r_type = toEnum (fromIntegral (r_info .&. 0xffffffff)) + r_symbol = fromIntegral (r_info `shiftR` 32) - 1 + -- + return Relocation {..} + + +readSymbolTable :: Peek -> Vector SectionHeader -> ByteString -> SectionHeader -> Either String (Vector Symbol) +readSymbolTable p@Peek{..} secs obj SectionHeader{..} = do + unless (sh_type == SymTab) $ fail "expected symbol table" + + let nsym = sh_size `quot` sh_entsize + offset = sh_offset + sh_entsize -- First symbol in the table is always null; skip it. + -- Make sure to update relocation indices + strtab <- readStringTable obj (secs V.! sh_link) + symbols <- runGet (V.replicateM (nsym-1) (readSymbol p strtab)) (B.drop offset obj) + return symbols + +readSymbol :: Peek -> ByteString -> Get Symbol +readSymbol p@Peek{..} strtab = + case is64Bit of + True -> readSymbol64 p strtab + False -> readSymbol32 p strtab + +readSymbol32 :: Peek -> ByteString -> Get Symbol +readSymbol32 _ _ = fail "TODO: readSymbol32" + +readSymbol64 :: Peek -> ByteString -> Get Symbol +readSymbol64 Peek{..} strtab = do + st_strx <- fromIntegral <$> getWord32 + st_info <- getWord8 + skip 1 -- st_other <- getWord8 + sym_section <- fromIntegral <$> getWord16 + sym_value <- getWord64 + skip 8 -- st_size <- getWord64 + + let sym_name | st_strx == 0 = B.empty + | otherwise = indexStringTable strtab st_strx + + sym_binding = toEnum $ fromIntegral ((st_info .&. 0xF0) `shiftR` 4) + sym_type = toEnum $ fromIntegral (st_info .&. 0x0F) + + case sym_section of + -- External symbol; lookup value + {#const SHN_UNDEF#} | not (B.null sym_name) -> do + funptr <- resolveSymbol sym_name + message (printf "%s: external symbol found at %s" (B8.unpack sym_name) (show funptr)) + return Symbol { sym_value = castPtrToWord64 (castFunPtrToPtr funptr), .. } + + -- Internally defined symbol + n | n < {#const SHN_LORESERVE#} -> do + message (printf "%s: local symbol in section %d at 0x%02x" (B8.unpack sym_name) sym_section sym_value) + return Symbol {..} + + {#const SHN_ABS#} | sym_type == File -> return Symbol {..} + {#const SHN_ABS#} -> fail "unhandled absolute symbol" + _ -> fail "unhandled symbol section" + + +-- Return the address binding the named symbol +-- +resolveSymbol :: ByteString -> Get (FunPtr ()) +resolveSymbol name + = unsafePerformIO + $ B.unsafeUseAsCString name $ \c_name -> do + addr <- c_dlsym (packDL Next) c_name + if addr == nullFunPtr + then do + err <- dlerror + return (fail $ printf "failed to resolve symbol %s: %s" (B8.unpack name) err) + else do + return (return addr) + + +-- Utilities +-- --------- + +-- Get the address of a pointer as a Word64 +-- +castPtrToWord64 :: Ptr a -> Word64 +castPtrToWord64 (Ptr addr#) = W64# (int2Word# (addr2Int# addr#)) + + +-- c-bits +-- ------ + +-- Control the protection of pages +-- +mprotect :: Ptr Word8 -> Int -> Int -> IO () +mprotect addr len prot + = throwErrnoIfMinus1_ "mprotect" + $ c_mprotect (castPtr addr) (fromIntegral len) (fromIntegral prot) + +foreign import ccall unsafe "mprotect" + c_mprotect :: Ptr () -> CSize -> CInt -> IO CInt + +foreign import ccall unsafe "getpagesize" + c_getpagesize :: CInt + +#if __GLASGOW_HASKELL__ <= 708 +-- Fill a given number of bytes in memory. Added in base-4.8.0.0. +-- +fillBytes :: Ptr a -> Word8 -> Int -> IO () +fillBytes dest char size = do + _ <- memset dest (fromIntegral char) (fromIntegral size) + return () + +foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO (Ptr a) +#endif + + +-- Debug +-- ----- + +{-# INLINE trace #-} +trace :: String -> a -> a +trace msg = Debug.trace Debug.dump_ld ("ld: " ++ msg) + +{-# INLINE message #-} +message :: Monad m => String -> m () +message msg = trace msg (return ()) + diff --git a/Data/Array/Accelerate/LLVM/Native/Link/MachO.chs b/Data/Array/Accelerate/LLVM/Native/Link/MachO.chs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Link/MachO.chs @@ -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 +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Link.MachO ( + + loadObject, + +) where + +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.LLVM.Native.Link.Object +import Data.Array.Accelerate.Lifetime +import qualified Data.Array.Accelerate.Debug as Debug + +import Control.Applicative +import Control.Monad +import Data.Bits +import Data.ByteString ( ByteString ) +import Data.Maybe ( catMaybes ) +import Data.Serialize.Get +import Data.Vector ( Vector ) +import Data.Word +import Foreign.C +import Foreign.ForeignPtr +import Foreign.ForeignPtr.Unsafe +import Foreign.Marshal +import Foreign.Ptr +import Foreign.Storable +import GHC.ForeignPtr ( mallocPlainForeignPtrAlignedBytes ) +import GHC.Prim ( addr2Int#, int2Word# ) +import GHC.Ptr ( Ptr(..) ) +import GHC.Word ( Word64(..) ) +import System.IO.Unsafe +import System.Posix.DynamicLinker +import Text.Printf +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Short as BS +import qualified Data.ByteString.Unsafe as B +import qualified Data.Vector as V +import Prelude as P + +#include +#include +#include +#include +#include +#ifdef x86_64_HOST_ARCH +#include +#endif +#ifdef powerpc_HOST_ARCH +#include +#endif + + +-- Dynamic object loading +-- ---------------------- + +-- Load a Mach-O object file and return pointers to the executable functions +-- defined within. The executable sections are aligned appropriately, as +-- specified in the object file, and are ready to be executed on the target +-- architecture. +-- +loadObject :: ByteString -> IO (FunctionTable, ObjectCode) +loadObject obj = + case parseObject obj of + Left err -> $internalError "loadObject" err + Right (symtab, lcs) -> loadSegments obj symtab lcs + + +-- Execute the load segment commands and return function pointers to the +-- executable code in the target memory space. +-- +loadSegments :: ByteString -> Vector Symbol -> Vector LoadSegment -> IO (FunctionTable, ObjectCode) +loadSegments obj symtab lcs = do + -- Load the segments into executable memory. + -- + segs <- V.mapM (loadSegment obj symtab) lcs + + -- Resolve the external symbols defined in the sections of this object into + -- function pointers. + -- + -- Note that in order to support ahead-of-time compilation, the generated + -- functions are given unique names by appending with an underscore followed + -- by a 16-digit unique ID. The execution phase doesn't need to know about + -- this however, so un-mangle the name to the basic "map", "fold", etc. + -- + let extern Symbol{..} = sym_extern && sym_segment > 0 + resolve Symbol{..} = + let Segment _ fp = segs V.! (fromIntegral (sym_segment-1)) + name = BS.toShort (B8.take (B8.length sym_name - 17) sym_name) + addr = castPtrToFunPtr (unsafeForeignPtrToPtr fp `plusPtr` fromIntegral sym_value) + in + (name, addr) + -- + funtab = FunctionTable $ V.toList $ V.map resolve (V.filter extern symtab) + objectcode = V.toList segs + + -- The executable pages were allocated on the GC heap. When the pages are + -- finalised, unset the executable bit and mark them as read/write so that + -- they can be reused. + -- + objectcode' <- newLifetime objectcode + addFinalizer objectcode' $ do + Debug.traceIO Debug.dump_gc ("gc: unload module: " ++ show funtab) + forM_ objectcode $ \(Segment vmsize oc_fp) -> do + withForeignPtr oc_fp $ \oc_p -> do + mprotect oc_p vmsize ({#const PROT_READ#} .|. {#const PROT_WRITE#}) + + return (funtab, objectcode') + + +-- Load a segment and all its sections into memory. +-- +-- Extra jump islands are added directly after the segment. On x86_64 +-- PC-relative jumps and accesses to the global offset table (GOT) are limited +-- to 32-bit (+-2GB). If we need to go outside of this range then we must do so +-- via the jump islands. +-- +-- NOTE: This puts all the sections into a single block of memory. Technically +-- this is incorrect because we then have both text and data sections together, +-- meaning that data sections are marked as execute when they really shouldn't +-- be. These would need to live in different pages in order to be mprotect-ed +-- properly. +-- +loadSegment :: ByteString -> Vector Symbol -> LoadSegment -> IO Segment +loadSegment obj symtab seg@LoadSegment{..} = do + let + pagesize = fromIntegral c_getpagesize + + -- round up to next multiple of given alignment + pad align n = (n + align - 1) .&. (complement (align - 1)) + + seg_vmsize' = pad 16 seg_vmsize -- align jump islands to 16 bytes + segsize = pad pagesize (seg_vmsize' + (V.length symtab * 16)) -- jump entries are 16 bytes each (x86_64) + -- + seg_fp <- mallocPlainForeignPtrAlignedBytes segsize pagesize + _ <- withForeignPtr seg_fp $ \seg_p -> do + -- Just in case, clear out the segment data (corresponds to NOP) + fillBytes seg_p 0 segsize + + -- Jump tables are placed directly after the segment data + let jump_p = seg_p `plusPtr` seg_vmsize' + V.imapM_ (makeJumpIsland jump_p) symtab + + -- Process each of the sections of this segment + V.mapM_ (loadSection obj symtab seg seg_p jump_p) seg_sections + + -- Mark the page as executable and read-only + mprotect seg_p segsize ({#const PROT_READ#} .|. {#const PROT_EXEC#}) + -- + return (Segment segsize seg_fp) + + +-- Add the jump-table entries directly to each external undefined symbol. +-- +makeJumpIsland :: Ptr Word8 -> Int -> Symbol -> IO () +makeJumpIsland jump_p symbolnum Symbol{..} = do +#ifdef x86_64_HOST_ARCH + when (sym_extern && sym_segment == 0) $ do + let + target = jump_p `plusPtr` (symbolnum * 16) :: Ptr Word64 + instr = target `plusPtr` 8 :: Ptr Word8 + -- + poke target sym_value + pokeArray instr [ 0xFF, 0x25, 0xF2, 0xFF, 0xFF, 0xFF ] -- jmp *-14(%rip) +#endif + return () + + +-- Load a section at the correct offset into the given segment, and apply +-- relocations. +-- +loadSection :: ByteString -> Vector Symbol -> LoadSegment -> Ptr Word8 -> Ptr Word8 -> LoadSection -> IO () +loadSection obj symtab seg seg_p jump_p sec@LoadSection{..} = do + let (obj_fp, obj_offset, _) = B.toForeignPtr obj + -- + withForeignPtr obj_fp $ \obj_p -> do + -- Copy this section's data to the appropriate place in the segment + let src = obj_p `plusPtr` (obj_offset + sec_offset) + dst = seg_p `plusPtr` sec_addr + -- + copyBytes dst src sec_size + V.mapM_ (processRelocation symtab seg seg_p jump_p sec) sec_relocs + + +-- Process both local and external relocations. The former are probably not +-- necessary since we load all sections into the same memory segment at the +-- correct offsets. +-- +processRelocation :: Vector Symbol -> LoadSegment -> Ptr Word8 -> Ptr Word8 -> LoadSection -> RelocationInfo -> IO () +#ifdef x86_64_HOST_ARCH +processRelocation symtab LoadSegment{..} seg_p jump_p sec RelocationInfo{..} + -- Relocation through global offset table + -- + | ri_type == X86_64_RELOC_GOT || + ri_type == X86_64_RELOC_GOT_LOAD + = $internalError "processRelocation" "Global offset table relocations not handled yet" + + -- External symbols, both those defined in the sections of this object, and + -- undefined externals. For the latter, the symbol might be outside of the + -- range of 32-bit pc-relative addressing, in which case we need to go via the + -- jump tables. + -- + | ri_extern + = let value = sym_value (symtab V.! ri_symbolnum) + value_rel = value - pc' - 2 ^ ri_length -- also subtract size of instruction from PC + in + case ri_pcrel of + False -> relocate value + True -> if (fromIntegral (fromIntegral value_rel::Word32) :: Word64) == value_rel + then relocate value_rel + else do + let value' = castPtrToWord64 (jump_p `plusPtr` (ri_symbolnum * 16 + 8)) + value'_rel = value' - pc' - 2 ^ ri_length + -- + -- message (printf "relocating %s via jump table" (B8.unpack (sym_name (symtab V.! ri_symbolnum)))) + relocate value'_rel + + -- Internal relocation (to constant sections, for example). Since the sections + -- are loaded at the appropriate offsets in a single contiguous segment, this + -- is unnecessary. + -- + | otherwise + = return () + + where + pc :: Ptr Word8 + pc = seg_p `plusPtr` (sec_addr sec + ri_address) + pc' = castPtrToWord64 pc + + -- Include the addend value already encoded in the instruction + addend :: (Integral a, Storable a) => Ptr a -> Word64 -> IO a + addend p x = do + base <- peek p + case ri_type of + X86_64_RELOC_SUBTRACTOR -> return $ fromIntegral (fromIntegral base - x) + _ -> return $ fromIntegral (fromIntegral base + x) + + -- Write the new relocated address + relocate :: Word64 -> IO () + relocate x = + case ri_length of + 0 -> let p' = castPtr pc :: Ptr Word8 in poke p' =<< addend p' x + 1 -> let p' = castPtr pc :: Ptr Word16 in poke p' =<< addend p' x + 2 -> let p' = castPtr pc :: Ptr Word32 in poke p' =<< addend p' x + _ -> $internalError "processRelocation" "unhandled relocation size" + +#else +precessRelocation = + $internalError "processRelocation" "not defined for non-x86_64 architectures yet" +#endif + + +-- Object file parser +-- ------------------ + +-- Parsing depends on whether the Mach-O file is 64-bit and whether it should be +-- read as big- or little-endian. +-- +data Peek = Peek + { is64Bit :: !Bool + , getWord16 :: !(Get Word16) + , getWord32 :: !(Get Word32) + , getWord64 :: !(Get Word64) + } + +-- Load commands directly follow the Mach-O header. +-- +data LoadCommand + = LC_Segment {-# UNPACK #-} !LoadSegment + | LC_SymbolTable {-# UNPACK #-} !(Vector Symbol) + +-- Indicates that a part of this file is to be mapped into the task's +-- address space. The size of the segment in memory, vmsize, must be equal +-- to or larger than the amount to map from this file, filesize. The file is +-- mapped starting at fileoff to the beginning of the segment in memory, +-- vmaddr. If the segment has sections then the section structures directly +-- follow the segment command. +-- +-- For compactness object files contain only one (unnamed) segment, which +-- contains all the sections. +-- +data LoadSegment = LoadSegment + { seg_name :: {-# UNPACK #-} !ByteString + , seg_vmaddr :: {-# UNPACK #-} !Int -- starting virtual memory address of the segment + , seg_vmsize :: {-# UNPACK #-} !Int -- size (bytes) of virtual memory occupied by the segment + , seg_fileoff :: {-# UNPACK #-} !Int -- offset in the file for the data mapped at 'seg_vmaddr' + , seg_filesize :: {-# UNPACK #-} !Int -- size (bytes) of the segment in the file + , seg_sections :: {-# UNPACK #-} !(Vector LoadSection) -- the sections of this segment + } + deriving Show + +data LoadSection = LoadSection + { sec_secname :: {-# UNPACK #-} !ByteString + , sec_segname :: {-# UNPACK #-} !ByteString + , sec_addr :: {-# UNPACK #-} !Int -- virtual memory address of this section + , sec_size :: {-# UNPACK #-} !Int -- size in bytes + , sec_offset :: {-# UNPACK #-} !Int -- offset of this section in the file + , sec_align :: {-# UNPACK #-} !Int + , sec_relocs :: {-# UNPACK #-} !(Vector RelocationInfo) + } + deriving Show + +data RelocationInfo = RelocationInfo + { ri_address :: {-# UNPACK #-} !Int -- offset from start of the section + , ri_symbolnum :: {-# UNPACK #-} !Int -- index into the symbol table (when ri_extern=True) else section number (??) + , ri_length :: {-# UNPACK #-} !Int -- length of address (bytes) to be relocated + , ri_pcrel :: !Bool -- item containing the address to be relocated uses PC-relative addressing + , ri_extern :: !Bool + , ri_type :: !RelocationType -- type of relocation + } + deriving Show + +-- A symbol defined in the sections of this object +-- +data Symbol = Symbol + { sym_name :: {-# UNPACK #-} !ByteString + , sym_value :: {-# UNPACK #-} !Word64 + , sym_segment :: {-# UNPACK #-} !Word8 + , sym_extern :: !Bool + } + deriving Show + +#ifdef i386_HOST_ARCH +{# enum reloc_type_generic as RelocationType { } deriving (Eq, Show) #} +#endif +#ifdef x86_64_HOST_ARCH +{# enum reloc_type_x86_64 as RelocationType { } deriving (Eq, Show) #} +#endif +#ifdef powerpc_HOST_ARCH +{# enum reloc_type_ppc as RelocationType { } deriving (Eq, Show) #} +#endif + + +-- Parse the Mach-O object file and return the set of section load commands, as +-- well as the symbols defined within the sections of this object. +-- +-- Actually _executing_ the load commands, which entails copying the pointed-to +-- segments into an appropriate VM image in the target address space, happens +-- separately. +-- +parseObject :: ByteString -> Either String (Vector Symbol, Vector LoadSegment) +parseObject obj = do + ((p, ncmd, _), rest) <- runGetState readHeader obj 0 + cmds <- catMaybes <$> runGet (replicateM ncmd (readLoadCommand p obj)) rest + let + lc = [ x | LC_Segment x <- cmds ] + st = [ x | LC_SymbolTable x <- cmds ] + -- + return (V.concat st, V.fromListN ncmd lc) + + +-- The Mach-O file consists of a header block, a number of load commands, +-- followed by the segment data. +-- +-- +-------------------+ +-- | Mach-O header | +-- +-------------------+ <- sizeofheader +-- | Load command | +-- | Load command | +-- | ... | +-- +-------------------+ <- sizeofcmds + sizeofheader +-- | Segment data | +-- | Segment data | +-- | ... | +-- +-------------------+ +-- +readHeader :: Get (Peek, Int, Int) +readHeader = do + magic <- getWord32le + p@Peek{..} <- case magic of + {#const MH_MAGIC#} -> return $ Peek False getWord16le getWord32le getWord64le + {#const MH_CIGAM#} -> return $ Peek False getWord16be getWord32be getWord64be + {#const MH_MAGIC_64#} -> return $ Peek True getWord16le getWord32le getWord64le + {#const MH_CIGAM_64#} -> return $ Peek True getWord16be getWord32be getWord64be + m -> fail (printf "unknown magic: %x" m) + cpu_type <- getWord32 + -- c2HS has trouble with the CPU_TYPE_* macros due to the type cast +#ifdef i386_HOST_ARCH + when (cpu_type /= 0x0000007) $ fail "expected i386 object file" +#endif +#ifdef x86_64_HOST_ARCH + when (cpu_type /= 0x1000007) $ fail "expected x86_64 object file" +#endif +#ifdef powerpc_HOST_ARCH + case is64Bit of + False -> when (cpu_type /= 0x0000012) $ fail "expected PPC object file" + True -> when (cpu_type /= 0x1000012) $ fail "expected PPC64 object file" +#endif + skip {#sizeof cpu_subtype_t#} + filetype <- getWord32 + case filetype of + {#const MH_OBJECT#} -> return () + _ -> fail "expected object file" + ncmds <- fromIntegral <$> getWord32 + sizeofcmds <- fromIntegral <$> getWord32 + skip $ case is64Bit of + True -> 8 -- flags + reserved + False -> 4 -- flags + return (p, ncmds, sizeofcmds) + + +-- Read a segment load command from the Mach-O file. +-- +-- The only thing we are interested in are the symbol table, which tell us which +-- external symbols are defined by this object, and the load commands, which +-- indicate part of the file is to be mapped into the target address space. +-- These will tell us everything we need to know about the generated machine +-- code in order to execute it. +-- +-- Since we are only concerned with loading object files, there should really +-- only be one of each of these. +-- +readLoadCommand :: Peek -> ByteString -> Get (Maybe LoadCommand) +readLoadCommand p@Peek{..} obj = do + cmd <- getWord32 + cmdsize <- fromIntegral <$> getWord32 + -- + let required = toBool $ cmd .&. {#const LC_REQ_DYLD#} + -- + case cmd .&. (complement {#const LC_REQ_DYLD#}) of + {#const LC_SEGMENT#} -> Just . LC_Segment <$> readLoadSegment p obj + {#const LC_SEGMENT_64#} -> Just . LC_Segment <$> readLoadSegment p obj + {#const LC_SYMTAB#} -> Just . LC_SymbolTable <$> readLoadSymbolTable p obj + {#const LC_DYSYMTAB#} -> const Nothing <$> readDynamicSymbolTable p obj + {#const LC_LOAD_DYLIB#} -> fail "unhandled LC_LOAD_DYLIB" + this -> do if required + then fail (printf "unknown load command required for execution: 0x%x" this) + else message (printf "skipping load command: 0x%x" this) + skip (cmdsize - 8) + return Nothing + + +-- Read a load segment command, including any relocation entries. +-- +readLoadSegment :: Peek -> ByteString -> Get LoadSegment +readLoadSegment p@Peek{..} obj = + if is64Bit + then readLoadSegment64 p obj + else readLoadSegment32 p obj + +readLoadSegment32 :: Peek -> ByteString -> Get LoadSegment +readLoadSegment32 p@Peek{..} obj = do + name <- B.takeWhile (/= 0) <$> getBytes 16 + vmaddr <- fromIntegral <$> getWord32 + vmsize <- fromIntegral <$> getWord32 + fileoff <- fromIntegral <$> getWord32 + filesize <- fromIntegral <$> getWord32 + skip (2 * {#sizeof vm_prot_t#}) -- maxprot, initprot + nsect <- fromIntegral <$> getWord32 + skip 4 -- flags + -- + message (printf "LC_SEGMENT: Mem: 0x%09x-0x09%x" vmaddr (vmaddr + vmsize)) + secs <- V.replicateM nsect (readLoadSection32 p obj) + -- + return LoadSegment + { seg_name = name + , seg_vmaddr = vmaddr + , seg_vmsize = vmsize + , seg_fileoff = fileoff + , seg_filesize = filesize + , seg_sections = secs + } + +readLoadSegment64 :: Peek -> ByteString -> Get LoadSegment +readLoadSegment64 p@Peek{..} obj = do + name <- B.takeWhile (/= 0) <$> getBytes 16 + vmaddr <- fromIntegral <$> getWord64 + vmsize <- fromIntegral <$> getWord64 + fileoff <- fromIntegral <$> getWord64 + filesize <- fromIntegral <$> getWord64 + skip (2 * {#sizeof vm_prot_t#}) -- maxprot, initprot + nsect <- fromIntegral <$> getWord32 + skip 4 -- flags + -- + message (printf "LC_SEGMENT_64: Mem: 0x%09x-0x%09x" vmaddr (vmaddr + vmsize)) + secs <- V.replicateM nsect (readLoadSection64 p obj) + -- + return LoadSegment + { seg_name = name + , seg_vmaddr = vmaddr + , seg_vmsize = vmsize + , seg_fileoff = fileoff + , seg_filesize = filesize + , seg_sections = secs + } + +readLoadSection32 :: Peek -> ByteString -> Get LoadSection +readLoadSection32 p@Peek{..} obj = do + secname <- B.takeWhile (/= 0) <$> getBytes 16 + segname <- B.takeWhile (/= 0) <$> getBytes 16 + addr <- fromIntegral <$> getWord32 + size <- fromIntegral <$> getWord32 + offset <- fromIntegral <$> getWord32 + align <- fromIntegral <$> getWord32 + reloff <- fromIntegral <$> getWord32 + nreloc <- fromIntegral <$> getWord32 + skip 12 -- flags, reserved1, reserved2 + -- + message (printf " Mem: 0x%09x-0x%09x %s.%s" addr (addr+size) (B8.unpack segname) (B8.unpack secname)) + relocs <- either fail return $ runGet (V.replicateM nreloc (loadRelocation p)) (B.drop reloff obj) + -- + return LoadSection + { sec_secname = secname + , sec_segname = segname + , sec_addr = addr + , sec_size = size + , sec_offset = offset + , sec_align = align + , sec_relocs = relocs + } + +readLoadSection64 :: Peek -> ByteString -> Get LoadSection +readLoadSection64 p@Peek{..} obj = do + secname <- B.takeWhile (/= 0) <$> getBytes 16 + segname <- B.takeWhile (/= 0) <$> getBytes 16 + addr <- fromIntegral <$> getWord64 + size <- fromIntegral <$> getWord64 + offset <- fromIntegral <$> getWord32 + align <- fromIntegral <$> getWord32 + reloff <- fromIntegral <$> getWord32 + nreloc <- fromIntegral <$> getWord32 + skip 16 -- flags, reserved1, reserved2, reserved3 + message (printf " Mem: 0x%09x-0x%09x %s.%s" addr (addr+size) (B8.unpack segname) (B8.unpack secname)) + relocs <- either fail return $ runGet (V.replicateM nreloc (loadRelocation p)) (B.drop reloff obj) + -- + return LoadSection + { sec_secname = secname + , sec_segname = segname + , sec_addr = addr + , sec_size = size + , sec_offset = offset + , sec_align = align + , sec_relocs = relocs + } + +loadRelocation :: Peek -> Get RelocationInfo +loadRelocation Peek{..} = do + addr <- fromIntegral <$> getWord32 + val <- getWord32 + let symbol = val .&. 0xFFFFFF + pcrel = testBit val 24 + extern = testBit val 27 + len = (val `shiftR` 25) .&. 0x3 + rtype = (val `shiftR` 28) .&. 0xF + rtype' = toEnum (fromIntegral rtype) + -- + when (toBool $ addr .&. {#const R_SCATTERED#}) $ fail "unhandled scatted relocation info" + message (printf " Reloc: 0x%04x to %s %d: length=%d, pcrel=%s, type=%s" addr (if extern then "symbol" else "section") symbol len (show pcrel) (show rtype')) + -- + return RelocationInfo + { ri_address = addr + , ri_symbolnum = fromIntegral symbol + , ri_pcrel = pcrel + , ri_extern = extern + , ri_length = fromIntegral len + , ri_type = rtype' + } + + +readLoadSymbolTable :: Peek -> ByteString -> Get (Vector Symbol) +readLoadSymbolTable p@Peek{..} obj = do + symoff <- fromIntegral <$> getWord32 + nsyms <- fromIntegral <$> getWord32 + stroff <- fromIntegral <$> getWord32 + strsize <- getWord32 + message "LC_SYMTAB" + message (printf " symbol table is at offset 0x%x (%d), %d entries" symoff symoff nsyms) + message (printf " string table is at offset 0x%x (%d), %d bytes" stroff stroff strsize) + -- + let symbols = B.drop symoff obj + strtab = B.drop stroff obj + -- + either fail return $ runGet (V.replicateM nsyms (loadSymbol p strtab)) symbols + + +readDynamicSymbolTable :: Peek -> ByteString -> Get () +readDynamicSymbolTable Peek{..} _obj = do +#ifdef ACCELERATE_DEBUG + ilocalsym <- getWord32 + nlocalsym <- getWord32 + iextdefsym <- getWord32 + nextdefsym <- getWord32 + iundefsym <- getWord32 + nundefsym <- getWord32 + skip 4 -- tocoff + ntoc <- getWord32 + skip 4 -- modtaboff + nmodtab <- getWord32 + skip 12 -- extrefsymoff, nextrefsyms, indirectsymoff, + nindirectsyms <- getWord32 + skip 16 -- extreloff, nextrel, locreloff, nlocrel, + message "LC_DYSYMTAB:" + -- + if nlocalsym > 0 + then message (printf " %d local symbols at index %d" nlocalsym ilocalsym) + else message (printf " No local symbols") + if nextdefsym > 0 + then message (printf " %d external symbols at index %d" nextdefsym iextdefsym) + else message (printf " No external symbols") + if nundefsym > 0 + then message (printf " %d undefined symbols at index %d" nundefsym iundefsym) + else message (printf " No undefined symbols") + if ntoc > 0 + then message (printf " %d table of contents entries" ntoc) + else message (printf " No table of contents") + if nmodtab > 0 + then message (printf " %d module table entries" nmodtab) + else message (printf " No module table") + if nindirectsyms > 0 + then message (printf " %d indirect symbols" nindirectsyms) + else message (printf " No indirect symbols") +#else + skip ({#sizeof dysymtab_command#} - 8) +#endif + return () + +loadSymbol :: Peek -> ByteString -> Get Symbol +loadSymbol Peek{..} strtab = do + n_strx <- fromIntegral <$> getWord32 + n_flag <- getWord8 + n_sect <- getWord8 + skip 2 -- n_desc + n_value <- case is64Bit of + True -> fromIntegral <$> getWord64 + False -> fromIntegral <$> getWord32 + + let -- Symbols with string table index zero are defined to have a null + -- name (""). Otherwise, drop the leading underscore. + str | n_strx == 0 = B.empty + | otherwise = B.takeWhile (/= 0) (B.drop n_strx strtab) + name + | B.length str > 0 && B8.head str == '_' = B.tail str + | otherwise = str + + -- Extract the four bit fields of the type flag + -- n_pext = n_flag .&. {#const N_PEXT#} -- private external symbol bit + n_stab = n_flag .&. {#const N_STAB#} -- if any bits set, a symbolic debugging entry + n_type = n_flag .&. {#const N_TYPE#} -- mask for type bits + n_ext = n_flag .&. {#const N_EXT#} -- external symbol bit + + unless (n_stab == 0) $ fail "unhandled symbolic debugging entry (stab)" + + case n_type of + {#const N_UNDF#} -> do + funptr <- resolveSymbol name + message (printf " %s: external symbol found at %s" (B8.unpack name) (show funptr)) + return Symbol + { sym_name = name + , sym_extern = toBool n_ext + , sym_segment = n_sect + , sym_value = castPtrToWord64 (castFunPtrToPtr funptr) + } + + {#const N_SECT#} -> do + message (printf " %s: local symbol in section %d at 0x%02x" (B8.unpack name) n_sect n_value) + return Symbol + { sym_name = name + , sym_extern = toBool n_ext + , sym_segment = n_sect + , sym_value = n_value + } + + {#const N_ABS#} -> fail "unhandled absolute symbol" + {#const N_PBUD#} -> fail "unhandled prebound (dylib) symbol" + {#const N_INDR#} -> fail "unhandled indirect symbol" + _ -> fail "unknown symbol type" + + +-- Return the address binding the named symbol +-- +resolveSymbol :: ByteString -> Get (FunPtr ()) +resolveSymbol name + = unsafePerformIO + $ B.unsafeUseAsCString name $ \c_name -> do + addr <- c_dlsym (packDL Next) c_name + if addr == nullFunPtr + then do + err <- dlerror + return (fail $ printf "failed to resolve symbol %s: %s" (B8.unpack name) err) + else do + return (return addr) + + +-- Utilities +-- --------- + +-- Get the address of a pointer as a Word64 +-- +castPtrToWord64 :: Ptr a -> Word64 +castPtrToWord64 (Ptr addr#) = W64# (int2Word# (addr2Int# addr#)) + + +-- C-bits +-- ------ + +-- Control the protection of pages +-- +mprotect :: Ptr Word8 -> Int -> Int -> IO () +mprotect addr len prot + = throwErrnoIfMinus1_ "mprotect" + $ c_mprotect (castPtr addr) (fromIntegral len) (fromIntegral prot) + +foreign import ccall unsafe "mprotect" + c_mprotect :: Ptr () -> CSize -> CInt -> IO CInt + +foreign import ccall unsafe "getpagesize" + c_getpagesize :: CInt + +#if __GLASGOW_HASKELL__ <= 708 +-- Fill a given number of bytes in memory. Added in base-4.8.0.0. +-- +fillBytes :: Ptr a -> Word8 -> Int -> IO () +fillBytes dest char size = do + _ <- memset dest (fromIntegral char) (fromIntegral size) + return () + +foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO (Ptr a) +#endif + + +-- Debug +-- ----- + +{-# INLINE trace #-} +trace :: String -> a -> a +trace msg = Debug.trace Debug.dump_ld ("ld: " ++ msg) + +{-# INLINE message #-} +message :: Monad m => String -> m () +message msg = trace msg (return ()) + diff --git a/Data/Array/Accelerate/LLVM/Native/Link/Object.hs b/Data/Array/Accelerate/LLVM/Native/Link/Object.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Link/Object.hs @@ -0,0 +1,40 @@ +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Link.Object +-- Copyright : [2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Link.Object + where + +import Data.List +import Data.Word +import Foreign.ForeignPtr +import Foreign.Ptr + +import Data.ByteString.Short.Char8 ( ShortByteString, unpack ) +import Data.Array.Accelerate.Lifetime + + +-- | The function table is a list of function names together with a pointer in +-- the target address space containing the corresponding executable code. +-- +data FunctionTable = FunctionTable { functionTable :: [Function] } +type Function = (ShortByteString, FunPtr ()) + +instance Show FunctionTable where + showsPrec _ f + = showString "<<" + . showString (intercalate "," [ unpack n | (n,_) <- functionTable f ]) + . showString ">>" + +-- | Object code consists of memory in the target address space. +-- +type ObjectCode = Lifetime [Segment] +data Segment = Segment {-# UNPACK #-} !Int -- size in bytes + {-# UNPACK #-} !(ForeignPtr Word8) -- memory in target address space + diff --git a/Data/Array/Accelerate/LLVM/Native/Plugin.hs b/Data/Array/Accelerate/LLVM/Native/Plugin.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Plugin.hs @@ -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 +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Plugin ( + + plugin, + +) where + +import GhcPlugins +import Linker +import SysTools + +import Control.Monad +import Data.IORef +import Data.List +import qualified Data.Map as Map + +import Data.Array.Accelerate.LLVM.Native.Plugin.Annotation +import Data.Array.Accelerate.LLVM.Native.Plugin.BuildInfo + + +-- | This GHC plugin is required to support ahead-of-time compilation for the +-- accelerate-llvm-native backend. In particular, it tells GHC about the +-- additional object files generated by +-- 'Data.Array.Accelerate.LLVM.Native.runQ'* which must be linked into the final +-- executable. +-- +-- To use it, add the following to the .cabal file of your project: +-- +-- > ghc-options: -fplugin=Data.Array.Accelerate.LLVM.Native.Plugin +-- +plugin :: Plugin +plugin = defaultPlugin + { installCoreToDos = install + } + +install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install _ rest = do +#if __GLASGOW_HASKELL__ < 802 + reinitializeGlobals +#endif + let this (CoreDoPluginPass "accelerate-llvm-native" _) = True + this _ = False + -- + return $ CoreDoPluginPass "accelerate-llvm-native" pass : filter (not . this) rest + +pass :: ModGuts -> CoreM ModGuts +pass guts = do + -- Determine the current build environment + -- + hscEnv <- getHscEnv + dynFlags <- getDynFlags + this <- getModule + + -- Gather annotations for the extra object files which must be supplied to the + -- linker in order to complete the current module. + -- + paths <- nub . concat <$> mapM (objectPaths guts) (mg_binds guts) + + when (not (null paths)) + $ debugTraceMsg + $ hang (text "Data.Array.Accelerate.LLVM.Native.Plugin: linking module" <+> quotes (pprModule this) <+> text "with:") 2 (vcat (map text paths)) + + -- The linking method depends on the current build target + -- + case hscTarget dynFlags of + HscNothing -> return () + HscInterpreted -> + -- We are in interactive mode (ghci) + -- + when (not (null paths)) . liftIO $ do + let opts = ldInputs dynFlags + objs = map optionOfPath paths + -- + linkCmdLineLibs +#if __GLASGOW_HASKELL__ < 800 + $ dynFlags { ldInputs = opts ++ objs } +#else + $ hscEnv { hsc_dflags = dynFlags { ldInputs = opts ++ objs }} +#endif + + -- We are building to object code. + -- + -- Because of separate compilation, we will only encounter the annotation + -- pragmas on files which have changed between invocations. This applies to + -- both @ghc --make@ as well as the separate compile/link phases of building + -- with @cabal@ (and @stack@). Note that whenever _any_ file is updated we + -- must make sure that the linker options contains the complete list of + -- objects required to build the entire project. + -- + _ -> liftIO $ do + + -- Read the object file index and update (we may have added or removed + -- objects for the given module) + -- + let buildInfo = mkBuildInfoFileName (objectMapPath dynFlags) + abi <- readBuildInfo buildInfo + -- + let abi' = if null paths + then Map.delete this abi + else Map.insert this paths abi + allPaths = nub (concat (Map.elems abi')) + allObjs = map optionOfPath allPaths + -- + writeBuildInfo buildInfo abi' + + -- Make sure the linker flags are up-to-date. + -- + when (not (isNoLink (ghcLink dynFlags))) $ do + linker_info <- getLinkerInfo dynFlags + writeIORef (rtldInfo dynFlags) + $ Just + $ case linker_info of + GnuLD opts -> GnuLD (nub (opts ++ allObjs)) + GnuGold opts -> GnuGold (nub (opts ++ allObjs)) + DarwinLD opts -> DarwinLD (nub (opts ++ allObjs)) + SolarisLD opts -> SolarisLD (nub (opts ++ allObjs)) +#if __GLASGOW_HASKELL__ >= 800 + AixLD opts -> AixLD (nub (opts ++ allObjs)) +#endif + UnknownLD -> UnknownLD -- no linking performed? + + return () + + return guts + +objectPaths :: ModGuts -> CoreBind -> CoreM [FilePath] +objectPaths guts (NonRec b _) = objectAnns guts b +objectPaths guts (Rec bs) = concat <$> mapM (objectAnns guts) (map fst bs) + +objectAnns :: ModGuts -> CoreBndr -> CoreM [FilePath] +objectAnns guts bndr = do + anns <- getAnnotations deserializeWithData guts + return [ path | Object path <- lookupWithDefaultUFM anns [] (varUnique bndr) ] + +objectMapPath :: DynFlags -> FilePath +objectMapPath DynFlags{..} + | Just p <- objectDir = p + | Just p <- dumpDir = p + | otherwise = "." + +optionOfPath :: FilePath -> Option +optionOfPath = FileOption [] + diff --git a/Data/Array/Accelerate/LLVM/Native/Plugin/Annotation.hs b/Data/Array/Accelerate/LLVM/Native/Plugin/Annotation.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Plugin/Annotation.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DeriveDataTypeable #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Plugin.Annotation +-- Copyright : [2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Plugin.Annotation ( + + Object(..), + +) where + +import Data.Data + +data Object = Object FilePath + deriving (Show, Data, Typeable) + diff --git a/Data/Array/Accelerate/LLVM/Native/Plugin/BuildInfo.hs b/Data/Array/Accelerate/LLVM/Native/Plugin/BuildInfo.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/LLVM/Native/Plugin/BuildInfo.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.Native.Plugin.BuildInfo +-- Copyright : [2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.Native.Plugin.BuildInfo + where + +import Module + +import Data.Map ( Map ) +import Data.Serialize +import System.Directory +import System.FilePath +import qualified Data.ByteString as B +import qualified Data.Map as Map + +import Data.Array.Accelerate.Error + + +mkBuildInfoFileName :: FilePath -> FilePath +mkBuildInfoFileName path = path "accelerate-llvm-native.buildinfo" + +readBuildInfo :: FilePath -> IO (Map Module [FilePath]) +readBuildInfo path = do + exists <- doesFileExist path + if not exists + then return Map.empty + else do + f <- B.readFile path + case decode f of + Left err -> $internalError "readBuildInfo" err + Right m -> return m + +writeBuildInfo :: FilePath -> Map Module [FilePath] -> IO () +writeBuildInfo path objs = B.writeFile path (encode objs) + + +instance Serialize Module where + put (Module p n) = put p >> put n + get = do + p <- get + n <- get + return (Module p n) + +#if __GLASGOW_HASKELL__ < 800 +instance Serialize PackageKey where + put p = put (packageKeyString p) + get = stringToPackageKey <$> get +#else +instance Serialize UnitId where + put u = put (unitIdString u) + get = stringToUnitId <$> get +#endif + +instance Serialize ModuleName where + put m = put (moduleNameString m) + get = mkModuleName <$> get + diff --git a/Data/Array/Accelerate/LLVM/Native/State.hs b/Data/Array/Accelerate/LLVM/Native/State.hs --- a/Data/Array/Accelerate/LLVM/Native/State.hs +++ b/Data/Array/Accelerate/LLVM/Native/State.hs @@ -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) diff --git a/Data/Array/Accelerate/LLVM/Native/Target.hs b/Data/Array/Accelerate/LLVM/Native/Target.hs --- a/Data/Array/Accelerate/LLVM/Native/Target.hs +++ b/Data/Array/Accelerate/LLVM/Native/Target.hs @@ -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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,188 @@ +An LLVM backend for the Accelerate Array Language +================================================= + +[![Build Status](https://travis-ci.org/AccelerateHS/accelerate-llvm.svg)](https://travis-ci.org/AccelerateHS/accelerate-llvm) +[![Hackage](https://img.shields.io/hackage/v/accelerate-llvm.svg)](https://hackage.haskell.org/package/accelerate-llvm) +[![Docker Automated build](https://img.shields.io/docker/automated/tmcdonell/accelerate-llvm.svg)](https://hub.docker.com/r/tmcdonell/accelerate-llvm/) +[![Docker status](https://images.microbadger.com/badges/image/tmcdonell/accelerate-llvm.svg)](https://microbadger.com/images/tmcdonell/accelerate-llvm) + +This package compiles Accelerate code to LLVM IR, and executes that code on +multicore CPUs as well as NVIDIA GPUs. This avoids the need to go through `nvcc` +or `clang`. For details on Accelerate, refer to the [main repository][GitHub]. + +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 +``` + diff --git a/accelerate-llvm-native.cabal b/accelerate-llvm-native.cabal --- a/accelerate-llvm-native.cabal +++ b/accelerate-llvm-native.cabal @@ -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: - + to the main + package. + . + [/Dependencies/] + . + Haskell dependencies are available from Hackage. The following external + libraries are alse required: + . + * + . + * + . + [/Installing LLVM/] + . + /Homebrew/ + . + Example using Homebrew on macOS: + . + > brew install llvm-hs/homebrew-llvm/llvm-5.0 + . + /Debian & Ubuntu/ + . + For Debian/Ubuntu based Linux distributions, the LLVM.org website provides + binary distribution packages. Check for + instructions for adding the correct package database for your OS version, + and then: + . + > apt-get install llvm-5.0-dev + . + /Building from source/ + . + If your OS does not have an appropriate LLVM distribution available, you can + also build from source. Detailed build instructions are available on + . Make sure to + include the cmake build options + @-DLLVM_BUILD_LLVM_DYLIB=ON -DLLVM_LINK_LLVM_DYLIB=ON@ so that the @libLLVM@ + shared library will be built. + . + [/Installing accelerate-llvm/] + . + To use @accelerate-llvm@ it is important that the @llvm-hs@ package is + installed against the @libLLVM@ shared library, rather than statically + linked, so that we can use LLVM from GHCi and Template Haskell. This is the + default configuration, but you can also enforce this explicitly by adding + the following to your @stack.yaml@ file: + . + > flags: + > llvm-hs: + > shared-llvm: true + . + Or by specifying the @shared-llvm@ flag to cabal: + . + > 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