accelerate-cuda 0.14.0.0 → 0.17.0.0
raw patch · 50 files changed
Files
- Data/Array/Accelerate/CUDA.hs +118/−70
- Data/Array/Accelerate/CUDA/AST.hs +111/−28
- Data/Array/Accelerate/CUDA/Analysis/Device.hs +2/−2
- Data/Array/Accelerate/CUDA/Analysis/Launch.hs +28/−29
- Data/Array/Accelerate/CUDA/Analysis/Shape.hs +50/−0
- Data/Array/Accelerate/CUDA/Array/Data.hs +132/−46
- Data/Array/Accelerate/CUDA/Array/Nursery.hs +0/−124
- Data/Array/Accelerate/CUDA/Array/Prim.hs +134/−82
- Data/Array/Accelerate/CUDA/Array/Remote.hs +249/−0
- Data/Array/Accelerate/CUDA/Array/Slice.hs +212/−0
- Data/Array/Accelerate/CUDA/Array/Sugar.hs +13/−12
- Data/Array/Accelerate/CUDA/Array/Table.hs +0/−291
- Data/Array/Accelerate/CUDA/Async.hs +0/−56
- Data/Array/Accelerate/CUDA/CodeGen.hs +262/−299
- Data/Array/Accelerate/CUDA/CodeGen/Arithmetic.hs +393/−0
- Data/Array/Accelerate/CUDA/CodeGen/Base.hs +67/−29
- Data/Array/Accelerate/CUDA/CodeGen/Constant.hs +93/−0
- Data/Array/Accelerate/CUDA/CodeGen/IndexSpace.hs +83/−48
- Data/Array/Accelerate/CUDA/CodeGen/Mapping.hs +3/−2
- Data/Array/Accelerate/CUDA/CodeGen/Monad.hs +2/−2
- Data/Array/Accelerate/CUDA/CodeGen/PrefixSum.hs +86/−41
- Data/Array/Accelerate/CUDA/CodeGen/Reduction.hs +55/−38
- Data/Array/Accelerate/CUDA/CodeGen/Stencil.hs +3/−2
- Data/Array/Accelerate/CUDA/CodeGen/Stencil/Extra.hs +7/−8
- Data/Array/Accelerate/CUDA/CodeGen/Streaming.hs +84/−0
- Data/Array/Accelerate/CUDA/CodeGen/Type.hs +147/−102
- Data/Array/Accelerate/CUDA/Compile.hs +254/−129
- Data/Array/Accelerate/CUDA/Context.hs +25/−33
- Data/Array/Accelerate/CUDA/Debug.hs +35/−173
- Data/Array/Accelerate/CUDA/Execute.hs +438/−123
- Data/Array/Accelerate/CUDA/Execute/Event.hs +108/−34
- Data/Array/Accelerate/CUDA/Execute/Stream.hs +68/−55
- Data/Array/Accelerate/CUDA/Foreign.hs +1/−1
- Data/Array/Accelerate/CUDA/Foreign/Export.hs +28/−20
- Data/Array/Accelerate/CUDA/Foreign/Import.hs +28/−23
- Data/Array/Accelerate/CUDA/FullList.hs +0/−118
- Data/Array/Accelerate/CUDA/Persistent.hs +80/−51
- Data/Array/Accelerate/CUDA/State.hs +37/−18
- Data/Array/Accelerate/Internal/Check.hs +0/−123
- Setup.hs +1/−18
- accelerate-cuda.buildinfo.in +0/−3
- accelerate-cuda.cabal +39/−39
- configure +0/−3568
- cubits/accelerate_cuda.h +3/−2
- cubits/accelerate_cuda_assert.h +2/−2
- cubits/accelerate_cuda_exceptional.h +26/−0
- cubits/accelerate_cuda_function.h +13/−100
- cubits/accelerate_cuda_texture.h +2/−2
- cubits/accelerate_cuda_type.h +3/−2
- include/accelerate.h +0/−31
Data/Array/Accelerate/CUDA.hs view
@@ -4,8 +4,9 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Data.Array.Accelerate.CUDA--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+-- [2008..2009] Sean Lee+-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>@@ -120,9 +121,7 @@ -- 'Data.Word.Word32'. -- -- * If the permutation function to 'Data.Array.Accelerate.permute' resolves to--- non-unique indices, the combination function requires compute-1.1 to--- combine 32-bit types, or compute-1.2 for 64-bit types. Tuple components--- are resolved separately.+-- non-unique indices, the combination function requires compute-1.1. -- -- -- [/Debugging options:/]@@ -187,37 +186,38 @@ Arrays, -- * Synchronous execution- run, run1, stream, runIn, run1In, streamIn,+ run, run1, runWith, run1With,+ stream, streamWith, -- * Asynchronous execution Async, wait, poll, cancel,- runAsync, run1Async, runAsyncIn, run1AsyncIn,+ runAsync, run1Async, runAsyncWith, run1AsyncWith, -- * Execution contexts Context, create, destroy,+ unsafeFree, unsafeFreeWith, performGC, performGCWith, ) where -- standard library-import Control.Exception import Control.Applicative import Control.Monad.Trans import System.IO.Unsafe+import Prelude -- friends-import Data.Array.Accelerate.Trafo-import Data.Array.Accelerate.Smart ( Acc ) import Data.Array.Accelerate.Array.Sugar ( Arrays(..), ArraysR(..) )+import Data.Array.Accelerate.Smart ( Acc )+import Data.Array.Accelerate.Async+import Data.Array.Accelerate.Trafo+ import Data.Array.Accelerate.CUDA.Array.Data-import Data.Array.Accelerate.CUDA.Async import Data.Array.Accelerate.CUDA.State import Data.Array.Accelerate.CUDA.Context import Data.Array.Accelerate.CUDA.Compile import Data.Array.Accelerate.CUDA.Execute -#if ACCELERATE_DEBUG-import Data.Array.Accelerate.Debug-#endif+import Data.Array.Accelerate.Debug as Debug -- Accelerate: CUDA@@ -230,21 +230,7 @@ -- Note that it is recommended you use 'run1' whenever possible. -- run :: Arrays a => Acc a -> a-run a- = unsafePerformIO- $ evaluate (runIn defaultContext a)---- | As 'run', but allow the computation to continue running in a thread and--- return immediately without waiting for the result. The status of the--- computation can be queried using 'wait', 'poll', and 'cancel'.------ Note that a CUDA Context can be active on only one host thread at a time. If--- you want to execute multiple computations in parallel, use 'runAsyncIn'.----runAsync :: Arrays a => Acc a -> Async a-runAsync a- = unsafePerformIO- $ evaluate (runAsyncIn defaultContext a)+run = runWith defaultContext -- | As 'run', but execute using the specified device context rather than using -- the default, automatically selected device.@@ -256,24 +242,34 @@ -- 'Foreign.CUDA.Driver.Context.create' pushes the new context on top of the -- stack and makes it current with the calling thread. You should call -- 'Foreign.CUDA.Driver.Context.pop' to make the context floating before passing--- it to 'runIn', which will make it current for the duration of evaluating the+-- it to 'runWith', which will make it current for the duration of evaluating the -- expression. See the CUDA C Programming Guide (G.1) for more information. ---runIn :: Arrays a => Context -> Acc a -> a-runIn ctx a+runWith :: Arrays a => Context -> Acc a -> a+runWith ctx a = unsafePerformIO- $ evaluate (runAsyncIn ctx a) >>= wait+ $ wait =<< runAsyncWith ctx a --- | As 'runIn', but execute asynchronously. Be sure not to destroy the context,+-- | As 'run', but allow the computation to continue running in a thread and+-- return immediately without waiting for the result. The status of the+-- computation can be queried using 'wait', 'poll', and 'cancel'.+--+-- Note that a CUDA Context can be active on only one host thread at a time. If+-- you want to execute multiple computations in parallel, use 'runAsyncWith'.+--+runAsync :: Arrays a => Acc a -> IO (Async a)+runAsync = runAsyncWith defaultContext++-- | As 'runWith', but execute asynchronously. Be sure not to destroy the context, -- or attempt to attach it to a different host thread, before all outstanding -- operations have completed. ---runAsyncIn :: Arrays a => Context -> Acc a -> Async a-runAsyncIn ctx a = unsafePerformIO $ async execute+runAsyncWith :: Arrays a => Context -> Acc a -> IO (Async a)+runAsyncWith ctx a = asyncBound execute where !acc = convertAccWith config a- execute = evalCUDA ctx (compileAcc acc >>= dumpStats >>= executeAcc >>= collect)+ execute = dumpGraph acc >> evalCUDA ctx (compileAcc acc >>= dumpStats >>= executeAcc >>= collect) -- | Prepare and execute an embedded array program of one argument.@@ -309,31 +305,28 @@ -- See the programs in the 'accelerate-examples' package for examples. -- run1 :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> b-run1 f- = unsafePerformIO- $ evaluate (run1In defaultContext f)-+run1 = run1With defaultContext --- | As 'run1', but the computation is executed asynchronously.+-- | As 'run1', but execute in the specified context. ---run1Async :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> Async b-run1Async f- = unsafePerformIO- $ evaluate (run1AsyncIn defaultContext f)+run1With :: (Arrays a, Arrays b) => Context -> (Acc a -> Acc b) -> a -> b+run1With ctx f =+ let go = run1AsyncWith ctx f+ in \a -> unsafePerformIO $ wait =<< go a --- | As 'run1', but execute in the specified context.++-- | As 'run1', but the computation is executed asynchronously. ---run1In :: (Arrays a, Arrays b) => Context -> (Acc a -> Acc b) -> a -> b-run1In ctx f = let go = run1AsyncIn ctx f- in \a -> unsafePerformIO $ wait (go a)+run1Async :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> IO (Async b)+run1Async = run1AsyncWith defaultContext --- | As 'run1In', but execute asynchronously.+-- | As 'run1With', but execute asynchronously. ---run1AsyncIn :: (Arrays a, Arrays b) => Context -> (Acc a -> Acc b) -> a -> Async b-run1AsyncIn ctx f = \a -> unsafePerformIO $ async (execute a)+run1AsyncWith :: (Arrays a, Arrays b) => Context -> (Acc a -> Acc b) -> a -> IO (Async b)+run1AsyncWith ctx f = \a -> asyncBound (execute a) where !acc = convertAfunWith config f- !afun = unsafePerformIO $ evalCUDA ctx (compileAfun acc) >>= dumpStats+ !afun = unsafePerformIO $ dumpGraph acc >> evalCUDA ctx (compileAfun acc) >>= dumpStats execute a = evalCUDA ctx (executeAfun1 afun a >>= collect) -- TLM: We need to be very careful with run1* variants, to ensure that the@@ -344,18 +337,46 @@ -- collecting results as we go. -- stream :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> [a] -> [b]-stream f arrs- = unsafePerformIO- $ evaluate (streamIn defaultContext f arrs)+stream = streamWith defaultContext -- | As 'stream', but execute in the specified context. ---streamIn :: (Arrays a, Arrays b) => Context -> (Acc a -> Acc b) -> [a] -> [b]-streamIn ctx f arrs- = let go = run1In ctx f- in map go arrs+streamWith :: (Arrays a, Arrays b) => Context -> (Acc a -> Acc b) -> [a] -> [b]+streamWith ctx f arrs = map go arrs+ where+ !go = run1With ctx f +{--+-- | Generate a lazy list from a sequence computation.+--+streamOut :: Arrays a => Seq [a] -> [a]+streamOut = streamOutWith defaultContext +streamOutWith :: forall a. Arrays a => Context -> Seq [a] -> [a]+streamOutWith ctx = exec . compile . convertSeq+ where+ compile = unsafePerformIO . evalCUDA ctx . compileSeq+ exec s = go (streamSeq s)+ where+ go !s' = case step s' of+ Nothing -> []+ Just (a, s'') -> a : go s''++ step (StreamSeq ss)+ = unsafePerformIO+ $ evalCUDA ctx+ $ do m <- ss+ case m of+ Nothing -> return Nothing+ Just (a, s') -> collect a >> return (Just (a, s'))+--}+++-- RCE: Similar to run1* variants, we need to be ultra careful with streamOut*+-- in order to make sure that the entire sequence is not reified at once.+-- The steps of the sequence computation should only be performed as needed+-- when elements of the list are forced.+ -- Copy arrays from device to host. -- collect :: forall arrs. Arrays arrs => arrs -> CIO arrs@@ -375,20 +396,47 @@ config = Phase { recoverAccSharing = True , recoverExpSharing = True+ , recoverSeqSharing = True , floatOutAccFromExp = True , enableAccFusion = True , convertOffsetOfSegment = True+ -- , vectoriseSequences = False } dumpStats :: MonadIO m => a -> m a-#if ACCELERATE_DEBUG-dumpStats next = do- stats <- liftIO simplCount- liftIO $ traceMessage dump_simpl_stats (show stats)- liftIO $ resetSimplCount- return next-#else-dumpStats next = return next-#endif+dumpStats next = dumpSimplStats >> return next+++-- Device memory management+-- ------------------------+--+-- Temporarily defining here, until we can define the interface for it.+++-- Deallocate the device arrays corresponding to the given host side arrays.+-- This is unsafe in the sense that it is possible to call this function while+-- the array is currently in use.+--+unsafeFree :: Arrays arrs => arrs -> IO ()+unsafeFree = unsafeFreeWith defaultContext++unsafeFreeWith :: forall arrs. Arrays arrs => Context -> arrs -> IO ()+unsafeFreeWith !ctx !arrs+ = evalCUDA ctx+ $ freeR (arrays (undefined :: arrs)) (fromArr arrs)+ where+ freeR :: ArraysR a -> a -> CIO ()+ freeR ArraysRunit () = return ()+ freeR ArraysRarray arr = freeArray arr+ freeR (ArraysRpair aeR1 aeR2) (arrs1, arrs2) = freeR aeR1 arrs1 >> freeR aeR2 arrs2+++-- Release any unused device memory+--+performGC :: IO ()+performGC = performGCWith defaultContext++performGCWith :: Context -> IO ()+performGCWith !ctx = evalCUDA ctx cleanupArrayData
Data/Array/Accelerate/CUDA/AST.hs view
@@ -1,11 +1,12 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeSynonymInstances #-} -- | -- Module : Data.Array.Accelerate.CUDA.AST--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>@@ -18,26 +19,29 @@ module Data.Array.Accelerate.AST, AccKernel(..), Free, Gamma(..), Idx_(..),- ExecAcc, ExecAfun, ExecOpenAcc(..),+ ExecAcc, ExecAfun, ExecOpenAfun, ExecOpenAcc(..), ExecExp, ExecFun, ExecOpenExp, ExecOpenFun,+ -- ExecSeq(..), ExecOpenSeq(..), ExecP(..), ExecC(..), freevar, makeEnvMap, ) where -- friends import Data.Array.Accelerate.AST-import Data.Array.Accelerate.Pretty+import Data.Array.Accelerate.Lifetime+import Data.Array.Accelerate.Pretty as PP import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt )-import qualified Data.Array.Accelerate.CUDA.FullList as FL+import qualified Data.Array.Accelerate.FullList as FL import qualified Foreign.CUDA.Driver as CUDA import qualified Foreign.CUDA.Analysis as CUDA -- system import Text.PrettyPrint import Data.Hashable-import Data.Monoid ( Monoid(..) )+import Data.Monoid hiding ( (<>) ) import qualified Data.HashSet as Set import qualified Data.HashMap.Strict as Map+import Prelude -- A non-empty list of binary objects will be used to execute a kernel. We keep@@ -45,13 +49,13 @@ -- and execution information. -- data AccKernel a where- AccKernel :: !String -- __global__ entry function name- -> {-# UNPACK #-} !CUDA.Fun -- __global__ function object- -> {-# UNPACK #-} !CUDA.Module -- binary module- -> {-# UNPACK #-} !CUDA.Occupancy -- occupancy analysis- -> {-# UNPACK #-} !Int -- thread block size- -> {-# UNPACK #-} !Int -- shared memory per block (bytes)- -> !(Int -> Int) -- number of blocks for input problem size+ AccKernel :: !String -- __global__ entry function name+ -> {-# UNPACK #-} !CUDA.Fun -- __global__ function object+ -> {-# UNPACK #-} !(Lifetime CUDA.Module) -- binary module+ -> {-# UNPACK #-} !CUDA.Occupancy -- occupancy analysis+ -> {-# UNPACK #-} !Int -- thread block size+ -> {-# UNPACK #-} !Int -- shared memory per block (bytes)+ -> !(Int -> Int) -- number of blocks for input problem size -> AccKernel a @@ -121,41 +125,45 @@ => !(PreExp ExecOpenAcc aenv sh) -- shape of the result array, used by execution -> ExecOpenAcc aenv (Array sh e) + -- ExecSeq :: Arrays arrs+ -- => ExecOpenSeq aenv () arrs+ -- -> ExecOpenAcc aenv arrs + -- An annotated AST suitable for execution in the CUDA environment ---type ExecAcc a = ExecOpenAcc () a-type ExecAfun a = PreAfun ExecOpenAcc a+type ExecAcc a = ExecOpenAcc () a+type ExecAfun a = PreAfun ExecOpenAcc a+type ExecOpenAfun aenv a = PreOpenAfun ExecOpenAcc aenv a -type ExecOpenExp = PreOpenExp ExecOpenAcc-type ExecOpenFun = PreOpenFun ExecOpenAcc+type ExecOpenExp = PreOpenExp ExecOpenAcc+type ExecOpenFun = PreOpenFun ExecOpenAcc -type ExecExp = ExecOpenExp ()-type ExecFun = ExecOpenFun ()+type ExecExp = ExecOpenExp ()+type ExecFun = ExecOpenFun () -- Display the annotated AST -- ------------------------- -instance Show (ExecOpenAcc aenv a) where- show = render . prettyExecAcc 0 noParens+instance Show (ExecAcc a) where+ show = render . prettyExecAcc noParens PP.Empty instance Show (ExecAfun a) where- show = render . prettyExecAfun 0-+ show = render . prettyExecAfun -prettyExecAfun :: Int -> ExecAfun a -> Doc-prettyExecAfun alvl pfun = prettyPreAfun prettyExecAcc alvl pfun+prettyExecAfun :: ExecAfun a -> Doc+prettyExecAfun pfun = prettyPreOpenAfun prettyExecAcc PP.Empty pfun prettyExecAcc :: PrettyAcc ExecOpenAcc-prettyExecAcc alvl wrap exec =+prettyExecAcc wrap aenv exec = case exec of EmbedAcc sh -> wrap $ hang (text "Embedded") 2- $ sep [ prettyPreExp prettyExecAcc 0 alvl parens sh ]+ $ sep [ prettyPreExp prettyExecAcc parens aenv sh ] ExecAcc _ (Gamma fv) pacc ->- let base = prettyPreAcc prettyExecAcc alvl wrap pacc+ let base = prettyPreOpenAcc prettyExecAcc wrap aenv pacc ann = braces (freevars (Map.keys fv)) freevars = (text "fv=" <>) . brackets . hcat . punctuate comma . map (\(Idx_ ix) -> char 'a' <> int (idxToInt ix))@@ -168,4 +176,79 @@ Atuple{} -> base Aprj{} -> base _ -> ann <+> base++ -- ExecSeq _ -> text "<SequenceComputation>"++{--+data ExecSeq a where+ ExecS :: Extend ExecOpenAcc () aenv -> ExecOpenSeq aenv () a -> ExecSeq a++data ExecOpenSeq aenv lenv arrs where+ ExecP :: Arrays a => ExecP aenv lenv a -> ExecOpenSeq aenv (lenv, a) arrs -> ExecOpenSeq aenv lenv arrs+ ExecC :: (Arrays a) => ExecC aenv lenv a -> ExecOpenSeq aenv lenv a+ ExecR :: Idx lenv a -> Maybe a -> ExecOpenSeq aenv lenv [a]++data ExecP aenv lenv a where++ ExecToSeq :: (Elt slix, Shape sl, Shape sh, Elt e)+ => SliceIndex (EltRepr slix)+ (EltRepr sl)+ co+ (EltRepr sh)+ -> ExecOpenAcc aenv (Array sh e)+ -> AccKernel (Array sl e)+ -> !(Gamma aenv)+ -> [slix]+ -> ExecP aenv lenv (Array sl e)++ ExecUseLazy :: (Elt slix, Shape sl, Shape sh, Elt e)+ => SliceIndex (EltRepr slix)+ (EltRepr sl)+ co+ (EltRepr sh)+ -> Array sh e+ -> [slix]+ -> ExecP aenv lenv (Array sl e)++ ExecStreamIn :: Arrays a+ => [a]+ -> ExecP aenv lenv a++ ExecMap :: (Arrays a, Arrays b)+ => ExecOpenAfun aenv (a -> b)+ -> Idx lenv a+ -> ExecP aenv lenv b++ ExecZipWith :: (Arrays a, Arrays b, Arrays c)+ => ExecOpenAfun aenv (a -> b -> c)+ -> Idx lenv a+ -> Idx lenv b+ -> ExecP aenv lenv c++ ExecScanSeq :: Elt a+ => ExecFun aenv (a -> a -> a)+ -> ExecExp aenv a+ -> Idx lenv (Scalar a)+ -> Maybe a+ -> ExecP aenv lenv (Scalar a)++data ExecC aenv lenv a where+ ExecFoldSeq :: Elt a+ => ExecFun aenv (a -> a -> a)+ -> ExecExp aenv a+ -> Idx lenv (Scalar a)+ -> Maybe a+ -> ExecC aenv lenv (Scalar a)++ ExecFoldSeqFlatten :: (Arrays a, Shape sh, Elt e)+ => ExecOpenAfun aenv (a -> Vector sh -> Vector e -> a)+ -> ExecOpenAcc aenv a+ -> Idx lenv (Array sh e)+ -> Maybe a+ -> ExecC aenv lenv a++ ExecStuple :: (Arrays a, IsAtuple a)+ => Atuple (ExecC aenv senv) (TupleRepr a)+ -> ExecC aenv senv a+--}
Data/Array/Accelerate/CUDA/Analysis/Device.hs view
@@ -1,7 +1,7 @@ -- | -- Module : Data.Array.Accelerate.CUDA.Analysis.Device--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>
Data/Array/Accelerate/CUDA/Analysis/Launch.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-} -- | -- Module : Data.Array.Accelerate.CUDA.Analysis.Launch--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>@@ -19,6 +19,7 @@ -- friends import Data.Array.Accelerate.AST+import Data.Array.Accelerate.Error import Data.Array.Accelerate.Trafo import Data.Array.Accelerate.Analysis.Type import Data.Array.Accelerate.Analysis.Shape@@ -27,9 +28,7 @@ import qualified Foreign.CUDA.Analysis as CUDA import qualified Foreign.CUDA.Driver as CUDA -#include "accelerate.h" - -- | -- Determine kernel launch parameters for the given array computation (as well -- as compiled function module). This consists of the thread block size, number@@ -47,7 +46,7 @@ -> ( Int -- block size , Int -> Int -- number of blocks for input problem size (grid) , Int ) -- shared memory (bytes)-launchConfig Delayed{} _ _ = INTERNAL_ERROR(error) "launchConfig" "encountered delayed array"+launchConfig Delayed{} _ _ = $internalError "launchConfig" "encountered delayed array" launchConfig (Manifest acc) dev occ = let cta = CUDA.activeThreads occ `div` CUDA.activeThreadBlocks occ maxGrid = CUDA.multiProcessorCount dev * CUDA.activeThreadBlocks occ@@ -66,7 +65,7 @@ -> CUDA.Fun -- corresponding __global__ entry function -> Int -- maximum number of threads per block -> IO CUDA.Occupancy-determineOccupancy Delayed{} _ _ _ = INTERNAL_ERROR(error) "determineOccupancy" "encountered delayed array"+determineOccupancy Delayed{} _ _ _ = $internalError "determineOccupancy" "encountered delayed array" determineOccupancy (Manifest acc) dev fn maxBlock = do registers <- CUDA.requires fn CUDA.NumRegs static_smem <- CUDA.requires fn CUDA.SharedSizeBytes -- static memory only@@ -89,7 +88,7 @@ -> (Int -> Int) -- shared memory as a function of thread block size (bytes) -> (Int, CUDA.Occupancy) blockSize dev acc lim regs smem =- CUDA.optimalBlockSizeBy dev (filter (<= lim) . strategy) (const regs) smem+ CUDA.optimalBlockSizeOf dev (filter (<= lim) (strategy dev)) (const regs) smem where strategy = case acc of Fold _ _ _ -> CUDA.incPow2@@ -102,7 +101,6 @@ Scanr1 _ _ -> CUDA.incWarp _ -> CUDA.decWarp - -- | -- Determine the number of blocks of the given size necessary to process the -- given array expression. This should understand things like #elements per@@ -117,17 +115,17 @@ -- for 1D reductions this is the total number of elements -- gridSize :: CUDA.DeviceProperties -> PreOpenAcc DelayedOpenAcc aenv a -> Int -> Int -> Int-gridSize p acc@(FoldSeg _ _ _ _) size cta = split acc (size * CUDA.warpSize p) cta-gridSize p acc@(Fold1Seg _ _ _) size cta = split acc (size * CUDA.warpSize p) cta-gridSize _ acc@(Fold _ _ _) size cta = if preAccDim delayedDim acc == 0 then split acc size cta else max 1 size-gridSize _ acc@(Fold1 _ _) size cta = if preAccDim delayedDim acc == 0 then split acc size cta else max 1 size-gridSize _ acc size cta = split acc size cta+gridSize p (FoldSeg _ _ _ _) size cta = split (size * CUDA.warpSize p) cta+gridSize p (Fold1Seg _ _ _) size cta = split (size * CUDA.warpSize p) cta+gridSize _ acc@(Fold _ _ _) size cta = if preAccDim delayedDim acc == 0 then split size cta else max 1 size+gridSize _ acc@(Fold1 _ _) size cta = if preAccDim delayedDim acc == 0 then split size cta else max 1 size+gridSize _ _ size cta = split size cta -split :: acc aenv a -> Int -> Int -> Int-split acc size cta = (size `between` eltsPerThread acc) `between` cta+split :: Int -> Int -> Int+split size cta = (size `between` eltsPerThread) `between` cta where between arr n = 1 `max` ((n + arr - 1) `div` n)- eltsPerThread _ = 1+ eltsPerThread = 1 -- |@@ -137,17 +135,17 @@ -- sharedMem :: CUDA.DeviceProperties -> PreOpenAcc DelayedOpenAcc aenv a -> Int -> Int -- non-computation forms-sharedMem _ Alet{} _ = INTERNAL_ERROR(error) "sharedMem" "Let"-sharedMem _ Avar{} _ = INTERNAL_ERROR(error) "sharedMem" "Avar"-sharedMem _ Apply{} _ = INTERNAL_ERROR(error) "sharedMem" "Apply"-sharedMem _ Acond{} _ = INTERNAL_ERROR(error) "sharedMem" "Acond"-sharedMem _ Awhile{} _ = INTERNAL_ERROR(error) "sharedMem" "Awhile"-sharedMem _ Atuple{} _ = INTERNAL_ERROR(error) "sharedMem" "Atuple"-sharedMem _ Aprj{} _ = INTERNAL_ERROR(error) "sharedMem" "Aprj"-sharedMem _ Use{} _ = INTERNAL_ERROR(error) "sharedMem" "Use"-sharedMem _ Unit{} _ = INTERNAL_ERROR(error) "sharedMem" "Unit"-sharedMem _ Reshape{} _ = INTERNAL_ERROR(error) "sharedMem" "Reshape"-sharedMem _ Aforeign{} _ = INTERNAL_ERROR(error) "sharedMem" "Aforeign"+sharedMem _ Alet{} _ = $internalError "sharedMem" "Let"+sharedMem _ Avar{} _ = $internalError "sharedMem" "Avar"+sharedMem _ Apply{} _ = $internalError "sharedMem" "Apply"+sharedMem _ Acond{} _ = $internalError "sharedMem" "Acond"+sharedMem _ Awhile{} _ = $internalError "sharedMem" "Awhile"+sharedMem _ Atuple{} _ = $internalError "sharedMem" "Atuple"+sharedMem _ Aprj{} _ = $internalError "sharedMem" "Aprj"+sharedMem _ Use{} _ = $internalError "sharedMem" "Use"+sharedMem _ Unit{} _ = $internalError "sharedMem" "Unit"+sharedMem _ Reshape{} _ = $internalError "sharedMem" "Reshape"+sharedMem _ Aforeign{} _ = $internalError "sharedMem" "Aforeign" -- skeleton nodes sharedMem _ Generate{} _ = 0@@ -172,4 +170,5 @@ (blockDim `div` CUDA.warpSize p) * 8 + blockDim * sizeOf (delayedExpType x) -- TLM: why 8? I can't remember... sharedMem p (Fold1Seg _ a _) blockDim = (blockDim `div` CUDA.warpSize p) * 8 + blockDim * sizeOf (delayedAccType a)+-- sharedMem _ (Collect _) _ = 0
+ Data/Array/Accelerate/CUDA/Analysis/Shape.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+-- |+-- Module : Data.Array.Accelerate.CUDA.Analysis.Shape+-- Copyright : [2012..2014] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.CUDA.Analysis.Shape (++ module Data.Array.Accelerate.Analysis.Shape,+ module Data.Array.Accelerate.CUDA.Analysis.Shape,+ (:~:)(..),++) where++import Data.Typeable++import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Analysis.Shape+import Data.Array.Accelerate.Analysis.Match++import Data.Array.Accelerate.CUDA.AST+++-- | Reify dimensionality of the result type of an array computation+--+execAccDim :: AccDim ExecOpenAcc+execAccDim (ExecAcc _ _ pacc) = preAccDim execAccDim pacc+++-- Match reified shape types+--+matchShapeType+ :: forall sh sh'. (Shape sh, Shape sh')+ => sh+ -> sh'+ -> Maybe (sh :~: sh')+matchShapeType _ _+ | Just Refl <- matchTupleType (eltType (undefined::sh)) (eltType (undefined::sh'))+ = gcast Refl++matchShapeType _ _+ = Nothing+
Data/Array/Accelerate/CUDA/Array/Data.hs view
@@ -2,12 +2,15 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.CUDA.Array.Data--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell--- [2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell, Robert Clifton-Everest+-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+-- [2009..2014] Trevor L. McDonell+-- [2013..2014] Robert Clifton-Everest -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>@@ -18,45 +21,51 @@ module Data.Array.Accelerate.CUDA.Array.Data ( -- * Array operations and representations- mallocArray, indexArray,- useArray, useArrayAsync,+ mallocArray, freeArray,+ indexArray,+ useArray, useArrayAsync, useArraySlice, useDevicePtrs,- copyArray, copyArrayPeer, copyArrayPeerAsync,+ copyArray, copyArrayAsync, copyArrayPeer, copyArrayPeerAsync, peekArray, peekArrayAsync, pokeArray, pokeArrayAsync, marshalArrayData, marshalTextureData, marshalDevicePtrs,- devicePtrsOfArrayData, advancePtrsOfArrayData,+ withDevicePtrs, advancePtrsOfArrayData, devicePtrsFromList, devicePtrsToWordPtrs, -- * Garbage collection- cleanupArrayData+ cleanupArrayData, ) where -- libraries-import Prelude hiding ( fst, snd )-import qualified Prelude as P import Control.Applicative import Control.Monad.Reader ( asks ) import Control.Monad.State ( gets ) import Control.Monad.Trans ( liftIO )+import Control.Monad.Trans.Cont import Foreign.C.Types import Foreign.Ptr+import Prelude hiding ( fst, snd )+import qualified Prelude as P + -- friends+import Data.Array.Accelerate.Error import Data.Array.Accelerate.Array.Data-import Data.Array.Accelerate.Array.Sugar ( Array(..), Shape, Elt, toElt, EltRepr )-import Data.Array.Accelerate.Array.Representation ( size )+import Data.Array.Accelerate.Array.Sugar ( Array(..), Shape, Elt, fromElt, toElt, EltRepr )+import Data.Array.Accelerate.Array.Representation ( size, SliceIndex ) import Data.Array.Accelerate.CUDA.State-import Data.Array.Accelerate.CUDA.Array.Table+import Data.Array.Accelerate.CUDA.Array.Slice ( TransferDesc, transferDesc )+import Data.Array.Accelerate.CUDA.Array.Remote+import Data.Array.Accelerate.CUDA.Persistent ( KernelTable )+import Data.Array.Accelerate.CUDA.Execute.Event ( EventTable )+import Data.Array.Accelerate.CUDA.Execute.Stream ( Reservoir ) import qualified Data.Array.Accelerate.CUDA.Array.Prim as Prim import qualified Foreign.CUDA.Driver as CUDA import qualified Foreign.CUDA.Driver.Stream as CUDA import qualified Foreign.CUDA.Driver.Texture as CUDA -#include "accelerate.h" - -- Array Operations -- ---------------- @@ -82,6 +91,15 @@ mt <- gets memoryTable liftIO $! f ctx mt +run' :: (Context -> MemoryTable -> KernelTable -> Reservoir -> EventTable -> IO a) -> CIO a+run' f = do+ ctx <- asks activeContext+ mt <- gets memoryTable+ kt <- gets kernelTable+ rsv <- gets streamReservoir+ etbl <- gets eventTable+ liftIO $! f ctx mt kt rsv etbl+ -- CPP hackery to generate the cases where we dispatch to the worker function handling -- elementary types. --@@ -133,6 +151,25 @@ mkPrimDispatch(mallocPrim,Prim.mallocArray) +-- |Deallocate the device array accompanying the given host-side array.+--+-- Note that this does not take into account whether or not the data is still+-- required by the current (or future) computation.+--+freeArray :: Array dim e -> CIO ()+freeArray (Array !_ !adata) = run doFree+ where+ doFree !ctx !mt = freeR arrayElt adata+ where+ freeR :: ArrayEltR e -> ArrayData e -> IO ()+ freeR ArrayEltRunit _ = return ()+ freeR (ArrayEltRpair aeR1 aeR2) ad = freeR aeR1 (fst ad) >> freeR aeR2 (snd ad)+ freeR aer ad = freePrim aer ctx mt ad+ --+ freePrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> IO ()+ mkPrimDispatch(freePrim,free)++ -- |Upload an existing array to the device -- useArray :: (Shape dim, Elt e) => Array dim e -> CIO ()@@ -164,6 +201,27 @@ mkPrimDispatch(usePrim,Prim.useArrayAsync) +-- | Upload a slice of an existing array (eg. row of a matrix) to the+-- device. TODO : Bounds checking, generalize slices to more than just+-- inner dimension?+useArraySlice :: (Elt slix, Shape sl, Shape dim, Elt e)+ => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr dim)+ -> slix -- Slice+ -> Array dim e -- Host array+ -> Array sl e -- Device array+ -> CIO ()+useArraySlice slix sl (Array dim !adata_host) (Array _ !adata_dev) = run doUse+ where+ tdesc = transferDesc slix (fromElt sl) dim+ doUse !ctx !mt = useR arrayElt adata_host adata_dev+ where+ useR :: ArrayEltR e -> ArrayData e -> ArrayData e -> IO ()+ useR ArrayEltRunit _ _ = return ()+ useR (ArrayEltRpair aeR1 aeR2) adh add = useR aeR1 (fst adh) (fst add) >> useR aeR2 (snd adh) (snd add)+ useR aer adh add = usePrim aer ctx mt adh add tdesc -- usePrim aer ctx mt adh add tdesc+ usePrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> ArrayData e -> TransferDesc -> IO ()+ mkPrimDispatch(usePrim,Prim.useArraySlice)+ useDevicePtrs :: (Shape sh, Elt e) => EltRepr sh -> Prim.DevicePtrs (EltRepr e) -> CIO (Array sh e) useDevicePtrs sh ptrs = run doUse where@@ -246,7 +304,7 @@ -- copyArray :: (Shape dim, Elt e) => Array dim e -> Array dim e -> CIO () copyArray (Array !sh1 !adata1) (Array !sh2 !adata2)- = BOUNDS_CHECK(check) "copyArray" "shape mismatch" (sh1 == sh2)+ = $boundsCheck "copyArray" "shape mismatch" (sh1 == sh2) $ run doCopy where !n = size sh1@@ -261,13 +319,30 @@ copyPrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> ArrayData e -> Int -> IO () mkPrimDispatch(copyPrim,Prim.copyArray) +copyArrayAsync :: (Shape dim, Elt e) => Array dim e -> Array dim e -> Maybe CUDA.Stream -> CIO ()+copyArrayAsync (Array !sh1 !adata1) (Array !sh2 !adata2) ms+ = $boundsCheck "copyArrayAsync" "shape mismatch" (sh1 == sh2)+ $ run doCopy+ where+ !n = size sh1+ doCopy !ctx !mt = copyR arrayElt adata1 adata2+ where+ copyR :: ArrayEltR e -> ArrayData e -> ArrayData e -> IO ()+ copyR ArrayEltRunit _ _ = return ()+ copyR (ArrayEltRpair aeR1 aeR2) ad1 ad2 = copyR aeR1 (fst ad1) (fst ad2) >>+ copyR aeR2 (snd ad1) (snd ad2)+ copyR aer ad1 ad2 = copyPrim aer ctx mt ad1 ad2 n ms+ --+ copyPrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> ArrayData e -> Int -> Maybe CUDA.Stream -> IO ()+ mkPrimDispatch(copyPrim,Prim.copyArrayAsync) + -- |Copy data between two device arrays which reside in different contexts. This -- might entail copying between devices. -- copyArrayPeer :: (Shape dim, Elt e) => Array dim e -> Context -> Array dim e -> Context -> CIO () copyArrayPeer (Array !sh1 !adata1) !ctxSrc (Array !sh2 !adata2) !ctxDst- = BOUNDS_CHECK(check) "copyArrayPeer" "shape mismatch" (sh1 == sh2)+ = $boundsCheck "copyArrayPeer" "shape mismatch" (sh1 == sh2) $ run doCopy where !n = size sh1@@ -284,7 +359,7 @@ copyArrayPeerAsync :: (Shape dim, Elt e) => Array dim e -> Context -> Array dim e -> Context -> Maybe CUDA.Stream -> CIO () copyArrayPeerAsync (Array !sh1 !adata1) !ctxSrc (Array !sh2 !adata2) !ctxDst !ms- = BOUNDS_CHECK(check) "copyArrayPeerAsync" "shape mismatch" (sh1 == sh2)+ = $boundsCheck "copyArrayPeerAsync" "shape mismatch" (sh1 == sh2) $ run doCopy where !n = size sh1@@ -383,61 +458,71 @@ marshalDevicePtrs !adata ptrs = map (CUDA.VArg . CUDA.wordPtrToDevPtr) $ devicePtrsToWordPtrs adata ptrs -- |Wrap the device pointers corresponding to a host-side array into arguments--- that can be passed to a kernel upon invocation.+-- that can be passed to a kernel upon invocation and call the+-- supplied continuation. Any asynchronous CUDA functions called by the+-- continuation must be in the same stream as given by the 2nd argument. ---marshalArrayData :: ArrayElt e => ArrayData e -> CIO [CUDA.FunParam]-marshalArrayData !adata = run doMarshal+marshalArrayData :: ArrayElt e => ArrayData e -> Maybe CUDA.Stream -> ([CUDA.FunParam] -> CIO b) -> CIO b+marshalArrayData !adata ms f = run' doMarshal where- doMarshal !ctx !mt = marshalR arrayElt adata+ doMarshal !ctx !mt !kt !rsv !etbl = runContT (marshalR arrayElt adata) (evalCUDAState ctx mt kt rsv etbl . f) where- marshalR :: ArrayEltR e -> ArrayData e -> IO [CUDA.FunParam]+ marshalR :: ArrayEltR e -> ArrayData e -> ContT b IO [CUDA.FunParam] marshalR ArrayEltRunit _ = return [] marshalR (ArrayEltRpair aeR1 aeR2) ad = (++) <$> marshalR aeR1 (fst ad) <*> marshalR aeR2 (snd ad)- marshalR aer ad = return <$> marshalPrim aer ctx mt ad+ marshalR aer ad = do+ param <- ContT $ marshalPrim aer ctx mt ad ms+ return [param] --- marshalPrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> IO CUDA.FunParam+ marshalPrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> Maybe CUDA.Stream -> (CUDA.FunParam -> IO b) -> IO b mkPrimDispatch(marshalPrim,Prim.marshalArrayData) -- |Bind the device memory arrays to the given texture reference(s), setting--- appropriate type. The arrays are bound, and the list of textures thereby--- consumed, in projection index order --- i.e. right-to-left+-- appropriate type, and call the supplied continuation. The arrays are bound,+-- and the list of textures thereby consumed, in projection index order+-- --- i.e. right-to-left+-- The textures should only be considered bound during the execution of the+-- continuation. Any asynchronous CUDA functions called by the continuation+-- must be in the same stream as given by the 4th argument. ---marshalTextureData :: ArrayElt e => ArrayData e -> Int -> [CUDA.Texture] -> CIO ()-marshalTextureData !adata !n !texs = run doMarshal+marshalTextureData :: ArrayElt e => ArrayData e -> Int -> [CUDA.Texture] -> Maybe CUDA.Stream -> ([CUDA.Texture] -> CIO b) -> CIO b+marshalTextureData !adata !n !texs ms f = run' doMarshal where- doMarshal !ctx !mt = marshalR arrayElt adata texs >> return ()+ doMarshal !ctx !mt !kt !rsv !etbl = runContT (marshalR arrayElt adata texs) (evalCUDAState ctx mt kt rsv etbl . \(_,ts) -> f ts) where- marshalR :: ArrayEltR e -> ArrayData e -> [CUDA.Texture] -> IO Int- marshalR ArrayEltRunit _ _ = return 0+ marshalR :: ArrayEltR e -> ArrayData e -> [CUDA.Texture] -> ContT b IO (Int, [CUDA.Texture])+ marshalR ArrayEltRunit _ _ = return (0, []) marshalR (ArrayEltRpair aeR1 aeR2) ad t- = do r <- marshalR aeR2 (snd ad) t- l <- marshalR aeR1 (fst ad) (drop r t)- return (l + r)+ = do (r, rs) <- marshalR aeR2 (snd ad) t+ (l, ls) <- marshalR aeR1 (fst ad) (drop r t)+ return (l + r, ls ++ rs) marshalR aer ad t- = do marshalPrim aer ctx mt ad n (head t)- return 1+ = do param <- ContT $ marshalPrim aer ctx mt ad n (head t) ms+ return (1, [param]) --- marshalPrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> Int -> CUDA.Texture -> IO ()+ marshalPrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> Int -> CUDA.Texture -> Maybe CUDA.Stream -> (CUDA.Texture -> IO b) -> IO b mkPrimDispatch(marshalPrim,Prim.marshalTextureData) --- |Raw device pointers associated with a host-side array+-- | Perform an operation using the device pointers of the given array. Any+-- asynchronous CUDA functions called by the supplied continuation must be in+-- the same stream as given by the second argument. ---devicePtrsOfArrayData :: ArrayElt e => ArrayData e -> CIO (Prim.DevicePtrs e)-devicePtrsOfArrayData !adata = run ptrs+withDevicePtrs :: ArrayElt e => ArrayData e -> Maybe CUDA.Stream -> (Prim.DevicePtrs e -> CIO b) -> CIO b+withDevicePtrs !adata ms f = run' ptrs where- ptrs !ctx !mt = ptrsR arrayElt adata+ ptrs !ctx !mt !kt !rsv !etbl = runContT (ptrsR arrayElt adata) (evalCUDAState ctx mt kt rsv etbl . f) where- ptrsR :: ArrayEltR e -> ArrayData e -> IO (Prim.DevicePtrs e)+ ptrsR :: ArrayEltR e -> ArrayData e -> ContT b IO (Prim.DevicePtrs e) ptrsR ArrayEltRunit _ = return () ptrsR (ArrayEltRpair aeR1 aeR2) ad = (,) <$> ptrsR aeR1 (fst ad) <*> ptrsR aeR2 (snd ad)- ptrsR aer ad = ptrsPrim aer ctx mt ad+ ptrsR aer ad = ContT $ ptrsPrim aer ctx mt ad ms --- ptrsPrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> IO (Prim.DevicePtrs e)- mkPrimDispatch(ptrsPrim,Prim.devicePtrsOfArrayData)+ ptrsPrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> Maybe CUDA.Stream -> (Prim.DevicePtrs e -> IO b) -> IO b+ mkPrimDispatch(ptrsPrim,Prim.withDevicePtrs) -- |Advance a set of device pointers by the given number of elements each@@ -453,3 +538,4 @@ -- advancePrim :: ArrayEltR e -> ArrayData e -> Prim.DevicePtrs e -> Prim.DevicePtrs e mkPrimDispatch(advancePrim,Prim.advancePtrsOfArrayData n)+
− Data/Array/Accelerate/CUDA/Array/Nursery.hs
@@ -1,124 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ViewPatterns #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- |--- Module : Data.Array.Accelerate.CUDA.Array.Nursery--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell--- License : BSD3------ Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability : experimental--- Portability : non-portable (GHC extensions)-----module Data.Array.Accelerate.CUDA.Array.Nursery (-- Nursery(..), NRS, new, malloc, stash, flush,--) where---- friends-import Data.Array.Accelerate.CUDA.FullList ( FullList(..) )-import qualified Data.Array.Accelerate.CUDA.FullList as FL-import qualified Data.Array.Accelerate.CUDA.Debug as D---- libraries-import Prelude-import Data.Hashable-import Control.Exception ( bracket_ )-import Control.Concurrent.MVar ( MVar, newMVar, withMVar, mkWeakMVar )-import System.Mem.Weak ( Weak )-import Foreign.Ptr ( ptrToIntPtr )-import Foreign.CUDA.Ptr ( DevicePtr )--import qualified Foreign.CUDA.Driver as CUDA-import qualified Data.HashTable.IO as HT----- The nursery is a place to store device memory arrays that are no longer--- needed. If a new array is requested of a similar size, we might return an--- array from the nursery instead of calling into the CUDA API to allocate fresh--- memory.------ Note that pointers are also related to a specific context, so we must include--- that when looking up the map.------ Note that since there might be many arrays for the same size, each entry in--- the map keeps a (non-empty) list of device pointers.----type HashTable key val = HT.BasicHashTable key val--type NRS = MVar ( HashTable (CUDA.Context, Int) (FullList () (DevicePtr ())) )-data Nursery = Nursery {-# UNPACK #-} !NRS- {-# UNPACK #-} !(Weak NRS)--instance Hashable CUDA.Context where- {-# INLINE hashWithSalt #-}- hashWithSalt salt (CUDA.Context ctx)- = salt `hashWithSalt` (fromIntegral (ptrToIntPtr ctx) :: Int)----- Generate a fresh nursery----new :: IO Nursery-new = do- tbl <- HT.new- ref <- newMVar tbl- weak <- mkWeakMVar ref (flush tbl)- return $! Nursery ref weak----- Look for a chunk of memory in the nursery of a given size (or a little bit--- larger). If found, it is removed from the nursery and a pointer to it--- returned.----{-# INLINE malloc #-}-malloc :: Int -> CUDA.Context -> Nursery -> IO (Maybe (DevicePtr ()))-malloc !n !ctx (Nursery !ref _) = withMVar ref $ \tbl -> do- let !key = (ctx,n)- --- mp <- HT.lookup tbl key- case mp of- Nothing -> return Nothing- Just (FL () ptr rest) ->- case rest of- FL.Nil -> HT.delete tbl key >> return (Just ptr)- FL.Cons () v xs -> HT.insert tbl key (FL () v xs) >> return (Just ptr)----- Add a device pointer to the nursery.----{-# INLINE stash #-}-stash :: Int -> CUDA.Context -> NRS -> DevicePtr a -> IO ()-stash !n !ctx !ref (CUDA.castDevPtr -> !ptr) = withMVar ref $ \tbl -> do- let !key = (ctx, n)- --- mp <- HT.lookup tbl key- case mp of- Nothing -> HT.insert tbl key (FL.singleton () ptr)- Just xs -> HT.insert tbl key (FL.cons () ptr xs)----- Delete all entries from the nursery and free all associated device memory.----flush :: HashTable (CUDA.Context,Int) (FullList () (CUDA.DevicePtr ())) -> IO ()-flush !tbl =- let clean (!key@(ctx,_),!val) = do- bracket_ (CUDA.push ctx) CUDA.pop (FL.mapM_ (const CUDA.free) val)- HT.delete tbl key- in- message "flush nursery" >> HT.mapM_ clean tbl----- Debug--- -------{-# INLINE trace #-}-trace :: String -> IO a -> IO a-trace msg next = D.message D.dump_gc ("gc: " ++ msg) >> next--{-# INLINE message #-}-message :: String -> IO ()-message s = s `trace` return ()-
Data/Array/Accelerate/CUDA/Array/Prim.hs view
@@ -1,13 +1,15 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-} -- | -- Module : Data.Array.Accelerate.CUDA.Array.Prim--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>@@ -20,13 +22,12 @@ DevicePtrs, HostPtrs, mallocArray, indexArray,- useArray, useArrayAsync,- useDevicePtrs,- copyArray, copyArrayPeer, copyArrayPeerAsync,+ useArray, useArrayAsync, useArraySlice, useDevicePtrs,+ copyArray, copyArrayAsync, copyArrayPeer, copyArrayPeerAsync, peekArray, peekArrayAsync, pokeArray, pokeArrayAsync, marshalDevicePtrs, marshalArrayData, marshalTextureData,- devicePtrsOfArrayData, advancePtrsOfArrayData+ withDevicePtrs, advancePtrsOfArrayData ) where @@ -34,11 +35,11 @@ import Prelude hiding ( lookup ) import Data.Int import Data.Word-import Data.Maybe-import Data.Functor import Data.Typeable import Control.Monad+import Language.Haskell.TH import System.Mem.StableName+import Foreign.CUDA.Ptr ( plusDevPtr ) import Foreign.Ptr import Foreign.C.Types import Foreign.Storable@@ -48,14 +49,15 @@ import qualified Foreign.CUDA.Driver.Texture as CUDA -- friends+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Lifetime ( withLifetime ) import Data.Array.Accelerate.Array.Data import Data.Array.Accelerate.CUDA.Context-import Data.Array.Accelerate.CUDA.Array.Table+import Data.Array.Accelerate.CUDA.Array.Slice ( TransferDesc(..), blocksOf )+import Data.Array.Accelerate.CUDA.Array.Remote import qualified Data.Array.Accelerate.CUDA.Debug as D -#include "accelerate.h" - -- Device array representation -- --------------------------- @@ -98,7 +100,7 @@ primArrayEltAs(CDouble, Double) primArrayElt(Char)-primArrayEltAs(CChar, Int8)+primArrayEltAs(CChar, HTYPE_CCHAR) primArrayEltAs(CSChar, Int8) primArrayEltAs(CUChar, Word8) @@ -140,12 +142,13 @@ instance TextureData CSChar where format _ = (CUDA.Int8, 1) instance TextureData CUChar where format _ = (CUDA.Word8, 1) instance TextureData Char where format _ = (CUDA.Word32, 1)-instance TextureData Int where format _ = (CUDA.Int32, SIZEOF_HTYPE_INT `div` 4)-instance TextureData Word where format _ = (CUDA.Word32, SIZEOF_HTYPE_WORD `div` 4)-instance TextureData CLong where format _ = (CUDA.Int32, SIZEOF_HTYPE_LONG `div` 4)-instance TextureData CULong where format _ = (CUDA.Word32, SIZEOF_HTYPE_UNSIGNED_LONG `div` 4) +$( runQ [d| instance TextureData Int where format _ = (CUDA.Int32, sizeOf (undefined::Int) `div` 4) |] )+$( runQ [d| instance TextureData Word where format _ = (CUDA.Word32, sizeOf (undefined::Word) `div` 4) |] )+$( runQ [d| instance TextureData CLong where format _ = (CUDA.Int32, sizeOf (undefined::CLong) `div` 4) |] )+$( runQ [d| instance TextureData CULong where format _ = (CUDA.Word32, sizeOf (undefined::CULong) `div` 4) |] ) + -- Primitive array operations -- -------------------------- @@ -154,7 +157,7 @@ -- release any inaccessible arrays and try again. -- mallocArray- :: forall e a. (ArrayElt e, DevicePtrs e ~ CUDA.DevicePtr a, Typeable e, Typeable a, Storable a)+ :: forall e a. (PrimElt e a, DevicePtrs e ~ CUDA.DevicePtr a) => Context -> MemoryTable -> ArrayData e@@ -163,18 +166,16 @@ mallocArray !ctx !mt !ad !n0 = do let !n = 1 `max` n0 !bytes = n * sizeOf (undefined :: a)- exists <- isJust <$> (lookup ctx mt ad :: IO (Maybe (CUDA.DevicePtr a)))- unless exists $ do- message $ "mallocArray: " ++ showBytes bytes- _ <- malloc ctx mt ad n :: IO (CUDA.DevicePtr a)- return ()+ message $ "mallocArray: " ++ showBytes bytes+ _ <- malloc ctx mt ad False n+ return () -- A combination of 'mallocArray' and 'pokeArray' to allocate space on the -- device and upload an existing array. This is specialised because if the host -- array is shared on the heap, we do not need to do anything. -- useArray- :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr a, Typeable e, Typeable a, Storable a)+ :: forall e a. (PrimElt e a, DevicePtrs e ~ CUDA.DevicePtr a) => Context -> MemoryTable -> ArrayData e@@ -184,13 +185,36 @@ let src = ptrsOfArrayData ad !n = 1 `max` n0 !bytes = n * sizeOf (undefined :: a)++ run dst = transfer "useArray/malloc" bytes $ CUDA.pokeArray n src dst in do- exists <- isJust <$> (lookup ctx mt ad :: IO (Maybe (CUDA.DevicePtr a)))- unless exists $ do- dst <- malloc ctx mt ad n- transfer "useArray/malloc" bytes $ CUDA.pokeArray n src dst+ alloc <- malloc ctx mt ad True n+ when alloc $ withDevicePtrs ctx mt ad Nothing run +-- A combination of 'mallocArray' and 'pokeArray' to allocate space on the+-- device and upload an existing array. This is specialised because if the host+-- array is shared on the heap, we do not need to do anything.+--+useArraySlice+ :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr a, Typeable e, Typeable a, Storable a)+ => Context+ -> MemoryTable+ -> ArrayData e+ -> ArrayData e+ -> TransferDesc+ -> IO ()+useArraySlice !ctx !mt !ad_host !ad_dev !tdesc =+ let src = ptrsOfArrayData ad_host+ k = sizeOf (undefined :: a)+ run dst =+ sequence_+ [ transfer "useArraySlice/malloc" (k * size) $ CUDA.pokeArray size (plusPtr src (k * src_offset)) (plusDevPtr dst (k * dst_offset))+ | (src_offset, dst_offset, size) <- blocksOf tdesc]+ in do+ alloc <- malloc ctx mt ad_dev True (k * nblocks tdesc * blocksize tdesc)+ when alloc $ withDevicePtrs ctx mt ad_dev Nothing run + useArrayAsync :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr a, Typeable e, Typeable a, Storable a) => Context@@ -203,11 +227,11 @@ let src = CUDA.HostPtr (ptrsOfArrayData ad) !n = 1 `max` n0 !bytes = n * sizeOf (undefined :: a)++ run dst = transfer "useArray/malloc" bytes $ CUDA.pokeArrayAsync n src dst ms in do- exists <- isJust <$> (lookup ctx mt ad :: IO (Maybe (CUDA.DevicePtr a)))- unless exists $ do- dst <- malloc ctx mt ad n- transfer "useArrayAsync/malloc" bytes $ CUDA.pokeArrayAsync n src dst ms+ alloc <- malloc ctx mt ad True n+ when alloc $ withDevicePtrs ctx mt ad ms run useDevicePtrs@@ -223,14 +247,14 @@ (adata, _) = runArrayData $ (,undefined) `fmap` newArrayData n in do message $ "useDevicePtrs: " ++ showBytes bytes- insertRemote ctx mt adata ptr+ insertUnmanaged ctx mt adata ptr return adata -- Read a single element from an array at the given row-major index -- indexArray- :: forall e a. (ArrayElt e, DevicePtrs e ~ CUDA.DevicePtr a, Typeable e, Typeable a, Storable a)+ :: forall e a. (PrimElt e a, DevicePtrs e ~ CUDA.DevicePtr a) => Context -> MemoryTable -> ArrayData e@@ -238,7 +262,7 @@ -> IO a indexArray !ctx !mt !ad !i = alloca $ \dst ->- devicePtrsOfArrayData ctx mt ad >>= \src -> do+ withDevicePtrs ctx mt ad Nothing $ \src -> do message $ "indexArray: " ++ showBytes (sizeOf (undefined::a)) CUDA.peekArray 1 (src `CUDA.advanceDevPtr` i) dst peek dst@@ -248,49 +272,67 @@ -- respect to the host, but will never overlap kernel execution. -- copyArray- :: forall e a b. (ArrayElt e, ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr b, Typeable a, Typeable b, Typeable e, Storable b)+ :: forall e a. (PrimElt e a, DevicePtrs e ~ CUDA.DevicePtr a) => Context -> MemoryTable -> ArrayData e -- source array -> ArrayData e -- destination array -> Int -- number of array elements -> IO ()-copyArray !ctx !mt !from !to !n = do- src <- devicePtrsOfArrayData ctx mt from- dst <- devicePtrsOfArrayData ctx mt to- transfer "copyArrayAsync" (n * sizeOf (undefined :: b)) $- CUDA.copyArrayAsync n src dst+copyArray !ctx !mt !from !to !n =+ withDevicePtrs ctx mt from Nothing $ \src ->+ withDevicePtrs ctx mt to Nothing $ \dst -> do+ transfer "copyArray" (n * sizeOf (undefined :: a)) $+ CUDA.copyArray n src dst +copyArrayAsync+ :: forall e a. (PrimElt e a, DevicePtrs e ~ CUDA.DevicePtr a)+ => Context+ -> MemoryTable+ -> ArrayData e -- source array+ -> ArrayData e -- destination array+ -> Int -- number of array elements+ -> Maybe CUDA.Stream+ -> IO ()+copyArrayAsync !ctx !mt !from !to !n !mst =+ withDevicePtrs ctx mt from Nothing$ \src ->+ withDevicePtrs ctx mt to Nothing $ \dst -> do+ transfer "copyArrayAsync" (n * sizeOf (undefined :: a)) $+ CUDA.copyArrayAsync n src dst mst -- Copy data between two device arrays that exist in different contexts and/or -- devices. -- copyArrayPeer- :: forall e a b. (ArrayElt e, ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr b, Typeable a, Typeable b, Typeable e, Storable b)+ :: forall e a. (PrimElt e a, DevicePtrs e ~ CUDA.DevicePtr a) => MemoryTable -> ArrayData e -> Context -- source array and context -> ArrayData e -> Context -- destination array and context -> Int -- number of array elements -> IO ()-copyArrayPeer !mt !from !ctxSrc !to !ctxDst !n = do- src <- devicePtrsOfArrayData ctxSrc mt from- dst <- devicePtrsOfArrayData ctxDst mt to- transfer "copyArrayPeer" (n * sizeOf (undefined :: b)) $- CUDA.copyArrayPeer n src (deviceContext ctxSrc) dst (deviceContext ctxDst)+copyArrayPeer !mt !from !ctxSrc !to !ctxDst !n =+ withDevicePtrs ctxSrc mt from Nothing $ \src ->+ withDevicePtrs ctxDst mt to Nothing $ \dst ->+ withLifetime (deviceContext ctxSrc) $ \dctxSrc ->+ withLifetime (deviceContext ctxDst) $ \dctxDst -> do+ transfer "copyArrayPeer" (n * sizeOf (undefined :: a)) $+ CUDA.copyArrayPeer n src dctxSrc dst dctxDst copyArrayPeerAsync- :: forall e a b. (ArrayElt e, ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr b, Typeable a, Typeable b, Typeable e, Storable b)+ :: forall e a. (PrimElt e a, DevicePtrs e ~ CUDA.DevicePtr a) => MemoryTable -> ArrayData e -> Context -- source array and context -> ArrayData e -> Context -- destination array and context -> Int -- number of array elements -> Maybe CUDA.Stream -> IO ()-copyArrayPeerAsync !mt !from !ctxSrc !to !ctxDst !n !st = do- src <- devicePtrsOfArrayData ctxSrc mt from- dst <- devicePtrsOfArrayData ctxDst mt to- transfer "copyArrayPeerAsync" (n * sizeOf (undefined :: b)) $- CUDA.copyArrayPeerAsync n src (deviceContext ctxSrc) dst (deviceContext ctxDst) st+copyArrayPeerAsync !mt !from !ctxSrc !to !ctxDst !n !st =+ withDevicePtrs ctxSrc mt from st $ \src ->+ withDevicePtrs ctxDst mt to st $ \dst ->+ withLifetime (deviceContext ctxSrc) $ \dctxSrc ->+ withLifetime (deviceContext ctxDst) $ \dctxDst ->+ transfer "copyArrayPeerAsync" (n * sizeOf (undefined :: a)) $+ CUDA.copyArrayPeerAsync n src dctxSrc dst dctxDst st -- Copy data from the device into the associated Accelerate host-side array@@ -303,7 +345,7 @@ -> Int -> IO () peekArray !ctx !mt !ad !n =- devicePtrsOfArrayData ctx mt ad >>= \src ->+ withDevicePtrs ctx mt ad Nothing $ \src -> transfer "peekArray" (n * sizeOf (undefined :: a)) $ CUDA.peekArray n src (ptrsOfArrayData ad) @@ -316,7 +358,7 @@ -> Maybe CUDA.Stream -> IO () peekArrayAsync !ctx !mt !ad !n !st =- devicePtrsOfArrayData ctx mt ad >>= \src ->+ withDevicePtrs ctx mt ad st $ \src -> transfer "peekArrayAsync" (n * sizeOf (undefined :: a)) $ CUDA.peekArrayAsync n src (CUDA.HostPtr $ ptrsOfArrayData ad) st @@ -331,7 +373,7 @@ -> Int -> IO () pokeArray !ctx !mt !ad !n =- devicePtrsOfArrayData ctx mt ad >>= \dst ->+ withDevicePtrs ctx mt ad Nothing $ \dst -> transfer "pokeArray: " (n * sizeOf (undefined :: a)) $ CUDA.pokeArray n (ptrsOfArrayData ad) dst @@ -344,7 +386,7 @@ -> Maybe CUDA.Stream -> IO () pokeArrayAsync !ctx !mt !ad !n !st =- devicePtrsOfArrayData ctx mt ad >>= \dst ->+ withDevicePtrs ctx mt ad st $ \dst -> transfer "pokeArrayAsync: " (n * sizeOf (undefined :: a)) $ CUDA.pokeArrayAsync n (CUDA.HostPtr $ ptrsOfArrayData ad) dst st @@ -360,49 +402,63 @@ -- Wrap a device pointer corresponding corresponding to a host-side array into--- arguments that can be passed to a kernel upon invocation+-- arguments that can be passed to a kernel upon invocation and call the+-- supplied continuation. Any asynchronous CUDA functions called by the+-- continuation must be in the same stream as given by the 4th argument. -- marshalArrayData- :: (ArrayElt e, DevicePtrs e ~ CUDA.DevicePtr b, Typeable b, Typeable e)+ :: (PrimElt e a, DevicePtrs e ~ CUDA.DevicePtr a) => Context -> MemoryTable -> ArrayData e- -> IO CUDA.FunParam-marshalArrayData !ctx !mt !ad = marshalDevicePtrs ad <$> devicePtrsOfArrayData ctx mt ad+ -> Maybe CUDA.Stream+ -> (CUDA.FunParam -> IO b)+ -> IO b+marshalArrayData !ctx !mt !ad ms run = withDevicePtrs ctx mt ad ms (run . marshalDevicePtrs ad) --- Bind device memory to the given texture reference, setting appropriate type+-- Bind device memory to the given texture reference, setting appropriate type,+-- and call the supplied continuation. The texture should only be considered+-- bound during the execution of the continuation. Any asynchronous CUDA+-- functions called by the continuation must be in the same stream as given by+-- the 6th argument. -- marshalTextureData- :: forall a e. (ArrayElt e, DevicePtrs e ~ CUDA.DevicePtr a, Typeable a, Typeable e, Storable a, TextureData a)+ :: forall a e b. (PrimElt e a, DevicePtrs e ~ CUDA.DevicePtr a, TextureData a) => Context -> MemoryTable -> ArrayData e -- host array -> Int -- number of elements -> CUDA.Texture -- texture reference to bind array to- -> IO ()-marshalTextureData !ctx !mt !ad !n !tex =+ -> Maybe CUDA.Stream+ -> (CUDA.Texture -> IO b)+ -> IO b+marshalTextureData !ctx !mt !ad !n !tex ms run = let (fmt, c) = format (undefined :: a)- in devicePtrsOfArrayData ctx mt ad >>= \ptr -> do+ in withDevicePtrs ctx mt ad ms $ \ptr -> do CUDA.setFormat tex fmt c CUDA.bind tex ptr (fromIntegral $ n * sizeOf (undefined :: a))-+ run tex --- Lookup the device memory associated with our host array+-- Perform an operation using the device pointer of the given array. Any+-- asynchronous CUDA functions called by the supplied continuation must be in+-- the same stream as given by the 4th argument. ---devicePtrsOfArrayData- :: (ArrayElt e, DevicePtrs e ~ CUDA.DevicePtr b, Typeable e, Typeable b)+withDevicePtrs+ :: (PrimElt e a, DevicePtrs e ~ CUDA.DevicePtr a) => Context -> MemoryTable -> ArrayData e- -> IO (DevicePtrs e)-devicePtrsOfArrayData !ctx !mt !ad = do- mv <- lookup ctx mt ad- case mv of- Just v -> return v+ -> Maybe (CUDA.Stream)+ -> (DevicePtrs e -> IO b)+ -> IO b+withDevicePtrs !ctx !mt !ad ms run = do+ mb <- withRemote ctx mt ad run ms+ case mb of+ Just b -> return b Nothing -> do sn <- makeStableName ad- INTERNAL_ERROR(error) "devicePtrsOfArrayData" $ "lost device memory #" ++ show (hashStableName sn)+ $internalError "withDevicePtrs" $ "lost device memory #" ++ show (hashStableName sn) -- Advance device pointers by a given number of elements@@ -423,13 +479,9 @@ showBytes :: Int -> String showBytes x = D.showFFloatSIBase (Just 0) 1024 (fromIntegral x :: Double) "B" -{-# INLINE trace #-}-trace :: String -> IO a -> IO a-trace msg next = D.message D.dump_gc ("gc: " ++ msg) >> next- {-# INLINE message #-} message :: String -> IO ()-message s = s `trace` return ()+message msg = D.traceIO D.dump_gc ("gc: " ++ msg) {-# INLINE transfer #-} transfer :: String -> Int -> IO () -> IO ()@@ -439,5 +491,5 @@ ++ showBytes bytes ++ " @ " ++ showRate bytes gpuTime ++ ", " ++ D.elapsed gpuTime cpuTime in- D.timed D.dump_gc msg action+ D.timed D.dump_gc msg Nothing action
+ Data/Array/Accelerate/CUDA/Array/Remote.hs view
@@ -0,0 +1,249 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module : Data.Array.Accelerate.CUDA.Array.Remote+-- Copyright : [2015..2016] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell, Robert Clifton-Everest+-- License : BSD3+--+-- Maintainer : Robert Clifton-Everest <robertce@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.CUDA.Array.Remote (++ -- Tables for host/device memory associations+ MemoryTable, R.PrimElt,+ new, malloc, withRemote, free, insertUnmanaged, reclaim++) where++import Control.Concurrent.MVar ( MVar, newMVar, withMVar, modifyMVar, readMVar )+import Control.Exception+import Control.Monad.IO.Class ( MonadIO, liftIO )+import Control.Monad.Trans.Reader+import Data.Functor+import Data.IntMap.Strict ( IntMap )+import Data.Proxy+import Data.Typeable ( Typeable )+import Foreign.Ptr ( ptrToIntPtr )+import Foreign.Storable+import Prelude hiding ( lookup )+import qualified Data.IntMap.Strict as IM++import Foreign.CUDA.Driver.Error+import qualified Foreign.CUDA.Driver as CUDA++import Data.Array.Accelerate.Array.Data+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Lifetime ( unsafeGetValue )+import qualified Data.Array.Accelerate.Array.Remote as R++import Data.Array.Accelerate.CUDA.Context ( Context(..), push, pop )+import Data.Array.Accelerate.CUDA.Execute.Event ( Event, EventTable, waypoint, query )+import Data.Array.Accelerate.CUDA.Execute.Stream ( Stream )+import qualified Data.Array.Accelerate.CUDA.Debug as Debug+++-- Instance for basic remote memory management functionality.+--+type CRM = ReaderT (Maybe Stream) IO++instance R.RemoteMemory CRM where+ type RemotePtr CRM = CUDA.DevicePtr+ --+ mallocRemote n = ReaderT $ \_ ->+ fmap Just (CUDA.mallocArray n)+ `catch` \e -> case e of+ ExitCode OutOfMemory -> return Nothing+ _ -> trace ("malloc failed with error: " ++ show e) (throwIO e)++ pokeRemote n dst ad = ReaderT $ \mst ->+ transfer "poke" (n * sizeOfPtr dst) $+ CUDA.pokeArrayAsync n (CUDA.HostPtr (ptrsOfArrayData ad)) dst mst++ peekRemote n src ad = ReaderT $ \mst ->+ transfer "peek" (n * sizeOfPtr src) $+ CUDA.peekArrayAsync n src (CUDA.HostPtr (ptrsOfArrayData ad)) mst++ castRemotePtr _ = CUDA.castDevPtr+ totalRemoteMem = ReaderT $ \_ -> snd <$> CUDA.getMemInfo+ availableRemoteMem = ReaderT $ \_ -> fst <$> CUDA.getMemInfo+ remoteAllocationSize = return 1024+++-- We leverage the memory cache from the accelerate base package.+--+-- However, we actually need multiple caches because every pointer has an+-- associated CUDA context. We could pair every DevicePtr with its context and+-- just have a single table, but the LRU implementation in the base package+-- assumes that remote pointers can be re-used, something that would not be true+-- for pointers allocated under different contexts.+--+type MT = IntMap (R.MemoryTable CUDA.DevicePtr Task)+data MemoryTable = MemoryTable {-# UNPACK #-} !EventTable+ {-# UNPACK #-} !(MVar MT)++type Task = Maybe Event++instance R.Task Task where+ completed Nothing = return True+ completed (Just e) = query e+++-- Create a MemoryTable.+--+new :: EventTable -> IO MemoryTable+new et = do+ message "initialise CUDA memory table"+ MemoryTable et <$> newMVar IM.empty+++-- Perform action on the device ptr that matches the given host-side array. Any+-- operations+--+withRemote+ :: forall e a b. R.PrimElt e a+ => Context+ -> MemoryTable+ -> ArrayData e+ -> (CUDA.DevicePtr a -> IO b)+ -> Maybe Stream+ -> IO (Maybe b)+withRemote ctx (MemoryTable et ref) ad run ms = do+ ct <- readMVar ref+ case IM.lookup (contextId ctx) ct of+ Nothing -> $internalError "withRemote" "context not found"+ Just mc -> streaming ms $ R.withRemote mc ad run'+ where+ run' :: R.RemotePtr CRM a -> CRM (Task, b)+ run' p = liftIO $ do+ c <- run p+ case ms of+ Nothing -> return (Nothing, c)+ Just s -> do+ e <- waypoint ctx et s+ return (Just e, c)+++-- Allocate a new device array to be associated with the given host-side array.+-- Has the same properties as `Data.Array.Accelerate.Array.Remote.LRU.malloc`+malloc :: forall a b. (Typeable a, R.PrimElt a b)+ => Context+ -> MemoryTable+ -> ArrayData a+ -> Bool+ -> Int+ -> IO Bool+malloc !ctx (MemoryTable _ !ref) !ad !frozen !n = do+ mt <- modifyMVar ref $ \ct -> blocking $ do+ case IM.lookup (contextId ctx) ct of+ Nothing -> trace "malloc/context not found" $ insertContext ctx ct+ Just mt -> return (ct, mt)+ blocking $ R.malloc mt ad frozen n+++-- Explicitly free an array in the LRU table. Has the same properties as+-- `Data.Array.Accelerate.Array.Remote.LRU.free`+--+free :: R.PrimElt a b+ => Context+ -> MemoryTable+ -> ArrayData a+ -> IO ()+free !ctx (MemoryTable _ !ref) !arr = withMVar ref $ \ct ->+ case IM.lookup (contextId ctx) ct of+ Nothing -> message "free/context not found"+ Just mt -> R.free (Proxy :: Proxy CRM) mt arr+++-- Record an association between a host-side array and a device memory area that was+-- not allocated by accelerate. The device memory will NOT be freed by the memory+-- manager.+--+insertUnmanaged+ :: R.PrimElt a b+ => Context+ -> MemoryTable+ -> ArrayData a+ -> CUDA.DevicePtr b+ -> IO ()+insertUnmanaged !ctx (MemoryTable _ !ref) !arr !ptr = do+ mt <- modifyMVar ref $ \ct -> blocking $ do+ case IM.lookup (contextId ctx) ct of+ Nothing -> trace "insertUnmanaged/context not found" $ insertContext ctx ct+ Just mt -> return (ct, mt)+ blocking $ R.insertUnmanaged mt arr ptr++insertContext+ :: Context+ -> MT+ -> CRM ( MT, R.MemoryTable CUDA.DevicePtr Task )+insertContext ctx ct = liftIO $ do+ mt <- R.new (\p -> bracket_ (push ctx) pop (CUDA.free p))+ return (IM.insert (contextId ctx) mt ct, mt)+++-- Removing entries+-- ----------------++-- Initiate garbage collection and finalise any arrays that have been marked as+-- unreachable.+--+reclaim :: MemoryTable -> IO ()+reclaim (MemoryTable _ ref) = withMVar ref (blocking . mapM_ R.reclaim . IM.elems)++-- Miscellaneous+-- -------------++{-# INLINE contextId #-}+contextId :: Context -> Int+contextId !ctx =+ let CUDA.Context !p = unsafeGetValue (deviceContext ctx)+ in fromIntegral (ptrToIntPtr p)++{-# INLINE blocking #-}+blocking :: CRM a -> IO a+blocking = flip runReaderT Nothing++{-# INLINE streaming #-}+streaming :: Maybe Stream -> CRM a -> IO a+streaming = flip runReaderT++{-# INLINE sizeOfPtr #-}+sizeOfPtr :: forall a. Storable a => CUDA.DevicePtr a -> Int+sizeOfPtr _ = sizeOf (undefined :: a)++-- Debug+-- -----++{-# INLINE trace #-}+trace :: MonadIO m => String -> m a -> m a+trace msg next = message msg >> next++{-# INLINE message #-}+message :: MonadIO m => String -> m ()+message msg = liftIO $ Debug.traceIO Debug.dump_gc ("gc/lru: " ++ msg)++{-# INLINE showBytes #-}+showBytes :: Int -> String+showBytes x = Debug.showFFloatSIBase (Just 0) 1024 (fromIntegral x :: Double) "B"++{-# INLINE transfer #-}+transfer :: String -> Int -> IO () -> IO ()+transfer name bytes action+ = let showRate x t = Debug.showFFloatSIBase (Just 3) 1024 (fromIntegral x / t) "B/s"+ msg gpuTime cpuTime = "gc/lru: " ++ name ++ ": "+ ++ showBytes bytes ++ " @ " ++ showRate bytes gpuTime ++ ", "+ ++ Debug.elapsed gpuTime cpuTime+ in+ Debug.timed Debug.dump_gc msg Nothing action+
+ Data/Array/Accelerate/CUDA/Array/Slice.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE GADTs #-}+-- |+-- Module : Data.Array.Accelerate.Array.Slice+--+-- Maintainer : Frederik Meisner Madsen <fmma@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.CUDA.Array.Slice (++ transferDesc, blocksOf,++ TransferDesc(..)++) where++import Control.Arrow ( first )+import Data.List ( groupBy, elemIndex )+import Data.Array.Accelerate.Array.Representation ( SliceIndex(..) )+++-- Slicing algorithm.++-- Figure out how to transfer a multi-dimensional slice from a+-- multi-dimensional array of the same or higher dimensionality to a+-- contiguous memory region. The algorithm uses as few data transfers+-- as possible, where a linear memory copy with a stride consitutes+-- one transfer (cudaMemcpy2d). Each transfer is described by four+-- numbers: A start, a stride, a number of basic blocks and block+-- size.+--++-- Memory transfer(s) description suitable for (multiple calls to)+-- cudaMemcpu2D. The number of calls necessary is given by the length+-- of the starting offsets. The unit is basic elements of the target+-- array.+data TransferDesc =+ TransferDesc { starts :: [Int] -- Starting offsets.+ , stride :: Int -- Stride.+ , nblocks :: Int -- Number of blocks.+ , blocksize :: Int } -- Elements per block.+ deriving Show++-- Get the basic blocks of the given transfer descriptions, described+-- as offset and length. This function can be used to do a memory copy+-- with only contiguous data transfers, if a strided transfer is not+-- available.+blocksOf :: TransferDesc -> [(Int, Int, Int)]+blocksOf tdesc =+ [ ( start + i * stride tdesc+ , i * blocksize tdesc+ , blocksize tdesc)+ | start <- starts tdesc+ , i <- [0..nblocks tdesc-1]]++-- A slice index in one dimension, annotated with information used to+-- catogorize how the dimension is transferred.+type SliceIR = ( TransferType -- Transfer type annotation.+ , Int ) -- Size of this dimension.++data TransferType =+ Strided -- Transfer the entire dimension. Each element+ -- will be transfered in a different block, but in+ -- a single transfer.++ | Contiguous -- Transfer the entire dimension in one+ -- contiguous data transfer. Each element will+ -- be transfered in the same block in the same+ -- transfer.++ | Fixed Int -- Transfer a specific element in this+ -- dimension. The argument is the element index.++ | FixedAll -- Transfer the entire dimension. Each element+ -- will be transfered in a seperate data+ -- transfer.++-- Convert a slice index to internal representation used by this+-- algorithm. Initially, all dimensions are represented as strided+-- (transfer entire dimension) or fixed (transfer specific element).++toIR :: SliceIndex slix sl co dim+ -> slix+ -> dim+ -> [SliceIR]+toIR SliceNil () () = []+toIR (SliceAll si) (sl, ()) (sh, n) = (Strided, n):toIR si sl sh+toIR (SliceFixed si) (sl, i ) (sh, n) = (Fixed i, n):toIR si sl sh+{-+toIR :: SliceIndex slix sl co dim+ -> slix+ -> dim+ -> [SliceIR]+toIR slix sl dim =+ f slix sl dim []+ where+ f :: SliceIndex slix' sl' co' dim'+ -> slix'+ -> dim'+ -> [SliceIR]+ -> [SliceIR]+ f SliceNil () () res = res+ f (SliceAll si) (sl, ()) (sh, n) res = f si sl sh ((Strided, n):res)+ f (SliceFixed si) (sl, i ) (sh, n) res = f si sl sh ((Fixed i, n):res)+-}++-- Promote strided slice indices to contiguous slice indices when+-- possible (= all strided innermost dimensions).+strideToContiguous :: [SliceIR] -> [SliceIR]+strideToContiguous slirs =+ let (strided, rest) = span (isStrided . fst) slirs+ conti = map (first promote) strided+ in conti ++ rest+ where+ isStrided Strided = True+ isStrided _ = False++ promote Strided = Contiguous+ promote x = x++-- Find largest group (= next to each other) of strided slice+-- indices. Promote all other strided groups to fixed groups, which+-- entails multiple data transfers in these dimensions. This is+-- necessary step, since it is impossible to describe the memory+-- transfer with the given transfer description type in some+-- situations (namely when there is a gap between strided+-- dimensions). This step chooses the split that results in fewest+-- possible data transfers by selecting the largest stride pivot.+selectStridePivot :: [SliceIR] -> [SliceIR]+selectStridePivot slirs =+ let -- Group the slice dimensions in groups of same transfer types.+ groups = groupBy sameTransferType slirs++ -- Calculate the sizes of the strided groups, ignore the rest.+ sizes = map (product . map stridedSize) groups++ -- Find the largest strided group.+ Just imax = elemIndex (maximum sizes) sizes++ -- Promote the remaining strided groups to fixed groups using+ -- multiple data transfers.+ (groups1, pivotGroup:groups2) = splitAt imax groups++ groups' = map (map (first promote)) groups1 ++ pivotGroup:map (map (first promote)) groups2++ in concat groups'+ where+ sameTransferType :: SliceIR -> SliceIR -> Bool+ sameTransferType x y = fst x ~= fst y+ where+ (~=) :: TransferType -> TransferType -> Bool+ Contiguous ~= Contiguous = True+ Strided ~= Strided = True+ Fixed _ ~= Fixed _ = True+ FixedAll ~= FixedAll = True+ _ ~= _ = False++ promote :: TransferType -> TransferType+ promote Strided = FixedAll+ promote x = x++ stridedSize :: SliceIR -> Int+ stridedSize (Strided, n) = n+ stridedSize _ = 0++-- Compute a description of the transfers necessary to copy the+-- specified slice.+transferDesc :: SliceIndex slix sl co dim+ -> slix -- Slice index.+ -> dim -- Full shape.+ -> TransferDesc+transferDesc slix sl dim =+ let slirs = selectStridePivot $ strideToContiguous $ toIR slix sl dim+ tdesc0 = TransferDesc [0] 1 1 1+ size0 = 1+ in f slirs size0 tdesc0+ where+ f :: [SliceIR] -> Int -> TransferDesc -> TransferDesc+ f slirs m tdesc =+ case slirs of+ [] -> tdesc++ (ttyp, n):slirs' -> f slirs' (n * m) $+ case ttyp of+ Strided ->+ TransferDesc+ { starts = starts tdesc+ , stride = if stride tdesc == 1 then m else stride tdesc+ , nblocks = n * nblocks tdesc+ , blocksize = blocksize tdesc }++ Contiguous ->+ TransferDesc+ { starts = starts tdesc+ , stride = stride tdesc+ , nblocks = nblocks tdesc+ , blocksize = n * blocksize tdesc }++ Fixed i ->+ TransferDesc+ { starts = [start + i * m | start <- starts tdesc]+ , stride = stride tdesc+ , nblocks = nblocks tdesc+ , blocksize = blocksize tdesc }++ FixedAll ->+ TransferDesc+ { starts = [start + i * m | start <- starts tdesc, i <- [0..n-1]]+ , stride = stride tdesc+ , nblocks = nblocks tdesc+ , blocksize = blocksize tdesc }
Data/Array/Accelerate/CUDA/Array/Sugar.hs view
@@ -1,7 +1,7 @@ -- | -- Module : Data.Array.Accelerate.CUDA.Array.Sugar--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>@@ -12,22 +12,24 @@ module Data.Array.Accelerate.CUDA.Array.Sugar ( module Data.Array.Accelerate.Array.Sugar,- newArray, allocateArray, useArray, useArrayAsync,+ fromFunction, allocateArray, useArray, useArrayAsync, ) where +import Control.Monad.Trans+ import Data.Array.Accelerate.CUDA.State import Data.Array.Accelerate.CUDA.Array.Data-import Data.Array.Accelerate.Array.Sugar hiding (newArray, allocateArray)+import Data.Array.Accelerate.Array.Sugar hiding ( fromFunction, allocateArray ) import qualified Data.Array.Accelerate.Array.Sugar as Sugar -- Create an array from its representation function, uploading the result to the -- device ---newArray :: (Shape sh, Elt e) => sh -> (sh -> e) -> CIO (Array sh e)-newArray sh f =- let arr = Sugar.newArray sh f+fromFunction :: (Shape sh, Elt e) => sh -> (sh -> e) -> CIO (Array sh e)+fromFunction sh f =+ let arr = Sugar.fromFunction sh f in do useArray arr return arr@@ -36,9 +38,8 @@ -- Allocate a new, uninitialised Accelerate array on host and device -- allocateArray :: (Shape dim, Elt e) => dim -> CIO (Array dim e)-allocateArray sh =- let arr = Sugar.allocateArray sh- in do- mallocArray arr- return arr+allocateArray sh = do+ arr <- liftIO $ Sugar.allocateArray sh+ mallocArray arr+ return arr
− Data/Array/Accelerate/CUDA/Array/Table.hs
@@ -1,291 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE ScopedTypeVariables #-}--- |--- Module : Data.Array.Accelerate.CUDA.Array.Table--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell--- License : BSD3------ Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability : experimental--- Portability : non-portable (GHC extensions)-----module Data.Array.Accelerate.CUDA.Array.Table (-- -- Tables for host/device memory associations- MemoryTable, new, lookup, malloc, insert, insertRemote, reclaim--) where--import Prelude hiding ( lookup )-import Data.Maybe ( isJust )-import Data.Hashable ( Hashable(..) )-import Data.Typeable ( Typeable, gcast )-import Control.Monad ( unless )-import Control.Concurrent ( yield )-import Control.Concurrent.MVar ( MVar, newMVar, withMVar, mkWeakMVar )-import Control.Exception ( bracket_, catch, throwIO )-import Control.Applicative ( (<$>) )-import System.Mem ( performGC )-import System.Mem.Weak ( Weak, mkWeak, deRefWeak, finalize )-import System.Mem.StableName ( StableName, makeStableName, hashStableName )-import Foreign.Ptr ( ptrToIntPtr )-import Foreign.Storable ( Storable, sizeOf )-import Foreign.CUDA.Ptr ( DevicePtr )--import Foreign.CUDA.Driver.Error-import qualified Foreign.CUDA.Driver as CUDA-import qualified Data.HashTable.IO as HT--import Data.Array.Accelerate.Array.Data ( ArrayData )-import Data.Array.Accelerate.CUDA.Context ( Context, weakContext, deviceContext )-import Data.Array.Accelerate.CUDA.Array.Nursery ( Nursery(..), NRS )-import qualified Data.Array.Accelerate.CUDA.Array.Nursery as N-import qualified Data.Array.Accelerate.CUDA.Debug as D--#include "accelerate.h"----- We use an MVar to the hash table, so that several threads may safely access--- it concurrently. This includes the finalisation threads that remove entries--- from the table.------ It is important that we can garbage collect old entries from the table when--- the key is no longer reachable in the heap. Hence the value part of each--- table entry is a (Weak val), where the stable name 'key' is the key for the--- memo table, and the 'val' is the value of this table entry. When the key--- becomes unreachable, a finaliser will fire and remove this entry from the--- hash buckets, and further attempts to dereference the weak pointer will--- return Nothing. References from 'val' to the key are ignored (see the--- semantics of weak pointers in the documentation).----type HashTable key val = HT.BasicHashTable key val-type MT = MVar ( HashTable HostArray DeviceArray )-data MemoryTable = MemoryTable {-# UNPACK #-} !MT- {-# UNPACK #-} !(Weak MT)- {-# UNPACK #-} !Nursery---- Arrays on the host and device----type ContextId = Int--data HostArray where- HostArray :: Typeable e- => {-# UNPACK #-} !ContextId -- unique ID relating to the parent context- -> {-# UNPACK #-} !(StableName (ArrayData e))- -> HostArray--data DeviceArray where- DeviceArray :: Typeable e- => {-# UNPACK #-} !(Weak (DevicePtr e))- -> DeviceArray--instance Eq HostArray where- HostArray _ a1 == HostArray _ a2- = maybe False (== a2) (gcast a1)--instance Hashable HostArray where- {-# INLINE hashWithSalt #-}- hashWithSalt salt (HostArray cid sn)- = salt `hashWithSalt` cid `hashWithSalt` sn--instance Show HostArray where- show (HostArray _ sn) = "Array #" ++ show (hashStableName sn)----- Referencing arrays--- ---------------------- Create a new hash table from host to device arrays. When the structure is--- collected it will finalise all entries in the table.----new :: IO MemoryTable-new = do- message "initialise memory table"- tbl <- HT.new- ref <- newMVar tbl- nrs <- N.new- weak <- mkWeakMVar ref (table_finalizer tbl)- return $! MemoryTable ref weak nrs----- Look for the device memory corresponding to a given host-side array.----lookup :: (Typeable a, Typeable b) => Context -> MemoryTable -> ArrayData a -> IO (Maybe (DevicePtr b))-lookup ctx (MemoryTable !ref _ _) !arr = do- sa <- makeStableArray ctx arr- mw <- withMVar ref (`HT.lookup` sa)- case mw of- Nothing -> trace ("lookup/not found: " ++ show sa) $ return Nothing- Just (DeviceArray w) -> do- mv <- deRefWeak w- case mv of- Just v | Just p <- gcast v -> trace ("lookup/found: " ++ show sa) $ return (Just p)- | otherwise -> INTERNAL_ERROR(error) "lookup" $ "type mismatch"-- -- Note: [Weak pointer weirdness]- --- -- After the lookup is successful, there might conceivably be no further- -- references to 'arr'. If that is so, and a garbage collection- -- intervenes, the weak pointer might get tombstoned before 'deRefWeak'- -- gets to it. In that case we throw an error (below). However, because- -- we have used 'arr' in the continuation, this ensures that 'arr' is- -- reachable in the continuation of 'deRefWeak' and thus 'deRefWeak'- -- always succeeds. This sort of weirdness, typical of the world of weak- -- pointers, is why we can not reuse the stable name 'sa' computed- -- above in the error message.- --- Nothing ->- makeStableArray ctx arr >>= \x -> INTERNAL_ERROR(error) "lookup" $ "dead weak pair: " ++ show x----- Allocate a new device array to be associated with the given host-side array.--- This will attempt to use an old array from the nursery, but will otherwise--- allocate fresh data.------ Instead of allocating the exact number of elements requested, we round up to--- a fixed chunk size; currently set at 128 elements. This means there is a--- greater chance the nursery will get a hit, and moreover that we can search--- the nursery for an exact size. TLM: I believe the CUDA API allocates in--- chunks, of size 4MB.----malloc :: forall a b. (Typeable a, Typeable b, Storable b) => Context -> MemoryTable -> ArrayData a -> Int -> IO (DevicePtr b)-malloc !ctx mt@(MemoryTable _ _ !nursery) !ad !n = do- let -- next highest multiple of f from x- multiple x f = floor ((x + (f-1)) / f :: Double)- chunk = 128-- !n' = chunk * multiple (fromIntegral n) (fromIntegral chunk)- !bytes = n' * sizeOf (undefined :: b)- --- mp <- N.malloc bytes (deviceContext ctx) nursery- ptr <- case mp of- Just p -> trace "malloc/nursery" $ return (CUDA.castDevPtr p)- Nothing -> trace "malloc/new" $- CUDA.mallocArray n' `catch` \(e :: CUDAException) ->- case e of- ExitCode OutOfMemory -> reclaim mt >> CUDA.mallocArray n'- _ -> throwIO e- insert ctx mt ad ptr bytes- return ptr----- Record an association between a host-side array and a new device memory area.--- The device memory will be freed when the host array is garbage collected.----insert :: (Typeable a, Typeable b) => Context -> MemoryTable -> ArrayData a -> DevicePtr b -> Int -> IO ()-insert !ctx (MemoryTable !ref !weak_ref (Nursery _ !weak_nrs)) !arr !ptr !bytes = do- key <- makeStableArray ctx arr- dev <- DeviceArray `fmap` mkWeak arr ptr (Just $ finalizer (weakContext ctx) weak_ref weak_nrs key ptr bytes)- message $ "insert: " ++ show key- withMVar ref $ \tbl -> HT.insert tbl key dev----- Record an association between a host-side array and a device memory area that was--- not allocated by accelerate. The device memory will NOT be freed when the host--- array is garbage collected.----insertRemote :: (Typeable a, Typeable b) => Context -> MemoryTable -> ArrayData a -> DevicePtr b -> IO ()-insertRemote !ctx (MemoryTable !ref !weak_ref _) !arr !ptr = do- key <- makeStableArray ctx arr- dev <- DeviceArray `fmap` mkWeak arr ptr (Just $ remoteFinalizer weak_ref key)- message $ "insert/remote: " ++ show key- withMVar ref $ \tbl -> HT.insert tbl key dev----- Removing entries--- -------------------- Initiate garbage collection and finalise any arrays that have been marked as--- unreachable.----reclaim :: MemoryTable -> IO ()-reclaim (MemoryTable _ weak_ref (Nursery nrs _)) = do- (free, total) <- CUDA.getMemInfo- performGC- yield- withMVar nrs N.flush- mr <- deRefWeak weak_ref- case mr of- Nothing -> return ()- Just ref -> withMVar ref $ \tbl ->- flip HT.mapM_ tbl $ \(_,DeviceArray w) -> do- alive <- isJust `fmap` deRefWeak w- unless alive $ finalize w- --- D.when D.dump_gc $ do- (free', _) <- CUDA.getMemInfo- message $ "reclaim: freed " ++ showBytes (fromIntegral (free - free'))- ++ ", " ++ showBytes (fromIntegral free')- ++ " of " ++ showBytes (fromIntegral total) ++ " remaining"---- Because a finaliser might run at any time, we must reinstate the context in--- which the array was allocated before attempting to release it.------ Note also that finaliser threads will silently terminate if an exception is--- raised. If the context, and thereby all allocated memory, was destroyed--- externally before the thread had a chance to run, all we need do is update--- the hash tables --- but we must do this first before failing to use a dead--- context.----finalizer :: Weak CUDA.Context -> Weak MT -> Weak NRS -> HostArray -> DevicePtr b -> Int -> IO ()-finalizer !weak_ctx !weak_ref !weak_nrs !key !ptr !bytes = do- mr <- deRefWeak weak_ref- case mr of- Nothing -> message ("finalise/dead table: " ++ show key)- Just ref -> withMVar ref (`HT.delete` key)- --- mc <- deRefWeak weak_ctx- case mc of- Nothing -> message ("finalise/dead context: " ++ show key)- Just ctx -> do- --- mn <- deRefWeak weak_nrs- case mn of- Nothing -> trace ("finalise/free: " ++ show key) $ bracket_ (CUDA.push ctx) CUDA.pop (CUDA.free ptr)- Just nrs -> trace ("finalise/nursery: " ++ show key) $ N.stash bytes ctx nrs ptr--remoteFinalizer :: Weak MT -> HostArray -> IO ()-remoteFinalizer !weak_ref !key = do- mr <- deRefWeak weak_ref- case mr of- Nothing -> message ("finalise/dead table: " ++ show key)- Just ref -> trace ("finalise: " ++ show key) $ withMVar ref (`HT.delete` key)--table_finalizer :: HashTable HostArray DeviceArray -> IO ()-table_finalizer !tbl- = trace "table finaliser"- $ HT.mapM_ (\(_,DeviceArray w) -> finalize w) tbl----- Miscellaneous--- ---------------{-# INLINE makeStableArray #-}-makeStableArray :: Typeable a => Context -> ArrayData a -> IO HostArray-makeStableArray !ctx !arr =- let CUDA.Context !p = deviceContext ctx- !cid = fromIntegral (ptrToIntPtr p)- in- HostArray cid <$> makeStableName arr----- Debug--- -------{-# INLINE showBytes #-}-showBytes :: Int -> String-showBytes x = D.showFFloatSIBase (Just 0) 1024 (fromIntegral x :: Double) "B"--{-# INLINE trace #-}-trace :: String -> IO a -> IO a-trace msg next = D.message D.dump_gc ("gc: " ++ msg) >> next--{-# INLINE message #-}-message :: String -> IO ()-message s = s `trace` return ()-
− Data/Array/Accelerate/CUDA/Async.hs
@@ -1,56 +0,0 @@-{-# LANGUAGE CPP #-}--- |--- Module : Data.Array.Accelerate.CUDA.Async--- Copyright : [2009..2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell--- License : BSD3------ Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability : experimental--- Portability : non-portable (GHC extensions)-----module Data.Array.Accelerate.CUDA.Async- where--import Control.Exception-import Control.Concurrent----- We need to execute the main thread asynchronously to give finalisers a chance--- to run. Make sure to catch exceptions to avoid "blocked indefinitely on MVar"--- errors.----data Async a = Async {-# UNPACK #-} !ThreadId- {-# UNPACK #-} !(MVar (Either SomeException a))---- | Fork an action to execute asynchronously.----async :: IO a -> IO (Async a)-async action = do- var <- newEmptyMVar- tid <- forkIO $ (putMVar var . Right =<< action)- `catch`- \e -> putMVar var (Left e)- return (Async tid var)---- | Block the calling thread until the computation completes, then return the--- result.----{-# INLINE wait #-}-wait :: Async a -> IO a-wait (Async _ var) = either throwIO return =<< readMVar var---- | Test whether the asynchronous computation has already completed. If so,--- return the result, else 'Nothing'.----{-# INLINE poll #-}-poll :: Async a -> IO (Maybe a)-poll (Async _ var) =- maybe (return Nothing) (either throwIO (return . Just)) =<< tryTakeMVar var---- | Cancel a running asynchronous computation.----{-# INLINE cancel #-}-cancel :: Async a -> IO ()-cancel (Async tid _) = throwTo tid ThreadKilled-
Data/Array/Accelerate/CUDA/CodeGen.hs view
@@ -1,14 +1,15 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-} {-# OPTIONS -fno-warn-name-shadowing #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>@@ -18,34 +19,35 @@ module Data.Array.Accelerate.CUDA.CodeGen ( - CUTranslSkel, codegenAcc,+ CUTranslSkel, codegenAcc, codegenToSeq ) where -- libraries-import Prelude hiding ( id, exp, replicate )-import Control.Applicative ( (<$>), (<*>) )-import Control.Monad.State.Strict-import Data.Loc-import Data.Char import Data.HashSet ( HashSet )+import Control.Monad.State.Strict import Foreign.CUDA.Analysis import Language.C.Quote.CUDA import qualified Language.C as C import qualified Data.HashSet as Set+import Control.Applicative hiding ( Const )+import Prelude hiding ( id, exp, replicate ) -- friends+import Data.Array.Accelerate.Error import Data.Array.Accelerate.Type-import Data.Array.Accelerate.Tuple+import Data.Array.Accelerate.Product import Data.Array.Accelerate.Trafo import Data.Array.Accelerate.Pretty () import Data.Array.Accelerate.Analysis.Shape-import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt, EltRepr )+import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt, EltRepr+ , Tuple(..), TupleRepr ) import Data.Array.Accelerate.Array.Representation ( SliceIndex(..) ) import qualified Data.Array.Accelerate.Array.Sugar as Sugar import qualified Data.Array.Accelerate.Analysis.Type as Sugar import Data.Array.Accelerate.CUDA.AST hiding ( Val(..), prj )+import Data.Array.Accelerate.CUDA.CodeGen.Constant import Data.Array.Accelerate.CUDA.CodeGen.Base import Data.Array.Accelerate.CUDA.CodeGen.Type import Data.Array.Accelerate.CUDA.CodeGen.Monad@@ -54,9 +56,9 @@ import Data.Array.Accelerate.CUDA.CodeGen.PrefixSum import Data.Array.Accelerate.CUDA.CodeGen.Reduction import Data.Array.Accelerate.CUDA.CodeGen.Stencil+import Data.Array.Accelerate.CUDA.CodeGen.Streaming import Data.Array.Accelerate.CUDA.Foreign.Import ( canExecuteExp )--#include "accelerate.h"+import qualified Data.Array.Accelerate.CUDA.CodeGen.Arithmetic as A -- Local environments@@ -68,7 +70,7 @@ prj :: Idx env t -> Val env -> [C.Exp] prj ZeroIdx (Push _ v) = v prj (SuccIdx ix) (Push val _) = prj ix val-prj _ _ = INTERNAL_ERROR(error) "prj" "inconsistent valuation"+prj _ _ = $internalError "prj" "inconsistent valuation" -- Array expressions@@ -87,7 +89,7 @@ -- TODO: include a measure of how much shared memory a kernel requires. -- codegenAcc :: forall aenv arrs. DeviceProperties -> DelayedOpenAcc aenv arrs -> Gamma aenv -> [ CUTranslSkel aenv arrs ]-codegenAcc _ Delayed{} _ = INTERNAL_ERROR(error) "codegenAcc" "expected manifest array"+codegenAcc _ Delayed{} _ = $internalError "codegenAcc" "expected manifest array" codegenAcc dev (Manifest pacc) aenv = codegen $ case pacc of@@ -113,6 +115,9 @@ Stencil f b a -> mkStencil dev aenv <$> travF1 f <*> travB a b Stencil2 f b1 a1 b2 a2 -> mkStencil2 dev aenv <$> travF2 f <*> travB a1 b1 <*> travB a2 b2 + -- Sequence collection+ -- Collect _ -> unexpectedError+ -- Non-computation forms -> sadness Alet{} -> unexpectedError Avar{} -> unexpectedError@@ -144,7 +149,7 @@ -- code generation for delayed arrays travD :: (Shape sh, Elt e) => DelayedOpenAcc aenv (Array sh e) -> CUDA (CUDelayedAcc aenv sh e)- travD Manifest{} = INTERNAL_ERROR(error) "codegenAcc" "expected delayed array"+ travD Manifest{} = $internalError "codegenAcc" "expected delayed array" travD Delayed{..} = CUDelayed <$> travE extentD <*> travF1 indexD <*> travF1 linearIndexD@@ -164,15 +169,47 @@ travB _ Clamp = return Clamp travB _ Mirror = return Mirror travB _ Wrap = return Wrap- travB _ (Constant c) = return . Constant $ CUExp ([], codegenConst (Sugar.eltType (undefined::e)) c)+ travB _ (Constant c) = return . Constant $ CUExp ([], constant (Sugar.eltType (undefined::e)) c) -- caffeine and misery prim :: String prim = showPreAccOp pacc- unexpectedError = INTERNAL_ERROR(error) "codegenAcc" $ "unexpected array primitive: " ++ prim- fusionError = INTERNAL_ERROR(error) "codegenAcc" $ "unexpected fusible material: " ++ prim+ unexpectedError = $internalError "codegenAcc" $ "unexpected array primitive: " ++ prim+ fusionError = $internalError "codegenAcc" $ "unexpected fusible material: " ++ prim +codegenToSeq :: forall aenv slix sl co sh e. (Shape sl, Shape sh, Elt e)+ => SliceIndex slix+ (EltRepr sl)+ co+ (EltRepr sh)+ -> DeviceProperties+ -> DelayedOpenAcc aenv (Array sh e)+ -> Gamma aenv+ -> CUTranslSkel aenv (Array sl e)+codegenToSeq slix dev acc aenv = codegen $ (mkToSeq slix dev aenv <$> travD acc)+ where+ codegen :: CUDA (CUTranslSkel aenv (Array sl e)) -> CUTranslSkel aenv (Array sl e)+ codegen cuda =+ let (skeleton, st) = runCUDA cuda+ addTo (CUTranslSkel name code) =+ CUTranslSkel name (Set.foldr (\h c -> [cedecl| $esc:("#include \"" ++ h ++ "\"") |] : c) code (headers st))+ in+ addTo skeleton + -- code generation for delayed arrays+ travD :: (Shape sh, Elt e) => DelayedOpenAcc aenv (Array sh e) -> CUDA (CUDelayedAcc aenv sh e )+ travD Manifest{} = $internalError "codegenAcc" "expected delayed array"+ travD Delayed{..} = CUDelayed <$> travE extentD+ <*> travF1 indexD+ <*> travF1 linearIndexD++ travE :: forall t. DelayedExp aenv t -> CUDA (CUExp aenv t)+ travE = codegenExp dev aenv++ travF1 :: forall a b. DelayedFun aenv (a -> b) -> CUDA (CUFun1 aenv (a -> b))+ travF1 = codegenFun1 dev aenv++ -- Scalar function abstraction -- --------------------------- @@ -214,7 +251,7 @@ $ \xs -> evalState (evalCGM (go xs)) n -- | otherwise- = INTERNAL_ERROR(error) "codegenFun1" "expected unary function"+ = $internalError "codegenFun1" "expected unary function" codegenFun2@@ -240,7 +277,7 @@ $ \xs ys -> evalState (evalCGM (go xs ys)) n -- | otherwise- = INTERNAL_ERROR(error) "codegenFun2" "expected binary function"+ = $internalError "codegenFun2" "expected binary function" -- It is important to filter output terms of a function that will not be used.@@ -314,9 +351,9 @@ case exp of Let bnd body -> elet bnd body env Var ix -> return $ prj ix env- PrimConst c -> return $ [codegenPrimConst c]- Const c -> return $ codegenConst (Sugar.eltType (undefined::t)) c- PrimApp f arg -> return . codegenPrim f <$> cvtE arg env+ PrimConst c -> return $ [primConst c]+ Const c -> return $ constant (Sugar.eltType (undefined::t)) c+ PrimApp f x -> primApp f x env Tuple t -> cvtT t env Prj i t -> prjT i t exp env Cond p t e -> cond p t e env@@ -339,6 +376,7 @@ Shape acc -> shape acc env ShapeSize sh -> shapeSize sh env Intersect sh1 sh2 -> intersect sh1 sh2 env+ Union sh1 sh2 -> union sh1 sh2 env --Foreign function Foreign ff _ e -> foreignE ff e env@@ -361,6 +399,119 @@ body' <- cvtE body (env `Push` bnd') return body' + -- When evaluating primitive functions, we evaluate each argument to the+ -- operation as a statement expression. This is necessary to ensure proper+ -- short-circuit behaviour for logical operations.+ --+ primApp :: PrimFun (a -> b) -> DelayedOpenExp env aenv a -> Val env -> Gen [C.Exp]+ primApp f x env =+ case f of+ -- operators from Num+ PrimAdd{} -> binary A.add x env+ PrimSub{} -> binary A.sub x env+ PrimMul{} -> binary A.mul x env+ PrimNeg{} -> unary A.negate x env+ PrimAbs ty -> unary (A.abs ty) x env+ PrimSig ty -> unaryM (A.signum ty) x env+ -- operators from Integral & Bits+ PrimQuot{} -> binary A.quot x env+ PrimRem{} -> binary A.rem x env+ PrimQuotRem ty -> binaryM2 (A.quotRem ty) x env+ PrimIDiv ty -> binaryM (A.idiv ty) x env+ PrimMod ty -> binaryM (A.mod ty) x env+ PrimDivMod ty -> binaryM2 (A.divMod ty) x env+ PrimBAnd{} -> binary A.band x env+ PrimBOr{} -> binary A.bor x env+ PrimBXor{} -> binary A.xor x env+ PrimBNot{} -> unary A.bnot x env+ PrimBShiftL{} -> binary A.shiftL x env+ PrimBShiftR{} -> binary A.shiftRA x env+ PrimBRotateL ty -> binaryM (A.rotateL ty) x env+ PrimBRotateR ty -> binaryM (A.rotateR ty) x env+ -- operators from Fractional and Floating+ PrimFDiv{} -> binary A.fdiv x env+ PrimRecip ty -> unary (A.recip ty) x env+ PrimSin ty -> unary (A.sin ty) x env+ PrimCos ty -> unary (A.cos ty) x env+ PrimTan ty -> unary (A.tan ty) x env+ PrimAsin ty -> unary (A.asin ty) x env+ PrimAcos ty -> unary (A.acos ty) x env+ PrimAtan ty -> unary (A.atan ty) x env+ PrimSinh ty -> unary (A.sinh ty) x env+ PrimCosh ty -> unary (A.cosh ty) x env+ PrimTanh ty -> unary (A.tanh ty) x env+ PrimAsinh ty -> unary (A.asinh ty) x env+ PrimAcosh ty -> unary (A.acosh ty) x env+ PrimAtanh ty -> unary (A.atanh ty) x env+ PrimExpFloating ty -> unary (A.exp ty) x env+ PrimSqrt ty -> unary (A.sqrt ty) x env+ PrimLog ty -> unary (A.log ty) x env+ PrimFPow ty -> binary (A.pow ty) x env+ PrimLogBase ty -> binary (A.logBase ty) x env+ -- operators from RealFrac+ PrimTruncate ta tb -> unary (A.trunc ta tb) x env+ PrimRound ta tb -> unary (A.round ta tb) x env+ PrimFloor ta tb -> unary (A.floor ta tb) x env+ PrimCeiling ta tb -> unary (A.ceiling ta tb) x env+ -- operators from RealFloat+ PrimAtan2 ty -> binary (A.atan2 ty) x env+ PrimIsNaN{} -> unary A.isNaN x env+ -- relational and equality operators+ PrimLt{} -> binary A.lt x env+ PrimGt{} -> binary A.gt x env+ PrimLtEq{} -> binary A.leq x env+ PrimGtEq{} -> binary A.geq x env+ PrimEq{} -> binary A.eq x env+ PrimNEq{} -> binary A.neq x env+ PrimMax ty -> binary (A.max ty) x env+ PrimMin ty -> binary (A.min ty) x env+ -- logical operators+ PrimLAnd -> binary A.land x env+ PrimLOr -> binary A.lor x env+ PrimLNot -> unary A.lnot x env+ -- type conversions+ PrimOrd -> unary A.ord x env+ PrimChr -> unary A.chr x env+ PrimBoolToInt -> unary A.boolToInt x env+ PrimFromIntegral ta tb -> unary (A.fromIntegral ta tb) x env+ where+ cvtE' :: DelayedOpenExp env aenv a -> Val env -> Gen C.Exp+ cvtE' e env = do+ (b,r) <- clean $ single "primApp" <$> cvtE e env+ if null b+ then return r+ else return [cexp| ({ $items:b; $exp:r; }) |]++ -- TLM: This is a bit ugly. Consider making all primitive functions from+ -- Arithmetic.hs evaluate in the Gen monad.+ --+ unary :: (C.Exp -> C.Exp) -> DelayedOpenExp env aenv a -> Val env -> Gen [C.Exp]+ unary f = unaryM (return . f)++ unaryM :: (C.Exp -> Gen C.Exp) -> DelayedOpenExp env aenv a -> Val env -> Gen [C.Exp]+ unaryM f a env = do+ a' <- cvtE' a env+ r <- f a'+ return [r]++ binary :: (C.Exp -> C.Exp -> C.Exp) -> DelayedOpenExp env aenv (a,b) -> Val env -> Gen [C.Exp]+ binary f = binaryM (\a b -> return (f a b))++ binaryM :: (C.Exp -> C.Exp -> Gen C.Exp) -> DelayedOpenExp env aenv (a,b) -> Val env -> Gen [C.Exp]+ binaryM f x env = do+ x' <- cvtE x env+ case x' of+ [a,b] -> return <$> f a b+ _ -> $internalError "primApp" "unexpected argument to binary function"++ binaryM2 :: (C.Exp -> C.Exp -> Gen (C.Exp, C.Exp)) -> DelayedOpenExp env aenv (a,b) -> Val env -> Gen [C.Exp]+ binaryM2 f x env = do+ x' <- cvtE x env+ case x' of+ [a,b] -> do (r,s) <- f a b+ return [r,s]+ _ -> $internalError "primApp" "unexpected argument to binary function"+ -- Convert an open expression into a sequence of C expressions. We retain -- snoc-list ordering, so the element at tuple index zero is at the end of -- the list. Note that nested tuple structures are flattened.@@ -395,27 +546,46 @@ prjToInt :: TupleIdx t e -> TupleType a -> Int prjToInt ZeroTupIdx _ = 0 prjToInt (SuccTupIdx i) (b `PairTuple` a) = sizeTupleType a + prjToInt i b- prjToInt _ _ = INTERNAL_ERROR(error) "prjToInt" "inconsistent valuation"+ prjToInt _ _ = $internalError "prjToInt" "inconsistent valuation" sizeTupleType :: TupleType a -> Int sizeTupleType UnitTuple = 0 sizeTupleType (SingleTuple _) = 1 sizeTupleType (PairTuple a b) = sizeTupleType a + sizeTupleType b - -- Scalar conditionals. To keep the return type as an expression list we use- -- the ternery C condition operator (?:). For tuples this is not- -- particularly good, so the least we can do is make sure the predicate- -- result is evaluated only once and bound to a local variable.+ -- Scalar conditionals insert a standard if/else statement block. We don't+ -- use the ternary expression operator (?:) because this forces all+ -- auxiliary bindings for both the true and false branches to always be+ -- evaluated before the correct result is chosen. --- cond :: DelayedOpenExp env aenv Bool+ cond :: forall env t. Elt t+ => DelayedOpenExp env aenv Bool -> DelayedOpenExp env aenv t -> DelayedOpenExp env aenv t- -> Val env -> Gen [C.Exp]- cond p t e env = do+ -> Val env+ -> Gen [C.Exp]+ cond p t f env = do p' <- cvtE p env ok <- single "Cond" <$> pushEnv p p'- zipWith (\a b -> [cexp| $exp:ok ? $exp:a : $exp:b |]) <$> cvtE t env <*> cvtE e env+ ifTrue <- clean $ cvtE t env+ ifFalse <- clean $ cvtE f env + -- Generate names for the result variables, which will be initialised+ -- within each branch of the conditional. Twiddle the names a bit to+ -- avoid clobbering.+ var_r <- lift fresh+ let (_, r, declr) = locals ('l':var_r) (undefined :: t)+ branch = [citem| if ( $exp:ok ) {+ $items:(r .=. ifTrue)+ }+ else {+ $items:(r .=. ifFalse)+ } |]+ : map C.BlockDecl declr++ modify (\s -> s { localBindings = branch ++ localBindings s })+ return r+ -- Value recursion -- while :: forall env a. Elt a@@ -435,9 +605,11 @@ x' <- cvtE x env var_acc <- lift fresh var_ok <- lift fresh+ var_tmp <- lift fresh - let (tn_acc, acc, _) = locals ('l':var_acc) (undefined :: a)- (tn_ok, ok, _) = locals ('l':var_ok) (undefined :: Bool)+ let (_, acc, decl_acc) = locals ('l':var_acc) (undefined :: a)+ (_, ok, decl_ok) = locals ('l':var_ok) (undefined :: Bool)+ (tmp, _, _) = locals ('l':var_tmp) (undefined :: a) -- Generate code for the predicate and body expressions, with the new -- names baked in directly. We can't use 'codegenFun1', because@@ -446,25 +618,24 @@ -- However, we do need to generate the function with a clean set of -- local bindings, and extract and new declarations afterwards. --- let cvtF :: forall env t. Elt t => DelayedOpenExp env aenv t -> Val env -> Gen ([C.BlockItem], [C.Exp])- cvtF e env = do- old <- state (\s -> ( localBindings s, s { localBindings = [] } ))- e' <- cvtE e env- env' <- state (\s -> ( localBindings s, s { localBindings = old } ))- return (reverse env', e')-- p' <- cvtF p (env `Push` acc)- f' <- cvtF f (env `Push` acc)+ p' <- clean $ cvtE p (env `Push` acc)+ f' <- clean $ cvtE f (env `Push` acc) -- Piece it all together. Note that declarations are added to the- -- localBindings in reverse order.+ -- localBindings in reverse order. Also, we have to be careful not to+ -- assign the results of f' direction into acc. Why? If some of the+ -- variables in acc are referenced in f', then we risk overwriting+ -- values that are still needed to computer f'.+ -- let loop = [citem| while ( $exp:(single "while" ok) ) {- $items:(acc .=. f')+ $items:(tmp .=. f')+ $items:(acc .=. tmp) $items:(ok .=. p') } |]- : (ok .=. p')- ++ map (\(t,n) -> [citem| $ty:t $id:n ; |]) tn_ok- ++ zipWith (\(t,n) v -> [citem| $ty:t $id:n = $v ; |]) tn_acc x'+ : reverse (ok .=. p')+ ++ reverse (acc .=. x')+ ++ map C.BlockDecl decl_ok+ ++ map C.BlockDecl decl_acc modify (\s -> s { localBindings = loop ++ localBindings s }) return acc@@ -486,7 +657,7 @@ restrict SliceNil _ _ = [] restrict (SliceAll sliceIdx) slx (sz:sl) = sz : restrict sliceIdx slx sl restrict (SliceFixed sliceIdx) (_:slx) ( _:sl) = restrict sliceIdx slx sl- restrict _ _ _ = INTERNAL_ERROR(error) "IndexSlice" "unexpected shapes"+ restrict _ _ _ = $internalError "IndexSlice" "unexpected shapes" -- slice slix' sh' = reverse $ restrict sliceIndex (reverse slix') (reverse sh') in@@ -505,7 +676,7 @@ extend SliceNil _ _ = [] extend (SliceAll sliceIdx) slx (sz:sh) = sz : extend sliceIdx slx sh extend (SliceFixed sliceIdx) (sz:slx) sh = sz : extend sliceIdx slx sh- extend _ _ _ = INTERNAL_ERROR(error) "IndexFull" "unexpected shapes"+ extend _ _ _ = $internalError "IndexFull" "unexpected shapes" -- replicate slix' sl' = reverse $ extend sliceIndex (reverse slix') (reverse sl') in@@ -555,7 +726,7 @@ return $ zipWith (\t a -> indexArray dev t (cvar a) i) ty arr -- | otherwise- = INTERNAL_ERROR(error) "Index" "expected array variable"+ = $internalError "Index" "expected array variable" linearIndex :: (Shape sh, Elt e)@@ -573,7 +744,7 @@ return $ zipWith (\t a -> indexArray dev t (cvar a) i) ty arr -- | otherwise- = INTERNAL_ERROR(error) "LinearIndex" "expected array variable"+ = $internalError "LinearIndex" "expected array variable" -- Array shapes created in this method refer to the shape of free array -- variables. As such, they are always passed as arguments to the kernel,@@ -587,7 +758,7 @@ = return $ cshape (delayedDim acc) (fst (namesOfAvar aenv idx)) | otherwise- = INTERNAL_ERROR(error) "Shape" "expected array variable"+ = $internalError "Shape" "expected array variable" -- The size of a shape, as the product of the extent in each dimension. The -- definition is inlined, but we could also call the C function helpers.@@ -604,275 +775,67 @@ intersect sh1 sh2 env = zipWith (\a b -> ccall "min" [a,b]) <$> cvtE sh1 env <*> cvtE sh2 env + -- Union of two shapes, taken as the maximum in each dimension.+ --+ union :: forall env sh. Elt sh+ => DelayedOpenExp env aenv sh+ -> DelayedOpenExp env aenv sh+ -> Val env -> Gen [C.Exp]+ union sh1 sh2 env =+ zipWith (\a b -> ccall "max" [a,b]) <$> cvtE sh1 env <*> cvtE sh2 env+ -- Foreign scalar functions. We need to extract any header files that might -- be required so they can be added to the top level definitions. -- -- Additionally, we insert an explicit type cast from the foreign function -- result back into Accelerate types (c.f. Int vs int). --- foreignE :: forall f a b env. (Sugar.Foreign f, Elt a, Elt b)- => f a b+ foreignE :: forall asm a b env. (Sugar.Foreign asm, Elt a, Elt b)+ => asm (a -> b) -> DelayedOpenExp env aenv a -> Val env -> Gen [C.Exp]- foreignE ff x env = case canExecuteExp ff of- Nothing -> INTERNAL_ERROR(error) "codegenOpenExp" "Non-CUDA foreign expression encountered"- Just (hs, f) -> do- lift $ modify (\st -> st { headers = foldl (flip Set.insert) (headers st) hs })- args <- cvtE x env- mapM_ use args- return $ [ccall f (ccastTup (Sugar.eltType (undefined::a)) args)]+ foreignE ff x env =+ case canExecuteExp ff of+ Nothing -> $internalError "codegenOpenExp" "failed to recover foreign function a second time"+ Just (hs, f) -> do+ lift $ modify (\st -> st { headers = foldl (flip Set.insert) (headers st) hs })+ args <- cvtE x env+ mapM_ use args+ return $ [ccall f (ccastTup (Sugar.eltType (undefined::a)) args)] + -- Execute a command in a new environment. The old environment is replaced+ -- on exit, and the result and any new bindings generated are returned.+ --+ clean :: Gen a -> Gen ([C.BlockItem], a)+ clean this = do+ env <- state (\s -> ( localBindings s, s { localBindings = [] } ))+ r <- this+ env' <- state (\s -> ( localBindings s, s { localBindings = env } ))+ return (reverse env', r)+ -- Some terms demand we extract only singly typed expressions -- single :: String -> [C.Exp] -> C.Exp single _ [x] = x- single loc _ = INTERNAL_ERROR(error) loc "expected single expression"----- Scalar Primitives--- -------------------codegenPrimConst :: PrimConst a -> C.Exp-codegenPrimConst (PrimMinBound ty) = codegenMinBound ty-codegenPrimConst (PrimMaxBound ty) = codegenMaxBound ty-codegenPrimConst (PrimPi ty) = codegenPi ty---codegenPrim :: PrimFun p -> [C.Exp] -> C.Exp-codegenPrim (PrimAdd _) [a,b] = [cexp|$exp:a + $exp:b|]-codegenPrim (PrimSub _) [a,b] = [cexp|$exp:a - $exp:b|]-codegenPrim (PrimMul _) [a,b] = [cexp|$exp:a * $exp:b|]-codegenPrim (PrimNeg _) [a] = [cexp| - $exp:a|]-codegenPrim (PrimAbs ty) [a] = codegenAbs ty a-codegenPrim (PrimSig ty) [a] = codegenSig ty a-codegenPrim (PrimQuot _) [a,b] = [cexp|$exp:a / $exp:b|]-codegenPrim (PrimRem _) [a,b] = [cexp|$exp:a % $exp:b|]-codegenPrim (PrimIDiv _) [a,b] = ccall "idiv" [a,b]-codegenPrim (PrimMod _) [a,b] = ccall "mod" [a,b]-codegenPrim (PrimBAnd _) [a,b] = [cexp|$exp:a & $exp:b|]-codegenPrim (PrimBOr _) [a,b] = [cexp|$exp:a | $exp:b|]-codegenPrim (PrimBXor _) [a,b] = [cexp|$exp:a ^ $exp:b|]-codegenPrim (PrimBNot _) [a] = [cexp|~ $exp:a|]-codegenPrim (PrimBShiftL _) [a,b] = [cexp|$exp:a << $exp:b|]-codegenPrim (PrimBShiftR _) [a,b] = [cexp|$exp:a >> $exp:b|]-codegenPrim (PrimBRotateL _) [a,b] = ccall "rotateL" [a,b]-codegenPrim (PrimBRotateR _) [a,b] = ccall "rotateR" [a,b]-codegenPrim (PrimFDiv _) [a,b] = [cexp|$exp:a / $exp:b|]-codegenPrim (PrimRecip ty) [a] = codegenRecip ty a-codegenPrim (PrimSin ty) [a] = ccall (FloatingNumType ty `postfix` "sin") [a]-codegenPrim (PrimCos ty) [a] = ccall (FloatingNumType ty `postfix` "cos") [a]-codegenPrim (PrimTan ty) [a] = ccall (FloatingNumType ty `postfix` "tan") [a]-codegenPrim (PrimAsin ty) [a] = ccall (FloatingNumType ty `postfix` "asin") [a]-codegenPrim (PrimAcos ty) [a] = ccall (FloatingNumType ty `postfix` "acos") [a]-codegenPrim (PrimAtan ty) [a] = ccall (FloatingNumType ty `postfix` "atan") [a]-codegenPrim (PrimAsinh ty) [a] = ccall (FloatingNumType ty `postfix` "asinh") [a]-codegenPrim (PrimAcosh ty) [a] = ccall (FloatingNumType ty `postfix` "acosh") [a]-codegenPrim (PrimAtanh ty) [a] = ccall (FloatingNumType ty `postfix` "atanh") [a]-codegenPrim (PrimExpFloating ty) [a] = ccall (FloatingNumType ty `postfix` "exp") [a]-codegenPrim (PrimSqrt ty) [a] = ccall (FloatingNumType ty `postfix` "sqrt") [a]-codegenPrim (PrimLog ty) [a] = ccall (FloatingNumType ty `postfix` "log") [a]-codegenPrim (PrimFPow ty) [a,b] = ccall (FloatingNumType ty `postfix` "pow") [a,b]-codegenPrim (PrimLogBase ty) [a,b] = codegenLogBase ty a b-codegenPrim (PrimTruncate ta tb) [a] = codegenTruncate ta tb a-codegenPrim (PrimRound ta tb) [a] = codegenRound ta tb a-codegenPrim (PrimFloor ta tb) [a] = codegenFloor ta tb a-codegenPrim (PrimCeiling ta tb) [a] = codegenCeiling ta tb a-codegenPrim (PrimAtan2 ty) [a,b] = ccall (FloatingNumType ty `postfix` "atan2") [a,b]-codegenPrim (PrimLt _) [a,b] = [cexp|$exp:a < $exp:b|]-codegenPrim (PrimGt _) [a,b] = [cexp|$exp:a > $exp:b|]-codegenPrim (PrimLtEq _) [a,b] = [cexp|$exp:a <= $exp:b|]-codegenPrim (PrimGtEq _) [a,b] = [cexp|$exp:a >= $exp:b|]-codegenPrim (PrimEq _) [a,b] = [cexp|$exp:a == $exp:b|]-codegenPrim (PrimNEq _) [a,b] = [cexp|$exp:a != $exp:b|]-codegenPrim (PrimMax ty) [a,b] = codegenMax ty a b-codegenPrim (PrimMin ty) [a,b] = codegenMin ty a b-codegenPrim PrimLAnd [a,b] = [cexp|$exp:a && $exp:b|]-codegenPrim PrimLOr [a,b] = [cexp|$exp:a || $exp:b|]-codegenPrim PrimLNot [a] = [cexp| ! $exp:a|]-codegenPrim PrimOrd [a] = codegenOrd a-codegenPrim PrimChr [a] = codegenChr a-codegenPrim PrimBoolToInt [a] = codegenBoolToInt a-codegenPrim (PrimFromIntegral ta tb) [a] = codegenFromIntegral ta tb a---- If the argument lists are not the correct length-codegenPrim _ _ =- INTERNAL_ERROR(error) "codegenPrim" "inconsistent valuation"---- Implementation of scalar primitives----codegenConst :: TupleType a -> a -> [C.Exp]-codegenConst UnitTuple _ = []-codegenConst (SingleTuple ty) c = [codegenScalar ty c]-codegenConst (PairTuple ty1 ty0) (cs,c) = codegenConst ty1 cs ++ codegenConst ty0 c----- Scalar constants----codegenScalar :: ScalarType a -> a -> C.Exp-codegenScalar (NumScalarType ty) = codegenNumScalar ty-codegenScalar (NonNumScalarType ty) = codegenNonNumScalar ty--codegenNumScalar :: NumType a -> a -> C.Exp-codegenNumScalar (IntegralNumType ty) = codegenIntegralScalar ty-codegenNumScalar (FloatingNumType ty) = codegenFloatingScalar ty--codegenIntegralScalar :: IntegralType a -> a -> C.Exp-codegenIntegralScalar ty x | IntegralDict <- integralDict ty = [cexp| ( $ty:(codegenIntegralType ty) ) $exp:(cintegral x) |]--codegenFloatingScalar :: FloatingType a -> a -> C.Exp-codegenFloatingScalar (TypeFloat _) x = C.Const (C.FloatConst (shows x "f") (toRational x) noLoc) noLoc-codegenFloatingScalar (TypeCFloat _) x = C.Const (C.FloatConst (shows x "f") (toRational x) noLoc) noLoc-codegenFloatingScalar (TypeDouble _) x = C.Const (C.DoubleConst (show x) (toRational x) noLoc) noLoc-codegenFloatingScalar (TypeCDouble _) x = C.Const (C.DoubleConst (show x) (toRational x) noLoc) noLoc--codegenNonNumScalar :: NonNumType a -> a -> C.Exp-codegenNonNumScalar (TypeBool _) x = cbool x-codegenNonNumScalar (TypeChar _) x = [cexp|$char:x|]-codegenNonNumScalar (TypeCChar _) x = [cexp|$char:(chr (fromIntegral x))|]-codegenNonNumScalar (TypeCUChar _) x = [cexp|$char:(chr (fromIntegral x))|]-codegenNonNumScalar (TypeCSChar _) x = [cexp|$char:(chr (fromIntegral x))|]----- Constant methods of floating----codegenPi :: FloatingType a -> C.Exp-codegenPi ty | FloatingDict <- floatingDict ty = codegenFloatingScalar ty pi----- Constant methods of bounded----codegenMinBound :: BoundedType a -> C.Exp-codegenMinBound (IntegralBoundedType ty) | IntegralDict <- integralDict ty = codegenIntegralScalar ty minBound-codegenMinBound (NonNumBoundedType ty) | NonNumDict <- nonNumDict ty = codegenNonNumScalar ty minBound---codegenMaxBound :: BoundedType a -> C.Exp-codegenMaxBound (IntegralBoundedType ty) | IntegralDict <- integralDict ty = codegenIntegralScalar ty maxBound-codegenMaxBound (NonNumBoundedType ty) | NonNumDict <- nonNumDict ty = codegenNonNumScalar ty maxBound----- Methods from Num, Floating, Fractional and RealFrac----codegenAbs :: NumType a -> C.Exp -> C.Exp-codegenAbs (FloatingNumType ty) x = ccall (FloatingNumType ty `postfix` "fabs") [x]-codegenAbs (IntegralNumType ty) x =- case ty of- TypeWord _ -> x- TypeWord8 _ -> x- TypeWord16 _ -> x- TypeWord32 _ -> x- TypeWord64 _ -> x- TypeCUShort _ -> x- TypeCUInt _ -> x- TypeCULong _ -> x- TypeCULLong _ -> x- _ -> ccall "abs" [x]---codegenSig :: NumType a -> C.Exp -> C.Exp-codegenSig (IntegralNumType ty) = codegenIntegralSig ty-codegenSig (FloatingNumType ty) = codegenFloatingSig ty--codegenIntegralSig :: IntegralType a -> C.Exp -> C.Exp-codegenIntegralSig ty x = [cexp|$exp:x == $exp:zero ? $exp:zero : $exp:(ccall "copysign" [one,x]) |]- where- zero | IntegralDict <- integralDict ty = codegenIntegralScalar ty 0- one | IntegralDict <- integralDict ty = codegenIntegralScalar ty 1--codegenFloatingSig :: FloatingType a -> C.Exp -> C.Exp-codegenFloatingSig ty x =- [cexp|$exp:x == $exp:zero- ? $exp:zero- : $exp:(ccall (FloatingNumType ty `postfix` "copysign") [one,x]) |]- where- zero | FloatingDict <- floatingDict ty = codegenFloatingScalar ty 0- one | FloatingDict <- floatingDict ty = codegenFloatingScalar ty 1---codegenRecip :: FloatingType a -> C.Exp -> C.Exp-codegenRecip ty x | FloatingDict <- floatingDict ty = [cexp|$exp:(codegenFloatingScalar ty 1) / $exp:x|]---codegenLogBase :: FloatingType a -> C.Exp -> C.Exp -> C.Exp-codegenLogBase ty x y = let a = ccall (FloatingNumType ty `postfix` "log") [x]- b = ccall (FloatingNumType ty `postfix` "log") [y]- in- [cexp|$exp:b / $exp:a|]---codegenMin :: ScalarType a -> C.Exp -> C.Exp -> C.Exp-codegenMin (NumScalarType ty@(IntegralNumType _)) a b = ccall (ty `postfix` "min") [a,b]-codegenMin (NumScalarType ty@(FloatingNumType _)) a b = ccall (ty `postfix` "fmin") [a,b]-codegenMin (NonNumScalarType _) a b =- let ty = scalarType :: ScalarType Int32- in codegenMin ty (ccast ty a) (ccast ty b)---codegenMax :: ScalarType a -> C.Exp -> C.Exp -> C.Exp-codegenMax (NumScalarType ty@(IntegralNumType _)) a b = ccall (ty `postfix` "max") [a,b]-codegenMax (NumScalarType ty@(FloatingNumType _)) a b = ccall (ty `postfix` "fmax") [a,b]-codegenMax (NonNumScalarType _) a b =- let ty = scalarType :: ScalarType Int32- in codegenMax ty (ccast ty a) (ccast ty b)----- Type coercions----codegenOrd :: C.Exp -> C.Exp-codegenOrd = ccast (scalarType :: ScalarType Int)--codegenChr :: C.Exp -> C.Exp-codegenChr = ccast (scalarType :: ScalarType Char)--codegenBoolToInt :: C.Exp -> C.Exp-codegenBoolToInt = ccast (scalarType :: ScalarType Int)--codegenFromIntegral :: IntegralType a -> NumType b -> C.Exp -> C.Exp-codegenFromIntegral _ ty = ccast (NumScalarType ty)--codegenTruncate :: FloatingType a -> IntegralType b -> C.Exp -> C.Exp-codegenTruncate ta tb x- = ccast (NumScalarType (IntegralNumType tb))- $ ccall (FloatingNumType ta `postfix` "trunc") [x]--codegenRound :: FloatingType a -> IntegralType b -> C.Exp -> C.Exp-codegenRound ta tb x- = ccast (NumScalarType (IntegralNumType tb))- $ ccall (FloatingNumType ta `postfix` "round") [x]--codegenFloor :: FloatingType a -> IntegralType b -> C.Exp -> C.Exp-codegenFloor ta tb x- = ccast (NumScalarType (IntegralNumType tb))- $ ccall (FloatingNumType ta `postfix` "floor") [x]--codegenCeiling :: FloatingType a -> IntegralType b -> C.Exp -> C.Exp-codegenCeiling ta tb x- = ccast (NumScalarType (IntegralNumType tb))- $ ccall (FloatingNumType ta `postfix` "ceil") [x]+ single loc _ = $internalError loc "expected single expression" -- Auxiliary Functions -- ------------------- ccast :: ScalarType a -> C.Exp -> C.Exp-ccast ty x = [cexp|($ty:(codegenScalarType ty)) $exp:x|]+ccast ty x = [cexp| ($ty:(typeOf ty)) $exp:x |] ccastTup :: TupleType e -> [C.Exp] -> [C.Exp] ccastTup ty = fst . travTup ty where- travTup :: TupleType e -> [C.Exp] -> ([C.Exp],[C.Exp])+ travTup :: TupleType e -> [C.Exp] -> ([C.Exp], [C.Exp]) travTup UnitTuple xs = ([], xs) travTup (SingleTuple ty') (x:xs) = ([ccast ty' x], xs)- travTup (PairTuple l r) xs = let- (ls, xs' ) = travTup l xs- (rs, xs'') = travTup r xs'- in (ls ++ rs, xs'')- travTup _ _ = INTERNAL_ERROR(error) "ccastTup" "not enough expressions to match type"---postfix :: NumType a -> String -> String-postfix (FloatingNumType (TypeFloat _)) x = x ++ "f"-postfix (FloatingNumType (TypeCFloat _)) x = x ++ "f"-postfix _ x = x+ travTup (PairTuple l r) xs =+ let (ls, xs' ) = travTup l xs+ (rs, xs'') = travTup r xs'+ in (ls ++ rs, xs'')+ travTup _ _ = $internalError "ccastTup" "not enough expressions to match type"
+ Data/Array/Accelerate/CUDA/CodeGen/Arithmetic.hs view
@@ -0,0 +1,393 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}+-- |+-- Module : Data.Array.Accelerate.CUDA.CodeGen.Arithmetic+-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+-- [2009..2014] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.CUDA.CodeGen.Arithmetic+ where++-- friends+import Data.Array.Accelerate.Type+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.CUDA.CodeGen.Base+import Data.Array.Accelerate.CUDA.CodeGen.Constant+import Data.Array.Accelerate.CUDA.CodeGen.Monad+import Data.Array.Accelerate.CUDA.CodeGen.Type++-- libraries+import Prelude ( String, ($), (++), (-), undefined, otherwise )+import Data.Bits ( finiteBitSize )+import Control.Monad.State.Strict+import Language.C+import Language.C.Quote.CUDA+import Foreign.Storable ( sizeOf )+++-- Operations from Num+-- ===================++add :: Exp -> Exp -> Exp+add x y = [cexp| $exp:x + $exp:y |]++sub :: Exp -> Exp -> Exp+sub x y = [cexp| $exp:x - $exp:y |]++mul :: Exp -> Exp -> Exp+mul x y = [cexp| $exp:x * $exp:y |]++negate :: Exp -> Exp+negate x = [cexp| - $exp:x |]++abs :: forall a. NumType a -> Exp -> Exp+abs (FloatingNumType t) x+ = mathf t "fabs" [x]++abs (IntegralNumType t) x+ | signedIntegralNum t+ , IntegralDict <- integralDict t+ = case sizeOf (undefined::a) of+ 8 -> ccall "llabs" [x]+ _ -> ccall "abs" [x]++ | otherwise+ = x++signum :: NumType a -> Exp -> Gen Exp+signum (IntegralNumType t) x+ | IntegralDict <- integralDict t+ , unsignedIntegralNum t+ = return [cexp| $exp:x > $exp:(integral t 0) |]++ | IntegralDict <- integralDict t+ = do x' <- bind (typeOf t) x+ return [cexp| ($exp:x' > $exp:(integral t 0)) - ($exp:x' < $exp:(integral t 0)) |]++signum (FloatingNumType t) x+ | FloatingDict <- floatingDict t+ = do x' <- bind (typeOf t) x+ return [cexp| $exp:x' == $exp:(floating t 0)+ ? $exp:(floating t 0)+ : $exp:(mathf t "copysign" [floating t 1, x']) |]+++-- Operators from Integral & Bits+-- ==============================++quot :: Exp -> Exp -> Exp+quot x y = [cexp| $exp:x / $exp:y |]++rem :: Exp -> Exp -> Exp+rem x y = [cexp| $exp:x % $exp:y |]++quotRem :: IntegralType a -> Exp -> Exp -> Gen (Exp,Exp)+quotRem (typeOf -> t') x y = do+ x' <- bind t' x+ y' <- bind t' y+ q <- bind t' (x' `quot` y')+ r <- bind t' (x' `sub` (y' `mul` q))+ return (q, r)++idiv :: IntegralType a -> Exp -> Exp -> Gen Exp+idiv t x y+ | unsignedIntegralNum t+ = return (x `quot` y)++ | IntegralDict <- integralDict t+ , zero <- integral t 0+ , one <- integral t 1+ = do+ x' <- bind (typeOf t) x+ y' <- bind (typeOf t) y+ return $+ cases [ ((x' `gt` zero) `land` (y' `lt` zero), ((x' `sub` one) `quot` y') `sub` one)+ , ((x' `lt` zero) `land` (y' `gt` zero), ((x' `add` one) `quot` y') `sub` one)+ ]+ (x' `quot` y')++mod :: IntegralType a -> Exp -> Exp -> Gen Exp+mod t x y+ | unsignedIntegralNum t+ = return (x `rem` y)++ | IntegralDict <- integralDict t+ , zero <- integral t 0+ = do+ x' <- bind (typeOf t) x+ y' <- bind (typeOf t) y+ r <- bind (typeOf t) (x' `rem` y')+ return $+ ((((x' `gt` zero) `land` (y' `lt` zero)) `lor` ((x' `lt` zero) `land` (y' `gt` zero)))+ ?: ( r `neq` zero ?: ( r `add` y', zero )+ , r ))++divMod :: IntegralType a -> Exp -> Exp -> Gen (Exp, Exp)+divMod t x y | IntegralDict <- integralDict t = do+ x' <- bind (typeOf t) x+ y' <- bind (typeOf t) y+ (q,r) <- quotRem t x' y'++ sr <- signum (IntegralNumType t) r+ sy' <- signum (IntegralNumType t) y'++ -- Somewhat awful way to inject an ifThenElse statement+ vd <- lift fresh+ vm <- lift fresh+ modify (\st -> st { localBindings = [citem| $ty:(typeOf t) $id:vd, $id:vm; |] : localBindings st })+ modify (\st -> st { localBindings = [citem| if ( $exp:(sr `eq` negate sy') ) {+ $id:vd = $exp:(q `sub` integral t 1);+ $id:vm = $exp:(r `add` y') ;+ } else {+ $id:vd = $exp:q;+ $id:vm = $exp:r;+ } |] : localBindings st })+ return ( cvar vd, cvar vm )+++band :: Exp -> Exp -> Exp+band x y = [cexp| $exp:x & $exp:y |]++bor :: Exp -> Exp -> Exp+bor x y = [cexp| $exp:x | $exp:y |]++xor :: Exp -> Exp -> Exp+xor x y = [cexp| $exp:x ^ $exp:y |]++bnot :: Exp -> Exp+bnot x = [cexp| ~ $exp:x |]++shiftL :: Exp -> Exp -> Exp+shiftL x i = [cexp| $exp:x << $exp:i |]++-- Arithmetic right shift (unchecked)+--+shiftRA :: Exp -> Exp -> Exp+shiftRA x i = [cexp| $exp:x >> $exp:i |]++-- Logical right shift (unchecked)+--+shiftRL :: IntegralType a -> Exp -> Exp -> Exp+shiftRL ty x i =+ let int = typeOf (integralType :: IntegralType Int)+ word = typeOf (integralType :: IntegralType Word)+ in+ case ty of+ TypeInt{} -> [cexp| ($ty:int) (($ty:word) $exp:x >> $exp:i) |]+ TypeInt8{} -> [cexp| (typename Int8) ((typename Word8) $exp:x >> $exp:i) |]+ TypeInt16{} -> [cexp| (typename Int16) ((typename Word16) $exp:x >> $exp:i) |]+ TypeInt32{} -> [cexp| (typename Int32) ((typename Word32) $exp:x >> $exp:i) |]+ TypeInt64{} -> [cexp| (typename Int64) ((typename Word64) $exp:x >> $exp:i) |]+ TypeCShort{} -> [cexp| (short) ((unsigned short) $exp:x >> $exp:i) |]+ TypeCInt{} -> [cexp| (int) ((unsigned int) $exp:x >> $exp:i) |]+ TypeCLong{} -> [cexp| (long) ((unsigned long) $exp:x >> $exp:i) |]+ TypeCLLong{} -> [cexp| (long long) ((unsigned long long) $exp:x >> $exp:i) |]++ -- unsigned types use arithmetic shift+ _ -> $internalCheck "shiftRL" "unhandled signed type" (unsignedIntegralNum ty) (shiftRA x i)+++rotateL :: forall a. IntegralType a -> Exp -> Exp -> Gen Exp+rotateL t x i | IntegralDict <- integralDict t = do+ let int = integralType :: IntegralType Int+ wsib = finiteBitSize (undefined::a)+ --+ x' <- bind (typeOf t) x+ i' <- bind (typeOf int) (i `band` integral int (wsib - 1))+ return $ (x' `shiftL` i') `bor` (shiftRL t x' (integral int wsib `sub` i'))++rotateR :: IntegralType a -> Exp -> Exp -> Gen Exp+rotateR t x i = rotateL t x (negate i)+++-- Operators from Fractional & Floating+-- ====================================++fdiv :: Exp -> Exp -> Exp+fdiv x y = [cexp| $exp:x / $exp:y |]++recip :: FloatingType a -> Exp -> Exp+recip t x | FloatingDict <- floatingDict t = fdiv (floating t 1) x++sin :: FloatingType a -> Exp -> Exp+sin t x = mathf t "sin" [x]++cos :: FloatingType a -> Exp -> Exp+cos t x = mathf t "cos" [x]++tan :: FloatingType a -> Exp -> Exp+tan t x = mathf t "tan" [x]++asin :: FloatingType a -> Exp -> Exp+asin t x = mathf t "asin" [x]++acos :: FloatingType a -> Exp -> Exp+acos t x = mathf t "acos" [x]++atan :: FloatingType a -> Exp -> Exp+atan t x = mathf t "atan" [x]++sinh :: FloatingType a -> Exp -> Exp+sinh t x = mathf t "sinh" [x]++cosh :: FloatingType a -> Exp -> Exp+cosh t x = mathf t "cosh" [x]++tanh :: FloatingType a -> Exp -> Exp+tanh t x = mathf t "tanh" [x]++asinh :: FloatingType a -> Exp -> Exp+asinh t x = mathf t "asinh" [x]++acosh :: FloatingType a -> Exp -> Exp+acosh t x = mathf t "acosh" [x]++atanh :: FloatingType a -> Exp -> Exp+atanh t x = mathf t "atanh" [x]++exp :: FloatingType a -> Exp -> Exp+exp t x = mathf t "exp" [x]++sqrt :: FloatingType a -> Exp -> Exp+sqrt t x = mathf t "sqrt" [x]++pow :: FloatingType a -> Exp -> Exp -> Exp+pow t x y = mathf t "pow" [x,y]++log :: FloatingType a -> Exp -> Exp+log t x = mathf t "log" [x]++logBase :: FloatingType a -> Exp -> Exp -> Exp+logBase t x y = log t y `fdiv` log t x+++-- Operators from RealFrac+-- =======================++trunc :: FloatingType a -> IntegralType b -> Exp -> Exp+trunc ta tb x = cast tb $ mathf ta "trunc" [x]++round :: FloatingType a -> IntegralType b -> Exp -> Exp+round ta tb x = cast tb $ mathf ta "round" [x]++floor :: FloatingType a -> IntegralType b -> Exp -> Exp+floor ta tb x = cast tb $ mathf ta "floor" [x]++ceiling :: FloatingType a -> IntegralType b -> Exp -> Exp+ceiling ta tb x = cast tb $ mathf ta "ceil" [x]+++-- Operators from RealFloat+-- ========================++atan2 :: FloatingType a -> Exp -> Exp -> Exp+atan2 t x y = mathf t "atan2" [x, y]++isNaN :: Exp -> Exp+isNaN x = ccall "isnan" [x]+++-- Relational and equality operators+-- =================================++lt :: Exp -> Exp -> Exp+lt x y = [cexp| $exp:x < $exp:y |]++gt :: Exp -> Exp -> Exp+gt x y = [cexp| $exp:x > $exp:y |]++leq :: Exp -> Exp -> Exp+leq x y = [cexp| $exp:x <= $exp:y |]++geq :: Exp -> Exp -> Exp+geq x y = [cexp| $exp:x >= $exp:y |]++eq :: Exp -> Exp -> Exp+eq x y = [cexp| $exp:x == $exp:y |]++neq :: Exp -> Exp -> Exp+neq x y = [cexp| $exp:x != $exp:y |]++max :: ScalarType a -> Exp -> Exp -> Exp+max (NonNumScalarType _) x y =+ let t = scalarType :: ScalarType Int32+ in max t (cast t x) (cast t y)++max (NumScalarType (IntegralNumType _)) x y = ccall "max" [x,y]+max (NumScalarType (FloatingNumType t)) x y = mathf t "fmax" [x,y]++min :: ScalarType a -> Exp -> Exp -> Exp+min (NonNumScalarType _) x y =+ let t = scalarType :: ScalarType Int32+ in min t (cast t x) (cast t y)++min (NumScalarType (IntegralNumType _)) x y = ccall "min" [x,y]+min (NumScalarType (FloatingNumType t)) x y = mathf t "fmin" [x,y]+++-- Logical operators+-- =================++land :: Exp -> Exp -> Exp+land x y = [cexp| $exp:x && $exp:y |]++lor :: Exp -> Exp -> Exp+lor x y = [cexp| $exp:x || $exp:y |]++lnot :: Exp -> Exp+lnot x = [cexp| ! $exp:x |]+++-- Type Conversions+-- ================++ord :: Exp -> Exp+ord = cast (scalarType :: ScalarType Int)++chr :: Exp -> Exp+chr = cast (scalarType :: ScalarType Char)++boolToInt :: Exp -> Exp+boolToInt = cast (scalarType :: ScalarType Int)++fromIntegral :: IntegralType a -> NumType b -> Exp -> Exp+fromIntegral _ tb = cast tb+++-- Helpers+-- =======++cast :: TypeOf a => a -> Exp -> Exp+cast t x = [cexp| ($ty:(typeOf t)) $exp:x |]++mathf :: forall t. FloatingType t -> String -> [Exp] -> Exp+mathf ty f args | FloatingDict <- floatingDict ty =+ let+ fun = f ++ case sizeOf (undefined :: t) of+ 4 -> "f"+ 8 -> []+ 16 -> "l" -- long double+ _ -> $internalError "mathf" "unsupported floating point size"+ in+ ccall fun args+++infix 0 ?:+(?:) :: Exp -> (Exp, Exp) -> Exp+(?:) p (t,e) = [cexp| $exp:p ? $exp:t : $exp:e |]++cases :: [(Exp, Exp)] -> Exp -> Exp+cases [] def = def+cases ((p,b):rest) def = p ?: (b, cases rest def)+
Data/Array/Accelerate/CUDA/CodeGen/Base.hs view
@@ -3,14 +3,19 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+#if __GLASGOW_HASKELL__ <= 708+{-# LANGUAGE OverlappingInstances #-}+{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}+#endif+ -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen.Base--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>@@ -26,7 +31,7 @@ Name, namesOfArray, namesOfAvar, groupOfInt, -- Declaration generation- cint, cvar, ccall, cchar, cintegral, cbool, cshape, csize, cindexHead, cindexTail, ctoIndex, cfromIndex,+ cint, cvar, ccall, cchar, cintegral, cbool, cshape, cslice, csize, cindexHead, cindexTail, ctoIndex, cfromIndex, readArray, writeArray, shared, indexArray, environment, arrayAsTex, arrayAsArg, umul24, gridSize, threadIdx,@@ -49,13 +54,13 @@ -- friends import Data.Array.Accelerate.Type+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Array.Representation ( SliceIndex(..) ) import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt ) import Data.Array.Accelerate.Analysis.Shape import Data.Array.Accelerate.CUDA.CodeGen.Type import Data.Array.Accelerate.CUDA.AST -#include "accelerate.h"- -- Names -- ----- @@ -137,7 +142,7 @@ -- ----------------------- cint :: C.Type-cint = codegenScalarType (scalarType :: ScalarType Int)+cint = typeOf (scalarType :: ScalarType Int) cvar :: Name -> C.Exp cvar x = [cexp|$id:x|]@@ -154,6 +159,17 @@ cbool :: Bool -> C.Exp cbool = cintegral . fromEnum +cslice :: SliceIndex slix sl co dim -> Name -> ([C.Param], [C.Exp], [(C.Type, Name)])+cslice slix sl =+ let xs = cshape' (ncodims slix) sl+ args = [ [cparam| const $ty:cint $id:x |] | x <- xs ]+ in (args, map cvar xs, zip (repeat cint) xs)+ where+ ncodims :: SliceIndex slix sl co dim -> Int+ ncodims SliceNil = 0+ ncodims (SliceAll s) = ncodims s+ ncodims (SliceFixed s) = ncodims s + 1+ -- Generate all the names of a shape given a base name and dimensionality cshape :: Int -> Name -> [C.Exp] cshape dim sh = [ cvar x | x <- cshape' dim sh ]@@ -183,7 +199,7 @@ toIndex [] [] = [cexp| $int:(0::Int) |] toIndex [_] [i] = i toIndex (sz:sh) (i:ix) = [cexp| $exp:(toIndex sh ix) * $exp:sz + $exp:i |]- toIndex _ _ = INTERNAL_ERROR(error) "toIndex" "argument mismatch"+ toIndex _ _ = $internalError "toIndex" "argument mismatch" -- Generate code to calculate a multi-dimensional index from a linear index and a given array shape. -- This version creates temporary values that are reused in the computation.@@ -247,7 +263,9 @@ :: forall aenv sh e. (Shape sh, Elt e) => Name -- group names -> Array sh e -- dummy to fix types- -> ( [C.Param], CUDelayedAcc aenv sh e )+ -> ( [C.Param]+ , [C.Exp]+ , CUDelayedAcc aenv sh e ) readArray grp dummy = let (sh, arrs) = namesOfArray grp (undefined :: e) args = arrayAsArg dummy grp@@ -256,9 +274,9 @@ sh' = cshape dim sh get ix = ([], map (\a -> [cexp| $id:a [ $exp:ix ] |]) arrs) manifest = CUDelayed (CUExp ([], sh'))- (INTERNAL_ERROR(error) "readArray" "linear indexing only")+ ($internalError "readArray" "linear indexing only") (CUFun1 (zip (repeat True)) (\[i] -> get (rvalue i)))- in ( args, manifest )+ in ( args, sh', manifest ) -- Generate function parameters and corresponding variable names for the@@ -269,11 +287,11 @@ -- writeArray :: forall sh e. (Shape sh, Elt e)- => Name -- group names- -> Array sh e -- dummy to fix types- -> ( [C.Param] -- function parameters to marshal the output array- , [C.Exp] -- the shape of the output array- , Rvalue x => x -> [C.Exp] ) -- write an element at a given index+ => Name -- group names+ -> Array sh e -- dummy to fix types+ -> ( [C.Param] -- function parameters to marshal the output array+ , [C.Exp] -- the shape of the output array+ , forall x. Rvalue x => x -> [C.Exp] ) -- write an element at a given index writeArray grp _ = let (sh, arrs) = namesOfArray grp (undefined :: e) dim = expDim (undefined :: Exp aenv sh)@@ -294,12 +312,12 @@ -- shared :: forall e. Elt e- => e -- dummy type- -> Name -- group name- -> C.Exp -- how much shared memory per type- -> Maybe C.Exp -- (optional) initialise from this base address- -> ( [C.InitGroup] -- shared memory declaration and...- , Rvalue x => x -> [C.Exp]) -- ...indexing function+ => e -- dummy type+ -> Name -- group name+ -> C.Exp -- how much shared memory per type+ -> Maybe C.Exp -- (optional) initialise from this base address+ -> ( [C.InitGroup] -- shared memory declaration and...+ , forall x. Rvalue x => x -> [C.Exp]) -- ...indexing function shared _ grp size mprev = let e:es = eltType (undefined :: e) x:xs = let k = length es in map (\n -> grp ++ show n) [k, k-1 .. 0]@@ -384,10 +402,30 @@ in unzip3 $ zipWith local elt [n-1, n-2 .. 0] - class Lvalue a where lvalue :: a -> C.Exp -> C.BlockItem +-- Note: [Mutable l-values]+--+-- Be careful when using mutable l-values that the same variable does not appear+-- on both the left and right hand side. For example, the following will lead to+-- problems (#114, #168):+--+-- $items:(x .=. f x)+--+-- $items:(y .=. combine x y)+--+-- If 'x' and 'y' represent values with tuple types, they will have multiple+-- components. Since the LHS is updated as the new values are calculated, it is+-- possible to get into a situation where computing the new value for some of+-- the components will be using the updated values, not the original values.+--+-- Instead, store the result to some (temporary) variable that does not appear+-- on the RHS, and then update old value using the fully computed result, e.g.:+--+-- $items:(x' .=. f x)+-- $items:(x .=. x')+-- instance Lvalue C.Exp where lvalue x y = [citem| $exp:x = $exp:y; |] @@ -418,17 +456,17 @@ instance (Lvalue l, Rvalue r) => Assign l r where assign lhs rhs = [ lvalue lhs (rvalue rhs) ] -instance Assign l r => Assign (Bool,l) r where+instance {-# OVERLAPS #-} Assign l r => Assign (Bool,l) r where assign (used,lhs) rhs | used = assign lhs rhs | otherwise = [] -instance Assign l r => Assign [l] [r] where+instance {-# OVERLAPS #-} Assign l r => Assign [l] [r] where assign [] [] = [] assign (x:xs) (y:ys) = assign x y ++ assign xs ys- assign _ _ = INTERNAL_ERROR(error) ".=." "argument mismatch"+ assign _ _ = $internalError ".=." "argument mismatch" -instance Assign l r => Assign l ([C.BlockItem], r) where+instance {-# OVERLAPS #-} Assign l r => Assign l ([C.BlockItem], r) where assign lhs (env, rhs) = env ++ assign lhs rhs @@ -440,10 +478,10 @@ zipWith :: (a -> b -> c) -> [a] -> [b] -> [c] zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys zipWith _ [] [] = []-zipWith _ _ _ = INTERNAL_ERROR(error) "zipWith" "argument mismatch"+zipWith _ _ _ = $internalError "zipWith" "argument mismatch" zipWith3 :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] zipWith3 f (x:xs) (y:ys) (z:zs) = f x y z : zipWith3 f xs ys zs zipWith3 _ [] [] [] = []-zipWith3 _ _ _ _ = INTERNAL_ERROR(error) "zipWith3" "argument mismatch"+zipWith3 _ _ _ _ = $internalError "zipWith3" "argument mismatch"
+ Data/Array/Accelerate/CUDA/CodeGen/Constant.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+-- |+-- Module : Data.Array.Accelerate.CUDA.CodeGen.Constant+-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+-- [2009..2014] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.CUDA.CodeGen.Constant+ where++-- friends+import Data.Array.Accelerate.AST ( PrimConst(..) )+import Data.Array.Accelerate.Type+import Data.Array.Accelerate.CUDA.CodeGen.Base+import Data.Array.Accelerate.CUDA.CodeGen.Type++-- libraries+import Data.Loc+import Data.Char+import Language.C+import Language.C.Quote.CUDA+++-- | A constant value. Note that this follows the EltRepr representation of the+-- type, meaning that any nested tupling on the surface type is flattened.+--+constant :: TupleType a -> a -> [Exp]+constant UnitTuple _ = []+constant (SingleTuple ty) c = [scalar ty c]+constant (PairTuple ty1 ty0) (cs,c) = constant ty1 cs ++ constant ty0 c++-- | A constant scalar value+--+scalar :: ScalarType a -> a -> Exp+scalar (NumScalarType ty) = num ty+scalar (NonNumScalarType ty) = nonnum ty++-- | A constant numeric value+--+num :: NumType a -> a -> Exp+num (IntegralNumType ty) = integral ty+num (FloatingNumType ty) = floating ty++-- | A constant integral value+--+integral :: IntegralType a -> a -> Exp+integral ty x | IntegralDict <- integralDict ty = [cexp| ( $ty:(typeOf ty) ) $exp:(cintegral x) |]++-- | A constant floating-point value+--+floating :: FloatingType a -> a -> Exp+floating (TypeFloat _) x = Const (FloatConst (shows x "f") (toRational x) noLoc) noLoc+floating (TypeCFloat _) x = Const (FloatConst (shows x "f") (toRational x) noLoc) noLoc+floating (TypeDouble _) x = Const (DoubleConst (show x) (toRational x) noLoc) noLoc+floating (TypeCDouble _) x = Const (DoubleConst (show x) (toRational x) noLoc) noLoc+++-- | A constant non-numeric value+--+nonnum :: NonNumType a -> a -> Exp+nonnum (TypeBool _) x = cbool x+nonnum (TypeChar _) x = [cexp|$char:x|]+nonnum (TypeCChar _) x = [cexp|$char:(chr (fromIntegral x))|]+nonnum (TypeCUChar _) x = [cexp|$char:(chr (fromIntegral x))|]+nonnum (TypeCSChar _) x = [cexp|$char:(chr (fromIntegral x))|]+++-- | Primitive constants+--+primConst :: PrimConst t -> Exp+primConst (PrimMinBound t) = primMinBound t+primConst (PrimMaxBound t) = primMaxBound t+primConst (PrimPi t) = primPi t++primMinBound :: BoundedType a -> Exp+primMinBound (IntegralBoundedType ty) | IntegralDict <- integralDict ty = integral ty minBound+primMinBound (NonNumBoundedType ty) | NonNumDict <- nonNumDict ty = nonnum ty minBound++primMaxBound :: BoundedType a -> Exp+primMaxBound (IntegralBoundedType ty) | IntegralDict <- integralDict ty = integral ty maxBound+primMaxBound (NonNumBoundedType ty) | NonNumDict <- nonNumDict ty = nonnum ty maxBound++primPi :: FloatingType a -> Exp+primPi ty | FloatingDict <- floatingDict ty = floating ty pi+
Data/Array/Accelerate/CUDA/CodeGen/IndexSpace.hs view
@@ -1,12 +1,14 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen.IndexSpace--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>@@ -24,19 +26,16 @@ ) where -import Data.List import Language.C.Quote.CUDA import Foreign.CUDA.Analysis.Device import qualified Language.C.Syntax as C import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt, ignore, shapeToList )+import Data.Array.Accelerate.Error ( internalError ) import Data.Array.Accelerate.CUDA.AST ( Gamma )-import Data.Array.Accelerate.CUDA.CodeGen.Type import Data.Array.Accelerate.CUDA.CodeGen.Base -#include "accelerate.h" - -- Construct a new array by applying a function to each index. Each thread -- processes multiple elements, striding the array by the grid size. --@@ -178,7 +177,8 @@ permute ( $params:argIn,- $params:argOut+ $params:argOut,+ typename Int32 * __restrict__ lock ) { /*@@ -199,25 +199,23 @@ if ( ! $exp:(cignore dst) ) {- $decls:decly- $decls:decly'-- $items:(jx .=. ctoIndex shOut dst)- $items:(dce_x x .=. get ix)- $items:(dce_y y .=. arrOut jx)+ $items:(jx .=. ctoIndex shOut dst)+ $items:(dce_x x .=. get ix) - $items:write+ $items:(atomically jx+ [ dce_y y .=. setOut jx+ , setOut jx .=. combine x y+ ]+ ) } } } |] where- sizeof = eltSizeOf (undefined::e) (texIn, argIn) = environment dev aenv- (argOut, shOut, arrOut) = writeArray "Out" (undefined :: Array sh' e)+ (argOut, shOut, setOut) = writeArray "Out" (undefined :: Array sh' e) (x, _, _) = locals "x" (undefined :: e)- (_, y, decly) = locals "y" (undefined :: e)- (_, y', decly') = locals "_y" (undefined :: e)+ (y, _, _) = locals "y" (undefined :: e) (sh, _, _) = locals "shIn" (undefined :: sh) (src, _, _) = locals "sh" (undefined :: sh) (dst, _, _) = locals "sh_" (undefined :: sh')@@ -227,43 +225,80 @@ -- If the destination index resolves to the magic index "ignore", the result -- is dropped from the output array.+ -- cignore :: Rvalue x => [x] -> C.Exp- cignore [] = INTERNAL_ERROR(error) "permute" "singleton arrays not supported"+ cignore [] = $internalError "permute" "singleton arrays not supported" cignore xs = foldl1 (\a b -> [cexp| $exp:a && $exp:b |]) $ zipWith (\a b -> [cexp| $exp:(rvalue a) == $int:b |]) xs $ shapeToList (ignore :: sh') - -- Apply the combining function between old and new values. If multiple- -- threads attempt to write to the same location, the hardware- -- write-combining mechanism will accept one transaction and all other- -- updates will be lost.- --- -- If the hardware supports it, we can use atomicCAS (compare-and-swap) to- -- work around this. This requires at least compute 1.1 for 32-bit values,- -- and compute 1.2 for 64-bit values. If hardware support is not available,- -- write the result as normal and hope for the best.+ -- If we can determine that the old values are not used in the combination+ -- function (e.g. filter) then the lock and unlock fragments can be replaced+ -- with a NOP. --- -- Each element of a tuple is necessarily written individually, so the tuple- -- as a whole is not stored atomically.+ -- If locking is required but the hardware does not support it (compute 1.0)+ -- then we issue a runtime error immediately instead of silently failing. --- write = env ++ zipWith6 apply sizeof (arrOut jx) fun x (dce_y y) y'- (env, fun) = combine x y-- apply size out f x1 (used,y1) y1'- | used- , Just atomicCAS <- reinterpret size- = [citem| do {- $exp:y1' = $exp:y1;- $exp:y1 = $exp:atomicCAS ( & $exp:out, $exp:y1', $exp:f );+ mustLock = or . fst . unzip $ dce_y y - } while ( $exp:y1 != $exp:y1' ); |]+ -- The atomic section is acquired using a spin lock. This requires a+ -- temporary array to represent the lock state for each element of the+ -- output. We use 1 to represent the locked state, and 0 to represent+ -- unlocked elements.+ --+ -- do {+ -- old = atomicExch(&lock[i], 1); // atomic exchange+ -- } while (old == 1);+ --+ -- /* critical section */+ --+ -- atomicExch(&lock[i], 0);+ --+ -- The initial loop repeatedly attempts to take the lock by writing a 1 into+ -- the slot. Once the 'old' state of the lock returns 0 (unlocked), we have+ -- just acquired the lock, and the atomic section can be computed. Finally,+ -- atomically write a 0 back into the slot to unlock the element.+ --+ -- However, there is a complication with CUDA devices because all threads in+ -- the warp must execute in lockstep (with predicated execution). Once a+ -- thread acquires a lock, then it will be disabled and stop participating+ -- in the first loop, waiting until all other threads in the warp acquire+ -- their locks. If two threads in a warp are attempting to acquire the same+ -- lock, once the lock is acquired by the first thread, it sits idle while+ -- the second thread spins attempting to grab a lock that will never be+ -- released, because the first thread can not progress. DEADLOCK.+ --+ -- So, we need to invert the algorithm so that threads can always make+ -- progress, until each thread in the warp has committed their result.+ --+ -- done = 0;+ -- do {+ -- if (atomicExch(&lock[i], 1) == 0) {+ --+ -- /* critical section */+ --+ -- done = 1;+ -- atomicExch(&lock[i], 0);+ -- }+ -- } while (done == 0)+ --+ atomically :: (C.Type, Name) -> [[C.BlockItem]] -> [C.BlockItem]+ atomically (_,i) (concat -> body)+ | not mustLock = body+ | sm < Compute 1 1 = $internalError "permute" "Requires at least compute compatibility 1.1"+ | otherwise =+ [ [citem| typename Int32 done = 0; |]+ , [citem| do {+ typename Int32 *addr = &lock[ $exp:(cvar i) ]; - | otherwise- = [citem| $exp:out = $exp:(rvalue x1); |]+ if ( atomicExch( addr, 1 ) == 0 ) {+ $items:body - --- reinterpret :: Int -> Maybe C.Exp- reinterpret 4 | sm >= Compute 1 1 = Just [cexp| $id:("atomicCAS32") |]- reinterpret 8 | sm >= Compute 1 2 = Just [cexp| $id:("atomicCAS64") |]- reinterpret _ = Nothing+ done = 1;+ atomicExch( addr, 0 );+ }+ __threadfence();+ } while (done == 0);+ |]+ ]
Data/Array/Accelerate/CUDA/CodeGen/Mapping.hs view
@@ -1,11 +1,12 @@ {-# LANGUAGE GADTs #-}+{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen.Mapping--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>
Data/Array/Accelerate/CUDA/CodeGen/Monad.hs view
@@ -2,8 +2,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen.Monad--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>
Data/Array/Accelerate/CUDA/CodeGen/PrefixSum.hs view
@@ -1,12 +1,14 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen.PrefixSum--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>@@ -27,60 +29,96 @@ import Language.C.Quote.CUDA import qualified Language.C.Syntax as C -import Data.Array.Accelerate.Array.Sugar ( Vector, Scalar, Elt, DIM1 )+import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Analysis.Match+ import Data.Array.Accelerate.CUDA.AST+import Data.Array.Accelerate.CUDA.Analysis.Shape import Data.Array.Accelerate.CUDA.CodeGen.Base +errorMsg :: String+errorMsg+ = error+ $ unlines [ "accelerate-cuda does not support rank-polymorphic scans. Please switch to accelerate-llvm-ptx instead."+ , ""+ , "*** https://hackage.haskell.org/package/accelerate-llvm-ptx ***"+ , "*** https://github.com/AccelerateHS/accelerate-llvm ***"+ ] -- Wrappers -- -------- mkScanl, mkScanr- :: Elt e+ :: forall aenv sh e. (Shape sh, Elt e) => DeviceProperties -> Gamma aenv -> CUFun2 aenv (e -> e -> e) -> CUExp aenv e- -> CUDelayedAcc aenv DIM1 e- -> [CUTranslSkel aenv (Vector e)]-mkScanl dev aenv f z a =- [ mkScan L dev aenv f (Just z) a- , mkScanUp1 L dev aenv f a- , mkScanUp2 L dev aenv f (Just z) ]+ -> CUDelayedAcc aenv (sh:.Int) e+ -> [CUTranslSkel aenv (Array (sh:.Int) e)]+mkScanl dev aenv f z a+ | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)+ = [ mkScan L dev aenv f (Just z) a+ , mkScanUp1 L dev aenv f a+ , mkScanUp2 L dev aenv f (Just z) ] -mkScanr dev aenv f z a =- [ mkScan R dev aenv f (Just z) a- , mkScanUp1 R dev aenv f a- , mkScanUp2 R dev aenv f (Just z) ]+ | otherwise+ = error errorMsg +mkScanr dev aenv f z a+ | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)+ = [ mkScan R dev aenv f (Just z) a+ , mkScanUp1 R dev aenv f a+ , mkScanUp2 R dev aenv f (Just z) ]++ | otherwise+ = error errorMsg+ mkScanl1, mkScanr1- :: Elt e+ :: forall aenv sh e. (Shape sh, Elt e) => DeviceProperties -> Gamma aenv -> CUFun2 aenv (e -> e -> e)- -> CUDelayedAcc aenv DIM1 e- -> [CUTranslSkel aenv (Vector e)]-mkScanl1 dev aenv f a =- [ mkScan L dev aenv f Nothing a- , mkScanUp1 L dev aenv f a- , mkScanUp2 L dev aenv f Nothing ]+ -> CUDelayedAcc aenv (sh:.Int) e+ -> [CUTranslSkel aenv (Array (sh:.Int) e)]+mkScanl1 dev aenv f a+ | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)+ = [ mkScan L dev aenv f Nothing a+ , mkScanUp1 L dev aenv f a+ , mkScanUp2 L dev aenv f Nothing ] -mkScanr1 dev aenv f a =- [ mkScan R dev aenv f Nothing a- , mkScanUp1 R dev aenv f a- , mkScanUp2 R dev aenv f Nothing ]+ | otherwise+ = error errorMsg +mkScanr1 dev aenv f a+ | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)+ = [ mkScan R dev aenv f Nothing a+ , mkScanUp1 R dev aenv f a+ , mkScanUp2 R dev aenv f Nothing ]++ | otherwise+ = error errorMsg+ mkScanl', mkScanr'- :: Elt e+ :: forall aenv sh e. (Shape sh, Elt e) => DeviceProperties -> Gamma aenv -> CUFun2 aenv (e -> e -> e) -> CUExp aenv e- -> CUDelayedAcc aenv DIM1 e- -> [CUTranslSkel aenv (Vector e, Scalar e)]-mkScanl' dev aenv f z = map cast . mkScanl dev aenv f z-mkScanr' dev aenv f z = map cast . mkScanr dev aenv f z+ -> CUDelayedAcc aenv (sh:.Int) e+ -> [CUTranslSkel aenv (Array (sh:.Int) e, Array sh e)]+mkScanl' dev aenv f z+ | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)+ = map cast . mkScanl dev aenv f z+ | otherwise+ = error errorMsg +mkScanr' dev aenv f z+ | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)+ = map cast . mkScanr dev aenv f z+ | otherwise+ = error errorMsg+ cast :: CUTranslSkel aenv a -> CUTranslSkel aenv b cast (CUTranslSkel entry code) = CUTranslSkel entry code @@ -183,6 +221,7 @@ ) { $decls:smem+ $decls:declt $decls:declx $decls:decly $decls:declz@@ -222,7 +261,8 @@ * Carry in the result from the privous segment */ if ( $exp:carryIn ) {- $items:(x .=. combine z x)+ $items:(t .=. combine z x)+ $items:(x .=. t) } /*@@ -232,7 +272,7 @@ $items:(sdata "threadIdx.x" .=. x) __syncthreads(); - $items:(scanBlock dev fun x y sdata Nothing)+ $items:(scanBlock dev fun x y t sdata Nothing) /* * Exclusive scans write the result of the previous thread to global@@ -273,6 +313,7 @@ (argOut, _, setOut) = writeArray "Out" (undefined :: Vector e) (argSum, _, totalSum) = writeArray "Sum" (undefined :: Vector e) (argBlk, _, blkSum) = writeArray "Blk" (undefined :: Vector e)+ (_, t, declt) = locals "t" (undefined :: e) (_, x, declx) = locals "x" (undefined :: e) (_, y, decly) = locals "y" (undefined :: e) (_, z, declz) = locals "z" (undefined :: e)@@ -351,6 +392,7 @@ ) { $decls:smem+ $decls:declt $decls:declx $decls:decly $items:(sh .=. shIn)@@ -376,7 +418,8 @@ $items:(x .=. get ix) if ( threadIdx.x == 0 && carryIn ) {- $items:(x .=. combine y x)+ $items:(t .=. combine y x)+ $items:(x .=. t) } /*@@ -385,7 +428,7 @@ $items:(sdata "threadIdx.x" .=. x) __syncthreads(); - $items:(scanBlock dev fun x y sdata Nothing)+ $items:(scanBlock dev fun x y t sdata Nothing) /* * Store the final result of the block to be carried in@@ -411,6 +454,7 @@ (argOut, _, setOut) = writeArray "Out" (undefined :: Vector e) (_, x, declx) = locals "x" (undefined :: e) (_, y, decly) = locals "y" (undefined :: e)+ (_, t, declt) = locals "t" (undefined :: e) (sh, _, _) = locals "sh" (undefined :: DIM1) (smem, sdata) = shared (undefined :: e) "sdata" [cexp| blockDim.x |] Nothing ix = [cvar "ix"]@@ -432,7 +476,7 @@ -> Maybe (CUExp aenv e) -> CUTranslSkel aenv (Vector e) mkScanUp2 dir dev aenv f z- = let (_, get) = readArray "Blk" (undefined :: Vector e)+ = let (_, _, get) = readArray "Blk" (undefined :: Vector e) in mkScan dir dev aenv f z get @@ -443,13 +487,13 @@ :: forall aenv e. Elt e => DeviceProperties -> CUFun2 aenv (e -> e -> e)- -> [C.Exp] -> [C.Exp]+ -> [C.Exp] -> [C.Exp] -> [C.Exp] -> (Name -> [C.Exp]) -> Maybe C.Exp -> [C.BlockItem]-scanBlock dev f x0 x1 sdata mlim+scanBlock dev f x0 x1 x2 sdata mlim | shflOK dev (undefined :: e) = error "shfl-scan"- | otherwise = scanBlockTree dev f x0 x1 sdata mlim+ | otherwise = scanBlockTree dev f x0 x1 x2 sdata mlim -- Use a thread block to scan values in shared memory. Each thread must have@@ -461,11 +505,11 @@ :: forall aenv e. Elt e => DeviceProperties -> CUFun2 aenv (e -> e -> e)- -> [C.Exp] -> [C.Exp] -- temporary variables x0 and x1+ -> [C.Exp] -> [C.Exp] -> [C.Exp] -- input variables x0 and x1, plus a temporary to store the intermediate value -> (Name -> [C.Exp]) -- index elements from shared memory -> Maybe C.Exp -- partially full block bounds check? -> [C.BlockItem]-scanBlockTree dev (CUFun2 _ _ f) x0 x1 sdata mlim = map (scan . pow2) [ 0 .. maxThreads ]+scanBlockTree dev (CUFun2 _ _ f) x0 x1 x2 sdata mlim = map (scan . pow2) [ 0 .. maxThreads ] where pow2 :: Int -> Int pow2 x = 2 ^ x@@ -479,7 +523,8 @@ if ( blockDim.x > $int:n ) { if ( $exp:(inrange n) ) { $items:(x1 .=. sdata ("threadIdx.x - " ++ show n))- $items:(x0 .=. f x1 x0)+ $items:(x2 .=. f x1 x0)+ $items:(x0 .=. x2) } __syncthreads(); $items:(sdata "threadIdx.x" .=. x0)
Data/Array/Accelerate/CUDA/CodeGen/Reduction.hs view
@@ -1,12 +1,13 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen.Reduction--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>@@ -24,16 +25,15 @@ import Language.C.Quote.CUDA import qualified Language.C.Syntax as C -import Data.Array.Accelerate.Type ( IsIntegral )-import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt, Z(..), (:.)(..) ) import Data.Array.Accelerate.Analysis.Shape+import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt, Z(..), (:.)(..) )+import Data.Array.Accelerate.Error ( internalError )+import Data.Array.Accelerate.Type ( IsIntegral ) import Data.Array.Accelerate.CUDA.AST import Data.Array.Accelerate.CUDA.CodeGen.Base import Data.Array.Accelerate.CUDA.CodeGen.Type -#include "accelerate.h" - -- Reduce an array along the innermost dimension. The function must be -- associative to enable efficient parallel implementation. --@@ -93,7 +93,7 @@ -> CUDelayedAcc aenv (sh :. Int) e -> [ CUTranslSkel aenv (Array sh e) ] mkFoldAll dev aenv f z a- = let (_, rec) = readArray "Rec" (undefined :: Array (sh:.Int) e)+ = let (_, _, rec) = readArray "Rec" (undefined :: Array (sh:.Int) e) in [ mkFoldAll' False dev aenv f z a , mkFoldAll' True dev aenv f z rec ]@@ -125,6 +125,7 @@ $decls:smem $decls:declx $decls:decly+ $decls:declz $items:(sh .=. shIn) @@ -159,7 +160,8 @@ for ( ix += gridSize; ix < shapeSize; ix += gridSize ) { $items:(x .=. get ix)- $items:(y .=. combine x y)+ $items:(z .=. combine y x)+ $items:(y .=. z) } } @@ -170,7 +172,7 @@ $items:(sdata "threadIdx.x" .=. y) ix = min(shapeSize - blockIdx.x * blockDim.x, blockDim.x);- $items:(reduceBlock dev fun x y sdata (cvar "ix"))+ $items:(reduceBlock dev fun x y z sdata (cvar "ix")) /* * Write the results of this block back to global memory. If we are the last@@ -186,12 +188,13 @@ foldAll = maybe "fold1All" (const "foldAll") mseed (texIn, argIn) = environment dev aenv (argOut, _, setOut) = writeArray "Out" (undefined :: Array (sh :. Int) e)- (argRec, _)+ (argRec, _, _) | recursive = readArray "Rec" (undefined :: Array (sh :. Int) e)- | otherwise = ([], undefined)+ | otherwise = ([], undefined, undefined) (_, x, declx) = locals "x" (undefined :: e) (_, y, decly) = locals "y" (undefined :: e)+ (_, z, declz) = locals "z" (undefined :: e) (sh, _, _) = locals "sh" (undefined :: sh :. Int) ix = [cvar "ix"] (smem, sdata) = shared (undefined :: e) "sdata" [cexp| blockDim.x |] Nothing@@ -201,7 +204,8 @@ if ( shapeSize > 0 ) { if ( gridDim.x == 1 ) { $items:(x .=. seed)- $items:(y .=. combine x y)+ $items:(z .=. combine y x)+ $items:(y .=. z) } $items:(setOut "blockIdx.x" .=. y) }@@ -239,6 +243,7 @@ $decls:smem $decls:declx $decls:decly+ $decls:declz $items:(sh .=. shIn) @@ -291,7 +296,8 @@ $items:(x .=. get [cvar "ix + blockDim.x"]) if ( ix >= start ) {- $items:(y .=. combine x y)+ $items:(z .=. combine y x)+ $items:(y .=. z) } else { $items:(y .=. x)@@ -304,7 +310,8 @@ for ( ix += 2 * blockDim.x; ix < end; ix += blockDim.x ) { $items:(x .=. get ix)- $items:(y .=. combine x y)+ $items:(z .=. combine y x)+ $items:(y .=. z) } } else@@ -317,7 +324,7 @@ * cooperatively reduces this to a single value. */ $items:(sdata "threadIdx.x" .=. y)- $items:(reduceBlock dev fun x y sdata (cvar "n"))+ $items:(reduceBlock dev fun x y z sdata (cvar "n")) /* * Finally, the first thread writes the result for this segment. For@@ -336,6 +343,7 @@ (argOut, shOut, setOut) = writeArray "Out" (undefined :: Array sh e) (_, x, declx) = locals "x" (undefined :: e) (_, y, decly) = locals "y" (undefined :: e)+ (_, z, declz) = locals "z" (undefined :: e) (sh, _, _) = locals "sh" (undefined :: sh :. Int) ix = [cvar "ix"] (smem, sdata) = shared (undefined :: e) "sdata" [cexp| blockDim.x |] Nothing@@ -355,7 +363,8 @@ -- exclusive_finish (CUExp seed) = concat [ x .=. seed- , y .=. combine x y ]+ , z .=. combine y x+ , y .=. z ] -- Segmented reduction along the innermost dimension of an array. Performs one@@ -451,6 +460,7 @@ $decls:smem $decls:declx $decls:decly+ $decls:declz $items:(sh .=. shIn) /*@@ -499,7 +509,8 @@ $items:(x .=. get [cvar "ix + warpSize"]) if ( ix >= start ) {- $items:(y .=. combine x y)+ $items:(z .=. combine y x)+ $items:(y .=. z) } else { $items:(y .=. x)@@ -512,7 +523,8 @@ for ( ix += 2 * warpSize; ix < end; ix += warpSize ) { $items:(x .=. get ix)- $items:(y .=. combine x y)+ $items:(z .=. combine y x)+ $items:(y .=. z) } } else if ( start + thread_lane < end )@@ -525,7 +537,7 @@ */ ix = min(num_elements, warpSize); $items:(sdata "threadIdx.x" .=. y)- $items:(reduceWarp dev fun x y sdata (cvar "ix") (cvar "thread_lane"))+ $items:(reduceWarp dev fun x y z sdata (cvar "ix") (cvar "thread_lane")) /* * Finally, the first thread writes the result for this segment@@ -544,6 +556,7 @@ (argOut, shOut, setOut) = writeArray "Out" (undefined :: Array (sh :. Int) e) (_, x, declx) = locals "x" (undefined :: e) (_, y, decly) = locals "y" (undefined :: e)+ (_, z, declz) = locals "z" (undefined :: e) (sh, _, _) = locals "sh" (undefined :: sh :. Int) (smem, sdata) = shared (undefined :: e) "sdata" [cexp| blockDim.x |] (Just $ [cexp| &s_ptrs[vectors_per_block][2] |]) --@@ -554,7 +567,8 @@ exclusive_finish (CUExp seed) = [[citem| if ( num_elements > 0 ) { $items:(x .=. seed)- $items:(y .=. combine x y)+ $items:(z .=. combine y x)+ $items:(y .=. z) } else { $items:(y .=. seed) } |]]@@ -572,28 +586,28 @@ :: forall aenv e. Elt e => DeviceProperties -> CUFun2 aenv (e -> e -> e)- -> [C.Exp] -> [C.Exp] -- temporary variables x0 and x1+ -> [C.Exp] -> [C.Exp] -> [C.Exp] -- input variables x0 and x1, plus a temporary to store the intermediate result -> (Name -> [C.Exp]) -- index elements from shared memory -> C.Exp -- number of elements -> C.Exp -- thread identifier: usually lane or thread ID -> [C.BlockItem]-reduceWarp dev fun x0 x1 sdata n tid+reduceWarp dev fun x0 x1 x2 sdata n tid | shflOK dev (undefined :: e) = return- $ reduceWarpShfl dev fun x0 x1 n tid- | otherwise = reduceWarpTree dev fun x0 x1 sdata n tid+ $ reduceWarpShfl dev fun x0 x1 n tid+ | otherwise = reduceWarpTree dev fun x0 x1 x2 sdata n tid reduceBlock :: forall aenv e. Elt e => DeviceProperties -> CUFun2 aenv (e -> e -> e)- -> [C.Exp] -> [C.Exp] -- temporary variables x0 and x1+ -> [C.Exp] -> [C.Exp] -> [C.Exp] -- input variables x0 and x1, plus a temporary to store the intermediate result -> (Name -> [C.Exp]) -- index elements from shared memory -> C.Exp -- number of elements -> [C.BlockItem]-reduceBlock dev fun x0 x1 sdata n- | shflOK dev (undefined :: e) = reduceBlockShfl dev fun x0 x1 sdata n- | otherwise = reduceBlockTree dev fun x0 x1 sdata n+reduceBlock dev fun x0 x1 x2 sdata n+ | shflOK dev (undefined :: e) = reduceBlockShfl dev fun x0 x1 sdata n+ | otherwise = reduceBlockTree dev fun x0 x1 x2 sdata n -- Tree reduction@@ -603,12 +617,12 @@ :: Elt e => DeviceProperties -> CUFun2 aenv (e -> e -> e)- -> [C.Exp] -> [C.Exp] -- temporary variables x0 and x1+ -> [C.Exp] -> [C.Exp] -> [C.Exp] -- input variables x0 and x1, plus a temporary to store the intermediate result -> (Name -> [C.Exp]) -- index elements from shared memory -> C.Exp -- number of elements -> C.Exp -- thread identifier: usually lane or thread ID -> [C.BlockItem]-reduceWarpTree dev (CUFun2 _ _ f) x0 x1 sdata n tid+reduceWarpTree dev (CUFun2 _ _ f) x0 x1 x2 sdata n tid = map (reduce . pow2) [v, v-1 .. 0] where v = floor (logBase 2 (fromIntegral $ warpSize dev :: Double))@@ -620,12 +634,14 @@ reduce 0 = [citem| if ( $exp:tid < $exp:n ) { $items:(x0 .=. sdata "threadIdx.x + 1")- $items:(x1 .=. f x1 x0)+ $items:(x2 .=. f x1 x0)+ $items:(x1 .=. x2) } |] reduce i = [citem| if ( $exp:tid + $int:i < $exp:n ) { $items:(x0 .=. sdata ("threadIdx.x + " ++ show i))- $items:(x1 .=. f x1 x0)+ $items:(x2 .=. f x1 x0)+ $items:(x1 .=. x2) $items:(sdata "threadIdx.x" .=. x1) } |] @@ -633,11 +649,11 @@ :: Elt e => DeviceProperties -> CUFun2 aenv (e -> e -> e)- -> [C.Exp] -> [C.Exp] -- temporary variables x0 and x1+ -> [C.Exp] -> [C.Exp] -> [C.Exp] -- input variables x0 and x1, plus a temporary to store the intermediate result -> (Name -> [C.Exp]) -- index elements from shared memory -> C.Exp -- number of elements -> [C.BlockItem]-reduceBlockTree dev fun@(CUFun2 _ _ f) x0 x1 sdata n+reduceBlockTree dev fun@(CUFun2 _ _ f) x0 x1 x2 sdata n = flip (foldr1 (.)) [] $ map (reduce . pow2) [u-1, u-2 .. v] @@ -664,7 +680,8 @@ = [citem| __syncthreads(); |] : [citem| if ( threadIdx.x + $int:i < $exp:n ) { $items:(x0 .=. sdata ("threadIdx.x + " ++ show i))- $items:(x1 .=. f x1 x0)+ $items:(x2 .=. f x1 x0)+ $items:(x1 .=. x2) } |] : [citem| __syncthreads(); |] : (sdata "threadIdx.x" .=. x1)@@ -677,7 +694,7 @@ | otherwise = [citem| __syncthreads(); |] : [citem| if ( threadIdx.x < $int:(warpSize dev) ) {- $items:(reduceWarpTree dev fun x0 x1 sdata n (cvar "threadIdx.x"))+ $items:(reduceWarpTree dev fun x0 x1 x2 sdata n (cvar "threadIdx.x")) } |] : rest @@ -718,7 +735,7 @@ where shfl 4 = "shfl_xor32" shfl 8 = "shfl_xor64"- shfl _ = INTERNAL_ERROR(error) "shfl_xor" "I only know about 32- and 64-bit types"+ shfl _ = $internalError "shfl_xor" "I only know about 32- and 64-bit types" -- Reduce a block of values in butterfly fashion using __shfl_xor(). Each warp
Data/Array/Accelerate/CUDA/CodeGen/Stencil.hs view
@@ -1,11 +1,12 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen.Stencil--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>
Data/Array/Accelerate/CUDA/CodeGen/Stencil/Extra.hs view
@@ -1,12 +1,12 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen.Stencil.Extra--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>@@ -33,6 +33,7 @@ import qualified Language.C.Syntax as C -- friends+import Data.Array.Accelerate.Error ( internalError ) import Data.Array.Accelerate.Type ( Boundary(..) ) import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt, shapeToList ) import Data.Array.Accelerate.Analysis.Shape@@ -42,9 +43,7 @@ import Data.Array.Accelerate.CUDA.CodeGen.Base import Data.Array.Accelerate.CUDA.CodeGen.Type -#include "accelerate.h" - -- Stencil Access -- -------------- @@ -190,7 +189,7 @@ -- Test whether an index lies within the boundaries of a shape (first argument) -- cinRange :: [C.Exp] -> [C.Exp] -> C.Exp-cinRange [] [] = INTERNAL_ERROR(error) "inRange" "singleton index"+cinRange [] [] = $internalError "inRange" "singleton index" cinRange shape index = foldl1 and (zipWith inside shape index) where inside sz i = [cexp| ({ const $ty:cint _i = $exp:i; _i >= 0 && _i < $exp:sz; }) |]@@ -264,12 +263,12 @@ zipWith :: (a -> b -> c) -> [a] -> [b] -> [c] zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys zipWith _ [] [] = []-zipWith _ _ _ = INTERNAL_ERROR(error) "zipWith" "argument mismatch"+zipWith _ _ _ = $internalError "zipWith" "argument mismatch" zipWith3 :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] zipWith3 f (x:xs) (y:ys) (z:zs) = f x y z : zipWith3 f xs ys zs zipWith3 _ [] [] [] = []-zipWith3 _ _ _ _ = INTERNAL_ERROR(error) "zipWith3" "argument mismatch"+zipWith3 _ _ _ _ = $internalError "zipWith3" "argument mismatch" -- Split a list into segments of given length
+ Data/Array/Accelerate/CUDA/CodeGen/Streaming.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++-- |+-- Module : Data.Array.Accelerate.CUDA.CodeGen.Streaming+--+-- Maintainer : Frederik Meisner Madsen <fmma@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.CUDA.CodeGen.Streaming (++ mkToSeq++) where++import Language.C.Quote.CUDA+import Foreign.CUDA.Analysis.Device++import Data.Array.Accelerate.Error ( internalError )+import Data.Array.Accelerate.Array.Representation ( SliceIndex(..) )+import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt, EltRepr )+import Data.Array.Accelerate.CUDA.AST+import Data.Array.Accelerate.CUDA.CodeGen.Base++mkToSeq+ :: forall slix aenv sh co sl a. (Shape sl, Shape sh, Elt a)+ => SliceIndex slix+ (EltRepr sl)+ co+ (EltRepr sh)+ -> DeviceProperties+ -> Gamma aenv+ -> CUDelayedAcc aenv sh a+ -> CUTranslSkel aenv (Array sl a)+mkToSeq slix dev aenv arr+ | CUDelayed (CUExp shIn) (CUFun1 _ get) _ <- arr+ = CUTranslSkel "tostream" [cunit|++ $esc:("#include <accelerate_cuda.h>")+ $edecls:texIn++ extern "C" __global__ void+ tostream+ (+ $params:argIn,+ $params:slIn,+ $params:argOut+ )+ {+ $items:(sh .=. shIn)++ const int shapeSize = $exp:(csize shOut);+ const int gridSize = $exp:(gridSize dev);+ int ix;++ for ( ix = $exp:(threadIdx dev)+ ; ix < shapeSize+ ; ix += gridSize )+ {+ $items:(src .=. cfromIndex shOut "ix" "tmp")+ $items:(setOut "ix" .=. get fullsrc)+ }+ }+ |]+ where+ (slIn, _, cosrc) = cslice slix "cosrc"+ (sh, _, _) = locals "shIn" (undefined :: sh)+ (src, _, _) = locals "src" (undefined :: sl)+ fullsrc = reverse (combine slix (reverse src) (reverse cosrc))+ (texIn, argIn) = environment dev aenv+ (argOut, shOut, setOut) = writeArray "Out" (undefined :: Array sl a)++combine :: SliceIndex slix sl co dim -> [a] -> [a] -> [a]+combine SliceNil [] [] = []+combine (SliceAll sl) (x:xs) ys = x:(combine sl xs ys)+combine (SliceFixed sl) xs (y:ys) = y:(combine sl xs ys)+combine _ _ _ = $internalError "mkToSeq" "Something went wrong with the slice index."+
Data/Array/Accelerate/CUDA/CodeGen/Type.hs view
@@ -1,11 +1,11 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>@@ -21,48 +21,72 @@ accType, accTypeTex, segmentsType, expType, eltType, eltTypeTex, eltSizeOf, - -- primitive bits...- codegenIntegralType, codegenScalarType+ -- working with reified dictionaries+ TypeOf(..),+ signedIntegralNum, unsignedIntegralNum, ) where -- friends+import Data.Array.Accelerate.Array.Data+import Data.Array.Accelerate.Error import Data.Array.Accelerate.Type import Data.Array.Accelerate.Trafo import qualified Data.Array.Accelerate.Array.Sugar as Sugar import qualified Data.Array.Accelerate.Analysis.Type as Sugar -- libraries+import Data.Bits import Language.C.Quote.CUDA+import qualified Data.Typeable as T import qualified Language.C as C -#include "accelerate.h" +class TypeOf a where+ typeOf :: a -> C.Type+ texTypeOf :: a -> C.Type -typename :: String -> C.Type-typename name = [cty| typename $id:name |]+instance TypeOf (ScalarType a) where+ typeOf = cScalarType+ texTypeOf = cScalarTypeTex +instance TypeOf (NumType a) where+ typeOf = cNumType+ texTypeOf = cNumTypeTex++instance TypeOf (IntegralType a) where+ typeOf = cIntegralType+ texTypeOf = cIntegralTypeTex++instance TypeOf (FloatingType a) where+ typeOf = cFloatingType+ texTypeOf = cFloatingTypeTex++instance TypeOf (NonNumType a) where+ typeOf = cNonNumType+ texTypeOf = cNonNumTypeTex++ -- Surface element types -- --------------------- - accType :: DelayedOpenAcc aenv (Sugar.Array dim e) -> [C.Type]-accType = codegenTupleType . Sugar.delayedAccType+accType = cTupleType . Sugar.delayedAccType expType :: DelayedOpenExp aenv env t -> [C.Type]-expType = codegenTupleType . Sugar.preExpType Sugar.delayedAccType+expType = cTupleType . Sugar.preExpType Sugar.delayedAccType segmentsType :: DelayedOpenAcc aenv (Sugar.Segments i) -> C.Type segmentsType seg | [s] <- accType seg = s- | otherwise = INTERNAL_ERROR(error) "accType" "non-scalar segment type"+ | otherwise = $internalError "accType" "non-scalar segment type" eltType :: Sugar.Elt a => a {- dummy -} -> [C.Type]-eltType = codegenTupleType . Sugar.eltType+eltType = cTupleType . Sugar.eltType eltTypeTex :: Sugar.Elt a => a {- dummy -} -> [C.Type]-eltTypeTex = codegenTupleTex . Sugar.eltType+eltTypeTex = cTupleTypeTex . Sugar.eltType eltSizeOf :: Sugar.Elt a => a {- dummy -} -> [Int] eltSizeOf = sizeOf' . Sugar.eltType@@ -73,110 +97,131 @@ sizeOf' (PairTuple a b) = sizeOf' a ++ sizeOf' b --- Implementation----codegenTupleType :: TupleType a -> [C.Type]-codegenTupleType UnitTuple = []-codegenTupleType (SingleTuple ty) = [codegenScalarType ty]-codegenTupleType (PairTuple t1 t0) = codegenTupleType t1 ++ codegenTupleType t0 -codegenScalarType :: ScalarType a -> C.Type-codegenScalarType (NumScalarType ty) = codegenNumType ty-codegenScalarType (NonNumScalarType ty) = codegenNonNumType ty+cTupleType :: TupleType a -> [C.Type]+cTupleType UnitTuple = []+cTupleType (SingleTuple ty) = [cScalarType ty]+cTupleType (PairTuple t1 t0) = cTupleType t1 ++ cTupleType t0 -codegenNumType :: NumType a -> C.Type-codegenNumType (IntegralNumType ty) = codegenIntegralType ty-codegenNumType (FloatingNumType ty) = codegenFloatingType ty+cScalarType :: ScalarType a -> C.Type+cScalarType (NumScalarType ty) = cNumType ty+cScalarType (NonNumScalarType ty) = cNonNumType ty -codegenIntegralType :: IntegralType a -> C.Type-codegenIntegralType (TypeInt8 _) = typename "Int8"-codegenIntegralType (TypeInt16 _) = typename "Int16"-codegenIntegralType (TypeInt32 _) = typename "Int32"-codegenIntegralType (TypeInt64 _) = typename "Int64"-codegenIntegralType (TypeWord8 _) = typename "Word8"-codegenIntegralType (TypeWord16 _) = typename "Word16"-codegenIntegralType (TypeWord32 _) = typename "Word32"-codegenIntegralType (TypeWord64 _) = typename "Word64"-codegenIntegralType (TypeCShort _) = [cty|short|]-codegenIntegralType (TypeCUShort _) = [cty|unsigned short|]-codegenIntegralType (TypeCInt _) = [cty|int|]-codegenIntegralType (TypeCUInt _) = [cty|unsigned int|]-codegenIntegralType (TypeCLong _) = [cty|long int|]-codegenIntegralType (TypeCULong _) = [cty|unsigned long int|]-codegenIntegralType (TypeCLLong _) = [cty|long long int|]-codegenIntegralType (TypeCULLong _) = [cty|unsigned long long int|]--- XXX: GHC's inbuilt CPP system can't handle stringification-codegenIntegralType (TypeInt _) = typename $ "Int" ++ show (SIZEOF_HTYPE_INT * 8 :: Int)-codegenIntegralType (TypeWord _) = typename $ "Word" ++ show (SIZEOF_HTYPE_INT * 8 :: Int)+cNumType :: NumType a -> C.Type+cNumType (IntegralNumType ty) = cIntegralType ty+cNumType (FloatingNumType ty) = cFloatingType ty -codegenFloatingType :: FloatingType a -> C.Type-codegenFloatingType (TypeFloat _) = [cty|float|]-codegenFloatingType (TypeCFloat _) = [cty|float|]-codegenFloatingType (TypeDouble _) = [cty|double|]-codegenFloatingType (TypeCDouble _) = [cty|double|]+cIntegralType :: IntegralType a -> C.Type+cIntegralType (TypeInt8 _) = typename "Int8"+cIntegralType (TypeInt16 _) = typename "Int16"+cIntegralType (TypeInt32 _) = typename "Int32"+cIntegralType (TypeInt64 _) = typename "Int64"+cIntegralType (TypeWord8 _) = typename "Word8"+cIntegralType (TypeWord16 _) = typename "Word16"+cIntegralType (TypeWord32 _) = typename "Word32"+cIntegralType (TypeWord64 _) = typename "Word64"+cIntegralType (TypeCShort _) = [cty|short|]+cIntegralType (TypeCUShort _) = [cty|unsigned short|]+cIntegralType (TypeCInt _) = [cty|int|]+cIntegralType (TypeCUInt _) = [cty|unsigned int|]+cIntegralType (TypeCLong _) = [cty|long int|]+cIntegralType (TypeCULong _) = [cty|unsigned long int|]+cIntegralType (TypeCLLong _) = [cty|long long int|]+cIntegralType (TypeCULLong _) = [cty|unsigned long long int|]+cIntegralType (TypeInt _) = typename (T.showsTypeRep (T.typeOf (undefined::HTYPE_INT)) "")+cIntegralType (TypeWord _) = typename (T.showsTypeRep (T.typeOf (undefined::HTYPE_WORD)) "") -codegenNonNumType :: NonNumType a -> C.Type-codegenNonNumType (TypeBool _) = typename "Word8"-codegenNonNumType (TypeChar _) = typename "Word32"-codegenNonNumType (TypeCChar _) = [cty|char|]-codegenNonNumType (TypeCSChar _) = [cty|signed char|]-codegenNonNumType (TypeCUChar _) = [cty|unsigned char|]+cFloatingType :: FloatingType a -> C.Type+cFloatingType (TypeFloat _) = [cty|float|]+cFloatingType (TypeCFloat _) = [cty|float|]+cFloatingType (TypeDouble _) = [cty|double|]+cFloatingType (TypeCDouble _) = [cty|double|] +cNonNumType :: NonNumType a -> C.Type+cNonNumType (TypeBool _) = typename "Word8"+cNonNumType (TypeChar _) = typename "Word32"+cNonNumType (TypeCChar _) = [cty|char|]+cNonNumType (TypeCSChar _) = [cty|signed char|]+cNonNumType (TypeCUChar _) = [cty|unsigned char|] + -- Texture types -- ------------- accTypeTex :: DelayedOpenAcc aenv (Sugar.Array dim e) -> [C.Type]-accTypeTex = codegenTupleTex . Sugar.delayedAccType+accTypeTex = cTupleTypeTex . Sugar.delayedAccType -- Implementation ---codegenTupleTex :: TupleType a -> [C.Type]-codegenTupleTex UnitTuple = []-codegenTupleTex (SingleTuple t) = [codegenScalarTex t]-codegenTupleTex (PairTuple t1 t0) = codegenTupleTex t1 ++ codegenTupleTex t0+cTupleTypeTex :: TupleType a -> [C.Type]+cTupleTypeTex UnitTuple = []+cTupleTypeTex (SingleTuple t) = [cScalarTypeTex t]+cTupleTypeTex (PairTuple t1 t0) = cTupleTypeTex t1 ++ cTupleTypeTex t0 -codegenScalarTex :: ScalarType a -> C.Type-codegenScalarTex (NumScalarType ty) = codegenNumTex ty-codegenScalarTex (NonNumScalarType ty) = codegenNonNumTex ty;+cScalarTypeTex :: ScalarType a -> C.Type+cScalarTypeTex (NumScalarType ty) = cNumTypeTex ty+cScalarTypeTex (NonNumScalarType ty) = cNonNumTypeTex ty; -codegenNumTex :: NumType a -> C.Type-codegenNumTex (IntegralNumType ty) = codegenIntegralTex ty-codegenNumTex (FloatingNumType ty) = codegenFloatingTex ty+cNumTypeTex :: NumType a -> C.Type+cNumTypeTex (IntegralNumType ty) = cIntegralTypeTex ty+cNumTypeTex (FloatingNumType ty) = cFloatingTypeTex ty -codegenIntegralTex :: IntegralType a -> C.Type-codegenIntegralTex (TypeInt8 _) = typename "TexInt8"-codegenIntegralTex (TypeInt16 _) = typename "TexInt16"-codegenIntegralTex (TypeInt32 _) = typename "TexInt32"-codegenIntegralTex (TypeInt64 _) = typename "TexInt64"-codegenIntegralTex (TypeWord8 _) = typename "TexWord8"-codegenIntegralTex (TypeWord16 _) = typename "TexWord16"-codegenIntegralTex (TypeWord32 _) = typename "TexWord32"-codegenIntegralTex (TypeWord64 _) = typename "TexWord64"-codegenIntegralTex (TypeCShort _) = typename "TexCShort"-codegenIntegralTex (TypeCUShort _) = typename "TexCUShort"-codegenIntegralTex (TypeCInt _) = typename "TexCInt"-codegenIntegralTex (TypeCUInt _) = typename "TexCUInt"-codegenIntegralTex (TypeCLong _) = typename "TexCLong"-codegenIntegralTex (TypeCULong _) = typename "TexCULong"-codegenIntegralTex (TypeCLLong _) = typename "TexCLLong"-codegenIntegralTex (TypeCULLong _) = typename "TexCULLong"--- XXX: GHC's inbuilt CPP system can't handle stringification-codegenIntegralTex (TypeInt _) = typename $ "TexInt" ++ show (SIZEOF_HTYPE_INT * 8 :: Int)-codegenIntegralTex (TypeWord _) = typename $ "TexWord" ++ show (SIZEOF_HTYPE_INT * 8 :: Int)+cIntegralTypeTex :: IntegralType a -> C.Type+cIntegralTypeTex (TypeInt8 _) = typename "TexInt8"+cIntegralTypeTex (TypeInt16 _) = typename "TexInt16"+cIntegralTypeTex (TypeInt32 _) = typename "TexInt32"+cIntegralTypeTex (TypeInt64 _) = typename "TexInt64"+cIntegralTypeTex (TypeWord8 _) = typename "TexWord8"+cIntegralTypeTex (TypeWord16 _) = typename "TexWord16"+cIntegralTypeTex (TypeWord32 _) = typename "TexWord32"+cIntegralTypeTex (TypeWord64 _) = typename "TexWord64"+cIntegralTypeTex (TypeCShort _) = typename "TexCShort"+cIntegralTypeTex (TypeCUShort _) = typename "TexCUShort"+cIntegralTypeTex (TypeCInt _) = typename "TexCInt"+cIntegralTypeTex (TypeCUInt _) = typename "TexCUInt"+cIntegralTypeTex (TypeCLong _) = typename "TexCLong"+cIntegralTypeTex (TypeCULong _) = typename "TexCULong"+cIntegralTypeTex (TypeCLLong _) = typename "TexCLLong"+cIntegralTypeTex (TypeCULLong _) = typename "TexCULLong"+cIntegralTypeTex (TypeInt _) = typename ("TexInt" ++ show (finiteBitSize (undefined::Int)))+cIntegralTypeTex (TypeWord _) = typename ("TexWord" ++ show (finiteBitSize (undefined::Word))) -codegenFloatingTex :: FloatingType a -> C.Type-codegenFloatingTex (TypeFloat _) = typename "TexFloat"-codegenFloatingTex (TypeCFloat _) = typename "TexCFloat"-codegenFloatingTex (TypeDouble _) = typename "TexDouble"-codegenFloatingTex (TypeCDouble _) = typename "TexCDouble"+cFloatingTypeTex :: FloatingType a -> C.Type+cFloatingTypeTex (TypeFloat _) = typename "TexFloat"+cFloatingTypeTex (TypeCFloat _) = typename "TexCFloat"+cFloatingTypeTex (TypeDouble _) = typename "TexDouble"+cFloatingTypeTex (TypeCDouble _) = typename "TexCDouble" -codegenNonNumTex :: NonNumType a -> C.Type-codegenNonNumTex (TypeBool _) = typename "TexWord8"-codegenNonNumTex (TypeChar _) = typename "TexWord32"-codegenNonNumTex (TypeCChar _) = typename "TexCChar"-codegenNonNumTex (TypeCSChar _) = typename "TexCSChar"-codegenNonNumTex (TypeCUChar _) = typename "TexCUChar"+cNonNumTypeTex :: NonNumType a -> C.Type+cNonNumTypeTex (TypeBool _) = typename "TexWord8"+cNonNumTypeTex (TypeChar _) = typename "TexWord32"+cNonNumTypeTex (TypeCChar _) = typename "TexCChar"+cNonNumTypeTex (TypeCSChar _) = typename "TexCSChar"+cNonNumTypeTex (TypeCUChar _) = typename "TexCUChar"+++-- Utilities+-- ---------++typename :: String -> C.Type+typename name = [cty| typename $id:name |]++signedIntegralNum :: IntegralType a -> Bool+signedIntegralNum t =+ case t of+ TypeInt _ -> True+ TypeInt8 _ -> True+ TypeInt16 _ -> True+ TypeInt32 _ -> True+ TypeInt64 _ -> True+ TypeCShort _ -> True+ TypeCInt _ -> True+ TypeCLong _ -> True+ TypeCLLong _ -> True+ _ -> False++unsignedIntegralNum :: IntegralType a -> Bool+unsignedIntegralNum = not . signedIntegralNum
Data/Array/Accelerate/CUDA/Compile.hs view
@@ -3,11 +3,12 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} -- | -- Module : Data.Array.Accelerate.CUDA.Compile--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>@@ -18,14 +19,13 @@ module Data.Array.Accelerate.CUDA.Compile ( -- * generate and compile kernels to realise a computation- compileAcc, compileAfun+ compileAcc, compileAfun, ) where -#include "accelerate.h"- -- friends-import Data.Array.Accelerate.Tuple+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Lifetime import Data.Array.Accelerate.Trafo import Data.Array.Accelerate.CUDA.AST import Data.Array.Accelerate.CUDA.State@@ -35,12 +35,11 @@ import Data.Array.Accelerate.CUDA.Analysis.Launch import Data.Array.Accelerate.CUDA.Foreign.Import ( canExecuteAcc, canExecuteExp ) import Data.Array.Accelerate.CUDA.Persistent as KT-import qualified Data.Array.Accelerate.CUDA.FullList as FL+import qualified Data.Array.Accelerate.FullList as FL import qualified Data.Array.Accelerate.CUDA.Debug as D -- libraries import Numeric-import Prelude hiding ( exp, scanl, scanr ) import Control.Applicative hiding ( Const ) import Control.Exception import Control.Monad@@ -50,6 +49,7 @@ import Control.Concurrent import Crypto.Hash.MD5 ( hashlazy ) import Data.List ( intercalate )+import Data.Bits import Data.Maybe import Data.Monoid import System.Directory@@ -58,9 +58,7 @@ import System.IO import System.IO.Error import System.IO.Unsafe-import System.Time import System.Process-import System.Mem.Weak import Text.PrettyPrint.Mainland ( ppr, renderCompact, displayLazyText ) import qualified Data.ByteString as B import qualified Data.Text.Lazy as T@@ -69,13 +67,21 @@ import qualified Control.Concurrent.MSem as Q import qualified Foreign.CUDA.Driver as CUDA import qualified Foreign.CUDA.Analysis as CUDA+import Prelude hiding ( exp, scanl, scanr ) import GHC.Conc ( getNumProcessors ) -#ifdef VERSION_unix+#ifdef ACCELERATE_DEBUG+import System.Time+#endif++-- Multiplatform support for dealing with external process spawning+#if defined(UNIX) import System.Posix.Process+#elif defined(WIN32)+import System.Win32.Process hiding ( ProcessHandle ) #else-import System.Win32.Process+#error "I don't know what operating system I am" #endif import Paths_accelerate_cuda ( getDataDir )@@ -114,7 +120,7 @@ -- are merged at every step. -- traverseAcc :: forall aenv arrs. DelayedOpenAcc aenv arrs -> CIO (ExecOpenAcc aenv arrs)- traverseAcc Delayed{} = INTERNAL_ERROR(error) "compileOpenAcc" "unexpected delayed array"+ traverseAcc Delayed{} = $internalError "compileOpenAcc" "unexpected delayed array" traverseAcc topAcc@(Manifest pacc) = case pacc of -- Environment and control flow@@ -127,7 +133,7 @@ Aprj ix tup -> node =<< liftA (Aprj ix) <$> travA tup -- Foreign- Aforeign ff afun a -> node =<< foreignA ff afun a+ Aforeign ff afun a -> foreignA ff afun a -- Array injection Unit e -> node =<< liftA Unit <$> travE e@@ -161,6 +167,9 @@ Stencil2 f b1 a1 b2 a2 -> exec =<< liftA3 stencil2 <$> travF f <*> travA a1 <*> travA a2 where stencil2 f' a1' a2' = Stencil2 f' b1 a1' b2 a2' + -- Loops+ -- Collect l -> ExecSeq <$> compileOpenSeq l+ where use :: ArraysR a -> a -> CIO () use ArraysRunit () = return ()@@ -191,121 +200,227 @@ travAtup NilAtup = return (pure NilAtup) travAtup (SnocAtup t a) = liftA2 SnocAtup <$> travAtup t <*> travA a + travE :: DelayedOpenExp env aenv e+ -> CIO (Free aenv, PreOpenExp ExecOpenAcc env aenv e)+ travE = compileOpenExp+ travF :: DelayedOpenFun env aenv t -> CIO (Free aenv, PreOpenFun ExecOpenAcc env aenv t) travF (Body b) = liftA Body <$> travE b travF (Lam f) = liftA Lam <$> travF f noKernel :: FL.FullList () (AccKernel a)- noKernel = FL.FL () (INTERNAL_ERROR(error) "compile" "no kernel module for this node") FL.Nil+ noKernel = FL.FL () ($internalError "compile" "no kernel module for this node") FL.Nil fullOfList :: [a] -> FL.FullList () a- fullOfList [] = INTERNAL_ERROR(error) "fullList" "empty list"+ fullOfList [] = $internalError "fullList" "empty list" fullOfList [x] = FL.singleton () x fullOfList (x:xs) = FL.cons () x (fullOfList xs) - -- If it is a foreign call for the CUDA backend, don't bother compiling- -- the pure version+ -- If the foreign function targets this backend, drop the remaining+ -- alternatives from the AST. Similarly, we drop the foreign node if it+ -- does not target this backend. --- foreignA :: (Arrays a, Arrays r, Foreign f)- => f a r- -> DelayedAfun (a -> r)- -> DelayedOpenAcc aenv a- -> CIO (Free aenv, PreOpenAcc ExecOpenAcc aenv r)- foreignA ff afun a = case canExecuteAcc ff of- Nothing -> liftA2 (Aforeign ff) <$> pure <$> compileAfun afun <*> travA a- Just _ -> liftA (Aforeign ff err) <$> travA a+ foreignA :: (Arrays as, Arrays bs, Foreign asm)+ => asm (as -> bs)+ -> DelayedAfun (as -> bs)+ -> DelayedOpenAcc aenv as+ -> CIO (ExecOpenAcc aenv bs)+ foreignA ff afun a =+ case canExecuteAcc ff of+ Nothing -> traverseAcc $ Manifest (Apply (weaken absurd afun) a)+ Just{} -> node =<< liftA (Aforeign ff err) <$> travA a where- err = INTERNAL_ERROR(error) "compile" "Executing pure version of a CUDA foreign function"+ absurd :: Idx () t -> Idx env t+ absurd = absurd+ err = $internalError "Aforeign" "failed to recover foreign function a second time" - -- Traverse a scalar expression+-- Traverse a scalar expression+--+compileOpenExp+ :: DelayedOpenExp env aenv e+ -> CIO (Free aenv, PreOpenExp ExecOpenAcc env aenv e)+compileOpenExp topExp =+ case topExp of+ Var ix -> return $ pure (Var ix)+ Const c -> return $ pure (Const c)+ PrimConst c -> return $ pure (PrimConst c)+ IndexAny -> return $ pure IndexAny+ IndexNil -> return $ pure IndexNil+ Foreign ff f x -> foreignE ff f x --+ Let a b -> liftA2 Let <$> travE a <*> travE b+ IndexCons t h -> liftA2 IndexCons <$> travE t <*> travE h+ IndexHead h -> liftA IndexHead <$> travE h+ IndexTail t -> liftA IndexTail <$> travE t+ IndexSlice slix x s -> liftA2 (IndexSlice slix) <$> travE x <*> travE s+ IndexFull slix x s -> liftA2 (IndexFull slix) <$> travE x <*> travE s+ ToIndex s i -> liftA2 ToIndex <$> travE s <*> travE i+ FromIndex s i -> liftA2 FromIndex <$> travE s <*> travE i+ Tuple t -> liftA Tuple <$> travT t+ Prj ix e -> liftA (Prj ix) <$> travE e+ Cond p t e -> liftA3 Cond <$> travE p <*> travE t <*> travE e+ While p f x -> liftA3 While <$> travF p <*> travF f <*> travE x+ PrimApp f e -> liftA (PrimApp f) <$> travE e+ Index a e -> liftA2 Index <$> travA a <*> travE e+ LinearIndex a e -> liftA2 LinearIndex <$> travA a <*> travE e+ Shape a -> liftA Shape <$> travA a+ ShapeSize e -> liftA ShapeSize <$> travE e+ Intersect x y -> liftA2 Intersect <$> travE x <*> travE y+ Union x y -> liftA2 Union <$> travE x <*> travE y++ where+ travA :: (Shape sh, Elt e)+ => DelayedOpenAcc aenv (Array sh e)+ -> CIO (Free aenv, ExecOpenAcc aenv (Array sh e))+ travA a = do+ a' <- compileOpenAcc a+ return $ (bind a', a')++ travT :: Tuple (DelayedOpenExp env aenv) t+ -> CIO (Free aenv, Tuple (PreOpenExp ExecOpenAcc env aenv) t)+ travT NilTup = return (pure NilTup)+ travT (SnocTup t e) = liftA2 SnocTup <$> travT t <*> travE e+ travE :: DelayedOpenExp env aenv e -> CIO (Free aenv, PreOpenExp ExecOpenAcc env aenv e)- travE exp =- case exp of- Var ix -> return $ pure (Var ix)- Const c -> return $ pure (Const c)- PrimConst c -> return $ pure (PrimConst c)- IndexAny -> return $ pure IndexAny- IndexNil -> return $ pure IndexNil- Foreign ff f x -> foreignE ff f x- --- Let a b -> liftA2 Let <$> travE a <*> travE b- IndexCons t h -> liftA2 IndexCons <$> travE t <*> travE h- IndexHead h -> liftA IndexHead <$> travE h- IndexTail t -> liftA IndexTail <$> travE t- IndexSlice slix x s -> liftA2 (IndexSlice slix) <$> travE x <*> travE s- IndexFull slix x s -> liftA2 (IndexFull slix) <$> travE x <*> travE s- ToIndex s i -> liftA2 ToIndex <$> travE s <*> travE i- FromIndex s i -> liftA2 FromIndex <$> travE s <*> travE i- Tuple t -> liftA Tuple <$> travT t- Prj ix e -> liftA (Prj ix) <$> travE e- Cond p t e -> liftA3 Cond <$> travE p <*> travE t <*> travE e- While p f x -> liftA3 While <$> travF p <*> travF f <*> travE x- PrimApp f e -> liftA (PrimApp f) <$> travE e- Index a e -> liftA2 Index <$> travA a <*> travE e- LinearIndex a e -> liftA2 LinearIndex <$> travA a <*> travE e- Shape a -> liftA Shape <$> travA a- ShapeSize e -> liftA ShapeSize <$> travE e- Intersect x y -> liftA2 Intersect <$> travE x <*> travE y-- where- travA :: (Shape sh, Elt e)- => DelayedOpenAcc aenv (Array sh e)- -> CIO (Free aenv, ExecOpenAcc aenv (Array sh e))- travA a = do- a' <- traverseAcc a- return $ (bind a', a')+ travE = compileOpenExp - travT :: Tuple (DelayedOpenExp env aenv) t- -> CIO (Free aenv, Tuple (PreOpenExp ExecOpenAcc env aenv) t)- travT NilTup = return (pure NilTup)- travT (SnocTup t e) = liftA2 SnocTup <$> travT t <*> travE e+ travF :: DelayedOpenFun env aenv t -> CIO (Free aenv, PreOpenFun ExecOpenAcc env aenv t)+ travF (Body b) = liftA Body <$> travE b+ travF (Lam f) = liftA Lam <$> travF f - travF :: DelayedOpenFun env aenv t -> CIO (Free aenv, PreOpenFun ExecOpenAcc env aenv t)- travF (Body b) = liftA Body <$> travE b- travF (Lam f) = liftA Lam <$> travF f+ foreignE :: (Elt a, Elt b, Foreign asm)+ => asm (a -> b)+ -> DelayedFun () (a -> b)+ -> DelayedOpenExp env aenv a+ -> CIO (Free aenv, PreOpenExp ExecOpenAcc env aenv b)+ foreignE ff f x = case canExecuteExp ff of+ -- If it's a foreign function that we can generate code from, just+ -- leave it alone. As the pure function is closed, the array+ -- environment needs to be replaced with one of the right type.+ --+ Just _ -> liftA2 (Foreign ff) <$> pure <$> snd <$> travF f <*> travE x - foreignE :: (Elt a, Elt b, Foreign f)- => f a b- -> DelayedFun () (a -> b)- -> DelayedOpenExp env aenv a- -> CIO (Free aenv, PreOpenExp ExecOpenAcc env aenv b)- foreignE ff f x = case canExecuteExp ff of- -- If it's a foreign function that we can generate code from, just- -- leave it alone. As the pure function is closed, the array- -- environment needs to be replaced with one of the right type.+ -- If the foreign function is not intended for this backend, this node+ -- needs to be replaced by a pure accelerate node giving the same+ -- result. Due to the lack of an 'apply' node in the scalar language,+ -- this is done by substitution.+ --+ Nothing -> travE (apply f x)+ where+ -- Twiddle the environment variables --- Just _ -> liftA2 (Foreign ff) <$> pure <$> snd <$> travF f <*> travE x+ apply :: DelayedFun () (a -> b) -> DelayedOpenExp env aenv a -> DelayedOpenExp env aenv b+ apply (Lam (Body b)) e = Let e $ weaken wAcc $ weakenE wExp b+ apply _ _ = error "This was a triumph." - -- If the foreign function is not intended for this backend, this node- -- needs to be replaced by a pure accelerate node giving the same- -- result. Due to the lack of an 'apply' node in the scalar language,- -- this is done by substitution.+ -- As the expression we want to weaken is closed with respect to the array+ -- environment, the index manipulation function becomes a dummy argument. --- Nothing -> travE (apply f x)- where- -- Twiddle the environment variables- --- apply :: DelayedFun () (a -> b) -> DelayedOpenExp env aenv a -> DelayedOpenExp env aenv b- apply (Lam (Body b)) e = Let e $ weakenEA rebuildAcc wAcc $ weakenE wExp b- apply _ _ = error "This was a triumph."+ wAcc :: Idx () t -> Idx aenv t+ wAcc _ = error "I'm making a note here:" - -- As the expression we want to weaken is closed with respect to the array- -- environment, the index manipulation function becomes a dummy argument.+ wExp :: Idx ((),a) t -> Idx (env,a) t+ wExp ZeroIdx = ZeroIdx+ wExp _ = error "HUGE SUCCESS"++ bind :: (Shape sh, Elt e) => ExecOpenAcc aenv (Array sh e) -> Free aenv+ bind (ExecAcc _ _ (Avar ix)) = freevar ix+ bind _ = $internalError "bind" "expected array variable"++{--+compileSeq :: DelayedSeq a -> CIO (ExecSeq a)+compileSeq (DelayedSeq aenv s) = ExecS <$> compileExtend aenv <*> compileOpenSeq s+ where+ compileExtend :: Extend DelayedOpenAcc aenv aenv' -> CIO (Extend ExecOpenAcc aenv aenv')+ compileExtend BaseEnv = return BaseEnv+ compileExtend (PushEnv e a) = PushEnv <$> compileExtend e <*> compileOpenAcc a++compileOpenSeq+ :: forall aenv lenv arrs'.+ PreOpenSeq DelayedOpenAcc aenv lenv arrs'+ -> CIO (ExecOpenSeq aenv lenv arrs')+compileOpenSeq l =+ case l of+ Producer p l' -> ExecP <$> compileP p <*> compileOpenSeq l'+ Consumer c -> ExecC <$> compileC c+ Reify ix -> return $ ExecR ix Nothing+ where+ compileP :: forall a. Producer DelayedOpenAcc aenv lenv a -> CIO (ExecP aenv lenv a)+ compileP p =+ case p of+ ToSeq slix (_ :: proxy slix) acc -> do+ case acc of+ -- In the case of converting an array that has not already been copied+ -- to device memory, we are smart and treat it specially.+ Manifest (Use a) -> return $ ExecUseLazy slix (toArr a) ([] :: [slix])+ _ -> do+ (free1, acc') <- travA acc+ let gamma = makeEnvMap free1+ dev <- asks deviceProperties+ -- The array computation passed to 'toSeq' needs to be treated+ -- specially. We don't want the entire array to be made manifest+ -- if we can help it. In the event it is a delayed array, we make+ -- the subarrays manifest one at a time and feed them to the 'Seq'+ -- computation. --- wAcc :: Idx () t -> Idx aenv t- wAcc _ = error "I'm making a note here:"+ -- For the purposes of device configuration and launching, this can+ -- be seen to work like 'Slice', even though in reality it+ -- resembles a delayed 'Slice'.+ let acc'' = Manifest (Slice slix acc (Const (zeroSlice slix) :: DelayedExp aenv slix)) - wExp :: Idx ((),a) t -> Idx (env,a) t- wExp ZeroIdx = ZeroIdx- wExp _ = error "HUGE SUCCESS"+ kernel <- build1 acc'' (codegenToSeq slix dev acc gamma)+ return $ ExecToSeq slix acc' kernel gamma ([] :: [slix])+ StreamIn xs -> return $ ExecStreamIn xs+ MapSeq f x -> do+ f' <- compileOpenAfun f+ return $ ExecMap f' x+ ZipWithSeq f x y -> do+ f' <- compileOpenAfun f+ return $ ExecZipWith f' x y+ ScanSeq f a0 x -> do+ (_, a0') <- travE a0+ (_, f') <- travF f+ return $ ExecScanSeq f' a0' x Nothing+ ChunkedMapSeq{} -> error "TODO: @fmma needs to finish this..." - bind :: (Shape sh, Elt e) => ExecOpenAcc aenv (Array sh e) -> Free aenv- bind (ExecAcc _ _ (Avar ix)) = freevar ix- bind _ = INTERNAL_ERROR(error) "bind" "expected array variable"+ compileC :: forall a. Consumer DelayedOpenAcc aenv lenv a -> CIO (ExecC aenv lenv a)+ compileC c =+ case c of+ FoldSeq f a0 x -> do+ (_, a0') <- travE a0+ (_, f') <- travF f+ return $ ExecFoldSeq f' a0' x Nothing+ FoldSeqFlatten f acc x -> do+ acc' <- compileOpenAcc acc+ f' <- compileOpenAfun f+ return $ ExecFoldSeqFlatten f' acc' x Nothing+ Stuple t -> ExecStuple <$> compileCT t + compileCT :: forall t. Atuple (Consumer DelayedOpenAcc aenv lenv) t -> CIO (Atuple (ExecC aenv lenv) t)+ compileCT NilAtup = return NilAtup+ compileCT (SnocAtup t c) = SnocAtup <$> compileCT t <*> compileC c + travA :: DelayedOpenAcc aenv a -> CIO (Free aenv, ExecOpenAcc aenv a)+ travA acc = case acc of+ Manifest{} -> pure <$> compileOpenAcc acc+ Delayed{..} -> liftA2 (const EmbedAcc) <$> travF indexD <*> travE extentD++ travE :: DelayedOpenExp env aenv e+ -> CIO (Free aenv, PreOpenExp ExecOpenAcc env aenv e)+ travE = compileOpenExp++ travF :: DelayedOpenFun env aenv t -> CIO (Free aenv, PreOpenFun ExecOpenAcc env aenv t)+ travF (Body b) = liftA Body <$> travE b+ travF (Lam f) = liftA Lam <$> travF f++ zeroSlice :: SliceIndex slix sl co sh -> slix+ zeroSlice SliceNil = ()+ zeroSlice (SliceFixed sl) = (zeroSlice sl, 0)+ zeroSlice (SliceAll sl) = (zeroSlice sl, ())+--}++ -- Applicative -- ----------- --@@ -335,7 +450,7 @@ let (cta,blocks,smem) = launchConfig acc dev occ (mdl,fun,occ) = unsafePerformIO $ do m <- link context table key- f <- CUDA.getFun m entry+ f <- withLifetime m $ flip CUDA.getFun entry l <- CUDA.requires f CUDA.MaxKernelThreadsPerBlock o <- determineOccupancy acc dev f l D.when D.dump_cc (stats entry f o)@@ -359,16 +474,16 @@ -- make sure kernel/stats are printed together. Use 'intercalate' rather -- than 'unlines' to avoid a trailing newline. --- message $ intercalate "\n ... " [msg1, msg2]+ message $ intercalate "\n ... " [msg1, msg2] -- Link a compiled binary and update the associated kernel entry in the hash -- table. This may entail waiting for the external compilation process to -- complete. If successful, the temporary files are removed. ---link :: Context -> KernelTable -> KernelKey -> IO CUDA.Module+link :: Context -> KernelTable -> KernelKey -> IO (Lifetime CUDA.Module) link context table key =- let intErr = INTERNAL_ERROR(error) "link" "missing kernel entry"+ let intErr = $internalError "link" "missing kernel entry" ctx = deviceContext context weak_ctx = weakContext context in do@@ -384,17 +499,18 @@ -- the binary object. -- message "waiting for nvcc..."- takeMVar done let cubin = replaceExtension cufile ".cubin"+ () <- takeMVar done bin <- B.readFile cubin mdl <- CUDA.loadData bin- addFinalizer mdl (module_finalizer weak_ctx key mdl)+ lmdl <- newLifetime mdl+ addFinalizer lmdl (module_finalizer weak_ctx key lmdl) -- Update hash tables and stash the binary object into the persistent -- cache --- KT.insert table key $! KernelObject bin (FL.singleton ctx mdl)- KT.persist cubin key+ KT.insert table key $! KernelObject bin (FL.singleton ctx lmdl)+ KT.persist table cubin key -- Remove temporary build products. -- If compiling kernels with debugging symbols, leave the source files@@ -405,25 +521,30 @@ removeDirectory (dropFileName cufile) `catchIOError` \_ -> return () -- directory not empty - return mdl+ return lmdl -- If we get a real object back, then this will already be in the -- persistent cache, since either it was just read in from there, or we -- had to generate new code and the link step above has added it. -- KernelObject bin active- | Just mdl <- FL.lookup ctx active -> return mdl+ | Just lmdl <- FL.lookup ctx active -> return lmdl | otherwise -> do message "re-linking module for current context" mdl <- CUDA.loadData bin- addFinalizer mdl (module_finalizer weak_ctx key mdl)- KT.insert table key $! KernelObject bin (FL.cons ctx mdl active)- return mdl+ lmdl <- newLifetime mdl+ addFinalizer lmdl (module_finalizer weak_ctx key lmdl)+ KT.insert table key $! KernelObject bin (FL.cons ctx lmdl active)+ return lmdl -- Generate and compile code for a single open array expression ---compile :: KernelTable -> CUDA.DeviceProperties -> CUTranslSkel aenv a -> CIO (String, KernelKey)+compile+ :: KernelTable+ -> CUDA.DeviceProperties+ -> CUTranslSkel aenv a+ -> CIO (String, KernelKey) compile table dev cunit = do context <- asks activeContext exists <- isJust `fmap` liftIO (KT.lookup context table key)@@ -452,6 +573,8 @@ compileFlags cufile = do CUDA.Compute m n <- CUDA.computeCapability `fmap` asks deviceProperties ddir <- liftIO getDataDir+ warnings <- liftIO $ (&&) <$> D.queryFlag D.dump_cc <*> D.queryFlag D.verbose+ debug <- liftIO $ D.queryFlag D.debug_cc return $ filter (not . null) $ [ "-I", ddir </> "cubits" , "-arch=sm_" ++ show m ++ show n@@ -465,12 +588,10 @@ , machine , cufile ] where- warnings = D.mode D.dump_cc && D.mode D.verbose- debug = D.mode D.debug_cc- machine = case (SIZEOF_HTYPE_INT :: Int) of- 4 -> "-m32"- 8 -> "-m64"- _ -> INTERNAL_ERROR(error) "compileFlags" "unknown 'Int' size"+ machine = case finiteBitSize (undefined :: Int) of+ 32 -> "-m32"+ 64 -> "-m64"+ _ -> $internalError "compileFlags" "unknown 'Int' size" -- Open a unique file in the temporary directory used for compilation@@ -483,9 +604,13 @@ createDirectoryIfMissing True dir openTempFile dir template -#ifndef VERSION_unix-getProcessID :: ProcessHandle -> IO ProcessId-getProcessID = getProcessId+#if defined(WIN32)+-- TLM: On windows, how do we get either the ProcessID or ProcessHandle of the+-- current process? For new, just use a dummy value (the sound of+-- disappearing down a rabbit hole...)+--+getProcessID :: IO ProcessId+getProcessID = return 0xaaaa #endif @@ -515,6 +640,10 @@ -- ... and wait for it to complete waitFor pid+ -- If compilation fails for some reason, fill the MVar by re-throwing+ -- the exception. This prevents the host thread from waiting+ -- indefinitely, which then requires the program to be killed manually.+ `catch` \(e :: SomeException) -> do putMVar mvar (throw e) ccEnd <- getTime return (diffTime ccBegin ccEnd)@@ -578,9 +707,5 @@ {-# INLINE message #-} message :: MonadIO m => String -> m ()-message msg = trace msg $ return ()--{-# INLINE trace #-}-trace :: MonadIO m => String -> m a -> m a-trace msg next = D.message D.dump_cc ("cc: " ++ msg) >> next+message msg = liftIO $ D.traceIO D.dump_cc ("cc: " ++ msg)
Data/Array/Accelerate/CUDA/Context.hs view
@@ -3,7 +3,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.CUDA.Context--- Copyright : [2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- Copyright : [2013..2014] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>@@ -18,45 +18,45 @@ -- An execution context Context(..), create, push, pop, destroy,- keepAlive, fromDeviceContext+ keepAlive, fromDeviceContext, ) where -- friends-import Data.Array.Accelerate.CUDA.Debug ( message, verbose, dump_gc, showFFloatSIBase )+import Data.Array.Accelerate.CUDA.Debug ( traceIO, verbose, dump_gc, showFFloatSIBase ) import Data.Array.Accelerate.CUDA.Analysis.Device+import Data.Array.Accelerate.Lifetime -- system import Data.Function ( on ) import Control.Exception ( bracket_ ) import Control.Concurrent ( forkIO, threadDelay ) import Control.Monad ( when )-import GHC.Exts ( Ptr(..), mkWeak# )-import GHC.Base ( IO(..) )-import GHC.Weak ( Weak(..) )+import System.Mem.Weak ( Weak ) import Text.PrettyPrint import qualified Foreign.CUDA.Driver as CUDA hiding ( device ) import qualified Foreign.CUDA.Driver.Context as CUDA+import qualified Foreign.CUDA.Driver.Device as CUDA -- | The execution context -- data Context = Context {- deviceProperties :: {-# UNPACK #-} !CUDA.DeviceProperties, -- information on hardware resources- deviceContext :: {-# UNPACK #-} !CUDA.Context, -- device execution context- weakContext :: {-# UNPACK #-} !(Weak CUDA.Context) -- weak pointer to the context (for memory management)+ deviceProperties :: {-# UNPACK #-} !CUDA.DeviceProperties, -- information on hardware resources+ deviceContext :: {-# UNPACK #-} !(Lifetime CUDA.Context), -- device execution context+ weakContext :: {-# UNPACK #-} !(Weak (Lifetime CUDA.Context)) -- weak pointer to the context (for memory management) } instance Eq Context where (==) = (==) `on` deviceContext - -- | Create a new CUDA context associated with the calling thread -- create :: CUDA.Device -> [CUDA.ContextFlag] -> IO Context create dev flags = do- ctx <- CUDA.create dev flags >> CUDA.pop >>= keepAlive+ ctx <- CUDA.create dev flags >> CUDA.pop actx@(Context prp _ _) <- fromDeviceContext dev ctx+ _ <- keepAlive actx -- Generated code does not take particular advantage of shared memory, so -- for devices that support it use those banks as an L1 cache instead.@@ -65,30 +65,32 @@ -- TODO: Make the occupancy calculator aware of adjustable shared memory -- when (CUDA.computeCapability prp >= CUDA.Compute 2 0)- $ bracket_ (CUDA.push ctx) CUDA.pop (CUDA.setCacheConfig CUDA.PreferL1)+ $ bracket_ (CUDA.push ctx) CUDA.pop (CUDA.setCache CUDA.PreferL1) - message verbose (deviceInfo dev prp)+ traceIO verbose (deviceInfo dev prp) return actx -- |Given a device context, construct a new context around it.+-- fromDeviceContext :: CUDA.Device -> CUDA.Context -> IO Context fromDeviceContext dev ctx = do prp <- CUDA.props dev- weak <- mkWeakContext ctx $ do- message dump_gc $ "gc: finalise context #" ++ show (CUDA.useContext ctx)+ lctx <- newLifetime ctx+ addFinalizer lctx $ do+ traceIO dump_gc $ "gc: finalise context #" ++ show (CUDA.useContext ctx)+ CUDA.push ctx CUDA.destroy ctx- message dump_gc $ "gc: initialise context #" ++ show (CUDA.useContext ctx)+ weak <- mkWeakPtr lctx+ traceIO dump_gc $ "gc: initialise context #" ++ show (CUDA.useContext ctx) - return $! Context prp ctx weak+ return $! Context prp lctx weak -- | Destroy the specified context. This will fail if the context is more than -- single attachment. -- {-# INLINE destroy #-} destroy :: Context -> IO ()-destroy (deviceContext -> ctx) = do- message dump_gc ("gc: destroy context: #" ++ show (CUDA.useContext ctx))- CUDA.destroy ctx+destroy (deviceContext -> ctx) = finalize ctx -- | Push the given context onto the CPU's thread stack of current contexts. The@@ -96,8 +98,8 @@ -- {-# INLINE push #-} push :: Context -> IO ()-push (deviceContext -> ctx) = do- message dump_gc ("gc: push context: #" ++ show (CUDA.useContext ctx))+push (deviceContext -> lctx) = withLifetime lctx $ \ctx -> do+ traceIO dump_gc ("gc: push context: #" ++ show (CUDA.useContext ctx)) CUDA.push ctx @@ -107,17 +109,7 @@ pop :: IO () pop = do ctx <- CUDA.pop- message dump_gc ("gc: pop context: #" ++ show (CUDA.useContext ctx))----- Make a weak pointer to a CUDA context. We need to be careful to put the--- finaliser on the underlying pointer, rather than the box around it as--- 'mkWeak' will do, because unpacking the context will cause the finaliser to--- fire prematurely.----mkWeakContext :: CUDA.Context -> IO () -> IO (Weak CUDA.Context)-mkWeakContext c@(CUDA.Context (Ptr c#)) f = IO $ \s ->- case mkWeak# c# c f s of (# s', w #) -> (# s', Weak w #)+ traceIO dump_gc ("gc: pop context: #" ++ show (CUDA.useContext ctx)) -- Make sure the GC knows that we want to keep this thing alive past the end of
Data/Array/Accelerate/CUDA/Debug.hs view
@@ -1,13 +1,10 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeOperators #-}-{-# OPTIONS -fno-warn-incomplete-patterns #-}-{-# OPTIONS -fno-warn-unused-binds #-}-{-# OPTIONS -fno-warn-unused-imports #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS -fno-warn-unused-binds #-}+{-# OPTIONS -fno-warn-unused-imports #-} -- | -- Module : Data.Array.Accelerate.CUDA.Debug--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>@@ -20,183 +17,47 @@ module Data.Array.Accelerate.CUDA.Debug ( - showFFloatSIBase,-- message, trace, event, when, unless, mode, timed, elapsed,- verbose, flush_cache,- dump_gc, dump_cc, debug_cc, dump_exec,+ module Data.Array.Accelerate.Debug,+ module Data.Array.Accelerate.CUDA.Debug, ) where -import Numeric-import Data.List-import Data.Label-import Data.IORef-import Debug.Trace ( traceIO, traceEventIO )+import Data.Array.Accelerate.Debug hiding ( timed, elapsed )++import Control.Concurrent ( forkIO ) import Control.Monad ( void ) import Control.Monad.IO.Class ( liftIO, MonadIO )-import Control.Concurrent ( forkIO )+import GHC.Float ( float2Double ) import System.CPUTime import System.IO.Unsafe-import System.Environment-import System.Console.GetOpt-import qualified Foreign.CUDA.Driver.Event as Event -import GHC.Float----- -------------------------------------------------------------------------------- Pretty-printing--showFFloatSIBase :: RealFloat a => Maybe Int -> a -> a -> ShowS-showFFloatSIBase p b n- = showString- $ showFFloat p n' (' ':si_unit)- where- n' = n / (b ^^ pow)- pow = (-4) `max` floor (logBase b n) `min` 4 :: Int- si_unit = case pow of- -4 -> "p"- -3 -> "n"- -2 -> "µ"- -1 -> "m"- 0 -> ""- 1 -> "k"- 2 -> "M"- 3 -> "G"- 4 -> "T"----- -------------------------------------------------------------------------------- Internals--data Flags = Flags- {- -- debugging- _dump_gc :: !Bool -- garbage collection & memory management- , _dump_cc :: !Bool -- compilation & linking- , _debug_cc :: !Bool -- compile device code with debug symbols- , _dump_exec :: !Bool -- kernel execution- , _verbose :: !Bool -- additional status messages-- -- general options / functionality- , _flush_cache :: !Bool -- delete the persistent cache directory- , _fast_math :: !Bool -- use faster, less accurate maths library operations- }--$(mkLabels [''Flags])--allFlags :: [OptDescr (Flags -> Flags)]-allFlags =- [- -- debugging- Option [] ["ddump-gc"] (NoArg (set dump_gc True)) "print device memory management trace"- , Option [] ["ddump-cc"] (NoArg (set dump_cc True)) "print generated code and compilation information"- , Option [] ["ddebug-cc"] (NoArg (set debug_cc True)) "generate debug information for device code"- , Option [] ["ddump-exec"] (NoArg (set dump_exec True)) "print kernel execution trace"- , Option [] ["dverbose"] (NoArg (set verbose True)) "print additional information"-- -- functionality / optimisation- , Option [] ["fflush-cache"] (NoArg (set flush_cache True)) "delete the persistent cache directory"- , Option [] ["ffast-math"] (NoArg (set fast_math True)) "use faster, less accurate maths library operations"- ]--initialise :: IO Flags-initialise = parse `fmap` getArgs- where- defaults = Flags False False False False False False False- parse = foldl parse1 defaults- parse1 opts x = case filter (\(Option _ [f] _ _) -> x `isPrefixOf` ('-':f)) allFlags of- [Option _ _ (NoArg go) _] -> go opts- _ -> opts -- not specified, or ambiguous--#ifdef ACCELERATE_DEBUG-{-# NOINLINE options #-}-options :: IORef Flags-options = unsafePerformIO $ newIORef =<< initialise-#endif--{-# INLINE mode #-}-mode :: (Flags :-> Bool) -> Bool-#ifdef ACCELERATE_DEBUG-mode f = unsafePerformIO $ get f `fmap` readIORef options-#else-mode _ = False-#endif--{-# INLINE message #-}-message :: MonadIO m => (Flags :-> Bool) -> String -> m ()-#ifdef ACCELERATE_DEBUG-message f str- = when f . liftIO- $ do psec <- getCPUTime- let sec = fromIntegral psec * 1E-12 :: Double- traceIO $ showFFloat (Just 2) sec (':':str)-#else-message _ _ = return ()-#endif--{-# INLINE event #-}-event :: MonadIO m => (Flags :-> Bool) -> String -> m ()-#ifdef ACCELERATE_DEBUG-event f str = when f (liftIO $ traceEventIO str)-#else-event _ _ = return ()-#endif--{-# INLINE trace #-}-trace :: (Flags :-> Bool) -> String -> a -> a-#ifdef ACCELERATE_DEBUG-trace f str next = unsafePerformIO (message f str) `seq` next-#else-trace _ _ next = next-#endif+import Foreign.CUDA.Driver.Stream ( Stream )+import qualified Foreign.CUDA.Driver.Event as Event -{-# INLINE when #-}-when :: MonadIO m => (Flags :-> Bool) -> m () -> m ()-#ifdef ACCELERATE_DEBUG-when f action- | mode f = action- | otherwise = return ()-#else-when _ _ = return ()-#endif--{-# INLINE unless #-}-unless :: MonadIO m => (Flags :-> Bool) -> m () -> m ()-#ifdef ACCELERATE_DEBUG-unless f action- | mode f = return ()- | otherwise = action-#else-unless _ action = action-#endif--{-# INLINE timed #-}-timed- :: MonadIO m- => (Flags :-> Bool)- -> (Double -> Double -> String)- -> m ()- -> m ()-timed _f _str action+-- | Execute an action and time the results. The second argument specifies how+-- to format the output string given elapsed GPU and CPU time respectively+--+timed :: Mode -> (Double -> Double -> String) -> Maybe Stream -> IO () -> IO () #ifdef ACCELERATE_DEBUG- | mode _f- = do- gpuBegin <- liftIO $ Event.create []- gpuEnd <- liftIO $ Event.create []- cpuBegin <- liftIO getCPUTime- liftIO $ Event.record gpuBegin Nothing+{-# NOINLINE timed #-}+timed f fmt stream action = do+ enabled <- queryFlag f+ if enabled+ then do+ gpuBegin <- Event.create []+ gpuEnd <- Event.create []+ cpuBegin <- getCPUTime+ Event.record gpuBegin stream action- liftIO $ Event.record gpuEnd Nothing- cpuEnd <- liftIO getCPUTime+ Event.record gpuEnd stream+ cpuEnd <- getCPUTime -- Wait for the GPU to finish executing then display the timing execution -- message. Do this in a separate thread so that the remaining kernels can -- be queued asynchronously. --- _ <- liftIO . forkIO $ do+ void . forkIO $ do Event.block gpuEnd diff <- Event.elapsedTime gpuBegin gpuEnd let gpuTime = float2Double $ diff * 1E-3 -- milliseconds@@ -205,13 +66,14 @@ Event.destroy gpuBegin Event.destroy gpuEnd --- message _f (_str gpuTime cpuTime)- --- return ()+ traceIO f (fmt gpuTime cpuTime) - | otherwise+ else+ action+#else+{-# INLINE timed #-}+timed _ _ _ action = action #endif- = action {-# INLINE elapsed #-} elapsed :: Double -> Double -> String
Data/Array/Accelerate/CUDA/Execute.hs view
@@ -6,13 +6,15 @@ {-# LANGUAGE NoForeignFunctionInterface #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} -- | -- Module : Data.Array.Accelerate.CUDA.Execute--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>@@ -23,51 +25,54 @@ module Data.Array.Accelerate.CUDA.Execute ( -- * Execute a computation under a CUDA environment- executeAcc, executeAfun1+ executeAcc, executeAfun1, + -- -- * Executing a sequence computation and streaming its output.+ -- StreamSeq(..), streamSeq,+ ) where -- friends import Data.Array.Accelerate.CUDA.AST-import Data.Array.Accelerate.CUDA.State-import Data.Array.Accelerate.CUDA.FullList ( FullList(..), List(..) )+import Data.Array.Accelerate.CUDA.Analysis.Shape import Data.Array.Accelerate.CUDA.Array.Data import Data.Array.Accelerate.CUDA.Array.Sugar-import Data.Array.Accelerate.CUDA.Foreign.Import ( canExecuteAcc ) import Data.Array.Accelerate.CUDA.CodeGen.Base ( Name, namesOfArray, groupOfInt ) import Data.Array.Accelerate.CUDA.Execute.Event ( Event ) import Data.Array.Accelerate.CUDA.Execute.Stream ( Stream )+import Data.Array.Accelerate.CUDA.Foreign.Import ( canExecuteAcc )+import Data.Array.Accelerate.CUDA.State import qualified Data.Array.Accelerate.CUDA.Array.Prim as Prim import qualified Data.Array.Accelerate.CUDA.Debug as D import qualified Data.Array.Accelerate.CUDA.Execute.Event as Event import qualified Data.Array.Accelerate.CUDA.Execute.Stream as Stream -import Data.Array.Accelerate.Tuple+import Data.Array.Accelerate.Error import Data.Array.Accelerate.Interpreter ( evalPrim, evalPrimConst, evalPrj ) import Data.Array.Accelerate.Array.Data ( ArrayElt, ArrayData ) import Data.Array.Accelerate.Array.Representation ( SliceIndex(..) )+import Data.Array.Accelerate.FullList ( FullList(..), List(..) )+import Data.Array.Accelerate.Lifetime ( withLifetime ) import qualified Data.Array.Accelerate.Array.Representation as R -- standard library-import Prelude hiding ( exp, sum, iterate ) import Control.Applicative hiding ( Const ) import Control.Monad ( join, when, liftM ) import Control.Monad.Reader ( asks ) import Control.Monad.State ( gets ) import Control.Monad.Trans ( MonadIO, liftIO )+import Control.Monad.Trans.Cont ( ContT(..) ) import System.IO.Unsafe ( unsafeInterleaveIO ) import Data.Int import Data.Word-import Data.Maybe+import Prelude hiding ( exp, sum, iterate ) -import Foreign.CUDA.Analysis.Device ( DeviceProperties, computeCapability, Compute(..) )+import Foreign.CUDA.Analysis.Device ( computeCapability, Compute(..) ) import qualified Foreign.CUDA.Driver as CUDA import qualified Data.HashMap.Strict as Map -#include "accelerate.h" - -- Asynchronous kernel execution -- ----------------------------- @@ -82,13 +87,15 @@ Aempty :: Aval () Apush :: Aval env -> Async t -> Aval (env, t) +-- -- A suspended sequence computation.+-- newtype StreamSeq a = StreamSeq (CIO (Maybe (a, StreamSeq a))) -- Projection of a value from a valuation using a de Bruijn index. -- aprj :: Idx env t -> Aval env -> Async t aprj ZeroIdx (Apush _ x) = x aprj (SuccIdx idx) (Apush val _) = aprj idx val-aprj _ _ = INTERNAL_ERROR(error) "aprj" "inconsistent valuation"+aprj _ _ = $internalError "aprj" "inconsistent valuation" -- All work submitted to the given stream will occur after the asynchronous@@ -108,11 +115,12 @@ -- Execute the given computation in a unique execution stream. ---streaming :: (Stream -> CIO a) -> CIO (Async a)-streaming action = do+streaming :: (Stream -> CIO a) -> (Async a -> CIO b) -> CIO b+streaming first second = do context <- asks activeContext reservoir <- gets streamReservoir- uncurry Async <$> Stream.streaming context reservoir action+ table <- gets eventTable+ Stream.streaming context reservoir table first (\e a -> second (Async e a)) -- Array expression evaluation@@ -131,21 +139,23 @@ -- memory allocated for the result, and the kernel(s) that implement the -- skeleton are invoked --+ executeAcc :: Arrays a => ExecAcc a -> CIO a-executeAcc !acc = wait =<< streaming (executeOpenAcc acc Aempty)+executeAcc !acc = streaming (executeOpenAcc acc Aempty) wait executeAfun1 :: (Arrays a, Arrays b) => ExecAfun (a -> b) -> a -> CIO b executeAfun1 !afun !arrs = do- Async event () <- streaming $ \st -> useArrays (arrays arrs) (fromArr arrs) st- executeOpenAfun1 afun Aempty (Async event arrs)+ streaming (useArrays (arrays arrs) (fromArr arrs))+ (\(Async event ()) -> executeOpenAfun1 afun Aempty (Async event arrs)) where useArrays :: ArraysR arrs -> arrs -> Stream -> CIO () useArrays ArraysRunit () _ = return () useArrays (ArraysRpair r1 r0) (a1, a0) st = useArrays r1 a1 st >> useArrays r0 a0 st useArrays ArraysRarray arr st = useArrayAsync arr (Just st) + executeOpenAfun1 :: PreOpenAfun ExecOpenAcc aenv (a -> b) -> Aval aenv -> Async a -> CIO b-executeOpenAfun1 (Alam (Abody f)) aenv x = wait =<< streaming (executeOpenAcc f (aenv `Apush` x))+executeOpenAfun1 (Alam (Abody f)) aenv x = streaming (executeOpenAcc f (aenv `Apush` x)) wait executeOpenAfun1 _ _ _ = error "the sword comes out after you swallow it, right?" @@ -158,25 +168,27 @@ -> Stream -> CIO arrs executeOpenAcc EmbedAcc{} _ _- = INTERNAL_ERROR(error) "execute" "unexpected delayed array"+ = $internalError "execute" "unexpected delayed array"+-- executeOpenAcc (ExecSeq l) !aenv !stream+-- = executeSequence l aenv stream executeOpenAcc (ExecAcc (FL () kernel more) !gamma !pacc) !aenv !stream = case pacc of -- Array introduction Use arr -> return (toArr arr)- Unit x -> newArray Z . const =<< travE x+ Unit x -> fromFunction Z . const =<< travE x -- Environment manipulation Avar ix -> after stream (aprj ix aenv)- Alet bnd body -> streamA bnd >>= \x -> executeOpenAcc body (aenv `Apush` x) stream- Atuple tup -> toTuple <$> travT tup- Aprj ix tup -> evalPrj ix . fromTuple <$> travA tup- Apply f a -> executeOpenAfun1 f aenv =<< streamA a+ Alet bnd body -> streaming (executeOpenAcc bnd aenv) (\x -> executeOpenAcc body (aenv `Apush` x) stream)+ Apply f a -> streaming (executeOpenAcc a aenv) (executeOpenAfun1 f aenv)+ Atuple tup -> toAtuple <$> travT tup+ Aprj ix tup -> evalPrj ix . fromAtuple <$> travA tup Acond p t e -> travE p >>= \x -> if x then travA t else travA e Awhile p f a -> awhile p f =<< travA a -- Foreign- Aforeign ff afun a -> fromMaybe (executeAfun1 afun) (canExecuteAcc ff) =<< travA a+ Aforeign ff afun a -> aforeign ff afun =<< travA a -- Producers Map _ a -> executeOp =<< extent a@@ -200,21 +212,20 @@ Stencil _ _ a -> stencilOp =<< travA a Stencil2 _ _ a1 _ a2 -> join $ stencil2Op <$> travA a1 <*> travA a2 - -- Removed by fusion- Replicate _ _ _ -> fusionError- Slice _ _ _ -> fusionError- ZipWith _ _ _ -> fusionError+ -- AST nodes that should be inaccessible at this point+ Replicate{} -> fusionError+ Slice{} -> fusionError+ ZipWith{} -> fusionError+ -- Collect{} -> streamingError where- fusionError = INTERNAL_ERROR(error) "executeOpenAcc" "unexpected fusible matter"+ fusionError = $internalError "executeOpenAcc" "unexpected fusible matter"+ -- streamingError = $internalError "executeOpenAcc" "unexpected sequence computation" -- term traversals travA :: ExecOpenAcc aenv a -> CIO a travA !acc = executeOpenAcc acc aenv stream - streamA :: ExecOpenAcc aenv a -> CIO (Async a)- streamA !acc = streaming $ \st -> executeOpenAcc acc aenv st- travE :: ExecExp aenv t -> CIO t travE !exp = executeExp exp aenv stream @@ -224,15 +235,24 @@ awhile :: PreOpenAfun ExecOpenAcc aenv (a -> Scalar Bool) -> PreOpenAfun ExecOpenAcc aenv (a -> a) -> a -> CIO a awhile p f a = do- nop <- liftIO Event.create -- record event never call, so this is a functional no-op+ tbl <- gets eventTable+ ctx <- asks activeContext+ nop <- liftIO $ Event.create ctx tbl -- record event never call, so this is a functional no-op r <- executeOpenAfun1 p aenv (Async nop a) ok <- indexArray r 0 -- TLM TODO: memory manager should remember what is already on the host if ok then awhile p f =<< executeOpenAfun1 f aenv (Async nop a) else return a + aforeign :: (Arrays as, Arrays bs, Foreign asm) => asm (as -> bs) -> PreAfun ExecOpenAcc (as -> bs) -> as -> CIO bs+ aforeign ff next a =+ case canExecuteAcc ff of+ Just asm -> asm stream a+ Nothing -> executeAfun1 next a+ -- get the extent of an embedded array extent :: Shape sh => ExecOpenAcc aenv (Array sh e) -> CIO sh- extent ExecAcc{} = INTERNAL_ERROR(error) "executeOpenAcc" "expected delayed array"+ extent ExecAcc{} = $internalError "executeOpenAcc" "expected delayed array"+ -- extent ExecSeq{} = $internalError "executeOpenAcc" "expected delayed array" extent (EmbedAcc sh) = travE sh -- Skeleton implementation@@ -252,7 +272,7 @@ -- reshapeOp :: Shape sh => sh -> Array sh' e -> Array sh e reshapeOp sh (Array sh' adata)- = BOUNDS_CHECK(check) "reshape" "shape mismatch" (size sh == R.size sh')+ = $boundsCheck "reshape" "shape mismatch" (size sh == R.size sh') $ Array (fromElt sh) adata -- Executing fold operations depend on whether we are recursively collapsing@@ -261,7 +281,7 @@ -- fold1Op :: (Shape sh, Elt e) => (sh :. Int) -> CIO (Array sh e) fold1Op !sh@(_ :. sz)- = BOUNDS_CHECK(check) "fold1" "empty array" (sz > 0)+ = $boundsCheck "fold1" "empty array" (sz > 0) $ foldCore sh foldOp :: (Shape sh, Elt e) => (sh :. Int) -> CIO (Array sh e)@@ -270,7 +290,7 @@ foldCore :: (Shape sh, Elt e) => (sh :. Int) -> CIO (Array sh e) foldCore !(!sh :. sz)- | dim sh > 0 = executeOp sh+ | rank sh > 0 = executeOp sh | otherwise = let !numElements = size sh * sz (_,!numBlocks,_) = configure kernel numElements@@ -295,7 +315,7 @@ foldRec out | otherwise- = INTERNAL_ERROR(error) "foldRec" "missing phase-2 kernel module"+ = $internalError "foldRec" "missing phase-2 kernel module" -- Segmented reduction. Subtract one from the size of the segments vector as -- this is the result of an exclusive scan to calculate segment offsets.@@ -305,35 +325,41 @@ -- Scans, all variations on a theme. --- scanOp :: Elt e => Bool -> (Z :. Int) -> CIO (Vector e)- scanOp !left !(Z :. numElements) = do- arr@(Array _ adata) <- allocateArray (Z :. numElements + 1)- out <- devicePtrsOfArrayData adata- let (!body, !sum)- | left = (out, advancePtrsOfArrayData adata numElements out)- | otherwise = (advancePtrsOfArrayData adata 1 out, out)- --- scanCore numElements arr body sum- return arr+ scanOp :: forall sh e. (Shape sh, Elt e) => Bool -> (sh :. Int) -> CIO (Array (sh:.Int) e)+ scanOp !left !(_ :. numElements)+ | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)+ = do+ arr@(Array _ adata) <- allocateArray (Z :. numElements + 1)+ withDevicePtrs adata (Just stream) $ \out -> do+ let (!body, !sum)+ | left = (out, advancePtrsOfArrayData adata numElements out)+ | otherwise = (advancePtrsOfArrayData adata 1 out, out)+ --+ scanCore numElements arr body sum+ return arr - scan1Op :: forall e. Elt e => (Z :. Int) -> CIO (Vector e)- scan1Op !(Z :. numElements) = do- arr@(Array _ adata) <- allocateArray (Z :. numElements + 1) :: CIO (Vector e)- body <- devicePtrsOfArrayData adata- let sum {- to fix type -} = advancePtrsOfArrayData adata numElements body- --- scanCore numElements arr body sum- return (Array ((),numElements) adata)+ scan1Op :: forall sh e. (Shape sh, Elt e) => (sh :. Int) -> CIO (Array (sh:.Int) e)+ scan1Op !(_ :. numElements)+ | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)+ = do+ arr@(Array _ adata) <- allocateArray (Z :. numElements + 1) :: CIO (Vector e)+ withDevicePtrs adata (Just stream) $ \body -> do+ let sum {- to fix type -} = advancePtrsOfArrayData adata numElements body+ --+ scanCore numElements arr body sum+ return (Array ((),numElements) adata) - scan'Op :: forall e. Elt e => (Z :. Int) -> CIO (Vector e, Scalar e)- scan'Op !(Z :. numElements) = do- vec@(Array _ ad_vec) <- allocateArray (Z :. numElements) :: CIO (Vector e)- sum@(Array _ ad_sum) <- allocateArray Z :: CIO (Scalar e)- d_vec <- devicePtrsOfArrayData ad_vec- d_sum <- devicePtrsOfArrayData ad_sum- --- scanCore numElements vec d_vec d_sum- return (vec, sum)+ scan'Op :: forall sh e. (Shape sh, Elt e) => (sh :. Int) -> CIO (Array (sh:.Int) e, Array sh e)+ scan'Op !(_ :. numElements)+ | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)+ = do+ vec@(Array _ ad_vec) <- allocateArray (Z :. numElements) :: CIO (Vector e)+ sum@(Array _ ad_sum) <- allocateArray Z :: CIO (Scalar e)+ withDevicePtrs ad_vec (Just stream) $ \d_vec ->+ withDevicePtrs ad_sum (Just stream) $ \d_sum -> do+ --+ scanCore numElements vec d_vec d_sum+ return (vec, sum) scanCore :: forall e. Elt e@@ -363,17 +389,24 @@ execute kernel gamma aenv numElements (numElements, d_body, blk, d_sum) stream | otherwise- = INTERNAL_ERROR(error) "scanOp" "missing multi-block kernel module(s)"+ = $internalError "scanOp" "missing multi-block kernel module(s)" -- Forward permutation --- permuteOp :: (Shape sh, Shape sh', Elt e) => sh -> Array sh' e -> CIO (Array sh' e)+ permuteOp :: forall sh sh' e. (Shape sh, Shape sh', Elt e) => sh -> Array sh' e -> CIO (Array sh' e) permuteOp !sh !dfs = do- out <- allocateArray (shape dfs)- copyArray dfs out- execute kernel gamma aenv (size sh) out stream- return out+ let sh' = shape dfs+ n' = size sh' + out <- allocateArray sh'+ Array _ locks <- allocateArray sh' :: CIO (Array sh' Int32)+ withDevicePtrs locks (Just stream) $ \d_locks -> do++ liftIO $ CUDA.memsetAsync d_locks n' 0 (Just stream) -- TLM: overlap these two operations?+ copyArrayAsync dfs out (Just stream)+ execute kernel gamma aenv (size sh) (out, d_locks) stream+ return out+ -- Stencil operations. NOTE: the arguments to 'namesOfArray' must be the -- same as those given in the function 'mkStencil[2]'. --@@ -384,9 +417,10 @@ dev <- asks deviceProperties if computeCapability dev < Compute 2 0- then marshalAccTex (namesOfArray "Stencil" (undefined :: a)) kernel arr >>- execute kernel gamma aenv (size sh) (out, sh) stream+ then marshalAccTex (namesOfArray "Stencil" (undefined :: a)) kernel arr (Just stream) $+ execute kernel gamma aenv (size sh) (out, sh) stream else execute kernel gamma aenv (size sh) (out, arr) stream+ execute kernel gamma aenv (size sh) (out, arr) stream -- return out @@ -404,24 +438,281 @@ dev <- asks deviceProperties if computeCapability dev < Compute 2 0- then marshalAccTex (namesOfArray "Stencil1" (undefined :: a)) op arr1 >>- marshalAccTex (namesOfArray "Stencil2" (undefined :: b)) op arr2 >>+ then marshalAccTex (namesOfArray "Stencil1" (undefined :: a)) op arr1 (Just stream) $+ marshalAccTex (namesOfArray "Stencil2" (undefined :: b)) op arr2 (Just stream) $ execute op gamma aenv (size sh) (out, sh1, sh2) stream else execute op gamma aenv (size sh) (out, arr1, arr2) stream+ execute op gamma aenv (size sh) (out, arr1, arr2) stream -- return out | otherwise- = INTERNAL_ERROR(error) "stencil2Op" "missing stencil specialisation kernel"+ = $internalError "stencil2Op" "missing stencil specialisation kernel" +{--+-- Execute a streaming computation+--+executeSequence+ :: forall aenv arrs. Arrays arrs+ => ExecOpenSeq aenv () arrs+ -> Aval aenv+ -> Stream+ -> CIO arrs+executeSequence topSequence aenv stream+ = initializeOpenSeq topSequence aenv stream >>= loop >>= returnOut+ where+ loop :: ExecOpenSeq aenv () arrs -> CIO (ExecOpenSeq aenv () arrs)+ loop = loop'+ where+ loop' :: ExecOpenSeq aenv () arrs -> CIO (ExecOpenSeq aenv () arrs)+ loop' s = do+ ms <- runMaybeT (stepOpenSeq aenv s stream)+ case ms of+ Nothing -> return s+ Just s' -> loop' s'++ returnOut :: forall lenv arrs' . ExecOpenSeq aenv lenv arrs' -> CIO arrs'+ returnOut !l =+ case l of+ ExecP _ l' -> returnOut l'+ ExecC c -> readConsumer c+ ExecR _ ma -> case ma of+ Just a -> return [a]+ Nothing -> $internalError "executeSequence" "Expected already executed Sequence"++ where+ readConsumer :: forall a . ExecC aenv lenv a -> CIO a+ readConsumer c =+ case c of+ ExecFoldSeq _ _ _ (Just a) -> let a' = fromList Z [a] in useArray a' >> return a'+ ExecFoldSeqFlatten _ _ _ (Just a) -> return a+ ExecStuple t -> toAtuple <$> rdT t+ where+ rdT :: forall t. Atuple (ExecC aenv lenv) t -> CIO t+ rdT NilAtup = return ()+ rdT (SnocAtup t' c') = (,) <$> rdT t' <*> readConsumer c'+ _ -> $internalError "executeSequence" "Expected already executed consumer"++initializeSeq+ :: Aval aenv+ -> ExecOpenSeq aenv () arrs'+ -> CIO (ExecOpenSeq aenv () arrs')+initializeSeq aenv s = streaming (initializeOpenSeq s aenv) wait++initializeOpenSeq+ :: forall lenv aenv arrs'.+ ExecOpenSeq aenv lenv arrs'+ -> Aval aenv+ -> Stream+ -> CIO (ExecOpenSeq aenv lenv arrs')+initializeOpenSeq l aenv stream =+ case l of+ ExecP p l' -> ExecP <$> initP p <*> initializeOpenSeq l' aenv stream+ ExecC c -> ExecC <$> initC c+ ExecR ix a -> return (ExecR ix a)++ where+ initP :: forall a. ExecP aenv lenv a -> CIO (ExecP aenv lenv a)+ initP (ExecToSeq slix acc k g (_::[slix])) =+ do sh <- extent acc+ --Lazy evaluation will stop this entire list being generated.+ let slices = enumSlices slix sh :: [slix]+ return $ ExecToSeq slix acc k g slices+ initP (ExecUseLazy slix arr (_::[slix])) =+ let sh = shape arr+ -- Same as above.+ slices = enumSlices slix sh :: [slix]+ in return $ ExecUseLazy slix arr slices+ initP s@ExecStreamIn{} = return s+ initP s@ExecMap{} = return s+ initP s@ExecZipWith{} = return s+ initP (ExecScanSeq f a0 ix _) =+ do a <- executeExp a0 aenv stream+ return $ ExecScanSeq f a0 ix (Just a)++ initC :: forall a. ExecC aenv lenv a -> CIO (ExecC aenv lenv a)+ initC c =+ case c of+ ExecFoldSeq f a0 ix _ ->+ do a <- executeExp a0 aenv stream+ return $ ExecFoldSeq f a0 ix (Just a)+ ExecFoldSeqFlatten afun acc ix _ ->+ do a <- executeOpenAcc acc aenv stream+ return $ ExecFoldSeqFlatten afun acc ix (Just a)+ ExecStuple t -> ExecStuple <$> initCT t++ initCT :: forall t. Atuple (ExecC aenv lenv) t -> CIO (Atuple (ExecC aenv lenv) t)+ initCT NilAtup = return NilAtup+ initCT (SnocAtup t c) = SnocAtup <$> initCT t <*> initC c++ -- get the extent of an embedded array+ extent :: Shape sh => ExecOpenAcc aenv (Array sh e) -> CIO sh+ extent ExecAcc{} = $internalError "executeOpenAcc" "expected delayed array"+ extent ExecSeq{} = $internalError "executeOpenAcc" "expected delayed array"+ extent (EmbedAcc sh) = executeExp sh aenv stream+++-- Turn a sequence computation into a suspended computation that can be forced+-- an element at a time.+--+streamSeq :: ExecSeq [a] -> StreamSeq a+streamSeq (ExecS binds sequ) = StreamSeq $ do+ aenv <- executeExtend binds Aempty+ iseq <- initializeSeq aenv sequ+ let go s = do+ ms <- stepSeq aenv s+ case ms of+ Nothing -> return Nothing+ Just (s', a) -> return (Just (a, StreamSeq (go s')))+ go iseq+++stepSeq+ :: forall a aenv.+ Aval aenv+ -> ExecOpenSeq aenv () [a]+ -> CIO (Maybe (ExecOpenSeq aenv () [a], a))+stepSeq aenv s = streaming step wait+ where+ step :: Stream -> CIO (Maybe (ExecOpenSeq aenv () [a], a))+ step stream = do+ ms <- runMaybeT (stepOpenSeq aenv s stream)+ return $ (,) <$> ms <*> (coll <$> ms)++ coll :: ExecOpenSeq aenv lenv [a] -> a+ coll (ExecP _ s') = coll s'+ coll (ExecC _) = $internalError "stepSeq" "Unreachable"+ coll (ExecR _ ma) = case ma of+ Nothing -> $internalError "stepSeq" "Trying to collect the value of an unexecuted sequence"+ Just a -> a++stepOpenSeq+ :: forall aenv arrs'.+ Aval aenv+ -> ExecOpenSeq aenv () arrs'+ -> Stream+ -> MaybeT CIO (ExecOpenSeq aenv () arrs')+stepOpenSeq aenv !l stream = go l Empty+ where+ go :: forall lenv. ExecOpenSeq aenv lenv arrs' -> Val lenv -> MaybeT CIO (ExecOpenSeq aenv lenv arrs')+ go s lenv =+ case s of+ ExecP p s' -> do+ (p', a) <- produce p+ s'' <- go s' (lenv `Push` a)+ return $ ExecP p' s''+ ExecC c -> ExecC <$> lift (consume c)+ ExecR ix _ -> return $ ExecR ix (Just (prj ix lenv))+ where+ produce :: forall a . ExecP aenv lenv a -> MaybeT CIO (ExecP aenv lenv a, a)+ produce (ExecToSeq slix acc kernel gamma sls) =+ do+ sl : sls' <- return sls+ lift $ do+ sh <- extent acc+ out <- allocateArray (sliceShape slix sh)+ m <- marshalSlice slix sl+ execute kernel gamma aenv (size sh) (m, out) stream+ return (ExecToSeq slix acc kernel gamma sls', out)+ produce (ExecUseLazy slix arr sls) =+ do let sh = shape arr+ lift $ do+ sl : sls' <- return sls+ out <- allocateArray (sliceShape slix sh)+ useArraySlice slix sl arr out+ return (ExecUseLazy slix arr sls', out)+ produce (ExecStreamIn xs) =+ let use :: ArraysR arrs -> arrs -> CIO ()+ use ArraysRunit () = return ()+ use ArraysRarray arr = useArrayAsync arr Nothing+ use (ArraysRpair r1 r2) (a1, a2) = use r1 a1 >> use r2 a2+ in case xs of+ [] -> MaybeT (return Nothing)+ x:xs' -> lift (use (arrays x) (fromArr x)) >> return (ExecStreamIn xs', x)+ produce (ExecMap afun x) = (ExecMap afun x ,) <$> lift (travAfun1 afun (prj x lenv))+ produce (ExecZipWith afun x y) = (ExecZipWith afun x y,) <$> lift (travAfun2 afun (prj x lenv) (prj y lenv))+ produce (ExecScanSeq afun a0 x ma) =+ do+ a <- MaybeT (return ma)+ a' <- lift $ travFun2 afun a (prj x lenv ! Z)+ return (ExecScanSeq afun a0 x (Just a'), fromList Z [a'])++ consume :: forall a . ExecC aenv lenv a -> CIO (ExecC aenv lenv a)+ consume c =+ case c of+ ExecFoldSeq afun a0 x (Just a) ->+ do b <- indexArray (prj x lenv) 0+ a' <- travFun2 afun a b+ return $ ExecFoldSeq afun a0 x (Just a')+ ExecFoldSeqFlatten afun a0 x (Just a) ->+ do useArray shapes+ a' <- travAfun3 afun a shapes elems+ return $ ExecFoldSeqFlatten afun a0 x (Just a')+ where+ Array sh adata = prj x lenv+ elems = Array ((), R.size sh) adata+ shapes = fromList (Z:.1) [toElt sh]+ ExecStuple t -> ExecStuple <$> consumeT t+ _ -> $internalError "executeSequence" "Expected already executed consumer"++ consumeT :: forall t. Atuple (ExecC aenv lenv) t -> CIO (Atuple (ExecC aenv lenv) t)+ consumeT NilAtup = return NilAtup+ consumeT (SnocAtup t c) = SnocAtup <$> consumeT t <*> consume c++ travAfun1 :: forall a b. PreOpenAfun ExecOpenAcc aenv (a -> b) -> a -> CIO b+ travAfun1 (Alam (Abody afun)) a =+ do nop <- join $ liftIO <$> (Event.create <$> asks activeContext <*> gets eventTable)+ executeOpenAcc afun (aenv `Apush` (Async nop a)) stream+ travAfun1 _ _ = error "travAfun1"++ travAfun2 :: forall a b c. PreOpenAfun ExecOpenAcc aenv (a -> b -> c) -> a -> b -> CIO c+ travAfun2 (Alam (Alam (Abody afun))) a b =+ do nop <- join $ liftIO <$> (Event.create <$> asks activeContext <*> gets eventTable)+ executeOpenAcc afun (aenv `Apush` (Async nop a) `Apush` (Async nop b)) stream+ travAfun2 _ _ _ = error "travAfun2"++ travAfun3 :: forall a b c d. PreOpenAfun ExecOpenAcc aenv (a -> b -> c -> d) -> a -> b -> c -> CIO d+ travAfun3 (Alam (Alam (Alam (Abody afun)))) a b c =+ do nop <- join $ liftIO <$> (Event.create <$> asks activeContext <*> gets eventTable)+ executeOpenAcc afun (aenv `Apush` (Async nop a) `Apush` (Async nop b) `Apush` (Async nop c)) stream+ travAfun3 _ _ _ _ = error "travAfun3"++ travFun2 :: forall a b c. PreFun ExecOpenAcc aenv (a -> b -> c) -> a -> b -> CIO c+ travFun2 (Lam (Lam (Body c))) a b = executeOpenExp c (Empty `Push` a `Push` b) aenv stream+ travFun2 _ _ _ = error "travFun2"++ -- get the extent of an embedded array+ extent :: Shape sh => ExecOpenAcc aenv (Array sh e) -> CIO sh+ extent ExecAcc{} = $internalError "executeOpenAcc" "expected delayed array"+ extent ExecSeq{} = $internalError "executeOpenAcc" "expected delayed array"+ extent (EmbedAcc sh) = executeExp sh aenv stream+++-- Evaluating bindings+-- -------------------++executeExtend :: Extend ExecOpenAcc aenv aenv' -> Aval aenv -> CIO (Aval aenv')+executeExtend BaseEnv aenv = return aenv+executeExtend (PushEnv e a) aenv = do+ aenv' <- executeExtend e aenv+ streaming (executeOpenAcc a aenv') $ \a' -> return $ Apush aenv' a'+--}++ -- Scalar expression evaluation -- ---------------------------- executeExp :: ExecExp aenv t -> Aval aenv -> Stream -> CIO t executeExp !exp !aenv !stream = executeOpenExp exp Empty aenv stream -executeOpenExp :: forall env aenv exp. ExecOpenExp env aenv exp -> Val env -> Aval aenv -> Stream -> CIO exp+executeOpenExp+ :: forall env aenv exp.+ ExecOpenExp env aenv exp+ -> Val env+ -> Aval aenv+ -> Stream+ -> CIO exp executeOpenExp !rootExp !env !aenv !stream = travE rootExp where travE :: ExecOpenExp env aenv t -> CIO t@@ -445,6 +736,7 @@ ToIndex sh ix -> toIndex <$> travE sh <*> travE ix FromIndex sh ix -> fromIndex <$> travE sh <*> travE ix Intersect sh1 sh2 -> intersect <$> travE sh1 <*> travE sh2+ Union sh1 sh2 -> union <$> travE sh1 <*> travE sh2 ShapeSize sh -> size <$> travE sh Shape acc -> shape <$> travA acc Index acc ix -> join $ index <$> travA acc <*> travE ix@@ -507,45 +799,64 @@ -- Marshalling data -- ---------------- +{--+marshalSlice'+ :: SliceIndex slix sl co dim+ -> slix+ -> CIO [CUDA.FunParam]+marshalSlice' SliceNil () = return []+marshalSlice' (SliceAll sl) (sh, ()) = marshalSlice' sl sh+marshalSlice' (SliceFixed sl) (sh, n) =+ do x <- runContT (marshal n Nothing) return+ xs <- marshalSlice' sl sh+ return (xs ++ x)++marshalSlice+ :: Elt slix => SliceIndex (EltRepr slix) sl co dim+ -> slix+ -> CIO [CUDA.FunParam]+marshalSlice slix = marshalSlice' slix . fromElt+--}+ -- Data which can be marshalled as function arguments to a kernel invocation. -- class Marshalable a where- marshal :: a -> CIO [CUDA.FunParam]+ marshal :: a -> Maybe Stream -> ContT b CIO [CUDA.FunParam] instance Marshalable () where- marshal () = return []+ marshal () _ = return [] instance Marshalable CUDA.FunParam where- marshal !x = return [x]+ marshal !x _ = return [x] instance ArrayElt e => Marshalable (ArrayData e) where- marshal !ad = marshalArrayData ad+ marshal !ad ms = ContT $ marshalArrayData ad ms instance Shape sh => Marshalable sh where- marshal !sh = marshal (reverse (shapeToList sh))+ marshal !sh ms = marshal (reverse (shapeToList sh)) ms instance Marshalable a => Marshalable [a] where- marshal = concatMapM marshal+ marshal xs ms = concatMapM (flip marshal ms) xs instance (Marshalable sh, Elt e) => Marshalable (Array sh e) where- marshal !(Array sh ad) = (++) <$> marshal (toElt sh :: sh) <*> marshal ad+ marshal !(Array sh ad) ms = (++) <$> marshal (toElt sh :: sh) ms <*> marshal ad ms instance (Marshalable a, Marshalable b) => Marshalable (a, b) where- marshal (!a, !b) = (++) <$> marshal a <*> marshal b+ marshal (!a, !b) ms = (++) <$> marshal a ms <*> marshal b ms instance (Marshalable a, Marshalable b, Marshalable c) => Marshalable (a, b, c) where- marshal (!a, !b, !c)- = concat <$> sequence [marshal a, marshal b, marshal c]+ marshal (!a, !b, !c) ms+ = concat <$> sequence [marshal a ms, marshal b ms, marshal c ms] instance (Marshalable a, Marshalable b, Marshalable c, Marshalable d) => Marshalable (a, b, c, d) where- marshal (!a, !b, !c, !d)- = concat <$> sequence [marshal a, marshal b, marshal c, marshal d]+ marshal (!a, !b, !c, !d) ms+ = concat <$> sequence [marshal a ms, marshal b ms, marshal c ms, marshal d ms] #define primMarshalable(ty) \ instance Marshalable (ty) where { \- marshal !x = return [CUDA.VArg x] }+ marshal !x _ = return [CUDA.VArg x] } primMarshalable(Int) primMarshalable(Int8)@@ -579,21 +890,23 @@ -- as to use the larger available caches. -- -marshalAccEnvTex :: AccKernel a -> Aval aenv -> Gamma aenv -> Stream -> CIO [CUDA.FunParam]+marshalAccEnvTex :: AccKernel a -> Aval aenv -> Gamma aenv -> Stream -> ContT b CIO [CUDA.FunParam] marshalAccEnvTex !kernel !aenv (Gamma !gamma) !stream = flip concatMapM (Map.toList gamma) $ \(Idx_ !(idx :: Idx aenv (Array sh e)), i) -> do arr <- after stream (aprj idx aenv)- marshalAccTex (namesOfArray (groupOfInt i) (undefined :: e)) kernel arr- marshal (shape arr)+ ContT $ \f -> marshalAccTex (namesOfArray (groupOfInt i) (undefined :: e)) kernel arr (Just stream) (f ())+ marshal (shape arr) (Just stream) -marshalAccTex :: (Name,[Name]) -> AccKernel a -> Array sh e -> CIO ()-marshalAccTex (_, !arrIn) (AccKernel _ _ !mdl _ _ _ _) (Array !sh !adata)- = marshalTextureData adata (R.size sh) =<< liftIO (sequence' $ map (CUDA.getTex mdl) (reverse arrIn))+marshalAccTex :: (Name,[Name]) -> AccKernel a -> Array sh e -> Maybe Stream -> CIO b -> CIO b+marshalAccTex (_, !arrIn) (AccKernel _ _ !lmdl _ _ _ _) (Array !sh !adata) ms run+ = do+ texs <- liftIO $ withLifetime lmdl $ \mdl -> (sequence' $ map (CUDA.getTex mdl) (reverse arrIn))+ marshalTextureData adata (R.size sh) texs ms (const run) -marshalAccEnvArg :: Aval aenv -> Gamma aenv -> Stream -> CIO [CUDA.FunParam]+marshalAccEnvArg :: Aval aenv -> Gamma aenv -> Stream -> ContT b CIO [CUDA.FunParam] marshalAccEnvArg !aenv (Gamma !gamma) !stream- = concatMapM (\(Idx_ !idx) -> marshal =<< after stream (aprj idx aenv)) (Map.keys gamma)+ = concatMapM (\(Idx_ !idx) -> flip marshal (Just stream) =<< after stream (aprj idx aenv)) (Map.keys gamma) -- A lazier version of 'Control.Monad.sequence'@@ -622,45 +935,47 @@ -- texture references, and for newer devices adds the parameters to the front of -- the argument list ---arguments :: Marshalable args- => AccKernel a- -> Aval aenv- -> Gamma aenv- -> args- -> Stream- -> CIO [CUDA.FunParam]+arguments+ :: Marshalable args+ => AccKernel a+ -> Aval aenv+ -> Gamma aenv+ -> args+ -> Stream+ -> ContT b CIO [CUDA.FunParam] arguments !kernel !aenv !gamma !a !stream = do dev <- asks deviceProperties let marshaller | computeCapability dev < Compute 2 0 = marshalAccEnvTex kernel | otherwise = marshalAccEnvArg --- (++) <$> marshaller aenv gamma stream <*> marshal a+ (++) <$> marshaller aenv gamma stream <*> marshal a (Just stream) -- Link the binary object implementing the computation, configure the kernel -- launch parameters, and initiate the computation. This also handles lifting -- and binding of array references from scalar expressions. ---execute :: Marshalable args- => AccKernel a -- The binary module implementing this kernel- -> Gamma aenv -- variables of arrays embedded in scalar expressions- -> Aval aenv -- the environment- -> Int -- a "size" parameter, typically number of elements in the output- -> args -- arguments to marshal to the kernel function- -> Stream -- Compute stream to execute in- -> CIO ()-execute !kernel !gamma !aenv !n !a !stream = do- args <- arguments kernel aenv gamma a stream- launch kernel (configure kernel n) args stream+execute+ :: Marshalable args+ => AccKernel a -- The binary module implementing this kernel+ -> Gamma aenv -- variables of arrays embedded in scalar expressions+ -> Aval aenv -- the environment+ -> Int -- a "size" parameter, typically number of elements in the output+ -> args -- arguments to marshal to the kernel function+ -> Stream -- Compute stream to execute in+ -> CIO ()+execute !kernel !gamma !aenv !n !a !stream = flip runContT return $ do+ args <- arguments kernel aenv gamma a stream+ liftIO $ launch kernel (configure kernel n) args stream -- Execute a device function, with the given thread configuration and function -- parameters. The tuple contains (threads per block, grid size, shared memory) ---launch :: AccKernel a -> (Int,Int,Int) -> [CUDA.FunParam] -> Stream -> CIO ()+launch :: AccKernel a -> (Int,Int,Int) -> [CUDA.FunParam] -> Stream -> IO () launch (AccKernel entry !fn _ _ _ _ _) !(cta, grid, smem) !args !stream- = D.timed D.dump_exec msg- $ liftIO $ CUDA.launchKernel fn (grid,1,1) (cta,1,1) smem (Just stream) args+ = D.timed D.dump_exec msg (Just stream)+ $ CUDA.launchKernel fn (grid,1,1) (cta,1,1) smem (Just stream) args where msg gpuTime cpuTime = "exec: " ++ entry ++ "<<< " ++ shows grid ", " ++ shows cta ", " ++ shows smem " >>> "
Data/Array/Accelerate/CUDA/Execute/Event.hs view
@@ -1,10 +1,11 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.CUDA.Execute.Event--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- Copyright : [2013..2014] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>@@ -13,41 +14,95 @@ -- module Data.Array.Accelerate.CUDA.Execute.Event ( - Event, create, waypoint, after, block,+ Event, EventTable, new, create, waypoint, after, block, query, destroy, ) where -- friends+import Data.Array.Accelerate.FullList ( FullList(..) )+import Data.Array.Accelerate.Lifetime+import Data.Array.Accelerate.CUDA.Context ( Context(..) ) import qualified Data.Array.Accelerate.CUDA.Debug as D+import qualified Data.Array.Accelerate.FullList as FL -- libraries-import Foreign.CUDA.Driver.Event ( Event(..) )-import Foreign.CUDA.Driver.Stream ( Stream )+import Control.Concurrent.MVar ( MVar, newMVar, withMVar, mkWeakMVar )+import Control.Exception ( bracket_ )+import Data.Hashable ( Hashable(..) )+import Foreign.CUDA.Driver.Stream ( Stream(..) )+import Foreign.Ptr ( ptrToIntPtr )+import qualified Foreign.CUDA.Driver as CUDA import qualified Foreign.CUDA.Driver.Event as Event+import qualified Data.HashTable.IO as HT -import GHC.Base-import GHC.Ptr+type Event = Lifetime Event.Event +type HashTable key val = HT.BasicHashTable key val --- Create a new event that will be automatically garbage collected. The event is--- not suitable for timing purposes.+type EventTable = MVar ( HashTable (Lifetime CUDA.Context) (FullList () Event.Event) )++instance Hashable (Lifetime CUDA.Context) where+ {-# INLINE hashWithSalt #-}+ hashWithSalt salt (unsafeGetValue -> CUDA.Context ctx)+ = salt `hashWithSalt` (fromIntegral (ptrToIntPtr ctx) :: Int)+++-- Generate a new empty event table. --+new :: IO EventTable+new = do+ tbl <- HT.new+ ref <- newMVar tbl+ _ <- mkWeakMVar ref (flush tbl)+ return ref++-- Create a new event. It will be automatically garbage collected, if a recycled+-- event is available, it will be returned, else a new event is created.+-- {-# INLINE create #-}-create :: IO Event-create = do- event <- Event.create [Event.DisableTiming]- addEventFinalizer event $ trace ("destroy " ++ show event) (Event.destroy event)+create :: Context -> EventTable -> IO Event+create ctx ref = withMVar ref $ \tbl -> do+ --+ let key = deviceContext ctx+ me <- HT.lookup tbl key+ e <- case me of+ Nothing -> do+ e <- Event.create [Event.DisableTiming]+ message ("new " ++ show e)+ return e++ Just (FL () e rest) -> do+ case rest of+ FL.Nil -> HT.delete tbl key+ FL.Cons () e' es -> HT.insert tbl key (FL () e' es)+ --+ return e+ --+ event <- newLifetime e+ addFinalizer event $ do+ D.traceIO D.dump_gc ("gc: finalise event " ++ showEvent event)+ insert ref (deviceContext ctx) e return event +{-# INLINE insert #-}+-- Insert an event into the table.+--+insert :: EventTable -> Lifetime CUDA.Context -> Event.Event -> IO ()+insert ref lctx e = withMVar ref $ \tbl -> do+ me <- HT.lookup tbl lctx+ case me of+ Nothing -> HT.insert tbl lctx (FL.singleton () e)+ Just es -> HT.insert tbl lctx (FL.cons () e es)+ -- Create a new event marker that will be filled once execution in the specified -- stream has completed all previously submitted work. -- {-# INLINE waypoint #-}-waypoint :: Stream -> IO Event-waypoint stream = do- event <- create- Event.record event (Just stream)--- message $ "waypoint " ++ show event ++ " in " ++ show stream+waypoint :: Context -> EventTable -> Stream -> IO Event+waypoint ctx ref stream = do+ event <- create ctx ref+ withLifetime event (`Event.record` Just stream)+ message $ "waypoint " ++ showEvent event ++ " in " ++ showStream stream return event -- Make all future work submitted to the given stream wait until the event@@ -56,31 +111,50 @@ {-# INLINE after #-} after :: Event -> Stream -> IO () after event stream = do--- message $ "after " ++ show event ++ " in " ++ show stream- Event.wait event (Just stream) []+ message $ "after " ++ showEvent event ++ " in " ++ showStream stream+ withLifetime event $ \e -> Event.wait e (Just stream) [] -- Block the calling thread until the event is recorded -- {-# INLINE block #-} block :: Event -> IO ()-block = Event.block+block = flip withLifetime Event.block +-- Query the status of the event.+--+{-# INLINE query #-}+query :: Event -> IO Bool+query = flip withLifetime Event.query --- Add a finaliser to an event token+-- Explicitly destroy the event. ---addEventFinalizer :: Event -> IO () -> IO ()-addEventFinalizer e@(Event (Ptr e#)) f = IO $ \s ->- case mkWeak# e# e f s of (# s', _w #) -> (# s', () #)+{-# INLINE destroy #-}+destroy :: Event -> IO ()+destroy = finalize +-- Destroy all events in the table.+--+flush :: HashTable (Lifetime CUDA.Context) (FullList () Event.Event) -> IO ()+flush !tbl =+ let clean (!lctx,!es) = do+ withLifetime lctx $ \ctx -> bracket_ (CUDA.push ctx) CUDA.pop (FL.mapM_ (const Event.destroy) es)+ HT.delete tbl lctx+ in+ message "flush reservoir" >> HT.mapM_ clean tbl + -- Debug -- ----- -{-# INLINE trace #-}-trace :: String -> IO a -> IO a-trace msg next = D.message D.dump_exec ("event: " ++ msg) >> next+{-# INLINE message #-}+message :: String -> IO ()+message msg = D.traceIO D.dump_sched ("event: " ++ msg) --- {-# INLINE message #-}--- message :: String -> IO ()--- message s = s `trace` return ()+{-# INLINE showEvent #-}+showEvent :: Event -> String+showEvent (unsafeGetValue -> Event.Event e) = show e++{-# INLINE showStream #-}+showStream :: Stream -> String+showStream (Stream s) = show s
Data/Array/Accelerate/CUDA/Execute/Stream.hs view
@@ -1,7 +1,11 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.CUDA.Execute.Stream--- Copyright : [2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- Copyright : [2013..2014] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>@@ -16,22 +20,20 @@ ) where -- friends-import Data.Array.Accelerate.CUDA.Array.Nursery ( ) -- hashable CUDA.Context instance import Data.Array.Accelerate.CUDA.Context ( Context(..) )-import Data.Array.Accelerate.CUDA.FullList ( FullList(..) )-import Data.Array.Accelerate.CUDA.Execute.Event ( Event )+import Data.Array.Accelerate.CUDA.Execute.Event ( Event, EventTable )+import Data.Array.Accelerate.FullList ( FullList(..) )+import Data.Array.Accelerate.Lifetime ( Lifetime, withLifetime ) import qualified Data.Array.Accelerate.CUDA.Execute.Event as Event-import qualified Data.Array.Accelerate.CUDA.FullList as FL import qualified Data.Array.Accelerate.CUDA.Debug as D+import qualified Data.Array.Accelerate.FullList as FL -- libraries-import Control.Monad ( void ) import Control.Monad.Trans ( MonadIO, liftIO ) import Control.Exception ( bracket_ )-import Control.Concurrent ( forkIO ) import Control.Concurrent.MVar ( MVar, newMVar, withMVar, mkWeakMVar ) import System.Mem.Weak ( Weak, deRefWeak )-import Foreign.CUDA.Driver.Stream ( Stream )+import Foreign.CUDA.Driver.Stream ( Stream(..) ) import qualified Foreign.CUDA.Driver as CUDA import qualified Foreign.CUDA.Driver.Stream as Stream @@ -47,7 +49,7 @@ -- type HashTable key val = HT.BasicHashTable key val -type RSV = MVar ( HashTable CUDA.Context (FullList () Stream) )+type RSV = MVar ( HashTable (Lifetime CUDA.Context) (FullList () Stream) ) data Reservoir = Reservoir {-# UNPACK #-} !RSV {-# UNPACK #-} !(Weak RSV) @@ -55,16 +57,21 @@ -- Executing operations in streams -- ------------------------------- --- Execute an operation in a unique execution stream.+-- Execute an operation in a unique execution stream. The (asynchronous) result+-- is passed to a second operation together with an event that will be signalled+-- once the operation is complete. The stream and event are released after the+-- second operation completes. -- {-# INLINE streaming #-}-streaming :: MonadIO m => Context -> Reservoir -> (Stream -> m a) -> m (Event, a)-streaming !ctx !rsv@(Reservoir !_ !weak_rsv) !action = do+streaming :: MonadIO m => Context -> Reservoir -> EventTable -> (Stream -> m a) -> (Event -> a -> m b) -> m b+streaming !ctx !rsv@(Reservoir !_ !weak_rsv) !etbl !action !after = do stream <- liftIO $ create ctx rsv- result <- action stream- end <- liftIO $ Event.waypoint stream- liftIO $ merge (weakContext ctx) weak_rsv stream- return $ (end, result)+ first <- action stream+ end <- liftIO $ Event.waypoint ctx etbl stream+ final <- after end first+ liftIO $! destroy (weakContext ctx) weak_rsv stream+ liftIO $! Event.destroy end+ return final -- Primitive operations@@ -86,61 +93,67 @@ -- {-# INLINE create #-} create :: Context -> Reservoir -> IO Stream-create !ctx (Reservoir !ref _) = withMVar ref $ \tbl -> do- let key = deviceContext ctx+create !ctx (Reservoir !ref !_) = withMVar ref $ \tbl -> do --+ let key = deviceContext ctx ms <- HT.lookup tbl key case ms of Nothing -> do- stream <- Stream.create []- message ("new " ++ showStream stream)- return stream+ stream <- Stream.create []+ message ("new " ++ showStream stream)+ return stream Just (FL () stream rest) -> do case rest of FL.Nil -> HT.delete tbl key FL.Cons () s ss -> HT.insert tbl key (FL () s ss)- --+ -- return stream --- Merge a stream back into the reservoir. This is done asynchronously, once all+-- Merge a stream back into the reservoir. This must only be done once all -- pending operations in the stream have completed. ---{-# INLINE merge #-}-merge :: Weak CUDA.Context -> Weak RSV -> Stream -> IO ()-merge !weak_ctx !weak_rsv !stream- = void . forkIO- $ do -- wait for all operations to complete- -- Stream.block stream+{-# INLINE destroy #-}+destroy :: Weak (Lifetime CUDA.Context) -> Weak RSV -> Stream -> IO ()+destroy !weak_ctx !weak_rsv !stream = do+ -- Wait for all preceding operations submitted to the stream to complete. Not+ -- necessary because of the setup of 'streaming'.+ -- Stream.block stream - -- Now check whether the context and reservoir are still active. Return- -- the stream back to the reservoir for later reuse if we can, otherwise- -- destroy it.- --- mc <- deRefWeak weak_ctx- case mc of- Nothing -> message ("finalise/dead context " ++ showStream stream)- Just ctx -> do- --- mr <- deRefWeak weak_rsv- case mr of- Nothing -> trace ("merge/free " ++ showStream stream) $ Stream.destroy stream- Just ref -> trace ("merge/save " ++ showStream stream) $ withMVar ref $ \tbl -> do- --- ms <- HT.lookup tbl ctx- case ms of- Nothing -> HT.insert tbl ctx (FL.singleton () stream)- Just ss -> HT.insert tbl ctx (FL.cons () stream ss)+ -- Now check whether the context and reservoir are still active. Return+ -- the stream back to the reservoir for later reuse if we can, otherwise+ -- destroy it.+ mc <- deRefWeak weak_ctx+ case mc of+ Nothing -> message ("finalise/dead context " ++ showStream stream)+ Just ctx -> do+ --+ mr <- deRefWeak weak_rsv+ case mr of+ Nothing -> trace ("destroy/free " ++ showStream stream) $ Stream.destroy stream+ Just ref -> trace ("destroy/save " ++ showStream stream) $ withMVar ref $ \tbl -> do+ --+ ms <- HT.lookup tbl ctx+ case ms of+ Nothing -> HT.insert tbl ctx (FL.singleton () stream)+ Just ss -> HT.insert tbl ctx (FL.cons () stream ss) +-- Add a finaliser to an execution stream+--+-- addStreamFinalizer :: Stream -> IO () -> IO ()+-- addStreamFinalizer st@(Stream (Ptr st#)) f = IO $ \s ->+-- case mkWeak# st# st f s of (# s', _w #) -> (# s', () #)++ -- Destroy all streams in the reservoir. ---flush :: HashTable CUDA.Context (FullList () Stream) -> IO ()+flush :: HashTable (Lifetime CUDA.Context) (FullList () Stream) -> IO () flush !tbl =- let clean (!ctx,!ss) = do- bracket_ (CUDA.push ctx) CUDA.pop (FL.mapM_ (const Stream.destroy) ss)- HT.delete tbl ctx+ let clean (!lctx,!ss) = do+ withLifetime lctx $ \ctx -> bracket_ (CUDA.push ctx) CUDA.pop (FL.mapM_ (const Stream.destroy) ss)+ HT.delete tbl lctx in message "flush reservoir" >> HT.mapM_ clean tbl @@ -150,13 +163,13 @@ {-# INLINE trace #-} trace :: String -> IO a -> IO a-trace msg next = D.message D.dump_exec ("stream: " ++ msg) >> next+trace msg next = message msg >> next {-# INLINE message #-} message :: String -> IO ()-message s = s `trace` return ()+message msg = D.traceIO D.dump_sched ("stream: " ++ msg) {-# INLINE showStream #-} showStream :: Stream -> String-showStream (Stream.Stream s) = show s+showStream (Stream s) = show s
Data/Array/Accelerate/CUDA/Foreign.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Data.Array.Accelerate.CUDA.Foreign--- Copyright : [2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell, Robert Clifton-Everest+-- Copyright : [2013..2014] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell, Robert Clifton-Everest -- License : BSD3 -- -- Maintainer : Robert Clifton-Everest <robertce@cse.unsw.edu.au>
Data/Array/Accelerate/CUDA/Foreign/Export.hs view
@@ -1,18 +1,20 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE GADTs #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ImpredicativeTypes #-}-{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.CUDA.Foreign.Export--- Copyright : [2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell, Robert Clifton-Everest+-- Copyright : [2013..2014] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell, Robert Clifton-Everest -- License : BSD3 -- -- Maintainer : Robert Clifton-Everest <robertce@cse.unsw.edu.au>@@ -38,24 +40,25 @@ ) where -import Prelude as P import Data.Functor import Control.Applicative+import Control.Monad.State ( liftIO ) import Foreign.StablePtr import Foreign.C.Types import Foreign.Ptr import Foreign.Storable ( Storable(..) ) import Foreign.Marshal.Array ( peekArray, pokeArray, mallocArray ) import Foreign.Marshal.Alloc ( free )-import Control.Monad.State ( liftIO )-import qualified Foreign.CUDA.Driver as CUDA import Language.Haskell.TH hiding ( ppr )+import qualified Foreign.CUDA.Driver as CUDA +import Prelude as P+ -- friends import Data.Array.Accelerate.Smart ( Acc ) import Data.Array.Accelerate.Type import Data.Array.Accelerate.Array.Data-import Data.Array.Accelerate.CUDA ( run1In )+import Data.Array.Accelerate.CUDA ( run1With ) import Data.Array.Accelerate.CUDA.Array.Sugar hiding ( shape, size ) import Data.Array.Accelerate.CUDA.Array.Data hiding ( pokeArray, peekArray, mallocArray ) import Data.Array.Accelerate.CUDA.State@@ -210,12 +213,13 @@ shbuf <- liftIO $ mallocArray (P.length sh') liftIO $ pokeArray shbuf (map fromIntegral sh') - dptrs <- devicePtrsToWordPtrs adata <$> devicePtrsOfArrayData adata- pbuf <- liftIO $ mallocArray (P.length dptrs)- liftIO $ pokeArray pbuf dptrs+ withDevicePtrs adata Nothing $ \dptrs -> do+ let wptrs = devicePtrsToWordPtrs adata dptrs+ pbuf <- liftIO $ mallocArray (P.length wptrs)+ liftIO $ pokeArray pbuf wptrs - sa <- liftIO $ newStablePtr (EArray a)- return (shbuf, pbuf, sa)+ sa <- liftIO $ newStablePtr (EArray a)+ return (shbuf, pbuf, sa) marshalOut (ArraysRpair aR1 aR2) (x,y) ptr = do ptr' <- marshalOut aR1 x ptr@@ -226,13 +230,17 @@ -- a function callable from foreign code with the second argument specifying it's name. exportAfun :: Name -> String -> Q [Dec] exportAfun fname ename = do+#if __GLASGOW_HASKELL__ <= 710 (VarI n ty _ _) <- reify fname+#else+ (VarI n ty _) <- reify fname+#endif -- Generate initialisation function genCompileFun n ename ty genCompileFun :: Name -> String -> Type -> Q [Dec]-genCompileFun fname ename ty@(AppT (AppT ArrowT (AppT _ a)) (AppT _ b))+genCompileFun fname ename (AppT (AppT ArrowT (AppT _ _)) (AppT _ _)) = sequence [sig, dec, expt] where initName = mkName ename@@ -254,14 +262,14 @@ ef :: IO (StablePtr Afun) ef = do ctx <- deRefStablePtr hndl- newStablePtr (Afun (run1In ctx f) (undefined :: a) (undefined :: b))+ newStablePtr (Afun (run1With ctx f) (undefined :: a) (undefined :: b)) -- Utility functions -- ------------------ arrayFromForeignData :: forall sh e. (Shape sh, Elt e) => DevicePtrBuffer -> ShapeBuffer -> CIO (Array sh e) arrayFromForeignData ptrs shape = do- let d = dim (ignore :: sh) -- Using ignore as using dim requires a non-dummy argument+ let d = rank (ignore :: sh) -- Using ignore as using dim requires a non-dummy argument let sz = eltSize (eltType (undefined :: e)) lst <- liftIO (peekArray d shape) let sh = listToShape (map fromIntegral lst) :: sh
Data/Array/Accelerate/CUDA/Foreign/Import.hs view
@@ -12,7 +12,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.CUDA.Foreign.Import--- Copyright : [2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell, Robert Clifton-Everest+-- Copyright : [2013..2014] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell, Robert Clifton-Everest -- License : BSD3 -- -- Maintainer : Robert Clifton-Everest <robertce@cse.unsw.edu.au>@@ -44,15 +44,16 @@ -- * Manipulating arrays DevicePtrs,- devicePtrsOfArray,- indexArray, copyArray,+ withDevicePtrs,+ indexArray, useArray, useArrayAsync, peekArray, peekArrayAsync, pokeArray, pokeArrayAsync,- allocateArray, newArray,+ copyArray, copyArrayAsync,+ allocateArray, fromFunction, -- * Running IO actions in an Accelerate context- CIO, liftIO, inContext, inDefaultContext+ CIO, Stream, liftIO, inContext, inDefaultContext ) where @@ -60,12 +61,15 @@ import Data.Array.Accelerate.CUDA.State import Data.Array.Accelerate.CUDA.Context import Data.Array.Accelerate.CUDA.Array.Sugar-import Data.Array.Accelerate.CUDA.Array.Data+import Data.Array.Accelerate.CUDA.Array.Data hiding ( withDevicePtrs )+import qualified Data.Array.Accelerate.CUDA.Array.Data as D import Data.Array.Accelerate.CUDA.Array.Prim ( DevicePtrs )+import Data.Array.Accelerate.CUDA.Execute.Stream ( Stream ) import Data.Typeable import Control.Exception ( bracket_ ) import Control.Monad.Trans ( liftIO )+import qualified Foreign.CUDA.Driver.Stream as CUDA -- CUDA backend representation of foreign functions@@ -73,12 +77,12 @@ -- |CUDA foreign Acc functions are just CIO functions. ---data CUDAForeignAcc as bs where+data CUDAForeignAcc f where CUDAForeignAcc :: String -- name of the function- -> (as -> CIO bs) -- operation to execute- -> CUDAForeignAcc as bs+ -> (Stream -> as -> CIO bs) -- operation to execute+ -> CUDAForeignAcc (as -> bs) -deriving instance Typeable2 CUDAForeignAcc+deriving instance Typeable CUDAForeignAcc instance Foreign CUDAForeignAcc where strForeign (CUDAForeignAcc n _) = n@@ -87,11 +91,11 @@ -- CUDA backend. -- canExecuteAcc- :: (Foreign f, Typeable as, Typeable bs)- => f as bs- -> Maybe (as -> CIO bs)+ :: forall asm as bs. (Foreign asm, Typeable as, Typeable bs)+ => asm (as -> bs)+ -> Maybe (Stream -> as -> CIO bs) canExecuteAcc ff- | Just (CUDAForeignAcc _ fun) <- cast ff+ | Just (CUDAForeignAcc _ fun) <- cast ff :: Maybe (CUDAForeignAcc (as -> bs)) = Just fun | otherwise@@ -100,13 +104,13 @@ -- |CUDA foreign Exp functions consist of a list of C header files necessary to call the function -- and the name of the function to call. ---data CUDAForeignExp x y where+data CUDAForeignExp f where CUDAForeignExp :: IsScalar y => [String] -- header files to be imported -> String -- name of the foreign function- -> CUDAForeignExp x y+ -> CUDAForeignExp (x -> y) -deriving instance Typeable2 CUDAForeignExp+deriving instance Typeable CUDAForeignExp instance Foreign CUDAForeignExp where strForeign (CUDAForeignExp _ n) = n@@ -115,11 +119,11 @@ -- for the CUDA backend. -- canExecuteExp- :: forall f x y. (Foreign f, Typeable y, Typeable x)- => f x y+ :: forall asm x y. (Foreign asm, Typeable y, Typeable x)+ => asm (x -> y) -> Maybe ([String], String) canExecuteExp ff- | Just (CUDAForeignExp hdr fun) <- cast ff :: Maybe (CUDAForeignExp x y)+ | Just (CUDAForeignExp hdr fun) <- cast ff :: Maybe (CUDAForeignExp (x -> y)) = Just (hdr, fun) | otherwise@@ -129,10 +133,11 @@ -- User facing utility functions -- ----------------------------- --- |Get the raw CUDA device pointers associated with an array+-- |Get the raw CUDA device pointers associated with an array and call the given+-- continuation. ---devicePtrsOfArray :: Array sh e -> CIO (DevicePtrs (EltRepr e))-devicePtrsOfArray (Array _ adata) = devicePtrsOfArrayData adata+withDevicePtrs :: Array sh e -> Maybe CUDA.Stream -> (DevicePtrs (EltRepr e) -> CIO b) -> CIO b+withDevicePtrs (Array _ adata) = D.withDevicePtrs adata -- |Run an IO action within the given Acclerate context --
− Data/Array/Accelerate/CUDA/FullList.hs
@@ -1,118 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE PatternGuards #-}--- |--- Module : Data.Array.Accelerate.CUDA.FullList--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell--- License : BSD3------ Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability : experimental--- Portability : non-portable (GHC extensions)------ Non-empty lists of key/value pairs. The lists are strict in the key and lazy--- in the values. We assume that keys only occur once.-----module Data.Array.Accelerate.CUDA.FullList (-- FullList(..),- List(..),-- singleton,- cons,- size,- mapM_,- lookup,- lookupDelete,--) where--import Prelude hiding ( lookup, mapM_ )---data FullList k v = FL !k v !(List k v)-data List k v = Nil | Cons !k v !(List k v)--infixr 5 `Cons`--instance (Eq k, Eq v) => Eq (FullList k v) where- (FL k1 v1 xs) == (FL k2 v2 ys) = k1 == k2 && v1 == v2 && xs == ys- (FL k1 v1 xs) /= (FL k2 v2 ys) = k1 /= k2 || v1 /= v2 || xs /= ys--instance (Eq k, Eq v) => Eq (List k v) where- (Cons k1 v1 xs) == (Cons k2 v2 ys) = k1 == k2 && v1 == v2 && xs == ys- Nil == Nil = True- _ == _ = False-- (Cons k1 v1 xs) /= (Cons k2 v2 ys) = k1 /= k2 || v1 /= v2 || xs /= ys- Nil /= Nil = False- _ /= _ = True----- List-like operations----infixr 5 `cons`-cons :: k -> v -> FullList k v -> FullList k v-cons k v (FL k' v' xs) = FL k v (Cons k' v' xs)--singleton :: k -> v -> FullList k v-singleton k v = FL k v Nil--size :: FullList k v -> Int-size (FL _ _ xs) = 1 + sizeL xs--sizeL :: List k v -> Int-sizeL Nil = 0-sizeL (Cons _ _ xs) = 1 + sizeL xs--lookup :: Eq k => k -> FullList k v -> Maybe v-lookup key (FL k v xs)- | key == k = Just v- | otherwise = lookupL key xs-{-# INLINABLE lookup #-}-{-# SPECIALISE lookup :: () -> FullList () v -> Maybe v #-}--lookupL :: Eq k => k -> List k v -> Maybe v-lookupL !key = go- where- go Nil = Nothing- go (Cons k v xs)- | key == k = Just v- | otherwise = go xs-{-# INLINABLE lookupL #-}-{-# SPECIALISE lookupL :: () -> List () v -> Maybe v #-}--lookupDelete :: Eq k => k -> FullList k v -> (Maybe v, Maybe (FullList k v))-lookupDelete key (FL k v xs)- | key == k- = case xs of- Nil -> (Just v, Nothing)- Cons k' v' xs' -> (Just v, Just $ FL k' v' xs')-- | (r, xs') <- lookupDeleteL k xs- = (r, Just $ FL k v xs')-{-# INLINABLE lookupDelete #-}-{-# SPECIALISE lookupDelete :: () -> FullList () v -> (Maybe v, Maybe (FullList () v)) #-}--lookupDeleteL :: Eq k => k -> List k v -> (Maybe v, List k v)-lookupDeleteL !key = go- where- go Nil = (Nothing, Nil)- go (Cons k v xs)- | key == k = (Just v, xs)- | (r, xs') <- go xs = (r, Cons k v xs')-{-# INLINABLE lookupDeleteL #-}-{-# SPECIALISE lookupDeleteL :: () -> List () v -> (Maybe v, List () v) #-}--mapM_ :: Monad m => (k -> v -> m a) -> FullList k v -> m ()-mapM_ !f (FL k v xs) = f k v >> mapML_ f xs-{-# INLINABLE mapM_ #-}--mapML_ :: Monad m => (k -> v -> m a) -> List k v -> m ()-mapML_ !f = go- where- go Nil = return ()- go (Cons k v xs) = f k v >> go xs-{-# INLINABLE mapML_ #-}-
Data/Array/Accelerate/CUDA/Persistent.hs view
@@ -1,10 +1,11 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.CUDA.Persistent--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>@@ -22,33 +23,37 @@ ) where -- friends+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.FullList ( FullList )+import Data.Array.Accelerate.Lifetime ( Lifetime, withLifetime, newLifetime ) import Data.Array.Accelerate.CUDA.Context-import Data.Array.Accelerate.CUDA.FullList ( FullList ) import qualified Data.Array.Accelerate.CUDA.Debug as D-import qualified Data.Array.Accelerate.CUDA.FullList as FL+import qualified Data.Array.Accelerate.FullList as FL -- libraries-import Prelude hiding ( lookup ) import Numeric-import Data.Char-import System.IO-import System.FilePath-import System.Directory-import System.IO.Error-import System.Mem.Weak import Control.Applicative import Control.Concurrent import Control.Exception-import Control.Monad.Trans-import Data.Version+import Control.Monad ( when ) import Data.Binary-import Data.Hashable import Data.Binary.Get import Data.ByteString ( ByteString ) import Data.ByteString.Internal ( w2c )-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L+import Data.Char+import Data.Hashable+import Data.Maybe ( fromMaybe )+import Data.Version+import System.Directory+import System.FilePath+import System.IO+import System.IO.Error+import System.Mem.Weak+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Internal as BL import qualified Data.HashTable.IO as HT+import Prelude hiding ( lookup ) import qualified Foreign.CUDA.Driver as CUDA @@ -67,6 +72,8 @@ -- Interface ------------------------------------------------------------------- -- --------- -- +type HashTable key val = HT.BasicHashTable key val+ data KernelTable = KT {-# UNPACK #-} !ProgramCache -- first level, in-memory cache {-# UNPACK #-} !PersistentCache -- second level, on-disk cache @@ -76,7 +83,7 @@ cacheDir <- cacheDirectory createDirectoryIfMissing True cacheDir --- local <- HT.new+ local <- newMVar =<< HT.new persistent <- restore (cacheDir </> "persistent.db") -- return $! KT local persistent@@ -86,7 +93,7 @@ -- the persistent cache, it is loaded and linked into the current context. -- lookup :: Context -> KernelTable -> KernelKey -> IO (Maybe KernelEntry)-lookup context (KT kt pt) !key = do+lookup context (KT !kt_ref !pt_ref) !key = withMVar kt_ref $ \kt -> do -- First check the local cache. If we get a hit, this could be: -- a) currently compiling -- b) compiled, but not linked into the current context@@ -95,7 +102,7 @@ v1 <- HT.lookup kt key case v1 of Just _ -> return v1- Nothing -> do+ Nothing -> withMVar pt_ref $ \pt -> do -- Check the persistent cache. If found, read in the associated object file -- and link it into the current context. Also add to the first-level cache.@@ -109,10 +116,11 @@ Just () -> do message "found/persistent" cubin <- (</>) <$> cacheDirectory <*> pure (cacheFilePath key)- bin <- B.readFile cubin+ bin <- BS.readFile cubin !mdl <- CUDA.loadData bin- let obj = KernelObject bin (FL.singleton (deviceContext context) mdl)- addFinalizer mdl (module_finalizer (weakContext context) key mdl)+ lmdl <- newLifetime mdl+ let obj = KernelObject bin (FL.singleton (deviceContext context) lmdl)+ addFinalizer lmdl (module_finalizer (weakContext context) key lmdl) HT.insert kt key obj return $! Just obj @@ -124,19 +132,21 @@ -- exists there already? Would require updating that hash table as new -- entries are added, which the functions currently do not do. --+{-# INLINE insert #-} insert :: KernelTable -> KernelKey -> KernelEntry -> IO ()-insert (KT kt _) !key !val = HT.insert kt key val+insert (KT !kt_ref !_) !key !val = withMVar kt_ref $ \kt -> HT.insert kt key val -- Unload a kernel module from the specified context ---module_finalizer :: Weak CUDA.Context -> KernelKey -> CUDA.Module -> IO ()-module_finalizer weak_ctx key mdl = do+module_finalizer :: Weak (Lifetime CUDA.Context) -> KernelKey -> Lifetime CUDA.Module -> IO ()+module_finalizer weak_ctx key lmdl = do mc <- deRefWeak weak_ctx case mc of- Nothing -> D.message D.dump_gc ("gc: finalise module/dead context: " ++ cacheFilePath key)- Just ctx -> D.message D.dump_gc ("gc: finalise module: " ++ cacheFilePath key)- >> bracket_ (CUDA.push ctx) CUDA.pop (CUDA.unload mdl)+ Nothing -> D.traceIO D.dump_gc ("gc: finalise module/dead context: " ++ cacheFilePath key)+ Just fctx -> D.traceIO D.dump_gc ("gc: finalise module: " ++ cacheFilePath key)+ >> withLifetime fctx (\ctx -> withLifetime lmdl (\mdl ->+ bracket_ (CUDA.push ctx) CUDA.pop (CUDA.unload mdl))) -- Local cache -----------------------------------------------------------------@@ -160,7 +170,7 @@ -- computation and no more, but we can not do that. Instead, this is keyed to -- the generated kernel code. ---type ProgramCache = HT.BasicHashTable KernelKey KernelEntry+type ProgramCache = MVar ( HashTable KernelKey KernelEntry ) type KernelKey = (CUDA.Compute, ByteString) data KernelEntry@@ -176,7 +186,8 @@ -- re-link into the current context. -- | KernelObject {-# UNPACK #-} !ByteString- {-# UNPACK #-} !(FullList CUDA.Context CUDA.Module)+ {-# UNPACK #-} !(FullList (Lifetime CUDA.Context)+ (Lifetime CUDA.Module)) -- Persistent cache ------------------------------------------------------------@@ -185,12 +196,16 @@ -- Stash compiled code into the user's home directory so that they are available -- across separate runs of the program. ----- TLM: we don't have any migration or versioning policy here, so cache files+-- TLM: We don't have any migration or versioning policy here, so cache files -- will be kept around indefinitely. This can easily clutter the cache by -- generating many similar kernels that differ only by, for example, an -- embedded constant value.+--+-- One way to handle this is to put a maximum size on the cache (either as+-- disk space consumed or number of kernels) and once the maximum size is+-- reached keep only the most recently used files. -type PersistentCache = HT.BasicHashTable KernelKey ()+type PersistentCache = MVar ( HashTable KernelKey () ) -- The root directory of where the various persistent cache files live; the@@ -210,7 +225,7 @@ -- cacheFilePath :: KernelKey -> FilePath cacheFilePath (cap, key) =- show cap </> zEncodeString (B.foldl (flip (showLitChar . w2c)) [] key)+ show cap </> zEncodeString (BS.foldl (flip (showLitChar . w2c)) [] key) -- stolen from compiler/utils/Encoding.hs --@@ -288,27 +303,45 @@ -- file is created, so that 'persist' can always append elements. -- restore :: FilePath -> IO PersistentCache-restore db = do- D.when D.flush_cache $ do+restore !db = do+ mflush <- D.queryFlag D.flush_cache+ when (fromMaybe False mflush) $ do message "deleting persistent cache" cacheDir <- cacheDirectory removeDirectoryRecursive cacheDir createDirectoryIfMissing True cacheDir -- exists <- doesFileExist db- case exists of+ pt <- case exists of False -> encodeFile db (0::Int) >> HT.new True -> do- store <- L.readFile db- let (n,rest,_) = runGetState get store 0+ store <- BL.readFile db++ -- Just read the start of the input to extract the number of entries+ -- in the persistent kernel table.+ let (n, rest) = setup (runGetIncremental get) store++ setup (Done s _ r) lbs = (r, BL.Chunk s lbs)+ setup (Partial k) lbs = setup (k (takeHeadChunk lbs)) (dropHeadChunk lbs)+ setup (Fail _ p msg) _ = $internalError "restore" $ show p ++ ": " ++ msg++ takeHeadChunk (BL.Chunk h _) = Just h+ takeHeadChunk _ = Nothing++ dropHeadChunk (BL.Chunk _ t) = t+ dropHeadChunk _ = BL.empty++ -- Allocate the persistent hash table and populate it with entries decoded+ -- from the index file pt <- HT.newSized n- -- let go [] = return () go (!k:xs) = HT.insert pt k () >> go xs- --+ message $ "persist/restore: " ++ shows n " entries" go (runGet (getMany n) rest) evaluate pt+ --+ newMVar pt -- Append a single value to the persistent cache.@@ -316,8 +349,8 @@ -- This moves the compiled object file (first argument) to the appropriate -- location, and updates the database on disk. ---persist :: FilePath -> KernelKey -> IO ()-persist !cubin !key = do+persist :: KernelTable -> FilePath -> KernelKey -> IO ()+persist (KT !_ !pt_ref) !cubin !key = withMVar pt_ref $ \_ -> do cacheDir <- cacheDirectory let db = cacheDir </> "persistent.db" cacheFile = cacheDir </> cacheFilePath key@@ -335,24 +368,20 @@ withBinaryFile db ReadWriteMode $ \h -> do -- The file opens with the cursor at the beginning of the file --- n <- runGet (get :: Get Int) `fmap` L.hGet h 8+ n <- runGet (get :: Get Int) `fmap` BL.hGet h 8 hSeek h AbsoluteSeek 0- L.hPut h (encode (n+1))+ BL.hPut h (encode (n+1)) -- Append the new entry to the end of file -- hSeek h SeekFromEnd 0- L.hPut h (encode key)+ BL.hPut h (encode key) -- Debug -- ----- {-# INLINE message #-}-message :: MonadIO m => String -> m ()-message msg = trace msg $ return ()--{-# INLINE trace #-}-trace :: MonadIO m => String -> m a -> m a-trace msg next = D.message D.dump_cc ("cc: " ++ msg) >> next+message :: String -> IO ()+message msg = D.traceIO D.dump_cc ("cc: " ++ msg)
Data/Array/Accelerate/CUDA/State.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-} -- | -- Module : Data.Array.Accelerate.CUDA.State--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>@@ -20,34 +20,35 @@ module Data.Array.Accelerate.CUDA.State ( -- Evaluating computations- CIO, Context, evalCUDA,+ CIO, Context, evalCUDA, evalCUDAState, -- Querying execution state defaultContext, deviceProperties, activeContext, kernelTable, memoryTable, streamReservoir,+ eventTable, ) where -- friends+import Data.Array.Accelerate.Error import Data.Array.Accelerate.CUDA.Context-import Data.Array.Accelerate.CUDA.Debug ( message, dump_gc )+import Data.Array.Accelerate.CUDA.Debug ( traceIO, dump_gc ) import Data.Array.Accelerate.CUDA.Persistent as KT ( KernelTable, new )-import Data.Array.Accelerate.CUDA.Array.Table as MT ( MemoryTable, new )+import Data.Array.Accelerate.CUDA.Array.Remote as MT ( MemoryTable, new ) import Data.Array.Accelerate.CUDA.Execute.Stream as ST ( Reservoir, new )+import Data.Array.Accelerate.CUDA.Execute.Event as ET ( EventTable, new) import Data.Array.Accelerate.CUDA.Analysis.Device -- library-import Control.Applicative ( Applicative )+import Control.Applicative import Control.Concurrent ( runInBoundThread ) import Control.Exception ( catch, bracket_ )-import Control.Monad.Trans ( MonadIO ) import Control.Monad.Reader ( MonadReader, ReaderT(..), runReaderT ) import Control.Monad.State.Strict ( MonadState, StateT(..), evalStateT )-import System.Mem ( performGC )+import Control.Monad.Trans ( MonadIO ) import System.IO.Unsafe ( unsafePerformIO ) import Foreign.CUDA.Driver.Error import qualified Foreign.CUDA.Driver as CUDA--#include "accelerate.h"+import Prelude -- Execution State@@ -60,7 +61,8 @@ data State = State { memoryTable :: {-# UNPACK #-} !MemoryTable, -- host/device memory associations kernelTable :: {-# UNPACK #-} !KernelTable, -- compiled kernel object code- streamReservoir :: {-# UNPACK #-} !Reservoir -- kernel execution streams+ streamReservoir :: {-# UNPACK #-} !Reservoir, -- kernel execution streams+ eventTable :: {-# UNPACK #-} !EventTable -- CUDA events } newtype CIO a = CIO {@@ -83,12 +85,20 @@ evalCUDA !ctx !acc = runInBoundThread (bracket_ setup teardown action) `catch`- \e -> INTERNAL_ERROR(error) "unhandled" (show (e :: CUDAException))+ \e -> $internalError "unhandled" (show (e :: CUDAException)) where setup = push ctx- teardown = pop >> performGC+ teardown = pop action = evalStateT (runReaderT (runCIO acc) ctx) theState +-- |Evaluate a CUDA array computation with the specific state. Exceptions are+-- not caught.+--+-- RCE: This is unfortunately hacky, but necessary to stop device pointers+-- leaking.+evalCUDAState :: Context -> MemoryTable -> KernelTable -> Reservoir -> EventTable -> CIO a -> IO a+evalCUDAState ctx mt kt rsv etbl acc = evalStateT (runReaderT (runCIO acc) ctx)+ (State mt kt rsv etbl) -- Top-level mutable state -- -----------------------@@ -101,11 +111,12 @@ theState :: State theState = unsafePerformIO- $ do message dump_gc "gc: initialise CUDA state"- mtb <- keepAlive =<< MT.new+ $ do message "initialise CUDA state"+ etbl <- keepAlive =<< ET.new+ mtb <- keepAlive =<< MT.new etbl ktb <- keepAlive =<< KT.new rsv <- keepAlive =<< ST.new- return $! State mtb ktb rsv+ return $! State mtb ktb rsv etbl -- Select and initialise a default CUDA device, and create a new execution@@ -115,8 +126,16 @@ {-# NOINLINE defaultContext #-} defaultContext :: Context defaultContext = unsafePerformIO $ do- message dump_gc "gc: initialise default context"+ message "initialise default context" CUDA.initialise [] (dev,_) <- selectBestDevice create dev [CUDA.SchedAuto]+++-- Debug+-- -----++{-# INLINE message #-}+message :: String -> IO ()+message msg = traceIO dump_gc ("gc: " ++ msg)
− Data/Array/Accelerate/Internal/Check.hs
@@ -1,123 +0,0 @@-{-# LANGUAGE CPP #-}--- |--- Module : Data.Array.Accelerate.Internal.Check--- Copyright : Roman Lechinskiy, Trevor L. McDonell--- License : BSD3------ Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability : experimental--- Portability : non-portable (GHC extensions)------ Bounds checking infrastructure------ Stolen from the Vector package by Roman Leshchinskiy. This code has a--- BSD-style license. <http://hackage.haskell.org/package/vector>-----module Data.Array.Accelerate.Internal.Check (-- -- * Bounds checking and assertion infrastructure- Checks(..), doChecks,- error, check, warning, assert, checkIndex, checkLength, checkSlice--) where--import Prelude hiding ( error )-import Debug.Trace-import qualified Prelude as P--data Checks = Bounds | Unsafe | Internal deriving( Eq )--doBoundsChecks :: Bool-#ifdef ACCELERATE_BOUNDS_CHECKS-doBoundsChecks = True-#else-doBoundsChecks = False-#endif--doUnsafeChecks :: Bool-#ifdef ACCELERATE_UNSAFE_CHECKS-doUnsafeChecks = True-#else-doUnsafeChecks = False-#endif--doInternalChecks :: Bool-#ifdef ACCELERATE_INTERNAL_CHECKS-doInternalChecks = True-#else-doInternalChecks = False-#endif---doChecks :: Checks -> Bool-{-# INLINE doChecks #-}-doChecks Bounds = doBoundsChecks-doChecks Unsafe = doUnsafeChecks-doChecks Internal = doInternalChecks--message :: String -> Int -> Checks -> String -> String -> String-{-# INLINE message #-}-message file line kind loc msg- = unlines- $ (if kind == Internal- then ([""- ,"*** Internal error in package accelerate ***"- ,"*** Please submit a bug report at https://github.com/AccelerateHS/accelerate/issues"]++)- else id)- [ file ++ ":" ++ show line ++ " (" ++ loc ++ "): " ++ msg ]--error :: String -> Int -> Checks -> String -> String -> a-{-# INLINE error #-}-error file line kind loc msg- = P.error (message file line kind loc msg)--check :: String -> Int -> Checks -> String -> String -> Bool -> a -> a-{-# INLINE check #-}-check file line kind loc msg cond x- | not (doChecks kind) || cond = x- | otherwise = error file line kind loc msg--warning :: String -> Int -> Checks -> String -> String -> Bool -> a -> a-{-# INLINE warning #-}-warning file line kind loc msg cond x- | not (doChecks kind) || cond = x- | otherwise = trace (message file line kind loc msg) x--assert_msg :: String-assert_msg = "assertion failure"--assert :: String -> Int -> Checks -> String -> Bool -> a -> a-{-# INLINE assert #-}-assert file line kind loc = check file line kind loc assert_msg--checkIndex_msg :: Int -> Int -> String-{-# NOINLINE checkIndex_msg #-}-checkIndex_msg i n = "index out of bounds " ++ show (i,n)--checkIndex :: String -> Int -> Checks -> String -> Int -> Int -> a -> a-{-# INLINE checkIndex #-}-checkIndex file line kind loc i n x- = check file line kind loc (checkIndex_msg i n) (i >= 0 && i<n) x---checkLength_msg :: Int -> String-{-# NOINLINE checkLength_msg #-}-checkLength_msg n = "negative length " ++ show n--checkLength :: String -> Int -> Checks -> String -> Int -> a -> a-{-# INLINE checkLength #-}-checkLength file line kind loc n x- = check file line kind loc (checkLength_msg n) (n >= 0) x---checkSlice_msg :: Int -> Int -> Int -> String-{-# NOINLINE checkSlice_msg #-}-checkSlice_msg i m n = "invalid slice " ++ show (i,m,n)--checkSlice :: String -> Int -> Checks -> String -> Int -> Int -> Int -> a -> a-{-# INLINE checkSlice #-}-checkSlice file line kind loc i m n x- = check file line kind loc (checkSlice_msg i m n)- (i >= 0 && m >= 0 && i+m <= n) x-
Setup.hs view
@@ -1,20 +1,3 @@-#! /usr/bin/env runhaskell--import Control.Monad import Distribution.Simple-import Distribution.Simple.Setup-import Distribution.Simple.Utils-import System.Directory--main :: IO ()-main = defaultMainWithHooks autoconfUserHooks { preConf = preConfHook }- where- preConfHook args flags = do- let verbosity = fromFlag (configVerbosity flags)-- confExists <- doesFileExist "configure"- unless confExists $- rawSystemExit verbosity "autoconf" []-- preConf autoconfUserHooks args flags+main = defaultMain
− accelerate-cuda.buildinfo.in
@@ -1,3 +0,0 @@-ghc-options: @ghc_flags@-cc-options: @cpp_flags@-
accelerate-cuda.cabal view
@@ -1,11 +1,13 @@ Name: accelerate-cuda-Version: 0.14.0.0+Version: 0.17.0.0 Cabal-version: >= 1.6-Tested-with: GHC == 7.6.*-Build-type: Custom+Tested-with: GHC >= 7.8+Build-type: Simple Synopsis: Accelerate backend for NVIDIA GPUs Description:+ __This backend has been deprecated in favour of <http://hackage.haskell.org/package/accelerate-llvm-ptx accelerate-llvm-ptx>.__+ . This library implements a backend for the /Accelerate/ language instrumented for parallel execution on CUDA-capable NVIDIA GPUs. For further information, refer to the main /Accelerate/ package:@@ -14,7 +16,7 @@ To use this backend you will need: . 1. A CUDA-enabled NVIDIA GPU with, for full functionality, compute- capability 1.2 or greater. See the table on Wikipedia for supported GPUs:+ capability 1.3 or greater. See the table on Wikipedia for supported GPUs: <http://en.wikipedia.org/wiki/CUDA#Supported_GPUs> . 2. The CUDA SDK, available from the NVIDIA Developer Zone:@@ -42,20 +44,12 @@ Data-files: cubits/accelerate_cuda.h cubits/accelerate_cuda_assert.h+ cubits/accelerate_cuda_exceptional.h cubits/accelerate_cuda_function.h cubits/accelerate_cuda_texture.h cubits/accelerate_cuda_type.h include/AccFFI.h -Extra-tmp-files: config.status- config.log- autom4te.cache- accelerate-cuda.buildinfo -- generated by configure--Extra-source-files: configure- accelerate-cuda.buildinfo.in- include/accelerate.h- Flag debug Description: Enable tracing message flags. These are read from the command-line@@ -90,33 +84,31 @@ Default: False Library- Include-Dirs: include-- Build-depends: accelerate == 0.14.*,+ Build-depends: accelerate == 1.0.*, array >= 0.3,- base == 4.6.*,- binary >= 0.5 && < 0.7,- -- binary 0.7 untested- bytestring >= 0.9 && < 0.11,- cryptohash >= 0.7 && < 0.12,- cuda >= 0.5.1.1 && < 0.6,+ base >= 4.7 && < 4.9.1,+ binary >= 0.7,+ bytestring >= 0.9,+ containers >= 0.3,+ cryptohash >= 0.7,+ cuda >= 0.7, directory >= 1.0,- fclabels >= 2.0 && < 2.1,+ fclabels >= 2.0, filepath >= 1.0,- hashable >= 1.1 && < 1.3,- hashtables >= 1.0.1 && < 1.2,- language-c-quote >= 0.4.4 && < 0.8,- mainland-pretty >= 0.2 && < 0.3,- mtl >= 2.0 && < 2.2,+ hashable >= 1.1,+ hashtables >= 1.0.1,+ language-c-quote >= 0.4.4,+ mainland-pretty >= 0.2,+ mtl >= 2.0, old-time >= 1.0, pretty >= 1.0, process >= 1.0,- SafeSemaphore >= 0.9 && < 0.10,- srcloc >= 0.2 && < 0.5,- text >= 0.11 && < 0.12,- template-haskell >= 2.2,- transformers >= 0.2 && < 0.4,- unordered-containers >= 0.1.4 && < 0.3+ SafeSemaphore >= 0.9,+ srcloc >= 0.2,+ text >= 0.11,+ template-haskell,+ transformers >= 0.2,+ unordered-containers >= 0.1.4 if os(windows) cpp-options: -DWIN32@@ -131,14 +123,16 @@ Other-modules: Data.Array.Accelerate.CUDA.AST Data.Array.Accelerate.CUDA.Analysis.Device Data.Array.Accelerate.CUDA.Analysis.Launch+ Data.Array.Accelerate.CUDA.Analysis.Shape+ Data.Array.Accelerate.CUDA.Array.Remote Data.Array.Accelerate.CUDA.Array.Data- Data.Array.Accelerate.CUDA.Array.Nursery Data.Array.Accelerate.CUDA.Array.Prim+ Data.Array.Accelerate.CUDA.Array.Slice Data.Array.Accelerate.CUDA.Array.Sugar- Data.Array.Accelerate.CUDA.Array.Table- Data.Array.Accelerate.CUDA.Async Data.Array.Accelerate.CUDA.CodeGen+ Data.Array.Accelerate.CUDA.CodeGen.Arithmetic Data.Array.Accelerate.CUDA.CodeGen.Base+ Data.Array.Accelerate.CUDA.CodeGen.Constant Data.Array.Accelerate.CUDA.CodeGen.IndexSpace Data.Array.Accelerate.CUDA.CodeGen.Mapping Data.Array.Accelerate.CUDA.CodeGen.Monad@@ -146,6 +140,7 @@ Data.Array.Accelerate.CUDA.CodeGen.Reduction Data.Array.Accelerate.CUDA.CodeGen.Stencil Data.Array.Accelerate.CUDA.CodeGen.Stencil.Extra+ Data.Array.Accelerate.CUDA.CodeGen.Streaming Data.Array.Accelerate.CUDA.CodeGen.Type Data.Array.Accelerate.CUDA.Compile Data.Array.Accelerate.CUDA.Context@@ -155,10 +150,8 @@ Data.Array.Accelerate.CUDA.Execute.Stream Data.Array.Accelerate.CUDA.Foreign.Export Data.Array.Accelerate.CUDA.Foreign.Import- Data.Array.Accelerate.CUDA.FullList Data.Array.Accelerate.CUDA.Persistent Data.Array.Accelerate.CUDA.State- Data.Array.Accelerate.Internal.Check Paths_accelerate_cuda if flag(debug)@@ -188,4 +181,11 @@ source-repository head type: git location: https://github.com/AccelerateHS/accelerate-cuda++source-repository this+ type: git+ tag: 0.17.0.0+ location: https://github.com/AccelerateHS/accelerate-cuda++-- vim: nospell
− configure
@@ -1,3568 +0,0 @@-#! /bin/sh-# Guess values for system-dependent variables and create Makefiles.-# Generated by GNU Autoconf 2.69 for accelerate-cuda 0.14.0.0.-#-# Report bugs to <accelerate-haskell@googlegroups.com>.-#-#-# Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc.-#-#-# This configure script is free software; the Free Software Foundation-# gives unlimited permission to copy, distribute and modify it.-## -------------------- ##-## M4sh Initialization. ##-## -------------------- ##--# Be more Bourne compatible-DUALCASE=1; export DUALCASE # for MKS sh-if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then :- emulate sh- NULLCMD=:- # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which- # is contrary to our usage. Disable this feature.- alias -g '${1+"$@"}'='"$@"'- setopt NO_GLOB_SUBST-else- case `(set -o) 2>/dev/null` in #(- *posix*) :- set -o posix ;; #(- *) :- ;;-esac-fi---as_nl='-'-export as_nl-# Printing a long string crashes Solaris 7 /usr/bin/printf.-as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\'-as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo-as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo-# Prefer a ksh shell builtin over an external printf program on Solaris,-# but without wasting forks for bash or zsh.-if test -z "$BASH_VERSION$ZSH_VERSION" \- && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then- as_echo='print -r --'- as_echo_n='print -rn --'-elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then- as_echo='printf %s\n'- as_echo_n='printf %s'-else- if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then- as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"'- as_echo_n='/usr/ucb/echo -n'- else- as_echo_body='eval expr "X$1" : "X\\(.*\\)"'- as_echo_n_body='eval- arg=$1;- case $arg in #(- *"$as_nl"*)- expr "X$arg" : "X\\(.*\\)$as_nl";- arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;;- esac;- expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl"- '- export as_echo_n_body- as_echo_n='sh -c $as_echo_n_body as_echo'- fi- export as_echo_body- as_echo='sh -c $as_echo_body as_echo'-fi--# The user is always right.-if test "${PATH_SEPARATOR+set}" != set; then- PATH_SEPARATOR=:- (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && {- (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 ||- PATH_SEPARATOR=';'- }-fi---# IFS-# We need space, tab and new line, in precisely that order. Quoting is-# there to prevent editors from complaining about space-tab.-# (If _AS_PATH_WALK were called with IFS unset, it would disable word-# splitting by setting IFS to empty value.)-IFS=" "" $as_nl"--# Find who we are. Look in the path if we contain no directory separator.-as_myself=-case $0 in #((- *[\\/]* ) as_myself=$0 ;;- *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR-for as_dir in $PATH-do- IFS=$as_save_IFS- test -z "$as_dir" && as_dir=.- test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break- done-IFS=$as_save_IFS-- ;;-esac-# We did not find ourselves, most probably we were run as `sh COMMAND'-# in which case we are not to be found in the path.-if test "x$as_myself" = x; then- as_myself=$0-fi-if test ! -f "$as_myself"; then- $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2- exit 1-fi--# Unset variables that we do not need and which cause bugs (e.g. in-# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1"-# suppresses any "Segmentation fault" message there. '((' could-# trigger a bug in pdksh 5.2.14.-for as_var in BASH_ENV ENV MAIL MAILPATH-do eval test x\${$as_var+set} = xset \- && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || :-done-PS1='$ '-PS2='> '-PS4='+ '--# NLS nuisances.-LC_ALL=C-export LC_ALL-LANGUAGE=C-export LANGUAGE--# CDPATH.-(unset CDPATH) >/dev/null 2>&1 && unset CDPATH--# Use a proper internal environment variable to ensure we don't fall- # into an infinite loop, continuously re-executing ourselves.- if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then- _as_can_reexec=no; export _as_can_reexec;- # We cannot yet assume a decent shell, so we have to provide a-# neutralization value for shells without unset; and this also-# works around shells that cannot unset nonexistent variables.-# Preserve -v and -x to the replacement shell.-BASH_ENV=/dev/null-ENV=/dev/null-(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV-case $- in # ((((- *v*x* | *x*v* ) as_opts=-vx ;;- *v* ) as_opts=-v ;;- *x* ) as_opts=-x ;;- * ) as_opts= ;;-esac-exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"}-# Admittedly, this is quite paranoid, since all the known shells bail-# out after a failed `exec'.-$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2-as_fn_exit 255- fi- # We don't want this to propagate to other subprocesses.- { _as_can_reexec=; unset _as_can_reexec;}-if test "x$CONFIG_SHELL" = x; then- as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then :- emulate sh- NULLCMD=:- # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which- # is contrary to our usage. Disable this feature.- alias -g '\${1+\"\$@\"}'='\"\$@\"'- setopt NO_GLOB_SUBST-else- case \`(set -o) 2>/dev/null\` in #(- *posix*) :- set -o posix ;; #(- *) :- ;;-esac-fi-"- as_required="as_fn_return () { (exit \$1); }-as_fn_success () { as_fn_return 0; }-as_fn_failure () { as_fn_return 1; }-as_fn_ret_success () { return 0; }-as_fn_ret_failure () { return 1; }--exitcode=0-as_fn_success || { exitcode=1; echo as_fn_success failed.; }-as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; }-as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; }-as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; }-if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then :--else- exitcode=1; echo positional parameters were not saved.-fi-test x\$exitcode = x0 || exit 1-test -x / || exit 1"- as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO- as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO- eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" &&- test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1"- if (eval "$as_required") 2>/dev/null; then :- as_have_required=yes-else- as_have_required=no-fi- if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then :--else- as_save_IFS=$IFS; IFS=$PATH_SEPARATOR-as_found=false-for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH-do- IFS=$as_save_IFS- test -z "$as_dir" && as_dir=.- as_found=:- case $as_dir in #(- /*)- for as_base in sh bash ksh sh5; do- # Try only shells that exist, to save several forks.- as_shell=$as_dir/$as_base- if { test -f "$as_shell" || test -f "$as_shell.exe"; } &&- { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then :- CONFIG_SHELL=$as_shell as_have_required=yes- if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then :- break 2-fi-fi- done;;- esac- as_found=false-done-$as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } &&- { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then :- CONFIG_SHELL=$SHELL as_have_required=yes-fi; }-IFS=$as_save_IFS--- if test "x$CONFIG_SHELL" != x; then :- export CONFIG_SHELL- # We cannot yet assume a decent shell, so we have to provide a-# neutralization value for shells without unset; and this also-# works around shells that cannot unset nonexistent variables.-# Preserve -v and -x to the replacement shell.-BASH_ENV=/dev/null-ENV=/dev/null-(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV-case $- in # ((((- *v*x* | *x*v* ) as_opts=-vx ;;- *v* ) as_opts=-v ;;- *x* ) as_opts=-x ;;- * ) as_opts= ;;-esac-exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"}-# Admittedly, this is quite paranoid, since all the known shells bail-# out after a failed `exec'.-$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2-exit 255-fi-- if test x$as_have_required = xno; then :- $as_echo "$0: This script requires a shell more modern than all"- $as_echo "$0: the shells that I found on your system."- if test x${ZSH_VERSION+set} = xset ; then- $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should"- $as_echo "$0: be upgraded to zsh 4.3.4 or later."- else- $as_echo "$0: Please tell bug-autoconf@gnu.org and-$0: accelerate-haskell@googlegroups.com about your system,-$0: including any error possibly output before this-$0: message. Then install a modern shell, or manually run-$0: the script under such a shell if you do have one."- fi- exit 1-fi-fi-fi-SHELL=${CONFIG_SHELL-/bin/sh}-export SHELL-# Unset more variables known to interfere with behavior of common tools.-CLICOLOR_FORCE= GREP_OPTIONS=-unset CLICOLOR_FORCE GREP_OPTIONS--## --------------------- ##-## M4sh Shell Functions. ##-## --------------------- ##-# as_fn_unset VAR-# ----------------# Portably unset VAR.-as_fn_unset ()-{- { eval $1=; unset $1;}-}-as_unset=as_fn_unset--# as_fn_set_status STATUS-# ------------------------# Set $? to STATUS, without forking.-as_fn_set_status ()-{- return $1-} # as_fn_set_status--# as_fn_exit STATUS-# ------------------# Exit the shell with STATUS, even in a "trap 0" or "set -e" context.-as_fn_exit ()-{- set +e- as_fn_set_status $1- exit $1-} # as_fn_exit--# as_fn_mkdir_p-# --------------# Create "$as_dir" as a directory, including parents if necessary.-as_fn_mkdir_p ()-{-- case $as_dir in #(- -*) as_dir=./$as_dir;;- esac- test -d "$as_dir" || eval $as_mkdir_p || {- as_dirs=- while :; do- case $as_dir in #(- *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'(- *) as_qdir=$as_dir;;- esac- as_dirs="'$as_qdir' $as_dirs"- as_dir=`$as_dirname -- "$as_dir" ||-$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \- X"$as_dir" : 'X\(//\)[^/]' \| \- X"$as_dir" : 'X\(//\)$' \| \- X"$as_dir" : 'X\(/\)' \| . 2>/dev/null ||-$as_echo X"$as_dir" |- sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{- s//\1/- q- }- /^X\(\/\/\)[^/].*/{- s//\1/- q- }- /^X\(\/\/\)$/{- s//\1/- q- }- /^X\(\/\).*/{- s//\1/- q- }- s/.*/./; q'`- test -d "$as_dir" && break- done- test -z "$as_dirs" || eval "mkdir $as_dirs"- } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir"---} # as_fn_mkdir_p--# as_fn_executable_p FILE-# ------------------------# Test if FILE is an executable regular file.-as_fn_executable_p ()-{- test -f "$1" && test -x "$1"-} # as_fn_executable_p-# as_fn_append VAR VALUE-# -----------------------# Append the text in VALUE to the end of the definition contained in VAR. Take-# advantage of any shell optimizations that allow amortized linear growth over-# repeated appends, instead of the typical quadratic growth present in naive-# implementations.-if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then :- eval 'as_fn_append ()- {- eval $1+=\$2- }'-else- as_fn_append ()- {- eval $1=\$$1\$2- }-fi # as_fn_append--# as_fn_arith ARG...-# -------------------# Perform arithmetic evaluation on the ARGs, and store the result in the-# global $as_val. Take advantage of shells that can avoid forks. The arguments-# must be portable across $(()) and expr.-if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then :- eval 'as_fn_arith ()- {- as_val=$(( $* ))- }'-else- as_fn_arith ()- {- as_val=`expr "$@" || test $? -eq 1`- }-fi # as_fn_arith---# as_fn_error STATUS ERROR [LINENO LOG_FD]-# -----------------------------------------# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are-# provided, also output the error to LOG_FD, referencing LINENO. Then exit the-# script with STATUS, using 1 if that was 0.-as_fn_error ()-{- as_status=$1; test $as_status -eq 0 && as_status=1- if test "$4"; then- as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack- $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4- fi- $as_echo "$as_me: error: $2" >&2- as_fn_exit $as_status-} # as_fn_error--if expr a : '\(a\)' >/dev/null 2>&1 &&- test "X`expr 00001 : '.*\(...\)'`" = X001; then- as_expr=expr-else- as_expr=false-fi--if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then- as_basename=basename-else- as_basename=false-fi--if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then- as_dirname=dirname-else- as_dirname=false-fi--as_me=`$as_basename -- "$0" ||-$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \- X"$0" : 'X\(//\)$' \| \- X"$0" : 'X\(/\)' \| . 2>/dev/null ||-$as_echo X/"$0" |- sed '/^.*\/\([^/][^/]*\)\/*$/{- s//\1/- q- }- /^X\/\(\/\/\)$/{- s//\1/- q- }- /^X\/\(\/\).*/{- s//\1/- q- }- s/.*/./; q'`--# Avoid depending upon Character Ranges.-as_cr_letters='abcdefghijklmnopqrstuvwxyz'-as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'-as_cr_Letters=$as_cr_letters$as_cr_LETTERS-as_cr_digits='0123456789'-as_cr_alnum=$as_cr_Letters$as_cr_digits--- as_lineno_1=$LINENO as_lineno_1a=$LINENO- as_lineno_2=$LINENO as_lineno_2a=$LINENO- eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" &&- test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || {- # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-)- sed -n '- p- /[$]LINENO/=- ' <$as_myself |- sed '- s/[$]LINENO.*/&-/- t lineno- b- :lineno- N- :loop- s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/- t loop- s/-\n.*//- ' >$as_me.lineno &&- chmod +x "$as_me.lineno" ||- { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; }-- # If we had to re-execute with $CONFIG_SHELL, we're ensured to have- # already done that, so ensure we don't try to do so again and fall- # in an infinite loop. This has already happened in practice.- _as_can_reexec=no; export _as_can_reexec- # Don't try to exec as it changes $[0], causing all sort of problems- # (the dirname of $[0] is not the place where we might find the- # original and so on. Autoconf is especially sensitive to this).- . "./$as_me.lineno"- # Exit status is that of the last command.- exit-}--ECHO_C= ECHO_N= ECHO_T=-case `echo -n x` in #(((((--n*)- case `echo 'xy\c'` in- *c*) ECHO_T=' ';; # ECHO_T is single tab character.- xy) ECHO_C='\c';;- *) echo `echo ksh88 bug on AIX 6.1` > /dev/null- ECHO_T=' ';;- esac;;-*)- ECHO_N='-n';;-esac--rm -f conf$$ conf$$.exe conf$$.file-if test -d conf$$.dir; then- rm -f conf$$.dir/conf$$.file-else- rm -f conf$$.dir- mkdir conf$$.dir 2>/dev/null-fi-if (echo >conf$$.file) 2>/dev/null; then- if ln -s conf$$.file conf$$ 2>/dev/null; then- as_ln_s='ln -s'- # ... but there are two gotchas:- # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail.- # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable.- # In both cases, we have to default to `cp -pR'.- ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||- as_ln_s='cp -pR'- elif ln conf$$.file conf$$ 2>/dev/null; then- as_ln_s=ln- else- as_ln_s='cp -pR'- fi-else- as_ln_s='cp -pR'-fi-rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file-rmdir conf$$.dir 2>/dev/null--if mkdir -p . 2>/dev/null; then- as_mkdir_p='mkdir -p "$as_dir"'-else- test -d ./-p && rmdir ./-p- as_mkdir_p=false-fi--as_test_x='test -x'-as_executable_p=as_fn_executable_p--# Sed expression to map a string onto a valid CPP name.-as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"--# Sed expression to map a string onto a valid variable name.-as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"---test -n "$DJDIR" || exec 7<&0 </dev/null-exec 6>&1--# Name of the host.-# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status,-# so uname gets run too.-ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q`--#-# Initializations.-#-ac_default_prefix=/usr/local-ac_clean_files=-ac_config_libobj_dir=.-LIBOBJS=-cross_compiling=no-subdirs=-MFLAGS=-MAKEFLAGS=--# Identity of this package.-PACKAGE_NAME='accelerate-cuda'-PACKAGE_TARNAME='accelerate-cuda'-PACKAGE_VERSION='0.14.0.0'-PACKAGE_STRING='accelerate-cuda 0.14.0.0'-PACKAGE_BUGREPORT='accelerate-haskell@googlegroups.com'-PACKAGE_URL=''--ac_unique_file="Data/Array/Accelerate/CUDA.hs"-ac_subst_vars='LTLIBOBJS-LIBOBJS-cpp_flags-ghc_flags-OBJEXT-EXEEXT-ac_ct_CXX-CPPFLAGS-LDFLAGS-CXXFLAGS-CXX-GHC-target_alias-host_alias-build_alias-LIBS-ECHO_T-ECHO_N-ECHO_C-DEFS-mandir-localedir-libdir-psdir-pdfdir-dvidir-htmldir-infodir-docdir-oldincludedir-includedir-localstatedir-sharedstatedir-sysconfdir-datadir-datarootdir-libexecdir-sbindir-bindir-program_transform_name-prefix-exec_prefix-PACKAGE_URL-PACKAGE_BUGREPORT-PACKAGE_STRING-PACKAGE_VERSION-PACKAGE_TARNAME-PACKAGE_NAME-PATH_SEPARATOR-SHELL'-ac_subst_files=''-ac_user_opts='-enable_option_checking-with_compiler-with_nvcc-with_gcc-'- ac_precious_vars='build_alias-host_alias-target_alias-CXX-CXXFLAGS-LDFLAGS-LIBS-CPPFLAGS-CCC'---# Initialize some variables set by options.-ac_init_help=-ac_init_version=false-ac_unrecognized_opts=-ac_unrecognized_sep=-# The variables have the same names as the options, with-# dashes changed to underlines.-cache_file=/dev/null-exec_prefix=NONE-no_create=-no_recursion=-prefix=NONE-program_prefix=NONE-program_suffix=NONE-program_transform_name=s,x,x,-silent=-site=-srcdir=-verbose=-x_includes=NONE-x_libraries=NONE--# Installation directory options.-# These are left unexpanded so users can "make install exec_prefix=/foo"-# and all the variables that are supposed to be based on exec_prefix-# by default will actually change.-# Use braces instead of parens because sh, perl, etc. also accept them.-# (The list follows the same order as the GNU Coding Standards.)-bindir='${exec_prefix}/bin'-sbindir='${exec_prefix}/sbin'-libexecdir='${exec_prefix}/libexec'-datarootdir='${prefix}/share'-datadir='${datarootdir}'-sysconfdir='${prefix}/etc'-sharedstatedir='${prefix}/com'-localstatedir='${prefix}/var'-includedir='${prefix}/include'-oldincludedir='/usr/include'-docdir='${datarootdir}/doc/${PACKAGE_TARNAME}'-infodir='${datarootdir}/info'-htmldir='${docdir}'-dvidir='${docdir}'-pdfdir='${docdir}'-psdir='${docdir}'-libdir='${exec_prefix}/lib'-localedir='${datarootdir}/locale'-mandir='${datarootdir}/man'--ac_prev=-ac_dashdash=-for ac_option-do- # If the previous option needs an argument, assign it.- if test -n "$ac_prev"; then- eval $ac_prev=\$ac_option- ac_prev=- continue- fi-- case $ac_option in- *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;;- *=) ac_optarg= ;;- *) ac_optarg=yes ;;- esac-- # Accept the important Cygnus configure options, so we can diagnose typos.-- case $ac_dashdash$ac_option in- --)- ac_dashdash=yes ;;-- -bindir | --bindir | --bindi | --bind | --bin | --bi)- ac_prev=bindir ;;- -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*)- bindir=$ac_optarg ;;-- -build | --build | --buil | --bui | --bu)- ac_prev=build_alias ;;- -build=* | --build=* | --buil=* | --bui=* | --bu=*)- build_alias=$ac_optarg ;;-- -cache-file | --cache-file | --cache-fil | --cache-fi \- | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c)- ac_prev=cache_file ;;- -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \- | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*)- cache_file=$ac_optarg ;;-- --config-cache | -C)- cache_file=config.cache ;;-- -datadir | --datadir | --datadi | --datad)- ac_prev=datadir ;;- -datadir=* | --datadir=* | --datadi=* | --datad=*)- datadir=$ac_optarg ;;-- -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \- | --dataroo | --dataro | --datar)- ac_prev=datarootdir ;;- -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \- | --dataroot=* | --dataroo=* | --dataro=* | --datar=*)- datarootdir=$ac_optarg ;;-- -disable-* | --disable-*)- ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'`- # Reject names that are not valid shell variable names.- expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&- as_fn_error $? "invalid feature name: $ac_useropt"- ac_useropt_orig=$ac_useropt- ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'`- case $ac_user_opts in- *"-"enable_$ac_useropt"-"*) ;;- *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig"- ac_unrecognized_sep=', ';;- esac- eval enable_$ac_useropt=no ;;-- -docdir | --docdir | --docdi | --doc | --do)- ac_prev=docdir ;;- -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*)- docdir=$ac_optarg ;;-- -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv)- ac_prev=dvidir ;;- -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*)- dvidir=$ac_optarg ;;-- -enable-* | --enable-*)- ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'`- # Reject names that are not valid shell variable names.- expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&- as_fn_error $? "invalid feature name: $ac_useropt"- ac_useropt_orig=$ac_useropt- ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'`- case $ac_user_opts in- *"-"enable_$ac_useropt"-"*) ;;- *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig"- ac_unrecognized_sep=', ';;- esac- eval enable_$ac_useropt=\$ac_optarg ;;-- -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \- | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \- | --exec | --exe | --ex)- ac_prev=exec_prefix ;;- -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \- | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \- | --exec=* | --exe=* | --ex=*)- exec_prefix=$ac_optarg ;;-- -gas | --gas | --ga | --g)- # Obsolete; use --with-gas.- with_gas=yes ;;-- -help | --help | --hel | --he | -h)- ac_init_help=long ;;- -help=r* | --help=r* | --hel=r* | --he=r* | -hr*)- ac_init_help=recursive ;;- -help=s* | --help=s* | --hel=s* | --he=s* | -hs*)- ac_init_help=short ;;-- -host | --host | --hos | --ho)- ac_prev=host_alias ;;- -host=* | --host=* | --hos=* | --ho=*)- host_alias=$ac_optarg ;;-- -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht)- ac_prev=htmldir ;;- -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \- | --ht=*)- htmldir=$ac_optarg ;;-- -includedir | --includedir | --includedi | --included | --include \- | --includ | --inclu | --incl | --inc)- ac_prev=includedir ;;- -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \- | --includ=* | --inclu=* | --incl=* | --inc=*)- includedir=$ac_optarg ;;-- -infodir | --infodir | --infodi | --infod | --info | --inf)- ac_prev=infodir ;;- -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*)- infodir=$ac_optarg ;;-- -libdir | --libdir | --libdi | --libd)- ac_prev=libdir ;;- -libdir=* | --libdir=* | --libdi=* | --libd=*)- libdir=$ac_optarg ;;-- -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \- | --libexe | --libex | --libe)- ac_prev=libexecdir ;;- -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \- | --libexe=* | --libex=* | --libe=*)- libexecdir=$ac_optarg ;;-- -localedir | --localedir | --localedi | --localed | --locale)- ac_prev=localedir ;;- -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*)- localedir=$ac_optarg ;;-- -localstatedir | --localstatedir | --localstatedi | --localstated \- | --localstate | --localstat | --localsta | --localst | --locals)- ac_prev=localstatedir ;;- -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \- | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*)- localstatedir=$ac_optarg ;;-- -mandir | --mandir | --mandi | --mand | --man | --ma | --m)- ac_prev=mandir ;;- -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*)- mandir=$ac_optarg ;;-- -nfp | --nfp | --nf)- # Obsolete; use --without-fp.- with_fp=no ;;-- -no-create | --no-create | --no-creat | --no-crea | --no-cre \- | --no-cr | --no-c | -n)- no_create=yes ;;-- -no-recursion | --no-recursion | --no-recursio | --no-recursi \- | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r)- no_recursion=yes ;;-- -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \- | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \- | --oldin | --oldi | --old | --ol | --o)- ac_prev=oldincludedir ;;- -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \- | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \- | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*)- oldincludedir=$ac_optarg ;;-- -prefix | --prefix | --prefi | --pref | --pre | --pr | --p)- ac_prev=prefix ;;- -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*)- prefix=$ac_optarg ;;-- -program-prefix | --program-prefix | --program-prefi | --program-pref \- | --program-pre | --program-pr | --program-p)- ac_prev=program_prefix ;;- -program-prefix=* | --program-prefix=* | --program-prefi=* \- | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*)- program_prefix=$ac_optarg ;;-- -program-suffix | --program-suffix | --program-suffi | --program-suff \- | --program-suf | --program-su | --program-s)- ac_prev=program_suffix ;;- -program-suffix=* | --program-suffix=* | --program-suffi=* \- | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*)- program_suffix=$ac_optarg ;;-- -program-transform-name | --program-transform-name \- | --program-transform-nam | --program-transform-na \- | --program-transform-n | --program-transform- \- | --program-transform | --program-transfor \- | --program-transfo | --program-transf \- | --program-trans | --program-tran \- | --progr-tra | --program-tr | --program-t)- ac_prev=program_transform_name ;;- -program-transform-name=* | --program-transform-name=* \- | --program-transform-nam=* | --program-transform-na=* \- | --program-transform-n=* | --program-transform-=* \- | --program-transform=* | --program-transfor=* \- | --program-transfo=* | --program-transf=* \- | --program-trans=* | --program-tran=* \- | --progr-tra=* | --program-tr=* | --program-t=*)- program_transform_name=$ac_optarg ;;-- -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd)- ac_prev=pdfdir ;;- -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*)- pdfdir=$ac_optarg ;;-- -psdir | --psdir | --psdi | --psd | --ps)- ac_prev=psdir ;;- -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*)- psdir=$ac_optarg ;;-- -q | -quiet | --quiet | --quie | --qui | --qu | --q \- | -silent | --silent | --silen | --sile | --sil)- silent=yes ;;-- -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)- ac_prev=sbindir ;;- -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \- | --sbi=* | --sb=*)- sbindir=$ac_optarg ;;-- -sharedstatedir | --sharedstatedir | --sharedstatedi \- | --sharedstated | --sharedstate | --sharedstat | --sharedsta \- | --sharedst | --shareds | --shared | --share | --shar \- | --sha | --sh)- ac_prev=sharedstatedir ;;- -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \- | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \- | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \- | --sha=* | --sh=*)- sharedstatedir=$ac_optarg ;;-- -site | --site | --sit)- ac_prev=site ;;- -site=* | --site=* | --sit=*)- site=$ac_optarg ;;-- -srcdir | --srcdir | --srcdi | --srcd | --src | --sr)- ac_prev=srcdir ;;- -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*)- srcdir=$ac_optarg ;;-- -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \- | --syscon | --sysco | --sysc | --sys | --sy)- ac_prev=sysconfdir ;;- -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \- | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*)- sysconfdir=$ac_optarg ;;-- -target | --target | --targe | --targ | --tar | --ta | --t)- ac_prev=target_alias ;;- -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*)- target_alias=$ac_optarg ;;-- -v | -verbose | --verbose | --verbos | --verbo | --verb)- verbose=yes ;;-- -version | --version | --versio | --versi | --vers | -V)- ac_init_version=: ;;-- -with-* | --with-*)- ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'`- # Reject names that are not valid shell variable names.- expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&- as_fn_error $? "invalid package name: $ac_useropt"- ac_useropt_orig=$ac_useropt- ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'`- case $ac_user_opts in- *"-"with_$ac_useropt"-"*) ;;- *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig"- ac_unrecognized_sep=', ';;- esac- eval with_$ac_useropt=\$ac_optarg ;;-- -without-* | --without-*)- ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'`- # Reject names that are not valid shell variable names.- expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&- as_fn_error $? "invalid package name: $ac_useropt"- ac_useropt_orig=$ac_useropt- ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'`- case $ac_user_opts in- *"-"with_$ac_useropt"-"*) ;;- *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig"- ac_unrecognized_sep=', ';;- esac- eval with_$ac_useropt=no ;;-- --x)- # Obsolete; use --with-x.- with_x=yes ;;-- -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \- | --x-incl | --x-inc | --x-in | --x-i)- ac_prev=x_includes ;;- -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \- | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*)- x_includes=$ac_optarg ;;-- -x-libraries | --x-libraries | --x-librarie | --x-librari \- | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l)- ac_prev=x_libraries ;;- -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \- | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*)- x_libraries=$ac_optarg ;;-- -*) as_fn_error $? "unrecognized option: \`$ac_option'-Try \`$0 --help' for more information"- ;;-- *=*)- ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='`- # Reject names that are not valid shell variable names.- case $ac_envvar in #(- '' | [0-9]* | *[!_$as_cr_alnum]* )- as_fn_error $? "invalid variable name: \`$ac_envvar'" ;;- esac- eval $ac_envvar=\$ac_optarg- export $ac_envvar ;;-- *)- # FIXME: should be removed in autoconf 3.0.- $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2- expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null &&- $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2- : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}"- ;;-- esac-done--if test -n "$ac_prev"; then- ac_option=--`echo $ac_prev | sed 's/_/-/g'`- as_fn_error $? "missing argument to $ac_option"-fi--if test -n "$ac_unrecognized_opts"; then- case $enable_option_checking in- no) ;;- fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;;- *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;;- esac-fi--# Check all directory arguments for consistency.-for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \- datadir sysconfdir sharedstatedir localstatedir includedir \- oldincludedir docdir infodir htmldir dvidir pdfdir psdir \- libdir localedir mandir-do- eval ac_val=\$$ac_var- # Remove trailing slashes.- case $ac_val in- */ )- ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'`- eval $ac_var=\$ac_val;;- esac- # Be sure to have absolute directory names.- case $ac_val in- [\\/$]* | ?:[\\/]* ) continue;;- NONE | '' ) case $ac_var in *prefix ) continue;; esac;;- esac- as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val"-done--# There might be people who depend on the old broken behavior: `$host'-# used to hold the argument of --host etc.-# FIXME: To remove some day.-build=$build_alias-host=$host_alias-target=$target_alias--# FIXME: To remove some day.-if test "x$host_alias" != x; then- if test "x$build_alias" = x; then- cross_compiling=maybe- elif test "x$build_alias" != "x$host_alias"; then- cross_compiling=yes- fi-fi--ac_tool_prefix=-test -n "$host_alias" && ac_tool_prefix=$host_alias---test "$silent" = yes && exec 6>/dev/null---ac_pwd=`pwd` && test -n "$ac_pwd" &&-ac_ls_di=`ls -di .` &&-ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` ||- as_fn_error $? "working directory cannot be determined"-test "X$ac_ls_di" = "X$ac_pwd_ls_di" ||- as_fn_error $? "pwd does not report name of working directory"---# Find the source files, if location was not specified.-if test -z "$srcdir"; then- ac_srcdir_defaulted=yes- # Try the directory containing this script, then the parent directory.- ac_confdir=`$as_dirname -- "$as_myself" ||-$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \- X"$as_myself" : 'X\(//\)[^/]' \| \- X"$as_myself" : 'X\(//\)$' \| \- X"$as_myself" : 'X\(/\)' \| . 2>/dev/null ||-$as_echo X"$as_myself" |- sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{- s//\1/- q- }- /^X\(\/\/\)[^/].*/{- s//\1/- q- }- /^X\(\/\/\)$/{- s//\1/- q- }- /^X\(\/\).*/{- s//\1/- q- }- s/.*/./; q'`- srcdir=$ac_confdir- if test ! -r "$srcdir/$ac_unique_file"; then- srcdir=..- fi-else- ac_srcdir_defaulted=no-fi-if test ! -r "$srcdir/$ac_unique_file"; then- test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .."- as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir"-fi-ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work"-ac_abs_confdir=`(- cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg"- pwd)`-# When building in place, set srcdir=.-if test "$ac_abs_confdir" = "$ac_pwd"; then- srcdir=.-fi-# Remove unnecessary trailing slashes from srcdir.-# Double slashes in file names in object file debugging info-# mess up M-x gdb in Emacs.-case $srcdir in-*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;;-esac-for ac_var in $ac_precious_vars; do- eval ac_env_${ac_var}_set=\${${ac_var}+set}- eval ac_env_${ac_var}_value=\$${ac_var}- eval ac_cv_env_${ac_var}_set=\${${ac_var}+set}- eval ac_cv_env_${ac_var}_value=\$${ac_var}-done--#-# Report the --help message.-#-if test "$ac_init_help" = "long"; then- # Omit some internal or obsolete options to make the list less imposing.- # This message is too long to be a string in the A/UX 3.1 sh.- cat <<_ACEOF-\`configure' configures accelerate-cuda 0.14.0.0 to adapt to many kinds of systems.--Usage: $0 [OPTION]... [VAR=VALUE]...--To assign environment variables (e.g., CC, CFLAGS...), specify them as-VAR=VALUE. See below for descriptions of some of the useful variables.--Defaults for the options are specified in brackets.--Configuration:- -h, --help display this help and exit- --help=short display options specific to this package- --help=recursive display the short help of all the included packages- -V, --version display version information and exit- -q, --quiet, --silent do not print \`checking ...' messages- --cache-file=FILE cache test results in FILE [disabled]- -C, --config-cache alias for \`--cache-file=config.cache'- -n, --no-create do not create output files- --srcdir=DIR find the sources in DIR [configure dir or \`..']--Installation directories:- --prefix=PREFIX install architecture-independent files in PREFIX- [$ac_default_prefix]- --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX- [PREFIX]--By default, \`make install' will install all the files in-\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify-an installation prefix other than \`$ac_default_prefix' using \`--prefix',-for instance \`--prefix=\$HOME'.--For better control, use the options below.--Fine tuning of the installation directories:- --bindir=DIR user executables [EPREFIX/bin]- --sbindir=DIR system admin executables [EPREFIX/sbin]- --libexecdir=DIR program executables [EPREFIX/libexec]- --sysconfdir=DIR read-only single-machine data [PREFIX/etc]- --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com]- --localstatedir=DIR modifiable single-machine data [PREFIX/var]- --libdir=DIR object code libraries [EPREFIX/lib]- --includedir=DIR C header files [PREFIX/include]- --oldincludedir=DIR C header files for non-gcc [/usr/include]- --datarootdir=DIR read-only arch.-independent data root [PREFIX/share]- --datadir=DIR read-only architecture-independent data [DATAROOTDIR]- --infodir=DIR info documentation [DATAROOTDIR/info]- --localedir=DIR locale-dependent data [DATAROOTDIR/locale]- --mandir=DIR man documentation [DATAROOTDIR/man]- --docdir=DIR documentation root [DATAROOTDIR/doc/accelerate-cuda]- --htmldir=DIR html documentation [DOCDIR]- --dvidir=DIR dvi documentation [DOCDIR]- --pdfdir=DIR pdf documentation [DOCDIR]- --psdir=DIR ps documentation [DOCDIR]-_ACEOF-- cat <<\_ACEOF-_ACEOF-fi--if test -n "$ac_init_help"; then- case $ac_init_help in- short | recursive ) echo "Configuration of accelerate-cuda 0.14.0.0:";;- esac- cat <<\_ACEOF--Optional Packages:- --with-PACKAGE[=ARG] use PACKAGE [ARG=yes]- --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no)-Haskell compiler-CUDA compiler-C compiler--Some influential environment variables:- CXX C++ compiler command- CXXFLAGS C++ compiler flags- LDFLAGS linker flags, e.g. -L<lib dir> if you have libraries in a- nonstandard directory <lib dir>- LIBS libraries to pass to the linker, e.g. -l<library>- CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I<include dir> if- you have headers in a nonstandard directory <include dir>--Use these variables to override the choices made by `configure' or to help-it to find libraries and programs with nonstandard names/locations.--Report bugs to <accelerate-haskell@googlegroups.com>.-_ACEOF-ac_status=$?-fi--if test "$ac_init_help" = "recursive"; then- # If there are subdirs, report their specific --help.- for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue- test -d "$ac_dir" ||- { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } ||- continue- ac_builddir=.--case "$ac_dir" in-.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;-*)- ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'`- # A ".." for each directory in $ac_dir_suffix.- ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'`- case $ac_top_builddir_sub in- "") ac_top_builddir_sub=. ac_top_build_prefix= ;;- *) ac_top_build_prefix=$ac_top_builddir_sub/ ;;- esac ;;-esac-ac_abs_top_builddir=$ac_pwd-ac_abs_builddir=$ac_pwd$ac_dir_suffix-# for backward compatibility:-ac_top_builddir=$ac_top_build_prefix--case $srcdir in- .) # We are building in place.- ac_srcdir=.- ac_top_srcdir=$ac_top_builddir_sub- ac_abs_top_srcdir=$ac_pwd ;;- [\\/]* | ?:[\\/]* ) # Absolute name.- ac_srcdir=$srcdir$ac_dir_suffix;- ac_top_srcdir=$srcdir- ac_abs_top_srcdir=$srcdir ;;- *) # Relative name.- ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix- ac_top_srcdir=$ac_top_build_prefix$srcdir- ac_abs_top_srcdir=$ac_pwd/$srcdir ;;-esac-ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix-- cd "$ac_dir" || { ac_status=$?; continue; }- # Check for guested configure.- if test -f "$ac_srcdir/configure.gnu"; then- echo &&- $SHELL "$ac_srcdir/configure.gnu" --help=recursive- elif test -f "$ac_srcdir/configure"; then- echo &&- $SHELL "$ac_srcdir/configure" --help=recursive- else- $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2- fi || ac_status=$?- cd "$ac_pwd" || { ac_status=$?; break; }- done-fi--test -n "$ac_init_help" && exit $ac_status-if $ac_init_version; then- cat <<\_ACEOF-accelerate-cuda configure 0.14.0.0-generated by GNU Autoconf 2.69--Copyright (C) 2012 Free Software Foundation, Inc.-This configure script is free software; the Free Software Foundation-gives unlimited permission to copy, distribute and modify it.-_ACEOF- exit-fi--## ------------------------ ##-## Autoconf initialization. ##-## ------------------------ ##--# ac_fn_cxx_try_compile LINENO-# -----------------------------# Try to compile conftest.$ac_ext, and return whether this succeeded.-ac_fn_cxx_try_compile ()-{- as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack- rm -f conftest.$ac_objext- if { { ac_try="$ac_compile"-case "(($ac_try" in- *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;- *) ac_try_echo=$ac_try;;-esac-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""-$as_echo "$ac_try_echo"; } >&5- (eval "$ac_compile") 2>conftest.err- ac_status=$?- if test -s conftest.err; then- grep -v '^ *+' conftest.err >conftest.er1- cat conftest.er1 >&5- mv -f conftest.er1 conftest.err- fi- $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5- test $ac_status = 0; } && {- test -z "$ac_cxx_werror_flag" ||- test ! -s conftest.err- } && test -s conftest.$ac_objext; then :- ac_retval=0-else- $as_echo "$as_me: failed program was:" >&5-sed 's/^/| /' conftest.$ac_ext >&5-- ac_retval=1-fi- eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno- as_fn_set_status $ac_retval--} # ac_fn_cxx_try_compile-cat >config.log <<_ACEOF-This file contains any messages produced by compilers while-running configure, to aid debugging if configure makes a mistake.--It was created by accelerate-cuda $as_me 0.14.0.0, which was-generated by GNU Autoconf 2.69. Invocation command line was-- $ $0 $@--_ACEOF-exec 5>>config.log-{-cat <<_ASUNAME-## --------- ##-## Platform. ##-## --------- ##--hostname = `(hostname || uname -n) 2>/dev/null | sed 1q`-uname -m = `(uname -m) 2>/dev/null || echo unknown`-uname -r = `(uname -r) 2>/dev/null || echo unknown`-uname -s = `(uname -s) 2>/dev/null || echo unknown`-uname -v = `(uname -v) 2>/dev/null || echo unknown`--/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown`-/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown`--/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown`-/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown`-/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown`-/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown`-/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown`-/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown`-/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown`--_ASUNAME--as_save_IFS=$IFS; IFS=$PATH_SEPARATOR-for as_dir in $PATH-do- IFS=$as_save_IFS- test -z "$as_dir" && as_dir=.- $as_echo "PATH: $as_dir"- done-IFS=$as_save_IFS--} >&5--cat >&5 <<_ACEOF---## ----------- ##-## Core tests. ##-## ----------- ##--_ACEOF---# Keep a trace of the command line.-# Strip out --no-create and --no-recursion so they do not pile up.-# Strip out --silent because we don't want to record it for future runs.-# Also quote any args containing shell meta-characters.-# Make two passes to allow for proper duplicate-argument suppression.-ac_configure_args=-ac_configure_args0=-ac_configure_args1=-ac_must_keep_next=false-for ac_pass in 1 2-do- for ac_arg- do- case $ac_arg in- -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;;- -q | -quiet | --quiet | --quie | --qui | --qu | --q \- | -silent | --silent | --silen | --sile | --sil)- continue ;;- *\'*)- ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;- esac- case $ac_pass in- 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;;- 2)- as_fn_append ac_configure_args1 " '$ac_arg'"- if test $ac_must_keep_next = true; then- ac_must_keep_next=false # Got value, back to normal.- else- case $ac_arg in- *=* | --config-cache | -C | -disable-* | --disable-* \- | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \- | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \- | -with-* | --with-* | -without-* | --without-* | --x)- case "$ac_configure_args0 " in- "$ac_configure_args1"*" '$ac_arg' "* ) continue ;;- esac- ;;- -* ) ac_must_keep_next=true ;;- esac- fi- as_fn_append ac_configure_args " '$ac_arg'"- ;;- esac- done-done-{ ac_configure_args0=; unset ac_configure_args0;}-{ ac_configure_args1=; unset ac_configure_args1;}--# When interrupted or exit'd, cleanup temporary files, and complete-# config.log. We remove comments because anyway the quotes in there-# would cause problems or look ugly.-# WARNING: Use '\'' to represent an apostrophe within the trap.-# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug.-trap 'exit_status=$?- # Save into config.log some information that might help in debugging.- {- echo-- $as_echo "## ---------------- ##-## Cache variables. ##-## ---------------- ##"- echo- # The following way of writing the cache mishandles newlines in values,-(- for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do- eval ac_val=\$$ac_var- case $ac_val in #(- *${as_nl}*)- case $ac_var in #(- *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5-$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;;- esac- case $ac_var in #(- _ | IFS | as_nl) ;; #(- BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #(- *) { eval $ac_var=; unset $ac_var;} ;;- esac ;;- esac- done- (set) 2>&1 |- case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #(- *${as_nl}ac_space=\ *)- sed -n \- "s/'\''/'\''\\\\'\'''\''/g;- s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p"- ;; #(- *)- sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"- ;;- esac |- sort-)- echo-- $as_echo "## ----------------- ##-## Output variables. ##-## ----------------- ##"- echo- for ac_var in $ac_subst_vars- do- eval ac_val=\$$ac_var- case $ac_val in- *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;- esac- $as_echo "$ac_var='\''$ac_val'\''"- done | sort- echo-- if test -n "$ac_subst_files"; then- $as_echo "## ------------------- ##-## File substitutions. ##-## ------------------- ##"- echo- for ac_var in $ac_subst_files- do- eval ac_val=\$$ac_var- case $ac_val in- *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;- esac- $as_echo "$ac_var='\''$ac_val'\''"- done | sort- echo- fi-- if test -s confdefs.h; then- $as_echo "## ----------- ##-## confdefs.h. ##-## ----------- ##"- echo- cat confdefs.h- echo- fi- test "$ac_signal" != 0 &&- $as_echo "$as_me: caught signal $ac_signal"- $as_echo "$as_me: exit $exit_status"- } >&5- rm -f core *.core core.conftest.* &&- rm -f -r conftest* confdefs* conf$$* $ac_clean_files &&- exit $exit_status-' 0-for ac_signal in 1 2 13 15; do- trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal-done-ac_signal=0--# confdefs.h avoids OS command line length limits that DEFS can exceed.-rm -f -r conftest* confdefs.h--$as_echo "/* confdefs.h */" > confdefs.h--# Predefined preprocessor variables.--cat >>confdefs.h <<_ACEOF-#define PACKAGE_NAME "$PACKAGE_NAME"-_ACEOF--cat >>confdefs.h <<_ACEOF-#define PACKAGE_TARNAME "$PACKAGE_TARNAME"-_ACEOF--cat >>confdefs.h <<_ACEOF-#define PACKAGE_VERSION "$PACKAGE_VERSION"-_ACEOF--cat >>confdefs.h <<_ACEOF-#define PACKAGE_STRING "$PACKAGE_STRING"-_ACEOF--cat >>confdefs.h <<_ACEOF-#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT"-_ACEOF--cat >>confdefs.h <<_ACEOF-#define PACKAGE_URL "$PACKAGE_URL"-_ACEOF---# Let the site file select an alternate cache file if it wants to.-# Prefer an explicitly selected file to automatically selected ones.-ac_site_file1=NONE-ac_site_file2=NONE-if test -n "$CONFIG_SITE"; then- # We do not want a PATH search for config.site.- case $CONFIG_SITE in #((- -*) ac_site_file1=./$CONFIG_SITE;;- */*) ac_site_file1=$CONFIG_SITE;;- *) ac_site_file1=./$CONFIG_SITE;;- esac-elif test "x$prefix" != xNONE; then- ac_site_file1=$prefix/share/config.site- ac_site_file2=$prefix/etc/config.site-else- ac_site_file1=$ac_default_prefix/share/config.site- ac_site_file2=$ac_default_prefix/etc/config.site-fi-for ac_site_file in "$ac_site_file1" "$ac_site_file2"-do- test "x$ac_site_file" = xNONE && continue- if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then- { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5-$as_echo "$as_me: loading site script $ac_site_file" >&6;}- sed 's/^/| /' "$ac_site_file" >&5- . "$ac_site_file" \- || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5-$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}-as_fn_error $? "failed to load site script $ac_site_file-See \`config.log' for more details" "$LINENO" 5; }- fi-done--if test -r "$cache_file"; then- # Some versions of bash will fail to source /dev/null (special files- # actually), so we avoid doing that. DJGPP emulates it as a regular file.- if test /dev/null != "$cache_file" && test -f "$cache_file"; then- { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5-$as_echo "$as_me: loading cache $cache_file" >&6;}- case $cache_file in- [\\/]* | ?:[\\/]* ) . "$cache_file";;- *) . "./$cache_file";;- esac- fi-else- { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5-$as_echo "$as_me: creating cache $cache_file" >&6;}- >$cache_file-fi--# Check that the precious variables saved in the cache have kept the same-# value.-ac_cache_corrupted=false-for ac_var in $ac_precious_vars; do- eval ac_old_set=\$ac_cv_env_${ac_var}_set- eval ac_new_set=\$ac_env_${ac_var}_set- eval ac_old_val=\$ac_cv_env_${ac_var}_value- eval ac_new_val=\$ac_env_${ac_var}_value- case $ac_old_set,$ac_new_set in- set,)- { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5-$as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;}- ac_cache_corrupted=: ;;- ,set)- { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5-$as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;}- ac_cache_corrupted=: ;;- ,);;- *)- if test "x$ac_old_val" != "x$ac_new_val"; then- # differences in whitespace do not lead to failure.- ac_old_val_w=`echo x $ac_old_val`- ac_new_val_w=`echo x $ac_new_val`- if test "$ac_old_val_w" != "$ac_new_val_w"; then- { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5-$as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;}- ac_cache_corrupted=:- else- { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5-$as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;}- eval $ac_var=\$ac_old_val- fi- { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5-$as_echo "$as_me: former value: \`$ac_old_val'" >&2;}- { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5-$as_echo "$as_me: current value: \`$ac_new_val'" >&2;}- fi;;- esac- # Pass precious variables to config.status.- if test "$ac_new_set" = set; then- case $ac_new_val in- *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;;- *) ac_arg=$ac_var=$ac_new_val ;;- esac- case " $ac_configure_args " in- *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy.- *) as_fn_append ac_configure_args " '$ac_arg'" ;;- esac- fi-done-if $ac_cache_corrupted; then- { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5-$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}- { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5-$as_echo "$as_me: error: changes in the environment can compromise the build" >&2;}- as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5-fi-## -------------------- ##-## Main body of script. ##-## -------------------- ##--ac_ext=c-ac_cpp='$CPP $CPPFLAGS'-ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'-ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'-ac_compiler_gnu=$ac_cv_c_compiler_gnu----ac_config_files="$ac_config_files accelerate-cuda.buildinfo"----# Check whether --with-compiler was given.-if test "${with_compiler+set}" = set; then :- withval=$with_compiler; GHC=$withval-else- # Extract the first word of "ghc", so it can be a program name with args.-set dummy ghc; ac_word=$2-{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5-$as_echo_n "checking for $ac_word... " >&6; }-if ${ac_cv_path_GHC+:} false; then :- $as_echo_n "(cached) " >&6-else- case $GHC in- [\\/]* | ?:[\\/]*)- ac_cv_path_GHC="$GHC" # Let the user override the test with a path.- ;;- *)- as_save_IFS=$IFS; IFS=$PATH_SEPARATOR-for as_dir in $PATH-do- IFS=$as_save_IFS- test -z "$as_dir" && as_dir=.- for ac_exec_ext in '' $ac_executable_extensions; do- if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then- ac_cv_path_GHC="$as_dir/$ac_word$ac_exec_ext"- $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5- break 2- fi-done- done-IFS=$as_save_IFS-- ;;-esac-fi-GHC=$ac_cv_path_GHC-if test -n "$GHC"; then- { $as_echo "$as_me:${as_lineno-$LINENO}: result: $GHC" >&5-$as_echo "$GHC" >&6; }-else- { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5-$as_echo "no" >&6; }-fi---fi---# Check whether --with-nvcc was given.-if test "${with_nvcc+set}" = set; then :- withval=$with_nvcc; NVCC=$withval-else- ac_ext=cpp-ac_cpp='$CXXCPP $CPPFLAGS'-ac_compile='$CXX -c $CXXFLAGS $CPPFLAGS conftest.$ac_ext >&5'-ac_link='$CXX -o conftest$ac_exeext $CXXFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'-ac_compiler_gnu=$ac_cv_cxx_compiler_gnu-if test -z "$CXX"; then- if test -n "$CCC"; then- CXX=$CCC- else- if test -n "$ac_tool_prefix"; then- for ac_prog in nvcc- do- # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args.-set dummy $ac_tool_prefix$ac_prog; ac_word=$2-{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5-$as_echo_n "checking for $ac_word... " >&6; }-if ${ac_cv_prog_CXX+:} false; then :- $as_echo_n "(cached) " >&6-else- if test -n "$CXX"; then- ac_cv_prog_CXX="$CXX" # Let the user override the test.-else-as_save_IFS=$IFS; IFS=$PATH_SEPARATOR-for as_dir in $PATH-do- IFS=$as_save_IFS- test -z "$as_dir" && as_dir=.- for ac_exec_ext in '' $ac_executable_extensions; do- if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then- ac_cv_prog_CXX="$ac_tool_prefix$ac_prog"- $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5- break 2- fi-done- done-IFS=$as_save_IFS--fi-fi-CXX=$ac_cv_prog_CXX-if test -n "$CXX"; then- { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CXX" >&5-$as_echo "$CXX" >&6; }-else- { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5-$as_echo "no" >&6; }-fi--- test -n "$CXX" && break- done-fi-if test -z "$CXX"; then- ac_ct_CXX=$CXX- for ac_prog in nvcc-do- # Extract the first word of "$ac_prog", so it can be a program name with args.-set dummy $ac_prog; ac_word=$2-{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5-$as_echo_n "checking for $ac_word... " >&6; }-if ${ac_cv_prog_ac_ct_CXX+:} false; then :- $as_echo_n "(cached) " >&6-else- if test -n "$ac_ct_CXX"; then- ac_cv_prog_ac_ct_CXX="$ac_ct_CXX" # Let the user override the test.-else-as_save_IFS=$IFS; IFS=$PATH_SEPARATOR-for as_dir in $PATH-do- IFS=$as_save_IFS- test -z "$as_dir" && as_dir=.- for ac_exec_ext in '' $ac_executable_extensions; do- if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then- ac_cv_prog_ac_ct_CXX="$ac_prog"- $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5- break 2- fi-done- done-IFS=$as_save_IFS--fi-fi-ac_ct_CXX=$ac_cv_prog_ac_ct_CXX-if test -n "$ac_ct_CXX"; then- { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CXX" >&5-$as_echo "$ac_ct_CXX" >&6; }-else- { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5-$as_echo "no" >&6; }-fi--- test -n "$ac_ct_CXX" && break-done-- if test "x$ac_ct_CXX" = x; then- CXX="g++"- else- case $cross_compiling:$ac_tool_warned in-yes:)-{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5-$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}-ac_tool_warned=yes ;;-esac- CXX=$ac_ct_CXX- fi-fi-- fi-fi-# Provide some information about the compiler.-$as_echo "$as_me:${as_lineno-$LINENO}: checking for C++ compiler version" >&5-set X $ac_compile-ac_compiler=$2-for ac_option in --version -v -V -qversion; do- { { ac_try="$ac_compiler $ac_option >&5"-case "(($ac_try" in- *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;- *) ac_try_echo=$ac_try;;-esac-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""-$as_echo "$ac_try_echo"; } >&5- (eval "$ac_compiler $ac_option >&5") 2>conftest.err- ac_status=$?- if test -s conftest.err; then- sed '10a\-... rest of stderr output deleted ...- 10q' conftest.err >conftest.er1- cat conftest.er1 >&5- fi- rm -f conftest.er1 conftest.err- $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5- test $ac_status = 0; }-done--cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h. */--int-main ()-{-- ;- return 0;-}-_ACEOF-ac_clean_files_save=$ac_clean_files-ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out"-# Try to create an executable without -o first, disregard a.out.-# It will help us diagnose broken compilers, and finding out an intuition-# of exeext.-{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the C++ compiler works" >&5-$as_echo_n "checking whether the C++ compiler works... " >&6; }-ac_link_default=`$as_echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'`--# The possible output files:-ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*"--ac_rmfiles=-for ac_file in $ac_files-do- case $ac_file in- *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;;- * ) ac_rmfiles="$ac_rmfiles $ac_file";;- esac-done-rm -f $ac_rmfiles--if { { ac_try="$ac_link_default"-case "(($ac_try" in- *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;- *) ac_try_echo=$ac_try;;-esac-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""-$as_echo "$ac_try_echo"; } >&5- (eval "$ac_link_default") 2>&5- ac_status=$?- $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5- test $ac_status = 0; }; then :- # Autoconf-2.13 could set the ac_cv_exeext variable to `no'.-# So ignore a value of `no', otherwise this would lead to `EXEEXT = no'-# in a Makefile. We should not override ac_cv_exeext if it was cached,-# so that the user can short-circuit this test for compilers unknown to-# Autoconf.-for ac_file in $ac_files ''-do- test -f "$ac_file" || continue- case $ac_file in- *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj )- ;;- [ab].out )- # We found the default executable, but exeext='' is most- # certainly right.- break;;- *.* )- if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no;- then :; else- ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`- fi- # We set ac_cv_exeext here because the later test for it is not- # safe: cross compilers may not add the suffix if given an `-o'- # argument, so we may need to know it at that point already.- # Even if this section looks crufty: it has the advantage of- # actually working.- break;;- * )- break;;- esac-done-test "$ac_cv_exeext" = no && ac_cv_exeext=--else- ac_file=''-fi-if test -z "$ac_file"; then :- { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5-$as_echo "no" >&6; }-$as_echo "$as_me: failed program was:" >&5-sed 's/^/| /' conftest.$ac_ext >&5--{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5-$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}-as_fn_error 77 "C++ compiler cannot create executables-See \`config.log' for more details" "$LINENO" 5; }-else- { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5-$as_echo "yes" >&6; }-fi-{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for C++ compiler default output file name" >&5-$as_echo_n "checking for C++ compiler default output file name... " >&6; }-{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5-$as_echo "$ac_file" >&6; }-ac_exeext=$ac_cv_exeext--rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out-ac_clean_files=$ac_clean_files_save-{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5-$as_echo_n "checking for suffix of executables... " >&6; }-if { { ac_try="$ac_link"-case "(($ac_try" in- *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;- *) ac_try_echo=$ac_try;;-esac-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""-$as_echo "$ac_try_echo"; } >&5- (eval "$ac_link") 2>&5- ac_status=$?- $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5- test $ac_status = 0; }; then :- # If both `conftest.exe' and `conftest' are `present' (well, observable)-# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will-# work properly (i.e., refer to `conftest.exe'), while it won't with-# `rm'.-for ac_file in conftest.exe conftest conftest.*; do- test -f "$ac_file" || continue- case $ac_file in- *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;;- *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`- break;;- * ) break;;- esac-done-else- { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5-$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}-as_fn_error $? "cannot compute suffix of executables: cannot compile and link-See \`config.log' for more details" "$LINENO" 5; }-fi-rm -f conftest conftest$ac_cv_exeext-{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5-$as_echo "$ac_cv_exeext" >&6; }--rm -f conftest.$ac_ext-EXEEXT=$ac_cv_exeext-ac_exeext=$EXEEXT-cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h. */-#include <stdio.h>-int-main ()-{-FILE *f = fopen ("conftest.out", "w");- return ferror (f) || fclose (f) != 0;-- ;- return 0;-}-_ACEOF-ac_clean_files="$ac_clean_files conftest.out"-# Check that the compiler produces executables we can run. If not, either-# the compiler is broken, or we cross compile.-{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5-$as_echo_n "checking whether we are cross compiling... " >&6; }-if test "$cross_compiling" != yes; then- { { ac_try="$ac_link"-case "(($ac_try" in- *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;- *) ac_try_echo=$ac_try;;-esac-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""-$as_echo "$ac_try_echo"; } >&5- (eval "$ac_link") 2>&5- ac_status=$?- $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5- test $ac_status = 0; }- if { ac_try='./conftest$ac_cv_exeext'- { { case "(($ac_try" in- *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;- *) ac_try_echo=$ac_try;;-esac-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""-$as_echo "$ac_try_echo"; } >&5- (eval "$ac_try") 2>&5- ac_status=$?- $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5- test $ac_status = 0; }; }; then- cross_compiling=no- else- if test "$cross_compiling" = maybe; then- cross_compiling=yes- else- { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5-$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}-as_fn_error $? "cannot run C++ compiled programs.-If you meant to cross compile, use \`--host'.-See \`config.log' for more details" "$LINENO" 5; }- fi- fi-fi-{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5-$as_echo "$cross_compiling" >&6; }--rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out-ac_clean_files=$ac_clean_files_save-{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5-$as_echo_n "checking for suffix of object files... " >&6; }-if ${ac_cv_objext+:} false; then :- $as_echo_n "(cached) " >&6-else- cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h. */--int-main ()-{-- ;- return 0;-}-_ACEOF-rm -f conftest.o conftest.obj-if { { ac_try="$ac_compile"-case "(($ac_try" in- *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;- *) ac_try_echo=$ac_try;;-esac-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""-$as_echo "$ac_try_echo"; } >&5- (eval "$ac_compile") 2>&5- ac_status=$?- $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5- test $ac_status = 0; }; then :- for ac_file in conftest.o conftest.obj conftest.*; do- test -f "$ac_file" || continue;- case $ac_file in- *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;;- *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'`- break;;- esac-done-else- $as_echo "$as_me: failed program was:" >&5-sed 's/^/| /' conftest.$ac_ext >&5--{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5-$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}-as_fn_error $? "cannot compute suffix of object files: cannot compile-See \`config.log' for more details" "$LINENO" 5; }-fi-rm -f conftest.$ac_cv_objext conftest.$ac_ext-fi-{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5-$as_echo "$ac_cv_objext" >&6; }-OBJEXT=$ac_cv_objext-ac_objext=$OBJEXT-{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C++ compiler" >&5-$as_echo_n "checking whether we are using the GNU C++ compiler... " >&6; }-if ${ac_cv_cxx_compiler_gnu+:} false; then :- $as_echo_n "(cached) " >&6-else- cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h. */--int-main ()-{-#ifndef __GNUC__- choke me-#endif-- ;- return 0;-}-_ACEOF-if ac_fn_cxx_try_compile "$LINENO"; then :- ac_compiler_gnu=yes-else- ac_compiler_gnu=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext-ac_cv_cxx_compiler_gnu=$ac_compiler_gnu--fi-{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_cxx_compiler_gnu" >&5-$as_echo "$ac_cv_cxx_compiler_gnu" >&6; }-if test $ac_compiler_gnu = yes; then- GXX=yes-else- GXX=-fi-ac_test_CXXFLAGS=${CXXFLAGS+set}-ac_save_CXXFLAGS=$CXXFLAGS-{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CXX accepts -g" >&5-$as_echo_n "checking whether $CXX accepts -g... " >&6; }-if ${ac_cv_prog_cxx_g+:} false; then :- $as_echo_n "(cached) " >&6-else- ac_save_cxx_werror_flag=$ac_cxx_werror_flag- ac_cxx_werror_flag=yes- ac_cv_prog_cxx_g=no- CXXFLAGS="-g"- cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h. */--int-main ()-{-- ;- return 0;-}-_ACEOF-if ac_fn_cxx_try_compile "$LINENO"; then :- ac_cv_prog_cxx_g=yes-else- CXXFLAGS=""- cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h. */--int-main ()-{-- ;- return 0;-}-_ACEOF-if ac_fn_cxx_try_compile "$LINENO"; then :--else- ac_cxx_werror_flag=$ac_save_cxx_werror_flag- CXXFLAGS="-g"- cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h. */--int-main ()-{-- ;- return 0;-}-_ACEOF-if ac_fn_cxx_try_compile "$LINENO"; then :- ac_cv_prog_cxx_g=yes-fi-rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext-fi-rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext-fi-rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext- ac_cxx_werror_flag=$ac_save_cxx_werror_flag-fi-{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cxx_g" >&5-$as_echo "$ac_cv_prog_cxx_g" >&6; }-if test "$ac_test_CXXFLAGS" = set; then- CXXFLAGS=$ac_save_CXXFLAGS-elif test $ac_cv_prog_cxx_g = yes; then- if test "$GXX" = yes; then- CXXFLAGS="-g -O2"- else- CXXFLAGS="-g"- fi-else- if test "$GXX" = yes; then- CXXFLAGS="-O2"- else- CXXFLAGS=- fi-fi-ac_ext=c-ac_cpp='$CPP $CPPFLAGS'-ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'-ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'-ac_compiler_gnu=$ac_cv_c_compiler_gnu--fi---# Check whether --with-gcc was given.-if test "${with_gcc+set}" = set; then :- withval=$with_gcc; CC=$withval-fi------ { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of Int" >&5-$as_echo_n "checking size of Int... " >&6; }-- sizeof_hs_Int=`$GHC -w -ignore-dot-ghci -e "import Foreign" -e "import Foreign.C" -e "putStr . show $ sizeOf (undefined::Int)"`- { $as_echo "$as_me:${as_lineno-$LINENO}: result: $sizeof_hs_Int" >&5-$as_echo "$sizeof_hs_Int" >&6; }-- case $sizeof_hs_Int in- 4) type_hs_int=Int32 ;;- 8) type_hs_int=Int64 ;;- esac-- # The type name- def="-DHTYPE_INT=$type_hs_int"- cpp_flags="$cpp_flags $def"- ghc_flags="$ghc_flags -optP$def"-- # And size- def="-DSIZEOF_HTYPE_INT=$sizeof_hs_Int"- cpp_flags="$cpp_flags $def"- ghc_flags="$ghc_flags -optP$def"--- { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of Word" >&5-$as_echo_n "checking size of Word... " >&6; }-- sizeof_hs_Word=`$GHC -w -ignore-dot-ghci -e "import Foreign" -e "import Foreign.C" -e "putStr . show $ sizeOf (undefined::Word)"`- { $as_echo "$as_me:${as_lineno-$LINENO}: result: $sizeof_hs_Word" >&5-$as_echo "$sizeof_hs_Word" >&6; }-- case $sizeof_hs_Word in- 4) type_hs_word=Word32 ;;- 8) type_hs_word=Word64 ;;- esac-- # The type name- def="-DHTYPE_WORD=$type_hs_word"- cpp_flags="$cpp_flags $def"- ghc_flags="$ghc_flags -optP$def"-- # And size- def="-DSIZEOF_HTYPE_WORD=$sizeof_hs_Word"- cpp_flags="$cpp_flags $def"- ghc_flags="$ghc_flags -optP$def"--- { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of CLong" >&5-$as_echo_n "checking size of CLong... " >&6; }-- sizeof_hs_CLong=`$GHC -w -ignore-dot-ghci -e "import Foreign" -e "import Foreign.C" -e "putStr . show $ sizeOf (undefined::CLong)"`- { $as_echo "$as_me:${as_lineno-$LINENO}: result: $sizeof_hs_CLong" >&5-$as_echo "$sizeof_hs_CLong" >&6; }-- case $sizeof_hs_CLong in- 4) type_hs_long=Int32 ;;- 8) type_hs_long=Int64 ;;- esac-- # The type name- def="-DHTYPE_LONG=$type_hs_long"- cpp_flags="$cpp_flags $def"- ghc_flags="$ghc_flags -optP$def"-- # And size- def="-DSIZEOF_HTYPE_LONG=$sizeof_hs_CLong"- cpp_flags="$cpp_flags $def"- ghc_flags="$ghc_flags -optP$def"--- { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of CULong" >&5-$as_echo_n "checking size of CULong... " >&6; }-- sizeof_hs_CULong=`$GHC -w -ignore-dot-ghci -e "import Foreign" -e "import Foreign.C" -e "putStr . show $ sizeOf (undefined::CULong)"`- { $as_echo "$as_me:${as_lineno-$LINENO}: result: $sizeof_hs_CULong" >&5-$as_echo "$sizeof_hs_CULong" >&6; }-- case $sizeof_hs_CULong in- 4) type_hs_unsigned_long=Word32 ;;- 8) type_hs_unsigned_long=Word64 ;;- esac-- # The type name- def="-DHTYPE_UNSIGNED_LONG=$type_hs_unsigned_long"- cpp_flags="$cpp_flags $def"- ghc_flags="$ghc_flags -optP$def"-- # And size- def="-DSIZEOF_HTYPE_UNSIGNED_LONG=$sizeof_hs_CULong"- cpp_flags="$cpp_flags $def"- ghc_flags="$ghc_flags -optP$def"-----cat >confcache <<\_ACEOF-# This file is a shell script that caches the results of configure-# tests run on this system so they can be shared between configure-# scripts and configure runs, see configure's option --config-cache.-# It is not useful on other systems. If it contains results you don't-# want to keep, you may remove or edit it.-#-# config.status only pays attention to the cache file if you give it-# the --recheck option to rerun configure.-#-# `ac_cv_env_foo' variables (set or unset) will be overridden when-# loading this file, other *unset* `ac_cv_foo' will be assigned the-# following values.--_ACEOF--# The following way of writing the cache mishandles newlines in values,-# but we know of no workaround that is simple, portable, and efficient.-# So, we kill variables containing newlines.-# Ultrix sh set writes to stderr and can't be redirected directly,-# and sets the high bit in the cache file unless we assign to the vars.-(- for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do- eval ac_val=\$$ac_var- case $ac_val in #(- *${as_nl}*)- case $ac_var in #(- *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5-$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;;- esac- case $ac_var in #(- _ | IFS | as_nl) ;; #(- BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #(- *) { eval $ac_var=; unset $ac_var;} ;;- esac ;;- esac- done-- (set) 2>&1 |- case $as_nl`(ac_space=' '; set) 2>&1` in #(- *${as_nl}ac_space=\ *)- # `set' does not quote correctly, so add quotes: double-quote- # substitution turns \\\\ into \\, and sed turns \\ into \.- sed -n \- "s/'/'\\\\''/g;- s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p"- ;; #(- *)- # `set' quotes correctly as required by POSIX, so do not add quotes.- sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"- ;;- esac |- sort-) |- sed '- /^ac_cv_env_/b end- t clear- :clear- s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/- t end- s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/- :end' >>confcache-if diff "$cache_file" confcache >/dev/null 2>&1; then :; else- if test -w "$cache_file"; then- if test "x$cache_file" != "x/dev/null"; then- { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5-$as_echo "$as_me: updating cache $cache_file" >&6;}- if test ! -f "$cache_file" || test -h "$cache_file"; then- cat confcache >"$cache_file"- else- case $cache_file in #(- */* | ?:*)- mv -f confcache "$cache_file"$$ &&- mv -f "$cache_file"$$ "$cache_file" ;; #(- *)- mv -f confcache "$cache_file" ;;- esac- fi- fi- else- { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5-$as_echo "$as_me: not updating unwritable cache $cache_file" >&6;}- fi-fi-rm -f confcache--test "x$prefix" = xNONE && prefix=$ac_default_prefix-# Let make expand exec_prefix.-test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'--# Transform confdefs.h into DEFS.-# Protect against shell expansion while executing Makefile rules.-# Protect against Makefile macro expansion.-#-# If the first sed substitution is executed (which looks for macros that-# take arguments), then branch to the quote section. Otherwise,-# look for a macro that doesn't take arguments.-ac_script='-:mline-/\\$/{- N- s,\\\n,,- b mline-}-t clear-:clear-s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g-t quote-s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g-t quote-b any-:quote-s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g-s/\[/\\&/g-s/\]/\\&/g-s/\$/$$/g-H-:any-${- g- s/^\n//- s/\n/ /g- p-}-'-DEFS=`sed -n "$ac_script" confdefs.h`---ac_libobjs=-ac_ltlibobjs=-U=-for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue- # 1. Remove the extension, and $U if already installed.- ac_script='s/\$U\././;s/\.o$//;s/\.obj$//'- ac_i=`$as_echo "$ac_i" | sed "$ac_script"`- # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR- # will be set to the directory where LIBOBJS objects are built.- as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext"- as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo'-done-LIBOBJS=$ac_libobjs--LTLIBOBJS=$ac_ltlibobjs----: "${CONFIG_STATUS=./config.status}"-ac_write_fail=0-ac_clean_files_save=$ac_clean_files-ac_clean_files="$ac_clean_files $CONFIG_STATUS"-{ $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5-$as_echo "$as_me: creating $CONFIG_STATUS" >&6;}-as_write_fail=0-cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1-#! $SHELL-# Generated by $as_me.-# Run this file to recreate the current configuration.-# Compiler output produced by configure, useful for debugging-# configure, is in config.log if it exists.--debug=false-ac_cs_recheck=false-ac_cs_silent=false--SHELL=\${CONFIG_SHELL-$SHELL}-export SHELL-_ASEOF-cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1-## -------------------- ##-## M4sh Initialization. ##-## -------------------- ##--# Be more Bourne compatible-DUALCASE=1; export DUALCASE # for MKS sh-if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then :- emulate sh- NULLCMD=:- # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which- # is contrary to our usage. Disable this feature.- alias -g '${1+"$@"}'='"$@"'- setopt NO_GLOB_SUBST-else- case `(set -o) 2>/dev/null` in #(- *posix*) :- set -o posix ;; #(- *) :- ;;-esac-fi---as_nl='-'-export as_nl-# Printing a long string crashes Solaris 7 /usr/bin/printf.-as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\'-as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo-as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo-# Prefer a ksh shell builtin over an external printf program on Solaris,-# but without wasting forks for bash or zsh.-if test -z "$BASH_VERSION$ZSH_VERSION" \- && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then- as_echo='print -r --'- as_echo_n='print -rn --'-elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then- as_echo='printf %s\n'- as_echo_n='printf %s'-else- if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then- as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"'- as_echo_n='/usr/ucb/echo -n'- else- as_echo_body='eval expr "X$1" : "X\\(.*\\)"'- as_echo_n_body='eval- arg=$1;- case $arg in #(- *"$as_nl"*)- expr "X$arg" : "X\\(.*\\)$as_nl";- arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;;- esac;- expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl"- '- export as_echo_n_body- as_echo_n='sh -c $as_echo_n_body as_echo'- fi- export as_echo_body- as_echo='sh -c $as_echo_body as_echo'-fi--# The user is always right.-if test "${PATH_SEPARATOR+set}" != set; then- PATH_SEPARATOR=:- (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && {- (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 ||- PATH_SEPARATOR=';'- }-fi---# IFS-# We need space, tab and new line, in precisely that order. Quoting is-# there to prevent editors from complaining about space-tab.-# (If _AS_PATH_WALK were called with IFS unset, it would disable word-# splitting by setting IFS to empty value.)-IFS=" "" $as_nl"--# Find who we are. Look in the path if we contain no directory separator.-as_myself=-case $0 in #((- *[\\/]* ) as_myself=$0 ;;- *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR-for as_dir in $PATH-do- IFS=$as_save_IFS- test -z "$as_dir" && as_dir=.- test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break- done-IFS=$as_save_IFS-- ;;-esac-# We did not find ourselves, most probably we were run as `sh COMMAND'-# in which case we are not to be found in the path.-if test "x$as_myself" = x; then- as_myself=$0-fi-if test ! -f "$as_myself"; then- $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2- exit 1-fi--# Unset variables that we do not need and which cause bugs (e.g. in-# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1"-# suppresses any "Segmentation fault" message there. '((' could-# trigger a bug in pdksh 5.2.14.-for as_var in BASH_ENV ENV MAIL MAILPATH-do eval test x\${$as_var+set} = xset \- && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || :-done-PS1='$ '-PS2='> '-PS4='+ '--# NLS nuisances.-LC_ALL=C-export LC_ALL-LANGUAGE=C-export LANGUAGE--# CDPATH.-(unset CDPATH) >/dev/null 2>&1 && unset CDPATH---# as_fn_error STATUS ERROR [LINENO LOG_FD]-# -----------------------------------------# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are-# provided, also output the error to LOG_FD, referencing LINENO. Then exit the-# script with STATUS, using 1 if that was 0.-as_fn_error ()-{- as_status=$1; test $as_status -eq 0 && as_status=1- if test "$4"; then- as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack- $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4- fi- $as_echo "$as_me: error: $2" >&2- as_fn_exit $as_status-} # as_fn_error---# as_fn_set_status STATUS-# ------------------------# Set $? to STATUS, without forking.-as_fn_set_status ()-{- return $1-} # as_fn_set_status--# as_fn_exit STATUS-# ------------------# Exit the shell with STATUS, even in a "trap 0" or "set -e" context.-as_fn_exit ()-{- set +e- as_fn_set_status $1- exit $1-} # as_fn_exit--# as_fn_unset VAR-# ----------------# Portably unset VAR.-as_fn_unset ()-{- { eval $1=; unset $1;}-}-as_unset=as_fn_unset-# as_fn_append VAR VALUE-# -----------------------# Append the text in VALUE to the end of the definition contained in VAR. Take-# advantage of any shell optimizations that allow amortized linear growth over-# repeated appends, instead of the typical quadratic growth present in naive-# implementations.-if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then :- eval 'as_fn_append ()- {- eval $1+=\$2- }'-else- as_fn_append ()- {- eval $1=\$$1\$2- }-fi # as_fn_append--# as_fn_arith ARG...-# -------------------# Perform arithmetic evaluation on the ARGs, and store the result in the-# global $as_val. Take advantage of shells that can avoid forks. The arguments-# must be portable across $(()) and expr.-if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then :- eval 'as_fn_arith ()- {- as_val=$(( $* ))- }'-else- as_fn_arith ()- {- as_val=`expr "$@" || test $? -eq 1`- }-fi # as_fn_arith---if expr a : '\(a\)' >/dev/null 2>&1 &&- test "X`expr 00001 : '.*\(...\)'`" = X001; then- as_expr=expr-else- as_expr=false-fi--if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then- as_basename=basename-else- as_basename=false-fi--if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then- as_dirname=dirname-else- as_dirname=false-fi--as_me=`$as_basename -- "$0" ||-$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \- X"$0" : 'X\(//\)$' \| \- X"$0" : 'X\(/\)' \| . 2>/dev/null ||-$as_echo X/"$0" |- sed '/^.*\/\([^/][^/]*\)\/*$/{- s//\1/- q- }- /^X\/\(\/\/\)$/{- s//\1/- q- }- /^X\/\(\/\).*/{- s//\1/- q- }- s/.*/./; q'`--# Avoid depending upon Character Ranges.-as_cr_letters='abcdefghijklmnopqrstuvwxyz'-as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'-as_cr_Letters=$as_cr_letters$as_cr_LETTERS-as_cr_digits='0123456789'-as_cr_alnum=$as_cr_Letters$as_cr_digits--ECHO_C= ECHO_N= ECHO_T=-case `echo -n x` in #(((((--n*)- case `echo 'xy\c'` in- *c*) ECHO_T=' ';; # ECHO_T is single tab character.- xy) ECHO_C='\c';;- *) echo `echo ksh88 bug on AIX 6.1` > /dev/null- ECHO_T=' ';;- esac;;-*)- ECHO_N='-n';;-esac--rm -f conf$$ conf$$.exe conf$$.file-if test -d conf$$.dir; then- rm -f conf$$.dir/conf$$.file-else- rm -f conf$$.dir- mkdir conf$$.dir 2>/dev/null-fi-if (echo >conf$$.file) 2>/dev/null; then- if ln -s conf$$.file conf$$ 2>/dev/null; then- as_ln_s='ln -s'- # ... but there are two gotchas:- # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail.- # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable.- # In both cases, we have to default to `cp -pR'.- ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||- as_ln_s='cp -pR'- elif ln conf$$.file conf$$ 2>/dev/null; then- as_ln_s=ln- else- as_ln_s='cp -pR'- fi-else- as_ln_s='cp -pR'-fi-rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file-rmdir conf$$.dir 2>/dev/null---# as_fn_mkdir_p-# --------------# Create "$as_dir" as a directory, including parents if necessary.-as_fn_mkdir_p ()-{-- case $as_dir in #(- -*) as_dir=./$as_dir;;- esac- test -d "$as_dir" || eval $as_mkdir_p || {- as_dirs=- while :; do- case $as_dir in #(- *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'(- *) as_qdir=$as_dir;;- esac- as_dirs="'$as_qdir' $as_dirs"- as_dir=`$as_dirname -- "$as_dir" ||-$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \- X"$as_dir" : 'X\(//\)[^/]' \| \- X"$as_dir" : 'X\(//\)$' \| \- X"$as_dir" : 'X\(/\)' \| . 2>/dev/null ||-$as_echo X"$as_dir" |- sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{- s//\1/- q- }- /^X\(\/\/\)[^/].*/{- s//\1/- q- }- /^X\(\/\/\)$/{- s//\1/- q- }- /^X\(\/\).*/{- s//\1/- q- }- s/.*/./; q'`- test -d "$as_dir" && break- done- test -z "$as_dirs" || eval "mkdir $as_dirs"- } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir"---} # as_fn_mkdir_p-if mkdir -p . 2>/dev/null; then- as_mkdir_p='mkdir -p "$as_dir"'-else- test -d ./-p && rmdir ./-p- as_mkdir_p=false-fi---# as_fn_executable_p FILE-# ------------------------# Test if FILE is an executable regular file.-as_fn_executable_p ()-{- test -f "$1" && test -x "$1"-} # as_fn_executable_p-as_test_x='test -x'-as_executable_p=as_fn_executable_p--# Sed expression to map a string onto a valid CPP name.-as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"--# Sed expression to map a string onto a valid variable name.-as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"---exec 6>&1-## ----------------------------------- ##-## Main body of $CONFIG_STATUS script. ##-## ----------------------------------- ##-_ASEOF-test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1--cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1-# Save the log message, to keep $0 and so on meaningful, and to-# report actual input values of CONFIG_FILES etc. instead of their-# values after options handling.-ac_log="-This file was extended by accelerate-cuda $as_me 0.14.0.0, which was-generated by GNU Autoconf 2.69. Invocation command line was-- CONFIG_FILES = $CONFIG_FILES- CONFIG_HEADERS = $CONFIG_HEADERS- CONFIG_LINKS = $CONFIG_LINKS- CONFIG_COMMANDS = $CONFIG_COMMANDS- $ $0 $@--on `(hostname || uname -n) 2>/dev/null | sed 1q`-"--_ACEOF--case $ac_config_files in *"-"*) set x $ac_config_files; shift; ac_config_files=$*;;-esac----cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1-# Files that config.status was made for.-config_files="$ac_config_files"--_ACEOF--cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1-ac_cs_usage="\-\`$as_me' instantiates files and other configuration actions-from templates according to the current configuration. Unless the files-and actions are specified as TAGs, all are instantiated by default.--Usage: $0 [OPTION]... [TAG]...-- -h, --help print this help, then exit- -V, --version print version number and configuration settings, then exit- --config print configuration, then exit- -q, --quiet, --silent- do not print progress messages- -d, --debug don't remove temporary files- --recheck update $as_me by reconfiguring in the same conditions- --file=FILE[:TEMPLATE]- instantiate the configuration file FILE--Configuration files:-$config_files--Report bugs to <accelerate-haskell@googlegroups.com>."--_ACEOF-cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1-ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`"-ac_cs_version="\\-accelerate-cuda config.status 0.14.0.0-configured by $0, generated by GNU Autoconf 2.69,- with options \\"\$ac_cs_config\\"--Copyright (C) 2012 Free Software Foundation, Inc.-This config.status script is free software; the Free Software Foundation-gives unlimited permission to copy, distribute and modify it."--ac_pwd='$ac_pwd'-srcdir='$srcdir'-test -n "\$AWK" || AWK=awk-_ACEOF--cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1-# The default lists apply if the user does not specify any file.-ac_need_defaults=:-while test $# != 0-do- case $1 in- --*=?*)- ac_option=`expr "X$1" : 'X\([^=]*\)='`- ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'`- ac_shift=:- ;;- --*=)- ac_option=`expr "X$1" : 'X\([^=]*\)='`- ac_optarg=- ac_shift=:- ;;- *)- ac_option=$1- ac_optarg=$2- ac_shift=shift- ;;- esac-- case $ac_option in- # Handling of the options.- -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r)- ac_cs_recheck=: ;;- --version | --versio | --versi | --vers | --ver | --ve | --v | -V )- $as_echo "$ac_cs_version"; exit ;;- --config | --confi | --conf | --con | --co | --c )- $as_echo "$ac_cs_config"; exit ;;- --debug | --debu | --deb | --de | --d | -d )- debug=: ;;- --file | --fil | --fi | --f )- $ac_shift- case $ac_optarg in- *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;;- '') as_fn_error $? "missing file argument" ;;- esac- as_fn_append CONFIG_FILES " '$ac_optarg'"- ac_need_defaults=false;;- --he | --h | --help | --hel | -h )- $as_echo "$ac_cs_usage"; exit ;;- -q | -quiet | --quiet | --quie | --qui | --qu | --q \- | -silent | --silent | --silen | --sile | --sil | --si | --s)- ac_cs_silent=: ;;-- # This is an error.- -*) as_fn_error $? "unrecognized option: \`$1'-Try \`$0 --help' for more information." ;;-- *) as_fn_append ac_config_targets " $1"- ac_need_defaults=false ;;-- esac- shift-done--ac_configure_extra_args=--if $ac_cs_silent; then- exec 6>/dev/null- ac_configure_extra_args="$ac_configure_extra_args --silent"-fi--_ACEOF-cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1-if \$ac_cs_recheck; then- set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion- shift- \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6- CONFIG_SHELL='$SHELL'- export CONFIG_SHELL- exec "\$@"-fi--_ACEOF-cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1-exec 5>>config.log-{- echo- sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX-## Running $as_me. ##-_ASBOX- $as_echo "$ac_log"-} >&5--_ACEOF-cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1-_ACEOF--cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1--# Handling of arguments.-for ac_config_target in $ac_config_targets-do- case $ac_config_target in- "accelerate-cuda.buildinfo") CONFIG_FILES="$CONFIG_FILES accelerate-cuda.buildinfo" ;;-- *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;;- esac-done---# If the user did not use the arguments to specify the items to instantiate,-# then the envvar interface is used. Set only those that are not.-# We use the long form for the default assignment because of an extremely-# bizarre bug on SunOS 4.1.3.-if $ac_need_defaults; then- test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files-fi--# Have a temporary directory for convenience. Make it in the build tree-# simply because there is no reason against having it here, and in addition,-# creating and moving files from /tmp can sometimes cause problems.-# Hook for its removal unless debugging.-# Note that there is a small window in which the directory will not be cleaned:-# after its creation but before its name has been assigned to `$tmp'.-$debug ||-{- tmp= ac_tmp=- trap 'exit_status=$?- : "${ac_tmp:=$tmp}"- { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status-' 0- trap 'as_fn_exit 1' 1 2 13 15-}-# Create a (secure) tmp directory for tmp files.--{- tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` &&- test -d "$tmp"-} ||-{- tmp=./conf$$-$RANDOM- (umask 077 && mkdir "$tmp")-} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5-ac_tmp=$tmp--# Set up the scripts for CONFIG_FILES section.-# No need to generate them if there are no CONFIG_FILES.-# This happens for instance with `./config.status config.h'.-if test -n "$CONFIG_FILES"; then---ac_cr=`echo X | tr X '\015'`-# On cygwin, bash can eat \r inside `` if the user requested igncr.-# But we know of no other shell where ac_cr would be empty at this-# point, so we can use a bashism as a fallback.-if test "x$ac_cr" = x; then- eval ac_cr=\$\'\\r\'-fi-ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' </dev/null 2>/dev/null`-if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then- ac_cs_awk_cr='\\r'-else- ac_cs_awk_cr=$ac_cr-fi--echo 'BEGIN {' >"$ac_tmp/subs1.awk" &&-_ACEOF---{- echo "cat >conf$$subs.awk <<_ACEOF" &&- echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' &&- echo "_ACEOF"-} >conf$$subs.sh ||- as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5-ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'`-ac_delim='%!_!# '-for ac_last_try in false false false false false :; do- . ./conf$$subs.sh ||- as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5-- ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X`- if test $ac_delim_n = $ac_delim_num; then- break- elif $ac_last_try; then- as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5- else- ac_delim="$ac_delim!$ac_delim _$ac_delim!! "- fi-done-rm -f conf$$subs.sh--cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1-cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK &&-_ACEOF-sed -n '-h-s/^/S["/; s/!.*/"]=/-p-g-s/^[^!]*!//-:repl-t repl-s/'"$ac_delim"'$//-t delim-:nl-h-s/\(.\{148\}\)..*/\1/-t more1-s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/-p-n-b repl-:more1-s/["\\]/\\&/g; s/^/"/; s/$/"\\/-p-g-s/.\{148\}//-t nl-:delim-h-s/\(.\{148\}\)..*/\1/-t more2-s/["\\]/\\&/g; s/^/"/; s/$/"/-p-b-:more2-s/["\\]/\\&/g; s/^/"/; s/$/"\\/-p-g-s/.\{148\}//-t delim-' <conf$$subs.awk | sed '-/^[^""]/{- N- s/\n//-}-' >>$CONFIG_STATUS || ac_write_fail=1-rm -f conf$$subs.awk-cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1-_ACAWK-cat >>"\$ac_tmp/subs1.awk" <<_ACAWK &&- for (key in S) S_is_set[key] = 1- FS = ""--}-{- line = $ 0- nfields = split(line, field, "@")- substed = 0- len = length(field[1])- for (i = 2; i < nfields; i++) {- key = field[i]- keylen = length(key)- if (S_is_set[key]) {- value = S[key]- line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3)- len += length(value) + length(field[++i])- substed = 1- } else- len += 1 + keylen- }-- print line-}--_ACAWK-_ACEOF-cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1-if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then- sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g"-else- cat-fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \- || as_fn_error $? "could not setup config files machinery" "$LINENO" 5-_ACEOF--# VPATH may cause trouble with some makes, so we remove sole $(srcdir),-# ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and-# trailing colons and then remove the whole line if VPATH becomes empty-# (actually we leave an empty line to preserve line numbers).-if test "x$srcdir" = x.; then- ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{-h-s///-s/^/:/-s/[ ]*$/:/-s/:\$(srcdir):/:/g-s/:\${srcdir}:/:/g-s/:@srcdir@:/:/g-s/^:*//-s/:*$//-x-s/\(=[ ]*\).*/\1/-G-s/\n//-s/^[^=]*=[ ]*$//-}'-fi--cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1-fi # test -n "$CONFIG_FILES"---eval set X " :F $CONFIG_FILES "-shift-for ac_tag-do- case $ac_tag in- :[FHLC]) ac_mode=$ac_tag; continue;;- esac- case $ac_mode$ac_tag in- :[FHL]*:*);;- :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;;- :[FH]-) ac_tag=-:-;;- :[FH]*) ac_tag=$ac_tag:$ac_tag.in;;- esac- ac_save_IFS=$IFS- IFS=:- set x $ac_tag- IFS=$ac_save_IFS- shift- ac_file=$1- shift-- case $ac_mode in- :L) ac_source=$1;;- :[FH])- ac_file_inputs=- for ac_f- do- case $ac_f in- -) ac_f="$ac_tmp/stdin";;- *) # Look for the file first in the build tree, then in the source tree- # (if the path is not absolute). The absolute path cannot be DOS-style,- # because $ac_f cannot contain `:'.- test -f "$ac_f" ||- case $ac_f in- [\\/$]*) false;;- *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";;- esac ||- as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;;- esac- case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac- as_fn_append ac_file_inputs " '$ac_f'"- done-- # Let's still pretend it is `configure' which instantiates (i.e., don't- # use $as_me), people would be surprised to read:- # /* config.h. Generated by config.status. */- configure_input='Generated from '`- $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g'- `' by configure.'- if test x"$ac_file" != x-; then- configure_input="$ac_file. $configure_input"- { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5-$as_echo "$as_me: creating $ac_file" >&6;}- fi- # Neutralize special characters interpreted by sed in replacement strings.- case $configure_input in #(- *\&* | *\|* | *\\* )- ac_sed_conf_input=`$as_echo "$configure_input" |- sed 's/[\\\\&|]/\\\\&/g'`;; #(- *) ac_sed_conf_input=$configure_input;;- esac-- case $ac_tag in- *:-:* | *:-) cat >"$ac_tmp/stdin" \- || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;;- esac- ;;- esac-- ac_dir=`$as_dirname -- "$ac_file" ||-$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \- X"$ac_file" : 'X\(//\)[^/]' \| \- X"$ac_file" : 'X\(//\)$' \| \- X"$ac_file" : 'X\(/\)' \| . 2>/dev/null ||-$as_echo X"$ac_file" |- sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{- s//\1/- q- }- /^X\(\/\/\)[^/].*/{- s//\1/- q- }- /^X\(\/\/\)$/{- s//\1/- q- }- /^X\(\/\).*/{- s//\1/- q- }- s/.*/./; q'`- as_dir="$ac_dir"; as_fn_mkdir_p- ac_builddir=.--case "$ac_dir" in-.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;-*)- ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'`- # A ".." for each directory in $ac_dir_suffix.- ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'`- case $ac_top_builddir_sub in- "") ac_top_builddir_sub=. ac_top_build_prefix= ;;- *) ac_top_build_prefix=$ac_top_builddir_sub/ ;;- esac ;;-esac-ac_abs_top_builddir=$ac_pwd-ac_abs_builddir=$ac_pwd$ac_dir_suffix-# for backward compatibility:-ac_top_builddir=$ac_top_build_prefix--case $srcdir in- .) # We are building in place.- ac_srcdir=.- ac_top_srcdir=$ac_top_builddir_sub- ac_abs_top_srcdir=$ac_pwd ;;- [\\/]* | ?:[\\/]* ) # Absolute name.- ac_srcdir=$srcdir$ac_dir_suffix;- ac_top_srcdir=$srcdir- ac_abs_top_srcdir=$srcdir ;;- *) # Relative name.- ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix- ac_top_srcdir=$ac_top_build_prefix$srcdir- ac_abs_top_srcdir=$ac_pwd/$srcdir ;;-esac-ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix--- case $ac_mode in- :F)- #- # CONFIG_FILE- #--_ACEOF--cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1-# If the template does not know about datarootdir, expand it.-# FIXME: This hack should be removed a few years after 2.60.-ac_datarootdir_hack=; ac_datarootdir_seen=-ac_sed_dataroot='-/datarootdir/ {- p- q-}-/@datadir@/p-/@docdir@/p-/@infodir@/p-/@localedir@/p-/@mandir@/p'-case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in-*datarootdir*) ac_datarootdir_seen=yes;;-*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*)- { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5-$as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;}-_ACEOF-cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1- ac_datarootdir_hack='- s&@datadir@&$datadir&g- s&@docdir@&$docdir&g- s&@infodir@&$infodir&g- s&@localedir@&$localedir&g- s&@mandir@&$mandir&g- s&\\\${datarootdir}&$datarootdir&g' ;;-esac-_ACEOF--# Neutralize VPATH when `$srcdir' = `.'.-# Shell code in configure.ac might set extrasub.-# FIXME: do we really want to maintain this feature?-cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1-ac_sed_extra="$ac_vpsub-$extrasub-_ACEOF-cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1-:t-/@[a-zA-Z_][a-zA-Z_0-9]*@/!b-s|@configure_input@|$ac_sed_conf_input|;t t-s&@top_builddir@&$ac_top_builddir_sub&;t t-s&@top_build_prefix@&$ac_top_build_prefix&;t t-s&@srcdir@&$ac_srcdir&;t t-s&@abs_srcdir@&$ac_abs_srcdir&;t t-s&@top_srcdir@&$ac_top_srcdir&;t t-s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t-s&@builddir@&$ac_builddir&;t t-s&@abs_builddir@&$ac_abs_builddir&;t t-s&@abs_top_builddir@&$ac_abs_top_builddir&;t t-$ac_datarootdir_hack-"-eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \- >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5--test -z "$ac_datarootdir_hack$ac_datarootdir_seen" &&- { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } &&- { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \- "$ac_tmp/out"`; test -z "$ac_out"; } &&- { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir'-which seems to be undefined. Please make sure it is defined" >&5-$as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir'-which seems to be undefined. Please make sure it is defined" >&2;}-- rm -f "$ac_tmp/stdin"- case $ac_file in- -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";;- *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";;- esac \- || as_fn_error $? "could not create $ac_file" "$LINENO" 5- ;;---- esac--done # for ac_tag---as_fn_exit 0-_ACEOF-ac_clean_files=$ac_clean_files_save--test $ac_write_fail = 0 ||- as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5---# configure is writing to config.log, and then calls config.status.-# config.status does its own redirection, appending to config.log.-# Unfortunately, on DOS this fails, as config.log is still kept open-# by configure, so config.status won't be able to write to it; its-# output is simply discarded. So we exec the FD to /dev/null,-# effectively closing config.log, so it can be properly (re)opened and-# appended to by config.status. When coming back to configure, we-# need to make the FD available again.-if test "$no_create" != yes; then- ac_cs_success=:- ac_config_status_args=- test "$silent" = yes &&- ac_config_status_args="$ac_config_status_args --quiet"- exec 5>/dev/null- $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false- exec 5>>config.log- # Use ||, not &&, to avoid exiting from the if with $? = 1, which- # would make configure fail if this is the last instruction.- $ac_cs_success || as_fn_exit 1-fi-if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then- { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5-$as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;}-fi--
cubits/accelerate_cuda.h view
@@ -1,8 +1,8 @@ /* ----------------------------------------------------------------------------- * * Module : Accelerate-CUDA- * Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee- * [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+ * Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+ * [2009..2014] Trevor L. McDonell * License : BSD3 * * Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>@@ -14,6 +14,7 @@ #define __ACCELERATE_CUDA_H__ #include "accelerate_cuda_assert.h"+#include "accelerate_cuda_exceptional.h" #include "accelerate_cuda_function.h" #include "accelerate_cuda_texture.h" #include "accelerate_cuda_type.h"
cubits/accelerate_cuda_assert.h view
@@ -1,8 +1,8 @@ /* ----------------------------------------------------------------------------- * * Module : Assert- * Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee- * [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+ * Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+ * [2009..2014] Trevor L. McDonell * License : BSD3 * * Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>
+ cubits/accelerate_cuda_exceptional.h view
@@ -0,0 +1,26 @@+/* -----------------------------------------------------------------------------+ *+ * Module : Exceptional+ * Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+ * [2009..2014] Trevor L. McDonell+ * License : BSD3+ *+ * Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+ * Stability : experimental+ *+ * ---------------------------------------------------------------------------*/++#ifndef __ACCELERATE_CUDA_EXCEPTIONAL_H__+#define __ACCELERATE_CUDA_EXCEPTIONAL_H__++/*+ * Exceptional values have slightly different names than what are produced by+ * the code generator.+ */+#include <math.h>++#define Infinity INFINITY+#define NaN NAN++#endif+
cubits/accelerate_cuda_function.h view
@@ -1,8 +1,8 @@ /* ----------------------------------------------------------------------------- * * Module : Function- * Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee- * [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+ * Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+ * [2009..2014] Trevor L. McDonell * License : BSD3 * * Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>@@ -23,93 +23,6 @@ * -------------------------------------------------------------------------- */ /*- * Left/Right bitwise rotation- */-template <typename T>-static __inline__ __device__ T rotateL(const T x, const Int32 i)-{- const Int32 i8 = i & 8 * sizeof(x) - 1;- return i8 == 0 ? x : x << i8 | x >> 8 * sizeof(x) - i8;-}--template <typename T>-static __inline__ __device__ T rotateR(const T x, const Int32 i)-{- const Int32 i8 = i & 8 * sizeof(x) - 1;- return i8 == 0 ? x : x >> i8 | x << 8 * sizeof(x) - i8;-}--/*- * Integer division, truncated towards negative infinity- */-template <typename T>-static __inline__ __device__ T idiv(const T x, const T y)-{- return x > 0 && y < 0 ? (x - y - 1) / y : (x < 0 && y > 0 ? (x - y + 1) / y : x / y);-}--template <>-static __inline__ __device__ Word8 idiv(const Word8 x, const Word8 y)-{- return x / y;-}--template <>-static __inline__ __device__ Word16 idiv(const Word16 x, const Word16 y)-{- return x / y;-}--template <>-static __inline__ __device__ Word32 idiv(const Word32 x, const Word32 y)-{- return x / y;-}--template <>-static __inline__ __device__ Word64 idiv(const Word64 x, const Word64 y)-{- return x / y;-}---/*- * Integer modulus, Haskell style- */-template <typename T>-static __inline__ __device__ T mod(const T x, const T y)-{- const T r = x % y;- return x > 0 && y < 0 || x < 0 && y > 0 ? (r != 0 ? r + y : 0) : r;-}--template <>-static __inline__ __device__ Word8 mod(const Word8 x, const Word8 y)-{- return x % y;-}--template <>-static __inline__ __device__ Word16 mod(const Word16 x, const Word16 y)-{- return x % y;-}--template <>-static __inline__ __device__ Word32 mod(const Word32 x, const Word32 y)-{- return x % y;-}--template <>-static __inline__ __device__ Word64 mod(const Word64 x, const Word64 y)-{- return x % y;-}----/* * Type coercion */ template <typename T>@@ -122,13 +35,13 @@ } template <>-static __inline__ __device__ Word32 reinterpret32(const Word32 x)+__inline__ __device__ Word32 reinterpret32(const Word32 x) { return x; } template <>-static __inline__ __device__ Word32 reinterpret32(const float x)+__inline__ __device__ Word32 reinterpret32(const float x) { return __float_as_int(x); }@@ -143,14 +56,14 @@ } template <>-static __inline__ __device__ Word64 reinterpret64(const Word64 x)+__inline__ __device__ Word64 reinterpret64(const Word64 x) { return x; } #if !defined(__CUDA_ARCH__) || __CUDA_ARCH__ >= 130 template <>-static __inline__ __device__ Word64 reinterpret64(const double x)+__inline__ __device__ Word64 reinterpret64(const double x) { return __double_as_longlong(x); }@@ -171,13 +84,13 @@ #if !defined(__CUDA_ARCH__) || __CUDA_ARCH__ >= 110 template <>-static __inline__ __device__ Int32 atomicCAS32(Int32* address, Int32 compare, Int32 val)+__inline__ __device__ Int32 atomicCAS32(Int32* address, Int32 compare, Int32 val) { return atomicCAS(address, compare, val); } template <>-static __inline__ __device__ Word32 atomicCAS32(Word32* address, Word32 compare, Word32 val)+__inline__ __device__ Word32 atomicCAS32(Word32* address, Word32 compare, Word32 val) { return atomicCAS(address, compare, val); }@@ -194,7 +107,7 @@ } template <>-static __inline__ __device__ Word64 atomicCAS64(Word64* address, Word64 compare, Word64 val)+__inline__ __device__ Word64 atomicCAS64(Word64* address, Word64 compare, Word64 val) { return atomicCAS(address, compare, val); }@@ -217,13 +130,13 @@ } template <>-static __inline__ __device__ int shfl_up32(int var, unsigned int delta, int width)+__inline__ __device__ int shfl_up32(int var, unsigned int delta, int width) { return __shfl_up(var, delta, width); } template <>-static __inline__ __device__ float shfl_up32(float var, unsigned int delta, int width)+__inline__ __device__ float shfl_up32(float var, unsigned int delta, int width) { return __shfl_up(var, delta, width); }@@ -254,13 +167,13 @@ } template <>-static __inline__ __device__ int shfl_xor32(int var, int laneMask, int width)+__inline__ __device__ int shfl_xor32(int var, int laneMask, int width) { return __shfl_xor(var, laneMask, width); } template <>-static __inline__ __device__ float shfl_xor32(float var, int laneMask, int width)+__inline__ __device__ float shfl_xor32(float var, int laneMask, int width) { return __shfl_xor(var, laneMask, width); }
cubits/accelerate_cuda_texture.h view
@@ -1,8 +1,8 @@ /* ----------------------------------------------------------------------------- * * Module : Texture- * Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee- * [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+ * Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+ * [2009..2014] Trevor L. McDonell * License : BSD3 * * Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>
cubits/accelerate_cuda_type.h view
@@ -1,8 +1,8 @@ /* ----------------------------------------------------------------------------- * * Module : Type- * Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee- * [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+ * Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller+ * [2009..2014] Trevor L. McDonell * License : BSD3 * * Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>@@ -30,3 +30,4 @@ typedef unsigned long long Word64; #endif+
− include/accelerate.h
@@ -1,31 +0,0 @@--#ifndef ACCELERATE_H-#define ACCELERATE_H-import qualified Data.Array.Accelerate.Internal.Check as Ck---/*- * Internal checks- */-#define ERROR(f) (Ck.f __FILE__ __LINE__)-#define ASSERT (Ck.assert __FILE__ __LINE__)-#define ENSURE (Ck.f __FILE__ __LINE__)-#define CHECK(f) (Ck.f __FILE__ __LINE__)--#define BOUNDS_ERROR(f) (ERROR(f) Ck.Bounds)-#define BOUNDS_ASSERT (ASSERT Ck.Bounds)-#define BOUNDS_ENSURE (ENSURE Ck.Bounds)-#define BOUNDS_CHECK(f) (CHECK(f) Ck.Bounds)--#define UNSAFE_ERROR(f) (ERROR(f) Ck.Unsafe)-#define UNSAFE_ASSERT (ASSERT Ck.Unsafe)-#define UNSAFE_ENSURE (ENSURE Ck.Unsafe)-#define UNSAFE_CHECK(f) (CHECK(f) Ck.Unsafe)--#define INTERNAL_ERROR(f) (ERROR(f) Ck.Internal)-#define INTERNAL_ASSERT (ASSERT Ck.Internal)-#define INTERNAL_ENSURE (ENSURE Ck.Internal)-#define INTERNAL_CHECK(f) (CHECK(f) Ck.Internal)--#endif-