diff --git a/Data/Array/Accelerate/CUDA.hs b/Data/Array/Accelerate/CUDA.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables #-} +-- | +-- Module : Data.Array.Accelerate.CUDA +-- 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 +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- This module implements the CUDA backend for the embedded array language +-- Accelerate. Expressions are on-line translated into CUDA code, compiled, and +-- executed in parallel on the GPU. +-- +-- The accelerate-cuda library is hosted at . +-- Comments, bug reports, and patches are always welcome. +-- + +module Data.Array.Accelerate.CUDA ( + + Arrays, + + -- * Synchronous execution + run, run1, stream, runIn, run1In, streamIn, + + -- * Asynchronous execution + Async, wait, poll, cancel, + runAsync, run1Async, runAsyncIn, run1AsyncIn + +) where + +-- standard library +import Prelude hiding ( catch ) +import Control.Exception +import Control.Applicative +import Control.Concurrent +import System.IO.Unsafe +import Foreign.CUDA.Driver ( Context ) +import Foreign.CUDA.Driver.Error + +-- friends +import Data.Array.Accelerate.Smart ( Acc, convertAcc, convertAccFun1 ) +import Data.Array.Accelerate.Array.Sugar ( Arrays(..), ArraysR(..) ) +import Data.Array.Accelerate.CUDA.Array.Data +import Data.Array.Accelerate.CUDA.State +import Data.Array.Accelerate.CUDA.Compile +import Data.Array.Accelerate.CUDA.Execute + +#include "accelerate.h" + + +-- Accelerate: CUDA +-- ---------------- + +-- | Compile and run a complete embedded array program using the CUDA backend. +-- This will select the fastest device available on which to execute +-- computations, based on compute capability and estimated maximum GFLOPS. +-- +run :: Arrays a => Acc a -> a +run a + = unsafePerformIO + $ withMVar defaultContext $ \ctx -> evaluate (runIn ctx 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 only be active no 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 + $ withMVar defaultContext $ \ctx -> evaluate (runAsyncIn ctx a) + +-- | As 'run', but execute using the specified device context rather than using +-- the default, automatically selected device. +-- +-- Contexts passed to this function may all refer to the same device, or to +-- separate devices of differing compute capabilities. +-- +-- Note that each thread has a stack of current contexts, and calling +-- '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 +-- expression. See the CUDA C Programming Guide (G.1) for more information. +-- +runIn :: Arrays a => Context -> Acc a -> a +runIn ctx a + = unsafePerformIO + $ evaluate (runAsyncIn ctx a) >>= wait + + +-- | As 'runIn', 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 + where + acc = convertAcc a + execute = evalCUDA ctx (compileAcc acc >>= executeAcc >>= collect) + `catch` + \e -> INTERNAL_ERROR(error) "unhandled" (show (e :: CUDAException)) + + +-- | Prepare and execute an embedded array program of one argument. +-- +-- This function can be used to improve performance in cases where the array +-- program is constant between invocations, because it allows us to bypass all +-- front-end conversion stages and move directly to the execution phase. If you +-- have a computation applied repeatedly to different input data, use this. +-- +-- See the Crystal demo, part of the 'accelerate-examples' package, for an +-- example. +-- +run1 :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> b +run1 f + = unsafePerformIO + $ withMVar defaultContext $ \ctx -> evaluate (run1In ctx f) + + +-- | As 'run1', but the computation is executed asynchronously. +-- +run1Async :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> Async b +run1Async f + = unsafePerformIO + $ withMVar defaultContext $ \ctx -> evaluate (run1AsyncIn ctx f) + +-- | As 'run1', but execute in the specified context. +-- +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) + +-- | As 'run1In', but execute asynchronously. +-- +run1AsyncIn :: (Arrays a, Arrays b) => Context -> (Acc a -> Acc b) -> a -> Async b +run1AsyncIn ctx f = \a -> unsafePerformIO $ async (execute a) + where + acc = convertAccFun1 f + !afun = unsafePerformIO $ evalCUDA ctx (compileAfun1 acc) + execute a = evalCUDA ctx (executeAfun1 afun a >>= collect) + `catch` + \e -> INTERNAL_ERROR(error) "unhandled" (show (e :: CUDAException)) + +-- TLM: We need to be very careful with run1* variants, to ensure that the +-- returned closure shortcuts directly to the execution phase. + + +-- | Stream a lazily read list of input arrays through the given program, +-- collecting results as we go. +-- +stream :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> [a] -> [b] +stream f arrs + = unsafePerformIO + $ withMVar defaultContext $ \ctx -> evaluate (streamIn ctx f arrs) + +-- | 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 + + +-- Copy arrays from device to host. +-- +collect :: forall arrs. Arrays arrs => arrs -> CIO arrs +collect arrs = toArr <$> collectR (arrays (undefined :: arrs)) (fromArr arrs) + where + collectR :: ArraysR a -> a -> CIO a + collectR ArraysRunit () = return () + collectR ArraysRarray arr = peekArray arr >> return arr + collectR (ArraysRpair r1 r2) (arrs1, arrs2) = (,) <$> collectR r1 arrs1 + <*> collectR r2 arrs2 + + +-- Running asynchronously +-- ---------------------- + +-- 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 !ThreadId !(MVar (Either SomeException a)) + +-- Fork an action to execute asynchronously. +-- +-- TLM: +-- CUDA contexts are specific to the processor on which they were created. It +-- may be necessary to take this into account when forking accelerate +-- computations (forkOn rather than forkIO), either by always requiring a +-- specific CPU, and/or having the driver API store the processor ordinal when +-- creating contexts. +-- +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. +-- +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'. +-- +poll :: Async a -> IO (Maybe a) +poll (Async _ var) = + maybe (return Nothing) (either throwIO (return . Just)) =<< tryTakeMVar var + +-- | Cancel a running asynchronous computation. +-- +cancel :: Async a -> IO () +cancel (Async tid _) = throwTo tid ThreadKilled + -- TLM: catch and ignore exceptions? + -- silently do nothing if the thread has already finished? + diff --git a/Data/Array/Accelerate/CUDA/AST.hs b/Data/Array/Accelerate/CUDA/AST.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/AST.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE GADTs, FlexibleInstances, 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 +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-partable (GHC extensions) +-- + +module Data.Array.Accelerate.CUDA.AST ( + + module Data.Array.Accelerate.AST, + AccKernel(..), AccBindings(..), ArrayVar(..), ExecAcc, ExecAfun, ExecOpenAcc(..), + retag + +) where + +-- friends +import Data.Array.Accelerate.AST +import Data.Array.Accelerate.Pretty +import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt ) +import qualified Data.Array.Accelerate.CUDA.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 qualified Data.HashSet as Set + + +-- A non-empty list of binary objects will be used to execute a kernel. We keep +-- auxiliary information together with the compiled module, such as entry point +-- and execution information. +-- +data AccKernel a = Kernel String CUDA.Module CUDA.Fun CUDA.Occupancy (Int -> (Int,Int,Int)) + +-- The kernel lists are monomorphic, so sometimes we need to change the phantom +-- type of the object code. +-- +retag :: AccKernel a -> AccKernel b +retag (Kernel x m f o l) = Kernel x m f o l + + +-- Kernel execution is asynchronous, barriers allow (cross-stream) +-- synchronisation to determine when the operation has completed +-- +-- data AccBarrier = AB !Stream !Event + +-- Array computations that were embedded within scalar expressions, and will be +-- required to execute the kernel; i.e. bound to texture references or similar. +-- +newtype AccBindings aenv = AccBindings ( Set.HashSet (ArrayVar aenv) ) + +instance Monoid (AccBindings aenv) where + mempty = AccBindings ( Set.empty ) + AccBindings x `mappend` AccBindings y = AccBindings ( Set.union x y ) + +data ArrayVar aenv where + ArrayVar :: (Shape sh, Elt e) + => Idx aenv (Array sh e) + -> ArrayVar aenv + +instance Eq (ArrayVar aenv) where + ArrayVar ix1 == ArrayVar ix2 = idxToInt ix1 == idxToInt ix2 + +instance Hashable (ArrayVar aenv) where + hash (ArrayVar ix) = hash (idxToInt ix) + + +-- Interleave compilation & execution state annotations into an open array +-- computation AST +-- +data ExecOpenAcc aenv a where + ExecAcc :: FL.FullList () (AccKernel a) -- executable binary objects + -> AccBindings aenv -- auxiliary arrays from the environment the kernel needs access to + -> PreOpenAcc ExecOpenAcc aenv a -- the actual computation + -> ExecOpenAcc aenv a -- the recursive knot + +-- An annotated AST suitable for execution in the CUDA environment +-- +type ExecAcc a = ExecOpenAcc () a +type ExecAfun a = PreAfun ExecOpenAcc a + +instance Show (ExecOpenAcc aenv a) where + show = render . prettyExecAcc 0 noParens + +instance Show (ExecAfun a) where + show = render . prettyExecAfun 0 + + +-- Display the annotated AST +-- +prettyExecAfun :: Int -> ExecAfun a -> Doc +prettyExecAfun alvl pfun = prettyPreAfun prettyExecAcc alvl pfun + +prettyExecAcc :: PrettyAcc ExecOpenAcc +prettyExecAcc alvl wrap (ExecAcc _ (AccBindings fv) pacc) = + let base = prettyPreAcc prettyExecAcc alvl wrap pacc + ann = braces (freevars (Set.toList fv)) + freevars = (text "fv=" <>) . brackets . hcat . punctuate comma + . map (\(ArrayVar ix) -> char 'a' <> int (idxToInt ix)) + in case pacc of + Avar _ -> base + Alet _ _ -> base + Apply _ _ -> base + Acond _ _ _ -> base + Atuple _ -> base + Aprj _ _ -> base + _ -> ann <+> base + diff --git a/Data/Array/Accelerate/CUDA/Analysis/Device.hs b/Data/Array/Accelerate/CUDA/Analysis/Device.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/Analysis/Device.hs @@ -0,0 +1,53 @@ +-- | +-- 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 +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-partable (GHC extensions) +-- + +module Data.Array.Accelerate.CUDA.Analysis.Device + where + +import Data.Ord +import Data.List +import Data.Function +import Foreign.CUDA.Driver.Device +import qualified Foreign.CUDA.Driver as CUDA + + +-- Select the best of the available CUDA capable devices. This prefers devices +-- with higher compute capability, followed by maximum throughput. This does not +-- take into account any other factors, such as whether the device is currently +-- in use by another process. +-- +-- Ignore the possibility of emulation-mode devices, as this has been deprecated +-- as of CUDA v3.0 (compute-capability == 9999.9999) +-- +selectBestDevice :: IO (Device, DeviceProperties) +selectBestDevice = do + dev <- mapM CUDA.device . enumFromTo 0 . subtract 1 =<< CUDA.count + prop <- mapM CUDA.props dev + return . head . sortBy (flip cmp `on` snd) $ zip dev prop + where + compute = computeCapability + flops d = multiProcessorCount d * coresPerMultiProcessor d * clockRate d + cmp x y + | compute x == compute y = comparing flops x y + | otherwise = comparing compute x y + + +-- Number of CUDA cores per streaming multiprocessor for a given architecture +-- revision. This is the number of SIMD arithmetic units per multiprocessor, +-- executing in lockstep in half-warp groupings (16 ALUs). +-- +coresPerMultiProcessor :: DeviceProperties -> Int +coresPerMultiProcessor prp + | computeCapability prp < 2 = 8 + | computeCapability prp < 2.1 = 32 + | otherwise = 48 + + diff --git a/Data/Array/Accelerate/CUDA/Analysis/Launch.hs b/Data/Array/Accelerate/CUDA/Analysis/Launch.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/Analysis/Launch.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE CPP, GADTs #-} +-- | +-- 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 +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-partable (GHC extensions) +-- + +module Data.Array.Accelerate.CUDA.Analysis.Launch ( + + launchConfig, determineOccupancy + +) where + +-- friends +import Data.Array.Accelerate.AST +import Data.Array.Accelerate.Analysis.Type +import Data.Array.Accelerate.Analysis.Shape + +-- library +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 +-- of blocks, and dynamically allocated shared memory (bytes), respectively. +-- +-- For most operations, this selects the minimum block size that gives maximum +-- occupancy, and the grid size limited to the maximum number of physically +-- resident blocks. Hence, kernels may need to process multiple elements per +-- thread. Scan operations select the largest block size of maximum occupancy. +-- +launchConfig + :: OpenAcc aenv a + -> CUDA.DeviceProperties + -> CUDA.Occupancy -- kernel occupancy information + -> Int -- number of elements to configure for + -> (Int, Int, Int) +launchConfig (OpenAcc acc) dev occ = \n -> + let cta = CUDA.activeThreads occ `div` CUDA.activeThreadBlocks occ + maxGrid = CUDA.multiProcessorCount dev * CUDA.activeThreadBlocks occ + smem = sharedMem dev acc cta + in + (cta, maxGrid `min` gridSize dev acc n cta, smem) + + +-- | +-- Determine maximal occupancy statistics for the given kernel / device +-- combination. +-- +determineOccupancy + :: OpenAcc aenv a + -> CUDA.DeviceProperties + -> CUDA.Fun -- corresponding __global__ entry function + -> Int -- maximum number of threads per block + -> IO CUDA.Occupancy +determineOccupancy (OpenAcc acc) dev fn maxBlock = do + registers <- CUDA.requires fn CUDA.NumRegs + static_smem <- CUDA.requires fn CUDA.SharedSizeBytes -- static memory only + return . snd $ blockSize dev acc maxBlock registers (\threads -> static_smem + dynamic_smem threads) + where + dynamic_smem = sharedMem dev acc + + +-- | +-- Determine an optimal thread block size for a given array computation. Fold +-- requires blocks with a power-of-two number of threads. Scans select the +-- largest size thread block possible, because if only one thread block is +-- needed we can calculate the scan in a single pass, rather than three. +-- +blockSize + :: CUDA.DeviceProperties + -> PreOpenAcc OpenAcc aenv a + -> Int -- maximum number of threads per block + -> Int -- number of registers used + -> (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 + where + strategy = case acc of + Fold _ _ _ -> CUDA.decPow2 + Fold1 _ _ -> CUDA.decPow2 + Scanl _ _ _ -> CUDA.incWarp + Scanl' _ _ _ -> CUDA.incWarp + Scanl1 _ _ -> CUDA.incWarp + Scanr _ _ _ -> CUDA.incWarp + Scanr' _ _ _ -> CUDA.incWarp + 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 +-- thread for the various kernels. +-- +-- The 'size' parameter is typically the number of elements in the array, except +-- for the following instances: +-- +-- * foldSeg: the number of segments; require one warp per segment +-- +-- * fold: for multidimensional reductions, this is the size of the shape tail +-- for 1D reductions this is the total number of elements +-- +gridSize :: CUDA.DeviceProperties -> PreOpenAcc OpenAcc 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 accDim acc == 0 then split acc size cta else size +gridSize _ acc@(Fold1 _ _) size cta = if preAccDim accDim acc == 0 then split acc size cta else size +gridSize _ acc size cta = split acc size cta + +split :: PreOpenAcc OpenAcc aenv a -> Int -> Int -> Int +split acc size cta = (size `between` eltsPerThread acc) `between` cta + where + between arr n = 1 `max` ((n + arr - 1) `div` n) + eltsPerThread _ = 1 + + +-- | +-- Analyse the given array expression, returning an estimate of dynamic shared +-- memory usage as a function of thread block size. This can be used by the +-- occupancy calculator to optimise kernel launch shape. +-- +sharedMem :: CUDA.DeviceProperties -> PreOpenAcc OpenAcc 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 _ (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" + +-- skeleton nodes +sharedMem _ (Generate _ _) _ = 0 +sharedMem _ (Replicate _ _ _) _ = 0 +sharedMem _ (Index _ _ _) _ = 0 +sharedMem _ (Map _ _) _ = 0 +sharedMem _ (ZipWith _ _ _) _ = 0 +sharedMem _ (Permute _ _ _ _) _ = 0 +sharedMem _ (Backpermute _ _ _) _ = 0 +sharedMem _ (Stencil _ _ _) _ = 0 +sharedMem _ (Stencil2 _ _ _ _ _) _ = 0 +sharedMem _ (Fold _ _ a) blockDim = sizeOf (accType a) * blockDim +sharedMem _ (Fold1 _ a) blockDim = sizeOf (accType a) * blockDim +sharedMem _ (Scanl _ x _) blockDim = sizeOf (expType x) * blockDim +sharedMem _ (Scanr _ x _) blockDim = sizeOf (expType x) * blockDim +sharedMem _ (Scanl' _ x _) blockDim = sizeOf (expType x) * blockDim +sharedMem _ (Scanr' _ x _) blockDim = sizeOf (expType x) * blockDim +sharedMem _ (Scanl1 _ a) blockDim = sizeOf (accType a) * blockDim +sharedMem _ (Scanr1 _ a) blockDim = sizeOf (accType a) * blockDim +sharedMem p (FoldSeg _ _ a _) blockDim = + (blockDim `div` CUDA.warpSize p) * 8 + blockDim * sizeOf (accType a) +sharedMem p (Fold1Seg _ a _) blockDim = + (blockDim `div` CUDA.warpSize p) * 8 + blockDim * sizeOf (accType a) + diff --git a/Data/Array/Accelerate/CUDA/Array/Data.hs b/Data/Array/Accelerate/CUDA/Array/Data.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/Array/Data.hs @@ -0,0 +1,315 @@ +{-# LANGUAGE CPP, GADTs, TypeFamilies, ScopedTypeVariables #-} +-- | +-- Module : Data.Array.Accelerate.CUDA.Array.Data +-- 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 +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.CUDA.Array.Data ( + + -- * Array operations and representations + mallocArray, indexArray, copyArray, + useArray, useArrayAsync, + peekArray, peekArrayAsync, + pokeArray, pokeArrayAsync, + marshalArrayData, marshalTextureData, marshalDevicePtrs, + devicePtrsOfArrayData, advancePtrsOfArrayData, + + -- * Garbage collection + cleanupArrayData + +) where + +-- libraries +import Prelude hiding (fst, snd) +import Data.Label.PureM +import Control.Applicative +import Control.Monad.Trans + +-- friends +import Data.Array.Accelerate.Array.Data +import Data.Array.Accelerate.Array.Sugar (Array(..), Shape, Elt, fromElt, toElt) +import Data.Array.Accelerate.Array.Representation (size, index) +import Data.Array.Accelerate.CUDA.State +import Data.Array.Accelerate.CUDA.Array.Table +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 +-- ---------------- + +-- Garbage collection +-- +cleanupArrayData :: CIO () +cleanupArrayData = liftIO . reclaim =<< gets memoryTable + +-- Array tuple extraction +-- +fst :: ArrayData (a,b) -> ArrayData a +fst = fstArrayData + +snd :: ArrayData (a,b) -> ArrayData b +snd = sndArrayData + +-- CPP hackery to generate the cases where we dispatch to the worker function handling +-- elementary types. +-- +#define mkPrimDispatch(dispatcher,worker) \ +; dispatcher ArrayEltRint = worker \ +; dispatcher ArrayEltRint8 = worker \ +; dispatcher ArrayEltRint16 = worker \ +; dispatcher ArrayEltRint32 = worker \ +; dispatcher ArrayEltRint64 = worker \ +; dispatcher ArrayEltRword = worker \ +; dispatcher ArrayEltRword8 = worker \ +; dispatcher ArrayEltRword16 = worker \ +; dispatcher ArrayEltRword32 = worker \ +; dispatcher ArrayEltRword64 = worker \ +; dispatcher ArrayEltRfloat = worker \ +; dispatcher ArrayEltRdouble = worker \ +; dispatcher ArrayEltRbool = error "mkPrimDispatcher: ArrayEltRbool" \ +; dispatcher ArrayEltRchar = error "mkPrimDispatcher: ArrayEltRchar" \ +; dispatcher _ = error "mkPrimDispatcher: not primitive" + + +-- |Allocate a new device array to accompany the given host-side array. +-- +mallocArray :: (Shape dim, Elt e) => Array dim e -> CIO () +mallocArray (Array sh adata) = doMalloc =<< gets memoryTable + where + doMalloc mt = liftIO $ mallocR arrayElt adata + where + mallocR :: ArrayEltR e -> ArrayData e -> IO () + mallocR ArrayEltRunit _ = return () + mallocR (ArrayEltRpair aeR1 aeR2) ad = mallocR aeR1 (fst ad) >> mallocR aeR2 (snd ad) + mallocR aer ad = mallocPrim aer mt ad (size sh) + -- + mallocPrim :: ArrayEltR e -> MemoryTable -> ArrayData e -> Int -> IO () + mkPrimDispatch(mallocPrim,Prim.mallocArray) + + +-- |Upload an existing array to the device +-- +useArray :: (Shape dim, Elt e) => Array dim e -> CIO () +useArray (Array sh adata) = doUse =<< gets memoryTable + where + doUse mt = liftIO $ useR arrayElt adata + where + useR :: ArrayEltR e -> ArrayData e -> IO () + useR ArrayEltRunit _ = return () + useR (ArrayEltRpair aeR1 aeR2) ad = useR aeR1 (fst ad) >> useR aeR2 (snd ad) + useR aer ad = usePrim aer mt ad (size sh) + -- + usePrim :: ArrayEltR e -> MemoryTable -> ArrayData e -> Int -> IO () + mkPrimDispatch(usePrim,Prim.useArray) + +useArrayAsync :: (Shape dim, Elt e) => Array dim e -> Maybe CUDA.Stream -> CIO () +useArrayAsync (Array sh adata) ms = doUse =<< gets memoryTable + where + doUse mt = liftIO $ useR arrayElt adata + where + useR :: ArrayEltR e -> ArrayData e -> IO () + useR ArrayEltRunit _ = return () + useR (ArrayEltRpair aeR1 aeR2) ad = useR aeR1 (fst ad) >> useR aeR2 (snd ad) + useR aer ad = usePrim aer mt ad (size sh) ms + -- + usePrim :: ArrayEltR e -> MemoryTable -> ArrayData e -> Int -> Maybe CUDA.Stream -> IO () + mkPrimDispatch(usePrim,Prim.useArrayAsync) + + +-- |Read a single element from an array at the given row-major index. This is a +-- synchronous operation. +-- +indexArray :: (Shape dim, Elt e) => Array dim e -> dim -> CIO e +indexArray (Array sh adata) ix = doIndex =<< gets memoryTable + where + i = index sh (fromElt ix) + doIndex mt = toElt <$> (liftIO $ indexR arrayElt adata) + where + indexR :: ArrayEltR e -> ArrayData e -> IO e + indexR ArrayEltRunit _ = return () + indexR (ArrayEltRpair aeR1 aeR2) ad = (,) <$> indexR aeR1 (fst ad) + <*> indexR aeR2 (snd ad) + indexR aer ad = indexPrim aer mt ad i + -- + indexPrim :: ArrayEltR e -> MemoryTable -> ArrayData e -> Int -> IO e + mkPrimDispatch(indexPrim,Prim.indexArray) + + +-- |Copy data between two device arrays. The operation is asynchronous with +-- respect to the host, but will never overlap kernel execution. +-- +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) + $ doCopy =<< gets memoryTable + where + doCopy mt = liftIO $ 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 mt ad1 ad2 (size sh1) + -- + copyPrim :: ArrayEltR e -> MemoryTable -> ArrayData e -> ArrayData e -> Int -> IO () + mkPrimDispatch(copyPrim,Prim.copyArray) + + +-- Copy data from the device into the associated Accelerate host-side array +-- +peekArray :: (Shape dim, Elt e) => Array dim e -> CIO () +peekArray (Array sh adata) = doPeek =<< gets memoryTable + where + doPeek mt = liftIO $ peekR arrayElt adata + where + peekR :: ArrayEltR e -> ArrayData e -> IO () + peekR ArrayEltRunit _ = return () + peekR (ArrayEltRpair aeR1 aeR2) ad = peekR aeR1 (fst ad) >> peekR aeR2 (snd ad) + peekR aer ad = peekPrim aer mt ad (size sh) + -- + peekPrim :: ArrayEltR e -> MemoryTable -> ArrayData e -> Int -> IO () + mkPrimDispatch(peekPrim,Prim.peekArray) + +peekArrayAsync :: (Shape dim, Elt e) => Array dim e -> Maybe CUDA.Stream -> CIO () +peekArrayAsync (Array sh adata) ms = doPeek =<< gets memoryTable + where + doPeek mt = liftIO $ peekR arrayElt adata + where + peekR :: ArrayEltR e -> ArrayData e -> IO () + peekR ArrayEltRunit _ = return () + peekR (ArrayEltRpair aeR1 aeR2) ad = peekR aeR1 (fst ad) >> peekR aeR2 (snd ad) + peekR aer ad = peekPrim aer mt ad (size sh) ms + -- + peekPrim :: ArrayEltR e -> MemoryTable -> ArrayData e -> Int -> Maybe CUDA.Stream -> IO () + mkPrimDispatch(peekPrim,Prim.peekArrayAsync) + + +-- Copy data from an Accelerate array into the associated device array +-- +pokeArray :: (Shape dim, Elt e) => Array dim e -> CIO () +pokeArray (Array sh adata) = doPoke =<< gets memoryTable + where + doPoke mt = liftIO $ pokeR arrayElt adata + where + pokeR :: ArrayEltR e -> ArrayData e -> IO () + pokeR ArrayEltRunit _ = return () + pokeR (ArrayEltRpair aeR1 aeR2) ad = pokeR aeR1 (fst ad) >> pokeR aeR2 (snd ad) + pokeR aer ad = pokePrim aer mt ad (size sh) + -- + pokePrim :: ArrayEltR e -> MemoryTable -> ArrayData e -> Int -> IO () + mkPrimDispatch(pokePrim,Prim.pokeArray) + +pokeArrayAsync :: (Shape dim, Elt e) => Array dim e -> Maybe CUDA.Stream -> CIO () +pokeArrayAsync (Array sh adata) ms = doPoke =<< gets memoryTable + where + doPoke mt = liftIO $ pokeR arrayElt adata + where + pokeR :: ArrayEltR e -> ArrayData e -> IO () + pokeR ArrayEltRunit _ = return () + pokeR (ArrayEltRpair aeR1 aeR2) ad = pokeR aeR1 (fst ad) >> pokeR aeR2 (snd ad) + pokeR aer ad = pokePrim aer mt ad (size sh) ms + -- + pokePrim :: ArrayEltR e -> MemoryTable -> ArrayData e -> Int -> Maybe CUDA.Stream -> IO () + mkPrimDispatch(pokePrim,Prim.pokeArrayAsync) + + +-- |Wrap device pointers into arguments that can be passed to a kernel +-- invocation +-- +marshalDevicePtrs :: ArrayElt e => ArrayData e -> Prim.DevicePtrs e -> [CUDA.FunParam] +marshalDevicePtrs adata = marshalR arrayElt adata + where + marshalR :: ArrayEltR e -> ArrayData e -> Prim.DevicePtrs e -> [CUDA.FunParam] + marshalR ArrayEltRunit _ _ = [] + marshalR (ArrayEltRpair aeR1 aeR2) ad (p1,p2) = marshalR aeR1 (fst ad) p1 ++ + marshalR aeR2 (snd ad) p2 + marshalR aer ad ptr = [marshalPrim aer ad ptr] + -- + marshalPrim :: ArrayEltR e -> ArrayData e -> Prim.DevicePtrs e -> CUDA.FunParam + mkPrimDispatch(marshalPrim,Prim.marshalDevicePtrs) + + +-- |Wrap the device pointers corresponding to a host-side array into arguments +-- that can be passed to a kernel upon invocation. +-- +marshalArrayData :: ArrayElt e => ArrayData e -> CIO [CUDA.FunParam] +marshalArrayData adata = doMarshal =<< gets memoryTable + where + doMarshal mt = liftIO $ marshalR arrayElt adata + where + marshalR :: ArrayEltR e -> ArrayData e -> 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 mt ad + -- + marshalPrim :: ArrayEltR e -> MemoryTable -> ArrayData e -> IO CUDA.FunParam + 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 +-- +marshalTextureData :: ArrayElt e => ArrayData e -> Int -> [CUDA.Texture] -> CIO () +marshalTextureData adata n texs = doMarshal =<< gets memoryTable + where + doMarshal mt = liftIO $ marshalR arrayElt adata texs >> return () + where + marshalR :: ArrayEltR e -> ArrayData e -> [CUDA.Texture] -> IO Int + 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) + marshalR aer ad t + = do marshalPrim aer mt ad n (head t) + return 1 + -- + marshalPrim :: ArrayEltR e -> MemoryTable -> ArrayData e -> Int -> CUDA.Texture -> IO () + mkPrimDispatch(marshalPrim,Prim.marshalTextureData) + + +-- |Raw device pointers associated with a host-side array +-- +devicePtrsOfArrayData :: ArrayElt e => ArrayData e -> CIO (Prim.DevicePtrs e) +devicePtrsOfArrayData adata = ptrs =<< gets memoryTable + where + ptrs mt = liftIO $ ptrsR arrayElt adata + where + ptrsR :: ArrayEltR e -> ArrayData e -> 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 mt ad + -- + ptrsPrim :: ArrayEltR e -> MemoryTable -> ArrayData e -> IO (Prim.DevicePtrs e) + mkPrimDispatch(ptrsPrim,Prim.devicePtrsOfArrayData) + + +-- |Advance a set of device pointers by the given number of elements each +-- +advancePtrsOfArrayData :: ArrayElt e => ArrayData e -> Int -> Prim.DevicePtrs e -> Prim.DevicePtrs e +advancePtrsOfArrayData adata n = advanceR arrayElt adata + where + advanceR :: ArrayEltR e -> ArrayData e -> Prim.DevicePtrs e -> Prim.DevicePtrs e + advanceR ArrayEltRunit _ _ = () + advanceR (ArrayEltRpair aeR1 aeR2) ad (p1,p2) = (advanceR aeR1 (fst ad) p1 + ,advanceR aeR2 (snd ad) p2) + advanceR aer ad ptr = advancePrim aer ad ptr + -- + advancePrim :: ArrayEltR e -> ArrayData e -> Prim.DevicePtrs e -> Prim.DevicePtrs e + mkPrimDispatch(advancePrim,Prim.advancePtrsOfArrayData n) + + diff --git a/Data/Array/Accelerate/CUDA/Array/Prim.hs b/Data/Array/Accelerate/CUDA/Array/Prim.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/Array/Prim.hs @@ -0,0 +1,373 @@ +{-# LANGUAGE BangPatterns, CPP, GADTs, TypeFamilies, ScopedTypeVariables #-} +-- | +-- Module : Data.Array.Accelerate.CUDA.Array.Prim +-- 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 +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.CUDA.Array.Prim ( + + DevicePtrs, HostPtrs, + + mallocArray, useArray, useArrayAsync, indexArray, copyArray, peekArray, peekArrayAsync, + pokeArray, pokeArrayAsync, marshalDevicePtrs, marshalArrayData, marshalTextureData, + devicePtrsOfArrayData, advancePtrsOfArrayData + +) where + +-- libraries +import Prelude hiding (catch, lookup) +import Data.Int +import Data.Word +import Data.Maybe +import Data.Functor +import Data.Typeable +import Control.Monad +import Control.Exception +import System.Mem.StableName +import Foreign.Ptr +import Foreign.Storable +import Foreign.Marshal.Alloc +import Foreign.CUDA.Driver.Error +import qualified Foreign.CUDA.Driver as CUDA +import qualified Foreign.CUDA.Driver.Stream as CUDA +import qualified Foreign.CUDA.Driver.Texture as CUDA + +-- friends +import Data.Array.Accelerate.Array.Data +import Data.Array.Accelerate.CUDA.Array.Table +import qualified Data.Array.Accelerate.CUDA.Debug as D + +#include "accelerate.h" + + +-- Device array representation +-- --------------------------- + +type family DevicePtrs e :: * +type family HostPtrs e :: * + +type instance DevicePtrs () = () +type instance HostPtrs () = () + +#define primArrayElt(ty) \ +type instance DevicePtrs ty = CUDA.DevicePtr ty ; \ +type instance HostPtrs ty = CUDA.HostPtr ty ; \ + +primArrayElt(Int) +primArrayElt(Int8) +primArrayElt(Int16) +primArrayElt(Int32) +primArrayElt(Int64) + +primArrayElt(Word) +primArrayElt(Word8) +primArrayElt(Word16) +primArrayElt(Word32) +primArrayElt(Word64) + +-- FIXME: +-- CShort +-- CUShort +-- CInt +-- CUInt +-- CLong +-- CULong +-- CLLong +-- CULLong + +primArrayElt(Float) +primArrayElt(Double) + +-- FIXME: +-- CFloat +-- CDouble + +-- FIXME: +-- No concrete implementation in Data.Array.Accelerate.Array.Data +-- +type instance HostPtrs Bool = () +type instance DevicePtrs Bool = () + +type instance HostPtrs Char = () +type instance DevicePtrs Char = () + +-- FIXME: +-- CChar +-- CSChar +-- CUChar + +type instance DevicePtrs (a,b) = (DevicePtrs a, DevicePtrs b) +type instance HostPtrs (a,b) = (HostPtrs a, HostPtrs b) + + + +-- Texture References +-- ------------------ + +-- This representation must match the code generator's understanding of how to +-- utilise the texture cache. +-- +class TextureData a where + format :: a -> (CUDA.Format, Int) + +instance TextureData Int8 where format _ = (CUDA.Int8, 1) +instance TextureData Int16 where format _ = (CUDA.Int16, 1) +instance TextureData Int32 where format _ = (CUDA.Int32, 1) +instance TextureData Int64 where format _ = (CUDA.Int32, 2) +instance TextureData Word8 where format _ = (CUDA.Word8, 1) +instance TextureData Word16 where format _ = (CUDA.Word16, 1) +instance TextureData Word32 where format _ = (CUDA.Word32, 1) +instance TextureData Word64 where format _ = (CUDA.Word32, 2) +instance TextureData Float where format _ = (CUDA.Float, 1) +instance TextureData Double where format _ = (CUDA.Int32, 2) + +instance TextureData Int where + format _ = case sizeOf (undefined :: Int) of + 4 -> (CUDA.Int32, 1) + 8 -> (CUDA.Int32, 2) + _ -> error "we can never get here" + +instance TextureData Word where + format _ = case sizeOf (undefined :: Word) of + 4 -> (CUDA.Word32, 1) + 8 -> (CUDA.Word32, 2) + _ -> error "we can never get here" + + + +-- Primitive array operations +-- -------------------------- + +-- Allocate a device-side array associated with the given host array. If the +-- allocation fails due to a lack of memory, run the garbage collector to +-- release any inaccessible arrays and try again. +-- +mallocArray + :: forall e a. (ArrayElt e, DevicePtrs e ~ CUDA.DevicePtr a, Typeable e, Typeable a, Storable a) + => MemoryTable + -> ArrayData e + -> Int + -> IO () +mallocArray !mt !ad !n0 = do + let !n = 1 `max` n0 + exists <- isJust <$> (lookup mt ad :: IO (Maybe (CUDA.DevicePtr a))) + unless exists $ do + message $ "mallocArray: " ++ showBytes (n * sizeOf (undefined::a)) + ptr <- CUDA.mallocArray n `catch` \(e :: CUDAException) -> + case e of + ExitCode OutOfMemory -> reclaim mt >> CUDA.mallocArray n + _ -> throwIO e + insert mt ad (ptr :: CUDA.DevicePtr a) + + +-- 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) + => MemoryTable + -> ArrayData e + -> Int + -> IO () +useArray !mt !ad !n0 = + let src = ptrsOfArrayData ad + !n = 1 `max` n0 + in do + exists <- isJust <$> (lookup mt ad :: IO (Maybe (CUDA.DevicePtr a))) + unless exists $ do + message $ "useArray/malloc: " ++ showBytes (n * sizeOf (undefined::a)) + dst <- CUDA.mallocArray n `catch` \(e :: CUDAException) -> + case e of + ExitCode OutOfMemory -> reclaim mt >> CUDA.mallocArray n + _ -> throwIO e + CUDA.pokeArray n src dst + insert mt ad dst + + +useArrayAsync + :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr a, Typeable e, Typeable a, Storable a) + => MemoryTable + -> ArrayData e + -> Int + -> Maybe CUDA.Stream + -> IO () +useArrayAsync !mt !ad !n0 !ms = + let src = CUDA.HostPtr (ptrsOfArrayData ad) + !n = 1 `max` n0 + in do + exists <- isJust <$> (lookup mt ad :: IO (Maybe (CUDA.DevicePtr a))) + unless exists $ do + message $ "useArrayAsync/malloc: " ++ showBytes (n * sizeOf (undefined::a)) + dst <- CUDA.mallocArray n `catch` \(e :: CUDAException) -> + case e of + ExitCode OutOfMemory -> reclaim mt >> CUDA.mallocArray n + _ -> throwIO e + CUDA.pokeArrayAsync n src dst ms + insert mt ad dst + + +-- Read a single element from an array at the given row-major index +-- +indexArray + :: (ArrayElt e, DevicePtrs e ~ CUDA.DevicePtr b, Typeable e, Typeable b, Storable b) + => MemoryTable + -> ArrayData e + -> Int + -> IO b +indexArray !mt !ad !i = + alloca $ \dst -> + devicePtrsOfArrayData mt ad >>= \src -> do + CUDA.peekArray 1 (src `CUDA.advanceDevPtr` i) dst + peek dst + + +-- Copy data between two device arrays. The operation is asynchronous with +-- respect to the host, but will never overlap kernel execution. +-- +copyArray + :: (ArrayElt e, ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr b, Typeable a, Typeable b, Typeable e, Storable b) + => MemoryTable + -> ArrayData e -- source array + -> ArrayData e -- destination array + -> Int -- number of array elements + -> IO () +copyArray !mt !from !to !n = do + src <- devicePtrsOfArrayData mt from + dst <- devicePtrsOfArrayData mt to + CUDA.copyArrayAsync n src dst + + +-- Copy data from the device into the associated Accelerate host-side array +-- +peekArray + :: (ArrayElt e, ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr a, Typeable a, Typeable e, Storable a) + => MemoryTable + -> ArrayData e + -> Int + -> IO () +peekArray !mt !ad !n = + devicePtrsOfArrayData mt ad >>= \src -> + CUDA.peekArray n src (ptrsOfArrayData ad) + +peekArrayAsync + :: (ArrayElt e, ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr a, Typeable a, Typeable e, Storable a) + => MemoryTable + -> ArrayData e + -> Int + -> Maybe CUDA.Stream + -> IO () +peekArrayAsync !mt !ad !n !st = + devicePtrsOfArrayData mt ad >>= \src -> + CUDA.peekArrayAsync n src (CUDA.HostPtr $ ptrsOfArrayData ad) st + + +-- Copy data from an Accelerate array into the associated device array +-- +pokeArray + :: (ArrayElt e, ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr a, Typeable a, Typeable e, Storable a) + => MemoryTable + -> ArrayData e + -> Int + -> IO () +pokeArray !mt !ad !n = + devicePtrsOfArrayData mt ad >>= \dst -> + CUDA.pokeArray n (ptrsOfArrayData ad) dst + +pokeArrayAsync + :: (ArrayElt e, ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr a, Typeable a, Typeable e, Storable a) + => MemoryTable + -> ArrayData e + -> Int + -> Maybe CUDA.Stream + -> IO () +pokeArrayAsync !mt !ad !n !st = + devicePtrsOfArrayData mt ad >>= \dst -> + CUDA.pokeArrayAsync n (CUDA.HostPtr $ ptrsOfArrayData ad) dst st + + +-- Marshal device pointers to arguments that can be passed to kernel invocation +-- +marshalDevicePtrs + :: (ArrayElt e, DevicePtrs e ~ CUDA.DevicePtr b) + => ArrayData e + -> DevicePtrs e + -> CUDA.FunParam +marshalDevicePtrs !_ !ptr = CUDA.VArg ptr + + +-- Wrap a device pointer corresponding corresponding to a host-side array into +-- arguments that can be passed to a kernel upon invocation +-- +marshalArrayData + :: (ArrayElt e, DevicePtrs e ~ CUDA.DevicePtr b, Typeable b, Typeable e) + => MemoryTable + -> ArrayData e + -> IO CUDA.FunParam +marshalArrayData !mt !ad = marshalDevicePtrs ad <$> devicePtrsOfArrayData mt ad + + +-- Bind device memory to the given texture reference, setting appropriate type +-- +marshalTextureData + :: forall a e. (ArrayElt e, DevicePtrs e ~ CUDA.DevicePtr a, Typeable a, Typeable e, Storable a, TextureData a) + => MemoryTable + -> ArrayData e -- host array + -> Int -- number of elements + -> CUDA.Texture -- texture reference to bind array to + -> IO () +marshalTextureData !mt !ad !n !tex = + let (fmt, c) = format (undefined :: a) + in devicePtrsOfArrayData mt ad >>= \ptr -> do + CUDA.setFormat tex fmt c + CUDA.bind tex ptr (fromIntegral $ n * sizeOf (undefined :: a)) + + +-- Lookup the device memory associated with our host array +-- +devicePtrsOfArrayData + :: (ArrayElt e, DevicePtrs e ~ CUDA.DevicePtr b, Typeable e, Typeable b) + => MemoryTable + -> ArrayData e + -> IO (DevicePtrs e) +devicePtrsOfArrayData !mt !ad = do + mv <- lookup mt ad + case mv of + Just v -> return v + Nothing -> do + sn <- makeStableName ad + INTERNAL_ERROR(error) "devicePtrsOfArrayData" $ "lost device memory #" ++ show (hashStableName sn) + + +-- Advance device pointers by a given number of elements +-- +advancePtrsOfArrayData + :: (ArrayElt e, DevicePtrs e ~ CUDA.DevicePtr b, Storable b) + => Int + -> ArrayData e + -> DevicePtrs e + -> DevicePtrs e +advancePtrsOfArrayData !n !_ !ptr = CUDA.advanceDevPtr ptr n + + +-- 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 () + diff --git a/Data/Array/Accelerate/CUDA/Array/Sugar.hs b/Data/Array/Accelerate/CUDA/Array/Sugar.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/Array/Sugar.hs @@ -0,0 +1,44 @@ +-- | +-- 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 +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.CUDA.Array.Sugar ( + + module Data.Array.Accelerate.Array.Sugar, + newArray, allocateArray, useArray + +) where + +import Data.Array.Accelerate.CUDA.State +import Data.Array.Accelerate.CUDA.Array.Data +import Data.Array.Accelerate.Array.Sugar hiding (newArray, 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 + in do + useArray arr + return arr + + +-- 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 + diff --git a/Data/Array/Accelerate/CUDA/Array/Table.hs b/Data/Array/Accelerate/CUDA/Array/Table.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/Array/Table.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE BangPatterns, CPP, GADTs, PatternGuards #-} +-- | +-- 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 +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.CUDA.Array.Table ( + + -- Tables for host/device memory associations + MemoryTable, new, lookup, insert, reclaim + +) where + +import Prelude hiding ( lookup ) +import Data.IORef ( IORef, newIORef, readIORef, mkWeakIORef ) +import Data.Maybe ( isJust ) +import Data.Hashable ( Hashable(..) ) +import Data.Typeable ( Typeable, gcast ) +import Control.Monad ( unless ) +import Control.Exception ( bracket_ ) +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.CUDA.Ptr ( DevicePtr ) + +import qualified Foreign.CUDA.Driver as CUDA +import qualified Data.HashTable.IO as HT + +import Data.Array.Accelerate.Array.Data ( ArrayData ) +import qualified Data.Array.Accelerate.CUDA.Debug as D ( message, dump_gc ) + +#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 = IORef ( HashTable HostArray DeviceArray ) +data MemoryTable = MemoryTable {-# UNPACK #-} !MT + {-# UNPACK #-} !(Weak MT) + + +data HostArray where + HostArray :: Typeable e + => {-# UNPACK #-} !CUDA.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 + hash (HostArray (CUDA.Context p) sn) = + fromIntegral (ptrToIntPtr p) `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 + tbl <- HT.new + ref <- newIORef tbl + weak <- mkWeakIORef ref (table_finalizer tbl) + return $! MemoryTable ref weak + + +-- Look for the device memory corresponding to a given host-side array. +-- +lookup :: (Typeable a, Typeable b) => MemoryTable -> ArrayData a -> IO (Maybe (DevicePtr b)) +lookup (MemoryTable ref _) !arr = do + sa <- makeStableArray arr + mw <- withIORef 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" + Nothing -> + makeStableArray arr >>= \x -> INTERNAL_ERROR(error) "lookup" $ "dead weak pair: " ++ show x + + +-- 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) => MemoryTable -> ArrayData a -> DevicePtr b -> IO () +insert (MemoryTable ref weak_ref) !arr !ptr = do + key <- makeStableArray arr + dev <- DeviceArray `fmap` mkWeak arr ptr (Just $ finalizer weak_ref key ptr) + tbl <- readIORef ref + message $ "insert: " ++ show key + 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) = do + trace "reclaim" performGC + mr <- deRefWeak weak_ref + case mr of + Nothing -> return () + Just ref -> withIORef ref $ \tbl -> + flip HT.mapM_ tbl $ \(_,DeviceArray w) -> do + alive <- isJust `fmap` deRefWeak w + unless alive $ finalize w + + +-- 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 MT -> HostArray -> DevicePtr b -> IO () +finalizer !weak_ref !key@(HostArray ctx _) !ptr = do + mr <- deRefWeak weak_ref + case mr of + Nothing -> trace ("finalise/dead table: " ++ show key) $ return () + Just ref -> trace ("finalise: " ++ show key) $ withIORef ref (`HT.delete` key) + -- + bracket_ + (CUDA.push ctx) + (CUDA.pop) + (CUDA.free ptr) + + +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 => ArrayData a -> IO HostArray +makeStableArray !arr = HostArray <$> CUDA.get <*> makeStableName arr + +{-# INLINE withIORef #-} +withIORef :: IORef a -> (a -> IO b) -> IO b +withIORef ref f = readIORef ref >>= f + + +-- 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 () + diff --git a/Data/Array/Accelerate/CUDA/CodeGen.hs b/Data/Array/Accelerate/CUDA/CodeGen.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/CodeGen.hs @@ -0,0 +1,643 @@ +{-# LANGUAGE CPP, GADTs, PatternGuards, ScopedTypeVariables, QuasiQuotes #-} +-- | +-- 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 +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.CUDA.CodeGen ( + + CUTranslSkel, codegenAcc + +) where + +-- libraries +import Prelude hiding ( exp ) +import Data.Loc +import Data.Char +import Control.Monad +import Control.Applicative hiding ( Const ) +import Text.PrettyPrint.Mainland +import Language.C.Syntax ( Const(..) ) +import Language.C.Quote.CUDA +import qualified Data.HashSet as Set +import qualified Language.C as C +import qualified Foreign.CUDA.Analysis as CUDA + +-- friends +import Data.Array.Accelerate.Type +import Data.Array.Accelerate.Tuple +import Data.Array.Accelerate.Pretty () +import Data.Array.Accelerate.Analysis.Shape +import Data.Array.Accelerate.Array.Representation +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.Base +import Data.Array.Accelerate.CUDA.CodeGen.Type +import Data.Array.Accelerate.CUDA.CodeGen.Monad +import Data.Array.Accelerate.CUDA.CodeGen.Mapping +import Data.Array.Accelerate.CUDA.CodeGen.IndexSpace +import Data.Array.Accelerate.CUDA.CodeGen.PrefixSum +import Data.Array.Accelerate.CUDA.CodeGen.Reduction +import Data.Array.Accelerate.CUDA.CodeGen.Stencil + +#include "accelerate.h" + + +data Val env where + Empty :: Val () + Push :: Val env -> [C.Exp] -> Val (env, s) + +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" + + +-- Array expressions +-- ----------------- + +-- | Instantiate an array computation with a set of concrete function and type +-- definitions to fix the parameters of an algorithmic skeleton. The generated +-- code can then be pretty-printed to file, and compiled to object code +-- executable on the device. +-- +-- The code generator needs to include binding points for array references from +-- scalar code. We require that the only array form allowed within expressions +-- are array variables. +-- +-- TODO: include a measure of how much shared memory a kernel requires. +-- +codegenAcc :: forall aenv a. + CUDA.DeviceProperties + -> OpenAcc aenv a + -> AccBindings aenv + -> CUTranslSkel +codegenAcc dev acc (AccBindings vars) = CUTranslSkel entry (extras : fvars code) + where + fvars rest = Set.foldr (\v vs -> liftAcc acc v ++ vs) rest vars + extras = [cedecl| $esc:("#include ") |] + CUTranslSkel entry code = codegen acc + + codegen :: OpenAcc aenv a -> CUTranslSkel + codegen (OpenAcc pacc) = case pacc of + -- + -- Non-computation forms + -- + Alet _ _ -> internalError + Avar _ -> internalError + Apply _ _ -> internalError + Acond _ _ _ -> internalError + Atuple _ -> internalError + Aprj _ _ -> internalError + Use _ -> internalError + Unit _ -> internalError + Reshape _ _ -> internalError + + -- + -- Skeleton nodes + -- + Generate _ f -> mkGenerate (accDim acc) (codegenFun f) + + Replicate sl _ a -> mkReplicate dimSl dimOut (extend sl) (undefined :: a) + where + dimSl = accDim a + dimOut = accDim acc + -- + extend :: SliceIndex slix sl co dim -> CUExp dim + extend = CUExp [] . reverse . extend' 0 + + extend' :: Int -> SliceIndex slix sl co dim -> [C.Exp] + extend' _ (SliceNil) = [] + extend' n (SliceAll sliceIdx) = mkPrj dimOut "dim" n : extend' (n+1) sliceIdx + extend' n (SliceFixed sliceIdx) = extend' (n+1) sliceIdx + + Index sl a slix -> mkSlice dimSl dimCo dimIn0 (restrict sl) (undefined :: a) + where + dimCo = length (expType slix) + dimSl = accDim acc + dimIn0 = accDim a + -- + restrict :: SliceIndex slix sl co dim -> CUExp slix + restrict = CUExp [] . reverse . restrict' (0,0) + + restrict' :: (Int,Int) -> SliceIndex slix sl co dim -> [C.Exp] + restrict' _ (SliceNil) = [] + restrict' (m,n) (SliceAll sliceIdx) = mkPrj dimSl "sl" n : restrict' (m,n+1) sliceIdx + restrict' (m,n) (SliceFixed sliceIdx) = mkPrj dimCo "co" m : restrict' (m+1,n) sliceIdx + + Map f _ -> mkMap (codegenFun f) + ZipWith f _ _ -> mkZipWith (accDim acc) (codegenFun f) + + Fold f e _ -> + if accDim acc == 0 + then mkFoldAll dev (codegenFun f) (Just (codegenExp e)) + else mkFold dev (codegenFun f) (Just (codegenExp e)) + + Fold1 f _ -> + if accDim acc == 0 + then mkFoldAll dev (codegenFun f) Nothing + else mkFold dev (codegenFun f) Nothing + + FoldSeg f e _ s -> mkFoldSeg dev (accDim acc) (segmentsType s) (codegenFun f) (Just (codegenExp e)) + Fold1Seg f _ s -> mkFoldSeg dev (accDim acc) (segmentsType s) (codegenFun f) Nothing + + Scanl f e _ -> mkScanl dev (codegenFun f) (Just (codegenExp e)) + Scanl' f e _ -> mkScanl dev (codegenFun f) (Just (codegenExp e)) + Scanl1 f _ -> mkScanl dev (codegenFun f) Nothing + + Scanr f e _ -> mkScanr dev (codegenFun f) (Just (codegenExp e)) + Scanr' f e _ -> mkScanr dev (codegenFun f) (Just (codegenExp e)) + Scanr1 f _ -> mkScanr dev (codegenFun f) Nothing + + Permute f _ ix a -> mkPermute dev (accDim acc) (accDim a) (codegenFun f) (codegenFun ix) + Backpermute _ f a -> mkBackpermute (accDim acc) (accDim a) (codegenFun f) (undefined :: a) + + Stencil f b0 a0 -> mkStencil (accDim acc) (codegenFun f) (codegenBoundary a0 b0) (undefined :: a) + Stencil2 f b1 a1 b0 a0 + -> mkStencil2 (accDim acc) (codegenFun f) (codegenBoundary a1 b1) (codegenBoundary a0 b0) (undefined :: a) + + -- + -- caffeine and misery + -- + internalError = + let msg = unlines ["unsupported array primitive", pretty 100 (nest 2 doc)] + pac = show acc + doc | length pac <= 250 = text pac + | otherwise = text (take 250 pac) <+> text "... {truncated}" + in + INTERNAL_ERROR(error) "codegenAcc" msg + + -- Generate binding points (texture references and shapes) for arrays lifted + -- from scalar expressions + -- + liftAcc :: OpenAcc aenv a -> ArrayVar aenv -> [C.Definition] + liftAcc _ (ArrayVar idx) = + let avar = OpenAcc (Avar idx) + idx' = show $ idxToInt idx + sh = cshape ("sh" ++ idx') (accDim avar) + ty = accTypeTex avar + arr n = "arr" ++ idx' ++ "_a" ++ show (n::Int) + in + sh : zipWith (\t n -> cglobal t (arr n)) (reverse ty) [0..] + + -- Shapes are still represented as C structs, so we need to generate field + -- indexing code for shapes + -- + mkPrj :: Int -> String -> Int -> C.Exp + mkPrj ndim var c + | ndim <= 1 = cvar var + | otherwise = [cexp| $exp:(cvar var) . $id:('a':show c) |] + + + -- code generation for stencil boundary conditions + -- + codegenBoundary :: forall dim e. Sugar.Elt e + => OpenAcc aenv (Sugar.Array dim e) {- dummy -} + -> Boundary (Sugar.EltRepr e) + -> Boundary (CUExp e) + codegenBoundary _ Clamp = Clamp + codegenBoundary _ Mirror = Mirror + codegenBoundary _ Wrap = Wrap + codegenBoundary _ (Constant c) + = Constant . CUExp [] + $ codegenConst (Sugar.eltType (undefined::e)) c + + + +-- Scalar Expressions +-- ------------------ + +-- Function abstraction +-- +-- Although Accelerate includes lambda abstractions, it does not include a +-- general application form. That is, lambda abstractions of scalar expressions +-- are only introduced as arguments to collective operations, so lambdas are +-- always outermost, and can always be translated into plain C functions. +-- +codegenFun :: Fun aenv t -> CUFun t +codegenFun fun = runCGM $ codegenOpenFun (arity fun) fun Empty + where + arity :: OpenFun env aenv t -> Int + arity (Body _) = -1 + arity (Lam f) = 1 + arity f + +codegenOpenFun :: Int -> OpenFun env aenv t -> Val env -> CGM (CUFun t) +codegenOpenFun _lvl (Body e) env = do + e' <- codegenOpenExp e env + env' <- environment + zipWithM_ addVar (expType e) e' + return $ CUBody (CUExp env' e') + +codegenOpenFun lvl (Lam (f :: OpenFun (env,a) aenv b)) env = do + let ty = eltType (undefined::a) + n = length ty + vars = map (\i -> cvar ('x':shows lvl "_a" ++ show i)) [n-1,n-2..0] + weaken + f' <- codegenOpenFun (lvl-1) f (env `Push` vars) + vars' <- subscripts lvl + return $ CULam vars' f' + + +-- Embedded scalar computations +-- +codegenExp :: Exp aenv t -> CUExp t +codegenExp exp = runCGM $ do + e' <- codegenOpenExp exp Empty + env' <- environment + return $ CUExp env' e' + + +codegenOpenExp :: forall env aenv t. OpenExp env aenv t -> Val env -> CGM [C.Exp] +codegenOpenExp exp env = + case exp of + -- local binders and variable indices + -- + -- NOTE: recording which variables are used is important, because the CUDA + -- compiler will not eliminate variables that are initialised but never + -- used. If this is a scalar type mark it as used immediately, otherwise + -- wait until tuple projection picks out an individual element. + -- + Let a b -> do + a' <- codegenOpenExp a env + vars <- zipWithM bindVars (expType a) a' + codegenOpenExp b (env `Push` vars) + where + -- FIXME: if we are let-binding an input argument (read from global + -- array) mark that as used and return the variable name directly, + -- otherwise create a fresh binding point. + -- + bindVars t x = do + p <- addVar t x + if p then return x + else bind t x + + Var ix + | [t] <- ty, [v] <- var -> addVar t v >> return var + | otherwise -> return var + where + var = prj ix env + ty = eltType (undefined :: t) + + -- Constant values + -- + PrimConst c -> return [codegenPrimConst c] + Const c -> return (codegenConst (Sugar.eltType (undefined::t)) c) + + -- Primitive scalar operations + -- + PrimApp f arg -> do + x <- codegenOpenExp arg env + return [codegenPrim f x] + + -- Tuples + -- + Tuple t -> codegenTup t env + Prj idx e -> do + e' <- codegenOpenExp e env + case subset (zip e' elt) of + [(x,t)] -> addVar t x >> return [x] + xts -> return $ fst (unzip xts) + where + elt = expType e + subset = reverse + . take (length (expType exp)) + . drop (prjToInt idx (Sugar.expType e)) + . reverse + + -- Conditional expression + -- + Cond p t e -> do + t' <- codegenOpenExp t env + e' <- codegenOpenExp e env + p' <- codegenOpenExp p env >>= \ps -> + case ps of + [x] -> bind [cty| typename bool |] x + _ -> INTERNAL_ERROR(error) "codegenOpenExp" "expected conditional predicate" + -- + return $ zipWith (\a b -> [cexp| $exp:p' ? $exp:a : $exp:b|]) t' e' + + -- Array indices and shapes + -- + IndexNil -> return [] + IndexAny -> return [] + IndexCons sh sz -> do + sh' <- codegenOpenExp sh env + sz' <- codegenOpenExp sz env + return (sh' ++ sz') + + IndexHead ix -> do + ix' <- last <$> codegenOpenExp ix env + _ <- addVar (last (expType ix)) ix' + return [ix'] + + IndexTail ix -> do + ix' <- codegenOpenExp ix env + return (init ix') + + -- Array shape and element indexing + -- + ShapeSize sh -> do + sh' <- codegenOpenExp sh env + return [ ccall "size" [ccall "shape" sh'] ] + + Shape arr + | OpenAcc (Avar a) <- arr -> + let ndim = accDim arr + sh = cvar ("sh" ++ show (idxToInt a)) + in return $ if ndim <= 1 + then [sh] + else map (\c -> [cexp| $exp:sh . $id:('a':show c) |] ) [ndim-1, ndim-2 .. 0] + + | otherwise -> INTERNAL_ERROR(error) "codegenOpenExp" "expected array variable" + + IndexScalar arr ix + | OpenAcc (Avar a) <- arr -> + let avar = show (idxToInt a) + sh = cvar ("sh" ++ avar) + array x = cvar ("arr" ++ avar ++ "_a" ++ show x) + elt = accTypeTex arr + n = length elt + in do + ix' <- codegenOpenExp ix env + v <- bind [cty| int |] (ccall "toIndex" [sh, ccall "shape" ix']) + return $ zipWith (\t x -> indexArray t (array x) v) elt [n-1, n-2 .. 0] + + | otherwise -> INTERNAL_ERROR(error) "codegenOpenExp" "expected array variable" + + +-- Tuples are defined as snoc-lists, so generate code right-to-left +-- +codegenTup :: Tuple (OpenExp env aenv) t -> Val env -> CGM [C.Exp] +codegenTup tup env = case tup of + NilTup -> return [] + SnocTup t e -> (++) <$> codegenTup t env <*> codegenOpenExp e env + + +-- Convert a tuple index into the corresponding integer. Since the internal +-- representation is flat, be sure to walk over all sub components when indexing +-- past nested tuples. +-- +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" + +sizeTupleType :: TupleType a -> Int +sizeTupleType UnitTuple = 0 +sizeTupleType (SingleTuple _) = 1 +sizeTupleType (PairTuple a b) = sizeTupleType a + sizeTupleType b + + +-- Recording which variables of a computation are actually used is important, +-- particularly for stencils and arrays of tuples, because the CUDA compiler +-- will not eliminate variables that are initialised but never used. +-- +-- FIXME: This dubious hack is used to inspect the expression and mark as used +-- if it refers to an array input. +-- +addVar :: C.Type -> C.Exp -> CGM Bool +addVar ty exp = case show exp of + ('x':v:'_':'a':n) | [(v',[])] <- reads [v], [(n',[])] <- reads n + -> use v' n' ty exp >> return True + _ -> return False + + +-- 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 (FloatConst (shows x "f") (toRational x) noSrcLoc) noSrcLoc +codegenFloatingScalar (TypeCFloat _) x = C.Const (FloatConst (shows x "f") (toRational x) noSrcLoc) noSrcLoc +codegenFloatingScalar (TypeDouble _) x = C.Const (DoubleConst (show x) (toRational x) noSrcLoc) noSrcLoc +codegenFloatingScalar (TypeCDouble _) x = C.Const (DoubleConst (show x) (toRational x) noSrcLoc) noSrcLoc + +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] + + +-- Auxiliary Functions +-- ------------------- + +ccast :: ScalarType a -> C.Exp -> C.Exp +ccast ty x = [cexp|($ty:(codegenScalarType ty)) $exp:x|] + +postfix :: NumType a -> String -> String +postfix (FloatingNumType (TypeFloat _)) = (++ "f") +postfix (FloatingNumType (TypeCFloat _)) = (++ "f") +postfix _ = id + diff --git a/Data/Array/Accelerate/CUDA/CodeGen/Base.hs b/Data/Array/Accelerate/CUDA/CodeGen/Base.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/CodeGen/Base.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE QuasiQuotes #-} +-- | +-- 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 +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-partable (GHC extensions) +-- + +module Data.Array.Accelerate.CUDA.CodeGen.Base ( + + -- Types + CUTranslSkel(..), CUFun(..), CUExp(..), + + -- Declaration generation + typename, cptr, cvar, ccall, cchar, cintegral, cbool, cdim, cglobal, cshape, + setters, getters, shared, indexArray, + + -- Mutable operations + (.=.), locals + +) where + +import Data.Loc +import Data.Char +import Data.List +import Language.C.Syntax +import Language.C.Quote.CUDA +import Text.PrettyPrint.Mainland ( Pretty(..) ) + +import Data.Array.Accelerate.Array.Sugar ( Elt ) + + +-- Compilation units +-- ----------------- + +-- A CUDA compilation unit, together with the name of the main __global__ entry +-- function. +-- +data CUTranslSkel = CUTranslSkel String [Definition] + +instance Show CUTranslSkel where + show (CUTranslSkel entry _) = entry + +instance Pretty CUTranslSkel where + ppr (CUTranslSkel _ code) = ppr code + + +-- Scalar functions and expressions, including the environment of local +-- let-bindings and array data elements. +-- +data CUFun a where + CUBody :: CUExp a -> CUFun a + CULam :: Elt a => [(Int, Type, Exp)] -> CUFun t -> CUFun (a -> t) + +data CUExp e where + CUExp :: [InitGroup] -> [Exp] -> CUExp e + + +-- Expression and Declaration generation +-- ------------------------------------- + +cvar :: String -> Exp +cvar x = [cexp|$id:x|] + +ccall :: String -> [Exp] -> Exp +ccall fn args = [cexp|$id:fn ($args:args)|] + +typename :: String -> Type +typename name = Type (DeclSpec [] [] (Tnamed (Id name noSrcLoc) noSrcLoc) noSrcLoc) (DeclRoot noSrcLoc) noSrcLoc + +cchar :: Char -> Exp +cchar c = [cexp|$char:c|] + +cintegral :: (Integral a, Show a) => a -> Exp +cintegral n = [cexp|$int:n|] + +cbool :: Bool -> Exp +cbool = cintegral . fromEnum + +cdim :: String -> Int -> Definition +cdim name n = [cedecl|typedef typename $id:("DIM" ++ show n) $id:name;|] + + +cglobal :: Type -> String -> Definition +cglobal ty name = [cedecl|static $ty:ty $id:name;|] + +cshape :: String -> Int -> Definition +cshape name n = [cedecl| static __constant__ typename $id:("DIM" ++ show n) $id:name;|] + +indexArray :: Type -> Exp -> Exp -> Exp +indexArray ty arr ix + | "double" `isSuffixOf` map toLower (show ty) = ccall "indexDArray" [arr, ix] + | otherwise = ccall "indexArray" [arr, ix] + + +-- Generate a list of variable bindings and declarations to read from the input +-- arrays. +-- +-- In the case where the input array is an array of tuples, the function +-- parameters naturally include all components, but the scalar declarations +-- include only those indices that are used. +-- +getters + :: Int -- base de Bruijn index + -> [Type] -- the array element type + -> [(Int, Type, Exp)] -- the variables used in the scalar expression + -> ( [Param] -- function parameters for array(s) input + , [Exp] -- variable names + , [InitGroup] -- non-const variable declarations + , String -> [Exp] -- index global array + , String -> [InitGroup] ) -- const declarations and initialisation from index +getters base arrElt expElt = + let n = length arrElt + arr x = "d_in" ++ shows base "_a" ++ show x + arrParams = zipWith (\t x -> [cparam| const $ty:(cptr t) $id:(arr x) |]) arrElt [n-1, n-2 .. 0] + expVars = map (\(_,_,v) -> v) expElt + expDecls = map (\(_,t,v) -> [cdecl| $ty:t $id:(show v) ; |]) expElt + in + ( arrParams + , expVars + , expDecls + , \ix -> map (\(i,_,_) -> [cexp| $id:(arr i) [ $id:ix ] |] ) expElt + , \ix -> map (\(i,t,v) -> [cdecl| const $ty:t $id:(show v) = $id:(arr i) [$id:ix] ; |]) expElt + ) + + +-- Generate function parameters and corresponding variable names for the +-- components of the given output array. +-- +setters + :: [Type] -- element type + -> ( [Param] -- function parameter declarations + , [Exp] -- variable name + , String -> [Exp] -> [Stm]) -- store a value to the given index +setters arrElt = + let n = length arrElt + arrVars = map (\x -> "d_out_a" ++ show x) [n-1, n-2 .. 0] + arrParams = zipWith (\t x -> [cparam| $ty:(cptr t) $id:x |]) arrElt arrVars + set ix a x = [cstm| $id:a [$id:ix] = $exp:x; |] + in + ( arrParams + , map cvar arrVars + , \ix e -> zipWith (set ix) arrVars e + ) + + +-- shared memory declaration. All dynamically allocated __shared__ memory will +-- begin at the same base address. If we call this more than once, or the kernel +-- itself declares some shared memory, the first parameter is a pointer to where +-- the new declarations should start from. +-- +shared + :: Int -- shared memory shadowing which input array + -> Maybe Exp -- (optional) initialise from this base address + -> Exp -- how much shared memory per type + -> [Type] -- element types + -> ( [InitGroup] -- shared memory declaration + , String -> [Exp] ) -- index shared memory +shared base = shared' ('s':shows base "_a") + +shared' :: String -> Maybe Exp -> Exp -> [Type] -> ([InitGroup], String -> [Exp]) +shared' base mprev ix elt = + ( sdecl (head elt) (head vars) : zipWith3 sdata (tail elt) (tail vars) vars + , \i -> map (\v -> [cexp| $id:v [ $id:i ] |]) vars ) + where + vars = let k = length elt in map (\n -> base ++ show n) [k-1,k-2..0] + sdecl t v + | Just p <- mprev = [cdecl| volatile $ty:(cptr t) $id:v = ( $ty:(cptr t) ) $exp:p; |] + | otherwise = [cdecl| extern volatile __shared__ $ty:t $id:v []; |] + sdata t v p = [cdecl| volatile $ty:(cptr t) $id:v = ( $ty:(cptr t) ) & $id:p [ $exp:ix ]; |] + + +-- Turn a plain type into a ptr type +-- +cptr :: Type -> Type +cptr t | Type d@(DeclSpec _ _ _ _) r@(DeclRoot _) lb <- t = Type d (Ptr [] r noSrcLoc) lb + | otherwise = t + + +-- Mutable operations +-- ------------------ + +-- Variable assignment +-- +(.=.) :: [Exp] -> [Exp] -> [Stm] +(.=.) = zipWith (\v e -> [cstm| $exp:v = $exp:e; |]) + +locals :: String -> [Type] -> ([Exp], [InitGroup]) +locals base elt = unzip (zipWith local elt names) + where + suf = let n = length elt in map show [n-1,n-2..0] + names = map (\n -> base ++ "_a" ++ n) suf + local t n = ( cvar n, [cdecl| $ty:t $id:n; |] ) + diff --git a/Data/Array/Accelerate/CUDA/CodeGen/IndexSpace.hs b/Data/Array/Accelerate/CUDA/CodeGen/IndexSpace.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/CodeGen/IndexSpace.hs @@ -0,0 +1,394 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS -fno-warn-incomplete-patterns #-} +-- | +-- 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 +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.CUDA.CodeGen.IndexSpace ( + + -- Array construction + mkGenerate, + + -- Permutations + mkPermute, mkBackpermute, + + -- Multidimensional index and replicate + mkSlice, mkReplicate + +) where + +import Data.List +import Language.C.Syntax +import Language.C.Quote.CUDA +import Foreign.CUDA.Analysis + +import Data.Array.Accelerate.Array.Sugar ( Array, Elt ) +import Data.Array.Accelerate.CUDA.CodeGen.Base +import Data.Array.Accelerate.CUDA.CodeGen.Type + + +-- Construct a new array by applying a function to each index. Each thread +-- processes multiple elements, striding the array by the grid size. +-- +-- generate :: (Shape ix, Elt e) +-- => Exp ix +-- -> (Exp ix -> Exp a) +-- -> Acc (Array ix a) +-- +mkGenerate :: forall sh e. Elt e => Int -> CUFun (sh -> e) -> CUTranslSkel +mkGenerate dimOut (CULam _ (CUBody (CUExp env fn))) = + CUTranslSkel "generate" [cunit| + $edecl:(cdim "DimOut" dimOut) + + extern "C" + __global__ void + generate + ( + $params:args, + const typename DimOut shOut + ) + { + const int n = size(shOut); + const int gridSize = __umul24(blockDim.x, gridDim.x); + int ix; + + for ( ix = __umul24(blockDim.x, blockIdx.x) + threadIdx.x + ; ix < n + ; ix += gridSize) + { + $decls:shape + $decls:env + $stms:(set "ix" fn) + } + } + |] + where + (args, _, set) = setters tyOut + tyOut = eltType (undefined :: e) + shape = fromIndex dimOut "DimOut" "shOut" "ix" "x0" + + +-- Forward permutation specified by an index mapping that determines for each +-- element in the source array where it should go in the target. The resultant +-- array is initialised with the given defaults and any further values that are +-- permuted into the result array are added to the current value using the given +-- combination function. +-- +-- The combination function must be associative. Extents that are mapped to the +-- magic value 'ignore' by the permutation function are dropped. +-- +-- permute :: (Shape ix, Shape ix', Elt a) +-- => (Exp a -> Exp a -> Exp a) -- combination function +-- -> Acc (Array ix' a) -- array of default values +-- -> (Exp ix -> Exp ix') -- permutation +-- -> Acc (Array ix a) -- permuted array +-- -> Acc (Array ix' a) +-- +mkPermute :: forall a ix ix'. + DeviceProperties + -> Int -- dimensionality ix' + -> Int -- dimensionality ix + -> CUFun (a -> a -> a) + -> CUFun (ix -> ix') + -> CUTranslSkel +mkPermute dev dimOut dimIn0 (CULam useFn (CULam _ (CUBody (CUExp env combine)))) (CULam _ (CUBody (CUExp envIx prj))) = + CUTranslSkel "permute" [cunit| + $edecl:(cdim "DimOut" dimOut) + $edecl:(cdim "DimIn0" dimIn0) + + extern "C" + __global__ void + permute + ( + $params:argOut, + $params:argIn0, + const typename DimOut shOut, + const typename DimIn0 shIn0 + ) + { + const int shapeSize = size(shIn0); + const int gridSize = __umul24(blockDim.x, gridDim.x); + int ix; + + for ( ix = __umul24(blockDim.x, blockIdx.x) + threadIdx.x + ; ix < shapeSize + ; ix += gridSize) + { + typename DimOut dst; + $decls:src + $decls:envIx + $stms:dst + + if (!ignore(dst)) + { + const int jx = toIndex(shOut, dst); + $decls:decl1 + $decls:temps + $decls:env + $stms:(x1 .=. getIn0 "ix") + $stms:write + } + } + } + |] + where + elt = eltType (undefined :: a) + sizeof = eltSizeOf (undefined :: a) + (argIn0, _, _, getIn0, _) = getters 0 elt useFn + (_, x1, decl1, _, _) = getters 1 elt useFn + (argOut, arrOut, setOut) = setters elt + (x0, _) = locals "x0" elt + src = fromIndex dimIn0 "DimIn0" "shIn0" "ix" "x0" + dst = project dimOut "dst" prj + sm = computeCapability dev + unsafe = setOut "jx" combine + (temps, write) = unzip $ zipWith6 apply unsafe combine elt arrOut x0 sizeof + -- + -- 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. + -- + -- Each element of a tuple is necessarily written individually, so the tuple + -- as a whole is not stored atomically. + -- + apply set f t a z s + | Just atomicCAS <- reinterpret s + = let z' = [cexp| $id:('_':show z) |] + in + ( [cdecl| $ty:t $id:(show z), $id:(show z') = $exp:a [ $id:("jx") ]; |] + , [cstm| do { $exp:z = $exp:z'; + $exp:z' = $exp:atomicCAS ( & $exp:a [ $id:("jx") ], $exp:z, $exp:f ); + } while ( $exp:z != $exp:z' ); |] + ) + + | otherwise + = ( [cdecl| const $ty:t $id:(show z) = $exp:a [ $id:("jx") ]; |] + , set + ) + -- + reinterpret :: Int -> Maybe Exp + reinterpret 4 | sm >= 1.1 = Just [cexp| $id:("atomicCAS32") |] + reinterpret 8 | sm >= 1.2 = Just [cexp| $id:("atomicCAS64") |] + reinterpret _ = Nothing + + +-- Backwards permutation (gather) of an array according to a permutation +-- function. +-- +-- backpermute :: (Shape ix, Shape ix', Elt a) +-- => Exp ix' -- shape of the result array +-- -> (Exp ix' -> Exp ix) -- permutation +-- -> Acc (Array ix a) -- permuted array +-- -> Acc (Array ix' a) +-- +mkBackpermute :: forall ix ix' a. Elt a + => Int -- dimensionality ix' + -> Int -- dimensionality ix + -> CUFun (ix' -> ix) + -> Array ix' a -- dummy to fix type variables + -> CUTranslSkel +mkBackpermute dimOut dimIn0 (CULam _ (CUBody (CUExp env prj))) _ = + CUTranslSkel "backpermute" [cunit| + $edecl:(cdim "DimOut" dimOut) + $edecl:(cdim "DimIn0" dimIn0) + + extern "C" + __global__ void + backpermute + ( + $params:argOut, + $params:argIn0, + const typename DimOut shOut, + const typename DimIn0 shIn0 + ) + { + const int shapeSize = size(shOut); + const int gridSize = __umul24(blockDim.x, gridDim.x); + int ix; + + for ( ix = __umul24(blockDim.x, blockIdx.x) + threadIdx.x + ; ix < shapeSize + ; ix += gridSize) + { + typename DimIn0 src; + $decls:dst + $decls:env + $stms:src + { + const int jx = toIndex(shIn0, src); + $decls:(getIn0 "jx") + $stms:(setOut "ix" (reverse x0)) + } + } + } + |] + where + elt = eltType (undefined :: a) + (argOut, _, setOut) = setters elt + (argIn0, x0, _, _, getIn0) = getters 0 elt (useAll 0 elt) + dst = fromIndex dimOut "DimOut" "shOut" "ix" "x0" + src = project dimIn0 "src" prj + + +-- Index an array with a generalised, multidimensional array index. The result +-- is a new array (possibly a singleton) containing all dimensions in their +-- entirety. +-- +-- slice :: (Slice slix, Elt e) +-- => Acc (Array (FullShape slix) e) +-- -> Exp slix +-- -> Acc (Array (SliceShape slix) e) +-- +mkSlice :: forall sl slix e. Elt e + => Int -- dimensionality sl + -> Int -- dimensionality co + -> Int -- dimensionality sh + -> CUExp slix + -> Array sl e -- dummy + -> CUTranslSkel +mkSlice dimSl dimCo dimIn0 (CUExp [] slix) _ = + CUTranslSkel "slice" [cunit| + $edecl:(cdim "Slice" dimSl) + $edecl:(cdim "CoSlice" dimCo) + $edecl:(cdim "SliceDim" dimIn0) + + extern "C" + __global__ void + slice + ( + $params:argOut, + $params:argIn0, + const typename Slice slice, + const typename CoSlice co, + const typename SliceDim sliceDim + ) + { + int ix; + const int shapeSize = size(slice); + const int gridSize = __umul24(blockDim.x, gridDim.x); + + for ( ix = __umul24(blockDim.x, blockIdx.x) + threadIdx.x + ; ix < shapeSize + ; ix += gridSize) + { + typename Slice sl = fromIndex(slice, ix); + typename SliceDim src; + $stms:src + { + const int jx = toIndex(sliceDim, src); + $decls:(getIn0 "jx") + $stms:(setOut "ix" x0) + } + } + } + |] + where + elt = eltType (undefined :: e) + (argOut, _, setOut) = setters elt + (argIn0, x0, _, _, getIn0) = getters 0 elt (useAll 0 elt) + src = project dimIn0 "src" slix + + +-- Replicate an array across one or more dimensions as specified by the +-- generalised array index. +-- +-- replicate :: (Slice slix, Elt e) +-- => Exp slix +-- -> Acc (Array (SliceShape slix) e) +-- -> Acc (Array (FullShape slix) e) +-- +mkReplicate :: forall sh slix e. Elt e + => Int -- dimensionality sl + -> Int -- dimensionality sh + -> CUExp slix + -> Array sh e -- dummy + -> CUTranslSkel +mkReplicate dimSl dimOut (CUExp _ slix) _ = + CUTranslSkel "replicate" [cunit| + $edecl:(cdim "Slice" dimSl) + $edecl:(cdim "SliceDim" dimOut) + + extern "C" + __global__ void + replicate + ( + $params:argOut, + $params:argIn0, + const typename Slice slice, + const typename SliceDim sliceDim + ) + { + int ix; + const int shapeSize = size(sliceDim); + const int gridSize = __umul24(blockDim.x, gridDim.x); + + for ( ix = __umul24(blockDim.x, blockIdx.x) + threadIdx.x + ; ix < shapeSize + ; ix += gridSize) + { + typename SliceDim dim = fromIndex(sliceDim, ix); + typename Slice src; + $stms:src + { + const int jx = toIndex(slice, src); + $decls:(getIn0 "jx") + $stms:(setOut "ix" x0) + } + } + } + |] + where + elt = eltType (undefined :: e) + (argOut, _, setOut) = setters elt + (argIn0, x0, _, _, getIn0) = getters 0 elt (useAll 0 elt) + src = project dimSl "src" slix + + + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +-- destruct shapes into separate components, since the code generator no +-- longer treats tuples as structs +-- +fromIndex :: Int -> String -> String -> String -> String -> [InitGroup] +fromIndex n dim sh ix base + | n == 1 = [[cdecl| const int $id:(base ++ "_a0") = $id:ix; |]] + | otherwise = sh0 : map (unsh . show) [0 .. n-1] + where + sh0 = [cdecl| const typename $id:dim $id:base = fromIndex( $id:sh , $id:ix ); |] + unsh c = [cdecl| const int $id:(base ++ "_a" ++ c) = $id:base . $id:('a':c); |] + + +-- apply expressions to the components of a shape +-- +project :: Int -> String -> [Exp] -> [Stm] +project n sh idx + | [e] <- idx = [[cstm| $id:sh = $exp:e; |]] + | otherwise = zipWith (\i c -> [cstm| $id:sh . $id:('a':show c) = $exp:i; |]) idx [n-1,n-2..0] + + +-- tell the getters function that we will use all the scalar components +-- +useAll :: Int -> [Type] -> [(Int, Type, Exp)] +useAll base elt = + let n = length elt + x i = 'x' : shows base "_a" ++ show i + in + zipWith (\i t -> (i,t, cvar (x i))) [n-1, n-2 .. 0] elt + diff --git a/Data/Array/Accelerate/CUDA/CodeGen/Mapping.hs b/Data/Array/Accelerate/CUDA/CodeGen/Mapping.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/CodeGen/Mapping.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS -fno-warn-incomplete-patterns #-} +-- | +-- 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 +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.CUDA.CodeGen.Mapping ( + + mkMap, mkZipWith + +) where + +import Language.C.Quote.CUDA +import Data.Array.Accelerate.Array.Sugar ( Elt ) +import Data.Array.Accelerate.CUDA.CodeGen.Base +import Data.Array.Accelerate.CUDA.CodeGen.Type + + +-- Apply the given unary function to each element of an array. Each thread +-- processes multiple elements, striding the array by the grid size. +-- +-- map :: (Shape sh, Elt a, Elt b) +-- => (Exp a -> Exp b) +-- -> Acc (Array sh a) +-- -> Acc (Array sh b) +-- +mkMap :: forall a b. Elt b => CUFun (a -> b) -> CUTranslSkel +mkMap (CULam use0 (CUBody (CUExp env fn))) = + CUTranslSkel "map" [cunit| + extern "C" + __global__ void + map + ( + $params:argOut, + $params:argIn0, + const typename Ix num_elements + ) + { + const int gridSize = __umul24(blockDim.x, gridDim.x); + int ix; + + for ( ix = __umul24(blockDim.x, blockIdx.x) + threadIdx.x + ; ix < num_elements + ; ix += gridSize) + { + $decls:(getIn0 "ix") + $decls:env + $stms:(setOut "ix" fn) + } + } + |] + where + tyIn0 = eltType (undefined :: a) + tyOut = eltType (undefined :: b) + (argIn0, _, _, _, getIn0) = getters 0 tyIn0 use0 + (argOut, _, setOut) = setters tyOut + + +-- Apply the given binary function element-wise to the two arrays. The extent of +-- the resulting array is the intersection of the extents of the two source +-- arrays. Each thread processes multiple elements, striding the array by the +-- grid size. +-- +-- zipWith :: (Shape ix, Elt a, Elt b, Elt c) +-- => (Exp a -> Exp b -> Exp c) +-- -> Acc (Array ix a) +-- -> Acc (Array ix b) +-- -> Acc (Array ix c) +-- +mkZipWith :: forall a b c. Elt c => Int -> CUFun (a -> b -> c) -> CUTranslSkel +mkZipWith dim (CULam use1 (CULam use0 (CUBody (CUExp env fn)))) = + CUTranslSkel "zipWith" [cunit| + $edecl:(cdim "DimOut" dim) + $edecl:(cdim "DimIn0" dim) + $edecl:(cdim "DimIn1" dim) + + extern "C" + __global__ void + zipWith + ( + $params:argOut, + $params:argIn1, + $params:argIn0, + const typename DimOut shOut, + const typename DimIn1 shIn1, + const typename DimIn0 shIn0 + ) + { + const int shapeSize = size(shOut); + const int gridSize = __umul24(blockDim.x, gridDim.x); + int ix; + + for ( ix = __umul24(blockDim.x, blockIdx.x) + threadIdx.x + ; ix < shapeSize + ; ix += gridSize) + { + const int ix1 = toIndex(shIn1, fromIndex(shOut, ix)); + const int ix0 = toIndex(shIn0, fromIndex(shOut, ix)); + $decls:(getIn0 "ix0") + $decls:(getIn1 "ix1") + $decls:env + $stms:(setOut "ix" fn) + } + } + |] + where + tyIn1 = eltType (undefined :: a) + tyIn0 = eltType (undefined :: b) + tyOut = eltType (undefined :: c) + (argIn1, _, _, _, getIn1) = getters 1 tyIn1 use1 + (argIn0, _, _, _, getIn0) = getters 0 tyIn0 use0 + (argOut, _, setOut) = setters tyOut + diff --git a/Data/Array/Accelerate/CUDA/CodeGen/Monad.hs b/Data/Array/Accelerate/CUDA/CodeGen/Monad.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/CodeGen/Monad.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE BangPatterns, TemplateHaskell, QuasiQuotes #-} +-- | +-- 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 +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.CUDA.CodeGen.Monad ( + + runCGM, CGM, + bind, use, weaken, environment, subscripts + +) where + +import Data.Label ( mkLabels ) +import Data.Label.PureM +import Control.Applicative +import Control.Monad.State ( State, evalState ) +import Language.C +import Language.C.Quote.CUDA + +import Data.IntMap ( IntMap ) +import Data.Sequence ( Seq, (|>) ) +import qualified Data.IntMap as IM +import qualified Data.Sequence as S + + +type CGM = State Gamma +data Gamma = Gamma + { + _unique :: {-# UNPACK #-} !Int, + _variables :: !(Seq (IntMap (Type, Exp))), + _bindings :: ![InitGroup] + } + deriving Show + +$(mkLabels [''Gamma]) + + +runCGM :: CGM a -> a +runCGM = flip evalState (Gamma 0 S.empty []) + + +-- Add space for another variable +-- +weaken :: CGM () +weaken = modify variables (|> IM.empty) + +-- Add an expression of given type to the environment and return the (new, +-- unique) binding name that can be used in place of the thing just bound. +-- +bind :: Type -> Exp -> CGM Exp +bind t e = do + name <- fresh + modify bindings ( [cdecl| const $ty:t $id:name = $exp:e;|] : ) + return [cexp|$id:name|] + +-- Return the environment (list of initialisation declarations). Since we +-- introduce new bindings to the front of the list, need to reverse so they +-- appear in usage order. +-- +environment :: CGM [InitGroup] +environment = reverse `fmap` gets bindings + +-- Generate a fresh variable name +-- +fresh :: CGM String +fresh = do + n <- gets unique <* modify unique (+1) + return $ 'v':show n + +-- Mark a variable at a given base and tuple index as being used. +-- +use :: Int -> Int -> Type -> Exp -> CGM () +use base prj ty var = modify variables (S.adjust (IM.insert prj (ty,var)) base) + +-- Return the tuple components of a given variable that are actually used +-- +subscripts :: Int -> CGM [(Int, Type, Exp)] +subscripts base = map swizzle . IM.toList . flip S.index base <$> gets variables + where + swizzle (i, (t,e)) = (i,t,e) + diff --git a/Data/Array/Accelerate/CUDA/CodeGen/PrefixSum.hs b/Data/Array/Accelerate/CUDA/CodeGen/PrefixSum.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/CodeGen/PrefixSum.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS -fno-warn-incomplete-patterns #-} +-- | +-- 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 +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.CUDA.CodeGen.PrefixSum ( + + -- skeletons + mkScanl, mkScanr, + + -- closets + scanBlock + +) where + +import Language.C.Syntax +import Language.C.Quote.CUDA +import Foreign.CUDA.Analysis +import Data.Maybe + +import Data.Array.Accelerate.CUDA.CodeGen.Base +import Data.Array.Accelerate.CUDA.CodeGen.Type + + +data Direction = L | R + deriving Eq + +instance Show Direction where + show L = "l" + show R = "r" + + +mkScanl, mkScanr :: DeviceProperties -> CUFun (a -> a -> a) -> Maybe (CUExp a) -> CUTranslSkel +mkScanl = mkScan L +mkScanr = mkScan R + + +-- [OVERVIEW] +-- +-- Data.List-style exclusive scan, with the additional restriction that the +-- first argument needs to be an /associative/ function to enable efficient +-- parallel implementation. The initial value may be arbitrary. +-- +-- scanl :: Elt a +-- => (Exp a -> Exp a -> Exp a) +-- -> Exp a +-- -> Acc (Vector a) +-- -> Acc (Vector a) +-- +-- > scanl (+) 10 (use xs) +-- > where +-- > xs = fromList (Z:.10) (cycle [1]) +-- > +-- > ==> Array (Z:.11) [10,11,12,13,14,15,16,17,18,19,20] +-- +-- Data.List-style inclusive scan without an initial value +-- +-- scanl1 :: Elt a +-- => (Exp a -> Exp a -> Exp a) +-- -> Acc (Vector a) +-- -> Acc (Vector a) +-- +-- > scanl1 (+) (use xs) +-- > where +-- > xs = fromList (Z:.10) (cycle [1]) +-- > +-- > ==> Array (Z:.10) [1,2,3,4,5,6,7,8,9,10] +-- +-- Variant of 'scanl' where the final result is returned separately. +-- +-- scanl' :: Elt a +-- => (Exp a -> Exp a -> Exp a) +-- -> Exp a +-- -> Acc (Vector a) +-- -> (Acc (Vector a), Acc (Scalar a)) +-- +-- Denotationally, we have: +-- +-- > scanl' f z xs = (init res, last res) +-- > where +-- > res = scanl f z xs +-- +-- +-- [IMPLEMENTATION] +-- +-- This code handles all the above cases, in both left and right-handed +-- variants. This is the _downsweep_ phase to a multi-block scan procedure. +-- We require a work distribution such that there is a _single_ thread block for +-- each interval. For multi-block scans, we have an array of interval sums that +-- are used to determine the carry-in value from the previous interval. Note +-- that 'argBlk' will not be accessed by a single-block scan, so may be null. +-- +-- We require some pointer manipulation from the calling code in order to +-- support all types of scans: +-- +-- * scanl : argSum should point to the last position of argOut +-- * scanr : argSum should be the start of argOut, argOut should be incremented by one +-- * scanl1, scanr1 : no change (argSum is required, even though it will not be used Haskell-side) +-- * scanl', scanr' : no change +-- +mkScan :: forall a. + Direction + -> DeviceProperties + -> CUFun (a -> a -> a) + -> Maybe (CUExp a) + -> CUTranslSkel +mkScan dir dev (CULam _ (CULam use0 (CUBody (CUExp env combine)))) mseed = + CUTranslSkel name [cunit| + extern "C" + __global__ void + $id:name + ( + $params:argOut, + $params:argSum, + $params:argIn0, + $params:argBlk, + typename Ix interval_size, + const typename Ix num_elements + ) + { + $decls:smem + $decls:decl0 + $decls:decl1 + $decls:decl2 + + /* + * Read in previous result partial sum. We store the carry value in x0 + * and read new values from the input array into x1, since 'scanBlock' + * will store its results into x1 on completion. + */ + int carry_in = 0; + + if ( threadIdx.x == 0 ) { + $stm:(initialise mseed) + } + + const int start = blockIdx.x * interval_size; + const int end = min(start + interval_size, num_elements); + interval_size = end - start; + + for (int i = threadIdx.x; i < interval_size; i += blockDim.x) + { + const int j = $id:(if left then "start + i" else "end - i - 1"); + $stms:(x1 .=. getIn0 "j") + + if ( $exp:carry_in ) { + $decls:env + $stms:(x0 .=. x2) + $stms:(x1 .=. combine) + } + + /* + * Store our input into shared memory and cooperatively scan + */ + $stms:(sdata "threadIdx.x" .=. x1) + __syncthreads(); + + $stms:(scanBlock dev elt Nothing (cvar "blockDim.x") sdata env combine) + + if ( $exp:(cbool exclusive) ) { + if ( threadIdx.x == 0 ) { + $stms:(x1 .=. x2) + } else { + $stms:(x1 .=. sdata "threadIdx.x - 1") + } + } + $stms:(setOut "j" x1) + + /* + * Carry the final result from this block through x0. If this is the + * last section of the interval, this is the value to write out as + * the final (reduction) result. + */ + if ( threadIdx.x == 0 ) { + const int last = min(interval_size - i, blockDim.x) - 1; + $stms:(x2 .=. sdata "last") + } + $id:( if not exclusive then "carry_in = 1" else [] ) ; + } + + /* + * for exclusive scans, set the overall scan result and reapply the + * initial element at the boundaries of each interval + */ + if ( $exp:(cbool exclusive) && threadIdx.x == 0 && blockIdx.x == $id:lastBlock ) { + $stms:(setSum .=. x2) + } + } + |] + where + name = "scan" ++ show dir ++ maybe "1" (const "") mseed + elt = eltType (undefined :: a) + (argIn0, x0, decl0, getIn0, _) = getters 0 elt use0 + (argOut, _, setOut) = setters elt + setSum = totalSum "0" + (argSum, totalSum) = arrays "d_sum" elt + (argBlk, blkSum) = arrays "d_blk" elt + (x1, decl1) = locals "x1" elt + (x2, decl2) = locals "x2" elt + (smem, sdata) = shared 0 Nothing [cexp| blockDim.x |] elt + -- + carry_in + | exclusive = [cexp| threadIdx.x == 0 |] + | otherwise = [cexp| threadIdx.x == 0 && carry_in |] + exclusive = isJust mseed + left = dir == L + firstBlock = if left then "0" else "gridDim.x - 1" + lastBlock = if not left then "0" else "gridDim.x - 1" + -- + initialise Nothing = [cstm| + if ( blockIdx.x != $id:firstBlock ) { + $stms:(x2 .=. blkSum (if left then "blockIdx.x - 1" else "blockIdx.x + 1")) + carry_in = 1; + } + |] + initialise (Just (CUExp env' seed)) = [cstm| + if ( gridDim.x > 1 ) { + $stms:(x2 .=. blkSum "blockIdx.x") + } else { + $decls:env' + $stms:(x2 .=. seed) + } + |] + + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +-- Introduce some new array arguments and a way to index them +-- +arrays :: String -> [Type] -> ([Param], String -> [Exp]) +arrays base elt = + ( zipWith (\t a -> [cparam| $ty:(cptr t) $id:a |]) elt arrs + , \ix -> map (\a -> [cexp| $id:a [$id:ix] |]) arrs + ) + where + n = length elt + arrs = map (\x -> base ++ "_a" ++ show x) [n-1, n-2 .. 0] + + +-- Scan a block of results in shared memory. We hijack the standard local +-- variables (x0 and x1) for the combination function. This thread must have +-- already stored its initial value into shared memory. The final result for +-- this thread will be stored in x1 as well as the appropriate place in shared +-- memory. +-- +scanBlock :: DeviceProperties + -> [Type] -- element type + -> Maybe Exp -- partially-full block bounds check? + -> Exp -- CTA size + -> (String -> [Exp]) -- index shared memory area + -> [InitGroup] -- local environment for the.. + -> [Exp] -- ..binary function + -> [Stm] +scanBlock dev elt mlim cta sdata env combine = map (scan . pow2) [0 .. maxThreads] + where + maxThreads = floor (logBase 2 (fromIntegral $ maxThreadsPerBlock dev :: Double)) :: Int + (x0, _) = locals "x0" elt + (x1, _) = locals "x1" elt + pow2 x = (2::Int) ^ x + scan n = + let inrange = maybe [cexp| threadIdx.x >= $int:n|] + (\m -> [cexp| threadIdx.x >= $int:n && threadIdx.x < $exp:m |]) mlim + ix = "threadIdx.x - " ++ show n + in + [cstm| + if ( $exp:cta > $int:n ) { + if ( $exp:inrange ) { + $stms:(x0 .=. sdata ix) + $decls:env + $stms:(x1 .=. combine) + } + __syncthreads(); + $stms:(sdata "threadIdx.x" .=. x1) + __syncthreads(); + } + |] + + diff --git a/Data/Array/Accelerate/CUDA/CodeGen/Reduction.hs b/Data/Array/Accelerate/CUDA/CodeGen/Reduction.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/CodeGen/Reduction.hs @@ -0,0 +1,542 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS -fno-warn-incomplete-patterns #-} +-- | +-- 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 +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.CUDA.CodeGen.Reduction ( + + -- skeletons + mkFold, mkFoldAll, mkFoldSeg, + + -- closets + reduceWarp, reduceBlock + +) where + +import Language.C.Syntax +import Language.C.Quote.CUDA +import Foreign.CUDA.Analysis + +import Data.Array.Accelerate.CUDA.CodeGen.Base +import Data.Array.Accelerate.CUDA.CodeGen.Type + + +-- Reduction of an array of arbitrary rank to a single scalar value. The first +-- argument needs to be an associative function to enable an efficient parallel +-- implementation +-- +-- foldAll :: (Shape sh, Elt a) +-- => (Exp a -> Exp a -> Exp a) +-- -> Exp a +-- -> Acc (Array sh a) +-- -> Acc (Scalar a) +-- +-- fold1All :: (Shape sh, Elt a) +-- => (Exp a -> Exp a -> Exp a) +-- -> Acc (Array sh a) +-- -> Acc (Scalar a) +-- +-- Each thread computes multiple elements sequentially. This reduces the overall +-- cost of the algorithm while keeping the work complexity O(n) and the step +-- complexity O(log n). c.f. Brent's Theorem optimisation. +-- +mkFoldAll :: forall a. + DeviceProperties + -> CUFun (a -> a -> a) + -> Maybe (CUExp a) -> CUTranslSkel +mkFoldAll dev (CULam _ (CULam use0 (CUBody (CUExp env combine)))) mseed = + CUTranslSkel name [cunit| + extern "C" + __global__ void + $id:name + ( + $params:argOut, + $params:argIn0, + const typename Ix num_elements + ) + { + const int gridSize = blockDim.x * gridDim.x; + int i = blockIdx.x * blockDim.x + threadIdx.x; + $decls:smem + $decls:decl0 + $decls:decl1 + + /* + * Reduce multiple elements per thread. The number is determined by the + * number of active thread blocks (via gridDim). More blocks will result in + * a larger `gridSize', and hence fewer elements per thread + * + * The loop stride of `gridSize' is used to maintain coalescing. + */ + if (i < num_elements) + { + $stms:(x1 .=. getIn0 "i") + + for (i += gridSize; i < num_elements; i += gridSize) + { + $decls:env + $stms:(x0 .=. getIn0 "i") + $stms:(x1 .=. combine) + } + } + + /* + * Each thread puts its local sum into shared memory, then threads + * cooperatively reduce the shared array to a single value. + */ + $stms:(sdata "threadIdx.x" .=. x1) + __syncthreads(); + + i = min(((int) num_elements) - blockIdx.x * blockDim.x, blockDim.x); + $stms:(reduceBlock dev elt "i" sdata env combine) + + /* + * Write the results of this block back to global memory. If we are the last + * phase of a recursive multi-block reduction, include the seed element. + */ + if (threadIdx.x == 0) + { + $stms:(maybe inclusive_finish exclusive_finish mseed) + } + } + |] + where + name = maybe "fold1All" (const "foldAll") mseed + elt = eltType (undefined :: a) + (argIn0, x0, decl0, getIn0, _) = getters 0 elt use0 + (argOut, _, setOut) = setters elt + (x1, decl1) = locals "x1" elt + (smem, sdata) = shared 0 Nothing [cexp| blockDim.x |] elt + -- + inclusive_finish = setOut "blockIdx.x" x1 + exclusive_finish (CUExp env' seed) = [[cstm| + if (num_elements > 0) { + if (gridDim.x == 1) { + $decls:env' + $stms:(x0 .=. seed) + $stms:(x1 .=. combine) + } + $stms:(setOut "blockIdx.x" x1) + } + else { + $decls:env' + $stms:(setOut "blockIdx.x" seed) + } + |]] + + +-- Reduction of the innermost dimension of an array of arbitrary rank. The first +-- argument needs to be an associative function to enable an efficient parallel +-- implementation +-- +-- fold :: (Shape ix, Elt a) +-- => (Exp a -> Exp a -> Exp a) +-- -> Exp a +-- -> Acc (Array (ix :. Int) a) +-- -> Acc (Array ix a) +-- +-- fold1 :: (Shape ix, Elt a) +-- => (Exp a -> Exp a -> Exp a) +-- -> Acc (Array (ix :. Int) a) +-- -> Acc (Array ix a) +-- +mkFold :: forall a. + DeviceProperties + -> CUFun (a -> a -> a) + -> Maybe (CUExp a) + -> CUTranslSkel +mkFold dev (CULam _ (CULam use0 (CUBody (CUExp env combine)))) mseed = + CUTranslSkel name [cunit| + extern "C" + __global__ void + $id:name + ( + $params:argOut, + $params:argIn0, + const typename Ix interval_size, // indexHead(shIn0) + const typename Ix num_intervals, // size(shOut) + const typename Ix num_elements // size(shIn0) + ) + { + $decls:smem + $decls:decl1 + $decls:decl0 + $decls:env + + /* + * If the intervals of an exclusive fold are empty, use all threads to + * map the seed value to the output array and exit. + */ + $stms:(maybe [] (return . mapseed) mseed) + + /* + * Threads in a block cooperatively reduce all elements in an interval. + */ + for (int seg = blockIdx.x; seg < num_intervals; seg += gridDim.x) + { + const int start = seg * interval_size; + const int end = min(start + interval_size, num_elements); + const int n = min(end - start, blockDim.x); + + /* + * Kill threads that will not participate in this segment to avoid + * invalid global reads. + */ + if (threadIdx.x >= n) + return; + + /* + * Ensure aligned access to global memory, and that each thread + * initialises its local sum + */ + int i = start - (start & (warpSize - 1)); + + if (i == start || interval_size > blockDim.x) + { + i += threadIdx.x; + + if (i >= start) + { + $stms:(x1 .=. getIn0 "i") + } + + if (i + blockDim.x < end) + { + $decls:(getTmp "i + blockDim.x") + + if (i >= start) { + $decls:env + $stms:(x1 .=. combine) + } + else { + $stms:(x1 .=. x0) + } + } + + /* + * Now, iterate collecting a local sum + */ + for (i += 2 * blockDim.x; i < end; i += blockDim.x) + { + $decls:env + $stms:(x0 .=. getIn0 "i") + $stms:(x1 .=. combine) + } + } + else + { + $stms:(x1 .=. getIn0 "start + threadIdx.x") + } + + /* + * Each thread puts its local sum into shared memory, and + * cooperatively reduces this to a single value. + */ + $stms:(sdata "threadIdx.x" .=. x1) + __syncthreads(); + + $stms:(reduceBlock dev elt "n" sdata env combine) + + /* + * Finally, the first thread writes the result for this segment. For + * exclusive reductions, we also combine with the seed element here. + */ + if (threadIdx.x == 0) + { + $decls:final_decls + $stms:final_stms + $stms:(setOut "seg" x1) + } + } + } + |] + where + name = maybe "fold1" (const "fold") mseed + elt = eltType (undefined :: a) + (argIn0, x0, decl0, getIn0, getTmp) = getters 0 elt use0 + (argOut, _, setOut) = setters elt + (x1, decl1) = locals "x1" elt + (smem, sdata) = shared 0 Nothing [cexp| blockDim.x |] elt + -- + (final_decls, final_stms) = + case mseed of + Nothing -> ([], []) + Just (CUExp env' seed) -> (env', concat [x0 .=. seed, x1 .=. combine]) + -- + mapseed (CUExp env' seed) = [cstm| + if (interval_size == 0) + { + const int gridSize = __umul24(blockDim.x, gridDim.x); + int seg; + + for ( seg = __umul24(blockDim.x, blockIdx.x) + threadIdx.x + ; seg < num_intervals + ; seg += gridSize ) + { + $decls:env' + $stms:(setOut "seg" seed) + } + return; + }|] + + +-- Segmented reduction along the innermost dimension of an array. Performs one +-- individual reduction per segment of the source array. These reductions +-- proceed in parallel. +-- +-- foldSeg :: (Shape ix, Elt a) +-- => (Exp a -> Exp a -> Exp a) +-- -> Exp a +-- -> Acc (Array (ix :. Int) a) +-- -> Acc Segments +-- -> Acc (Array (ix :. Int) a) +-- +-- fold1Seg :: (Shape ix, Elt a) +-- => (Exp a -> Exp a -> Exp a) +-- -> Acc (Array (ix :. Int) a) +-- -> Acc Segments +-- -> Acc (Array (ix :. Int) a) +-- +-- Each segment of the vector is assigned to a warp, which computes the +-- reduction of the i-th section, in parallel. Care is taken to ensure that data +-- array access is aligned to a warp boundary. +-- +-- Since an entire 32-thread warp is assigned for each segment, many threads +-- will remain idle when the segments are very small. This code relies on +-- implicit synchronisation among threads in a warp. +-- +-- The offset array contains the starting index for each segment in the input +-- array. The i-th warp reduces values in the input array at indices +-- [d_offset[i], d_offset[i+1]). +-- +mkFoldSeg :: forall a. + DeviceProperties + -> Int + -> Type -- of the segments array + -> CUFun (a -> a -> a) + -> Maybe (CUExp a) + -> CUTranslSkel +mkFoldSeg dev dim tySeg (CULam _ (CULam use0 (CUBody (CUExp env combine)))) mseed = + CUTranslSkel name [cunit| + $edecl:(cdim "DimOut" dim) + $edecl:(cdim "DimIn0" dim) + + extern "C" + __global__ void + $id:name + ( + $params:argOut, + $params:argIn0, + const $ty:(cptr tySeg) d_offset, + const typename DimOut shOut, + const typename DimIn0 shIn0 + ) + { + const int vectors_per_block = blockDim.x / warpSize; + const int num_vectors = vectors_per_block * gridDim.x; + const int thread_id = blockDim.x * blockIdx.x + threadIdx.x; + const int vector_id = thread_id / warpSize; + const int thread_lane = threadIdx.x & (warpSize - 1); + const int vector_lane = threadIdx.x / warpSize; + + const int num_segments = indexHead(shOut); + const int total_segments = size(shOut); + + extern volatile __shared__ int s_ptrs[][2]; + + $decls:smem + $decls:decl1 + $decls:decl0 + + for (int seg = vector_id; seg < total_segments; seg += num_vectors) + { + const int s = seg % num_segments; + const int base = (seg / num_segments) * indexHead(shIn0); + + /* + * Use two threads to fetch the indices of the start and end of this + * segment. This results in single coalesced global read, instead of two + * separate transactions. + */ + if (thread_lane < 2) + s_ptrs[vector_lane][thread_lane] = (int) d_offset[s + thread_lane]; + + const int start = base + s_ptrs[vector_lane][0]; + const int end = base + s_ptrs[vector_lane][1]; + const int num_elements = end - start; + + /* + * Each thread reads in values of this segment, accumulating a local sum + */ + if (num_elements > warpSize) + { + /* + * Ensure aligned access to global memory + */ + int i = start - (start & (warpSize - 1)) + thread_lane; + if (i >= start) + { + $stms:(x1 .=. getIn0 "i") + } + + /* + * Subsequent reads to global memory are aligned, but make sure all + * threads have initialised their local sum. + */ + if (i + warpSize < end) + { + $decls:(getTmp "i + warpSize") + + if (i >= start) { + $decls:env + $stms:(x1 .=. combine) + } + else { + $stms:(x1 .=. x0) + } + } + + /* + * Now, iterate along the inner-most dimension collecting a local sum + */ + for (i += 2 * warpSize; i < end; i += warpSize) + { + $decls:env + $stms:(x0 .=. getIn0 "i") + $stms:(x1 .=. combine) + } + } + else if (start + thread_lane < end) + { + $stms:(x1 .=. getIn0 "start + thread_lane") + } + + /* + * Store local sums into shared memory and reduce to a single value + */ + const int n = min(num_elements, warpSize); + $stms:(sdata "threadIdx.x" .=. x1) + $stms:(tail $ reduceWarp dev elt "n" "thread_lane" sdata env combine) + + /* + * Finally, the first thread writes the result for this segment + */ + if (thread_lane == 0) + { + $stms:(maybe inclusive_finish exclusive_finish mseed) + } + } + } + |] + where + name = maybe "fold1Seg" (const "foldSeg") mseed + elt = eltType (undefined :: a) + (argIn0, x0, decl0, getIn0, getTmp) = getters 0 elt use0 + (argOut, _, setOut) = setters elt + (x1, decl1) = locals "x1" elt + (smem, sdata) = shared 0 (Just $ [cexp| &s_ptrs[vectors_per_block][2] |]) [cexp| blockDim.x |] elt + -- + inclusive_finish = setOut "seg" x1 + exclusive_finish (CUExp env' seed) = [cstm| + if (num_elements > 0) { + $decls:env' + $stms:(x0 .=. seed) + $stms:(x1 .=. combine) + } else { + $decls:env' + $stms:(x1 .=. seed) + }|] : + setOut "seg" x1 + + + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +-- Threads of a warp run in lockstep, so there is no need to synchronise. We +-- hijack the standard local variable sets (x0 and x1) for the combination +-- function. The initial values must already be stored in shared memory. The +-- final result is stored in x1. +-- +reduceWarp :: DeviceProperties + -> [Type] + -> String -- number of elements + -> String -- thread identifier: usually the lane or thread id + -> (String -> [Exp]) -- index shared memory + -> [InitGroup] -- local binding environment for the.. + -> [Exp] -- ..binary associative combination function + -> [Stm] +reduceWarp dev elt n tid sdata env combine = map (reduce . pow2) [v,v-1..0] + where + v = floor (logBase 2 (fromIntegral $ warpSize dev :: Double)) :: Int + pow2 x = (2::Int) ^ x + (x0, _) = locals "x0" elt + (x1, _) = locals "x1" elt + -- + reduce i + | i > 1 + = [cstm| if ( $id:tid + $int:i < $id:n ) { + $decls:env + $stms:(x0 .=. sdata ("threadIdx.x + " ++ show i)) + $stms:(x1 .=. combine) + $stms:(sdata "threadIdx.x" .=. x1) + } + |] + -- + | otherwise + = [cstm| if ( $id:tid + $int:i < $id:n ) { + $decls:env + $stms:(x0 .=. sdata "threadIdx.x + 1") + $stms:(x1 .=. combine) + } + |] + + +-- All threads cooperatively reduce this block's data in shared memory. We +-- hijack the standard local variables (x0 and x1) for the combination function. +-- The initial values must already be stored in shared memory. +-- +reduceBlock :: DeviceProperties + -> [Type] + -> String -- number of elements + -> (String -> [Exp]) -- index shared memory + -> [InitGroup] -- local binding environment for the.. + -> [Exp] -- ..binary associative function + -> [Stm] +reduceBlock dev elt n sdata env combine = map (reduce . pow2) [u-1,u-2..v] + where + u = floor (logBase 2 (fromIntegral $ maxThreadsPerBlock dev :: Double)) :: Int + v = floor (logBase 2 (fromIntegral $ warpSize dev :: Double)) :: Int + pow2 x = (2::Int) ^ x + (x0, _) = locals "x0" elt + (x1, _) = locals "x1" elt + -- + reduce i + | i > warpSize dev + = [cstm| if ( $id:n > $int:i ) { + if ( threadIdx.x + $int:i < $id:n ) { + $decls:env + $stms:(x0 .=. sdata ("threadIdx.x + " ++ show i)) + $stms:(x1 .=. combine) + $stms:(sdata "threadIdx.x" .=. x1) + } + __syncthreads(); + } + |] + -- + | otherwise + = [cstm| if ( threadIdx.x < $int:(warpSize dev) ) { + $stms:(reduceWarp dev elt n "threadIdx.x" sdata env combine) + } + |] + diff --git a/Data/Array/Accelerate/CUDA/CodeGen/Stencil.hs b/Data/Array/Accelerate/CUDA/CodeGen/Stencil.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/CodeGen/Stencil.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS -fno-warn-incomplete-patterns #-} +-- | +-- 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 +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.CUDA.CodeGen.Stencil ( + + mkStencil, mkStencil2 + +) where + +import Language.C.Syntax +import Language.C.Quote.CUDA + +import Data.Array.Accelerate.Type +import Data.Array.Accelerate.AST ( OpenAcc, Fun, Stencil ) +import Data.Array.Accelerate.Array.Sugar ( Array, Elt, shapeToList ) +import Data.Array.Accelerate.CUDA.CodeGen.Base +import Data.Array.Accelerate.CUDA.CodeGen.Type + +import qualified Data.Array.Accelerate.Analysis.Stencil as Stencil +import qualified Data.Array.IArray as IArray + + +-- Map a stencil over an array. In contrast to 'map', the domain of a stencil +-- function is an entire /neighbourhood/ of each array element. Neighbourhoods +-- are sub-arrays centred around a focal point. They are not necessarily +-- rectangular, but they are symmetric in each dimension and have an extent of +-- at least three in each dimensions — due to the symmetry requirement, the +-- extent is necessarily odd. The focal point is the array position that is +-- determined by the stencil. +-- +-- For those array positions where the neighbourhood extends past the boundaries +-- of the source array, a boundary condition determines the contents of the +-- out-of-bounds neighbourhood positions. +-- +-- stencil :: (Shape ix, Elt a, Elt b, Stencil ix a stencil) +-- => (stencil -> Exp b) -- stencil function +-- -> Boundary a -- boundary condition +-- -> Acc (Array ix a) -- source array +-- -> Acc (Array ix b) -- destination array +-- +-- To improve performance, the input array(s) are read through the texture +-- cache. +-- +mkStencil :: forall sh stencil a b. (Stencil sh a stencil, Elt b) + => Int + -> CUFun (stencil -> b) + -> Boundary (CUExp a) + -> Array sh b {- dummy -} + -> CUTranslSkel +mkStencil dim (CULam use0 (CUBody (CUExp env stencil))) boundary _ = + CUTranslSkel "stencil" [cunit| + $edecl:(cdim "Shape" dim) + $edecls:arrIn0 + + extern "C" + __global__ void + stencil + ( + $params:argOut, + const typename Shape shIn0 + ) + { + const int shapeSize = size(shIn0); + const int gridSize = __umul24(blockDim.x, gridDim.x); + int i; + + for ( i = __umul24(blockDim.x, blockIdx.x) + threadIdx.x + ; i < shapeSize + ; i += gridSize ) + { + const typename Shape ix = fromIndex(shIn0, i); + $decls:(getIn0 "ix") + $decls:env + $stms:(setOut "i" stencil) + } + } + |] + where + tyOut = eltType (undefined :: b) + stencilIn0 = eltTypeTex (undefined :: a) + (argOut, _, setOut) = setters tyOut + (arrIn0, getIn0) = stencilAccess 0 dim stencilIn0 use0 boundary offsets + -- + offsets = map shapeToList p0 + p0 = Stencil.offsets (undefined :: Fun aenv (stencil -> b)) + (undefined :: OpenAcc aenv (Array sh a)) + + +-- Map a binary stencil of an array. The extent of the resulting array is the +-- intersection of the extents of the two source arrays. +-- +-- stencil2 :: (Shape ix, Elt a, Elt b, Elt c, +-- Stencil ix a stencil1, +-- Stencil ix b stencil2) +-- => (stencil1 -> stencil2 -> Exp c) -- binary stencil function +-- -> Boundary a -- boundary condition #1 +-- -> Acc (Array ix a) -- source array #1 +-- -> Boundary b -- boundary condition #2 +-- -> Acc (Array ix b) -- source array #2 +-- -> Acc (Array ix c) -- destination array +-- +mkStencil2 :: forall sh stencil1 stencil0 a b c. + (Stencil sh a stencil1, Stencil sh b stencil0, Elt c) + => Int + -> CUFun (stencil1 -> stencil0 -> c) + -> Boundary (CUExp a) + -> Boundary (CUExp b) + -> Array sh c {- dummy -} + -> CUTranslSkel +mkStencil2 dim (CULam use1 (CULam use0 (CUBody (CUExp env stencil)))) boundary1 boundary0 _ = + CUTranslSkel "stencil2" [cunit| + $edecl:(cdim "Shape" dim) + $edecls:arrIn0 + $edecls:arrIn1 + + extern "C" + __global__ void + stencil2 + ( + $params:argOut, + const typename Shape shOut, + const typename Shape shIn1, + const typename Shape shIn0 + ) + { + const int shapeSize = size(shOut); + const int gridSize = __umul24(blockDim.x, gridDim.x); + int i; + + for ( i = __umul24(blockDim.x, blockIdx.x) + threadIdx.x + ; i < shapeSize + ; i += gridSize ) + { + const typename Shape ix = fromIndex(shOut, i); + $decls:(getIn0 "ix") + $decls:(getIn1 "ix") + $decls:env + $stms:(setOut "i" stencil) + } + } + |] + where + tyOut = eltType (undefined :: c) + stencilIn0 = eltTypeTex (undefined :: b) + stencilIn1 = eltTypeTex (undefined :: a) + (argOut, _, setOut) = setters tyOut + (arrIn0, getIn0) = stencilAccess 0 dim stencilIn0 use0 boundary0 offsets0 + (arrIn1, getIn1) = stencilAccess 1 dim stencilIn1 use1 boundary1 offsets1 + -- + offsets0 = map shapeToList p0 + offsets1 = map shapeToList p1 + (p1, p0) = Stencil.offsets2 (undefined :: Fun aenv (stencil1 -> stencil0 -> c)) + (undefined :: OpenAcc aenv (Array sh a)) + (undefined :: OpenAcc aenv (Array sh b)) + + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +stencilAccess + :: Int -- array de Bruijn index + -> Int -- array dimensionality + -> [Type] -- array type (texture memory) + -> [(Int, Type, Exp)] -- the variables used in the scalar expression + -> Boundary (CUExp a) -- how to handle boundary array access + -> [[Int]] -- all stencil index offsets, top left to bottom right + -> ( [Definition] -- texture-reference definitions + , String -> [InitGroup] ) -- array indexing +stencilAccess base dim stencil subs boundary shx = + ( textures + , \ix -> concatMap (get ix) subs ) + where + n = length stencil + sh = "shIn" ++ show base + arr x = "stencil" ++ shows base "_a" ++ show (x `mod` n) + textures = zipWith cglobal stencil (map arr [n-1, n-2 .. 0]) + -- + offsets :: IArray.Array Int [Int] + offsets = IArray.listArray (0, length shx-1) shx + -- + get ix (i,t,v) = case boundary of + Clamp -> bounded "clamp" + Mirror -> bounded "mirror" + Wrap -> bounded "wrap" + Constant (CUExp _ c) -> inRange c + where + j = 'j':shows base "_a" ++ show i + k = 'k':shows base "_a" ++ show i + -- + bounded f + = [cdecl| const int $id:j = $exp:ix'; |] + : [cdecl| const $ty:t $id:(show v) = $exp:(indexArray t (cvar (arr i)) (cvar j)); |] + : [] + where + ix' = case offsets IArray.! div i n of + ks | all (== 0) ks -> [cexp| toIndex( $id:sh, ix ) |] + | otherwise -> [cexp| toIndex( $id:sh, $exp:(ccall f [cvar sh, cursor ks]) ) |] + -- + inRange c = case offsets IArray.! div i n of + ks | all (== 0) ks -> let f = indexArray t (cvar (arr i)) (ccall "toIndex" [cvar sh, cvar "ix"]) + in [[cdecl| const $ty:t $id:(show v) = $exp:f; |]] + | otherwise -> [cdecl| const typename Shape $id:j = $exp:(cursor ks); |] + : [cdecl| const typename bool $id:k = inRange( $id:sh, $id:j ); |] + : [cdecl| const $ty:t $id:(show v) = $id:k ? $exp:(indexArray t (cvar (arr i)) (ccall "toIndex" [cvar sh, cvar j])) + : $exp:(reverse c !! mod i n); |] + : [] + -- + cursor [c] = [cexp| $id:ix + $int:c |] + cursor cs = ccall "shape" $ zipWith (\a c -> [cexp| $id:ix . $id:('a':show a) + $int:c |]) [dim-1,dim-2..0] cs + diff --git a/Data/Array/Accelerate/CUDA/CodeGen/Type.hs b/Data/Array/Accelerate/CUDA/CodeGen/Type.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/CodeGen/Type.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE QuasiQuotes #-} +-- | +-- 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 +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Generate types for the reified elements of an array computation +-- + +module Data.Array.Accelerate.CUDA.CodeGen.Type ( + + -- surface types + accType, accTypeTex, segmentsType, expType, + eltType, eltTypeTex, eltSizeOf, + + -- primitive bits... + codegenIntegralType, codegenScalarType + +) where + +-- friends +import Data.Array.Accelerate.AST +import Data.Array.Accelerate.Type +import Data.Array.Accelerate.CUDA.CodeGen.Base +import qualified Data.Array.Accelerate.Array.Sugar as Sugar +import qualified Data.Array.Accelerate.Analysis.Type as Sugar + +-- libraries +import Language.C.Quote.CUDA +import qualified Language.C as C +import qualified Foreign.Storable as F + + +#include "accelerate.h" + + +-- Surface element types +-- --------------------- + +accType :: OpenAcc aenv (Sugar.Array dim e) -> [C.Type] +accType = codegenTupleType . Sugar.accType + +expType :: OpenExp aenv env t -> [C.Type] +expType = codegenTupleType . Sugar.expType + +segmentsType :: OpenAcc aenv (Sugar.Segments i) -> C.Type +segmentsType seg + | [s] <- accType seg = s + | otherwise = INTERNAL_ERROR(error) "accType" "non-scalar segment type" + + +--sizeOfAccTypes :: OpenAcc aenv (Sugar.Array dim e) -> [Int] +--sizeOfAccTypes = sizeOf' . Sugar.accType +-- where +-- sizeOf' :: TupleType a -> [Int] +-- sizeOf' UnitTuple = [] +-- sizeOf' x@(SingleTuple _) = [Sugar.sizeOf x] +-- sizeOf' (PairTuple a b) = sizeOf' a ++ sizeOf' b + +eltType :: Sugar.Elt a => a {- dummy -} -> [C.Type] +eltType = codegenTupleType . Sugar.eltType + +eltTypeTex :: Sugar.Elt a => a {- dummy -} -> [C.Type] +eltTypeTex = codegenTupleTex . Sugar.eltType + +eltSizeOf :: Sugar.Elt a => a {- dummy -} -> [Int] +eltSizeOf = sizeOf' . Sugar.eltType + where + sizeOf' :: TupleType a -> [Int] + sizeOf' UnitTuple = [] + sizeOf' x@(SingleTuple _) = [Sugar.sizeOf x] + 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 + +codegenNumType :: NumType a -> C.Type +codegenNumType (IntegralNumType ty) = codegenIntegralType ty +codegenNumType (FloatingNumType ty) = codegenFloatingType ty + +codegenIntegralType :: IntegralType a -> C.Type +codegenIntegralType (TypeInt8 _) = typename "int8_t" +codegenIntegralType (TypeInt16 _) = typename "int16_t" +codegenIntegralType (TypeInt32 _) = typename "int32_t" +codegenIntegralType (TypeInt64 _) = typename "int64_t" +codegenIntegralType (TypeWord8 _) = typename "uint8_t" +codegenIntegralType (TypeWord16 _) = typename "uint16_t" +codegenIntegralType (TypeWord32 _) = typename "uint32_t" +codegenIntegralType (TypeWord64 _) = typename "uint64_t" +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|] + +codegenIntegralType (TypeInt _) = + case F.sizeOf (undefined::Int) of + 4 -> typename "int32_t" + 8 -> typename "int64_t" + _ -> error "we can never get here" + +codegenIntegralType (TypeWord _) = + case F.sizeOf (undefined::Int) of + 4 -> typename "uint32_t" + 8 -> typename "uint64_t" + _ -> error "we can never get here" + + +codegenFloatingType :: FloatingType a -> C.Type +codegenFloatingType (TypeFloat _) = [cty|float|] +codegenFloatingType (TypeCFloat _) = [cty|float|] +codegenFloatingType (TypeDouble _) = [cty|double|] +codegenFloatingType (TypeCDouble _) = [cty|double|] + +codegenNonNumType :: NonNumType a -> C.Type +codegenNonNumType (TypeBool _) = error "codegenNonNum :: Bool" +codegenNonNumType (TypeChar _) = error "codegenNonNum :: Char" +codegenNonNumType (TypeCChar _) = [cty|char|] +codegenNonNumType (TypeCSChar _) = [cty|signed char|] +codegenNonNumType (TypeCUChar _) = [cty|unsigned char|] + + +-- Texture types +-- ------------- + +accTypeTex :: OpenAcc aenv (Sugar.Array dim e) -> [C.Type] +accTypeTex = codegenTupleTex . Sugar.accType + + +-- Implementation +-- +codegenTupleTex :: TupleType a -> [C.Type] +codegenTupleTex UnitTuple = [] +codegenTupleTex (SingleTuple t) = [codegenScalarTex t] +codegenTupleTex (PairTuple t1 t0) = codegenTupleTex t1 ++ codegenTupleTex t0 + +codegenScalarTex :: ScalarType a -> C.Type +codegenScalarTex (NumScalarType ty) = codegenNumTex ty +codegenScalarTex (NonNumScalarType ty) = codegenNonNumTex ty; + +codegenNumTex :: NumType a -> C.Type +codegenNumTex (IntegralNumType ty) = codegenIntegralTex ty +codegenNumTex (FloatingNumType ty) = codegenFloatingTex 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" + +codegenIntegralTex (TypeInt _) = + case F.sizeOf (undefined::Int) of + 4 -> typename "TexInt32" + 8 -> typename "TexInt64" + _ -> error "we can never get here" + +codegenIntegralTex (TypeWord _) = + case F.sizeOf (undefined::Word) of + 4 -> typename "TexWord32" + 8 -> typename "TexWord64" + _ -> error "we can never get here" + + +codegenFloatingTex :: FloatingType a -> C.Type +codegenFloatingTex (TypeFloat _) = typename "TexFloat" +codegenFloatingTex (TypeCFloat _) = typename "TexCFloat" +codegenFloatingTex (TypeDouble _) = typename "TexDouble" +codegenFloatingTex (TypeCDouble _) = typename "TexCDouble" + + +-- TLM 2010-06-29: +-- Bool and Char can be implemented once the array types in +-- Data.Array.Accelerate.[CUDA.]Array.Data are made concrete. +-- +codegenNonNumTex :: NonNumType a -> C.Type +codegenNonNumTex (TypeBool _) = error "codegenNonNumTex :: Bool" +codegenNonNumTex (TypeChar _) = error "codegenNonNumTex :: Char" +codegenNonNumTex (TypeCChar _) = typename "TexCChar" +codegenNonNumTex (TypeCSChar _) = typename "TexCSChar" +codegenNonNumTex (TypeCUChar _) = typename "TexCUChar" + diff --git a/Data/Array/Accelerate/CUDA/Compile.hs b/Data/Array/Accelerate/CUDA/Compile.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/Compile.hs @@ -0,0 +1,448 @@ +{-# LANGUAGE CPP, GADTs, TupleSections, ScopedTypeVariables #-} +-- | +-- 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 +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-partable (GHC extensions) +-- + +module Data.Array.Accelerate.CUDA.Compile ( + + -- * generate and compile kernels to realise a computation + compileAcc, compileAfun1 + +) where + +#include "accelerate.h" + +-- friends +import Data.Array.Accelerate.Type +import Data.Array.Accelerate.Tuple + +import Data.Array.Accelerate.CUDA.AST +import Data.Array.Accelerate.CUDA.FullList as FL +import Data.Array.Accelerate.CUDA.State +import Data.Array.Accelerate.CUDA.CodeGen +import Data.Array.Accelerate.CUDA.Array.Sugar +import Data.Array.Accelerate.CUDA.Analysis.Launch +import qualified Data.Array.Accelerate.CUDA.Debug as D + +-- libraries +import Numeric +import Prelude hiding ( exp, catch ) +import Control.Applicative hiding ( Const ) +import Blaze.ByteString.Builder +import Blaze.ByteString.Builder.Char8 +import Control.Exception +import Control.Monad +import Control.Monad.Trans +import Crypto.Hash.MD5 ( hashlazy ) +import Data.Label.PureM +import Data.List +import Data.Maybe +import Data.Monoid +import Foreign.Storable +import System.Directory +import System.Exit ( ExitCode(..) ) +import System.FilePath +import System.IO +import System.IO.Unsafe +import System.Process +import Text.PrettyPrint.Mainland ( RDoc(..), ppr, renderCompact ) +import Data.ByteString.Internal ( w2c ) +import qualified Data.HashSet as Set +import qualified Data.HashTable.IO as HT +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Foreign.CUDA.Driver as CUDA +import qualified Foreign.CUDA.Analysis as CUDA + +#ifdef VERSION_unix +import System.Posix.Process +#else +import System.Win32.Process +#endif + +import Paths_accelerate_cuda ( getDataDir ) + + +-- | Initiate code generation, compilation, and data transfer for an array +-- expression. The returned array computation is annotated so to be suitable for +-- execution in the CUDA environment. This includes: +-- +-- * list of array variables embedded within scalar expressions +-- * kernel object(s) required to executed the kernel +-- +compileAcc :: Acc a -> CIO (ExecAcc a) +compileAcc acc = prepareAcc acc + + +compileAfun1 :: Afun (a -> b) -> CIO (ExecAfun (a -> b)) +compileAfun1 (Alam (Abody b)) = Alam . Abody <$> prepareAcc b +compileAfun1 _ = + error "Hope (noun): something that happens to facts when the world refuses to agree" + + +prepareAcc :: OpenAcc aenv a -> CIO (ExecOpenAcc aenv a) +prepareAcc rootAcc = traverseAcc rootAcc + where + -- Traverse an open array expression in depth-first order + -- + -- The applicative combinators are used to gloss over that we are passing + -- around the AST nodes together with a set of free variable indices that + -- are merged at every step. + -- + traverseAcc :: forall aenv a. OpenAcc aenv a -> CIO (ExecOpenAcc aenv a) + traverseAcc acc@(OpenAcc pacc) = do + + let exec :: (AccBindings aenv, PreOpenAcc ExecOpenAcc aenv a) -> CIO (ExecOpenAcc aenv a) + exec (var, eacc) = do + kernel <- build acc var + return $ ExecAcc (FL.singleton () kernel) var eacc + + node :: (AccBindings aenv, PreOpenAcc ExecOpenAcc aenv a) -> CIO (ExecOpenAcc aenv a) + node (_, eacc) = return $ ExecAcc noKernel mempty eacc + + case pacc of + -- + -- Environment manipulations + -- + Avar ix -> node $ pure (Avar ix) + + -- + -- Let bindings + -- + Alet a b -> node . pure =<< Alet <$> traverseAcc a <*> traverseAcc b + Apply f a -> node . pure =<< Apply <$> compileAfun1 f <*> traverseAcc a + Acond p t e -> node =<< liftA3 Acond <$> travE p <*> travA t <*> travA e + + -- + -- Tuples + -- + Atuple tup -> node =<< liftA Atuple <$> travAtup tup + Aprj ix tup -> node =<< liftA (Aprj ix) <$> travA tup + + -- + -- Array injection + -- + Use arrs -> use (arrays (undefined::a)) arrs >> node (pure $ Use arrs) + where + use :: ArraysR a' -> a' -> CIO () + use ArraysRunit () = return () + use ArraysRarray arr = useArray arr + use (ArraysRpair r1 r2) (a1, a2) = use r1 a1 >> use r2 a2 + + -- + -- Computation nodes + -- + Reshape s a -> node =<< liftA2 Reshape <$> travE s <*> travA a + Unit e -> node =<< liftA Unit <$> travE e + Generate e f -> exec =<< liftA2 Generate <$> travE e <*> travF f + Replicate slix e a -> exec =<< liftA2 (Replicate slix) <$> travE e <*> travA a + Index slix a e -> exec =<< liftA2 (Index slix) <$> travA a <*> travE e + Map f a -> exec =<< liftA2 Map <$> travF f <*> travA a + ZipWith f a b -> exec =<< liftA3 ZipWith <$> travF f <*> travA a <*> travA b + Fold f z a -> exec =<< liftA3 Fold <$> travF f <*> travE z <*> travA a + Fold1 f a -> exec =<< liftA2 Fold1 <$> travF f <*> travA a + FoldSeg f e a s -> exec =<< liftA4 FoldSeg <$> travF f <*> travE e <*> travA a <*> travA (segments s) + Fold1Seg f a s -> exec =<< liftA3 Fold1Seg <$> travF f <*> travA a <*> travA (segments s) + Permute f a g b -> exec =<< liftA4 Permute <$> travF f <*> travA a <*> travF g <*> travA b + Backpermute e f a -> exec =<< liftA3 Backpermute <$> travE e <*> travF f <*> travA a + Stencil f b a -> exec =<< liftA2 (flip Stencil b) <$> travF f <*> travA a + 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' + + -- TODO: write helper functions to clean these up + Scanl f e a -> do + ExecAcc (FL _ scan _) var eacc <- exec =<< liftA3 Scanl <$> travF f <*> travE e <*> travA a + add <- build (OpenAcc (Fold1 f mat)) var + return $ ExecAcc (cons () add $ FL.singleton () scan) var eacc + + Scanl' f e a -> do + ExecAcc (FL _ scan _) var eacc <- exec =<< liftA3 Scanl' <$> travF f <*> travE e <*> travA a + add <- build (OpenAcc (Fold1 f mat)) var + return $ ExecAcc (cons () (retag add) $ FL.singleton () scan) var eacc + + Scanl1 f a -> do + ExecAcc (FL _ scan1 _) var eacc <- exec =<< liftA2 Scanl1 <$> travF f <*> travA a + add <- build (OpenAcc (Fold1 f mat)) var + return $ ExecAcc (cons () add $ FL.singleton () scan1) var eacc + + Scanr f e a -> do + ExecAcc (FL _ scan _) var eacc <- exec =<< liftA3 Scanr <$> travF f <*> travE e <*> travA a + add <- build (OpenAcc (Fold1 f mat)) var + return $ ExecAcc (cons () add $ FL.singleton () scan) var eacc + + Scanr' f e a -> do + ExecAcc (FL _ scan _) var eacc <- exec =<< liftA3 Scanr' <$> travF f <*> travE e <*> travA a + add <- build (OpenAcc (Fold1 f mat)) var + return $ ExecAcc (cons () (retag add) $ FL.singleton () scan) var eacc + + Scanr1 f a -> do + ExecAcc (FL _ scan1 _) var eacc <- exec =<< liftA2 Scanr1 <$> travF f <*> travA a + add <- build (OpenAcc (Fold1 f mat)) var + return $ ExecAcc (cons () add $ FL.singleton () scan1) var eacc + + where + travA :: OpenAcc aenv' a' -> CIO (AccBindings aenv', ExecOpenAcc aenv' a') + travA a = pure <$> traverseAcc a + + travAtup :: Atuple (OpenAcc aenv') a' -> CIO (AccBindings aenv', Atuple (ExecOpenAcc aenv') a') + travAtup NilAtup = return (pure NilAtup) + travAtup (SnocAtup t a) = liftA2 SnocAtup <$> travAtup t <*> travA a + + travF :: OpenFun env aenv t -> CIO (AccBindings aenv, PreOpenFun ExecOpenAcc env aenv t) + travF (Body b) = liftA Body <$> travE b + travF (Lam f) = liftA Lam <$> travF f + + segments :: forall i. (Elt i, IsIntegral i) + => OpenAcc aenv (Segments i) -> OpenAcc aenv (Segments i) + segments = OpenAcc . Scanl plus (Const (fromElt (0::i))) + + plus :: (Elt i, IsIntegral i) => PreOpenFun OpenAcc () aenv (i -> i -> i) + plus = Lam (Lam (Body (PrimAdd numType + `PrimApp` + Tuple (NilTup `SnocTup` Var (SuccIdx ZeroIdx) + `SnocTup` Var ZeroIdx)))) + + mat :: Elt e => OpenAcc aenv (Array DIM2 e) + mat = OpenAcc $ Use ((), Array (((),0),0) undefined) + + noKernel :: FullList () (AccKernel a) + noKernel = FL () (INTERNAL_ERROR(error) "compile" "no kernel module for this node") Nil + + -- Traverse a scalar expression + -- + travE :: OpenExp env aenv e + -> CIO (AccBindings 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 + -- + 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 + 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 + PrimApp f e -> liftA (PrimApp f) <$> travE e + IndexScalar a e -> liftA2 IndexScalar <$> travA a <*> travE e + Shape a -> liftA Shape <$> travA a + ShapeSize e -> liftA ShapeSize <$> travE e + where + travA :: (Shape sh, Elt e) + => OpenAcc aenv (Array sh e) -> CIO (AccBindings aenv, ExecOpenAcc aenv (Array sh e)) + travA a = do + a' <- traverseAcc a + return $ (bind a', a') + + travT :: Tuple (OpenExp env aenv) t + -> CIO (AccBindings aenv, Tuple (PreOpenExp ExecOpenAcc env aenv) t) + travT NilTup = return (pure NilTup) + travT (SnocTup t e) = liftA2 SnocTup <$> travT t <*> travE e + + bind :: (Shape sh, Elt e) => ExecOpenAcc aenv (Array sh e) -> AccBindings aenv + bind (ExecAcc _ _ (Avar ix)) = AccBindings ( Set.singleton (ArrayVar ix) ) + bind _ = INTERNAL_ERROR(error) "bind" "expected array variable" + + +-- Applicative +-- ----------- +-- +liftA4 :: Applicative f => (a -> b -> c -> d -> e) -> f a -> f b -> f c -> f d -> f e +liftA4 f a b c d = f <$> a <*> b <*> c <*> d + + +-- Compilation +-- ----------- + +-- Generate, compile, and link code to evaluate an array computation. We use +-- 'unsafePerformIO' here to leverage laziness, so that the 'link' function +-- evaluates and blocks on the external compiler only once the compiled object +-- is truly needed. +-- +build :: OpenAcc aenv a -> AccBindings aenv -> CIO (AccKernel a) +build acc fvar = do + dev <- gets deviceProps + table <- gets kernelTable + (entry,key) <- compile table dev acc fvar + let (mdl,fun,occ) = unsafePerformIO $ do + m <- link table key + f <- CUDA.getFun m entry + l <- CUDA.requires f CUDA.MaxKernelThreadsPerBlock + o <- determineOccupancy acc dev f l + D.when D.dump_cc (stats entry f o) + return (m,f,o) + -- + return $ Kernel entry mdl fun occ (launchConfig acc dev occ) + where + stats name fn occ = do + regs <- CUDA.requires fn CUDA.NumRegs + smem <- CUDA.requires fn CUDA.SharedSizeBytes + cmem <- CUDA.requires fn CUDA.ConstSizeBytes + lmem <- CUDA.requires fn CUDA.LocalSizeBytes + let msg1 = "entry function '" ++ name ++ "' used " + ++ shows regs " registers, " ++ shows smem " bytes smem, " + ++ shows lmem " bytes lmem, " ++ shows cmem " bytes cmem" + msg2 = "multiprocessor occupancy " ++ showFFloat (Just 1) (CUDA.occupancy100 occ) "% : " + ++ shows (CUDA.activeThreads occ) " threads over " + ++ shows (CUDA.activeWarps occ) " warps in " + ++ shows (CUDA.activeThreadBlocks occ) " blocks" + -- + -- make sure kernel/stats are printed together + -- + message $ intercalate "\n" [msg1, "cc: " ++ 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 successfully, the temporary files are removed. +-- +link :: KernelTable -> KernelKey -> IO CUDA.Module +link table key = + let intErr = INTERNAL_ERROR(error) "link" "missing kernel entry" + in do + ctx <- CUDA.get + (KernelEntry cufile stat) <- fromMaybe intErr `fmap` HT.lookup table key + case stat of + Right (KernelObject bin active) + | Just mdl <- FL.lookup ctx active -> return mdl + | otherwise -> do + message "re-linking module for current context" + mdl <- CUDA.loadData bin + let obj = KernelObject bin (FL.cons ctx mdl active) + HT.insert table key (KernelEntry cufile (Right obj)) + return mdl + -- + Left pid -> do + -- wait for compiler to finish and load binary object + -- + message "waiting for nvcc..." + waitFor pid + bin <- B.readFile (replaceExtension cufile ".cubin") + mdl <- CUDA.loadData bin + let obj = KernelObject bin (FL.singleton ctx mdl) + +#ifndef ACCELERATE_CUDA_PERSISTENT_CACHE + -- remove build products + -- + removeFile cufile + removeFile (replaceExtension cufile ".cubin") + removeDirectory (dropFileName cufile) + `catch` \(_ :: IOError) -> return () -- directory not empty +#endif + + -- update hash table + -- + HT.insert table key (KernelEntry cufile (Right obj)) + return mdl + + +-- Generate and compile code for a single open array expression +-- +compile :: KernelTable + -> CUDA.DeviceProperties + -> OpenAcc aenv a + -> AccBindings aenv + -> CIO (String, KernelKey) +compile table dev acc fvar = do + exists <- isJust `fmap` liftIO (HT.lookup table key) + unless exists $ do + message $ unlines [ show key, map w2c (L.unpack code) ] + nvcc <- fromMaybe (error "nvcc: command not found") <$> liftIO (findExecutable "nvcc") + (file,hdl) <- openOutputFile "dragon.cu" -- rawr! + flags <- compileFlags file + (_,_,_,pid) <- liftIO $ do + L.hPut hdl code `finally` hClose hdl + createProcess (proc nvcc flags) `onException` removeFile file + -- + liftIO $ HT.insert table key (KernelEntry file (Left pid)) + -- + return (entry, key) + where + cunit = codegenAcc dev acc fvar + entry = show cunit + key = (CUDA.computeCapability dev, hashlazy code) + code = toLazyByteString + . layout . renderCompact $ ppr cunit + -- + layout (RText _ s next) = fromString s `mappend` layout next + layout (RChar c next) = fromChar c `mappend` layout next + layout (RLine _ next) = fromChar '\n' `mappend` layout next -- no indenting + layout (RPos _ next) = layout next -- no line markers + layout REmpty = mempty -- done + + +-- Wait for the compilation process to finish +-- +waitFor :: ProcessHandle -> IO () +waitFor pid = do + status <- waitForProcess pid + case status of + ExitSuccess -> return () + ExitFailure c -> error $ "nvcc terminated abnormally (" ++ show c ++ ")" + + +-- Determine the appropriate command line flags to pass to the compiler process. +-- This is dependent on the host architecture and device capabilities. +-- +compileFlags :: FilePath -> CIO [String] +compileFlags cufile = do + arch <- CUDA.computeCapability `fmap` gets deviceProps + ddir <- liftIO getDataDir + return $ filter (not . null) $ + [ "-I", ddir "cubits" + , "--compiler-options", "-fno-strict-aliasing" + , "-arch=sm_" ++ show (round (arch * 10) :: Int) + , "-cubin" + , "-o", cufile `replaceExtension` "cubin" + , if D.mode D.verbose then "" else "--disable-warnings" + , if D.mode D.debug then "-G" else "-O3" + , machine + , cufile ] + where + wordSize = sizeOf (undefined::Int) + machine | wordSize == 4 = "-m32" + | wordSize == 8 = "-m64" + | otherwise = error "recreational scolding?" + + +-- Open a unique file in the temporary directory used for compilation +-- by-products. The directory will be created if it does not exist. +-- +openOutputFile :: String -> CIO (FilePath, Handle) +openOutputFile template = liftIO $ do +#ifdef ACCELERATE_CUDA_PERSISTENT_CACHE + dir <- () <$> getDataDir <*> pure "cache" +#else + pid <- getProcessID + dir <- () <$> getTemporaryDirectory <*> pure ("accelerate-cuda-" ++ show pid) +#endif + createDirectoryIfMissing True dir + openTempFile dir template + +#ifndef VERSION_unix +getProcessID :: ProcessHandle -> IO ProcessId +getProcessID = getProcessId +#endif + +-- Debug +-- ----- + +{-# INLINE message #-} +message :: MonadIO m => String -> m () +message msg = trace ("cc: " ++ msg) $ return () + +{-# INLINE trace #-} +trace :: MonadIO m => String -> m a -> m a +trace msg next = D.message D.dump_cc msg >> next + diff --git a/Data/Array/Accelerate/CUDA/Debug.hs b/Data/Array/Accelerate/CUDA/Debug.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/Debug.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE CPP, TemplateHaskell, TypeOperators #-} +{-# OPTIONS -fno-warn-unused-imports #-} +{-# OPTIONS -fno-warn-unused-binds #-} +-- | +-- 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 +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-partable (GHC extensions) +-- +-- Hijack some command line arguments to pass runtime debugging options. This +-- might cause problems for users of the library... +-- + +module Data.Array.Accelerate.CUDA.Debug ( + + showFFloatSIBase, + + message, event, when, mode, + verbose, debug, + dump_gc, dump_cc, dump_exec, + +) where + +import Numeric +import Data.List +import Data.Label +import Data.IORef +import Control.Monad.IO.Class +import System.IO.Unsafe +import System.Environment +import System.Console.GetOpt + +#if MIN_VERSION_base(4,5,0) +import Debug.Trace ( traceIO, traceEventIO ) +#else +import Debug.Trace ( putTraceMsg ) + +traceIO :: String -> IO () +traceIO = putTraceMsg + +traceEventIO :: String -> IO () +traceEventIO = traceIO +#endif + + +-- ----------------------------------------------------------------------------- +-- Pretty-printing + +showFFloatSIBase :: RealFloat a => Maybe Int -> a -> a -> ShowS +showFFloatSIBase p b n + = showString + . nubBy (\x y -> x == ' ' && y == ' ') + $ showFFloat p n' [ ' ', si_unit ] + where + n' = n / (b ^^ (pow-4)) + pow = max 0 . min 8 . (+) 4 . floor $ logBase b n + si_unit = "pnµm kMGT" !! pow + + +-- ----------------------------------------------------------------------------- +-- Internals + +data Flags = Flags + { + -- phase control + _dump_gc :: !Bool -- garbage collection & memory management + , _dump_cc :: !Bool -- compilation & linking + , _dump_exec :: !Bool -- kernel execution + + -- general options + , _verbose :: !Bool -- additional status messages + , _debug :: !Bool -- generate device code suitable for debugging + } + +$(mkLabels [''Flags]) + +flags :: [OptDescr (Flags -> Flags)] +flags = + [ 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 [] ["ddump-exec"] (NoArg (set dump_exec True)) "print kernel execution trace" + , Option [] ["dverbose"] (NoArg (set verbose True)) "print additional information" + , Option [] ["ddebug"] (NoArg (set debug True)) "generate debug information for device code" + ] + +initialise :: IO Flags +initialise = parse `fmap` getArgs + where + defaults = Flags False False False False False + parse = foldl parse1 defaults + parse1 opts x = case filter (\(Option _ [f] _ _) -> x `isPrefixOf` ('-':f)) flags 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 $ traceIO 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 when #-} +when :: MonadIO m => (Flags :-> Bool) -> m () -> m () +#ifdef ACCELERATE_DEBUG +when f action + | mode f = action + | otherwise = return () +#else +when _ _ = return () +#endif + diff --git a/Data/Array/Accelerate/CUDA/Execute.hs b/Data/Array/Accelerate/CUDA/Execute.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/Execute.hs @@ -0,0 +1,937 @@ +{-# LANGUAGE UndecidableInstances, OverlappingInstances, IncoherentInstances #-} +{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, FlexibleInstances #-} +{-# LANGUAGE RankNTypes, TupleSections, TypeOperators, TypeSynonymInstances #-} +{-# OPTIONS -fno-warn-orphans #-} +-- | +-- 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 +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-partable (GHC extensions) +-- + +module Data.Array.Accelerate.CUDA.Execute ( + + -- * Execute a computation under a CUDA environment + executeAcc, executeAfun1 + +) where + + +-- friends +import Data.Array.Accelerate.Type +import Data.Array.Accelerate.Tuple +import Data.Array.Accelerate.Array.Representation hiding (Shape, sliceIndex) +import qualified Data.Array.Accelerate.Interpreter as I +import qualified Data.Array.Accelerate.Array.Data as AD +import qualified Data.Array.Accelerate.Array.Representation as R + +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.Array.Data +import Data.Array.Accelerate.CUDA.Array.Sugar hiding + (dim, size, index, shapeToList, sliceIndex) +import qualified Data.Array.Accelerate.CUDA.Array.Sugar as Sugar +import qualified Data.Array.Accelerate.CUDA.Debug as D ( message, dump_exec ) + + +-- libraries +import Prelude hiding ( sum, exp ) +import Control.Applicative hiding ( Const ) +import Control.Monad +import Control.Monad.Trans +import System.IO.Unsafe +import qualified Data.HashSet as Set + +import Foreign ( Ptr, Storable ) +import qualified Foreign as F +import qualified Foreign.CUDA.Driver as CUDA + +#include "accelerate.h" + + +-- Array expression evaluation +-- --------------------------- + +-- Computations are evaluated by traversing the AST bottom-up, and for each node +-- distinguishing between three cases: +-- +-- 1. If it is a Use node, return a reference to the device memory holding the +-- array data +-- +-- 2. If it is a non-skeleton node, such as a let-binding or shape conversion, +-- this is executed directly by updating the environment or similar +-- +-- 3. If it is a skeleton node, the associated binary object is retrieved, +-- memory allocated for the result, and the kernel(s) that implement the +-- skeleton are invoked +-- + +-- Evaluate a closed array expression +-- +executeAcc :: Arrays a => ExecAcc a -> CIO a +executeAcc acc = executeOpenAcc acc Empty + +-- Evaluate an expression with free array variables +-- +executeAfun1 :: forall a b. (Arrays a, Arrays b) => ExecAfun (a -> b) -> a -> CIO b +executeAfun1 (Alam (Abody f)) arrs = do + applyArraysR useArray (arrays (undefined::a)) (fromArr arrs) + executeOpenAcc f (Empty `Push` arrs) + +executeAfun1 _ _ = + error "the sword comes out after you swallow it, right?" + + +-- Evaluate an open array expression +-- +executeOpenAcc :: ExecOpenAcc aenv a -> Val aenv -> CIO a +executeOpenAcc (ExecAcc kernelList@(FL _ kernel _) bindings acc) aenv = + case acc of + -- + -- (1) Array introduction + -- + Use arr -> return (toArr arr) + + -- + -- (2) Environment manipulation + -- + Avar ix -> return (prj ix aenv) + + Alet a b -> do + a0 <- executeOpenAcc a aenv + executeOpenAcc b (aenv `Push` a0) + + Atuple tup -> toTuple <$> executeAtuple tup aenv + + Aprj ix tup -> do + arrs <- executeOpenAcc tup aenv + return $! executeAprj ix (fromTuple arrs) + + Apply (Alam (Abody f)) a -> do + a0 <- executeOpenAcc a aenv + executeOpenAcc f (Empty `Push` a0) + Apply _ _ -> error "Awww... the sky is crying" + + Acond p t e -> do + cond <- executeExp p aenv + if cond then executeOpenAcc t aenv + else executeOpenAcc e aenv + + Reshape e a -> do + ix <- executeExp e aenv + a0 <- executeOpenAcc a aenv + reshapeOp ix a0 + + Unit e -> + unitOp =<< executeExp e aenv + + -- + -- (3) Array computations + -- + Generate e _ -> + generateOp kernel bindings aenv =<< executeExp e aenv + + Replicate sliceIndex e a -> do + slix <- executeExp e aenv + a0 <- executeOpenAcc a aenv + replicateOp kernel bindings aenv sliceIndex slix a0 + + Index sliceIndex a e -> do + slix <- executeExp e aenv + a0 <- executeOpenAcc a aenv + indexOp kernel bindings aenv sliceIndex a0 slix + + Map _ a -> do + a0 <- executeOpenAcc a aenv + mapOp kernel bindings aenv a0 + + ZipWith _ a b -> do + a1 <- executeOpenAcc a aenv + a0 <- executeOpenAcc b aenv + zipWithOp kernel bindings aenv a1 a0 + + Fold _ _ a -> do + a0 <- executeOpenAcc a aenv + foldOp kernel bindings aenv a0 + + Fold1 _ a -> do + a0 <- executeOpenAcc a aenv + fold1Op kernel bindings aenv a0 + + FoldSeg _ _ a s -> do + a0 <- executeOpenAcc a aenv + s0 <- executeOpenAcc s aenv + foldSegOp kernel bindings aenv a0 s0 + + Fold1Seg _ a s -> do + a0 <- executeOpenAcc a aenv + s0 <- executeOpenAcc s aenv + fold1SegOp kernel bindings aenv a0 s0 + + Scanl _ _ a -> do + a0 <- executeOpenAcc a aenv + scanOp L kernelList bindings aenv a0 + + Scanl' _ _ a -> do + a0 <- executeOpenAcc a aenv + scan'Op kernelList bindings aenv a0 + + Scanl1 _ a -> do + a0 <- executeOpenAcc a aenv + scan1Op kernelList bindings aenv a0 + + Scanr _ _ a -> do + a0 <- executeOpenAcc a aenv + scanOp R kernelList bindings aenv a0 + + Scanr' _ _ a -> do + a0 <- executeOpenAcc a aenv + scan'Op kernelList bindings aenv a0 + + Scanr1 _ a -> do + a0 <- executeOpenAcc a aenv + scan1Op kernelList bindings aenv a0 + + Permute _ a _ b -> do + a0 <- executeOpenAcc a aenv + a1 <- executeOpenAcc b aenv + permuteOp kernel bindings aenv a0 a1 + + Backpermute e _ a -> do + sh <- executeExp e aenv + a0 <- executeOpenAcc a aenv + backpermuteOp kernel bindings aenv sh a0 + + Stencil _ _ a -> do + a0 <- executeOpenAcc a aenv + stencilOp kernel bindings aenv a0 + + Stencil2 _ _ a _ b -> do + a1 <- executeOpenAcc a aenv + a0 <- executeOpenAcc b aenv + stencil2Op kernel bindings aenv a1 a0 + +-- Tuples evaluation +-- +executeAtuple :: Atuple (ExecOpenAcc aenv) t -> Val aenv -> CIO t +executeAtuple NilAtup _ = return () +executeAtuple (SnocAtup t a) aenv = (,) <$> executeAtuple t aenv + <*> executeOpenAcc a aenv + +executeAprj :: TupleIdx arrs a -> arrs -> a +executeAprj ZeroTupIdx (_, a) = a +executeAprj (SuccTupIdx ix) (t, _) = executeAprj ix t + + +-- Implementation of primitive array operations +-- -------------------------------------------- + +reshapeOp + :: Shape dim + => dim + -> Array dim' e + -> CIO (Array dim e) +reshapeOp newShape (Array oldShape adata) + = BOUNDS_CHECK(check) "reshape" "shape mismatch" (Sugar.size newShape == size oldShape) + $ return $ Array (fromElt newShape) adata + + +unitOp + :: Elt e + => e + -> CIO (Scalar e) +unitOp v = newArray Z (const v) + + +generateOp + :: (Shape dim, Elt e) + => AccKernel (Array dim e) + -> AccBindings aenv + -> Val aenv + -> dim + -> CIO (Array dim e) +generateOp kernel bindings aenv sh = do + res@(Array _ out) <- allocateArray sh + execute kernel bindings aenv (Sugar.size sh) + (((), out) + , sh) + return res + + +replicateOp + :: forall aenv e dim sl co slix. (Shape dim, Elt slix) + => AccKernel (Array dim e) + -> AccBindings aenv + -> Val aenv + -> SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr dim) + -> slix + -> Array sl e + -> CIO (Array dim e) +replicateOp kernel bindings aenv sliceIndex slix (Array sh0 in0) = do + let sh = toElt $ extend sliceIndex (fromElt slix) sh0 + sl = toElt sh0 :: sl + res@(Array _ out) <- allocateArray sh + execute kernel bindings aenv (Sugar.size sh) + (((((), out) + , in0) + , sl) + , sh) + return res + where + extend :: SliceIndex slix' sl' co' dim' -> slix' -> sl' -> dim' + extend (SliceNil) () () = () + extend (SliceAll sliceIdx) (slx,()) (sl,sz) = (extend sliceIdx slx sl, sz) + extend (SliceFixed sliceIdx) (slx,sz) sl = (extend sliceIdx slx sl, sz) + + +indexOp + :: forall sl co slix aenv dim e. (Shape sl, Elt slix) + => AccKernel (Array sl e) + -> AccBindings aenv + -> Val aenv + -> SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr dim) + -> Array dim e + -> slix + -> CIO (Array sl e) +indexOp kernel bindings aenv sliceIndex (Array sh0 in0) slix = do + let sz = toElt sh0 :: dim + sh = toElt $ restrict sliceIndex (fromElt slix) sh0 :: sl + sl = Sugar.listToShape $ convertSlix sliceIndex (fromElt slix) :: sl + res@(Array _ out) <- allocateArray sh + execute kernel bindings aenv (Sugar.size sh) + ((((((), out) + , in0) + , sh) + , sl) + , sz) + return res + where + restrict :: SliceIndex slix' sl' co' dim' -> slix' -> dim' -> sl' + restrict (SliceNil) () () = () + restrict (SliceAll sliceIdx) (slx,()) (sh,sz) = (restrict sliceIdx slx sh, sz) + restrict (SliceFixed sliceIdx) (slx,i) (sh,sz) + = BOUNDS_CHECK(checkIndex) "slice" i sz $ restrict sliceIdx slx sh + -- + convertSlix :: SliceIndex slix' sl' co' dim' -> slix' -> [Int] + convertSlix (SliceNil) () = [] + convertSlix (SliceAll sliceIdx) (s,()) = convertSlix sliceIdx s + convertSlix (SliceFixed sliceIdx) (s,i) = i : convertSlix sliceIdx s + + +mapOp + :: Elt e + => AccKernel (Array dim e) + -> AccBindings aenv + -> Val aenv + -> Array dim e' + -> CIO (Array dim e) +mapOp kernel bindings aenv (Array sh0 in0) = do + res@(Array _ out) <- allocateArray (toElt sh0) + execute kernel bindings aenv (size sh0) + ((((), out) + , in0) + , convertIx (size sh0)) + return res + +zipWithOp + :: forall aenv dim a b c. Elt c + => AccKernel (Array dim c) + -> AccBindings aenv + -> Val aenv + -> Array dim a + -> Array dim b + -> CIO (Array dim c) +zipWithOp kernel bindings aenv (Array sh1 in1) (Array sh0 in0) = do + res@(Array sh out) <- allocateArray $ toElt (sh1 `intersect` sh0) + execute kernel bindings aenv (size sh) + (((((((), out) + , in1) + , in0) + , toElt sh :: dim) + , toElt sh1 :: dim) + , toElt sh0 :: dim) + return res + +foldOp, fold1Op + :: forall dim e aenv. Shape dim + => AccKernel (Array dim e) + -> AccBindings aenv + -> Val aenv + -> Array (dim:.Int) e + -> CIO (Array dim e) +fold1Op kernel bindings aenv in0@(Array (_,sz) _) + = BOUNDS_CHECK(check) "fold1" "empty array" (sz > 0) + $ foldOp kernel bindings aenv in0 + +foldOp kernel bindings aenv (Array sh0 in0) + -- A recursive multi-block reduction when collapsing to a single value + -- + | dim sh0 == 1 = do + let numElements = size sh0 + (_,numBlocks,_) = configure kernel (size sh0) + res@(Array _ out) <- allocateArray (toElt (fst sh0,numBlocks)) :: CIO (Array (dim:.Int) e) + execute kernel bindings aenv numElements + ((((), out) + , in0) + , convertIx numElements) + if numBlocks > 1 then foldOp kernel bindings aenv res + else return (Array (fst sh0) out) + -- + -- Reduction over the innermost dimension of an array (single pass operation) + -- + | otherwise = do + let (sh, sz) = sh0 + interval_size = sz + num_intervals = size sh + num_elements = size sh0 + res@(Array _ out) <- allocateArray $ toElt sh + execute kernel bindings aenv (num_intervals `max` 1) + ((((((), out) + , in0) + , convertIx interval_size) + , convertIx num_intervals) + , convertIx num_elements) + return res + +foldSegOp, fold1SegOp + :: forall aenv dim e i. Shape dim + => AccKernel (Array (dim:.Int) e) + -> AccBindings aenv + -> Val aenv + -> Array (dim:.Int) e + -> Segments i + -> CIO (Array (dim:.Int) e) +fold1SegOp kernel bindings aenv in0 seg = + foldSegOp kernel bindings aenv in0 seg + +foldSegOp kernel bindings aenv (Array sh0 in0) (Array shs seg) = do + res@(Array sh out) <- allocateArray $ toElt (fst sh0, size shs-1) + -- + message $ "foldSeg: shOut = (" ++ showShape (toElt sh :: dim :. Int) ++ ")" + ++ ", shIn0 = (" ++ showShape (toElt sh0 :: dim :. Int) ++ ")" + execute kernel bindings aenv (size sh) + ((((((), out) + , in0) + , seg) + , toElt sh :: dim :. Int) + , toElt sh0 :: dim :. Int) + return res + + +data ScanDirection = L | R + +scanOp + :: forall aenv e. Elt e + => ScanDirection + -> FullList () (AccKernel (Vector e)) + -> AccBindings aenv + -> Val aenv + -> Vector e + -> CIO (Vector e) +scanOp dir (FL _ kfold1' (Cons _ kscan Nil)) bindings aenv (Array sh0 in0) = do + let (_,num_intervals,_) = configure kscan num_elements + a_out@(Array _ out) <- allocateArray (Z :. num_elements + 1) + (Array _ blk) <- allocateArray (Z :. num_intervals) :: CIO (Vector e) + d_out <- devicePtrsOfArrayData out + -- + -- depending on whether we are a left or right scan, we need to manipulate the + -- pointers that specify the final element and main scan body + -- + let interval_size = (num_elements + num_intervals - 1) `div` num_intervals + body = marshalDevicePtrs out d_body + sum = marshalDevicePtrs out d_sum + (d_body, d_sum) = + case dir of + L -> (d_out, advancePtrsOfArrayData out num_elements d_out) + R -> (advancePtrsOfArrayData out 1 d_out, d_out) + -- + -- If the array is sized such that there is only a single interval, the first + -- phase of calculating a per-interval carry-in value can be skipped + -- + when (num_intervals > 1) $ do + -- Compute the interval sum. Since we use associative operations, this can + -- be done as a reduction instead of requiring a full left-/right-scan. + message $ "scan phase 1: interval_size = " ++ shows interval_size + ", num_intervals = " ++ shows num_intervals + ", num_elements = " ++ show num_elements + execute kfold1 bindings aenv num_elements + ((((((), blk) + , in0) + , convertIx interval_size) + , convertIx num_intervals) + , convertIx num_elements) + + -- + -- Inclusive scan of the per-interval results to compute each segment's + -- carry-in value. + execute kscan bindings aenv 1 + (((((((), blk) + , sum) + , blk) + , blk) -- not used, just need the right number of arguments + , convertIx num_intervals) + , convertIx num_intervals) + + -- + -- Prefix-sum of the input array, using interval carry-in values. + message $ "scan phase 2: interval_size = " ++ shows interval_size + ", num_elements = " ++ show num_elements + execute kscan bindings aenv num_elements + (((((((), body) + , sum) + , in0) + , blk) + , convertIx interval_size) + , convertIx num_elements) + return a_out + where + num_elements = size sh0 + kfold1 = retag kfold1' :: AccKernel (Vector e) +-- kscan1 = retag kscan1' :: AccKernel (Vector e) + +scanOp _ _ _ _ _ = error "I'll just pretend to hug you until you get here." + + +scan'Op + :: forall aenv e. Elt e + => FullList () (AccKernel (Vector e, Scalar e)) + -> AccBindings aenv + -> Val aenv + -> Vector e + -> CIO (Vector e, Scalar e) +scan'Op (FL _ kfold1' (Cons _ kscan Nil)) bindings aenv (Array sh0 in0) = do + let (_,num_intervals,_) = configure kscan num_elements + (Array _ blk) <- allocateArray (Z :. num_intervals) :: CIO (Vector e) + a_out@(Array _ out) <- allocateArray (Z :. num_elements) + a_sum@(Array _ sum) <- allocateArray Z + let interval_size = (num_elements + num_intervals - 1) `div` num_intervals + -- + -- see comments in 'scanOp' + when (num_intervals > 1) $ do + message $ "scan phase 1: interval_size = " ++ shows interval_size + ", num_intervals = " ++ shows num_intervals + ", num_elements = " ++ show num_elements + execute kfold1 bindings aenv num_elements + ((((((), blk) + , in0) + , convertIx interval_size) + , convertIx num_intervals) + , convertIx num_elements) + -- + execute kscan bindings aenv 1 + (((((((), blk) + , sum) + , blk) + , blk) -- not used + , convertIx num_intervals) + , convertIx num_intervals) + -- + message $ "scan phase 2: interval_size = " ++ shows interval_size + ", num_elements = " ++ show num_elements + execute kscan bindings aenv num_elements + (((((((), out) + , sum) + , in0) + , blk) + , convertIx interval_size) + , convertIx num_elements) + return (a_out, a_sum) + where + num_elements = size sh0 + kfold1 = retag kfold1' :: AccKernel (Vector e) + +scan'Op _ _ _ _ = error "If I promise not to kill you, can I have a hug?" + + +scan1Op + :: forall aenv e. Elt e + => FullList () (AccKernel (Vector e)) + -> AccBindings aenv + -> Val aenv + -> Vector e + -> CIO (Vector e) +scan1Op (FL _ kfold1' (Cons _ kscan1 Nil)) bindings aenv (Array sh0 in0) = do + let (_,num_intervals,_) = configure kscan1 num_elements + (Array _ sum) <- allocateArray Z :: CIO (Scalar e) + (Array _ blk) <- allocateArray (Z :. num_intervals) :: CIO (Vector e) + a_out@(Array _ out) <- allocateArray (Z :. num_elements) + let interval_size = (num_elements + num_intervals - 1) `div` num_intervals + -- + -- see comments in 'scanOp' + when (num_intervals > 1) $ do + message $ "scan phase 1: interval_size = " ++ shows interval_size + ", num_intervals = " ++ shows num_intervals + ", num_elements = " ++ show num_elements + execute kfold1 bindings aenv num_elements + ((((((), blk) + , in0) + , convertIx interval_size) + , convertIx num_intervals) + , convertIx num_elements) + -- + execute kscan1 bindings aenv 1 + (((((((), blk) + , sum) + , blk) + , blk) -- not used + , convertIx num_intervals) + , convertIx num_intervals) + -- + message $ "scan phase 2: interval_size = " ++ shows interval_size + ", num_elements = " ++ show num_elements + execute kscan1 bindings aenv num_elements + (((((((), out) + , sum) + , in0) + , blk) + , convertIx interval_size) + , convertIx num_elements) + return a_out + where + num_elements = size sh0 + kfold1 = retag kfold1' :: AccKernel (Vector e) + +scan1Op _ _ _ _ = error "If you get wet, you'll get sick." + + +permuteOp + :: forall aenv dim dim' e. Elt e + => AccKernel (Array dim' e) + -> AccBindings aenv + -> Val aenv + -> Array dim' e -- default values + -> Array dim e -- permuted array + -> CIO (Array dim' e) +permuteOp kernel bindings aenv in0@(Array sh0 _) (Array sh1 in1) = do + res@(Array _ out) <- allocateArray (toElt sh0) + copyArray in0 res + execute kernel bindings aenv (size sh0) + (((((), out) + , in1) + , toElt sh0 :: dim') + , toElt sh1 :: dim) + return res + +backpermuteOp + :: forall aenv dim dim' e. (Shape dim', Elt e) + => AccKernel (Array dim' e) + -> AccBindings aenv + -> Val aenv + -> dim' + -> Array dim e + -> CIO (Array dim' e) +backpermuteOp kernel bindings aenv dim' (Array sh0 in0) = do + res@(Array sh out) <- allocateArray dim' + execute kernel bindings aenv (size sh) + (((((), out) + , in0) + , toElt sh :: dim') + , toElt sh0 :: dim) + return res + +stencilOp + :: forall aenv dim a b. Elt b + => AccKernel (Array dim b) + -> AccBindings aenv + -> Val aenv + -> Array dim a + -> CIO (Array dim b) +stencilOp kernel@(Kernel _ mdl _ _ _) bindings aenv in0@(Array sh0 _) = do + res@(Array _ out) <- allocateArray (toElt sh0) + bindStencil 0 mdl in0 + execute kernel bindings aenv (size sh0) + (((), out) + , toElt sh0 :: dim) + return res + +stencil2Op + :: forall aenv dim a b c. Elt c + => AccKernel (Array dim c) + -> AccBindings aenv + -> Val aenv + -> Array dim a + -> Array dim b + -> CIO (Array dim c) +stencil2Op kernel@(Kernel _ mdl _ _ _) bindings aenv in1@(Array sh1 _) in0@(Array sh0 _) = do + res@(Array sh out) <- allocateArray $ toElt (sh1 `intersect` sh0) + bindStencil 1 mdl in1 + bindStencil 0 mdl in0 + execute kernel bindings aenv (size sh) + (((((), out) + , toElt sh :: dim) + , toElt sh1 :: dim) + , toElt sh0 :: dim) + return res + + +-- Expression evaluation +-- --------------------- + +-- Evaluate an open expression +-- +executeOpenExp :: PreOpenExp ExecOpenAcc env aenv t -> Val env -> Val aenv -> CIO t +executeOpenExp exp env aenv = do + case exp of + -- Local binders and variable indices, ranging over tuples and scalars + Var ix -> return $! prj ix env + Let x e -> do + x' <- executeOpenExp x env aenv + executeOpenExp e (env `Push` x') aenv + + -- Constant values + Const c -> return $! toElt c + PrimConst c -> return $! I.evalPrimConst c + + -- Primitive scalar operations + PrimApp fun arg -> do + x <- executeOpenExp arg env aenv + return $! I.evalPrim fun x + + -- Tuples + Tuple tup -> do + t <- executeTuple tup env aenv + return $! toTuple t + + Prj ix e -> do + t <- executeOpenExp e env aenv + return $! I.evalPrj ix (fromTuple t) + + -- Conditional expression + Cond p t e -> do + p' <- executeOpenExp p env aenv + case p' of + True -> executeOpenExp t env aenv + False -> executeOpenExp e env aenv + + -- Array indices and shapes + IndexAny -> return Sugar.Any + IndexNil -> return Z + IndexCons sh sz -> do + sh' <- executeOpenExp sh env aenv + sz' <- executeOpenExp sz env aenv + return $! sh' :. sz' + + IndexHead sh -> do + (_ :. ix) <- executeOpenExp sh env aenv + return $! ix + + IndexTail sh -> do + (ix :. _) <- executeOpenExp sh env aenv + return $! ix + + -- Array shape and element indexing + IndexScalar acc ix -> do + arr' <- executeOpenAcc acc aenv + ix' <- executeOpenExp ix env aenv + indexArray arr' ix' + + Shape acc -> do + (Array sh _) <- executeOpenAcc acc aenv + return $! toElt sh + + ShapeSize e -> do + sh <- executeOpenExp e env aenv + return $! size (fromElt sh) + + +-- Evaluate a closed expression +-- +executeExp :: PreExp ExecOpenAcc aenv t -> Val aenv -> CIO t +executeExp e = executeOpenExp e Empty + + +-- Tuple evaluation +-- +executeTuple :: Tuple (PreOpenExp ExecOpenAcc env aenv) t -> Val env -> Val aenv -> CIO t +executeTuple NilTup _ _ = return () +executeTuple (t `SnocTup` e) env aenv = (,) <$> executeTuple t env aenv + <*> executeOpenExp e env aenv + + +-- Array references in scalar code +-- ------------------------------- + +bindLifted :: CUDA.Module -> Val aenv -> AccBindings aenv -> CIO () +bindLifted mdl aenv (AccBindings vars) = mapM_ (bindAcc mdl aenv) (Set.toList vars) + + +bindAcc + :: CUDA.Module + -> Val aenv + -> ArrayVar aenv + -> CIO () +bindAcc mdl aenv (ArrayVar idx) = + let idx' = show $ idxToInt idx + Array sh ad = prj idx aenv + -- + bindDim = liftIO $ + CUDA.getPtr mdl ("sh" ++ idx') >>= + CUDA.pokeListArray (convertSh sh) . fst + -- + arr n = "arr" ++ idx' ++ "_a" ++ show (n::Int) + tex = CUDA.getTex mdl . arr + bindTex = marshalTextureData ad (size sh) =<< liftIO (sequence' $ map tex [0..]) + in + bindDim >> bindTex + + +bindStencil + :: Int + -> CUDA.Module + -> Array dim e + -> CIO () +bindStencil s mdl (Array sh ad) = + let sten n = "stencil" ++ show s ++ "_a" ++ show (n::Int) + tex = CUDA.getTex mdl . sten + in + marshalTextureData ad (size sh) =<< liftIO (sequence' $ map tex [0..]) + + +-- Kernel execution +-- ---------------- + +-- Data which can be marshalled as arguments to a kernel invocation. +-- +class Marshalable a where + marshal :: a -> CIO [CUDA.FunParam] + +instance Marshalable () where + marshal _ = return [] + +#define primMarshalable(ty) \ +instance Marshalable (ty) where { \ + marshal x = return [CUDA.VArg x] } + +primMarshalable(Int) +primMarshalable(Int8) +primMarshalable(Int16) +primMarshalable(Int32) +primMarshalable(Int64) +primMarshalable(Word) +primMarshalable(Word8) +primMarshalable(Word16) +primMarshalable(Word32) +primMarshalable(Word64) +primMarshalable(Float) +primMarshalable(Double) +primMarshalable(Ptr a) +primMarshalable(CUDA.DevicePtr a) + +instance Marshalable CUDA.FunParam where + marshal x = return [x] + +instance AD.ArrayElt e => Marshalable (AD.ArrayData e) where + marshal = marshalArrayData + +instance Marshalable a => Marshalable [a] where + marshal = concatMapM marshal + +instance (Marshalable a, Marshalable b) => Marshalable (a,b) where + marshal (a,b) = (++) <$> marshal a <*> marshal b + + +-- This requires incoherent instances \= +-- +instance Shape sh => Storable sh where + sizeOf sh = F.sizeOf (undefined::Int32) * (1 `max` Sugar.dim sh) + alignment _ = F.alignment (undefined::Int32) + poke p sh = F.pokeArray (F.castPtr p) (convertSh (fromElt sh)) + +instance Shape sh => Marshalable sh where + marshal sh = return [CUDA.VArg sh] + + +-- What launch parameters should we use to execute the kernel with a number of +-- array elements? +-- +configure :: AccKernel a -> Int -> (Int, Int, Int) +configure (Kernel _ !_ !_ !_ !launchConfig) !n = launchConfig n + + +-- 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 + -> AccBindings aenv -- Array variables embedded in scalar expressions + -> Val aenv + -> Int + -> args + -> CIO () +execute kernel@(Kernel _ !mdl !_ !_ !_) !bindings !aenv !n !args = do + bindLifted mdl aenv bindings + launch kernel (configure kernel n) args + + +-- Execute a device function, with the given thread configuration and function +-- parameters. The tuple contains (threads per block, grid size, shared memory) +-- +launch :: Marshalable args => AccKernel a -> (Int,Int,Int) -> args -> CIO () +launch (Kernel entry _ !fn _ _) !(cta, grid, smem) !a = do + message $ entry ++ " <<< " ++ shows grid ", " ++ shows cta ", " ++ shows smem " >>>" + -- + args <- marshal a + liftIO $ CUDA.launchKernel fn (grid,1,1) (cta,1,1) smem Nothing args + + +-- Auxiliary functions +-- ------------------- + +-- Generalise concatMap for teh monadz +-- +concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] +concatMapM f xs = concat `liftM` mapM f xs + +-- A lazier version of 'Control.Monad.sequence' +-- +sequence' :: [IO a] -> IO [a] +sequence' = foldr k (return []) + where k m ms = do { x <- m; xs <- unsafeInterleaveIO ms; return (x:xs) } + +-- Extract shape dimensions as a list of integers. Singleton dimensions are +-- considered to be of unit size. +-- +-- Internally, Accelerate uses snoc-based tuple projection, while the data +-- itself is stored in reading order. Ensure we match the behaviour of regular +-- tuples and code generation thereof. +-- +convertSh :: R.Shape sh => sh -> [Int32] +convertSh = post . shapeToList + where + post [] = [1] + post xs = reverse (map convertIx xs) + +convertIx :: Int -> Int32 +convertIx ix = INTERNAL_ASSERT "convertIx" (ix <= intmax) (fromIntegral ix) + where intmax = fromIntegral (maxBound :: Int32) + + +-- Apply a function to all components of an Arrays structure +-- +applyArraysR + :: (forall sh e. (Shape sh, Elt e) => Array sh e -> CIO ()) + -> ArraysR arrs + -> arrs + -> CIO () +applyArraysR _ ArraysRunit () = return () +applyArraysR f (ArraysRpair r1 r0) (a1, a0) = applyArraysR f r1 a1 >> applyArraysR f r0 a0 +applyArraysR f ArraysRarray arr = f arr + + +-- Debug +-- ----- + +{-# INLINE trace #-} +trace :: String -> CIO a -> CIO a +trace msg next = D.message D.dump_exec ("exec: " ++ msg) >> next + +{-# INLINE message #-} +message :: String -> CIO () +message s = s `trace` return () + diff --git a/Data/Array/Accelerate/CUDA/FullList.hs b/Data/Array/Accelerate/CUDA/FullList.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/FullList.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE BangPatterns #-} +-- | +-- 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 +-- Stability : experimental +-- Portability : non-partable (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, + lookup + +) where + +import Prelude hiding ( lookup ) + + +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 #-} + +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 #-} + diff --git a/Data/Array/Accelerate/CUDA/State.hs b/Data/Array/Accelerate/CUDA/State.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/State.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- CUDA.Context +-- | +-- 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 +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-partable (GHC extensions) +-- +-- This module defines a state monad token which keeps track of the code +-- generator state, including memory transfers and external compilation +-- processes. +-- + +module Data.Array.Accelerate.CUDA.State ( + + -- Types + CIO, KernelTable, KernelKey, KernelEntry(KernelEntry), KernelObject(KernelObject), + + -- Evaluating computations + evalCUDA, defaultContext, deviceProps, + memoryTable, kernelTable, kernelName, kernelStatus + +) where + +-- friends +import Data.Array.Accelerate.CUDA.FullList ( FullList ) +import Data.Array.Accelerate.CUDA.Debug ( message, verbose, dump_gc, showFFloatSIBase ) +import Data.Array.Accelerate.CUDA.Array.Table as MT +import Data.Array.Accelerate.CUDA.Analysis.Device + +-- library +import Data.Label +import Control.Exception +import Data.ByteString ( ByteString ) +import Control.Concurrent.MVar ( MVar, newMVar ) +import Control.Monad.State.Strict ( StateT(..), evalStateT ) +import System.Process ( ProcessHandle ) +import System.Mem ( performGC ) +import System.Mem.Weak ( addFinalizer ) +import System.IO.Unsafe +import Text.PrettyPrint +import qualified Foreign.CUDA.Driver as CUDA hiding ( device ) +import qualified Foreign.CUDA.Driver.Context as CUDA +import qualified Foreign.CUDA.Analysis as CUDA +import qualified Data.HashTable.IO as HT + +#ifdef ACCELERATE_CUDA_PERSISTENT_CACHE +import Data.Binary ( encodeFile, decodeFile ) +import Control.Arrow ( second ) +import Paths_accelerate ( getDataDir ) +#endif + + +-- An exact association between an accelerate computation and its +-- implementation, which is either a reference to the external compiler (nvcc) +-- or the resulting binary module. +-- +-- Note that since we now support running in multiple contexts, we also need to +-- keep track of +-- a) the compute architecture the code was compiled for +-- b) which contexts have linked the code +-- +-- We aren't concerned with true (typed) equality of an OpenAcc expression, +-- since we largely want to disregard the array environment; we really only want +-- to assert the type and index of those variables that are accessed by the +-- computation and no more, but we can not do that. Instead, this is keyed to +-- the generated kernel code. +-- +type KernelTable = HT.BasicHashTable KernelKey KernelEntry + +type KernelKey = (CUDA.Compute, ByteString) +data KernelEntry = KernelEntry + { + _kernelName :: !FilePath, + _kernelStatus :: !(Either ProcessHandle KernelObject) + } + +data KernelObject = KernelObject + { + _binaryData :: !ByteString, + _activeContexts :: {-# UNPACK #-} !(FullList CUDA.Context CUDA.Module) + } + +-- The state token for CUDA accelerated array operations +-- +type CIO = StateT CUDAState IO +data CUDAState = CUDAState + { + _deviceProps :: !CUDA.DeviceProperties, + _kernelTable :: {-# UNPACK #-} !KernelTable, + _memoryTable :: {-# UNPACK #-} !MemoryTable + } + +instance Eq CUDA.Context where + CUDA.Context p1 == CUDA.Context p2 = p1 == p2 + +$(mkLabels [''CUDAState, ''KernelEntry]) + + +-- Execution State +-- --------------- + +-- |Evaluate a CUDA array computation +-- +evalCUDA :: CUDA.Context -> CIO a -> IO a +evalCUDA ctx acc = bracket setup teardown $ evalStateT acc + where + teardown _ = CUDA.pop >> performGC + setup = do + CUDA.push ctx + dev <- CUDA.device + prp <- CUDA.props dev + return $! CUDAState prp knl mem + + -- one-shot top-level mutable state + {-# NOINLINE mem #-} + {-# NOINLINE knl #-} + mem = unsafePerformIO MT.new + knl = unsafePerformIO HT.new + + +-- Select and initialise a default CUDA device, and create a new execution +-- context. The device is selected based on compute capability and estimated +-- maximum throughput. +-- +{-# NOINLINE defaultContext #-} +defaultContext :: MVar CUDA.Context +defaultContext = unsafePerformIO $ do + CUDA.initialise [] + (dev,prp) <- selectBestDevice + ctx <- CUDA.create dev [CUDA.SchedAuto] >> CUDA.pop + ref <- newMVar ctx + -- + message dump_gc $ "gc: initialise context" + message verbose $ deviceInfo dev prp + -- + addFinalizer ctx $ do + message dump_gc $ "gc: finalise context" + CUDA.destroy ctx + -- + return ref + + +-- Debugging +-- --------- + +-- Nicely format a summary of the selected CUDA device, example: +-- +-- Device 0: GeForce 9600M GT (compute capability 1.1) +-- 4 multiprocessors @ 1.25GHz (32 cores), 512MB global memory +-- +deviceInfo :: CUDA.Device -> CUDA.DeviceProperties -> String +deviceInfo dev prp = render $ + devID <> colon <+> vcat [ name <+> parens compute + , processors <+> at <+> text clock <+> parens cores <> comma <+> memory + ] + where + name = text (CUDA.deviceName prp) + compute = text "compute capatability" <+> double (CUDA.computeCapability prp) + devID = text "Device" <+> int (fromIntegral $ CUDA.useDevice dev) -- hax + processors = int (CUDA.multiProcessorCount prp) <+> text "multiprocessors" + cores = int (CUDA.multiProcessorCount prp * coresPerMultiProcessor prp) <+> text "cores" + memory = text mem <+> text "global memory" + -- + clock = showFFloatSIBase (Just 2) 1000 (fromIntegral $ CUDA.clockRate prp * 1000 :: Double) "Hz" + mem = showFFloatSIBase (Just 0) 1024 (fromIntegral $ CUDA.totalGlobalMem prp :: Double) "B" + at = char '@' + + +-- Persistent caching (deprecated) +-- ------------------------------- + +#ifdef ACCELERATE_CUDA_PERSISTENT_CACHE +-- Load and save the persistent kernel index file +-- +indexFileName :: IO FilePath +indexFileName = do + tmp <- ( "cache") `fmap` getDataDir + dir <- createDirectoryIfMissing True tmp >> canonicalizePath tmp + return (dir "_index") + +saveIndexFile :: CUDAState -> IO () +saveIndexFile s = do + ind <- indexFileName + encodeFile ind . map (second _kernelName) =<< HT.toList (_kernelTable s) + +-- Read the kernel index map file (if it exists), loading modules into the +-- current context +-- +loadIndexFile :: IO (KernelTable, Int) +loadIndexFile = do + f <- indexFileName + x <- doesFileExist f + e <- if x then mapM reload =<< decodeFile f + else return [] + (,length e) <$> HT.fromList hashAccKey e + where + reload (k,n) = (k,) . KernelEntry n . Right <$> CUDA.loadFile (n `replaceExtension` ".cubin") +#endif + diff --git a/Data/Array/Accelerate/Internal/Check.hs b/Data/Array/Accelerate/Internal/Check.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Internal/Check.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Data.Array.Accelerate.Internal.Check +-- Copyright : Roman Lechinskiy, Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- 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. +-- + +module Data.Array.Accelerate.Internal.Check ( + + -- * Bounds checking and assertion infrastructure + Checks(..), doChecks, + error, check, assert, checkIndex, checkLength, checkSlice + +) where + +import Prelude hiding( error ) +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 + +error :: String -> Int -> Checks -> String -> String -> a +error file line kind loc msg + = P.error . unlines $ + (if kind == Internal + then (["" + ,"*** Internal error in package accelerate-cuda ***" + ,"*** Please submit a bug report at https://github.com/AccelerateHS/accelerate/issues"]++) + else id) + [ file ++ ":" ++ show line ++ " (" ++ 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 + +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 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 + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,23 @@ +Copyright (c) [2007..2012] The Accelerate Team. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the names of the contributors nor of their affiliations may + be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ''AS IS'' AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL COPYRIGHT HOLDERS BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +import Distribution.Simple +main = defaultMain diff --git a/accelerate-cuda.cabal b/accelerate-cuda.cabal new file mode 100644 --- /dev/null +++ b/accelerate-cuda.cabal @@ -0,0 +1,164 @@ +Name: accelerate-cuda +Version: 0.12.0.0 +Cabal-version: >= 1.6 +Tested-with: GHC >= 7.4 +Build-type: Configure + +Synopsis: Accelerate backend for NVIDIA GPUs +Description: + This library implements a backend for the Accelerate language instrumented for + parallel execution on CUDA-capable NVIDIA GPUs. + . + To use this backend you need CUDA version 3.x or later installed. Note that + currently there is no support for 'Char' and 'Bool' arrays (this is a + limitation of the front-end language). + +License: BSD3 +License-file: LICENSE +Author: Manuel M T Chakravarty, + Gabriele Keller, + Sean Lee, + Trevor L. McDonell +Maintainer: Trevor L. McDonell +Bug-reports: https://github.com/AccelerateHS/accelerate/issues +Homepage: http://www.cse.unsw.edu.au/~chak/project/accelerate/ + +Category: Compilers/Interpreters, Concurrency, Data, Parallelism +Stability: Experimental + +-- We require 'accelerate_cuda_shape.h' to be in this list so that it is copied +-- as part of the installation, although 'cabal sdist' does not grok that it is +-- generated by the configure script. +-- +Data-files: cubits/accelerate_cuda_extras.h + cubits/accelerate_cuda_function.h + cubits/accelerate_cuda_shape.h + cubits/accelerate_cuda_stencil.h + cubits/accelerate_cuda_texture.h + cubits/accelerate_cuda_util.h + +Extra-tmp-files: config.status + config.log + cubits/accelerate_cuda_shape.h -- generated by configure + +Extra-source-files: configure + cubits/accelerate_cuda_shape.h.in + include/accelerate.h + +-- Flag pcache +-- Description: Enable the persistent caching of the compiled CUDA modules (experimental) +-- Default: False + +Flag debug + Description: Enable tracing message flags + Default: False + +Flag bounds-checks + Description: Enable bounds checking + Default: True + +Flag unsafe-checks + Description: Enable bounds checking in unsafe operations + Default: False + +Flag internal-checks + Description: Enable internal consistency checks + Default: False + +Library + Include-Dirs: include + + Build-depends: accelerate == 0.12.*, + array >= 0.3, + base == 4.*, + binary >= 0.5, + blaze-builder >= 0.3, + bytestring >= 0.9, + containers >= 0.4, + cryptohash >= 0.7, + cuda >= 0.4.1, + directory >= 1.0, + fclabels >= 1.0, + filepath >= 1.0, + hashable >= 1.1, + hashtables >= 1.0.1, + language-c-quote >= 0.3, + mainland-pretty >= 0.1.1, + mtl >= 2.0, + pretty >= 1.0, + process >= 1.0, + srcloc >= 0.1, + symbol >= 0.1, + transformers >= 0.2, + unordered-containers >= 0.1.4 + + if os(windows) + build-depends: Win32 >= 2.2.1 + else + build-depends: unix >= 2.4 + + Exposed-modules: Data.Array.Accelerate.CUDA + + Other-modules: Data.Array.Accelerate.CUDA.Analysis.Device + Data.Array.Accelerate.CUDA.Analysis.Launch + Data.Array.Accelerate.CUDA.Array.Data + Data.Array.Accelerate.CUDA.Array.Prim + Data.Array.Accelerate.CUDA.Array.Sugar + Data.Array.Accelerate.CUDA.Array.Table + Data.Array.Accelerate.CUDA.CodeGen + Data.Array.Accelerate.CUDA.CodeGen.Base + Data.Array.Accelerate.CUDA.CodeGen.Monad + Data.Array.Accelerate.CUDA.CodeGen.Mapping + Data.Array.Accelerate.CUDA.CodeGen.IndexSpace + Data.Array.Accelerate.CUDA.CodeGen.PrefixSum + Data.Array.Accelerate.CUDA.CodeGen.Reduction + Data.Array.Accelerate.CUDA.CodeGen.Stencil + Data.Array.Accelerate.CUDA.CodeGen.Type + Data.Array.Accelerate.CUDA.AST + Data.Array.Accelerate.CUDA.Compile + Data.Array.Accelerate.CUDA.Debug + Data.Array.Accelerate.CUDA.Execute + Data.Array.Accelerate.CUDA.FullList + Data.Array.Accelerate.CUDA.State + Data.Array.Accelerate.Internal.Check + Paths_accelerate_cuda + +-- if flag(pcache) +-- CPP-options: -DACCELERATE_CUDA_PERSISTENT_CACHE + + if flag(debug) + cpp-options: -DACCELERATE_DEBUG + + if flag(bounds-checks) + cpp-options: -DACCELERATE_BOUNDS_CHECKS + + if flag(unsafe-checks) + cpp-options: -DACCELERATE_UNSAFE_CHECKS + + if flag(internal-checks) + cpp-options: -DACCELERATE_INTERNAL_CHECKS + + ghc-options: -O2 + -Wall + -fwarn-tabs + + Extensions: BangPatterns, + CPP, + ExistentialQuantification, + FlexibleContexts, + FlexibleInstances, + GADTs, + PatternGuards, + QuasiQuotes, + RankNTypes, + ScopedTypeVariables, + TemplateHaskell, + TupleSections, + TypeFamilies, + TypeOperators, + TypeSynonymInstances + +source-repository head + type: git + location: https://github.com/AccelerateHS/accelerate-cuda + diff --git a/configure b/configure new file mode 100644 --- /dev/null +++ b/configure @@ -0,0 +1,3410 @@ +#! /bin/sh +# Guess values for system-dependent variables and create Makefiles. +# Generated by GNU Autoconf 2.65 for accelerate-cuda 0.9.0.0. +# +# Report bugs to . +# +# +# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, +# 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 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. +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 + +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" + 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 : + # 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. + BASH_ENV=/dev/null + ENV=/dev/null + (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV + export CONFIG_SHELL + exec "$CONFIG_SHELL" "$as_myself" ${1+"$@"} +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@projects.haskell.org 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_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 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=$?; test $as_status -eq 0 && as_status=1 + if test "$3"; then + as_lineno=${as_lineno-"$2"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $1" >&$3 + fi + $as_echo "$as_me: error: $1" >&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; } + + # 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 -p'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -p' + elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln + else + as_ln_s='cp -p' + fi +else + as_ln_s='cp -p' +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 + +if test -x / >/dev/null 2>&1; then + as_test_x='test -x' +else + if ls -dL / >/dev/null 2>&1; then + as_ls_L_option=L + else + as_ls_L_option= + fi + as_test_x=' + eval sh -c '\'' + if test -d "$1"; then + test -d "$1/."; + else + case $1 in #( + -*)set "./$1";; + esac; + case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #(( + ???[sx]*):;;*)false;;esac;fi + '\'' sh + ' +fi +as_executable_p=$as_test_x + +# 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 &1 + +# Name of the host. +# hostname on some systems (SVR3.2, 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.9.0.0' +PACKAGE_STRING='accelerate-cuda 0.9.0.0' +PACKAGE_BUGREPORT='accelerate@projects.haskell.org' +PACKAGE_URL='' + +ac_unique_file="Data/Array/Accelerate/CUDA.hs" +ac_subst_vars='LTLIBOBJS +LIBOBJS +hs_int_type +GHC +OBJEXT +EXEEXT +ac_ct_CXX +CPPFLAGS +LDFLAGS +CXXFLAGS +CXX +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 +' + 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=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 + $as_echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host. + If a cross compiler is detected then cross compile mode will be used." >&2 + 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.9.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.9.0.0:";; + esac + cat <<\_ACEOF + +Some influential environment variables: + CXX C++ compiler command + CXXFLAGS C++ compiler flags + LDFLAGS linker flags, e.g. -L if you have libraries in a + nonstandard directory + LIBS libraries to pass to the linker, e.g. -l + CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I if + you have headers in a nonstandard directory + +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 . +_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.9.0.0 +generated by GNU Autoconf 2.65 + +Copyright (C) 2009 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; test "x$as_lineno_stack" = x && { as_lineno=; 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.9.0.0, which was +generated by GNU Autoconf 2.65. 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 + + cat <<\_ASBOX +## ---------------- ## +## Cache variables. ## +## ---------------- ## +_ASBOX + 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 + + cat <<\_ASBOX +## ----------------- ## +## Output variables. ## +## ----------------- ## +_ASBOX + 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 + cat <<\_ASBOX +## ------------------- ## +## File substitutions. ## +## ------------------- ## +_ASBOX + 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 + cat <<\_ASBOX +## ----------- ## +## confdefs.h. ## +## ----------- ## +_ASBOX + 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 + ac_site_file1=$CONFIG_SITE +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" + 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 cubits/accelerate_cuda_shape.h" + + +# This doesn't pick up a user specified '--with-compiler' flag +# +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 test "${ac_cv_prog_CXX+set}" = set; 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 { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$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 test "${ac_cv_prog_ac_ct_CXX+set}" = set; 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 { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$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_set_status 77 +as_fn_error "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 +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 test "${ac_cv_objext+set}" = set; 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 test "${ac_cv_cxx_compiler_gnu+set}" = set; 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 test "${ac_cv_prog_cxx_g+set}" = set; 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 + +# 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 test "${ac_cv_path_GHC+set}" = set; 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 { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$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 + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking size of Int" >&5 +$as_echo_n "checking size of Int... " >&6; } + +hs_int_size=`$GHC -w -ignore-dot-ghci -e "Foreign.sizeOf (undefined::Int)"` +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $hs_int_size" >&5 +$as_echo "$hs_int_size" >&6; } + +case $hs_int_size in + 4) hs_int_type=int32_t ;; + 8) hs_int_type=int64_t ;; + *) as_fn_error "could not determine size of a Haskell Int" "$LINENO" 5 +esac + + +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 + test "x$cache_file" != "x/dev/null" && + { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 +$as_echo "$as_me: updating cache $cache_file" >&6;} + cat confcache >$cache_file + 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= +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. +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 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=$?; test $as_status -eq 0 && as_status=1 + if test "$3"; then + as_lineno=${as_lineno-"$2"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $1" >&$3 + fi + $as_echo "$as_me: error: $1" >&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 -p'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -p' + elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln + else + as_ln_s='cp -p' + fi +else + as_ln_s='cp -p' +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 + +if test -x / >/dev/null 2>&1; then + as_test_x='test -x' +else + if ls -dL / >/dev/null 2>&1; then + as_ls_L_option=L + else + as_ls_L_option= + fi + as_test_x=' + eval sh -c '\'' + if test -d "$1"; then + test -d "$1/."; + else + case $1 in #( + -*)set "./$1";; + esac; + case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #(( + ???[sx]*):;;*)false;;esac;fi + '\'' sh + ' +fi +as_executable_p=$as_test_x + +# 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.9.0.0, which was +generated by GNU Autoconf 2.65. 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 ." + +_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.9.0.0 +configured by $0, generated by GNU Autoconf 2.65, + with options \\"\$ac_cs_config\\" + +Copyright (C) 2009 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=$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"` ;; + 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 + "cubits/accelerate_cuda_shape.h") CONFIG_FILES="$CONFIG_FILES cubits/accelerate_cuda_shape.h" ;; + + *) 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= + trap 'exit_status=$? + { test -z "$tmp" || test ! -d "$tmp" || rm -fr "$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 -n "$tmp" && test -d "$tmp" +} || +{ + tmp=./conf$$-$RANDOM + (umask 077 && mkdir "$tmp") +} || as_fn_error "cannot create a temporary directory in ." "$LINENO" 5 + +# 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` +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 {' >"$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 >>"\$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 +' >$CONFIG_STATUS || ac_write_fail=1 +rm -f conf$$subs.awk +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +_ACAWK +cat >>"\$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 < "$tmp/subs1.awk" > "$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 $(srcdir), +# ${srcdir} and @srcdir@ 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[ ]*=/{ +s/:*\$(srcdir):*/:/ +s/:*\${srcdir}:*/:/ +s/:*@srcdir@:*/:/ +s/^\([^=]*=[ ]*\):*/\1/ +s/:*$// +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="$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 "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 >"$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 "$tmp/subs.awk" >$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' "$tmp/out"`; test -n "$ac_out"; } && + { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' "$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 "$tmp/stdin" + case $ac_file in + -) cat "$tmp/out" && rm -f "$tmp/out";; + *) rm -f "$ac_file" && mv "$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 $? +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 + + diff --git a/cubits/accelerate_cuda_extras.h b/cubits/accelerate_cuda_extras.h new file mode 100644 --- /dev/null +++ b/cubits/accelerate_cuda_extras.h @@ -0,0 +1,22 @@ +/* ----------------------------------------------------------------------------- + * + * Module : Extras + * 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 + * Stability : experimental + * + * ---------------------------------------------------------------------------*/ + +#ifndef __ACCELERATE_CUDA_EXTRAS_H__ +#define __ACCELERATE_CUDA_EXTRAS_H__ + +#include "accelerate_cuda_function.h" +#include "accelerate_cuda_shape.h" +#include "accelerate_cuda_stencil.h" +#include "accelerate_cuda_texture.h" + +#endif + diff --git a/cubits/accelerate_cuda_function.h b/cubits/accelerate_cuda_function.h new file mode 100644 --- /dev/null +++ b/cubits/accelerate_cuda_function.h @@ -0,0 +1,209 @@ +/* ----------------------------------------------------------------------------- + * + * Module : Function + * 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 + * Stability : experimental + * + * ---------------------------------------------------------------------------*/ + +#ifndef __ACCELERATE_CUDA_FUNCTION_H__ +#define __ACCELERATE_CUDA_FUNCTION_H__ + +#include +#include + +#ifdef __cplusplus + +/* ----------------------------------------------------------------------------- + * Device functions required to support generated code + * -------------------------------------------------------------------------- */ + +/* + * Left/Right bitwise rotation + */ +template +static __inline__ __device__ T rotateL(const T x, const int32_t i) +{ + const int32_t i8 = i & 8 * sizeof(x) - 1; + return i8 == 0 ? x : x << i8 | x >> 8 * sizeof(x) - i8; +} + +template +static __inline__ __device__ T rotateR(const T x, const int32_t i) +{ + const int32_t i8 = i & 8 * sizeof(x) - 1; + return i8 == 0 ? x : x >> i8 | x << 8 * sizeof(x) - i8; +} + +/* + * Integer division, truncated towards negative infinity + */ +template +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); +} + +/* + * Integer modulus, Haskell style + */ +template +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; +} + + +/* + * Type coercion + */ +template +static __inline__ __device__ uint32_t reinterpret32(const T x) +{ + union { T a; uint32_t b; } u; + + u.a = x; + return u.b; +} + +template <> +static __inline__ __device__ uint32_t reinterpret32(const float x) +{ + return __float_as_int(x); +} + +template +static __inline__ __device__ uint64_t reinterpret64(const T x) +{ + union { T a; uint64_t b; } u; + + u.a = x; + return u.b; +} + +#if !defined(__CUDA_ARCH__) || __CUDA_ARCH__ >= 130 +template <> +static __inline__ __device__ uint64_t reinterpret64(const double x) +{ + return __double_as_longlong(x); +} +#endif + + +/* + * Atomic compare-and-swap, with type coercion + */ +template +static __inline__ __device__ T atomicCAS32(T* address, T compare, T val) +{ + union { T a; uint32_t b; } u; + + u.b = atomicCAS((uint32_t*) address, reinterpret32(compare), reinterpret32(val)); + return u.a; +} + +template <> +static __inline__ __device__ int32_t atomicCAS32(int32_t* address, int32_t compare, int32_t val) +{ + return atomicCAS(address, compare, val); +} + +template <> +static __inline__ __device__ uint32_t atomicCAS32(uint32_t* address, uint32_t compare, uint32_t val) +{ + return atomicCAS(address, compare, val); +} + +#if !defined(__CUDA_ARCH__) || __CUDA_ARCH__ >= 120 +template +static __inline__ __device__ T atomicCAS64(T* address, T compare, T val) +{ + union { T a; unsigned long long int b; } u; + + u.b = atomicCAS((unsigned long long int*) address, reinterpret64(compare), reinterpret64(val)); + return u.a; +} + +template <> +static __inline__ __device__ unsigned long long int atomicCAS64(unsigned long long int* address, unsigned long long int compare, unsigned long long int val) +{ + return atomicCAS(address, compare, val); +} +#endif + +#if 0 +/* ----------------------------------------------------------------------------- + * Additional helper functions + * -------------------------------------------------------------------------- */ + +/* + * Determine if the input is a power of two + */ +template +static __inline__ __host__ __device__ T isPow2(const T x) +{ + return ((x&(x-1)) == 0); +} + +/* + * Compute the next highest power of two + */ +template +static __inline__ __host__ T ceilPow2(const T x) +{ +#if 0 + --x; + x |= x >> 1; + x |= x >> 2; + x |= x >> 4; + x |= x >> 8; + x |= x >> 16; + return ++x; +#endif + + return (isPow2(x)) ? x : 1u << (int) ceil(log2((double)x)); +} + +/* + * Compute the next lowest power of two + */ +template +static __inline__ __host__ T floorPow2(const T x) +{ +#if 0 + float nf = (float) n; + return 1 << (((*(int*)&nf) >> 23) - 127); +#endif + + int exp; + frexp(x, &exp); + return 1 << (exp - 1); +} + +/* + * computes next highest multiple of f from x + */ +template +static __inline__ __host__ T multiple(const T x, const T f) +{ + return ((x + (f-1)) / f); +} + +/* + * MS Excel-style CEIL() function. Rounds x up to nearest multiple of f + */ +template +static __inline__ __host__ T ceiling(const T x, const T f) +{ + return multiple(x, f) * f; +} +#endif + +#endif // __cplusplus +#endif // __ACCELERATE_CUDA_FUNCTION_H__ + diff --git a/cubits/accelerate_cuda_shape.h b/cubits/accelerate_cuda_shape.h new file mode 100644 --- /dev/null +++ b/cubits/accelerate_cuda_shape.h @@ -0,0 +1,338 @@ +/* ----------------------------------------------------------------------------- + * + * Module : Shape + * 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 + * Stability : experimental + * + * ---------------------------------------------------------------------------*/ + +#ifndef __ACCELERATE_CUDA_SHAPE_H__ +#define __ACCELERATE_CUDA_SHAPE_H__ + +#include +#include + +/* + * For the time being, the D.A.A.CUDA.Execute converts shape components from + * Haskell Ints (which may be 32- or 64-bits) into CUDA integers which are + * 32-bit. This is to avoid undue register pressure. Lift this restriction if + * future hardware gains better 64-bit support and/or we need to access very + * large arrays. + * + * typedef int64_t Ix; + */ +typedef int32_t Ix; +typedef void* DIM0; +typedef Ix DIM1; +typedef struct { Ix a1,a0; } DIM2; +typedef struct { Ix a2,a1,a0; } DIM3; +typedef struct { Ix a3,a2,a1,a0; } DIM4; +typedef struct { Ix a4,a3,a2,a1,a0; } DIM5; +typedef struct { Ix a5,a4,a3,a2,a1,a0; } DIM6; +typedef struct { Ix a6,a5,a4,a3,a2,a1,a0; } DIM7; +typedef struct { Ix a7,a6,a5,a4,a3,a2,a1,a0; } DIM8; +typedef struct { Ix a8,a7,a6,a5,a4,a3,a2,a1,a0; } DIM9; + +#ifdef __cplusplus + +/* ----------------------------------------------------------------------------- + * Shape construction and destruction + */ + +/* + * Convert the individual dimensions of a linear array into a shape + */ +static __inline__ __device__ DIM0 shape() +{ + return NULL; +} + +static __inline__ __device__ DIM1 shape(const Ix a) +{ + return a; +} + +static __inline__ __device__ DIM2 shape(const Ix b, const Ix a) +{ + DIM2 sh = { b, a }; + return sh; +} + +static __inline__ __device__ DIM3 shape(const Ix c, const Ix b, const Ix a) +{ + DIM3 sh = { c, b, a }; + return sh; +} + +static __inline__ __device__ DIM4 shape(const Ix d, const Ix c, const Ix b, const Ix a) +{ + DIM4 sh = { d, c, b, a }; + return sh; +} + +static __inline__ __device__ DIM5 shape(const Ix e, const Ix d, const Ix c, const Ix b, const Ix a) +{ + DIM5 sh = { e, d, c, b, a }; + return sh; +} + +static __inline__ __device__ DIM6 shape(const Ix f, const Ix e, const Ix d, const Ix c, const Ix b, const Ix a) +{ + DIM6 sh = { f, e, d, c, b, a }; + return sh; +} + +static __inline__ __device__ DIM7 shape(const Ix g, const Ix f, const Ix e, const Ix d, const Ix c, const Ix b, const Ix a) +{ + DIM7 sh = { g, f, e, d, c, b, a }; + return sh; +} + +static __inline__ __device__ DIM8 shape(const Ix h, const Ix g, const Ix f, const Ix e, const Ix d, const Ix c, const Ix b, const Ix a) +{ + DIM8 sh = { h, g, f, e, d, c, b, a }; + return sh; +} + +static __inline__ __device__ DIM9 shape(const Ix i, const Ix h, const Ix g, const Ix f, const Ix e, const Ix d, const Ix c, const Ix b, const Ix a) +{ + DIM9 sh = { i, h, g, f, e, d, c, b, a }; + return sh; +} + +/* + * Yield the inner-most dimension of a shape only + */ +template +static __inline__ __device__ Ix indexHead(const Shape ix) +{ + return ix.a0; +} + +template <> +static __inline__ __device__ Ix indexHead(const DIM0 ix) +{ + return 0; +} + +template <> +static __inline__ __device__ Ix indexHead(const DIM1 ix) +{ + return ix; +} + + +/* + * Yield all but the inner-most dimension of a shape + */ +static __inline__ __device__ DIM0 indexTail(const DIM1 ix) +{ + return 0; +} + +static __inline__ __device__ DIM1 indexTail(const DIM2 ix) +{ + return ix.a1; +} + +static __inline__ __device__ DIM2 indexTail(const DIM3 ix) +{ + return shape(ix.a2, ix.a1); +} + +static __inline__ __device__ DIM3 indexTail(const DIM4 ix) +{ + return shape(ix.a3, ix.a2, ix.a1); +} + +static __inline__ __device__ DIM4 indexTail(const DIM5 ix) +{ + return shape(ix.a4, ix.a3, ix.a2, ix.a1); +} + +static __inline__ __device__ DIM5 indexTail(const DIM6 ix) +{ + return shape(ix.a5, ix.a4, ix.a3, ix.a2, ix.a1); +} + +static __inline__ __device__ DIM6 indexTail(const DIM7 ix) +{ + return shape(ix.a6, ix.a5, ix.a4, ix.a3, ix.a2, ix.a1); +} + +static __inline__ __device__ DIM7 indexTail(const DIM8 ix) +{ + return shape(ix.a7, ix.a6, ix.a5, ix.a4, ix.a3, ix.a2, ix.a1); +} + +static __inline__ __device__ DIM8 indexTail(const DIM9 ix) +{ + return shape(ix.a8, ix.a7, ix.a6, ix.a5, ix.a4, ix.a3, ix.a2, ix.a1); +} + + +/* ----------------------------------------------------------------------------- + * Shape methods + */ + +/* + * Number of dimensions of a shape + */ +template +static __inline__ __device__ int dim(const Shape sh) +{ + return dim(indexTail(sh)) + 1; +} + +template <> +static __inline__ __device__ int dim(const DIM0 sh) +{ + return 0; +} + + +/* + * Yield the total number of elements in a shape + */ +template +static __inline__ __device__ int size(const Shape sh) +{ + return size(indexTail(sh)) * indexHead(sh); +} + +template <> +static __inline__ __device__ int size(const DIM0 sh) +{ + return 1; +} + + +/* + * Add an index to the head of a shape + */ +static __inline__ __device__ DIM1 indexCons(const DIM0 sh, const Ix ix) +{ + return shape(ix); +} + +static __inline__ __device__ DIM2 indexCons(const DIM1 sh, const Ix ix) +{ + return shape(sh, ix); +} + +static __inline__ __device__ DIM3 indexCons(const DIM2 sh, const Ix ix) +{ + return shape(sh.a1, sh.a0, ix); +} + +static __inline__ __device__ DIM4 indexCons(const DIM3 sh, const Ix ix) +{ + return shape(sh.a2, sh.a1, sh.a0, ix); +} + +static __inline__ __device__ DIM5 indexCons(const DIM4 sh, const Ix ix) +{ + return shape(sh.a3, sh.a2, sh.a1, sh.a0, ix); +} + +static __inline__ __device__ DIM6 indexCons(const DIM5 sh, const Ix ix) +{ + return shape(sh.a4, sh.a3, sh.a2, sh.a1, sh.a0, ix); +} + +static __inline__ __device__ DIM7 indexCons(const DIM6 sh, const Ix ix) +{ + return shape(sh.a5, sh.a4, sh.a3, sh.a2, sh.a1, sh.a0, ix); +} + +static __inline__ __device__ DIM8 indexCons(const DIM7 sh, const Ix ix) +{ + return shape(sh.a6, sh.a5, sh.a4, sh.a3, sh.a2, sh.a1, sh.a0, ix); +} + +static __inline__ __device__ DIM9 indexCons(const DIM8 sh, const Ix ix) +{ + return shape(sh.a7, sh.a6, sh.a5, sh.a4, sh.a3, sh.a2, sh.a1, sh.a0, ix); +} + + +/* + * Yield the index position in a linear, row-major representation of the array. + * First argument is the shape of the array, the second the index + */ +template +static __inline__ __device__ Ix toIndex(const Shape sh, const Shape ix) +{ + return toIndex(indexTail(sh), indexTail(ix)) * indexHead(sh) + indexHead(ix); +} + +template <> +static __inline__ __device__ Ix toIndex(const DIM0 sh, const DIM0 ix) +{ + return 0; +} + +template <> +static __inline__ __device__ Ix toIndex(const DIM1 sh, const DIM1 ix) +{ + return ix; +} + + +/* + * Inverse of 'toIndex' + */ +template +static __inline__ __device__ Shape fromIndex(const Shape sh, const Ix ix) +{ + const Ix d = indexHead(sh); + return indexCons(fromIndex(indexTail(sh), ix / d), ix % d); +} + +template <> +static __inline__ __device__ DIM0 fromIndex(const DIM0 sh, const Ix ix) +{ + return 0; +} + +template <> +static __inline__ __device__ DIM1 fromIndex(const DIM1 sh, const Ix ix) +{ + return ix; +} + + +/* + * Test for the magic index `ignore` + */ +template +static __inline__ __device__ int ignore(const Shape ix) +{ + return indexHead(ix) == -1 && ignore(indexTail(ix)); +} + +template <> +static __inline__ __device__ int ignore(const DIM0 ix) +{ + return 1; +} + + +#else + +static __inline__ __device__ int dim(const Ix sh); +static __inline__ __device__ int size(const Ix sh); +static __inline__ __device__ int shape(const Ix sh); +static __inline__ __device__ int toIndex(const Ix sh, const Ix ix); +static __inline__ __device__ int fromIndex(const Ix sh, const Ix ix); +static __inline__ __device__ int indexHead(const Ix ix); +static __inline__ __device__ int indexTail(const Ix ix); +static __inline__ __device__ int indexCons(const Ix sh, const Ix ix); + +#endif // __cplusplus +#endif // __ACCELERATE_CUDA_SHAPE_H__ + diff --git a/cubits/accelerate_cuda_shape.h.in b/cubits/accelerate_cuda_shape.h.in new file mode 100644 --- /dev/null +++ b/cubits/accelerate_cuda_shape.h.in @@ -0,0 +1,338 @@ +/* ----------------------------------------------------------------------------- + * + * Module : Shape + * 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 + * Stability : experimental + * + * ---------------------------------------------------------------------------*/ + +#ifndef __ACCELERATE_CUDA_SHAPE_H__ +#define __ACCELERATE_CUDA_SHAPE_H__ + +#include +#include + +/* + * For the time being, the D.A.A.CUDA.Execute converts shape components from + * Haskell Ints (which may be 32- or 64-bits) into CUDA integers which are + * 32-bit. This is to avoid undue register pressure. Lift this restriction if + * future hardware gains better 64-bit support and/or we need to access very + * large arrays. + * + * typedef @hs_int_type@ Ix; + */ +typedef int32_t Ix; +typedef void* DIM0; +typedef Ix DIM1; +typedef struct { Ix a1,a0; } DIM2; +typedef struct { Ix a2,a1,a0; } DIM3; +typedef struct { Ix a3,a2,a1,a0; } DIM4; +typedef struct { Ix a4,a3,a2,a1,a0; } DIM5; +typedef struct { Ix a5,a4,a3,a2,a1,a0; } DIM6; +typedef struct { Ix a6,a5,a4,a3,a2,a1,a0; } DIM7; +typedef struct { Ix a7,a6,a5,a4,a3,a2,a1,a0; } DIM8; +typedef struct { Ix a8,a7,a6,a5,a4,a3,a2,a1,a0; } DIM9; + +#ifdef __cplusplus + +/* ----------------------------------------------------------------------------- + * Shape construction and destruction + */ + +/* + * Convert the individual dimensions of a linear array into a shape + */ +static __inline__ __device__ DIM0 shape() +{ + return NULL; +} + +static __inline__ __device__ DIM1 shape(const Ix a) +{ + return a; +} + +static __inline__ __device__ DIM2 shape(const Ix b, const Ix a) +{ + DIM2 sh = { b, a }; + return sh; +} + +static __inline__ __device__ DIM3 shape(const Ix c, const Ix b, const Ix a) +{ + DIM3 sh = { c, b, a }; + return sh; +} + +static __inline__ __device__ DIM4 shape(const Ix d, const Ix c, const Ix b, const Ix a) +{ + DIM4 sh = { d, c, b, a }; + return sh; +} + +static __inline__ __device__ DIM5 shape(const Ix e, const Ix d, const Ix c, const Ix b, const Ix a) +{ + DIM5 sh = { e, d, c, b, a }; + return sh; +} + +static __inline__ __device__ DIM6 shape(const Ix f, const Ix e, const Ix d, const Ix c, const Ix b, const Ix a) +{ + DIM6 sh = { f, e, d, c, b, a }; + return sh; +} + +static __inline__ __device__ DIM7 shape(const Ix g, const Ix f, const Ix e, const Ix d, const Ix c, const Ix b, const Ix a) +{ + DIM7 sh = { g, f, e, d, c, b, a }; + return sh; +} + +static __inline__ __device__ DIM8 shape(const Ix h, const Ix g, const Ix f, const Ix e, const Ix d, const Ix c, const Ix b, const Ix a) +{ + DIM8 sh = { h, g, f, e, d, c, b, a }; + return sh; +} + +static __inline__ __device__ DIM9 shape(const Ix i, const Ix h, const Ix g, const Ix f, const Ix e, const Ix d, const Ix c, const Ix b, const Ix a) +{ + DIM9 sh = { i, h, g, f, e, d, c, b, a }; + return sh; +} + +/* + * Yield the inner-most dimension of a shape only + */ +template +static __inline__ __device__ Ix indexHead(const Shape ix) +{ + return ix.a0; +} + +template <> +static __inline__ __device__ Ix indexHead(const DIM0 ix) +{ + return 0; +} + +template <> +static __inline__ __device__ Ix indexHead(const DIM1 ix) +{ + return ix; +} + + +/* + * Yield all but the inner-most dimension of a shape + */ +static __inline__ __device__ DIM0 indexTail(const DIM1 ix) +{ + return 0; +} + +static __inline__ __device__ DIM1 indexTail(const DIM2 ix) +{ + return ix.a1; +} + +static __inline__ __device__ DIM2 indexTail(const DIM3 ix) +{ + return shape(ix.a2, ix.a1); +} + +static __inline__ __device__ DIM3 indexTail(const DIM4 ix) +{ + return shape(ix.a3, ix.a2, ix.a1); +} + +static __inline__ __device__ DIM4 indexTail(const DIM5 ix) +{ + return shape(ix.a4, ix.a3, ix.a2, ix.a1); +} + +static __inline__ __device__ DIM5 indexTail(const DIM6 ix) +{ + return shape(ix.a5, ix.a4, ix.a3, ix.a2, ix.a1); +} + +static __inline__ __device__ DIM6 indexTail(const DIM7 ix) +{ + return shape(ix.a6, ix.a5, ix.a4, ix.a3, ix.a2, ix.a1); +} + +static __inline__ __device__ DIM7 indexTail(const DIM8 ix) +{ + return shape(ix.a7, ix.a6, ix.a5, ix.a4, ix.a3, ix.a2, ix.a1); +} + +static __inline__ __device__ DIM8 indexTail(const DIM9 ix) +{ + return shape(ix.a8, ix.a7, ix.a6, ix.a5, ix.a4, ix.a3, ix.a2, ix.a1); +} + + +/* ----------------------------------------------------------------------------- + * Shape methods + */ + +/* + * Number of dimensions of a shape + */ +template +static __inline__ __device__ int dim(const Shape sh) +{ + return dim(indexTail(sh)) + 1; +} + +template <> +static __inline__ __device__ int dim(const DIM0 sh) +{ + return 0; +} + + +/* + * Yield the total number of elements in a shape + */ +template +static __inline__ __device__ int size(const Shape sh) +{ + return size(indexTail(sh)) * indexHead(sh); +} + +template <> +static __inline__ __device__ int size(const DIM0 sh) +{ + return 1; +} + + +/* + * Add an index to the head of a shape + */ +static __inline__ __device__ DIM1 indexCons(const DIM0 sh, const Ix ix) +{ + return shape(ix); +} + +static __inline__ __device__ DIM2 indexCons(const DIM1 sh, const Ix ix) +{ + return shape(sh, ix); +} + +static __inline__ __device__ DIM3 indexCons(const DIM2 sh, const Ix ix) +{ + return shape(sh.a1, sh.a0, ix); +} + +static __inline__ __device__ DIM4 indexCons(const DIM3 sh, const Ix ix) +{ + return shape(sh.a2, sh.a1, sh.a0, ix); +} + +static __inline__ __device__ DIM5 indexCons(const DIM4 sh, const Ix ix) +{ + return shape(sh.a3, sh.a2, sh.a1, sh.a0, ix); +} + +static __inline__ __device__ DIM6 indexCons(const DIM5 sh, const Ix ix) +{ + return shape(sh.a4, sh.a3, sh.a2, sh.a1, sh.a0, ix); +} + +static __inline__ __device__ DIM7 indexCons(const DIM6 sh, const Ix ix) +{ + return shape(sh.a5, sh.a4, sh.a3, sh.a2, sh.a1, sh.a0, ix); +} + +static __inline__ __device__ DIM8 indexCons(const DIM7 sh, const Ix ix) +{ + return shape(sh.a6, sh.a5, sh.a4, sh.a3, sh.a2, sh.a1, sh.a0, ix); +} + +static __inline__ __device__ DIM9 indexCons(const DIM8 sh, const Ix ix) +{ + return shape(sh.a7, sh.a6, sh.a5, sh.a4, sh.a3, sh.a2, sh.a1, sh.a0, ix); +} + + +/* + * Yield the index position in a linear, row-major representation of the array. + * First argument is the shape of the array, the second the index + */ +template +static __inline__ __device__ Ix toIndex(const Shape sh, const Shape ix) +{ + return toIndex(indexTail(sh), indexTail(ix)) * indexHead(sh) + indexHead(ix); +} + +template <> +static __inline__ __device__ Ix toIndex(const DIM0 sh, const DIM0 ix) +{ + return 0; +} + +template <> +static __inline__ __device__ Ix toIndex(const DIM1 sh, const DIM1 ix) +{ + return ix; +} + + +/* + * Inverse of 'toIndex' + */ +template +static __inline__ __device__ Shape fromIndex(const Shape sh, const Ix ix) +{ + const Ix d = indexHead(sh); + return indexCons(fromIndex(indexTail(sh), ix / d), ix % d); +} + +template <> +static __inline__ __device__ DIM0 fromIndex(const DIM0 sh, const Ix ix) +{ + return 0; +} + +template <> +static __inline__ __device__ DIM1 fromIndex(const DIM1 sh, const Ix ix) +{ + return ix; +} + + +/* + * Test for the magic index `ignore` + */ +template +static __inline__ __device__ int ignore(const Shape ix) +{ + return indexHead(ix) == -1 && ignore(indexTail(ix)); +} + +template <> +static __inline__ __device__ int ignore(const DIM0 ix) +{ + return 1; +} + + +#else + +static __inline__ __device__ int dim(const Ix sh); +static __inline__ __device__ int size(const Ix sh); +static __inline__ __device__ int shape(const Ix sh); +static __inline__ __device__ int toIndex(const Ix sh, const Ix ix); +static __inline__ __device__ int fromIndex(const Ix sh, const Ix ix); +static __inline__ __device__ int indexHead(const Ix ix); +static __inline__ __device__ int indexTail(const Ix ix); +static __inline__ __device__ int indexCons(const Ix sh, const Ix ix); + +#endif // __cplusplus +#endif // __ACCELERATE_CUDA_SHAPE_H__ + diff --git a/cubits/accelerate_cuda_stencil.h b/cubits/accelerate_cuda_stencil.h new file mode 100644 --- /dev/null +++ b/cubits/accelerate_cuda_stencil.h @@ -0,0 +1,93 @@ +/* ----------------------------------------------------------------------------- + * + * Module : Stencil + * 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 + * Stability : experimental + * + * ---------------------------------------------------------------------------*/ + +#ifndef __ACCELERATE_CUDA_STENCIL_H__ +#define __ACCELERATE_CUDA_STENCIL_H__ + +#include + +#ifdef __cplusplus + +/* + * Test if an index lies within the boundaries of a shape + */ +template +static __inline__ __device__ int inRange(const Shape sh, const Shape ix) +{ + return inRange(indexHead(sh), indexHead(ix)) && inRange(indexTail(sh), indexTail(ix)); +} + +template <> +static __inline__ __device__ int inRange(const DIM1 sz, const DIM1 i) +{ + return i >= 0 && i < sz; +} + +template <> +static __inline__ __device__ int inRange(const DIM0 sz, const DIM0 i) +{ + return i == 0; +} + + +/* + * Boundary condition handlers + */ +template +static __inline__ __device__ Shape clamp(const Shape sh, const Shape ix) +{ + return indexCons( clamp(indexTail(sh), indexTail(ix)) + , clamp(indexHead(sh), indexHead(ix)) ); +} + +template <> +static __inline__ __device__ DIM1 clamp(const DIM1 sz, const DIM1 i) +{ + // CUDA-4.0 does not include 64-bit min/max functions for Fermi (?) + return max(0, min((int) i, (int) sz-1)); +} + + +template +static __inline__ __device__ Shape mirror(const Shape sh, const Shape ix) +{ + return indexCons( mirror(indexTail(sh), indexTail(ix)) + , mirror(indexHead(sh), indexHead(ix)) ); +} + +template <> +static __inline__ __device__ DIM1 mirror(const DIM1 sz, const DIM1 i) +{ + if (i < 0) return -i; + else if (i >= sz) return sz - (i-sz+2); + else return i; +} + + +template +static __inline__ __device__ Shape wrap(const Shape sh, const Shape ix) +{ + return indexCons( wrap(indexTail(sh), indexTail(ix)) + , wrap(indexHead(sh), indexHead(ix)) ); +} + +template <> +static __inline__ __device__ DIM1 wrap(const DIM1 sz, const DIM1 i) +{ + if (i < 0) return sz+i; + else if (i >= sz) return i-sz; + else return i; +} + +#endif + +#endif diff --git a/cubits/accelerate_cuda_texture.h b/cubits/accelerate_cuda_texture.h new file mode 100644 --- /dev/null +++ b/cubits/accelerate_cuda_texture.h @@ -0,0 +1,133 @@ +/* ----------------------------------------------------------------------------- + * + * Module : Texture + * 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 + * Stability : experimental + * + * CUDA texture definitions and access functions are defined in terms of + * templates, and hence only available through the C++ interface. Expose some + * dummy wrappers to enable parsing with language-c. + * + * We don't have a definition for `Int' or `Word', since the bitwidth of the + * Haskell and C types may be different. + * + * NOTE ON 64-BIT TYPES + * The CUDA device uses little-endian arithmetic. We haven't accounted for the + * fact that this may be different on the host, for both initial data transfer + * and the unpacking below. + * + * ---------------------------------------------------------------------------*/ + +#ifndef __ACCELERATE_CUDA_TEXTURE_H__ +#define __ACCELERATE_CUDA_TEXTURE_H__ + +#include +#include + +#if defined(__cplusplus) && defined(__CUDACC__) + +typedef texture TexWord64; +typedef texture TexWord32; +typedef texture TexWord16; +typedef texture TexWord8; +typedef texture TexInt64; +typedef texture TexInt32; +typedef texture TexInt16; +typedef texture TexInt8; +typedef texture TexFloat; +typedef texture TexCChar; + +static __inline__ __device__ uint8_t indexArray(TexWord8 t, const int x) { return tex1Dfetch(t,x); } +static __inline__ __device__ uint16_t indexArray(TexWord16 t, const int x) { return tex1Dfetch(t,x); } +static __inline__ __device__ uint32_t indexArray(TexWord32 t, const int x) { return tex1Dfetch(t,x); } +static __inline__ __device__ uint64_t indexArray(TexWord64 t, const int x) +{ + union { uint2 x; uint64_t y; } v; + v.x = tex1Dfetch(t,x); + return v.y; +} + +static __inline__ __device__ int8_t indexArray(TexInt8 t, const int x) { return tex1Dfetch(t,x); } +static __inline__ __device__ int16_t indexArray(TexInt16 t, const int x) { return tex1Dfetch(t,x); } +static __inline__ __device__ int32_t indexArray(TexInt32 t, const int x) { return tex1Dfetch(t,x); } +static __inline__ __device__ int64_t indexArray(TexInt64 t, const int x) +{ + union { int2 x; int64_t y; } v; + v.x = tex1Dfetch(t,x); + return v.y; +} + +static __inline__ __device__ float indexArray(TexFloat t, const int x) { return tex1Dfetch(t,x); } +static __inline__ __device__ char indexArray(TexCChar t, const int x) { return tex1Dfetch(t,x); } + +#if defined(__LP64__) +typedef TexInt64 TexCLong; +typedef TexWord64 TexCULong; +#else +typedef TexInt32 TexCLong; +typedef TexWord32 TexCULong; +#endif + +/* + * Synonyms for C-types. NVCC will force Ints to be 32-bits. + */ +typedef TexInt8 TexCSChar; +typedef TexWord8 TexCUChar; +typedef TexInt16 TexCShort; +typedef TexWord16 TexCUShort; +typedef TexInt32 TexCInt; +typedef TexWord32 TexCUInt; +typedef TexInt64 TexCLLong; +typedef TexWord64 TexCULLong; +typedef TexFloat TexCFloat; + +/* + * Doubles, only available when compiled for Compute 1.3 and greater + */ +typedef texture TexDouble; +typedef TexDouble TexCDouble; + +#if !defined(CUDA_NO_SM_13_DOUBLE_INTRINSICS) +static __inline__ __device__ double indexDArray(TexDouble t, const int x) +{ + int2 v = tex1Dfetch(t,x); + return __hiloint2double(v.y,v.x); +} +#endif + +#else + +typedef void* TexWord64; +typedef void* TexWord32; +typedef void* TexWord16; +typedef void* TexWord8; +typedef void* TexInt64; +typedef void* TexInt32; +typedef void* TexInt16; +typedef void* TexInt8; +typedef void* TexCShort; +typedef void* TexCUShort; +typedef void* TexCInt; +typedef void* TexCUInt; +typedef void* TexCLong; +typedef void* TexCULong; +typedef void* TexCLLong; +typedef void* TexCULLong; +typedef void* TexFloat; +typedef void* TexDouble; +typedef void* TexCFloat; +typedef void* TexCDouble; +typedef void* TexCChar; +typedef void* TexCSChar; +typedef void* TexCUChar; + +void* indexArray(const void*, const int); +void* indexDArray(const void*, const int); + +#endif // defined(__cplusplus) && defined(__CUDACC__) +#endif // __ACCELERATE_CUDA_TEXTURE_H__ + diff --git a/cubits/accelerate_cuda_util.h b/cubits/accelerate_cuda_util.h new file mode 100644 --- /dev/null +++ b/cubits/accelerate_cuda_util.h @@ -0,0 +1,70 @@ +/* ----------------------------------------------------------------------------- + * + * Module : Util + * 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 + * Stability : experimental + * + * ---------------------------------------------------------------------------*/ + +#ifndef __ACCELERATE_CUDA_UTIL_H__ +#define __ACCELERATE_CUDA_UTIL_H__ + +#include +#include + +/* + * Core assert function. Don't let this escape... + */ +#if defined(__CUDACC__) || !defined(__DEVICE_EMULATION__) +#define __assert(e, file, line) ((void)0) +#else +#define __assert(e, file, line) \ + ((void) fprintf (stderr, "%s:%u: failed assertion `%s'\n", file, line, e), abort()) +#endif + +/* + * Test the given expression, and abort the program if it evaluates to false. + * Only available in debug mode. + */ +#ifndef _DEBUG +#define assert(e) ((void)0) +#else +#define assert(e) \ + ((void) ((e) ? (void(0)) : __assert (#e, __FILE__, __LINE__))) +#endif + +/* + * Macro to insert __syncthreads() in device emulation mode + */ +#ifdef __DEVICE_EMULATION__ +#define __EMUSYNC __syncthreads() +#else +#define __EMUSYNC +#endif + +/* + * Check the return status of CUDA API calls, and abort with an appropriate + * error string on failure. + */ +#define CUDA_SAFE_CALL_NO_SYNC(call) \ + do { \ + cudaError err = call; \ + if(cudaSuccess != err) { \ + const char *str = cudaGetErrorString(err); \ + __assert(str, __FILE__, __LINE__); \ + } \ + } while (0) + +#define CUDA_SAFE_CALL(call) \ + do { \ + CUDA_SAFE_CALL_NO_SYNC(call); \ + CUDA_SAFE_CALL_NO_SYNC(cudaThreadSynchronize()); \ + } while (0) + +#undef __assert +#endif // __ACCELERATE_CUDA_UTIL_H__ + diff --git a/include/accelerate.h b/include/accelerate.h new file mode 100644 --- /dev/null +++ b/include/accelerate.h @@ -0,0 +1,31 @@ + +#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 +