diff --git a/Data/Array/Accelerate/CUDA.hs b/Data/Array/Accelerate/CUDA.hs --- a/Data/Array/Accelerate/CUDA.hs +++ b/Data/Array/Accelerate/CUDA.hs @@ -4,8 +4,9 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Data.Array.Accelerate.CUDA --- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --- [2009..2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller +-- [2008..2009] Sean Lee +-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell @@ -120,9 +121,7 @@ -- 'Data.Word.Word32'. -- -- * If the permutation function to 'Data.Array.Accelerate.permute' resolves to --- non-unique indices, the combination function requires compute-1.1 to --- combine 32-bit types, or compute-1.2 for 64-bit types. Tuple components --- are resolved separately. +-- non-unique indices, the combination function requires compute-1.1. -- -- -- [/Debugging options:/] @@ -187,37 +186,38 @@ Arrays, -- * Synchronous execution - run, run1, stream, runIn, run1In, streamIn, + run, run1, runWith, run1With, + stream, streamWith, -- * Asynchronous execution Async, wait, poll, cancel, - runAsync, run1Async, runAsyncIn, run1AsyncIn, + runAsync, run1Async, runAsyncWith, run1AsyncWith, -- * Execution contexts Context, create, destroy, + unsafeFree, unsafeFreeWith, performGC, performGCWith, ) where -- standard library -import Control.Exception import Control.Applicative import Control.Monad.Trans import System.IO.Unsafe +import Prelude -- friends -import Data.Array.Accelerate.Trafo -import Data.Array.Accelerate.Smart ( Acc ) import Data.Array.Accelerate.Array.Sugar ( Arrays(..), ArraysR(..) ) +import Data.Array.Accelerate.Smart ( Acc ) +import Data.Array.Accelerate.Async +import Data.Array.Accelerate.Trafo + import Data.Array.Accelerate.CUDA.Array.Data -import Data.Array.Accelerate.CUDA.Async import Data.Array.Accelerate.CUDA.State import Data.Array.Accelerate.CUDA.Context import Data.Array.Accelerate.CUDA.Compile import Data.Array.Accelerate.CUDA.Execute -#if ACCELERATE_DEBUG -import Data.Array.Accelerate.Debug -#endif +import Data.Array.Accelerate.Debug as Debug -- Accelerate: CUDA @@ -230,21 +230,7 @@ -- Note that it is recommended you use 'run1' whenever possible. -- run :: Arrays a => Acc a -> a -run a - = unsafePerformIO - $ evaluate (runIn defaultContext a) - --- | As 'run', but allow the computation to continue running in a thread and --- return immediately without waiting for the result. The status of the --- computation can be queried using 'wait', 'poll', and 'cancel'. --- --- Note that a CUDA Context can be active on only one host thread at a time. If --- you want to execute multiple computations in parallel, use 'runAsyncIn'. --- -runAsync :: Arrays a => Acc a -> Async a -runAsync a - = unsafePerformIO - $ evaluate (runAsyncIn defaultContext a) +run = runWith defaultContext -- | As 'run', but execute using the specified device context rather than using -- the default, automatically selected device. @@ -256,24 +242,34 @@ -- 'Foreign.CUDA.Driver.Context.create' pushes the new context on top of the -- stack and makes it current with the calling thread. You should call -- 'Foreign.CUDA.Driver.Context.pop' to make the context floating before passing --- it to 'runIn', which will make it current for the duration of evaluating the +-- it to 'runWith', which will make it current for the duration of evaluating the -- expression. See the CUDA C Programming Guide (G.1) for more information. -- -runIn :: Arrays a => Context -> Acc a -> a -runIn ctx a +runWith :: Arrays a => Context -> Acc a -> a +runWith ctx a = unsafePerformIO - $ evaluate (runAsyncIn ctx a) >>= wait + $ wait =<< runAsyncWith ctx a --- | As 'runIn', but execute asynchronously. Be sure not to destroy the context, +-- | As 'run', but allow the computation to continue running in a thread and +-- return immediately without waiting for the result. The status of the +-- computation can be queried using 'wait', 'poll', and 'cancel'. +-- +-- Note that a CUDA Context can be active on only one host thread at a time. If +-- you want to execute multiple computations in parallel, use 'runAsyncWith'. +-- +runAsync :: Arrays a => Acc a -> IO (Async a) +runAsync = runAsyncWith defaultContext + +-- | As 'runWith', but execute asynchronously. Be sure not to destroy the context, -- or attempt to attach it to a different host thread, before all outstanding -- operations have completed. -- -runAsyncIn :: Arrays a => Context -> Acc a -> Async a -runAsyncIn ctx a = unsafePerformIO $ async execute +runAsyncWith :: Arrays a => Context -> Acc a -> IO (Async a) +runAsyncWith ctx a = asyncBound execute where !acc = convertAccWith config a - execute = evalCUDA ctx (compileAcc acc >>= dumpStats >>= executeAcc >>= collect) + execute = dumpGraph acc >> evalCUDA ctx (compileAcc acc >>= dumpStats >>= executeAcc >>= collect) -- | Prepare and execute an embedded array program of one argument. @@ -309,31 +305,28 @@ -- See the programs in the 'accelerate-examples' package for examples. -- run1 :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> b -run1 f - = unsafePerformIO - $ evaluate (run1In defaultContext f) - +run1 = run1With defaultContext --- | As 'run1', but the computation is executed asynchronously. +-- | As 'run1', but execute in the specified context. -- -run1Async :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> Async b -run1Async f - = unsafePerformIO - $ evaluate (run1AsyncIn defaultContext f) +run1With :: (Arrays a, Arrays b) => Context -> (Acc a -> Acc b) -> a -> b +run1With ctx f = + let go = run1AsyncWith ctx f + in \a -> unsafePerformIO $ wait =<< go a --- | As 'run1', but execute in the specified context. + +-- | As 'run1', but the computation is executed asynchronously. -- -run1In :: (Arrays a, Arrays b) => Context -> (Acc a -> Acc b) -> a -> b -run1In ctx f = let go = run1AsyncIn ctx f - in \a -> unsafePerformIO $ wait (go a) +run1Async :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> IO (Async b) +run1Async = run1AsyncWith defaultContext --- | As 'run1In', but execute asynchronously. +-- | As 'run1With', but execute asynchronously. -- -run1AsyncIn :: (Arrays a, Arrays b) => Context -> (Acc a -> Acc b) -> a -> Async b -run1AsyncIn ctx f = \a -> unsafePerformIO $ async (execute a) +run1AsyncWith :: (Arrays a, Arrays b) => Context -> (Acc a -> Acc b) -> a -> IO (Async b) +run1AsyncWith ctx f = \a -> asyncBound (execute a) where !acc = convertAfunWith config f - !afun = unsafePerformIO $ evalCUDA ctx (compileAfun acc) >>= dumpStats + !afun = unsafePerformIO $ dumpGraph acc >> evalCUDA ctx (compileAfun acc) >>= dumpStats execute a = evalCUDA ctx (executeAfun1 afun a >>= collect) -- TLM: We need to be very careful with run1* variants, to ensure that the @@ -344,18 +337,46 @@ -- collecting results as we go. -- stream :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> [a] -> [b] -stream f arrs - = unsafePerformIO - $ evaluate (streamIn defaultContext f arrs) +stream = streamWith defaultContext -- | As 'stream', but execute in the specified context. -- -streamIn :: (Arrays a, Arrays b) => Context -> (Acc a -> Acc b) -> [a] -> [b] -streamIn ctx f arrs - = let go = run1In ctx f - in map go arrs +streamWith :: (Arrays a, Arrays b) => Context -> (Acc a -> Acc b) -> [a] -> [b] +streamWith ctx f arrs = map go arrs + where + !go = run1With ctx f +{-- +-- | Generate a lazy list from a sequence computation. +-- +streamOut :: Arrays a => Seq [a] -> [a] +streamOut = streamOutWith defaultContext +streamOutWith :: forall a. Arrays a => Context -> Seq [a] -> [a] +streamOutWith ctx = exec . compile . convertSeq + where + compile = unsafePerformIO . evalCUDA ctx . compileSeq + exec s = go (streamSeq s) + where + go !s' = case step s' of + Nothing -> [] + Just (a, s'') -> a : go s'' + + step (StreamSeq ss) + = unsafePerformIO + $ evalCUDA ctx + $ do m <- ss + case m of + Nothing -> return Nothing + Just (a, s') -> collect a >> return (Just (a, s')) +--} + + +-- RCE: Similar to run1* variants, we need to be ultra careful with streamOut* +-- in order to make sure that the entire sequence is not reified at once. +-- The steps of the sequence computation should only be performed as needed +-- when elements of the list are forced. + -- Copy arrays from device to host. -- collect :: forall arrs. Arrays arrs => arrs -> CIO arrs @@ -375,20 +396,47 @@ config = Phase { recoverAccSharing = True , recoverExpSharing = True + , recoverSeqSharing = True , floatOutAccFromExp = True , enableAccFusion = True , convertOffsetOfSegment = True + -- , vectoriseSequences = False } dumpStats :: MonadIO m => a -> m a -#if ACCELERATE_DEBUG -dumpStats next = do - stats <- liftIO simplCount - liftIO $ traceMessage dump_simpl_stats (show stats) - liftIO $ resetSimplCount - return next -#else -dumpStats next = return next -#endif +dumpStats next = dumpSimplStats >> return next + + +-- Device memory management +-- ------------------------ +-- +-- Temporarily defining here, until we can define the interface for it. + + +-- Deallocate the device arrays corresponding to the given host side arrays. +-- This is unsafe in the sense that it is possible to call this function while +-- the array is currently in use. +-- +unsafeFree :: Arrays arrs => arrs -> IO () +unsafeFree = unsafeFreeWith defaultContext + +unsafeFreeWith :: forall arrs. Arrays arrs => Context -> arrs -> IO () +unsafeFreeWith !ctx !arrs + = evalCUDA ctx + $ freeR (arrays (undefined :: arrs)) (fromArr arrs) + where + freeR :: ArraysR a -> a -> CIO () + freeR ArraysRunit () = return () + freeR ArraysRarray arr = freeArray arr + freeR (ArraysRpair aeR1 aeR2) (arrs1, arrs2) = freeR aeR1 arrs1 >> freeR aeR2 arrs2 + + +-- Release any unused device memory +-- +performGC :: IO () +performGC = performGCWith defaultContext + +performGCWith :: Context -> IO () +performGCWith !ctx = evalCUDA ctx cleanupArrayData diff --git a/Data/Array/Accelerate/CUDA/AST.hs b/Data/Array/Accelerate/CUDA/AST.hs --- a/Data/Array/Accelerate/CUDA/AST.hs +++ b/Data/Array/Accelerate/CUDA/AST.hs @@ -1,11 +1,12 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeSynonymInstances #-} -- | -- Module : Data.Array.Accelerate.CUDA.AST --- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller +-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell @@ -18,26 +19,29 @@ module Data.Array.Accelerate.AST, AccKernel(..), Free, Gamma(..), Idx_(..), - ExecAcc, ExecAfun, ExecOpenAcc(..), + ExecAcc, ExecAfun, ExecOpenAfun, ExecOpenAcc(..), ExecExp, ExecFun, ExecOpenExp, ExecOpenFun, + -- ExecSeq(..), ExecOpenSeq(..), ExecP(..), ExecC(..), freevar, makeEnvMap, ) where -- friends import Data.Array.Accelerate.AST -import Data.Array.Accelerate.Pretty +import Data.Array.Accelerate.Lifetime +import Data.Array.Accelerate.Pretty as PP import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt ) -import qualified Data.Array.Accelerate.CUDA.FullList as FL +import qualified Data.Array.Accelerate.FullList as FL import qualified Foreign.CUDA.Driver as CUDA import qualified Foreign.CUDA.Analysis as CUDA -- system import Text.PrettyPrint import Data.Hashable -import Data.Monoid ( Monoid(..) ) +import Data.Monoid hiding ( (<>) ) import qualified Data.HashSet as Set import qualified Data.HashMap.Strict as Map +import Prelude -- A non-empty list of binary objects will be used to execute a kernel. We keep @@ -45,13 +49,13 @@ -- and execution information. -- data AccKernel a where - AccKernel :: !String -- __global__ entry function name - -> {-# UNPACK #-} !CUDA.Fun -- __global__ function object - -> {-# UNPACK #-} !CUDA.Module -- binary module - -> {-# UNPACK #-} !CUDA.Occupancy -- occupancy analysis - -> {-# UNPACK #-} !Int -- thread block size - -> {-# UNPACK #-} !Int -- shared memory per block (bytes) - -> !(Int -> Int) -- number of blocks for input problem size + AccKernel :: !String -- __global__ entry function name + -> {-# UNPACK #-} !CUDA.Fun -- __global__ function object + -> {-# UNPACK #-} !(Lifetime CUDA.Module) -- binary module + -> {-# UNPACK #-} !CUDA.Occupancy -- occupancy analysis + -> {-# UNPACK #-} !Int -- thread block size + -> {-# UNPACK #-} !Int -- shared memory per block (bytes) + -> !(Int -> Int) -- number of blocks for input problem size -> AccKernel a @@ -121,41 +125,45 @@ => !(PreExp ExecOpenAcc aenv sh) -- shape of the result array, used by execution -> ExecOpenAcc aenv (Array sh e) + -- ExecSeq :: Arrays arrs + -- => ExecOpenSeq aenv () arrs + -- -> ExecOpenAcc aenv arrs + -- An annotated AST suitable for execution in the CUDA environment -- -type ExecAcc a = ExecOpenAcc () a -type ExecAfun a = PreAfun ExecOpenAcc a +type ExecAcc a = ExecOpenAcc () a +type ExecAfun a = PreAfun ExecOpenAcc a +type ExecOpenAfun aenv a = PreOpenAfun ExecOpenAcc aenv a -type ExecOpenExp = PreOpenExp ExecOpenAcc -type ExecOpenFun = PreOpenFun ExecOpenAcc +type ExecOpenExp = PreOpenExp ExecOpenAcc +type ExecOpenFun = PreOpenFun ExecOpenAcc -type ExecExp = ExecOpenExp () -type ExecFun = ExecOpenFun () +type ExecExp = ExecOpenExp () +type ExecFun = ExecOpenFun () -- Display the annotated AST -- ------------------------- -instance Show (ExecOpenAcc aenv a) where - show = render . prettyExecAcc 0 noParens +instance Show (ExecAcc a) where + show = render . prettyExecAcc noParens PP.Empty instance Show (ExecAfun a) where - show = render . prettyExecAfun 0 - + show = render . prettyExecAfun -prettyExecAfun :: Int -> ExecAfun a -> Doc -prettyExecAfun alvl pfun = prettyPreAfun prettyExecAcc alvl pfun +prettyExecAfun :: ExecAfun a -> Doc +prettyExecAfun pfun = prettyPreOpenAfun prettyExecAcc PP.Empty pfun prettyExecAcc :: PrettyAcc ExecOpenAcc -prettyExecAcc alvl wrap exec = +prettyExecAcc wrap aenv exec = case exec of EmbedAcc sh -> wrap $ hang (text "Embedded") 2 - $ sep [ prettyPreExp prettyExecAcc 0 alvl parens sh ] + $ sep [ prettyPreExp prettyExecAcc parens aenv sh ] ExecAcc _ (Gamma fv) pacc -> - let base = prettyPreAcc prettyExecAcc alvl wrap pacc + let base = prettyPreOpenAcc prettyExecAcc wrap aenv pacc ann = braces (freevars (Map.keys fv)) freevars = (text "fv=" <>) . brackets . hcat . punctuate comma . map (\(Idx_ ix) -> char 'a' <> int (idxToInt ix)) @@ -168,4 +176,79 @@ Atuple{} -> base Aprj{} -> base _ -> ann <+> base + + -- ExecSeq _ -> text "" + +{-- +data ExecSeq a where + ExecS :: Extend ExecOpenAcc () aenv -> ExecOpenSeq aenv () a -> ExecSeq a + +data ExecOpenSeq aenv lenv arrs where + ExecP :: Arrays a => ExecP aenv lenv a -> ExecOpenSeq aenv (lenv, a) arrs -> ExecOpenSeq aenv lenv arrs + ExecC :: (Arrays a) => ExecC aenv lenv a -> ExecOpenSeq aenv lenv a + ExecR :: Idx lenv a -> Maybe a -> ExecOpenSeq aenv lenv [a] + +data ExecP aenv lenv a where + + ExecToSeq :: (Elt slix, Shape sl, Shape sh, Elt e) + => SliceIndex (EltRepr slix) + (EltRepr sl) + co + (EltRepr sh) + -> ExecOpenAcc aenv (Array sh e) + -> AccKernel (Array sl e) + -> !(Gamma aenv) + -> [slix] + -> ExecP aenv lenv (Array sl e) + + ExecUseLazy :: (Elt slix, Shape sl, Shape sh, Elt e) + => SliceIndex (EltRepr slix) + (EltRepr sl) + co + (EltRepr sh) + -> Array sh e + -> [slix] + -> ExecP aenv lenv (Array sl e) + + ExecStreamIn :: Arrays a + => [a] + -> ExecP aenv lenv a + + ExecMap :: (Arrays a, Arrays b) + => ExecOpenAfun aenv (a -> b) + -> Idx lenv a + -> ExecP aenv lenv b + + ExecZipWith :: (Arrays a, Arrays b, Arrays c) + => ExecOpenAfun aenv (a -> b -> c) + -> Idx lenv a + -> Idx lenv b + -> ExecP aenv lenv c + + ExecScanSeq :: Elt a + => ExecFun aenv (a -> a -> a) + -> ExecExp aenv a + -> Idx lenv (Scalar a) + -> Maybe a + -> ExecP aenv lenv (Scalar a) + +data ExecC aenv lenv a where + ExecFoldSeq :: Elt a + => ExecFun aenv (a -> a -> a) + -> ExecExp aenv a + -> Idx lenv (Scalar a) + -> Maybe a + -> ExecC aenv lenv (Scalar a) + + ExecFoldSeqFlatten :: (Arrays a, Shape sh, Elt e) + => ExecOpenAfun aenv (a -> Vector sh -> Vector e -> a) + -> ExecOpenAcc aenv a + -> Idx lenv (Array sh e) + -> Maybe a + -> ExecC aenv lenv a + + ExecStuple :: (Arrays a, IsAtuple a) + => Atuple (ExecC aenv senv) (TupleRepr a) + -> ExecC aenv senv a +--} diff --git a/Data/Array/Accelerate/CUDA/Analysis/Device.hs b/Data/Array/Accelerate/CUDA/Analysis/Device.hs --- a/Data/Array/Accelerate/CUDA/Analysis/Device.hs +++ b/Data/Array/Accelerate/CUDA/Analysis/Device.hs @@ -1,7 +1,7 @@ -- | -- Module : Data.Array.Accelerate.CUDA.Analysis.Device --- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller +-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/Data/Array/Accelerate/CUDA/Analysis/Launch.hs b/Data/Array/Accelerate/CUDA/Analysis/Launch.hs --- a/Data/Array/Accelerate/CUDA/Analysis/Launch.hs +++ b/Data/Array/Accelerate/CUDA/Analysis/Launch.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} -- | -- Module : Data.Array.Accelerate.CUDA.Analysis.Launch --- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller +-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell @@ -19,6 +19,7 @@ -- friends import Data.Array.Accelerate.AST +import Data.Array.Accelerate.Error import Data.Array.Accelerate.Trafo import Data.Array.Accelerate.Analysis.Type import Data.Array.Accelerate.Analysis.Shape @@ -27,9 +28,7 @@ import qualified Foreign.CUDA.Analysis as CUDA import qualified Foreign.CUDA.Driver as CUDA -#include "accelerate.h" - -- | -- Determine kernel launch parameters for the given array computation (as well -- as compiled function module). This consists of the thread block size, number @@ -47,7 +46,7 @@ -> ( Int -- block size , Int -> Int -- number of blocks for input problem size (grid) , Int ) -- shared memory (bytes) -launchConfig Delayed{} _ _ = INTERNAL_ERROR(error) "launchConfig" "encountered delayed array" +launchConfig Delayed{} _ _ = $internalError "launchConfig" "encountered delayed array" launchConfig (Manifest acc) dev occ = let cta = CUDA.activeThreads occ `div` CUDA.activeThreadBlocks occ maxGrid = CUDA.multiProcessorCount dev * CUDA.activeThreadBlocks occ @@ -66,7 +65,7 @@ -> CUDA.Fun -- corresponding __global__ entry function -> Int -- maximum number of threads per block -> IO CUDA.Occupancy -determineOccupancy Delayed{} _ _ _ = INTERNAL_ERROR(error) "determineOccupancy" "encountered delayed array" +determineOccupancy Delayed{} _ _ _ = $internalError "determineOccupancy" "encountered delayed array" determineOccupancy (Manifest acc) dev fn maxBlock = do registers <- CUDA.requires fn CUDA.NumRegs static_smem <- CUDA.requires fn CUDA.SharedSizeBytes -- static memory only @@ -89,7 +88,7 @@ -> (Int -> Int) -- shared memory as a function of thread block size (bytes) -> (Int, CUDA.Occupancy) blockSize dev acc lim regs smem = - CUDA.optimalBlockSizeBy dev (filter (<= lim) . strategy) (const regs) smem + CUDA.optimalBlockSizeOf dev (filter (<= lim) (strategy dev)) (const regs) smem where strategy = case acc of Fold _ _ _ -> CUDA.incPow2 @@ -102,7 +101,6 @@ Scanr1 _ _ -> CUDA.incWarp _ -> CUDA.decWarp - -- | -- Determine the number of blocks of the given size necessary to process the -- given array expression. This should understand things like #elements per @@ -117,17 +115,17 @@ -- for 1D reductions this is the total number of elements -- gridSize :: CUDA.DeviceProperties -> PreOpenAcc DelayedOpenAcc aenv a -> Int -> Int -> Int -gridSize p acc@(FoldSeg _ _ _ _) size cta = split acc (size * CUDA.warpSize p) cta -gridSize p acc@(Fold1Seg _ _ _) size cta = split acc (size * CUDA.warpSize p) cta -gridSize _ acc@(Fold _ _ _) size cta = if preAccDim delayedDim acc == 0 then split acc size cta else max 1 size -gridSize _ acc@(Fold1 _ _) size cta = if preAccDim delayedDim acc == 0 then split acc size cta else max 1 size -gridSize _ acc size cta = split acc size cta +gridSize p (FoldSeg _ _ _ _) size cta = split (size * CUDA.warpSize p) cta +gridSize p (Fold1Seg _ _ _) size cta = split (size * CUDA.warpSize p) cta +gridSize _ acc@(Fold _ _ _) size cta = if preAccDim delayedDim acc == 0 then split size cta else max 1 size +gridSize _ acc@(Fold1 _ _) size cta = if preAccDim delayedDim acc == 0 then split size cta else max 1 size +gridSize _ _ size cta = split size cta -split :: acc aenv a -> Int -> Int -> Int -split acc size cta = (size `between` eltsPerThread acc) `between` cta +split :: Int -> Int -> Int +split size cta = (size `between` eltsPerThread) `between` cta where between arr n = 1 `max` ((n + arr - 1) `div` n) - eltsPerThread _ = 1 + eltsPerThread = 1 -- | @@ -137,17 +135,17 @@ -- sharedMem :: CUDA.DeviceProperties -> PreOpenAcc DelayedOpenAcc aenv a -> Int -> Int -- non-computation forms -sharedMem _ Alet{} _ = INTERNAL_ERROR(error) "sharedMem" "Let" -sharedMem _ Avar{} _ = INTERNAL_ERROR(error) "sharedMem" "Avar" -sharedMem _ Apply{} _ = INTERNAL_ERROR(error) "sharedMem" "Apply" -sharedMem _ Acond{} _ = INTERNAL_ERROR(error) "sharedMem" "Acond" -sharedMem _ Awhile{} _ = INTERNAL_ERROR(error) "sharedMem" "Awhile" -sharedMem _ Atuple{} _ = INTERNAL_ERROR(error) "sharedMem" "Atuple" -sharedMem _ Aprj{} _ = INTERNAL_ERROR(error) "sharedMem" "Aprj" -sharedMem _ Use{} _ = INTERNAL_ERROR(error) "sharedMem" "Use" -sharedMem _ Unit{} _ = INTERNAL_ERROR(error) "sharedMem" "Unit" -sharedMem _ Reshape{} _ = INTERNAL_ERROR(error) "sharedMem" "Reshape" -sharedMem _ Aforeign{} _ = INTERNAL_ERROR(error) "sharedMem" "Aforeign" +sharedMem _ Alet{} _ = $internalError "sharedMem" "Let" +sharedMem _ Avar{} _ = $internalError "sharedMem" "Avar" +sharedMem _ Apply{} _ = $internalError "sharedMem" "Apply" +sharedMem _ Acond{} _ = $internalError "sharedMem" "Acond" +sharedMem _ Awhile{} _ = $internalError "sharedMem" "Awhile" +sharedMem _ Atuple{} _ = $internalError "sharedMem" "Atuple" +sharedMem _ Aprj{} _ = $internalError "sharedMem" "Aprj" +sharedMem _ Use{} _ = $internalError "sharedMem" "Use" +sharedMem _ Unit{} _ = $internalError "sharedMem" "Unit" +sharedMem _ Reshape{} _ = $internalError "sharedMem" "Reshape" +sharedMem _ Aforeign{} _ = $internalError "sharedMem" "Aforeign" -- skeleton nodes sharedMem _ Generate{} _ = 0 @@ -172,4 +170,5 @@ (blockDim `div` CUDA.warpSize p) * 8 + blockDim * sizeOf (delayedExpType x) -- TLM: why 8? I can't remember... sharedMem p (Fold1Seg _ a _) blockDim = (blockDim `div` CUDA.warpSize p) * 8 + blockDim * sizeOf (delayedAccType a) +-- sharedMem _ (Collect _) _ = 0 diff --git a/Data/Array/Accelerate/CUDA/Analysis/Shape.hs b/Data/Array/Accelerate/CUDA/Analysis/Shape.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/Analysis/Shape.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module : Data.Array.Accelerate.CUDA.Analysis.Shape +-- Copyright : [2012..2014] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.CUDA.Analysis.Shape ( + + module Data.Array.Accelerate.Analysis.Shape, + module Data.Array.Accelerate.CUDA.Analysis.Shape, + (:~:)(..), + +) where + +import Data.Typeable + +import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Analysis.Shape +import Data.Array.Accelerate.Analysis.Match + +import Data.Array.Accelerate.CUDA.AST + + +-- | Reify dimensionality of the result type of an array computation +-- +execAccDim :: AccDim ExecOpenAcc +execAccDim (ExecAcc _ _ pacc) = preAccDim execAccDim pacc + + +-- Match reified shape types +-- +matchShapeType + :: forall sh sh'. (Shape sh, Shape sh') + => sh + -> sh' + -> Maybe (sh :~: sh') +matchShapeType _ _ + | Just Refl <- matchTupleType (eltType (undefined::sh)) (eltType (undefined::sh')) + = gcast Refl + +matchShapeType _ _ + = Nothing + diff --git a/Data/Array/Accelerate/CUDA/Array/Data.hs b/Data/Array/Accelerate/CUDA/Array/Data.hs --- a/Data/Array/Accelerate/CUDA/Array/Data.hs +++ b/Data/Array/Accelerate/CUDA/Array/Data.hs @@ -2,12 +2,15 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.CUDA.Array.Data --- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --- [2009..2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell --- [2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell, Robert Clifton-Everest +-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller +-- [2009..2014] Trevor L. McDonell +-- [2013..2014] Robert Clifton-Everest -- License : BSD3 -- -- Maintainer : Trevor L. McDonell @@ -18,45 +21,51 @@ module Data.Array.Accelerate.CUDA.Array.Data ( -- * Array operations and representations - mallocArray, indexArray, - useArray, useArrayAsync, + mallocArray, freeArray, + indexArray, + useArray, useArrayAsync, useArraySlice, useDevicePtrs, - copyArray, copyArrayPeer, copyArrayPeerAsync, + copyArray, copyArrayAsync, copyArrayPeer, copyArrayPeerAsync, peekArray, peekArrayAsync, pokeArray, pokeArrayAsync, marshalArrayData, marshalTextureData, marshalDevicePtrs, - devicePtrsOfArrayData, advancePtrsOfArrayData, + withDevicePtrs, advancePtrsOfArrayData, devicePtrsFromList, devicePtrsToWordPtrs, -- * Garbage collection - cleanupArrayData + cleanupArrayData, ) where -- libraries -import Prelude hiding ( fst, snd ) -import qualified Prelude as P import Control.Applicative import Control.Monad.Reader ( asks ) import Control.Monad.State ( gets ) import Control.Monad.Trans ( liftIO ) +import Control.Monad.Trans.Cont import Foreign.C.Types import Foreign.Ptr +import Prelude hiding ( fst, snd ) +import qualified Prelude as P + -- friends +import Data.Array.Accelerate.Error import Data.Array.Accelerate.Array.Data -import Data.Array.Accelerate.Array.Sugar ( Array(..), Shape, Elt, toElt, EltRepr ) -import Data.Array.Accelerate.Array.Representation ( size ) +import Data.Array.Accelerate.Array.Sugar ( Array(..), Shape, Elt, fromElt, toElt, EltRepr ) +import Data.Array.Accelerate.Array.Representation ( size, SliceIndex ) import Data.Array.Accelerate.CUDA.State -import Data.Array.Accelerate.CUDA.Array.Table +import Data.Array.Accelerate.CUDA.Array.Slice ( TransferDesc, transferDesc ) +import Data.Array.Accelerate.CUDA.Array.Remote +import Data.Array.Accelerate.CUDA.Persistent ( KernelTable ) +import Data.Array.Accelerate.CUDA.Execute.Event ( EventTable ) +import Data.Array.Accelerate.CUDA.Execute.Stream ( Reservoir ) import qualified Data.Array.Accelerate.CUDA.Array.Prim as Prim import qualified Foreign.CUDA.Driver as CUDA import qualified Foreign.CUDA.Driver.Stream as CUDA import qualified Foreign.CUDA.Driver.Texture as CUDA -#include "accelerate.h" - -- Array Operations -- ---------------- @@ -82,6 +91,15 @@ mt <- gets memoryTable liftIO $! f ctx mt +run' :: (Context -> MemoryTable -> KernelTable -> Reservoir -> EventTable -> IO a) -> CIO a +run' f = do + ctx <- asks activeContext + mt <- gets memoryTable + kt <- gets kernelTable + rsv <- gets streamReservoir + etbl <- gets eventTable + liftIO $! f ctx mt kt rsv etbl + -- CPP hackery to generate the cases where we dispatch to the worker function handling -- elementary types. -- @@ -133,6 +151,25 @@ mkPrimDispatch(mallocPrim,Prim.mallocArray) +-- |Deallocate the device array accompanying the given host-side array. +-- +-- Note that this does not take into account whether or not the data is still +-- required by the current (or future) computation. +-- +freeArray :: Array dim e -> CIO () +freeArray (Array !_ !adata) = run doFree + where + doFree !ctx !mt = freeR arrayElt adata + where + freeR :: ArrayEltR e -> ArrayData e -> IO () + freeR ArrayEltRunit _ = return () + freeR (ArrayEltRpair aeR1 aeR2) ad = freeR aeR1 (fst ad) >> freeR aeR2 (snd ad) + freeR aer ad = freePrim aer ctx mt ad + -- + freePrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> IO () + mkPrimDispatch(freePrim,free) + + -- |Upload an existing array to the device -- useArray :: (Shape dim, Elt e) => Array dim e -> CIO () @@ -164,6 +201,27 @@ mkPrimDispatch(usePrim,Prim.useArrayAsync) +-- | Upload a slice of an existing array (eg. row of a matrix) to the +-- device. TODO : Bounds checking, generalize slices to more than just +-- inner dimension? +useArraySlice :: (Elt slix, Shape sl, Shape dim, Elt e) + => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr dim) + -> slix -- Slice + -> Array dim e -- Host array + -> Array sl e -- Device array + -> CIO () +useArraySlice slix sl (Array dim !adata_host) (Array _ !adata_dev) = run doUse + where + tdesc = transferDesc slix (fromElt sl) dim + doUse !ctx !mt = useR arrayElt adata_host adata_dev + where + useR :: ArrayEltR e -> ArrayData e -> ArrayData e -> IO () + useR ArrayEltRunit _ _ = return () + useR (ArrayEltRpair aeR1 aeR2) adh add = useR aeR1 (fst adh) (fst add) >> useR aeR2 (snd adh) (snd add) + useR aer adh add = usePrim aer ctx mt adh add tdesc -- usePrim aer ctx mt adh add tdesc + usePrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> ArrayData e -> TransferDesc -> IO () + mkPrimDispatch(usePrim,Prim.useArraySlice) + useDevicePtrs :: (Shape sh, Elt e) => EltRepr sh -> Prim.DevicePtrs (EltRepr e) -> CIO (Array sh e) useDevicePtrs sh ptrs = run doUse where @@ -246,7 +304,7 @@ -- copyArray :: (Shape dim, Elt e) => Array dim e -> Array dim e -> CIO () copyArray (Array !sh1 !adata1) (Array !sh2 !adata2) - = BOUNDS_CHECK(check) "copyArray" "shape mismatch" (sh1 == sh2) + = $boundsCheck "copyArray" "shape mismatch" (sh1 == sh2) $ run doCopy where !n = size sh1 @@ -261,13 +319,30 @@ copyPrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> ArrayData e -> Int -> IO () mkPrimDispatch(copyPrim,Prim.copyArray) +copyArrayAsync :: (Shape dim, Elt e) => Array dim e -> Array dim e -> Maybe CUDA.Stream -> CIO () +copyArrayAsync (Array !sh1 !adata1) (Array !sh2 !adata2) ms + = $boundsCheck "copyArrayAsync" "shape mismatch" (sh1 == sh2) + $ run doCopy + where + !n = size sh1 + doCopy !ctx !mt = copyR arrayElt adata1 adata2 + where + copyR :: ArrayEltR e -> ArrayData e -> ArrayData e -> IO () + copyR ArrayEltRunit _ _ = return () + copyR (ArrayEltRpair aeR1 aeR2) ad1 ad2 = copyR aeR1 (fst ad1) (fst ad2) >> + copyR aeR2 (snd ad1) (snd ad2) + copyR aer ad1 ad2 = copyPrim aer ctx mt ad1 ad2 n ms + -- + copyPrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> ArrayData e -> Int -> Maybe CUDA.Stream -> IO () + mkPrimDispatch(copyPrim,Prim.copyArrayAsync) + -- |Copy data between two device arrays which reside in different contexts. This -- might entail copying between devices. -- copyArrayPeer :: (Shape dim, Elt e) => Array dim e -> Context -> Array dim e -> Context -> CIO () copyArrayPeer (Array !sh1 !adata1) !ctxSrc (Array !sh2 !adata2) !ctxDst - = BOUNDS_CHECK(check) "copyArrayPeer" "shape mismatch" (sh1 == sh2) + = $boundsCheck "copyArrayPeer" "shape mismatch" (sh1 == sh2) $ run doCopy where !n = size sh1 @@ -284,7 +359,7 @@ copyArrayPeerAsync :: (Shape dim, Elt e) => Array dim e -> Context -> Array dim e -> Context -> Maybe CUDA.Stream -> CIO () copyArrayPeerAsync (Array !sh1 !adata1) !ctxSrc (Array !sh2 !adata2) !ctxDst !ms - = BOUNDS_CHECK(check) "copyArrayPeerAsync" "shape mismatch" (sh1 == sh2) + = $boundsCheck "copyArrayPeerAsync" "shape mismatch" (sh1 == sh2) $ run doCopy where !n = size sh1 @@ -383,61 +458,71 @@ marshalDevicePtrs !adata ptrs = map (CUDA.VArg . CUDA.wordPtrToDevPtr) $ devicePtrsToWordPtrs adata ptrs -- |Wrap the device pointers corresponding to a host-side array into arguments --- that can be passed to a kernel upon invocation. +-- that can be passed to a kernel upon invocation and call the +-- supplied continuation. Any asynchronous CUDA functions called by the +-- continuation must be in the same stream as given by the 2nd argument. -- -marshalArrayData :: ArrayElt e => ArrayData e -> CIO [CUDA.FunParam] -marshalArrayData !adata = run doMarshal +marshalArrayData :: ArrayElt e => ArrayData e -> Maybe CUDA.Stream -> ([CUDA.FunParam] -> CIO b) -> CIO b +marshalArrayData !adata ms f = run' doMarshal where - doMarshal !ctx !mt = marshalR arrayElt adata + doMarshal !ctx !mt !kt !rsv !etbl = runContT (marshalR arrayElt adata) (evalCUDAState ctx mt kt rsv etbl . f) where - marshalR :: ArrayEltR e -> ArrayData e -> IO [CUDA.FunParam] + marshalR :: ArrayEltR e -> ArrayData e -> ContT b IO [CUDA.FunParam] marshalR ArrayEltRunit _ = return [] marshalR (ArrayEltRpair aeR1 aeR2) ad = (++) <$> marshalR aeR1 (fst ad) <*> marshalR aeR2 (snd ad) - marshalR aer ad = return <$> marshalPrim aer ctx mt ad + marshalR aer ad = do + param <- ContT $ marshalPrim aer ctx mt ad ms + return [param] -- - marshalPrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> IO CUDA.FunParam + marshalPrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> Maybe CUDA.Stream -> (CUDA.FunParam -> IO b) -> IO b mkPrimDispatch(marshalPrim,Prim.marshalArrayData) -- |Bind the device memory arrays to the given texture reference(s), setting --- appropriate type. The arrays are bound, and the list of textures thereby --- consumed, in projection index order --- i.e. right-to-left +-- appropriate type, and call the supplied continuation. The arrays are bound, +-- and the list of textures thereby consumed, in projection index order +-- --- i.e. right-to-left +-- The textures should only be considered bound during the execution of the +-- continuation. Any asynchronous CUDA functions called by the continuation +-- must be in the same stream as given by the 4th argument. -- -marshalTextureData :: ArrayElt e => ArrayData e -> Int -> [CUDA.Texture] -> CIO () -marshalTextureData !adata !n !texs = run doMarshal +marshalTextureData :: ArrayElt e => ArrayData e -> Int -> [CUDA.Texture] -> Maybe CUDA.Stream -> ([CUDA.Texture] -> CIO b) -> CIO b +marshalTextureData !adata !n !texs ms f = run' doMarshal where - doMarshal !ctx !mt = marshalR arrayElt adata texs >> return () + doMarshal !ctx !mt !kt !rsv !etbl = runContT (marshalR arrayElt adata texs) (evalCUDAState ctx mt kt rsv etbl . \(_,ts) -> f ts) where - marshalR :: ArrayEltR e -> ArrayData e -> [CUDA.Texture] -> IO Int - marshalR ArrayEltRunit _ _ = return 0 + marshalR :: ArrayEltR e -> ArrayData e -> [CUDA.Texture] -> ContT b IO (Int, [CUDA.Texture]) + marshalR ArrayEltRunit _ _ = return (0, []) marshalR (ArrayEltRpair aeR1 aeR2) ad t - = do r <- marshalR aeR2 (snd ad) t - l <- marshalR aeR1 (fst ad) (drop r t) - return (l + r) + = do (r, rs) <- marshalR aeR2 (snd ad) t + (l, ls) <- marshalR aeR1 (fst ad) (drop r t) + return (l + r, ls ++ rs) marshalR aer ad t - = do marshalPrim aer ctx mt ad n (head t) - return 1 + = do param <- ContT $ marshalPrim aer ctx mt ad n (head t) ms + return (1, [param]) -- - marshalPrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> Int -> CUDA.Texture -> IO () + marshalPrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> Int -> CUDA.Texture -> Maybe CUDA.Stream -> (CUDA.Texture -> IO b) -> IO b mkPrimDispatch(marshalPrim,Prim.marshalTextureData) --- |Raw device pointers associated with a host-side array +-- | Perform an operation using the device pointers of the given array. Any +-- asynchronous CUDA functions called by the supplied continuation must be in +-- the same stream as given by the second argument. -- -devicePtrsOfArrayData :: ArrayElt e => ArrayData e -> CIO (Prim.DevicePtrs e) -devicePtrsOfArrayData !adata = run ptrs +withDevicePtrs :: ArrayElt e => ArrayData e -> Maybe CUDA.Stream -> (Prim.DevicePtrs e -> CIO b) -> CIO b +withDevicePtrs !adata ms f = run' ptrs where - ptrs !ctx !mt = ptrsR arrayElt adata + ptrs !ctx !mt !kt !rsv !etbl = runContT (ptrsR arrayElt adata) (evalCUDAState ctx mt kt rsv etbl . f) where - ptrsR :: ArrayEltR e -> ArrayData e -> IO (Prim.DevicePtrs e) + ptrsR :: ArrayEltR e -> ArrayData e -> ContT b IO (Prim.DevicePtrs e) ptrsR ArrayEltRunit _ = return () ptrsR (ArrayEltRpair aeR1 aeR2) ad = (,) <$> ptrsR aeR1 (fst ad) <*> ptrsR aeR2 (snd ad) - ptrsR aer ad = ptrsPrim aer ctx mt ad + ptrsR aer ad = ContT $ ptrsPrim aer ctx mt ad ms -- - ptrsPrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> IO (Prim.DevicePtrs e) - mkPrimDispatch(ptrsPrim,Prim.devicePtrsOfArrayData) + ptrsPrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> Maybe CUDA.Stream -> (Prim.DevicePtrs e -> IO b) -> IO b + mkPrimDispatch(ptrsPrim,Prim.withDevicePtrs) -- |Advance a set of device pointers by the given number of elements each @@ -453,3 +538,4 @@ -- advancePrim :: ArrayEltR e -> ArrayData e -> Prim.DevicePtrs e -> Prim.DevicePtrs e mkPrimDispatch(advancePrim,Prim.advancePtrsOfArrayData n) + diff --git a/Data/Array/Accelerate/CUDA/Array/Nursery.hs b/Data/Array/Accelerate/CUDA/Array/Nursery.hs deleted file mode 100644 --- a/Data/Array/Accelerate/CUDA/Array/Nursery.hs +++ /dev/null @@ -1,124 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | --- Module : Data.Array.Accelerate.CUDA.Array.Nursery --- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --- [2009..2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.CUDA.Array.Nursery ( - - Nursery(..), NRS, new, malloc, stash, flush, - -) where - --- friends -import Data.Array.Accelerate.CUDA.FullList ( FullList(..) ) -import qualified Data.Array.Accelerate.CUDA.FullList as FL -import qualified Data.Array.Accelerate.CUDA.Debug as D - --- libraries -import Prelude -import Data.Hashable -import Control.Exception ( bracket_ ) -import Control.Concurrent.MVar ( MVar, newMVar, withMVar, mkWeakMVar ) -import System.Mem.Weak ( Weak ) -import Foreign.Ptr ( ptrToIntPtr ) -import Foreign.CUDA.Ptr ( DevicePtr ) - -import qualified Foreign.CUDA.Driver as CUDA -import qualified Data.HashTable.IO as HT - - --- The nursery is a place to store device memory arrays that are no longer --- needed. If a new array is requested of a similar size, we might return an --- array from the nursery instead of calling into the CUDA API to allocate fresh --- memory. --- --- Note that pointers are also related to a specific context, so we must include --- that when looking up the map. --- --- Note that since there might be many arrays for the same size, each entry in --- the map keeps a (non-empty) list of device pointers. --- -type HashTable key val = HT.BasicHashTable key val - -type NRS = MVar ( HashTable (CUDA.Context, Int) (FullList () (DevicePtr ())) ) -data Nursery = Nursery {-# UNPACK #-} !NRS - {-# UNPACK #-} !(Weak NRS) - -instance Hashable CUDA.Context where - {-# INLINE hashWithSalt #-} - hashWithSalt salt (CUDA.Context ctx) - = salt `hashWithSalt` (fromIntegral (ptrToIntPtr ctx) :: Int) - - --- Generate a fresh nursery --- -new :: IO Nursery -new = do - tbl <- HT.new - ref <- newMVar tbl - weak <- mkWeakMVar ref (flush tbl) - return $! Nursery ref weak - - --- Look for a chunk of memory in the nursery of a given size (or a little bit --- larger). If found, it is removed from the nursery and a pointer to it --- returned. --- -{-# INLINE malloc #-} -malloc :: Int -> CUDA.Context -> Nursery -> IO (Maybe (DevicePtr ())) -malloc !n !ctx (Nursery !ref _) = withMVar ref $ \tbl -> do - let !key = (ctx,n) - -- - mp <- HT.lookup tbl key - case mp of - Nothing -> return Nothing - Just (FL () ptr rest) -> - case rest of - FL.Nil -> HT.delete tbl key >> return (Just ptr) - FL.Cons () v xs -> HT.insert tbl key (FL () v xs) >> return (Just ptr) - - --- Add a device pointer to the nursery. --- -{-# INLINE stash #-} -stash :: Int -> CUDA.Context -> NRS -> DevicePtr a -> IO () -stash !n !ctx !ref (CUDA.castDevPtr -> !ptr) = withMVar ref $ \tbl -> do - let !key = (ctx, n) - -- - mp <- HT.lookup tbl key - case mp of - Nothing -> HT.insert tbl key (FL.singleton () ptr) - Just xs -> HT.insert tbl key (FL.cons () ptr xs) - - --- Delete all entries from the nursery and free all associated device memory. --- -flush :: HashTable (CUDA.Context,Int) (FullList () (CUDA.DevicePtr ())) -> IO () -flush !tbl = - let clean (!key@(ctx,_),!val) = do - bracket_ (CUDA.push ctx) CUDA.pop (FL.mapM_ (const CUDA.free) val) - HT.delete tbl key - in - message "flush nursery" >> HT.mapM_ clean tbl - - --- Debug --- ----- - -{-# INLINE trace #-} -trace :: String -> IO a -> IO a -trace msg next = D.message D.dump_gc ("gc: " ++ msg) >> next - -{-# INLINE message #-} -message :: String -> IO () -message s = s `trace` return () - diff --git a/Data/Array/Accelerate/CUDA/Array/Prim.hs b/Data/Array/Accelerate/CUDA/Array/Prim.hs --- a/Data/Array/Accelerate/CUDA/Array/Prim.hs +++ b/Data/Array/Accelerate/CUDA/Array/Prim.hs @@ -1,13 +1,15 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} -- | -- Module : Data.Array.Accelerate.CUDA.Array.Prim --- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --- [2009..2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller +-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell @@ -20,13 +22,12 @@ DevicePtrs, HostPtrs, mallocArray, indexArray, - useArray, useArrayAsync, - useDevicePtrs, - copyArray, copyArrayPeer, copyArrayPeerAsync, + useArray, useArrayAsync, useArraySlice, useDevicePtrs, + copyArray, copyArrayAsync, copyArrayPeer, copyArrayPeerAsync, peekArray, peekArrayAsync, pokeArray, pokeArrayAsync, marshalDevicePtrs, marshalArrayData, marshalTextureData, - devicePtrsOfArrayData, advancePtrsOfArrayData + withDevicePtrs, advancePtrsOfArrayData ) where @@ -34,11 +35,11 @@ import Prelude hiding ( lookup ) import Data.Int import Data.Word -import Data.Maybe -import Data.Functor import Data.Typeable import Control.Monad +import Language.Haskell.TH import System.Mem.StableName +import Foreign.CUDA.Ptr ( plusDevPtr ) import Foreign.Ptr import Foreign.C.Types import Foreign.Storable @@ -48,14 +49,15 @@ import qualified Foreign.CUDA.Driver.Texture as CUDA -- friends +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Lifetime ( withLifetime ) import Data.Array.Accelerate.Array.Data import Data.Array.Accelerate.CUDA.Context -import Data.Array.Accelerate.CUDA.Array.Table +import Data.Array.Accelerate.CUDA.Array.Slice ( TransferDesc(..), blocksOf ) +import Data.Array.Accelerate.CUDA.Array.Remote import qualified Data.Array.Accelerate.CUDA.Debug as D -#include "accelerate.h" - -- Device array representation -- --------------------------- @@ -98,7 +100,7 @@ primArrayEltAs(CDouble, Double) primArrayElt(Char) -primArrayEltAs(CChar, Int8) +primArrayEltAs(CChar, HTYPE_CCHAR) primArrayEltAs(CSChar, Int8) primArrayEltAs(CUChar, Word8) @@ -140,12 +142,13 @@ instance TextureData CSChar where format _ = (CUDA.Int8, 1) instance TextureData CUChar where format _ = (CUDA.Word8, 1) instance TextureData Char where format _ = (CUDA.Word32, 1) -instance TextureData Int where format _ = (CUDA.Int32, SIZEOF_HTYPE_INT `div` 4) -instance TextureData Word where format _ = (CUDA.Word32, SIZEOF_HTYPE_WORD `div` 4) -instance TextureData CLong where format _ = (CUDA.Int32, SIZEOF_HTYPE_LONG `div` 4) -instance TextureData CULong where format _ = (CUDA.Word32, SIZEOF_HTYPE_UNSIGNED_LONG `div` 4) +$( runQ [d| instance TextureData Int where format _ = (CUDA.Int32, sizeOf (undefined::Int) `div` 4) |] ) +$( runQ [d| instance TextureData Word where format _ = (CUDA.Word32, sizeOf (undefined::Word) `div` 4) |] ) +$( runQ [d| instance TextureData CLong where format _ = (CUDA.Int32, sizeOf (undefined::CLong) `div` 4) |] ) +$( runQ [d| instance TextureData CULong where format _ = (CUDA.Word32, sizeOf (undefined::CULong) `div` 4) |] ) + -- Primitive array operations -- -------------------------- @@ -154,7 +157,7 @@ -- release any inaccessible arrays and try again. -- mallocArray - :: forall e a. (ArrayElt e, DevicePtrs e ~ CUDA.DevicePtr a, Typeable e, Typeable a, Storable a) + :: forall e a. (PrimElt e a, DevicePtrs e ~ CUDA.DevicePtr a) => Context -> MemoryTable -> ArrayData e @@ -163,18 +166,16 @@ mallocArray !ctx !mt !ad !n0 = do let !n = 1 `max` n0 !bytes = n * sizeOf (undefined :: a) - exists <- isJust <$> (lookup ctx mt ad :: IO (Maybe (CUDA.DevicePtr a))) - unless exists $ do - message $ "mallocArray: " ++ showBytes bytes - _ <- malloc ctx mt ad n :: IO (CUDA.DevicePtr a) - return () + message $ "mallocArray: " ++ showBytes bytes + _ <- malloc ctx mt ad False n + return () -- A combination of 'mallocArray' and 'pokeArray' to allocate space on the -- device and upload an existing array. This is specialised because if the host -- array is shared on the heap, we do not need to do anything. -- useArray - :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr a, Typeable e, Typeable a, Storable a) + :: forall e a. (PrimElt e a, DevicePtrs e ~ CUDA.DevicePtr a) => Context -> MemoryTable -> ArrayData e @@ -184,13 +185,36 @@ let src = ptrsOfArrayData ad !n = 1 `max` n0 !bytes = n * sizeOf (undefined :: a) + + run dst = transfer "useArray/malloc" bytes $ CUDA.pokeArray n src dst in do - exists <- isJust <$> (lookup ctx mt ad :: IO (Maybe (CUDA.DevicePtr a))) - unless exists $ do - dst <- malloc ctx mt ad n - transfer "useArray/malloc" bytes $ CUDA.pokeArray n src dst + alloc <- malloc ctx mt ad True n + when alloc $ withDevicePtrs ctx mt ad Nothing run +-- A combination of 'mallocArray' and 'pokeArray' to allocate space on the +-- device and upload an existing array. This is specialised because if the host +-- array is shared on the heap, we do not need to do anything. +-- +useArraySlice + :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr a, Typeable e, Typeable a, Storable a) + => Context + -> MemoryTable + -> ArrayData e + -> ArrayData e + -> TransferDesc + -> IO () +useArraySlice !ctx !mt !ad_host !ad_dev !tdesc = + let src = ptrsOfArrayData ad_host + k = sizeOf (undefined :: a) + run dst = + sequence_ + [ transfer "useArraySlice/malloc" (k * size) $ CUDA.pokeArray size (plusPtr src (k * src_offset)) (plusDevPtr dst (k * dst_offset)) + | (src_offset, dst_offset, size) <- blocksOf tdesc] + in do + alloc <- malloc ctx mt ad_dev True (k * nblocks tdesc * blocksize tdesc) + when alloc $ withDevicePtrs ctx mt ad_dev Nothing run + useArrayAsync :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr a, Typeable e, Typeable a, Storable a) => Context @@ -203,11 +227,11 @@ let src = CUDA.HostPtr (ptrsOfArrayData ad) !n = 1 `max` n0 !bytes = n * sizeOf (undefined :: a) + + run dst = transfer "useArray/malloc" bytes $ CUDA.pokeArrayAsync n src dst ms in do - exists <- isJust <$> (lookup ctx mt ad :: IO (Maybe (CUDA.DevicePtr a))) - unless exists $ do - dst <- malloc ctx mt ad n - transfer "useArrayAsync/malloc" bytes $ CUDA.pokeArrayAsync n src dst ms + alloc <- malloc ctx mt ad True n + when alloc $ withDevicePtrs ctx mt ad ms run useDevicePtrs @@ -223,14 +247,14 @@ (adata, _) = runArrayData $ (,undefined) `fmap` newArrayData n in do message $ "useDevicePtrs: " ++ showBytes bytes - insertRemote ctx mt adata ptr + insertUnmanaged ctx mt adata ptr return adata -- Read a single element from an array at the given row-major index -- indexArray - :: forall e a. (ArrayElt e, DevicePtrs e ~ CUDA.DevicePtr a, Typeable e, Typeable a, Storable a) + :: forall e a. (PrimElt e a, DevicePtrs e ~ CUDA.DevicePtr a) => Context -> MemoryTable -> ArrayData e @@ -238,7 +262,7 @@ -> IO a indexArray !ctx !mt !ad !i = alloca $ \dst -> - devicePtrsOfArrayData ctx mt ad >>= \src -> do + withDevicePtrs ctx mt ad Nothing $ \src -> do message $ "indexArray: " ++ showBytes (sizeOf (undefined::a)) CUDA.peekArray 1 (src `CUDA.advanceDevPtr` i) dst peek dst @@ -248,49 +272,67 @@ -- respect to the host, but will never overlap kernel execution. -- copyArray - :: forall e a b. (ArrayElt e, ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr b, Typeable a, Typeable b, Typeable e, Storable b) + :: forall e a. (PrimElt e a, DevicePtrs e ~ CUDA.DevicePtr a) => Context -> MemoryTable -> ArrayData e -- source array -> ArrayData e -- destination array -> Int -- number of array elements -> IO () -copyArray !ctx !mt !from !to !n = do - src <- devicePtrsOfArrayData ctx mt from - dst <- devicePtrsOfArrayData ctx mt to - transfer "copyArrayAsync" (n * sizeOf (undefined :: b)) $ - CUDA.copyArrayAsync n src dst +copyArray !ctx !mt !from !to !n = + withDevicePtrs ctx mt from Nothing $ \src -> + withDevicePtrs ctx mt to Nothing $ \dst -> do + transfer "copyArray" (n * sizeOf (undefined :: a)) $ + CUDA.copyArray n src dst +copyArrayAsync + :: forall e a. (PrimElt e a, DevicePtrs e ~ CUDA.DevicePtr a) + => Context + -> MemoryTable + -> ArrayData e -- source array + -> ArrayData e -- destination array + -> Int -- number of array elements + -> Maybe CUDA.Stream + -> IO () +copyArrayAsync !ctx !mt !from !to !n !mst = + withDevicePtrs ctx mt from Nothing$ \src -> + withDevicePtrs ctx mt to Nothing $ \dst -> do + transfer "copyArrayAsync" (n * sizeOf (undefined :: a)) $ + CUDA.copyArrayAsync n src dst mst -- Copy data between two device arrays that exist in different contexts and/or -- devices. -- copyArrayPeer - :: forall e a b. (ArrayElt e, ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr b, Typeable a, Typeable b, Typeable e, Storable b) + :: forall e a. (PrimElt e a, DevicePtrs e ~ CUDA.DevicePtr a) => MemoryTable -> ArrayData e -> Context -- source array and context -> ArrayData e -> Context -- destination array and context -> Int -- number of array elements -> IO () -copyArrayPeer !mt !from !ctxSrc !to !ctxDst !n = do - src <- devicePtrsOfArrayData ctxSrc mt from - dst <- devicePtrsOfArrayData ctxDst mt to - transfer "copyArrayPeer" (n * sizeOf (undefined :: b)) $ - CUDA.copyArrayPeer n src (deviceContext ctxSrc) dst (deviceContext ctxDst) +copyArrayPeer !mt !from !ctxSrc !to !ctxDst !n = + withDevicePtrs ctxSrc mt from Nothing $ \src -> + withDevicePtrs ctxDst mt to Nothing $ \dst -> + withLifetime (deviceContext ctxSrc) $ \dctxSrc -> + withLifetime (deviceContext ctxDst) $ \dctxDst -> do + transfer "copyArrayPeer" (n * sizeOf (undefined :: a)) $ + CUDA.copyArrayPeer n src dctxSrc dst dctxDst copyArrayPeerAsync - :: forall e a b. (ArrayElt e, ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr b, Typeable a, Typeable b, Typeable e, Storable b) + :: forall e a. (PrimElt e a, DevicePtrs e ~ CUDA.DevicePtr a) => MemoryTable -> ArrayData e -> Context -- source array and context -> ArrayData e -> Context -- destination array and context -> Int -- number of array elements -> Maybe CUDA.Stream -> IO () -copyArrayPeerAsync !mt !from !ctxSrc !to !ctxDst !n !st = do - src <- devicePtrsOfArrayData ctxSrc mt from - dst <- devicePtrsOfArrayData ctxDst mt to - transfer "copyArrayPeerAsync" (n * sizeOf (undefined :: b)) $ - CUDA.copyArrayPeerAsync n src (deviceContext ctxSrc) dst (deviceContext ctxDst) st +copyArrayPeerAsync !mt !from !ctxSrc !to !ctxDst !n !st = + withDevicePtrs ctxSrc mt from st $ \src -> + withDevicePtrs ctxDst mt to st $ \dst -> + withLifetime (deviceContext ctxSrc) $ \dctxSrc -> + withLifetime (deviceContext ctxDst) $ \dctxDst -> + transfer "copyArrayPeerAsync" (n * sizeOf (undefined :: a)) $ + CUDA.copyArrayPeerAsync n src dctxSrc dst dctxDst st -- Copy data from the device into the associated Accelerate host-side array @@ -303,7 +345,7 @@ -> Int -> IO () peekArray !ctx !mt !ad !n = - devicePtrsOfArrayData ctx mt ad >>= \src -> + withDevicePtrs ctx mt ad Nothing $ \src -> transfer "peekArray" (n * sizeOf (undefined :: a)) $ CUDA.peekArray n src (ptrsOfArrayData ad) @@ -316,7 +358,7 @@ -> Maybe CUDA.Stream -> IO () peekArrayAsync !ctx !mt !ad !n !st = - devicePtrsOfArrayData ctx mt ad >>= \src -> + withDevicePtrs ctx mt ad st $ \src -> transfer "peekArrayAsync" (n * sizeOf (undefined :: a)) $ CUDA.peekArrayAsync n src (CUDA.HostPtr $ ptrsOfArrayData ad) st @@ -331,7 +373,7 @@ -> Int -> IO () pokeArray !ctx !mt !ad !n = - devicePtrsOfArrayData ctx mt ad >>= \dst -> + withDevicePtrs ctx mt ad Nothing $ \dst -> transfer "pokeArray: " (n * sizeOf (undefined :: a)) $ CUDA.pokeArray n (ptrsOfArrayData ad) dst @@ -344,7 +386,7 @@ -> Maybe CUDA.Stream -> IO () pokeArrayAsync !ctx !mt !ad !n !st = - devicePtrsOfArrayData ctx mt ad >>= \dst -> + withDevicePtrs ctx mt ad st $ \dst -> transfer "pokeArrayAsync: " (n * sizeOf (undefined :: a)) $ CUDA.pokeArrayAsync n (CUDA.HostPtr $ ptrsOfArrayData ad) dst st @@ -360,49 +402,63 @@ -- Wrap a device pointer corresponding corresponding to a host-side array into --- arguments that can be passed to a kernel upon invocation +-- arguments that can be passed to a kernel upon invocation and call the +-- supplied continuation. Any asynchronous CUDA functions called by the +-- continuation must be in the same stream as given by the 4th argument. -- marshalArrayData - :: (ArrayElt e, DevicePtrs e ~ CUDA.DevicePtr b, Typeable b, Typeable e) + :: (PrimElt e a, DevicePtrs e ~ CUDA.DevicePtr a) => Context -> MemoryTable -> ArrayData e - -> IO CUDA.FunParam -marshalArrayData !ctx !mt !ad = marshalDevicePtrs ad <$> devicePtrsOfArrayData ctx mt ad + -> Maybe CUDA.Stream + -> (CUDA.FunParam -> IO b) + -> IO b +marshalArrayData !ctx !mt !ad ms run = withDevicePtrs ctx mt ad ms (run . marshalDevicePtrs ad) --- Bind device memory to the given texture reference, setting appropriate type +-- Bind device memory to the given texture reference, setting appropriate type, +-- and call the supplied continuation. The texture should only be considered +-- bound during the execution of the continuation. Any asynchronous CUDA +-- functions called by the continuation must be in the same stream as given by +-- the 6th argument. -- marshalTextureData - :: forall a e. (ArrayElt e, DevicePtrs e ~ CUDA.DevicePtr a, Typeable a, Typeable e, Storable a, TextureData a) + :: forall a e b. (PrimElt e a, DevicePtrs e ~ CUDA.DevicePtr a, TextureData a) => Context -> MemoryTable -> ArrayData e -- host array -> Int -- number of elements -> CUDA.Texture -- texture reference to bind array to - -> IO () -marshalTextureData !ctx !mt !ad !n !tex = + -> Maybe CUDA.Stream + -> (CUDA.Texture -> IO b) + -> IO b +marshalTextureData !ctx !mt !ad !n !tex ms run = let (fmt, c) = format (undefined :: a) - in devicePtrsOfArrayData ctx mt ad >>= \ptr -> do + in withDevicePtrs ctx mt ad ms $ \ptr -> do CUDA.setFormat tex fmt c CUDA.bind tex ptr (fromIntegral $ n * sizeOf (undefined :: a)) - + run tex --- Lookup the device memory associated with our host array +-- Perform an operation using the device pointer of the given array. Any +-- asynchronous CUDA functions called by the supplied continuation must be in +-- the same stream as given by the 4th argument. -- -devicePtrsOfArrayData - :: (ArrayElt e, DevicePtrs e ~ CUDA.DevicePtr b, Typeable e, Typeable b) +withDevicePtrs + :: (PrimElt e a, DevicePtrs e ~ CUDA.DevicePtr a) => Context -> MemoryTable -> ArrayData e - -> IO (DevicePtrs e) -devicePtrsOfArrayData !ctx !mt !ad = do - mv <- lookup ctx mt ad - case mv of - Just v -> return v + -> Maybe (CUDA.Stream) + -> (DevicePtrs e -> IO b) + -> IO b +withDevicePtrs !ctx !mt !ad ms run = do + mb <- withRemote ctx mt ad run ms + case mb of + Just b -> return b Nothing -> do sn <- makeStableName ad - INTERNAL_ERROR(error) "devicePtrsOfArrayData" $ "lost device memory #" ++ show (hashStableName sn) + $internalError "withDevicePtrs" $ "lost device memory #" ++ show (hashStableName sn) -- Advance device pointers by a given number of elements @@ -423,13 +479,9 @@ showBytes :: Int -> String showBytes x = D.showFFloatSIBase (Just 0) 1024 (fromIntegral x :: Double) "B" -{-# INLINE trace #-} -trace :: String -> IO a -> IO a -trace msg next = D.message D.dump_gc ("gc: " ++ msg) >> next - {-# INLINE message #-} message :: String -> IO () -message s = s `trace` return () +message msg = D.traceIO D.dump_gc ("gc: " ++ msg) {-# INLINE transfer #-} transfer :: String -> Int -> IO () -> IO () @@ -439,5 +491,5 @@ ++ showBytes bytes ++ " @ " ++ showRate bytes gpuTime ++ ", " ++ D.elapsed gpuTime cpuTime in - D.timed D.dump_gc msg action + D.timed D.dump_gc msg Nothing action diff --git a/Data/Array/Accelerate/CUDA/Array/Remote.hs b/Data/Array/Accelerate/CUDA/Array/Remote.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/Array/Remote.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.CUDA.Array.Remote +-- Copyright : [2015..2016] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell, Robert Clifton-Everest +-- License : BSD3 +-- +-- Maintainer : Robert Clifton-Everest +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.CUDA.Array.Remote ( + + -- Tables for host/device memory associations + MemoryTable, R.PrimElt, + new, malloc, withRemote, free, insertUnmanaged, reclaim + +) where + +import Control.Concurrent.MVar ( MVar, newMVar, withMVar, modifyMVar, readMVar ) +import Control.Exception +import Control.Monad.IO.Class ( MonadIO, liftIO ) +import Control.Monad.Trans.Reader +import Data.Functor +import Data.IntMap.Strict ( IntMap ) +import Data.Proxy +import Data.Typeable ( Typeable ) +import Foreign.Ptr ( ptrToIntPtr ) +import Foreign.Storable +import Prelude hiding ( lookup ) +import qualified Data.IntMap.Strict as IM + +import Foreign.CUDA.Driver.Error +import qualified Foreign.CUDA.Driver as CUDA + +import Data.Array.Accelerate.Array.Data +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Lifetime ( unsafeGetValue ) +import qualified Data.Array.Accelerate.Array.Remote as R + +import Data.Array.Accelerate.CUDA.Context ( Context(..), push, pop ) +import Data.Array.Accelerate.CUDA.Execute.Event ( Event, EventTable, waypoint, query ) +import Data.Array.Accelerate.CUDA.Execute.Stream ( Stream ) +import qualified Data.Array.Accelerate.CUDA.Debug as Debug + + +-- Instance for basic remote memory management functionality. +-- +type CRM = ReaderT (Maybe Stream) IO + +instance R.RemoteMemory CRM where + type RemotePtr CRM = CUDA.DevicePtr + -- + mallocRemote n = ReaderT $ \_ -> + fmap Just (CUDA.mallocArray n) + `catch` \e -> case e of + ExitCode OutOfMemory -> return Nothing + _ -> trace ("malloc failed with error: " ++ show e) (throwIO e) + + pokeRemote n dst ad = ReaderT $ \mst -> + transfer "poke" (n * sizeOfPtr dst) $ + CUDA.pokeArrayAsync n (CUDA.HostPtr (ptrsOfArrayData ad)) dst mst + + peekRemote n src ad = ReaderT $ \mst -> + transfer "peek" (n * sizeOfPtr src) $ + CUDA.peekArrayAsync n src (CUDA.HostPtr (ptrsOfArrayData ad)) mst + + castRemotePtr _ = CUDA.castDevPtr + totalRemoteMem = ReaderT $ \_ -> snd <$> CUDA.getMemInfo + availableRemoteMem = ReaderT $ \_ -> fst <$> CUDA.getMemInfo + remoteAllocationSize = return 1024 + + +-- We leverage the memory cache from the accelerate base package. +-- +-- However, we actually need multiple caches because every pointer has an +-- associated CUDA context. We could pair every DevicePtr with its context and +-- just have a single table, but the LRU implementation in the base package +-- assumes that remote pointers can be re-used, something that would not be true +-- for pointers allocated under different contexts. +-- +type MT = IntMap (R.MemoryTable CUDA.DevicePtr Task) +data MemoryTable = MemoryTable {-# UNPACK #-} !EventTable + {-# UNPACK #-} !(MVar MT) + +type Task = Maybe Event + +instance R.Task Task where + completed Nothing = return True + completed (Just e) = query e + + +-- Create a MemoryTable. +-- +new :: EventTable -> IO MemoryTable +new et = do + message "initialise CUDA memory table" + MemoryTable et <$> newMVar IM.empty + + +-- Perform action on the device ptr that matches the given host-side array. Any +-- operations +-- +withRemote + :: forall e a b. R.PrimElt e a + => Context + -> MemoryTable + -> ArrayData e + -> (CUDA.DevicePtr a -> IO b) + -> Maybe Stream + -> IO (Maybe b) +withRemote ctx (MemoryTable et ref) ad run ms = do + ct <- readMVar ref + case IM.lookup (contextId ctx) ct of + Nothing -> $internalError "withRemote" "context not found" + Just mc -> streaming ms $ R.withRemote mc ad run' + where + run' :: R.RemotePtr CRM a -> CRM (Task, b) + run' p = liftIO $ do + c <- run p + case ms of + Nothing -> return (Nothing, c) + Just s -> do + e <- waypoint ctx et s + return (Just e, c) + + +-- Allocate a new device array to be associated with the given host-side array. +-- Has the same properties as `Data.Array.Accelerate.Array.Remote.LRU.malloc` +malloc :: forall a b. (Typeable a, R.PrimElt a b) + => Context + -> MemoryTable + -> ArrayData a + -> Bool + -> Int + -> IO Bool +malloc !ctx (MemoryTable _ !ref) !ad !frozen !n = do + mt <- modifyMVar ref $ \ct -> blocking $ do + case IM.lookup (contextId ctx) ct of + Nothing -> trace "malloc/context not found" $ insertContext ctx ct + Just mt -> return (ct, mt) + blocking $ R.malloc mt ad frozen n + + +-- Explicitly free an array in the LRU table. Has the same properties as +-- `Data.Array.Accelerate.Array.Remote.LRU.free` +-- +free :: R.PrimElt a b + => Context + -> MemoryTable + -> ArrayData a + -> IO () +free !ctx (MemoryTable _ !ref) !arr = withMVar ref $ \ct -> + case IM.lookup (contextId ctx) ct of + Nothing -> message "free/context not found" + Just mt -> R.free (Proxy :: Proxy CRM) mt arr + + +-- Record an association between a host-side array and a device memory area that was +-- not allocated by accelerate. The device memory will NOT be freed by the memory +-- manager. +-- +insertUnmanaged + :: R.PrimElt a b + => Context + -> MemoryTable + -> ArrayData a + -> CUDA.DevicePtr b + -> IO () +insertUnmanaged !ctx (MemoryTable _ !ref) !arr !ptr = do + mt <- modifyMVar ref $ \ct -> blocking $ do + case IM.lookup (contextId ctx) ct of + Nothing -> trace "insertUnmanaged/context not found" $ insertContext ctx ct + Just mt -> return (ct, mt) + blocking $ R.insertUnmanaged mt arr ptr + +insertContext + :: Context + -> MT + -> CRM ( MT, R.MemoryTable CUDA.DevicePtr Task ) +insertContext ctx ct = liftIO $ do + mt <- R.new (\p -> bracket_ (push ctx) pop (CUDA.free p)) + return (IM.insert (contextId ctx) mt ct, mt) + + +-- Removing entries +-- ---------------- + +-- Initiate garbage collection and finalise any arrays that have been marked as +-- unreachable. +-- +reclaim :: MemoryTable -> IO () +reclaim (MemoryTable _ ref) = withMVar ref (blocking . mapM_ R.reclaim . IM.elems) + +-- Miscellaneous +-- ------------- + +{-# INLINE contextId #-} +contextId :: Context -> Int +contextId !ctx = + let CUDA.Context !p = unsafeGetValue (deviceContext ctx) + in fromIntegral (ptrToIntPtr p) + +{-# INLINE blocking #-} +blocking :: CRM a -> IO a +blocking = flip runReaderT Nothing + +{-# INLINE streaming #-} +streaming :: Maybe Stream -> CRM a -> IO a +streaming = flip runReaderT + +{-# INLINE sizeOfPtr #-} +sizeOfPtr :: forall a. Storable a => CUDA.DevicePtr a -> Int +sizeOfPtr _ = sizeOf (undefined :: a) + +-- Debug +-- ----- + +{-# INLINE trace #-} +trace :: MonadIO m => String -> m a -> m a +trace msg next = message msg >> next + +{-# INLINE message #-} +message :: MonadIO m => String -> m () +message msg = liftIO $ Debug.traceIO Debug.dump_gc ("gc/lru: " ++ msg) + +{-# INLINE showBytes #-} +showBytes :: Int -> String +showBytes x = Debug.showFFloatSIBase (Just 0) 1024 (fromIntegral x :: Double) "B" + +{-# INLINE transfer #-} +transfer :: String -> Int -> IO () -> IO () +transfer name bytes action + = let showRate x t = Debug.showFFloatSIBase (Just 3) 1024 (fromIntegral x / t) "B/s" + msg gpuTime cpuTime = "gc/lru: " ++ name ++ ": " + ++ showBytes bytes ++ " @ " ++ showRate bytes gpuTime ++ ", " + ++ Debug.elapsed gpuTime cpuTime + in + Debug.timed Debug.dump_gc msg Nothing action + diff --git a/Data/Array/Accelerate/CUDA/Array/Slice.hs b/Data/Array/Accelerate/CUDA/Array/Slice.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/Array/Slice.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE GADTs #-} +-- | +-- Module : Data.Array.Accelerate.Array.Slice +-- +-- Maintainer : Frederik Meisner Madsen +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.CUDA.Array.Slice ( + + transferDesc, blocksOf, + + TransferDesc(..) + +) where + +import Control.Arrow ( first ) +import Data.List ( groupBy, elemIndex ) +import Data.Array.Accelerate.Array.Representation ( SliceIndex(..) ) + + +-- Slicing algorithm. + +-- Figure out how to transfer a multi-dimensional slice from a +-- multi-dimensional array of the same or higher dimensionality to a +-- contiguous memory region. The algorithm uses as few data transfers +-- as possible, where a linear memory copy with a stride consitutes +-- one transfer (cudaMemcpy2d). Each transfer is described by four +-- numbers: A start, a stride, a number of basic blocks and block +-- size. +-- + +-- Memory transfer(s) description suitable for (multiple calls to) +-- cudaMemcpu2D. The number of calls necessary is given by the length +-- of the starting offsets. The unit is basic elements of the target +-- array. +data TransferDesc = + TransferDesc { starts :: [Int] -- Starting offsets. + , stride :: Int -- Stride. + , nblocks :: Int -- Number of blocks. + , blocksize :: Int } -- Elements per block. + deriving Show + +-- Get the basic blocks of the given transfer descriptions, described +-- as offset and length. This function can be used to do a memory copy +-- with only contiguous data transfers, if a strided transfer is not +-- available. +blocksOf :: TransferDesc -> [(Int, Int, Int)] +blocksOf tdesc = + [ ( start + i * stride tdesc + , i * blocksize tdesc + , blocksize tdesc) + | start <- starts tdesc + , i <- [0..nblocks tdesc-1]] + +-- A slice index in one dimension, annotated with information used to +-- catogorize how the dimension is transferred. +type SliceIR = ( TransferType -- Transfer type annotation. + , Int ) -- Size of this dimension. + +data TransferType = + Strided -- Transfer the entire dimension. Each element + -- will be transfered in a different block, but in + -- a single transfer. + + | Contiguous -- Transfer the entire dimension in one + -- contiguous data transfer. Each element will + -- be transfered in the same block in the same + -- transfer. + + | Fixed Int -- Transfer a specific element in this + -- dimension. The argument is the element index. + + | FixedAll -- Transfer the entire dimension. Each element + -- will be transfered in a seperate data + -- transfer. + +-- Convert a slice index to internal representation used by this +-- algorithm. Initially, all dimensions are represented as strided +-- (transfer entire dimension) or fixed (transfer specific element). + +toIR :: SliceIndex slix sl co dim + -> slix + -> dim + -> [SliceIR] +toIR SliceNil () () = [] +toIR (SliceAll si) (sl, ()) (sh, n) = (Strided, n):toIR si sl sh +toIR (SliceFixed si) (sl, i ) (sh, n) = (Fixed i, n):toIR si sl sh +{- +toIR :: SliceIndex slix sl co dim + -> slix + -> dim + -> [SliceIR] +toIR slix sl dim = + f slix sl dim [] + where + f :: SliceIndex slix' sl' co' dim' + -> slix' + -> dim' + -> [SliceIR] + -> [SliceIR] + f SliceNil () () res = res + f (SliceAll si) (sl, ()) (sh, n) res = f si sl sh ((Strided, n):res) + f (SliceFixed si) (sl, i ) (sh, n) res = f si sl sh ((Fixed i, n):res) +-} + +-- Promote strided slice indices to contiguous slice indices when +-- possible (= all strided innermost dimensions). +strideToContiguous :: [SliceIR] -> [SliceIR] +strideToContiguous slirs = + let (strided, rest) = span (isStrided . fst) slirs + conti = map (first promote) strided + in conti ++ rest + where + isStrided Strided = True + isStrided _ = False + + promote Strided = Contiguous + promote x = x + +-- Find largest group (= next to each other) of strided slice +-- indices. Promote all other strided groups to fixed groups, which +-- entails multiple data transfers in these dimensions. This is +-- necessary step, since it is impossible to describe the memory +-- transfer with the given transfer description type in some +-- situations (namely when there is a gap between strided +-- dimensions). This step chooses the split that results in fewest +-- possible data transfers by selecting the largest stride pivot. +selectStridePivot :: [SliceIR] -> [SliceIR] +selectStridePivot slirs = + let -- Group the slice dimensions in groups of same transfer types. + groups = groupBy sameTransferType slirs + + -- Calculate the sizes of the strided groups, ignore the rest. + sizes = map (product . map stridedSize) groups + + -- Find the largest strided group. + Just imax = elemIndex (maximum sizes) sizes + + -- Promote the remaining strided groups to fixed groups using + -- multiple data transfers. + (groups1, pivotGroup:groups2) = splitAt imax groups + + groups' = map (map (first promote)) groups1 ++ pivotGroup:map (map (first promote)) groups2 + + in concat groups' + where + sameTransferType :: SliceIR -> SliceIR -> Bool + sameTransferType x y = fst x ~= fst y + where + (~=) :: TransferType -> TransferType -> Bool + Contiguous ~= Contiguous = True + Strided ~= Strided = True + Fixed _ ~= Fixed _ = True + FixedAll ~= FixedAll = True + _ ~= _ = False + + promote :: TransferType -> TransferType + promote Strided = FixedAll + promote x = x + + stridedSize :: SliceIR -> Int + stridedSize (Strided, n) = n + stridedSize _ = 0 + +-- Compute a description of the transfers necessary to copy the +-- specified slice. +transferDesc :: SliceIndex slix sl co dim + -> slix -- Slice index. + -> dim -- Full shape. + -> TransferDesc +transferDesc slix sl dim = + let slirs = selectStridePivot $ strideToContiguous $ toIR slix sl dim + tdesc0 = TransferDesc [0] 1 1 1 + size0 = 1 + in f slirs size0 tdesc0 + where + f :: [SliceIR] -> Int -> TransferDesc -> TransferDesc + f slirs m tdesc = + case slirs of + [] -> tdesc + + (ttyp, n):slirs' -> f slirs' (n * m) $ + case ttyp of + Strided -> + TransferDesc + { starts = starts tdesc + , stride = if stride tdesc == 1 then m else stride tdesc + , nblocks = n * nblocks tdesc + , blocksize = blocksize tdesc } + + Contiguous -> + TransferDesc + { starts = starts tdesc + , stride = stride tdesc + , nblocks = nblocks tdesc + , blocksize = n * blocksize tdesc } + + Fixed i -> + TransferDesc + { starts = [start + i * m | start <- starts tdesc] + , stride = stride tdesc + , nblocks = nblocks tdesc + , blocksize = blocksize tdesc } + + FixedAll -> + TransferDesc + { starts = [start + i * m | start <- starts tdesc, i <- [0..n-1]] + , stride = stride tdesc + , nblocks = nblocks tdesc + , blocksize = blocksize tdesc } diff --git a/Data/Array/Accelerate/CUDA/Array/Sugar.hs b/Data/Array/Accelerate/CUDA/Array/Sugar.hs --- a/Data/Array/Accelerate/CUDA/Array/Sugar.hs +++ b/Data/Array/Accelerate/CUDA/Array/Sugar.hs @@ -1,7 +1,7 @@ -- | -- Module : Data.Array.Accelerate.CUDA.Array.Sugar --- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller +-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell @@ -12,22 +12,24 @@ module Data.Array.Accelerate.CUDA.Array.Sugar ( module Data.Array.Accelerate.Array.Sugar, - newArray, allocateArray, useArray, useArrayAsync, + fromFunction, allocateArray, useArray, useArrayAsync, ) where +import Control.Monad.Trans + import Data.Array.Accelerate.CUDA.State import Data.Array.Accelerate.CUDA.Array.Data -import Data.Array.Accelerate.Array.Sugar hiding (newArray, allocateArray) +import Data.Array.Accelerate.Array.Sugar hiding ( fromFunction, allocateArray ) import qualified Data.Array.Accelerate.Array.Sugar as Sugar -- Create an array from its representation function, uploading the result to the -- device -- -newArray :: (Shape sh, Elt e) => sh -> (sh -> e) -> CIO (Array sh e) -newArray sh f = - let arr = Sugar.newArray sh f +fromFunction :: (Shape sh, Elt e) => sh -> (sh -> e) -> CIO (Array sh e) +fromFunction sh f = + let arr = Sugar.fromFunction sh f in do useArray arr return arr @@ -36,9 +38,8 @@ -- Allocate a new, uninitialised Accelerate array on host and device -- allocateArray :: (Shape dim, Elt e) => dim -> CIO (Array dim e) -allocateArray sh = - let arr = Sugar.allocateArray sh - in do - mallocArray arr - return arr +allocateArray sh = do + arr <- liftIO $ Sugar.allocateArray sh + mallocArray arr + return arr diff --git a/Data/Array/Accelerate/CUDA/Array/Table.hs b/Data/Array/Accelerate/CUDA/Array/Table.hs deleted file mode 100644 --- a/Data/Array/Accelerate/CUDA/Array/Table.hs +++ /dev/null @@ -1,291 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | --- Module : Data.Array.Accelerate.CUDA.Array.Table --- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.CUDA.Array.Table ( - - -- Tables for host/device memory associations - MemoryTable, new, lookup, malloc, insert, insertRemote, reclaim - -) where - -import Prelude hiding ( lookup ) -import Data.Maybe ( isJust ) -import Data.Hashable ( Hashable(..) ) -import Data.Typeable ( Typeable, gcast ) -import Control.Monad ( unless ) -import Control.Concurrent ( yield ) -import Control.Concurrent.MVar ( MVar, newMVar, withMVar, mkWeakMVar ) -import Control.Exception ( bracket_, catch, throwIO ) -import Control.Applicative ( (<$>) ) -import System.Mem ( performGC ) -import System.Mem.Weak ( Weak, mkWeak, deRefWeak, finalize ) -import System.Mem.StableName ( StableName, makeStableName, hashStableName ) -import Foreign.Ptr ( ptrToIntPtr ) -import Foreign.Storable ( Storable, sizeOf ) -import Foreign.CUDA.Ptr ( DevicePtr ) - -import Foreign.CUDA.Driver.Error -import qualified Foreign.CUDA.Driver as CUDA -import qualified Data.HashTable.IO as HT - -import Data.Array.Accelerate.Array.Data ( ArrayData ) -import Data.Array.Accelerate.CUDA.Context ( Context, weakContext, deviceContext ) -import Data.Array.Accelerate.CUDA.Array.Nursery ( Nursery(..), NRS ) -import qualified Data.Array.Accelerate.CUDA.Array.Nursery as N -import qualified Data.Array.Accelerate.CUDA.Debug as D - -#include "accelerate.h" - - --- We use an MVar to the hash table, so that several threads may safely access --- it concurrently. This includes the finalisation threads that remove entries --- from the table. --- --- It is important that we can garbage collect old entries from the table when --- the key is no longer reachable in the heap. Hence the value part of each --- table entry is a (Weak val), where the stable name 'key' is the key for the --- memo table, and the 'val' is the value of this table entry. When the key --- becomes unreachable, a finaliser will fire and remove this entry from the --- hash buckets, and further attempts to dereference the weak pointer will --- return Nothing. References from 'val' to the key are ignored (see the --- semantics of weak pointers in the documentation). --- -type HashTable key val = HT.BasicHashTable key val -type MT = MVar ( HashTable HostArray DeviceArray ) -data MemoryTable = MemoryTable {-# UNPACK #-} !MT - {-# UNPACK #-} !(Weak MT) - {-# UNPACK #-} !Nursery - --- Arrays on the host and device --- -type ContextId = Int - -data HostArray where - HostArray :: Typeable e - => {-# UNPACK #-} !ContextId -- unique ID relating to the parent context - -> {-# UNPACK #-} !(StableName (ArrayData e)) - -> HostArray - -data DeviceArray where - DeviceArray :: Typeable e - => {-# UNPACK #-} !(Weak (DevicePtr e)) - -> DeviceArray - -instance Eq HostArray where - HostArray _ a1 == HostArray _ a2 - = maybe False (== a2) (gcast a1) - -instance Hashable HostArray where - {-# INLINE hashWithSalt #-} - hashWithSalt salt (HostArray cid sn) - = salt `hashWithSalt` cid `hashWithSalt` sn - -instance Show HostArray where - show (HostArray _ sn) = "Array #" ++ show (hashStableName sn) - - --- Referencing arrays --- ------------------ - --- Create a new hash table from host to device arrays. When the structure is --- collected it will finalise all entries in the table. --- -new :: IO MemoryTable -new = do - message "initialise memory table" - tbl <- HT.new - ref <- newMVar tbl - nrs <- N.new - weak <- mkWeakMVar ref (table_finalizer tbl) - return $! MemoryTable ref weak nrs - - --- Look for the device memory corresponding to a given host-side array. --- -lookup :: (Typeable a, Typeable b) => Context -> MemoryTable -> ArrayData a -> IO (Maybe (DevicePtr b)) -lookup ctx (MemoryTable !ref _ _) !arr = do - sa <- makeStableArray ctx arr - mw <- withMVar ref (`HT.lookup` sa) - case mw of - Nothing -> trace ("lookup/not found: " ++ show sa) $ return Nothing - Just (DeviceArray w) -> do - mv <- deRefWeak w - case mv of - Just v | Just p <- gcast v -> trace ("lookup/found: " ++ show sa) $ return (Just p) - | otherwise -> INTERNAL_ERROR(error) "lookup" $ "type mismatch" - - -- Note: [Weak pointer weirdness] - -- - -- After the lookup is successful, there might conceivably be no further - -- references to 'arr'. If that is so, and a garbage collection - -- intervenes, the weak pointer might get tombstoned before 'deRefWeak' - -- gets to it. In that case we throw an error (below). However, because - -- we have used 'arr' in the continuation, this ensures that 'arr' is - -- reachable in the continuation of 'deRefWeak' and thus 'deRefWeak' - -- always succeeds. This sort of weirdness, typical of the world of weak - -- pointers, is why we can not reuse the stable name 'sa' computed - -- above in the error message. - -- - Nothing -> - makeStableArray ctx arr >>= \x -> INTERNAL_ERROR(error) "lookup" $ "dead weak pair: " ++ show x - - --- Allocate a new device array to be associated with the given host-side array. --- This will attempt to use an old array from the nursery, but will otherwise --- allocate fresh data. --- --- Instead of allocating the exact number of elements requested, we round up to --- a fixed chunk size; currently set at 128 elements. This means there is a --- greater chance the nursery will get a hit, and moreover that we can search --- the nursery for an exact size. TLM: I believe the CUDA API allocates in --- chunks, of size 4MB. --- -malloc :: forall a b. (Typeable a, Typeable b, Storable b) => Context -> MemoryTable -> ArrayData a -> Int -> IO (DevicePtr b) -malloc !ctx mt@(MemoryTable _ _ !nursery) !ad !n = do - let -- next highest multiple of f from x - multiple x f = floor ((x + (f-1)) / f :: Double) - chunk = 128 - - !n' = chunk * multiple (fromIntegral n) (fromIntegral chunk) - !bytes = n' * sizeOf (undefined :: b) - -- - mp <- N.malloc bytes (deviceContext ctx) nursery - ptr <- case mp of - Just p -> trace "malloc/nursery" $ return (CUDA.castDevPtr p) - Nothing -> trace "malloc/new" $ - CUDA.mallocArray n' `catch` \(e :: CUDAException) -> - case e of - ExitCode OutOfMemory -> reclaim mt >> CUDA.mallocArray n' - _ -> throwIO e - insert ctx mt ad ptr bytes - return ptr - - --- Record an association between a host-side array and a new device memory area. --- The device memory will be freed when the host array is garbage collected. --- -insert :: (Typeable a, Typeable b) => Context -> MemoryTable -> ArrayData a -> DevicePtr b -> Int -> IO () -insert !ctx (MemoryTable !ref !weak_ref (Nursery _ !weak_nrs)) !arr !ptr !bytes = do - key <- makeStableArray ctx arr - dev <- DeviceArray `fmap` mkWeak arr ptr (Just $ finalizer (weakContext ctx) weak_ref weak_nrs key ptr bytes) - message $ "insert: " ++ show key - withMVar ref $ \tbl -> HT.insert tbl key dev - - --- Record an association between a host-side array and a device memory area that was --- not allocated by accelerate. The device memory will NOT be freed when the host --- array is garbage collected. --- -insertRemote :: (Typeable a, Typeable b) => Context -> MemoryTable -> ArrayData a -> DevicePtr b -> IO () -insertRemote !ctx (MemoryTable !ref !weak_ref _) !arr !ptr = do - key <- makeStableArray ctx arr - dev <- DeviceArray `fmap` mkWeak arr ptr (Just $ remoteFinalizer weak_ref key) - message $ "insert/remote: " ++ show key - withMVar ref $ \tbl -> HT.insert tbl key dev - - --- Removing entries --- ---------------- - --- Initiate garbage collection and finalise any arrays that have been marked as --- unreachable. --- -reclaim :: MemoryTable -> IO () -reclaim (MemoryTable _ weak_ref (Nursery nrs _)) = do - (free, total) <- CUDA.getMemInfo - performGC - yield - withMVar nrs N.flush - mr <- deRefWeak weak_ref - case mr of - Nothing -> return () - Just ref -> withMVar ref $ \tbl -> - flip HT.mapM_ tbl $ \(_,DeviceArray w) -> do - alive <- isJust `fmap` deRefWeak w - unless alive $ finalize w - -- - D.when D.dump_gc $ do - (free', _) <- CUDA.getMemInfo - message $ "reclaim: freed " ++ showBytes (fromIntegral (free - free')) - ++ ", " ++ showBytes (fromIntegral free') - ++ " of " ++ showBytes (fromIntegral total) ++ " remaining" - --- Because a finaliser might run at any time, we must reinstate the context in --- which the array was allocated before attempting to release it. --- --- Note also that finaliser threads will silently terminate if an exception is --- raised. If the context, and thereby all allocated memory, was destroyed --- externally before the thread had a chance to run, all we need do is update --- the hash tables --- but we must do this first before failing to use a dead --- context. --- -finalizer :: Weak CUDA.Context -> Weak MT -> Weak NRS -> HostArray -> DevicePtr b -> Int -> IO () -finalizer !weak_ctx !weak_ref !weak_nrs !key !ptr !bytes = do - mr <- deRefWeak weak_ref - case mr of - Nothing -> message ("finalise/dead table: " ++ show key) - Just ref -> withMVar ref (`HT.delete` key) - -- - mc <- deRefWeak weak_ctx - case mc of - Nothing -> message ("finalise/dead context: " ++ show key) - Just ctx -> do - -- - mn <- deRefWeak weak_nrs - case mn of - Nothing -> trace ("finalise/free: " ++ show key) $ bracket_ (CUDA.push ctx) CUDA.pop (CUDA.free ptr) - Just nrs -> trace ("finalise/nursery: " ++ show key) $ N.stash bytes ctx nrs ptr - -remoteFinalizer :: Weak MT -> HostArray -> IO () -remoteFinalizer !weak_ref !key = do - mr <- deRefWeak weak_ref - case mr of - Nothing -> message ("finalise/dead table: " ++ show key) - Just ref -> trace ("finalise: " ++ show key) $ withMVar ref (`HT.delete` key) - -table_finalizer :: HashTable HostArray DeviceArray -> IO () -table_finalizer !tbl - = trace "table finaliser" - $ HT.mapM_ (\(_,DeviceArray w) -> finalize w) tbl - - --- Miscellaneous --- ------------- - -{-# INLINE makeStableArray #-} -makeStableArray :: Typeable a => Context -> ArrayData a -> IO HostArray -makeStableArray !ctx !arr = - let CUDA.Context !p = deviceContext ctx - !cid = fromIntegral (ptrToIntPtr p) - in - HostArray cid <$> makeStableName arr - - --- Debug --- ----- - -{-# INLINE showBytes #-} -showBytes :: Int -> String -showBytes x = D.showFFloatSIBase (Just 0) 1024 (fromIntegral x :: Double) "B" - -{-# INLINE trace #-} -trace :: String -> IO a -> IO a -trace msg next = D.message D.dump_gc ("gc: " ++ msg) >> next - -{-# INLINE message #-} -message :: String -> IO () -message s = s `trace` return () - diff --git a/Data/Array/Accelerate/CUDA/Async.hs b/Data/Array/Accelerate/CUDA/Async.hs deleted file mode 100644 --- a/Data/Array/Accelerate/CUDA/Async.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE CPP #-} --- | --- Module : Data.Array.Accelerate.CUDA.Async --- Copyright : [2009..2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.CUDA.Async - where - -import Control.Exception -import Control.Concurrent - - --- We need to execute the main thread asynchronously to give finalisers a chance --- to run. Make sure to catch exceptions to avoid "blocked indefinitely on MVar" --- errors. --- -data Async a = Async {-# UNPACK #-} !ThreadId - {-# UNPACK #-} !(MVar (Either SomeException a)) - --- | Fork an action to execute asynchronously. --- -async :: IO a -> IO (Async a) -async action = do - var <- newEmptyMVar - tid <- forkIO $ (putMVar var . Right =<< action) - `catch` - \e -> putMVar var (Left e) - return (Async tid var) - --- | Block the calling thread until the computation completes, then return the --- result. --- -{-# INLINE wait #-} -wait :: Async a -> IO a -wait (Async _ var) = either throwIO return =<< readMVar var - --- | Test whether the asynchronous computation has already completed. If so, --- return the result, else 'Nothing'. --- -{-# INLINE poll #-} -poll :: Async a -> IO (Maybe a) -poll (Async _ var) = - maybe (return Nothing) (either throwIO (return . Just)) =<< tryTakeMVar var - --- | Cancel a running asynchronous computation. --- -{-# INLINE cancel #-} -cancel :: Async a -> IO () -cancel (Async tid _) = throwTo tid ThreadKilled - diff --git a/Data/Array/Accelerate/CUDA/CodeGen.hs b/Data/Array/Accelerate/CUDA/CodeGen.hs --- a/Data/Array/Accelerate/CUDA/CodeGen.hs +++ b/Data/Array/Accelerate/CUDA/CodeGen.hs @@ -1,14 +1,15 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS -fno-warn-name-shadowing #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen --- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller +-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell @@ -18,34 +19,35 @@ module Data.Array.Accelerate.CUDA.CodeGen ( - CUTranslSkel, codegenAcc, + CUTranslSkel, codegenAcc, codegenToSeq ) where -- libraries -import Prelude hiding ( id, exp, replicate ) -import Control.Applicative ( (<$>), (<*>) ) -import Control.Monad.State.Strict -import Data.Loc -import Data.Char import Data.HashSet ( HashSet ) +import Control.Monad.State.Strict import Foreign.CUDA.Analysis import Language.C.Quote.CUDA import qualified Language.C as C import qualified Data.HashSet as Set +import Control.Applicative hiding ( Const ) +import Prelude hiding ( id, exp, replicate ) -- friends +import Data.Array.Accelerate.Error import Data.Array.Accelerate.Type -import Data.Array.Accelerate.Tuple +import Data.Array.Accelerate.Product import Data.Array.Accelerate.Trafo import Data.Array.Accelerate.Pretty () import Data.Array.Accelerate.Analysis.Shape -import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt, EltRepr ) +import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt, EltRepr + , Tuple(..), TupleRepr ) import Data.Array.Accelerate.Array.Representation ( SliceIndex(..) ) import qualified Data.Array.Accelerate.Array.Sugar as Sugar import qualified Data.Array.Accelerate.Analysis.Type as Sugar import Data.Array.Accelerate.CUDA.AST hiding ( Val(..), prj ) +import Data.Array.Accelerate.CUDA.CodeGen.Constant import Data.Array.Accelerate.CUDA.CodeGen.Base import Data.Array.Accelerate.CUDA.CodeGen.Type import Data.Array.Accelerate.CUDA.CodeGen.Monad @@ -54,9 +56,9 @@ import Data.Array.Accelerate.CUDA.CodeGen.PrefixSum import Data.Array.Accelerate.CUDA.CodeGen.Reduction import Data.Array.Accelerate.CUDA.CodeGen.Stencil +import Data.Array.Accelerate.CUDA.CodeGen.Streaming import Data.Array.Accelerate.CUDA.Foreign.Import ( canExecuteExp ) - -#include "accelerate.h" +import qualified Data.Array.Accelerate.CUDA.CodeGen.Arithmetic as A -- Local environments @@ -68,7 +70,7 @@ prj :: Idx env t -> Val env -> [C.Exp] prj ZeroIdx (Push _ v) = v prj (SuccIdx ix) (Push val _) = prj ix val -prj _ _ = INTERNAL_ERROR(error) "prj" "inconsistent valuation" +prj _ _ = $internalError "prj" "inconsistent valuation" -- Array expressions @@ -87,7 +89,7 @@ -- TODO: include a measure of how much shared memory a kernel requires. -- codegenAcc :: forall aenv arrs. DeviceProperties -> DelayedOpenAcc aenv arrs -> Gamma aenv -> [ CUTranslSkel aenv arrs ] -codegenAcc _ Delayed{} _ = INTERNAL_ERROR(error) "codegenAcc" "expected manifest array" +codegenAcc _ Delayed{} _ = $internalError "codegenAcc" "expected manifest array" codegenAcc dev (Manifest pacc) aenv = codegen $ case pacc of @@ -113,6 +115,9 @@ Stencil f b a -> mkStencil dev aenv <$> travF1 f <*> travB a b Stencil2 f b1 a1 b2 a2 -> mkStencil2 dev aenv <$> travF2 f <*> travB a1 b1 <*> travB a2 b2 + -- Sequence collection + -- Collect _ -> unexpectedError + -- Non-computation forms -> sadness Alet{} -> unexpectedError Avar{} -> unexpectedError @@ -144,7 +149,7 @@ -- code generation for delayed arrays travD :: (Shape sh, Elt e) => DelayedOpenAcc aenv (Array sh e) -> CUDA (CUDelayedAcc aenv sh e) - travD Manifest{} = INTERNAL_ERROR(error) "codegenAcc" "expected delayed array" + travD Manifest{} = $internalError "codegenAcc" "expected delayed array" travD Delayed{..} = CUDelayed <$> travE extentD <*> travF1 indexD <*> travF1 linearIndexD @@ -164,15 +169,47 @@ travB _ Clamp = return Clamp travB _ Mirror = return Mirror travB _ Wrap = return Wrap - travB _ (Constant c) = return . Constant $ CUExp ([], codegenConst (Sugar.eltType (undefined::e)) c) + travB _ (Constant c) = return . Constant $ CUExp ([], constant (Sugar.eltType (undefined::e)) c) -- caffeine and misery prim :: String prim = showPreAccOp pacc - unexpectedError = INTERNAL_ERROR(error) "codegenAcc" $ "unexpected array primitive: " ++ prim - fusionError = INTERNAL_ERROR(error) "codegenAcc" $ "unexpected fusible material: " ++ prim + unexpectedError = $internalError "codegenAcc" $ "unexpected array primitive: " ++ prim + fusionError = $internalError "codegenAcc" $ "unexpected fusible material: " ++ prim +codegenToSeq :: forall aenv slix sl co sh e. (Shape sl, Shape sh, Elt e) + => SliceIndex slix + (EltRepr sl) + co + (EltRepr sh) + -> DeviceProperties + -> DelayedOpenAcc aenv (Array sh e) + -> Gamma aenv + -> CUTranslSkel aenv (Array sl e) +codegenToSeq slix dev acc aenv = codegen $ (mkToSeq slix dev aenv <$> travD acc) + where + codegen :: CUDA (CUTranslSkel aenv (Array sl e)) -> CUTranslSkel aenv (Array sl e) + codegen cuda = + let (skeleton, st) = runCUDA cuda + addTo (CUTranslSkel name code) = + CUTranslSkel name (Set.foldr (\h c -> [cedecl| $esc:("#include \"" ++ h ++ "\"") |] : c) code (headers st)) + in + addTo skeleton + -- code generation for delayed arrays + travD :: (Shape sh, Elt e) => DelayedOpenAcc aenv (Array sh e) -> CUDA (CUDelayedAcc aenv sh e ) + travD Manifest{} = $internalError "codegenAcc" "expected delayed array" + travD Delayed{..} = CUDelayed <$> travE extentD + <*> travF1 indexD + <*> travF1 linearIndexD + + travE :: forall t. DelayedExp aenv t -> CUDA (CUExp aenv t) + travE = codegenExp dev aenv + + travF1 :: forall a b. DelayedFun aenv (a -> b) -> CUDA (CUFun1 aenv (a -> b)) + travF1 = codegenFun1 dev aenv + + -- Scalar function abstraction -- --------------------------- @@ -214,7 +251,7 @@ $ \xs -> evalState (evalCGM (go xs)) n -- | otherwise - = INTERNAL_ERROR(error) "codegenFun1" "expected unary function" + = $internalError "codegenFun1" "expected unary function" codegenFun2 @@ -240,7 +277,7 @@ $ \xs ys -> evalState (evalCGM (go xs ys)) n -- | otherwise - = INTERNAL_ERROR(error) "codegenFun2" "expected binary function" + = $internalError "codegenFun2" "expected binary function" -- It is important to filter output terms of a function that will not be used. @@ -314,9 +351,9 @@ case exp of Let bnd body -> elet bnd body env Var ix -> return $ prj ix env - PrimConst c -> return $ [codegenPrimConst c] - Const c -> return $ codegenConst (Sugar.eltType (undefined::t)) c - PrimApp f arg -> return . codegenPrim f <$> cvtE arg env + PrimConst c -> return $ [primConst c] + Const c -> return $ constant (Sugar.eltType (undefined::t)) c + PrimApp f x -> primApp f x env Tuple t -> cvtT t env Prj i t -> prjT i t exp env Cond p t e -> cond p t e env @@ -339,6 +376,7 @@ Shape acc -> shape acc env ShapeSize sh -> shapeSize sh env Intersect sh1 sh2 -> intersect sh1 sh2 env + Union sh1 sh2 -> union sh1 sh2 env --Foreign function Foreign ff _ e -> foreignE ff e env @@ -361,6 +399,119 @@ body' <- cvtE body (env `Push` bnd') return body' + -- When evaluating primitive functions, we evaluate each argument to the + -- operation as a statement expression. This is necessary to ensure proper + -- short-circuit behaviour for logical operations. + -- + primApp :: PrimFun (a -> b) -> DelayedOpenExp env aenv a -> Val env -> Gen [C.Exp] + primApp f x env = + case f of + -- operators from Num + PrimAdd{} -> binary A.add x env + PrimSub{} -> binary A.sub x env + PrimMul{} -> binary A.mul x env + PrimNeg{} -> unary A.negate x env + PrimAbs ty -> unary (A.abs ty) x env + PrimSig ty -> unaryM (A.signum ty) x env + -- operators from Integral & Bits + PrimQuot{} -> binary A.quot x env + PrimRem{} -> binary A.rem x env + PrimQuotRem ty -> binaryM2 (A.quotRem ty) x env + PrimIDiv ty -> binaryM (A.idiv ty) x env + PrimMod ty -> binaryM (A.mod ty) x env + PrimDivMod ty -> binaryM2 (A.divMod ty) x env + PrimBAnd{} -> binary A.band x env + PrimBOr{} -> binary A.bor x env + PrimBXor{} -> binary A.xor x env + PrimBNot{} -> unary A.bnot x env + PrimBShiftL{} -> binary A.shiftL x env + PrimBShiftR{} -> binary A.shiftRA x env + PrimBRotateL ty -> binaryM (A.rotateL ty) x env + PrimBRotateR ty -> binaryM (A.rotateR ty) x env + -- operators from Fractional and Floating + PrimFDiv{} -> binary A.fdiv x env + PrimRecip ty -> unary (A.recip ty) x env + PrimSin ty -> unary (A.sin ty) x env + PrimCos ty -> unary (A.cos ty) x env + PrimTan ty -> unary (A.tan ty) x env + PrimAsin ty -> unary (A.asin ty) x env + PrimAcos ty -> unary (A.acos ty) x env + PrimAtan ty -> unary (A.atan ty) x env + PrimSinh ty -> unary (A.sinh ty) x env + PrimCosh ty -> unary (A.cosh ty) x env + PrimTanh ty -> unary (A.tanh ty) x env + PrimAsinh ty -> unary (A.asinh ty) x env + PrimAcosh ty -> unary (A.acosh ty) x env + PrimAtanh ty -> unary (A.atanh ty) x env + PrimExpFloating ty -> unary (A.exp ty) x env + PrimSqrt ty -> unary (A.sqrt ty) x env + PrimLog ty -> unary (A.log ty) x env + PrimFPow ty -> binary (A.pow ty) x env + PrimLogBase ty -> binary (A.logBase ty) x env + -- operators from RealFrac + PrimTruncate ta tb -> unary (A.trunc ta tb) x env + PrimRound ta tb -> unary (A.round ta tb) x env + PrimFloor ta tb -> unary (A.floor ta tb) x env + PrimCeiling ta tb -> unary (A.ceiling ta tb) x env + -- operators from RealFloat + PrimAtan2 ty -> binary (A.atan2 ty) x env + PrimIsNaN{} -> unary A.isNaN x env + -- relational and equality operators + PrimLt{} -> binary A.lt x env + PrimGt{} -> binary A.gt x env + PrimLtEq{} -> binary A.leq x env + PrimGtEq{} -> binary A.geq x env + PrimEq{} -> binary A.eq x env + PrimNEq{} -> binary A.neq x env + PrimMax ty -> binary (A.max ty) x env + PrimMin ty -> binary (A.min ty) x env + -- logical operators + PrimLAnd -> binary A.land x env + PrimLOr -> binary A.lor x env + PrimLNot -> unary A.lnot x env + -- type conversions + PrimOrd -> unary A.ord x env + PrimChr -> unary A.chr x env + PrimBoolToInt -> unary A.boolToInt x env + PrimFromIntegral ta tb -> unary (A.fromIntegral ta tb) x env + where + cvtE' :: DelayedOpenExp env aenv a -> Val env -> Gen C.Exp + cvtE' e env = do + (b,r) <- clean $ single "primApp" <$> cvtE e env + if null b + then return r + else return [cexp| ({ $items:b; $exp:r; }) |] + + -- TLM: This is a bit ugly. Consider making all primitive functions from + -- Arithmetic.hs evaluate in the Gen monad. + -- + unary :: (C.Exp -> C.Exp) -> DelayedOpenExp env aenv a -> Val env -> Gen [C.Exp] + unary f = unaryM (return . f) + + unaryM :: (C.Exp -> Gen C.Exp) -> DelayedOpenExp env aenv a -> Val env -> Gen [C.Exp] + unaryM f a env = do + a' <- cvtE' a env + r <- f a' + return [r] + + binary :: (C.Exp -> C.Exp -> C.Exp) -> DelayedOpenExp env aenv (a,b) -> Val env -> Gen [C.Exp] + binary f = binaryM (\a b -> return (f a b)) + + binaryM :: (C.Exp -> C.Exp -> Gen C.Exp) -> DelayedOpenExp env aenv (a,b) -> Val env -> Gen [C.Exp] + binaryM f x env = do + x' <- cvtE x env + case x' of + [a,b] -> return <$> f a b + _ -> $internalError "primApp" "unexpected argument to binary function" + + binaryM2 :: (C.Exp -> C.Exp -> Gen (C.Exp, C.Exp)) -> DelayedOpenExp env aenv (a,b) -> Val env -> Gen [C.Exp] + binaryM2 f x env = do + x' <- cvtE x env + case x' of + [a,b] -> do (r,s) <- f a b + return [r,s] + _ -> $internalError "primApp" "unexpected argument to binary function" + -- Convert an open expression into a sequence of C expressions. We retain -- snoc-list ordering, so the element at tuple index zero is at the end of -- the list. Note that nested tuple structures are flattened. @@ -395,27 +546,46 @@ prjToInt :: TupleIdx t e -> TupleType a -> Int prjToInt ZeroTupIdx _ = 0 prjToInt (SuccTupIdx i) (b `PairTuple` a) = sizeTupleType a + prjToInt i b - prjToInt _ _ = INTERNAL_ERROR(error) "prjToInt" "inconsistent valuation" + prjToInt _ _ = $internalError "prjToInt" "inconsistent valuation" sizeTupleType :: TupleType a -> Int sizeTupleType UnitTuple = 0 sizeTupleType (SingleTuple _) = 1 sizeTupleType (PairTuple a b) = sizeTupleType a + sizeTupleType b - -- Scalar conditionals. To keep the return type as an expression list we use - -- the ternery C condition operator (?:). For tuples this is not - -- particularly good, so the least we can do is make sure the predicate - -- result is evaluated only once and bound to a local variable. + -- Scalar conditionals insert a standard if/else statement block. We don't + -- use the ternary expression operator (?:) because this forces all + -- auxiliary bindings for both the true and false branches to always be + -- evaluated before the correct result is chosen. -- - cond :: DelayedOpenExp env aenv Bool + cond :: forall env t. Elt t + => DelayedOpenExp env aenv Bool -> DelayedOpenExp env aenv t -> DelayedOpenExp env aenv t - -> Val env -> Gen [C.Exp] - cond p t e env = do + -> Val env + -> Gen [C.Exp] + cond p t f env = do p' <- cvtE p env ok <- single "Cond" <$> pushEnv p p' - zipWith (\a b -> [cexp| $exp:ok ? $exp:a : $exp:b |]) <$> cvtE t env <*> cvtE e env + ifTrue <- clean $ cvtE t env + ifFalse <- clean $ cvtE f env + -- Generate names for the result variables, which will be initialised + -- within each branch of the conditional. Twiddle the names a bit to + -- avoid clobbering. + var_r <- lift fresh + let (_, r, declr) = locals ('l':var_r) (undefined :: t) + branch = [citem| if ( $exp:ok ) { + $items:(r .=. ifTrue) + } + else { + $items:(r .=. ifFalse) + } |] + : map C.BlockDecl declr + + modify (\s -> s { localBindings = branch ++ localBindings s }) + return r + -- Value recursion -- while :: forall env a. Elt a @@ -435,9 +605,11 @@ x' <- cvtE x env var_acc <- lift fresh var_ok <- lift fresh + var_tmp <- lift fresh - let (tn_acc, acc, _) = locals ('l':var_acc) (undefined :: a) - (tn_ok, ok, _) = locals ('l':var_ok) (undefined :: Bool) + let (_, acc, decl_acc) = locals ('l':var_acc) (undefined :: a) + (_, ok, decl_ok) = locals ('l':var_ok) (undefined :: Bool) + (tmp, _, _) = locals ('l':var_tmp) (undefined :: a) -- Generate code for the predicate and body expressions, with the new -- names baked in directly. We can't use 'codegenFun1', because @@ -446,25 +618,24 @@ -- However, we do need to generate the function with a clean set of -- local bindings, and extract and new declarations afterwards. -- - let cvtF :: forall env t. Elt t => DelayedOpenExp env aenv t -> Val env -> Gen ([C.BlockItem], [C.Exp]) - cvtF e env = do - old <- state (\s -> ( localBindings s, s { localBindings = [] } )) - e' <- cvtE e env - env' <- state (\s -> ( localBindings s, s { localBindings = old } )) - return (reverse env', e') - - p' <- cvtF p (env `Push` acc) - f' <- cvtF f (env `Push` acc) + p' <- clean $ cvtE p (env `Push` acc) + f' <- clean $ cvtE f (env `Push` acc) -- Piece it all together. Note that declarations are added to the - -- localBindings in reverse order. + -- localBindings in reverse order. Also, we have to be careful not to + -- assign the results of f' direction into acc. Why? If some of the + -- variables in acc are referenced in f', then we risk overwriting + -- values that are still needed to computer f'. + -- let loop = [citem| while ( $exp:(single "while" ok) ) { - $items:(acc .=. f') + $items:(tmp .=. f') + $items:(acc .=. tmp) $items:(ok .=. p') } |] - : (ok .=. p') - ++ map (\(t,n) -> [citem| $ty:t $id:n ; |]) tn_ok - ++ zipWith (\(t,n) v -> [citem| $ty:t $id:n = $v ; |]) tn_acc x' + : reverse (ok .=. p') + ++ reverse (acc .=. x') + ++ map C.BlockDecl decl_ok + ++ map C.BlockDecl decl_acc modify (\s -> s { localBindings = loop ++ localBindings s }) return acc @@ -486,7 +657,7 @@ restrict SliceNil _ _ = [] restrict (SliceAll sliceIdx) slx (sz:sl) = sz : restrict sliceIdx slx sl restrict (SliceFixed sliceIdx) (_:slx) ( _:sl) = restrict sliceIdx slx sl - restrict _ _ _ = INTERNAL_ERROR(error) "IndexSlice" "unexpected shapes" + restrict _ _ _ = $internalError "IndexSlice" "unexpected shapes" -- slice slix' sh' = reverse $ restrict sliceIndex (reverse slix') (reverse sh') in @@ -505,7 +676,7 @@ extend SliceNil _ _ = [] extend (SliceAll sliceIdx) slx (sz:sh) = sz : extend sliceIdx slx sh extend (SliceFixed sliceIdx) (sz:slx) sh = sz : extend sliceIdx slx sh - extend _ _ _ = INTERNAL_ERROR(error) "IndexFull" "unexpected shapes" + extend _ _ _ = $internalError "IndexFull" "unexpected shapes" -- replicate slix' sl' = reverse $ extend sliceIndex (reverse slix') (reverse sl') in @@ -555,7 +726,7 @@ return $ zipWith (\t a -> indexArray dev t (cvar a) i) ty arr -- | otherwise - = INTERNAL_ERROR(error) "Index" "expected array variable" + = $internalError "Index" "expected array variable" linearIndex :: (Shape sh, Elt e) @@ -573,7 +744,7 @@ return $ zipWith (\t a -> indexArray dev t (cvar a) i) ty arr -- | otherwise - = INTERNAL_ERROR(error) "LinearIndex" "expected array variable" + = $internalError "LinearIndex" "expected array variable" -- Array shapes created in this method refer to the shape of free array -- variables. As such, they are always passed as arguments to the kernel, @@ -587,7 +758,7 @@ = return $ cshape (delayedDim acc) (fst (namesOfAvar aenv idx)) | otherwise - = INTERNAL_ERROR(error) "Shape" "expected array variable" + = $internalError "Shape" "expected array variable" -- The size of a shape, as the product of the extent in each dimension. The -- definition is inlined, but we could also call the C function helpers. @@ -604,275 +775,67 @@ intersect sh1 sh2 env = zipWith (\a b -> ccall "min" [a,b]) <$> cvtE sh1 env <*> cvtE sh2 env + -- Union of two shapes, taken as the maximum in each dimension. + -- + union :: forall env sh. Elt sh + => DelayedOpenExp env aenv sh + -> DelayedOpenExp env aenv sh + -> Val env -> Gen [C.Exp] + union sh1 sh2 env = + zipWith (\a b -> ccall "max" [a,b]) <$> cvtE sh1 env <*> cvtE sh2 env + -- Foreign scalar functions. We need to extract any header files that might -- be required so they can be added to the top level definitions. -- -- Additionally, we insert an explicit type cast from the foreign function -- result back into Accelerate types (c.f. Int vs int). -- - foreignE :: forall f a b env. (Sugar.Foreign f, Elt a, Elt b) - => f a b + foreignE :: forall asm a b env. (Sugar.Foreign asm, Elt a, Elt b) + => asm (a -> b) -> DelayedOpenExp env aenv a -> Val env -> Gen [C.Exp] - foreignE ff x env = case canExecuteExp ff of - Nothing -> INTERNAL_ERROR(error) "codegenOpenExp" "Non-CUDA foreign expression encountered" - Just (hs, f) -> do - lift $ modify (\st -> st { headers = foldl (flip Set.insert) (headers st) hs }) - args <- cvtE x env - mapM_ use args - return $ [ccall f (ccastTup (Sugar.eltType (undefined::a)) args)] + foreignE ff x env = + case canExecuteExp ff of + Nothing -> $internalError "codegenOpenExp" "failed to recover foreign function a second time" + Just (hs, f) -> do + lift $ modify (\st -> st { headers = foldl (flip Set.insert) (headers st) hs }) + args <- cvtE x env + mapM_ use args + return $ [ccall f (ccastTup (Sugar.eltType (undefined::a)) args)] + -- Execute a command in a new environment. The old environment is replaced + -- on exit, and the result and any new bindings generated are returned. + -- + clean :: Gen a -> Gen ([C.BlockItem], a) + clean this = do + env <- state (\s -> ( localBindings s, s { localBindings = [] } )) + r <- this + env' <- state (\s -> ( localBindings s, s { localBindings = env } )) + return (reverse env', r) + -- Some terms demand we extract only singly typed expressions -- single :: String -> [C.Exp] -> C.Exp single _ [x] = x - single loc _ = INTERNAL_ERROR(error) loc "expected single expression" - - --- Scalar Primitives --- ----------------- - -codegenPrimConst :: PrimConst a -> C.Exp -codegenPrimConst (PrimMinBound ty) = codegenMinBound ty -codegenPrimConst (PrimMaxBound ty) = codegenMaxBound ty -codegenPrimConst (PrimPi ty) = codegenPi ty - - -codegenPrim :: PrimFun p -> [C.Exp] -> C.Exp -codegenPrim (PrimAdd _) [a,b] = [cexp|$exp:a + $exp:b|] -codegenPrim (PrimSub _) [a,b] = [cexp|$exp:a - $exp:b|] -codegenPrim (PrimMul _) [a,b] = [cexp|$exp:a * $exp:b|] -codegenPrim (PrimNeg _) [a] = [cexp| - $exp:a|] -codegenPrim (PrimAbs ty) [a] = codegenAbs ty a -codegenPrim (PrimSig ty) [a] = codegenSig ty a -codegenPrim (PrimQuot _) [a,b] = [cexp|$exp:a / $exp:b|] -codegenPrim (PrimRem _) [a,b] = [cexp|$exp:a % $exp:b|] -codegenPrim (PrimIDiv _) [a,b] = ccall "idiv" [a,b] -codegenPrim (PrimMod _) [a,b] = ccall "mod" [a,b] -codegenPrim (PrimBAnd _) [a,b] = [cexp|$exp:a & $exp:b|] -codegenPrim (PrimBOr _) [a,b] = [cexp|$exp:a | $exp:b|] -codegenPrim (PrimBXor _) [a,b] = [cexp|$exp:a ^ $exp:b|] -codegenPrim (PrimBNot _) [a] = [cexp|~ $exp:a|] -codegenPrim (PrimBShiftL _) [a,b] = [cexp|$exp:a << $exp:b|] -codegenPrim (PrimBShiftR _) [a,b] = [cexp|$exp:a >> $exp:b|] -codegenPrim (PrimBRotateL _) [a,b] = ccall "rotateL" [a,b] -codegenPrim (PrimBRotateR _) [a,b] = ccall "rotateR" [a,b] -codegenPrim (PrimFDiv _) [a,b] = [cexp|$exp:a / $exp:b|] -codegenPrim (PrimRecip ty) [a] = codegenRecip ty a -codegenPrim (PrimSin ty) [a] = ccall (FloatingNumType ty `postfix` "sin") [a] -codegenPrim (PrimCos ty) [a] = ccall (FloatingNumType ty `postfix` "cos") [a] -codegenPrim (PrimTan ty) [a] = ccall (FloatingNumType ty `postfix` "tan") [a] -codegenPrim (PrimAsin ty) [a] = ccall (FloatingNumType ty `postfix` "asin") [a] -codegenPrim (PrimAcos ty) [a] = ccall (FloatingNumType ty `postfix` "acos") [a] -codegenPrim (PrimAtan ty) [a] = ccall (FloatingNumType ty `postfix` "atan") [a] -codegenPrim (PrimAsinh ty) [a] = ccall (FloatingNumType ty `postfix` "asinh") [a] -codegenPrim (PrimAcosh ty) [a] = ccall (FloatingNumType ty `postfix` "acosh") [a] -codegenPrim (PrimAtanh ty) [a] = ccall (FloatingNumType ty `postfix` "atanh") [a] -codegenPrim (PrimExpFloating ty) [a] = ccall (FloatingNumType ty `postfix` "exp") [a] -codegenPrim (PrimSqrt ty) [a] = ccall (FloatingNumType ty `postfix` "sqrt") [a] -codegenPrim (PrimLog ty) [a] = ccall (FloatingNumType ty `postfix` "log") [a] -codegenPrim (PrimFPow ty) [a,b] = ccall (FloatingNumType ty `postfix` "pow") [a,b] -codegenPrim (PrimLogBase ty) [a,b] = codegenLogBase ty a b -codegenPrim (PrimTruncate ta tb) [a] = codegenTruncate ta tb a -codegenPrim (PrimRound ta tb) [a] = codegenRound ta tb a -codegenPrim (PrimFloor ta tb) [a] = codegenFloor ta tb a -codegenPrim (PrimCeiling ta tb) [a] = codegenCeiling ta tb a -codegenPrim (PrimAtan2 ty) [a,b] = ccall (FloatingNumType ty `postfix` "atan2") [a,b] -codegenPrim (PrimLt _) [a,b] = [cexp|$exp:a < $exp:b|] -codegenPrim (PrimGt _) [a,b] = [cexp|$exp:a > $exp:b|] -codegenPrim (PrimLtEq _) [a,b] = [cexp|$exp:a <= $exp:b|] -codegenPrim (PrimGtEq _) [a,b] = [cexp|$exp:a >= $exp:b|] -codegenPrim (PrimEq _) [a,b] = [cexp|$exp:a == $exp:b|] -codegenPrim (PrimNEq _) [a,b] = [cexp|$exp:a != $exp:b|] -codegenPrim (PrimMax ty) [a,b] = codegenMax ty a b -codegenPrim (PrimMin ty) [a,b] = codegenMin ty a b -codegenPrim PrimLAnd [a,b] = [cexp|$exp:a && $exp:b|] -codegenPrim PrimLOr [a,b] = [cexp|$exp:a || $exp:b|] -codegenPrim PrimLNot [a] = [cexp| ! $exp:a|] -codegenPrim PrimOrd [a] = codegenOrd a -codegenPrim PrimChr [a] = codegenChr a -codegenPrim PrimBoolToInt [a] = codegenBoolToInt a -codegenPrim (PrimFromIntegral ta tb) [a] = codegenFromIntegral ta tb a - --- If the argument lists are not the correct length -codegenPrim _ _ = - INTERNAL_ERROR(error) "codegenPrim" "inconsistent valuation" - --- Implementation of scalar primitives --- -codegenConst :: TupleType a -> a -> [C.Exp] -codegenConst UnitTuple _ = [] -codegenConst (SingleTuple ty) c = [codegenScalar ty c] -codegenConst (PairTuple ty1 ty0) (cs,c) = codegenConst ty1 cs ++ codegenConst ty0 c - - --- Scalar constants --- -codegenScalar :: ScalarType a -> a -> C.Exp -codegenScalar (NumScalarType ty) = codegenNumScalar ty -codegenScalar (NonNumScalarType ty) = codegenNonNumScalar ty - -codegenNumScalar :: NumType a -> a -> C.Exp -codegenNumScalar (IntegralNumType ty) = codegenIntegralScalar ty -codegenNumScalar (FloatingNumType ty) = codegenFloatingScalar ty - -codegenIntegralScalar :: IntegralType a -> a -> C.Exp -codegenIntegralScalar ty x | IntegralDict <- integralDict ty = [cexp| ( $ty:(codegenIntegralType ty) ) $exp:(cintegral x) |] - -codegenFloatingScalar :: FloatingType a -> a -> C.Exp -codegenFloatingScalar (TypeFloat _) x = C.Const (C.FloatConst (shows x "f") (toRational x) noLoc) noLoc -codegenFloatingScalar (TypeCFloat _) x = C.Const (C.FloatConst (shows x "f") (toRational x) noLoc) noLoc -codegenFloatingScalar (TypeDouble _) x = C.Const (C.DoubleConst (show x) (toRational x) noLoc) noLoc -codegenFloatingScalar (TypeCDouble _) x = C.Const (C.DoubleConst (show x) (toRational x) noLoc) noLoc - -codegenNonNumScalar :: NonNumType a -> a -> C.Exp -codegenNonNumScalar (TypeBool _) x = cbool x -codegenNonNumScalar (TypeChar _) x = [cexp|$char:x|] -codegenNonNumScalar (TypeCChar _) x = [cexp|$char:(chr (fromIntegral x))|] -codegenNonNumScalar (TypeCUChar _) x = [cexp|$char:(chr (fromIntegral x))|] -codegenNonNumScalar (TypeCSChar _) x = [cexp|$char:(chr (fromIntegral x))|] - - --- Constant methods of floating --- -codegenPi :: FloatingType a -> C.Exp -codegenPi ty | FloatingDict <- floatingDict ty = codegenFloatingScalar ty pi - - --- Constant methods of bounded --- -codegenMinBound :: BoundedType a -> C.Exp -codegenMinBound (IntegralBoundedType ty) | IntegralDict <- integralDict ty = codegenIntegralScalar ty minBound -codegenMinBound (NonNumBoundedType ty) | NonNumDict <- nonNumDict ty = codegenNonNumScalar ty minBound - - -codegenMaxBound :: BoundedType a -> C.Exp -codegenMaxBound (IntegralBoundedType ty) | IntegralDict <- integralDict ty = codegenIntegralScalar ty maxBound -codegenMaxBound (NonNumBoundedType ty) | NonNumDict <- nonNumDict ty = codegenNonNumScalar ty maxBound - - --- Methods from Num, Floating, Fractional and RealFrac --- -codegenAbs :: NumType a -> C.Exp -> C.Exp -codegenAbs (FloatingNumType ty) x = ccall (FloatingNumType ty `postfix` "fabs") [x] -codegenAbs (IntegralNumType ty) x = - case ty of - TypeWord _ -> x - TypeWord8 _ -> x - TypeWord16 _ -> x - TypeWord32 _ -> x - TypeWord64 _ -> x - TypeCUShort _ -> x - TypeCUInt _ -> x - TypeCULong _ -> x - TypeCULLong _ -> x - _ -> ccall "abs" [x] - - -codegenSig :: NumType a -> C.Exp -> C.Exp -codegenSig (IntegralNumType ty) = codegenIntegralSig ty -codegenSig (FloatingNumType ty) = codegenFloatingSig ty - -codegenIntegralSig :: IntegralType a -> C.Exp -> C.Exp -codegenIntegralSig ty x = [cexp|$exp:x == $exp:zero ? $exp:zero : $exp:(ccall "copysign" [one,x]) |] - where - zero | IntegralDict <- integralDict ty = codegenIntegralScalar ty 0 - one | IntegralDict <- integralDict ty = codegenIntegralScalar ty 1 - -codegenFloatingSig :: FloatingType a -> C.Exp -> C.Exp -codegenFloatingSig ty x = - [cexp|$exp:x == $exp:zero - ? $exp:zero - : $exp:(ccall (FloatingNumType ty `postfix` "copysign") [one,x]) |] - where - zero | FloatingDict <- floatingDict ty = codegenFloatingScalar ty 0 - one | FloatingDict <- floatingDict ty = codegenFloatingScalar ty 1 - - -codegenRecip :: FloatingType a -> C.Exp -> C.Exp -codegenRecip ty x | FloatingDict <- floatingDict ty = [cexp|$exp:(codegenFloatingScalar ty 1) / $exp:x|] - - -codegenLogBase :: FloatingType a -> C.Exp -> C.Exp -> C.Exp -codegenLogBase ty x y = let a = ccall (FloatingNumType ty `postfix` "log") [x] - b = ccall (FloatingNumType ty `postfix` "log") [y] - in - [cexp|$exp:b / $exp:a|] - - -codegenMin :: ScalarType a -> C.Exp -> C.Exp -> C.Exp -codegenMin (NumScalarType ty@(IntegralNumType _)) a b = ccall (ty `postfix` "min") [a,b] -codegenMin (NumScalarType ty@(FloatingNumType _)) a b = ccall (ty `postfix` "fmin") [a,b] -codegenMin (NonNumScalarType _) a b = - let ty = scalarType :: ScalarType Int32 - in codegenMin ty (ccast ty a) (ccast ty b) - - -codegenMax :: ScalarType a -> C.Exp -> C.Exp -> C.Exp -codegenMax (NumScalarType ty@(IntegralNumType _)) a b = ccall (ty `postfix` "max") [a,b] -codegenMax (NumScalarType ty@(FloatingNumType _)) a b = ccall (ty `postfix` "fmax") [a,b] -codegenMax (NonNumScalarType _) a b = - let ty = scalarType :: ScalarType Int32 - in codegenMax ty (ccast ty a) (ccast ty b) - - --- Type coercions --- -codegenOrd :: C.Exp -> C.Exp -codegenOrd = ccast (scalarType :: ScalarType Int) - -codegenChr :: C.Exp -> C.Exp -codegenChr = ccast (scalarType :: ScalarType Char) - -codegenBoolToInt :: C.Exp -> C.Exp -codegenBoolToInt = ccast (scalarType :: ScalarType Int) - -codegenFromIntegral :: IntegralType a -> NumType b -> C.Exp -> C.Exp -codegenFromIntegral _ ty = ccast (NumScalarType ty) - -codegenTruncate :: FloatingType a -> IntegralType b -> C.Exp -> C.Exp -codegenTruncate ta tb x - = ccast (NumScalarType (IntegralNumType tb)) - $ ccall (FloatingNumType ta `postfix` "trunc") [x] - -codegenRound :: FloatingType a -> IntegralType b -> C.Exp -> C.Exp -codegenRound ta tb x - = ccast (NumScalarType (IntegralNumType tb)) - $ ccall (FloatingNumType ta `postfix` "round") [x] - -codegenFloor :: FloatingType a -> IntegralType b -> C.Exp -> C.Exp -codegenFloor ta tb x - = ccast (NumScalarType (IntegralNumType tb)) - $ ccall (FloatingNumType ta `postfix` "floor") [x] - -codegenCeiling :: FloatingType a -> IntegralType b -> C.Exp -> C.Exp -codegenCeiling ta tb x - = ccast (NumScalarType (IntegralNumType tb)) - $ ccall (FloatingNumType ta `postfix` "ceil") [x] + single loc _ = $internalError loc "expected single expression" -- Auxiliary Functions -- ------------------- ccast :: ScalarType a -> C.Exp -> C.Exp -ccast ty x = [cexp|($ty:(codegenScalarType ty)) $exp:x|] +ccast ty x = [cexp| ($ty:(typeOf ty)) $exp:x |] ccastTup :: TupleType e -> [C.Exp] -> [C.Exp] ccastTup ty = fst . travTup ty where - travTup :: TupleType e -> [C.Exp] -> ([C.Exp],[C.Exp]) + travTup :: TupleType e -> [C.Exp] -> ([C.Exp], [C.Exp]) travTup UnitTuple xs = ([], xs) travTup (SingleTuple ty') (x:xs) = ([ccast ty' x], xs) - travTup (PairTuple l r) xs = let - (ls, xs' ) = travTup l xs - (rs, xs'') = travTup r xs' - in (ls ++ rs, xs'') - travTup _ _ = INTERNAL_ERROR(error) "ccastTup" "not enough expressions to match type" - - -postfix :: NumType a -> String -> String -postfix (FloatingNumType (TypeFloat _)) x = x ++ "f" -postfix (FloatingNumType (TypeCFloat _)) x = x ++ "f" -postfix _ x = x + travTup (PairTuple l r) xs = + let (ls, xs' ) = travTup l xs + (rs, xs'') = travTup r xs' + in (ls ++ rs, xs'') + travTup _ _ = $internalError "ccastTup" "not enough expressions to match type" diff --git a/Data/Array/Accelerate/CUDA/CodeGen/Arithmetic.hs b/Data/Array/Accelerate/CUDA/CodeGen/Arithmetic.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/CodeGen/Arithmetic.hs @@ -0,0 +1,393 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Data.Array.Accelerate.CUDA.CodeGen.Arithmetic +-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller +-- [2009..2014] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.CUDA.CodeGen.Arithmetic + where + +-- friends +import Data.Array.Accelerate.Type +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.CUDA.CodeGen.Base +import Data.Array.Accelerate.CUDA.CodeGen.Constant +import Data.Array.Accelerate.CUDA.CodeGen.Monad +import Data.Array.Accelerate.CUDA.CodeGen.Type + +-- libraries +import Prelude ( String, ($), (++), (-), undefined, otherwise ) +import Data.Bits ( finiteBitSize ) +import Control.Monad.State.Strict +import Language.C +import Language.C.Quote.CUDA +import Foreign.Storable ( sizeOf ) + + +-- Operations from Num +-- =================== + +add :: Exp -> Exp -> Exp +add x y = [cexp| $exp:x + $exp:y |] + +sub :: Exp -> Exp -> Exp +sub x y = [cexp| $exp:x - $exp:y |] + +mul :: Exp -> Exp -> Exp +mul x y = [cexp| $exp:x * $exp:y |] + +negate :: Exp -> Exp +negate x = [cexp| - $exp:x |] + +abs :: forall a. NumType a -> Exp -> Exp +abs (FloatingNumType t) x + = mathf t "fabs" [x] + +abs (IntegralNumType t) x + | signedIntegralNum t + , IntegralDict <- integralDict t + = case sizeOf (undefined::a) of + 8 -> ccall "llabs" [x] + _ -> ccall "abs" [x] + + | otherwise + = x + +signum :: NumType a -> Exp -> Gen Exp +signum (IntegralNumType t) x + | IntegralDict <- integralDict t + , unsignedIntegralNum t + = return [cexp| $exp:x > $exp:(integral t 0) |] + + | IntegralDict <- integralDict t + = do x' <- bind (typeOf t) x + return [cexp| ($exp:x' > $exp:(integral t 0)) - ($exp:x' < $exp:(integral t 0)) |] + +signum (FloatingNumType t) x + | FloatingDict <- floatingDict t + = do x' <- bind (typeOf t) x + return [cexp| $exp:x' == $exp:(floating t 0) + ? $exp:(floating t 0) + : $exp:(mathf t "copysign" [floating t 1, x']) |] + + +-- Operators from Integral & Bits +-- ============================== + +quot :: Exp -> Exp -> Exp +quot x y = [cexp| $exp:x / $exp:y |] + +rem :: Exp -> Exp -> Exp +rem x y = [cexp| $exp:x % $exp:y |] + +quotRem :: IntegralType a -> Exp -> Exp -> Gen (Exp,Exp) +quotRem (typeOf -> t') x y = do + x' <- bind t' x + y' <- bind t' y + q <- bind t' (x' `quot` y') + r <- bind t' (x' `sub` (y' `mul` q)) + return (q, r) + +idiv :: IntegralType a -> Exp -> Exp -> Gen Exp +idiv t x y + | unsignedIntegralNum t + = return (x `quot` y) + + | IntegralDict <- integralDict t + , zero <- integral t 0 + , one <- integral t 1 + = do + x' <- bind (typeOf t) x + y' <- bind (typeOf t) y + return $ + cases [ ((x' `gt` zero) `land` (y' `lt` zero), ((x' `sub` one) `quot` y') `sub` one) + , ((x' `lt` zero) `land` (y' `gt` zero), ((x' `add` one) `quot` y') `sub` one) + ] + (x' `quot` y') + +mod :: IntegralType a -> Exp -> Exp -> Gen Exp +mod t x y + | unsignedIntegralNum t + = return (x `rem` y) + + | IntegralDict <- integralDict t + , zero <- integral t 0 + = do + x' <- bind (typeOf t) x + y' <- bind (typeOf t) y + r <- bind (typeOf t) (x' `rem` y') + return $ + ((((x' `gt` zero) `land` (y' `lt` zero)) `lor` ((x' `lt` zero) `land` (y' `gt` zero))) + ?: ( r `neq` zero ?: ( r `add` y', zero ) + , r )) + +divMod :: IntegralType a -> Exp -> Exp -> Gen (Exp, Exp) +divMod t x y | IntegralDict <- integralDict t = do + x' <- bind (typeOf t) x + y' <- bind (typeOf t) y + (q,r) <- quotRem t x' y' + + sr <- signum (IntegralNumType t) r + sy' <- signum (IntegralNumType t) y' + + -- Somewhat awful way to inject an ifThenElse statement + vd <- lift fresh + vm <- lift fresh + modify (\st -> st { localBindings = [citem| $ty:(typeOf t) $id:vd, $id:vm; |] : localBindings st }) + modify (\st -> st { localBindings = [citem| if ( $exp:(sr `eq` negate sy') ) { + $id:vd = $exp:(q `sub` integral t 1); + $id:vm = $exp:(r `add` y') ; + } else { + $id:vd = $exp:q; + $id:vm = $exp:r; + } |] : localBindings st }) + return ( cvar vd, cvar vm ) + + +band :: Exp -> Exp -> Exp +band x y = [cexp| $exp:x & $exp:y |] + +bor :: Exp -> Exp -> Exp +bor x y = [cexp| $exp:x | $exp:y |] + +xor :: Exp -> Exp -> Exp +xor x y = [cexp| $exp:x ^ $exp:y |] + +bnot :: Exp -> Exp +bnot x = [cexp| ~ $exp:x |] + +shiftL :: Exp -> Exp -> Exp +shiftL x i = [cexp| $exp:x << $exp:i |] + +-- Arithmetic right shift (unchecked) +-- +shiftRA :: Exp -> Exp -> Exp +shiftRA x i = [cexp| $exp:x >> $exp:i |] + +-- Logical right shift (unchecked) +-- +shiftRL :: IntegralType a -> Exp -> Exp -> Exp +shiftRL ty x i = + let int = typeOf (integralType :: IntegralType Int) + word = typeOf (integralType :: IntegralType Word) + in + case ty of + TypeInt{} -> [cexp| ($ty:int) (($ty:word) $exp:x >> $exp:i) |] + TypeInt8{} -> [cexp| (typename Int8) ((typename Word8) $exp:x >> $exp:i) |] + TypeInt16{} -> [cexp| (typename Int16) ((typename Word16) $exp:x >> $exp:i) |] + TypeInt32{} -> [cexp| (typename Int32) ((typename Word32) $exp:x >> $exp:i) |] + TypeInt64{} -> [cexp| (typename Int64) ((typename Word64) $exp:x >> $exp:i) |] + TypeCShort{} -> [cexp| (short) ((unsigned short) $exp:x >> $exp:i) |] + TypeCInt{} -> [cexp| (int) ((unsigned int) $exp:x >> $exp:i) |] + TypeCLong{} -> [cexp| (long) ((unsigned long) $exp:x >> $exp:i) |] + TypeCLLong{} -> [cexp| (long long) ((unsigned long long) $exp:x >> $exp:i) |] + + -- unsigned types use arithmetic shift + _ -> $internalCheck "shiftRL" "unhandled signed type" (unsignedIntegralNum ty) (shiftRA x i) + + +rotateL :: forall a. IntegralType a -> Exp -> Exp -> Gen Exp +rotateL t x i | IntegralDict <- integralDict t = do + let int = integralType :: IntegralType Int + wsib = finiteBitSize (undefined::a) + -- + x' <- bind (typeOf t) x + i' <- bind (typeOf int) (i `band` integral int (wsib - 1)) + return $ (x' `shiftL` i') `bor` (shiftRL t x' (integral int wsib `sub` i')) + +rotateR :: IntegralType a -> Exp -> Exp -> Gen Exp +rotateR t x i = rotateL t x (negate i) + + +-- Operators from Fractional & Floating +-- ==================================== + +fdiv :: Exp -> Exp -> Exp +fdiv x y = [cexp| $exp:x / $exp:y |] + +recip :: FloatingType a -> Exp -> Exp +recip t x | FloatingDict <- floatingDict t = fdiv (floating t 1) x + +sin :: FloatingType a -> Exp -> Exp +sin t x = mathf t "sin" [x] + +cos :: FloatingType a -> Exp -> Exp +cos t x = mathf t "cos" [x] + +tan :: FloatingType a -> Exp -> Exp +tan t x = mathf t "tan" [x] + +asin :: FloatingType a -> Exp -> Exp +asin t x = mathf t "asin" [x] + +acos :: FloatingType a -> Exp -> Exp +acos t x = mathf t "acos" [x] + +atan :: FloatingType a -> Exp -> Exp +atan t x = mathf t "atan" [x] + +sinh :: FloatingType a -> Exp -> Exp +sinh t x = mathf t "sinh" [x] + +cosh :: FloatingType a -> Exp -> Exp +cosh t x = mathf t "cosh" [x] + +tanh :: FloatingType a -> Exp -> Exp +tanh t x = mathf t "tanh" [x] + +asinh :: FloatingType a -> Exp -> Exp +asinh t x = mathf t "asinh" [x] + +acosh :: FloatingType a -> Exp -> Exp +acosh t x = mathf t "acosh" [x] + +atanh :: FloatingType a -> Exp -> Exp +atanh t x = mathf t "atanh" [x] + +exp :: FloatingType a -> Exp -> Exp +exp t x = mathf t "exp" [x] + +sqrt :: FloatingType a -> Exp -> Exp +sqrt t x = mathf t "sqrt" [x] + +pow :: FloatingType a -> Exp -> Exp -> Exp +pow t x y = mathf t "pow" [x,y] + +log :: FloatingType a -> Exp -> Exp +log t x = mathf t "log" [x] + +logBase :: FloatingType a -> Exp -> Exp -> Exp +logBase t x y = log t y `fdiv` log t x + + +-- Operators from RealFrac +-- ======================= + +trunc :: FloatingType a -> IntegralType b -> Exp -> Exp +trunc ta tb x = cast tb $ mathf ta "trunc" [x] + +round :: FloatingType a -> IntegralType b -> Exp -> Exp +round ta tb x = cast tb $ mathf ta "round" [x] + +floor :: FloatingType a -> IntegralType b -> Exp -> Exp +floor ta tb x = cast tb $ mathf ta "floor" [x] + +ceiling :: FloatingType a -> IntegralType b -> Exp -> Exp +ceiling ta tb x = cast tb $ mathf ta "ceil" [x] + + +-- Operators from RealFloat +-- ======================== + +atan2 :: FloatingType a -> Exp -> Exp -> Exp +atan2 t x y = mathf t "atan2" [x, y] + +isNaN :: Exp -> Exp +isNaN x = ccall "isnan" [x] + + +-- Relational and equality operators +-- ================================= + +lt :: Exp -> Exp -> Exp +lt x y = [cexp| $exp:x < $exp:y |] + +gt :: Exp -> Exp -> Exp +gt x y = [cexp| $exp:x > $exp:y |] + +leq :: Exp -> Exp -> Exp +leq x y = [cexp| $exp:x <= $exp:y |] + +geq :: Exp -> Exp -> Exp +geq x y = [cexp| $exp:x >= $exp:y |] + +eq :: Exp -> Exp -> Exp +eq x y = [cexp| $exp:x == $exp:y |] + +neq :: Exp -> Exp -> Exp +neq x y = [cexp| $exp:x != $exp:y |] + +max :: ScalarType a -> Exp -> Exp -> Exp +max (NonNumScalarType _) x y = + let t = scalarType :: ScalarType Int32 + in max t (cast t x) (cast t y) + +max (NumScalarType (IntegralNumType _)) x y = ccall "max" [x,y] +max (NumScalarType (FloatingNumType t)) x y = mathf t "fmax" [x,y] + +min :: ScalarType a -> Exp -> Exp -> Exp +min (NonNumScalarType _) x y = + let t = scalarType :: ScalarType Int32 + in min t (cast t x) (cast t y) + +min (NumScalarType (IntegralNumType _)) x y = ccall "min" [x,y] +min (NumScalarType (FloatingNumType t)) x y = mathf t "fmin" [x,y] + + +-- Logical operators +-- ================= + +land :: Exp -> Exp -> Exp +land x y = [cexp| $exp:x && $exp:y |] + +lor :: Exp -> Exp -> Exp +lor x y = [cexp| $exp:x || $exp:y |] + +lnot :: Exp -> Exp +lnot x = [cexp| ! $exp:x |] + + +-- Type Conversions +-- ================ + +ord :: Exp -> Exp +ord = cast (scalarType :: ScalarType Int) + +chr :: Exp -> Exp +chr = cast (scalarType :: ScalarType Char) + +boolToInt :: Exp -> Exp +boolToInt = cast (scalarType :: ScalarType Int) + +fromIntegral :: IntegralType a -> NumType b -> Exp -> Exp +fromIntegral _ tb = cast tb + + +-- Helpers +-- ======= + +cast :: TypeOf a => a -> Exp -> Exp +cast t x = [cexp| ($ty:(typeOf t)) $exp:x |] + +mathf :: forall t. FloatingType t -> String -> [Exp] -> Exp +mathf ty f args | FloatingDict <- floatingDict ty = + let + fun = f ++ case sizeOf (undefined :: t) of + 4 -> "f" + 8 -> [] + 16 -> "l" -- long double + _ -> $internalError "mathf" "unsupported floating point size" + in + ccall fun args + + +infix 0 ?: +(?:) :: Exp -> (Exp, Exp) -> Exp +(?:) p (t,e) = [cexp| $exp:p ? $exp:t : $exp:e |] + +cases :: [(Exp, Exp)] -> Exp -> Exp +cases [] def = def +cases ((p,b):rest) def = p ?: (b, cases rest def) + diff --git a/Data/Array/Accelerate/CUDA/CodeGen/Base.hs b/Data/Array/Accelerate/CUDA/CodeGen/Base.hs --- a/Data/Array/Accelerate/CUDA/CodeGen/Base.hs +++ b/Data/Array/Accelerate/CUDA/CodeGen/Base.hs @@ -3,14 +3,19 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +#if __GLASGOW_HASKELL__ <= 708 +{-# LANGUAGE OverlappingInstances #-} +{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} +#endif + -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen.Base --- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller +-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell @@ -26,7 +31,7 @@ Name, namesOfArray, namesOfAvar, groupOfInt, -- Declaration generation - cint, cvar, ccall, cchar, cintegral, cbool, cshape, csize, cindexHead, cindexTail, ctoIndex, cfromIndex, + cint, cvar, ccall, cchar, cintegral, cbool, cshape, cslice, csize, cindexHead, cindexTail, ctoIndex, cfromIndex, readArray, writeArray, shared, indexArray, environment, arrayAsTex, arrayAsArg, umul24, gridSize, threadIdx, @@ -49,13 +54,13 @@ -- friends import Data.Array.Accelerate.Type +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Array.Representation ( SliceIndex(..) ) import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt ) import Data.Array.Accelerate.Analysis.Shape import Data.Array.Accelerate.CUDA.CodeGen.Type import Data.Array.Accelerate.CUDA.AST -#include "accelerate.h" - -- Names -- ----- @@ -137,7 +142,7 @@ -- ----------------------- cint :: C.Type -cint = codegenScalarType (scalarType :: ScalarType Int) +cint = typeOf (scalarType :: ScalarType Int) cvar :: Name -> C.Exp cvar x = [cexp|$id:x|] @@ -154,6 +159,17 @@ cbool :: Bool -> C.Exp cbool = cintegral . fromEnum +cslice :: SliceIndex slix sl co dim -> Name -> ([C.Param], [C.Exp], [(C.Type, Name)]) +cslice slix sl = + let xs = cshape' (ncodims slix) sl + args = [ [cparam| const $ty:cint $id:x |] | x <- xs ] + in (args, map cvar xs, zip (repeat cint) xs) + where + ncodims :: SliceIndex slix sl co dim -> Int + ncodims SliceNil = 0 + ncodims (SliceAll s) = ncodims s + ncodims (SliceFixed s) = ncodims s + 1 + -- Generate all the names of a shape given a base name and dimensionality cshape :: Int -> Name -> [C.Exp] cshape dim sh = [ cvar x | x <- cshape' dim sh ] @@ -183,7 +199,7 @@ toIndex [] [] = [cexp| $int:(0::Int) |] toIndex [_] [i] = i toIndex (sz:sh) (i:ix) = [cexp| $exp:(toIndex sh ix) * $exp:sz + $exp:i |] - toIndex _ _ = INTERNAL_ERROR(error) "toIndex" "argument mismatch" + toIndex _ _ = $internalError "toIndex" "argument mismatch" -- Generate code to calculate a multi-dimensional index from a linear index and a given array shape. -- This version creates temporary values that are reused in the computation. @@ -247,7 +263,9 @@ :: forall aenv sh e. (Shape sh, Elt e) => Name -- group names -> Array sh e -- dummy to fix types - -> ( [C.Param], CUDelayedAcc aenv sh e ) + -> ( [C.Param] + , [C.Exp] + , CUDelayedAcc aenv sh e ) readArray grp dummy = let (sh, arrs) = namesOfArray grp (undefined :: e) args = arrayAsArg dummy grp @@ -256,9 +274,9 @@ sh' = cshape dim sh get ix = ([], map (\a -> [cexp| $id:a [ $exp:ix ] |]) arrs) manifest = CUDelayed (CUExp ([], sh')) - (INTERNAL_ERROR(error) "readArray" "linear indexing only") + ($internalError "readArray" "linear indexing only") (CUFun1 (zip (repeat True)) (\[i] -> get (rvalue i))) - in ( args, manifest ) + in ( args, sh', manifest ) -- Generate function parameters and corresponding variable names for the @@ -269,11 +287,11 @@ -- writeArray :: forall sh e. (Shape sh, Elt e) - => Name -- group names - -> Array sh e -- dummy to fix types - -> ( [C.Param] -- function parameters to marshal the output array - , [C.Exp] -- the shape of the output array - , Rvalue x => x -> [C.Exp] ) -- write an element at a given index + => Name -- group names + -> Array sh e -- dummy to fix types + -> ( [C.Param] -- function parameters to marshal the output array + , [C.Exp] -- the shape of the output array + , forall x. Rvalue x => x -> [C.Exp] ) -- write an element at a given index writeArray grp _ = let (sh, arrs) = namesOfArray grp (undefined :: e) dim = expDim (undefined :: Exp aenv sh) @@ -294,12 +312,12 @@ -- shared :: forall e. Elt e - => e -- dummy type - -> Name -- group name - -> C.Exp -- how much shared memory per type - -> Maybe C.Exp -- (optional) initialise from this base address - -> ( [C.InitGroup] -- shared memory declaration and... - , Rvalue x => x -> [C.Exp]) -- ...indexing function + => e -- dummy type + -> Name -- group name + -> C.Exp -- how much shared memory per type + -> Maybe C.Exp -- (optional) initialise from this base address + -> ( [C.InitGroup] -- shared memory declaration and... + , forall x. Rvalue x => x -> [C.Exp]) -- ...indexing function shared _ grp size mprev = let e:es = eltType (undefined :: e) x:xs = let k = length es in map (\n -> grp ++ show n) [k, k-1 .. 0] @@ -384,10 +402,30 @@ in unzip3 $ zipWith local elt [n-1, n-2 .. 0] - class Lvalue a where lvalue :: a -> C.Exp -> C.BlockItem +-- Note: [Mutable l-values] +-- +-- Be careful when using mutable l-values that the same variable does not appear +-- on both the left and right hand side. For example, the following will lead to +-- problems (#114, #168): +-- +-- $items:(x .=. f x) +-- +-- $items:(y .=. combine x y) +-- +-- If 'x' and 'y' represent values with tuple types, they will have multiple +-- components. Since the LHS is updated as the new values are calculated, it is +-- possible to get into a situation where computing the new value for some of +-- the components will be using the updated values, not the original values. +-- +-- Instead, store the result to some (temporary) variable that does not appear +-- on the RHS, and then update old value using the fully computed result, e.g.: +-- +-- $items:(x' .=. f x) +-- $items:(x .=. x') +-- instance Lvalue C.Exp where lvalue x y = [citem| $exp:x = $exp:y; |] @@ -418,17 +456,17 @@ instance (Lvalue l, Rvalue r) => Assign l r where assign lhs rhs = [ lvalue lhs (rvalue rhs) ] -instance Assign l r => Assign (Bool,l) r where +instance {-# OVERLAPS #-} Assign l r => Assign (Bool,l) r where assign (used,lhs) rhs | used = assign lhs rhs | otherwise = [] -instance Assign l r => Assign [l] [r] where +instance {-# OVERLAPS #-} Assign l r => Assign [l] [r] where assign [] [] = [] assign (x:xs) (y:ys) = assign x y ++ assign xs ys - assign _ _ = INTERNAL_ERROR(error) ".=." "argument mismatch" + assign _ _ = $internalError ".=." "argument mismatch" -instance Assign l r => Assign l ([C.BlockItem], r) where +instance {-# OVERLAPS #-} Assign l r => Assign l ([C.BlockItem], r) where assign lhs (env, rhs) = env ++ assign lhs rhs @@ -440,10 +478,10 @@ zipWith :: (a -> b -> c) -> [a] -> [b] -> [c] zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys zipWith _ [] [] = [] -zipWith _ _ _ = INTERNAL_ERROR(error) "zipWith" "argument mismatch" +zipWith _ _ _ = $internalError "zipWith" "argument mismatch" zipWith3 :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] zipWith3 f (x:xs) (y:ys) (z:zs) = f x y z : zipWith3 f xs ys zs zipWith3 _ [] [] [] = [] -zipWith3 _ _ _ _ = INTERNAL_ERROR(error) "zipWith3" "argument mismatch" +zipWith3 _ _ _ _ = $internalError "zipWith3" "argument mismatch" diff --git a/Data/Array/Accelerate/CUDA/CodeGen/Constant.hs b/Data/Array/Accelerate/CUDA/CodeGen/Constant.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/CodeGen/Constant.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +-- | +-- Module : Data.Array.Accelerate.CUDA.CodeGen.Constant +-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller +-- [2009..2014] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.CUDA.CodeGen.Constant + where + +-- friends +import Data.Array.Accelerate.AST ( PrimConst(..) ) +import Data.Array.Accelerate.Type +import Data.Array.Accelerate.CUDA.CodeGen.Base +import Data.Array.Accelerate.CUDA.CodeGen.Type + +-- libraries +import Data.Loc +import Data.Char +import Language.C +import Language.C.Quote.CUDA + + +-- | A constant value. Note that this follows the EltRepr representation of the +-- type, meaning that any nested tupling on the surface type is flattened. +-- +constant :: TupleType a -> a -> [Exp] +constant UnitTuple _ = [] +constant (SingleTuple ty) c = [scalar ty c] +constant (PairTuple ty1 ty0) (cs,c) = constant ty1 cs ++ constant ty0 c + +-- | A constant scalar value +-- +scalar :: ScalarType a -> a -> Exp +scalar (NumScalarType ty) = num ty +scalar (NonNumScalarType ty) = nonnum ty + +-- | A constant numeric value +-- +num :: NumType a -> a -> Exp +num (IntegralNumType ty) = integral ty +num (FloatingNumType ty) = floating ty + +-- | A constant integral value +-- +integral :: IntegralType a -> a -> Exp +integral ty x | IntegralDict <- integralDict ty = [cexp| ( $ty:(typeOf ty) ) $exp:(cintegral x) |] + +-- | A constant floating-point value +-- +floating :: FloatingType a -> a -> Exp +floating (TypeFloat _) x = Const (FloatConst (shows x "f") (toRational x) noLoc) noLoc +floating (TypeCFloat _) x = Const (FloatConst (shows x "f") (toRational x) noLoc) noLoc +floating (TypeDouble _) x = Const (DoubleConst (show x) (toRational x) noLoc) noLoc +floating (TypeCDouble _) x = Const (DoubleConst (show x) (toRational x) noLoc) noLoc + + +-- | A constant non-numeric value +-- +nonnum :: NonNumType a -> a -> Exp +nonnum (TypeBool _) x = cbool x +nonnum (TypeChar _) x = [cexp|$char:x|] +nonnum (TypeCChar _) x = [cexp|$char:(chr (fromIntegral x))|] +nonnum (TypeCUChar _) x = [cexp|$char:(chr (fromIntegral x))|] +nonnum (TypeCSChar _) x = [cexp|$char:(chr (fromIntegral x))|] + + +-- | Primitive constants +-- +primConst :: PrimConst t -> Exp +primConst (PrimMinBound t) = primMinBound t +primConst (PrimMaxBound t) = primMaxBound t +primConst (PrimPi t) = primPi t + +primMinBound :: BoundedType a -> Exp +primMinBound (IntegralBoundedType ty) | IntegralDict <- integralDict ty = integral ty minBound +primMinBound (NonNumBoundedType ty) | NonNumDict <- nonNumDict ty = nonnum ty minBound + +primMaxBound :: BoundedType a -> Exp +primMaxBound (IntegralBoundedType ty) | IntegralDict <- integralDict ty = integral ty maxBound +primMaxBound (NonNumBoundedType ty) | NonNumDict <- nonNumDict ty = nonnum ty maxBound + +primPi :: FloatingType a -> Exp +primPi ty | FloatingDict <- floatingDict ty = floating ty pi + diff --git a/Data/Array/Accelerate/CUDA/CodeGen/IndexSpace.hs b/Data/Array/Accelerate/CUDA/CodeGen/IndexSpace.hs --- a/Data/Array/Accelerate/CUDA/CodeGen/IndexSpace.hs +++ b/Data/Array/Accelerate/CUDA/CodeGen/IndexSpace.hs @@ -1,12 +1,14 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen.IndexSpace --- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller +-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell @@ -24,19 +26,16 @@ ) where -import Data.List import Language.C.Quote.CUDA import Foreign.CUDA.Analysis.Device import qualified Language.C.Syntax as C import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt, ignore, shapeToList ) +import Data.Array.Accelerate.Error ( internalError ) import Data.Array.Accelerate.CUDA.AST ( Gamma ) -import Data.Array.Accelerate.CUDA.CodeGen.Type import Data.Array.Accelerate.CUDA.CodeGen.Base -#include "accelerate.h" - -- Construct a new array by applying a function to each index. Each thread -- processes multiple elements, striding the array by the grid size. -- @@ -178,7 +177,8 @@ permute ( $params:argIn, - $params:argOut + $params:argOut, + typename Int32 * __restrict__ lock ) { /* @@ -199,25 +199,23 @@ if ( ! $exp:(cignore dst) ) { - $decls:decly - $decls:decly' - - $items:(jx .=. ctoIndex shOut dst) - $items:(dce_x x .=. get ix) - $items:(dce_y y .=. arrOut jx) + $items:(jx .=. ctoIndex shOut dst) + $items:(dce_x x .=. get ix) - $items:write + $items:(atomically jx + [ dce_y y .=. setOut jx + , setOut jx .=. combine x y + ] + ) } } } |] where - sizeof = eltSizeOf (undefined::e) (texIn, argIn) = environment dev aenv - (argOut, shOut, arrOut) = writeArray "Out" (undefined :: Array sh' e) + (argOut, shOut, setOut) = writeArray "Out" (undefined :: Array sh' e) (x, _, _) = locals "x" (undefined :: e) - (_, y, decly) = locals "y" (undefined :: e) - (_, y', decly') = locals "_y" (undefined :: e) + (y, _, _) = locals "y" (undefined :: e) (sh, _, _) = locals "shIn" (undefined :: sh) (src, _, _) = locals "sh" (undefined :: sh) (dst, _, _) = locals "sh_" (undefined :: sh') @@ -227,43 +225,80 @@ -- If the destination index resolves to the magic index "ignore", the result -- is dropped from the output array. + -- cignore :: Rvalue x => [x] -> C.Exp - cignore [] = INTERNAL_ERROR(error) "permute" "singleton arrays not supported" + cignore [] = $internalError "permute" "singleton arrays not supported" cignore xs = foldl1 (\a b -> [cexp| $exp:a && $exp:b |]) $ zipWith (\a b -> [cexp| $exp:(rvalue a) == $int:b |]) xs $ shapeToList (ignore :: sh') - -- Apply the combining function between old and new values. If multiple - -- threads attempt to write to the same location, the hardware - -- write-combining mechanism will accept one transaction and all other - -- updates will be lost. - -- - -- If the hardware supports it, we can use atomicCAS (compare-and-swap) to - -- work around this. This requires at least compute 1.1 for 32-bit values, - -- and compute 1.2 for 64-bit values. If hardware support is not available, - -- write the result as normal and hope for the best. + -- If we can determine that the old values are not used in the combination + -- function (e.g. filter) then the lock and unlock fragments can be replaced + -- with a NOP. -- - -- Each element of a tuple is necessarily written individually, so the tuple - -- as a whole is not stored atomically. + -- If locking is required but the hardware does not support it (compute 1.0) + -- then we issue a runtime error immediately instead of silently failing. -- - write = env ++ zipWith6 apply sizeof (arrOut jx) fun x (dce_y y) y' - (env, fun) = combine x y - - apply size out f x1 (used,y1) y1' - | used - , Just atomicCAS <- reinterpret size - = [citem| do { - $exp:y1' = $exp:y1; - $exp:y1 = $exp:atomicCAS ( & $exp:out, $exp:y1', $exp:f ); + mustLock = or . fst . unzip $ dce_y y - } while ( $exp:y1 != $exp:y1' ); |] + -- The atomic section is acquired using a spin lock. This requires a + -- temporary array to represent the lock state for each element of the + -- output. We use 1 to represent the locked state, and 0 to represent + -- unlocked elements. + -- + -- do { + -- old = atomicExch(&lock[i], 1); // atomic exchange + -- } while (old == 1); + -- + -- /* critical section */ + -- + -- atomicExch(&lock[i], 0); + -- + -- The initial loop repeatedly attempts to take the lock by writing a 1 into + -- the slot. Once the 'old' state of the lock returns 0 (unlocked), we have + -- just acquired the lock, and the atomic section can be computed. Finally, + -- atomically write a 0 back into the slot to unlock the element. + -- + -- However, there is a complication with CUDA devices because all threads in + -- the warp must execute in lockstep (with predicated execution). Once a + -- thread acquires a lock, then it will be disabled and stop participating + -- in the first loop, waiting until all other threads in the warp acquire + -- their locks. If two threads in a warp are attempting to acquire the same + -- lock, once the lock is acquired by the first thread, it sits idle while + -- the second thread spins attempting to grab a lock that will never be + -- released, because the first thread can not progress. DEADLOCK. + -- + -- So, we need to invert the algorithm so that threads can always make + -- progress, until each thread in the warp has committed their result. + -- + -- done = 0; + -- do { + -- if (atomicExch(&lock[i], 1) == 0) { + -- + -- /* critical section */ + -- + -- done = 1; + -- atomicExch(&lock[i], 0); + -- } + -- } while (done == 0) + -- + atomically :: (C.Type, Name) -> [[C.BlockItem]] -> [C.BlockItem] + atomically (_,i) (concat -> body) + | not mustLock = body + | sm < Compute 1 1 = $internalError "permute" "Requires at least compute compatibility 1.1" + | otherwise = + [ [citem| typename Int32 done = 0; |] + , [citem| do { + typename Int32 *addr = &lock[ $exp:(cvar i) ]; - | otherwise - = [citem| $exp:out = $exp:(rvalue x1); |] + if ( atomicExch( addr, 1 ) == 0 ) { + $items:body - -- - reinterpret :: Int -> Maybe C.Exp - reinterpret 4 | sm >= Compute 1 1 = Just [cexp| $id:("atomicCAS32") |] - reinterpret 8 | sm >= Compute 1 2 = Just [cexp| $id:("atomicCAS64") |] - reinterpret _ = Nothing + done = 1; + atomicExch( addr, 0 ); + } + __threadfence(); + } while (done == 0); + |] + ] diff --git a/Data/Array/Accelerate/CUDA/CodeGen/Mapping.hs b/Data/Array/Accelerate/CUDA/CodeGen/Mapping.hs --- a/Data/Array/Accelerate/CUDA/CodeGen/Mapping.hs +++ b/Data/Array/Accelerate/CUDA/CodeGen/Mapping.hs @@ -1,11 +1,12 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen.Mapping --- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller +-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/Data/Array/Accelerate/CUDA/CodeGen/Monad.hs b/Data/Array/Accelerate/CUDA/CodeGen/Monad.hs --- a/Data/Array/Accelerate/CUDA/CodeGen/Monad.hs +++ b/Data/Array/Accelerate/CUDA/CodeGen/Monad.hs @@ -2,8 +2,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen.Monad --- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller +-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/Data/Array/Accelerate/CUDA/CodeGen/PrefixSum.hs b/Data/Array/Accelerate/CUDA/CodeGen/PrefixSum.hs --- a/Data/Array/Accelerate/CUDA/CodeGen/PrefixSum.hs +++ b/Data/Array/Accelerate/CUDA/CodeGen/PrefixSum.hs @@ -1,12 +1,14 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen.PrefixSum --- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller +-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell @@ -27,60 +29,96 @@ import Language.C.Quote.CUDA import qualified Language.C.Syntax as C -import Data.Array.Accelerate.Array.Sugar ( Vector, Scalar, Elt, DIM1 ) +import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Analysis.Match + import Data.Array.Accelerate.CUDA.AST +import Data.Array.Accelerate.CUDA.Analysis.Shape import Data.Array.Accelerate.CUDA.CodeGen.Base +errorMsg :: String +errorMsg + = error + $ unlines [ "accelerate-cuda does not support rank-polymorphic scans. Please switch to accelerate-llvm-ptx instead." + , "" + , "*** https://hackage.haskell.org/package/accelerate-llvm-ptx ***" + , "*** https://github.com/AccelerateHS/accelerate-llvm ***" + ] -- Wrappers -- -------- mkScanl, mkScanr - :: Elt e + :: forall aenv sh e. (Shape sh, Elt e) => DeviceProperties -> Gamma aenv -> CUFun2 aenv (e -> e -> e) -> CUExp aenv e - -> CUDelayedAcc aenv DIM1 e - -> [CUTranslSkel aenv (Vector e)] -mkScanl dev aenv f z a = - [ mkScan L dev aenv f (Just z) a - , mkScanUp1 L dev aenv f a - , mkScanUp2 L dev aenv f (Just z) ] + -> CUDelayedAcc aenv (sh:.Int) e + -> [CUTranslSkel aenv (Array (sh:.Int) e)] +mkScanl dev aenv f z a + | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) + = [ mkScan L dev aenv f (Just z) a + , mkScanUp1 L dev aenv f a + , mkScanUp2 L dev aenv f (Just z) ] -mkScanr dev aenv f z a = - [ mkScan R dev aenv f (Just z) a - , mkScanUp1 R dev aenv f a - , mkScanUp2 R dev aenv f (Just z) ] + | otherwise + = error errorMsg +mkScanr dev aenv f z a + | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) + = [ mkScan R dev aenv f (Just z) a + , mkScanUp1 R dev aenv f a + , mkScanUp2 R dev aenv f (Just z) ] + + | otherwise + = error errorMsg + mkScanl1, mkScanr1 - :: Elt e + :: forall aenv sh e. (Shape sh, Elt e) => DeviceProperties -> Gamma aenv -> CUFun2 aenv (e -> e -> e) - -> CUDelayedAcc aenv DIM1 e - -> [CUTranslSkel aenv (Vector e)] -mkScanl1 dev aenv f a = - [ mkScan L dev aenv f Nothing a - , mkScanUp1 L dev aenv f a - , mkScanUp2 L dev aenv f Nothing ] + -> CUDelayedAcc aenv (sh:.Int) e + -> [CUTranslSkel aenv (Array (sh:.Int) e)] +mkScanl1 dev aenv f a + | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) + = [ mkScan L dev aenv f Nothing a + , mkScanUp1 L dev aenv f a + , mkScanUp2 L dev aenv f Nothing ] -mkScanr1 dev aenv f a = - [ mkScan R dev aenv f Nothing a - , mkScanUp1 R dev aenv f a - , mkScanUp2 R dev aenv f Nothing ] + | otherwise + = error errorMsg +mkScanr1 dev aenv f a + | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) + = [ mkScan R dev aenv f Nothing a + , mkScanUp1 R dev aenv f a + , mkScanUp2 R dev aenv f Nothing ] + + | otherwise + = error errorMsg + mkScanl', mkScanr' - :: Elt e + :: forall aenv sh e. (Shape sh, Elt e) => DeviceProperties -> Gamma aenv -> CUFun2 aenv (e -> e -> e) -> CUExp aenv e - -> CUDelayedAcc aenv DIM1 e - -> [CUTranslSkel aenv (Vector e, Scalar e)] -mkScanl' dev aenv f z = map cast . mkScanl dev aenv f z -mkScanr' dev aenv f z = map cast . mkScanr dev aenv f z + -> CUDelayedAcc aenv (sh:.Int) e + -> [CUTranslSkel aenv (Array (sh:.Int) e, Array sh e)] +mkScanl' dev aenv f z + | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) + = map cast . mkScanl dev aenv f z + | otherwise + = error errorMsg +mkScanr' dev aenv f z + | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) + = map cast . mkScanr dev aenv f z + | otherwise + = error errorMsg + cast :: CUTranslSkel aenv a -> CUTranslSkel aenv b cast (CUTranslSkel entry code) = CUTranslSkel entry code @@ -183,6 +221,7 @@ ) { $decls:smem + $decls:declt $decls:declx $decls:decly $decls:declz @@ -222,7 +261,8 @@ * Carry in the result from the privous segment */ if ( $exp:carryIn ) { - $items:(x .=. combine z x) + $items:(t .=. combine z x) + $items:(x .=. t) } /* @@ -232,7 +272,7 @@ $items:(sdata "threadIdx.x" .=. x) __syncthreads(); - $items:(scanBlock dev fun x y sdata Nothing) + $items:(scanBlock dev fun x y t sdata Nothing) /* * Exclusive scans write the result of the previous thread to global @@ -273,6 +313,7 @@ (argOut, _, setOut) = writeArray "Out" (undefined :: Vector e) (argSum, _, totalSum) = writeArray "Sum" (undefined :: Vector e) (argBlk, _, blkSum) = writeArray "Blk" (undefined :: Vector e) + (_, t, declt) = locals "t" (undefined :: e) (_, x, declx) = locals "x" (undefined :: e) (_, y, decly) = locals "y" (undefined :: e) (_, z, declz) = locals "z" (undefined :: e) @@ -351,6 +392,7 @@ ) { $decls:smem + $decls:declt $decls:declx $decls:decly $items:(sh .=. shIn) @@ -376,7 +418,8 @@ $items:(x .=. get ix) if ( threadIdx.x == 0 && carryIn ) { - $items:(x .=. combine y x) + $items:(t .=. combine y x) + $items:(x .=. t) } /* @@ -385,7 +428,7 @@ $items:(sdata "threadIdx.x" .=. x) __syncthreads(); - $items:(scanBlock dev fun x y sdata Nothing) + $items:(scanBlock dev fun x y t sdata Nothing) /* * Store the final result of the block to be carried in @@ -411,6 +454,7 @@ (argOut, _, setOut) = writeArray "Out" (undefined :: Vector e) (_, x, declx) = locals "x" (undefined :: e) (_, y, decly) = locals "y" (undefined :: e) + (_, t, declt) = locals "t" (undefined :: e) (sh, _, _) = locals "sh" (undefined :: DIM1) (smem, sdata) = shared (undefined :: e) "sdata" [cexp| blockDim.x |] Nothing ix = [cvar "ix"] @@ -432,7 +476,7 @@ -> Maybe (CUExp aenv e) -> CUTranslSkel aenv (Vector e) mkScanUp2 dir dev aenv f z - = let (_, get) = readArray "Blk" (undefined :: Vector e) + = let (_, _, get) = readArray "Blk" (undefined :: Vector e) in mkScan dir dev aenv f z get @@ -443,13 +487,13 @@ :: forall aenv e. Elt e => DeviceProperties -> CUFun2 aenv (e -> e -> e) - -> [C.Exp] -> [C.Exp] + -> [C.Exp] -> [C.Exp] -> [C.Exp] -> (Name -> [C.Exp]) -> Maybe C.Exp -> [C.BlockItem] -scanBlock dev f x0 x1 sdata mlim +scanBlock dev f x0 x1 x2 sdata mlim | shflOK dev (undefined :: e) = error "shfl-scan" - | otherwise = scanBlockTree dev f x0 x1 sdata mlim + | otherwise = scanBlockTree dev f x0 x1 x2 sdata mlim -- Use a thread block to scan values in shared memory. Each thread must have @@ -461,11 +505,11 @@ :: forall aenv e. Elt e => DeviceProperties -> CUFun2 aenv (e -> e -> e) - -> [C.Exp] -> [C.Exp] -- temporary variables x0 and x1 + -> [C.Exp] -> [C.Exp] -> [C.Exp] -- input variables x0 and x1, plus a temporary to store the intermediate value -> (Name -> [C.Exp]) -- index elements from shared memory -> Maybe C.Exp -- partially full block bounds check? -> [C.BlockItem] -scanBlockTree dev (CUFun2 _ _ f) x0 x1 sdata mlim = map (scan . pow2) [ 0 .. maxThreads ] +scanBlockTree dev (CUFun2 _ _ f) x0 x1 x2 sdata mlim = map (scan . pow2) [ 0 .. maxThreads ] where pow2 :: Int -> Int pow2 x = 2 ^ x @@ -479,7 +523,8 @@ if ( blockDim.x > $int:n ) { if ( $exp:(inrange n) ) { $items:(x1 .=. sdata ("threadIdx.x - " ++ show n)) - $items:(x0 .=. f x1 x0) + $items:(x2 .=. f x1 x0) + $items:(x0 .=. x2) } __syncthreads(); $items:(sdata "threadIdx.x" .=. x0) diff --git a/Data/Array/Accelerate/CUDA/CodeGen/Reduction.hs b/Data/Array/Accelerate/CUDA/CodeGen/Reduction.hs --- a/Data/Array/Accelerate/CUDA/CodeGen/Reduction.hs +++ b/Data/Array/Accelerate/CUDA/CodeGen/Reduction.hs @@ -1,12 +1,13 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen.Reduction --- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller +-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell @@ -24,16 +25,15 @@ import Language.C.Quote.CUDA import qualified Language.C.Syntax as C -import Data.Array.Accelerate.Type ( IsIntegral ) -import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt, Z(..), (:.)(..) ) import Data.Array.Accelerate.Analysis.Shape +import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt, Z(..), (:.)(..) ) +import Data.Array.Accelerate.Error ( internalError ) +import Data.Array.Accelerate.Type ( IsIntegral ) import Data.Array.Accelerate.CUDA.AST import Data.Array.Accelerate.CUDA.CodeGen.Base import Data.Array.Accelerate.CUDA.CodeGen.Type -#include "accelerate.h" - -- Reduce an array along the innermost dimension. The function must be -- associative to enable efficient parallel implementation. -- @@ -93,7 +93,7 @@ -> CUDelayedAcc aenv (sh :. Int) e -> [ CUTranslSkel aenv (Array sh e) ] mkFoldAll dev aenv f z a - = let (_, rec) = readArray "Rec" (undefined :: Array (sh:.Int) e) + = let (_, _, rec) = readArray "Rec" (undefined :: Array (sh:.Int) e) in [ mkFoldAll' False dev aenv f z a , mkFoldAll' True dev aenv f z rec ] @@ -125,6 +125,7 @@ $decls:smem $decls:declx $decls:decly + $decls:declz $items:(sh .=. shIn) @@ -159,7 +160,8 @@ for ( ix += gridSize; ix < shapeSize; ix += gridSize ) { $items:(x .=. get ix) - $items:(y .=. combine x y) + $items:(z .=. combine y x) + $items:(y .=. z) } } @@ -170,7 +172,7 @@ $items:(sdata "threadIdx.x" .=. y) ix = min(shapeSize - blockIdx.x * blockDim.x, blockDim.x); - $items:(reduceBlock dev fun x y sdata (cvar "ix")) + $items:(reduceBlock dev fun x y z sdata (cvar "ix")) /* * Write the results of this block back to global memory. If we are the last @@ -186,12 +188,13 @@ foldAll = maybe "fold1All" (const "foldAll") mseed (texIn, argIn) = environment dev aenv (argOut, _, setOut) = writeArray "Out" (undefined :: Array (sh :. Int) e) - (argRec, _) + (argRec, _, _) | recursive = readArray "Rec" (undefined :: Array (sh :. Int) e) - | otherwise = ([], undefined) + | otherwise = ([], undefined, undefined) (_, x, declx) = locals "x" (undefined :: e) (_, y, decly) = locals "y" (undefined :: e) + (_, z, declz) = locals "z" (undefined :: e) (sh, _, _) = locals "sh" (undefined :: sh :. Int) ix = [cvar "ix"] (smem, sdata) = shared (undefined :: e) "sdata" [cexp| blockDim.x |] Nothing @@ -201,7 +204,8 @@ if ( shapeSize > 0 ) { if ( gridDim.x == 1 ) { $items:(x .=. seed) - $items:(y .=. combine x y) + $items:(z .=. combine y x) + $items:(y .=. z) } $items:(setOut "blockIdx.x" .=. y) } @@ -239,6 +243,7 @@ $decls:smem $decls:declx $decls:decly + $decls:declz $items:(sh .=. shIn) @@ -291,7 +296,8 @@ $items:(x .=. get [cvar "ix + blockDim.x"]) if ( ix >= start ) { - $items:(y .=. combine x y) + $items:(z .=. combine y x) + $items:(y .=. z) } else { $items:(y .=. x) @@ -304,7 +310,8 @@ for ( ix += 2 * blockDim.x; ix < end; ix += blockDim.x ) { $items:(x .=. get ix) - $items:(y .=. combine x y) + $items:(z .=. combine y x) + $items:(y .=. z) } } else @@ -317,7 +324,7 @@ * cooperatively reduces this to a single value. */ $items:(sdata "threadIdx.x" .=. y) - $items:(reduceBlock dev fun x y sdata (cvar "n")) + $items:(reduceBlock dev fun x y z sdata (cvar "n")) /* * Finally, the first thread writes the result for this segment. For @@ -336,6 +343,7 @@ (argOut, shOut, setOut) = writeArray "Out" (undefined :: Array sh e) (_, x, declx) = locals "x" (undefined :: e) (_, y, decly) = locals "y" (undefined :: e) + (_, z, declz) = locals "z" (undefined :: e) (sh, _, _) = locals "sh" (undefined :: sh :. Int) ix = [cvar "ix"] (smem, sdata) = shared (undefined :: e) "sdata" [cexp| blockDim.x |] Nothing @@ -355,7 +363,8 @@ -- exclusive_finish (CUExp seed) = concat [ x .=. seed - , y .=. combine x y ] + , z .=. combine y x + , y .=. z ] -- Segmented reduction along the innermost dimension of an array. Performs one @@ -451,6 +460,7 @@ $decls:smem $decls:declx $decls:decly + $decls:declz $items:(sh .=. shIn) /* @@ -499,7 +509,8 @@ $items:(x .=. get [cvar "ix + warpSize"]) if ( ix >= start ) { - $items:(y .=. combine x y) + $items:(z .=. combine y x) + $items:(y .=. z) } else { $items:(y .=. x) @@ -512,7 +523,8 @@ for ( ix += 2 * warpSize; ix < end; ix += warpSize ) { $items:(x .=. get ix) - $items:(y .=. combine x y) + $items:(z .=. combine y x) + $items:(y .=. z) } } else if ( start + thread_lane < end ) @@ -525,7 +537,7 @@ */ ix = min(num_elements, warpSize); $items:(sdata "threadIdx.x" .=. y) - $items:(reduceWarp dev fun x y sdata (cvar "ix") (cvar "thread_lane")) + $items:(reduceWarp dev fun x y z sdata (cvar "ix") (cvar "thread_lane")) /* * Finally, the first thread writes the result for this segment @@ -544,6 +556,7 @@ (argOut, shOut, setOut) = writeArray "Out" (undefined :: Array (sh :. Int) e) (_, x, declx) = locals "x" (undefined :: e) (_, y, decly) = locals "y" (undefined :: e) + (_, z, declz) = locals "z" (undefined :: e) (sh, _, _) = locals "sh" (undefined :: sh :. Int) (smem, sdata) = shared (undefined :: e) "sdata" [cexp| blockDim.x |] (Just $ [cexp| &s_ptrs[vectors_per_block][2] |]) -- @@ -554,7 +567,8 @@ exclusive_finish (CUExp seed) = [[citem| if ( num_elements > 0 ) { $items:(x .=. seed) - $items:(y .=. combine x y) + $items:(z .=. combine y x) + $items:(y .=. z) } else { $items:(y .=. seed) } |]] @@ -572,28 +586,28 @@ :: forall aenv e. Elt e => DeviceProperties -> CUFun2 aenv (e -> e -> e) - -> [C.Exp] -> [C.Exp] -- temporary variables x0 and x1 + -> [C.Exp] -> [C.Exp] -> [C.Exp] -- input variables x0 and x1, plus a temporary to store the intermediate result -> (Name -> [C.Exp]) -- index elements from shared memory -> C.Exp -- number of elements -> C.Exp -- thread identifier: usually lane or thread ID -> [C.BlockItem] -reduceWarp dev fun x0 x1 sdata n tid +reduceWarp dev fun x0 x1 x2 sdata n tid | shflOK dev (undefined :: e) = return - $ reduceWarpShfl dev fun x0 x1 n tid - | otherwise = reduceWarpTree dev fun x0 x1 sdata n tid + $ reduceWarpShfl dev fun x0 x1 n tid + | otherwise = reduceWarpTree dev fun x0 x1 x2 sdata n tid reduceBlock :: forall aenv e. Elt e => DeviceProperties -> CUFun2 aenv (e -> e -> e) - -> [C.Exp] -> [C.Exp] -- temporary variables x0 and x1 + -> [C.Exp] -> [C.Exp] -> [C.Exp] -- input variables x0 and x1, plus a temporary to store the intermediate result -> (Name -> [C.Exp]) -- index elements from shared memory -> C.Exp -- number of elements -> [C.BlockItem] -reduceBlock dev fun x0 x1 sdata n - | shflOK dev (undefined :: e) = reduceBlockShfl dev fun x0 x1 sdata n - | otherwise = reduceBlockTree dev fun x0 x1 sdata n +reduceBlock dev fun x0 x1 x2 sdata n + | shflOK dev (undefined :: e) = reduceBlockShfl dev fun x0 x1 sdata n + | otherwise = reduceBlockTree dev fun x0 x1 x2 sdata n -- Tree reduction @@ -603,12 +617,12 @@ :: Elt e => DeviceProperties -> CUFun2 aenv (e -> e -> e) - -> [C.Exp] -> [C.Exp] -- temporary variables x0 and x1 + -> [C.Exp] -> [C.Exp] -> [C.Exp] -- input variables x0 and x1, plus a temporary to store the intermediate result -> (Name -> [C.Exp]) -- index elements from shared memory -> C.Exp -- number of elements -> C.Exp -- thread identifier: usually lane or thread ID -> [C.BlockItem] -reduceWarpTree dev (CUFun2 _ _ f) x0 x1 sdata n tid +reduceWarpTree dev (CUFun2 _ _ f) x0 x1 x2 sdata n tid = map (reduce . pow2) [v, v-1 .. 0] where v = floor (logBase 2 (fromIntegral $ warpSize dev :: Double)) @@ -620,12 +634,14 @@ reduce 0 = [citem| if ( $exp:tid < $exp:n ) { $items:(x0 .=. sdata "threadIdx.x + 1") - $items:(x1 .=. f x1 x0) + $items:(x2 .=. f x1 x0) + $items:(x1 .=. x2) } |] reduce i = [citem| if ( $exp:tid + $int:i < $exp:n ) { $items:(x0 .=. sdata ("threadIdx.x + " ++ show i)) - $items:(x1 .=. f x1 x0) + $items:(x2 .=. f x1 x0) + $items:(x1 .=. x2) $items:(sdata "threadIdx.x" .=. x1) } |] @@ -633,11 +649,11 @@ :: Elt e => DeviceProperties -> CUFun2 aenv (e -> e -> e) - -> [C.Exp] -> [C.Exp] -- temporary variables x0 and x1 + -> [C.Exp] -> [C.Exp] -> [C.Exp] -- input variables x0 and x1, plus a temporary to store the intermediate result -> (Name -> [C.Exp]) -- index elements from shared memory -> C.Exp -- number of elements -> [C.BlockItem] -reduceBlockTree dev fun@(CUFun2 _ _ f) x0 x1 sdata n +reduceBlockTree dev fun@(CUFun2 _ _ f) x0 x1 x2 sdata n = flip (foldr1 (.)) [] $ map (reduce . pow2) [u-1, u-2 .. v] @@ -664,7 +680,8 @@ = [citem| __syncthreads(); |] : [citem| if ( threadIdx.x + $int:i < $exp:n ) { $items:(x0 .=. sdata ("threadIdx.x + " ++ show i)) - $items:(x1 .=. f x1 x0) + $items:(x2 .=. f x1 x0) + $items:(x1 .=. x2) } |] : [citem| __syncthreads(); |] : (sdata "threadIdx.x" .=. x1) @@ -677,7 +694,7 @@ | otherwise = [citem| __syncthreads(); |] : [citem| if ( threadIdx.x < $int:(warpSize dev) ) { - $items:(reduceWarpTree dev fun x0 x1 sdata n (cvar "threadIdx.x")) + $items:(reduceWarpTree dev fun x0 x1 x2 sdata n (cvar "threadIdx.x")) } |] : rest @@ -718,7 +735,7 @@ where shfl 4 = "shfl_xor32" shfl 8 = "shfl_xor64" - shfl _ = INTERNAL_ERROR(error) "shfl_xor" "I only know about 32- and 64-bit types" + shfl _ = $internalError "shfl_xor" "I only know about 32- and 64-bit types" -- Reduce a block of values in butterfly fashion using __shfl_xor(). Each warp diff --git a/Data/Array/Accelerate/CUDA/CodeGen/Stencil.hs b/Data/Array/Accelerate/CUDA/CodeGen/Stencil.hs --- a/Data/Array/Accelerate/CUDA/CodeGen/Stencil.hs +++ b/Data/Array/Accelerate/CUDA/CodeGen/Stencil.hs @@ -1,11 +1,12 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen.Stencil --- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller +-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/Data/Array/Accelerate/CUDA/CodeGen/Stencil/Extra.hs b/Data/Array/Accelerate/CUDA/CodeGen/Stencil/Extra.hs --- a/Data/Array/Accelerate/CUDA/CodeGen/Stencil/Extra.hs +++ b/Data/Array/Accelerate/CUDA/CodeGen/Stencil/Extra.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen.Stencil.Extra --- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --- [2009..2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller +-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell @@ -33,6 +33,7 @@ import qualified Language.C.Syntax as C -- friends +import Data.Array.Accelerate.Error ( internalError ) import Data.Array.Accelerate.Type ( Boundary(..) ) import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt, shapeToList ) import Data.Array.Accelerate.Analysis.Shape @@ -42,9 +43,7 @@ import Data.Array.Accelerate.CUDA.CodeGen.Base import Data.Array.Accelerate.CUDA.CodeGen.Type -#include "accelerate.h" - -- Stencil Access -- -------------- @@ -190,7 +189,7 @@ -- Test whether an index lies within the boundaries of a shape (first argument) -- cinRange :: [C.Exp] -> [C.Exp] -> C.Exp -cinRange [] [] = INTERNAL_ERROR(error) "inRange" "singleton index" +cinRange [] [] = $internalError "inRange" "singleton index" cinRange shape index = foldl1 and (zipWith inside shape index) where inside sz i = [cexp| ({ const $ty:cint _i = $exp:i; _i >= 0 && _i < $exp:sz; }) |] @@ -264,12 +263,12 @@ zipWith :: (a -> b -> c) -> [a] -> [b] -> [c] zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys zipWith _ [] [] = [] -zipWith _ _ _ = INTERNAL_ERROR(error) "zipWith" "argument mismatch" +zipWith _ _ _ = $internalError "zipWith" "argument mismatch" zipWith3 :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] zipWith3 f (x:xs) (y:ys) (z:zs) = f x y z : zipWith3 f xs ys zs zipWith3 _ [] [] [] = [] -zipWith3 _ _ _ _ = INTERNAL_ERROR(error) "zipWith3" "argument mismatch" +zipWith3 _ _ _ _ = $internalError "zipWith3" "argument mismatch" -- Split a list into segments of given length diff --git a/Data/Array/Accelerate/CUDA/CodeGen/Streaming.hs b/Data/Array/Accelerate/CUDA/CodeGen/Streaming.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/CodeGen/Streaming.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Data.Array.Accelerate.CUDA.CodeGen.Streaming +-- +-- Maintainer : Frederik Meisner Madsen +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.CUDA.CodeGen.Streaming ( + + mkToSeq + +) where + +import Language.C.Quote.CUDA +import Foreign.CUDA.Analysis.Device + +import Data.Array.Accelerate.Error ( internalError ) +import Data.Array.Accelerate.Array.Representation ( SliceIndex(..) ) +import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt, EltRepr ) +import Data.Array.Accelerate.CUDA.AST +import Data.Array.Accelerate.CUDA.CodeGen.Base + +mkToSeq + :: forall slix aenv sh co sl a. (Shape sl, Shape sh, Elt a) + => SliceIndex slix + (EltRepr sl) + co + (EltRepr sh) + -> DeviceProperties + -> Gamma aenv + -> CUDelayedAcc aenv sh a + -> CUTranslSkel aenv (Array sl a) +mkToSeq slix dev aenv arr + | CUDelayed (CUExp shIn) (CUFun1 _ get) _ <- arr + = CUTranslSkel "tostream" [cunit| + + $esc:("#include ") + $edecls:texIn + + extern "C" __global__ void + tostream + ( + $params:argIn, + $params:slIn, + $params:argOut + ) + { + $items:(sh .=. shIn) + + const int shapeSize = $exp:(csize shOut); + const int gridSize = $exp:(gridSize dev); + int ix; + + for ( ix = $exp:(threadIdx dev) + ; ix < shapeSize + ; ix += gridSize ) + { + $items:(src .=. cfromIndex shOut "ix" "tmp") + $items:(setOut "ix" .=. get fullsrc) + } + } + |] + where + (slIn, _, cosrc) = cslice slix "cosrc" + (sh, _, _) = locals "shIn" (undefined :: sh) + (src, _, _) = locals "src" (undefined :: sl) + fullsrc = reverse (combine slix (reverse src) (reverse cosrc)) + (texIn, argIn) = environment dev aenv + (argOut, shOut, setOut) = writeArray "Out" (undefined :: Array sl a) + +combine :: SliceIndex slix sl co dim -> [a] -> [a] -> [a] +combine SliceNil [] [] = [] +combine (SliceAll sl) (x:xs) ys = x:(combine sl xs ys) +combine (SliceFixed sl) xs (y:ys) = y:(combine sl xs ys) +combine _ _ _ = $internalError "mkToSeq" "Something went wrong with the slice index." + diff --git a/Data/Array/Accelerate/CUDA/CodeGen/Type.hs b/Data/Array/Accelerate/CUDA/CodeGen/Type.hs --- a/Data/Array/Accelerate/CUDA/CodeGen/Type.hs +++ b/Data/Array/Accelerate/CUDA/CodeGen/Type.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen --- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller +-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell @@ -21,48 +21,72 @@ accType, accTypeTex, segmentsType, expType, eltType, eltTypeTex, eltSizeOf, - -- primitive bits... - codegenIntegralType, codegenScalarType + -- working with reified dictionaries + TypeOf(..), + signedIntegralNum, unsignedIntegralNum, ) where -- friends +import Data.Array.Accelerate.Array.Data +import Data.Array.Accelerate.Error import Data.Array.Accelerate.Type import Data.Array.Accelerate.Trafo import qualified Data.Array.Accelerate.Array.Sugar as Sugar import qualified Data.Array.Accelerate.Analysis.Type as Sugar -- libraries +import Data.Bits import Language.C.Quote.CUDA +import qualified Data.Typeable as T import qualified Language.C as C -#include "accelerate.h" +class TypeOf a where + typeOf :: a -> C.Type + texTypeOf :: a -> C.Type -typename :: String -> C.Type -typename name = [cty| typename $id:name |] +instance TypeOf (ScalarType a) where + typeOf = cScalarType + texTypeOf = cScalarTypeTex +instance TypeOf (NumType a) where + typeOf = cNumType + texTypeOf = cNumTypeTex + +instance TypeOf (IntegralType a) where + typeOf = cIntegralType + texTypeOf = cIntegralTypeTex + +instance TypeOf (FloatingType a) where + typeOf = cFloatingType + texTypeOf = cFloatingTypeTex + +instance TypeOf (NonNumType a) where + typeOf = cNonNumType + texTypeOf = cNonNumTypeTex + + -- Surface element types -- --------------------- - accType :: DelayedOpenAcc aenv (Sugar.Array dim e) -> [C.Type] -accType = codegenTupleType . Sugar.delayedAccType +accType = cTupleType . Sugar.delayedAccType expType :: DelayedOpenExp aenv env t -> [C.Type] -expType = codegenTupleType . Sugar.preExpType Sugar.delayedAccType +expType = cTupleType . Sugar.preExpType Sugar.delayedAccType segmentsType :: DelayedOpenAcc aenv (Sugar.Segments i) -> C.Type segmentsType seg | [s] <- accType seg = s - | otherwise = INTERNAL_ERROR(error) "accType" "non-scalar segment type" + | otherwise = $internalError "accType" "non-scalar segment type" eltType :: Sugar.Elt a => a {- dummy -} -> [C.Type] -eltType = codegenTupleType . Sugar.eltType +eltType = cTupleType . Sugar.eltType eltTypeTex :: Sugar.Elt a => a {- dummy -} -> [C.Type] -eltTypeTex = codegenTupleTex . Sugar.eltType +eltTypeTex = cTupleTypeTex . Sugar.eltType eltSizeOf :: Sugar.Elt a => a {- dummy -} -> [Int] eltSizeOf = sizeOf' . Sugar.eltType @@ -73,110 +97,131 @@ sizeOf' (PairTuple a b) = sizeOf' a ++ sizeOf' b --- Implementation --- -codegenTupleType :: TupleType a -> [C.Type] -codegenTupleType UnitTuple = [] -codegenTupleType (SingleTuple ty) = [codegenScalarType ty] -codegenTupleType (PairTuple t1 t0) = codegenTupleType t1 ++ codegenTupleType t0 -codegenScalarType :: ScalarType a -> C.Type -codegenScalarType (NumScalarType ty) = codegenNumType ty -codegenScalarType (NonNumScalarType ty) = codegenNonNumType ty +cTupleType :: TupleType a -> [C.Type] +cTupleType UnitTuple = [] +cTupleType (SingleTuple ty) = [cScalarType ty] +cTupleType (PairTuple t1 t0) = cTupleType t1 ++ cTupleType t0 -codegenNumType :: NumType a -> C.Type -codegenNumType (IntegralNumType ty) = codegenIntegralType ty -codegenNumType (FloatingNumType ty) = codegenFloatingType ty +cScalarType :: ScalarType a -> C.Type +cScalarType (NumScalarType ty) = cNumType ty +cScalarType (NonNumScalarType ty) = cNonNumType ty -codegenIntegralType :: IntegralType a -> C.Type -codegenIntegralType (TypeInt8 _) = typename "Int8" -codegenIntegralType (TypeInt16 _) = typename "Int16" -codegenIntegralType (TypeInt32 _) = typename "Int32" -codegenIntegralType (TypeInt64 _) = typename "Int64" -codegenIntegralType (TypeWord8 _) = typename "Word8" -codegenIntegralType (TypeWord16 _) = typename "Word16" -codegenIntegralType (TypeWord32 _) = typename "Word32" -codegenIntegralType (TypeWord64 _) = typename "Word64" -codegenIntegralType (TypeCShort _) = [cty|short|] -codegenIntegralType (TypeCUShort _) = [cty|unsigned short|] -codegenIntegralType (TypeCInt _) = [cty|int|] -codegenIntegralType (TypeCUInt _) = [cty|unsigned int|] -codegenIntegralType (TypeCLong _) = [cty|long int|] -codegenIntegralType (TypeCULong _) = [cty|unsigned long int|] -codegenIntegralType (TypeCLLong _) = [cty|long long int|] -codegenIntegralType (TypeCULLong _) = [cty|unsigned long long int|] --- XXX: GHC's inbuilt CPP system can't handle stringification -codegenIntegralType (TypeInt _) = typename $ "Int" ++ show (SIZEOF_HTYPE_INT * 8 :: Int) -codegenIntegralType (TypeWord _) = typename $ "Word" ++ show (SIZEOF_HTYPE_INT * 8 :: Int) +cNumType :: NumType a -> C.Type +cNumType (IntegralNumType ty) = cIntegralType ty +cNumType (FloatingNumType ty) = cFloatingType ty -codegenFloatingType :: FloatingType a -> C.Type -codegenFloatingType (TypeFloat _) = [cty|float|] -codegenFloatingType (TypeCFloat _) = [cty|float|] -codegenFloatingType (TypeDouble _) = [cty|double|] -codegenFloatingType (TypeCDouble _) = [cty|double|] +cIntegralType :: IntegralType a -> C.Type +cIntegralType (TypeInt8 _) = typename "Int8" +cIntegralType (TypeInt16 _) = typename "Int16" +cIntegralType (TypeInt32 _) = typename "Int32" +cIntegralType (TypeInt64 _) = typename "Int64" +cIntegralType (TypeWord8 _) = typename "Word8" +cIntegralType (TypeWord16 _) = typename "Word16" +cIntegralType (TypeWord32 _) = typename "Word32" +cIntegralType (TypeWord64 _) = typename "Word64" +cIntegralType (TypeCShort _) = [cty|short|] +cIntegralType (TypeCUShort _) = [cty|unsigned short|] +cIntegralType (TypeCInt _) = [cty|int|] +cIntegralType (TypeCUInt _) = [cty|unsigned int|] +cIntegralType (TypeCLong _) = [cty|long int|] +cIntegralType (TypeCULong _) = [cty|unsigned long int|] +cIntegralType (TypeCLLong _) = [cty|long long int|] +cIntegralType (TypeCULLong _) = [cty|unsigned long long int|] +cIntegralType (TypeInt _) = typename (T.showsTypeRep (T.typeOf (undefined::HTYPE_INT)) "") +cIntegralType (TypeWord _) = typename (T.showsTypeRep (T.typeOf (undefined::HTYPE_WORD)) "") -codegenNonNumType :: NonNumType a -> C.Type -codegenNonNumType (TypeBool _) = typename "Word8" -codegenNonNumType (TypeChar _) = typename "Word32" -codegenNonNumType (TypeCChar _) = [cty|char|] -codegenNonNumType (TypeCSChar _) = [cty|signed char|] -codegenNonNumType (TypeCUChar _) = [cty|unsigned char|] +cFloatingType :: FloatingType a -> C.Type +cFloatingType (TypeFloat _) = [cty|float|] +cFloatingType (TypeCFloat _) = [cty|float|] +cFloatingType (TypeDouble _) = [cty|double|] +cFloatingType (TypeCDouble _) = [cty|double|] +cNonNumType :: NonNumType a -> C.Type +cNonNumType (TypeBool _) = typename "Word8" +cNonNumType (TypeChar _) = typename "Word32" +cNonNumType (TypeCChar _) = [cty|char|] +cNonNumType (TypeCSChar _) = [cty|signed char|] +cNonNumType (TypeCUChar _) = [cty|unsigned char|] + -- Texture types -- ------------- accTypeTex :: DelayedOpenAcc aenv (Sugar.Array dim e) -> [C.Type] -accTypeTex = codegenTupleTex . Sugar.delayedAccType +accTypeTex = cTupleTypeTex . Sugar.delayedAccType -- Implementation -- -codegenTupleTex :: TupleType a -> [C.Type] -codegenTupleTex UnitTuple = [] -codegenTupleTex (SingleTuple t) = [codegenScalarTex t] -codegenTupleTex (PairTuple t1 t0) = codegenTupleTex t1 ++ codegenTupleTex t0 +cTupleTypeTex :: TupleType a -> [C.Type] +cTupleTypeTex UnitTuple = [] +cTupleTypeTex (SingleTuple t) = [cScalarTypeTex t] +cTupleTypeTex (PairTuple t1 t0) = cTupleTypeTex t1 ++ cTupleTypeTex t0 -codegenScalarTex :: ScalarType a -> C.Type -codegenScalarTex (NumScalarType ty) = codegenNumTex ty -codegenScalarTex (NonNumScalarType ty) = codegenNonNumTex ty; +cScalarTypeTex :: ScalarType a -> C.Type +cScalarTypeTex (NumScalarType ty) = cNumTypeTex ty +cScalarTypeTex (NonNumScalarType ty) = cNonNumTypeTex ty; -codegenNumTex :: NumType a -> C.Type -codegenNumTex (IntegralNumType ty) = codegenIntegralTex ty -codegenNumTex (FloatingNumType ty) = codegenFloatingTex ty +cNumTypeTex :: NumType a -> C.Type +cNumTypeTex (IntegralNumType ty) = cIntegralTypeTex ty +cNumTypeTex (FloatingNumType ty) = cFloatingTypeTex ty -codegenIntegralTex :: IntegralType a -> C.Type -codegenIntegralTex (TypeInt8 _) = typename "TexInt8" -codegenIntegralTex (TypeInt16 _) = typename "TexInt16" -codegenIntegralTex (TypeInt32 _) = typename "TexInt32" -codegenIntegralTex (TypeInt64 _) = typename "TexInt64" -codegenIntegralTex (TypeWord8 _) = typename "TexWord8" -codegenIntegralTex (TypeWord16 _) = typename "TexWord16" -codegenIntegralTex (TypeWord32 _) = typename "TexWord32" -codegenIntegralTex (TypeWord64 _) = typename "TexWord64" -codegenIntegralTex (TypeCShort _) = typename "TexCShort" -codegenIntegralTex (TypeCUShort _) = typename "TexCUShort" -codegenIntegralTex (TypeCInt _) = typename "TexCInt" -codegenIntegralTex (TypeCUInt _) = typename "TexCUInt" -codegenIntegralTex (TypeCLong _) = typename "TexCLong" -codegenIntegralTex (TypeCULong _) = typename "TexCULong" -codegenIntegralTex (TypeCLLong _) = typename "TexCLLong" -codegenIntegralTex (TypeCULLong _) = typename "TexCULLong" --- XXX: GHC's inbuilt CPP system can't handle stringification -codegenIntegralTex (TypeInt _) = typename $ "TexInt" ++ show (SIZEOF_HTYPE_INT * 8 :: Int) -codegenIntegralTex (TypeWord _) = typename $ "TexWord" ++ show (SIZEOF_HTYPE_INT * 8 :: Int) +cIntegralTypeTex :: IntegralType a -> C.Type +cIntegralTypeTex (TypeInt8 _) = typename "TexInt8" +cIntegralTypeTex (TypeInt16 _) = typename "TexInt16" +cIntegralTypeTex (TypeInt32 _) = typename "TexInt32" +cIntegralTypeTex (TypeInt64 _) = typename "TexInt64" +cIntegralTypeTex (TypeWord8 _) = typename "TexWord8" +cIntegralTypeTex (TypeWord16 _) = typename "TexWord16" +cIntegralTypeTex (TypeWord32 _) = typename "TexWord32" +cIntegralTypeTex (TypeWord64 _) = typename "TexWord64" +cIntegralTypeTex (TypeCShort _) = typename "TexCShort" +cIntegralTypeTex (TypeCUShort _) = typename "TexCUShort" +cIntegralTypeTex (TypeCInt _) = typename "TexCInt" +cIntegralTypeTex (TypeCUInt _) = typename "TexCUInt" +cIntegralTypeTex (TypeCLong _) = typename "TexCLong" +cIntegralTypeTex (TypeCULong _) = typename "TexCULong" +cIntegralTypeTex (TypeCLLong _) = typename "TexCLLong" +cIntegralTypeTex (TypeCULLong _) = typename "TexCULLong" +cIntegralTypeTex (TypeInt _) = typename ("TexInt" ++ show (finiteBitSize (undefined::Int))) +cIntegralTypeTex (TypeWord _) = typename ("TexWord" ++ show (finiteBitSize (undefined::Word))) -codegenFloatingTex :: FloatingType a -> C.Type -codegenFloatingTex (TypeFloat _) = typename "TexFloat" -codegenFloatingTex (TypeCFloat _) = typename "TexCFloat" -codegenFloatingTex (TypeDouble _) = typename "TexDouble" -codegenFloatingTex (TypeCDouble _) = typename "TexCDouble" +cFloatingTypeTex :: FloatingType a -> C.Type +cFloatingTypeTex (TypeFloat _) = typename "TexFloat" +cFloatingTypeTex (TypeCFloat _) = typename "TexCFloat" +cFloatingTypeTex (TypeDouble _) = typename "TexDouble" +cFloatingTypeTex (TypeCDouble _) = typename "TexCDouble" -codegenNonNumTex :: NonNumType a -> C.Type -codegenNonNumTex (TypeBool _) = typename "TexWord8" -codegenNonNumTex (TypeChar _) = typename "TexWord32" -codegenNonNumTex (TypeCChar _) = typename "TexCChar" -codegenNonNumTex (TypeCSChar _) = typename "TexCSChar" -codegenNonNumTex (TypeCUChar _) = typename "TexCUChar" +cNonNumTypeTex :: NonNumType a -> C.Type +cNonNumTypeTex (TypeBool _) = typename "TexWord8" +cNonNumTypeTex (TypeChar _) = typename "TexWord32" +cNonNumTypeTex (TypeCChar _) = typename "TexCChar" +cNonNumTypeTex (TypeCSChar _) = typename "TexCSChar" +cNonNumTypeTex (TypeCUChar _) = typename "TexCUChar" + + +-- Utilities +-- --------- + +typename :: String -> C.Type +typename name = [cty| typename $id:name |] + +signedIntegralNum :: IntegralType a -> Bool +signedIntegralNum t = + case t of + TypeInt _ -> True + TypeInt8 _ -> True + TypeInt16 _ -> True + TypeInt32 _ -> True + TypeInt64 _ -> True + TypeCShort _ -> True + TypeCInt _ -> True + TypeCLong _ -> True + TypeCLLong _ -> True + _ -> False + +unsignedIntegralNum :: IntegralType a -> Bool +unsignedIntegralNum = not . signedIntegralNum diff --git a/Data/Array/Accelerate/CUDA/Compile.hs b/Data/Array/Accelerate/CUDA/Compile.hs --- a/Data/Array/Accelerate/CUDA/Compile.hs +++ b/Data/Array/Accelerate/CUDA/Compile.hs @@ -3,11 +3,12 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} -- | -- Module : Data.Array.Accelerate.CUDA.Compile --- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller +-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell @@ -18,14 +19,13 @@ module Data.Array.Accelerate.CUDA.Compile ( -- * generate and compile kernels to realise a computation - compileAcc, compileAfun + compileAcc, compileAfun, ) where -#include "accelerate.h" - -- friends -import Data.Array.Accelerate.Tuple +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Lifetime import Data.Array.Accelerate.Trafo import Data.Array.Accelerate.CUDA.AST import Data.Array.Accelerate.CUDA.State @@ -35,12 +35,11 @@ import Data.Array.Accelerate.CUDA.Analysis.Launch import Data.Array.Accelerate.CUDA.Foreign.Import ( canExecuteAcc, canExecuteExp ) import Data.Array.Accelerate.CUDA.Persistent as KT -import qualified Data.Array.Accelerate.CUDA.FullList as FL +import qualified Data.Array.Accelerate.FullList as FL import qualified Data.Array.Accelerate.CUDA.Debug as D -- libraries import Numeric -import Prelude hiding ( exp, scanl, scanr ) import Control.Applicative hiding ( Const ) import Control.Exception import Control.Monad @@ -50,6 +49,7 @@ import Control.Concurrent import Crypto.Hash.MD5 ( hashlazy ) import Data.List ( intercalate ) +import Data.Bits import Data.Maybe import Data.Monoid import System.Directory @@ -58,9 +58,7 @@ import System.IO import System.IO.Error import System.IO.Unsafe -import System.Time import System.Process -import System.Mem.Weak import Text.PrettyPrint.Mainland ( ppr, renderCompact, displayLazyText ) import qualified Data.ByteString as B import qualified Data.Text.Lazy as T @@ -69,13 +67,21 @@ import qualified Control.Concurrent.MSem as Q import qualified Foreign.CUDA.Driver as CUDA import qualified Foreign.CUDA.Analysis as CUDA +import Prelude hiding ( exp, scanl, scanr ) import GHC.Conc ( getNumProcessors ) -#ifdef VERSION_unix +#ifdef ACCELERATE_DEBUG +import System.Time +#endif + +-- Multiplatform support for dealing with external process spawning +#if defined(UNIX) import System.Posix.Process +#elif defined(WIN32) +import System.Win32.Process hiding ( ProcessHandle ) #else -import System.Win32.Process +#error "I don't know what operating system I am" #endif import Paths_accelerate_cuda ( getDataDir ) @@ -114,7 +120,7 @@ -- are merged at every step. -- traverseAcc :: forall aenv arrs. DelayedOpenAcc aenv arrs -> CIO (ExecOpenAcc aenv arrs) - traverseAcc Delayed{} = INTERNAL_ERROR(error) "compileOpenAcc" "unexpected delayed array" + traverseAcc Delayed{} = $internalError "compileOpenAcc" "unexpected delayed array" traverseAcc topAcc@(Manifest pacc) = case pacc of -- Environment and control flow @@ -127,7 +133,7 @@ Aprj ix tup -> node =<< liftA (Aprj ix) <$> travA tup -- Foreign - Aforeign ff afun a -> node =<< foreignA ff afun a + Aforeign ff afun a -> foreignA ff afun a -- Array injection Unit e -> node =<< liftA Unit <$> travE e @@ -161,6 +167,9 @@ Stencil2 f b1 a1 b2 a2 -> exec =<< liftA3 stencil2 <$> travF f <*> travA a1 <*> travA a2 where stencil2 f' a1' a2' = Stencil2 f' b1 a1' b2 a2' + -- Loops + -- Collect l -> ExecSeq <$> compileOpenSeq l + where use :: ArraysR a -> a -> CIO () use ArraysRunit () = return () @@ -191,121 +200,227 @@ travAtup NilAtup = return (pure NilAtup) travAtup (SnocAtup t a) = liftA2 SnocAtup <$> travAtup t <*> travA a + travE :: DelayedOpenExp env aenv e + -> CIO (Free aenv, PreOpenExp ExecOpenAcc env aenv e) + travE = compileOpenExp + travF :: DelayedOpenFun env aenv t -> CIO (Free aenv, PreOpenFun ExecOpenAcc env aenv t) travF (Body b) = liftA Body <$> travE b travF (Lam f) = liftA Lam <$> travF f noKernel :: FL.FullList () (AccKernel a) - noKernel = FL.FL () (INTERNAL_ERROR(error) "compile" "no kernel module for this node") FL.Nil + noKernel = FL.FL () ($internalError "compile" "no kernel module for this node") FL.Nil fullOfList :: [a] -> FL.FullList () a - fullOfList [] = INTERNAL_ERROR(error) "fullList" "empty list" + fullOfList [] = $internalError "fullList" "empty list" fullOfList [x] = FL.singleton () x fullOfList (x:xs) = FL.cons () x (fullOfList xs) - -- If it is a foreign call for the CUDA backend, don't bother compiling - -- the pure version + -- If the foreign function targets this backend, drop the remaining + -- alternatives from the AST. Similarly, we drop the foreign node if it + -- does not target this backend. -- - foreignA :: (Arrays a, Arrays r, Foreign f) - => f a r - -> DelayedAfun (a -> r) - -> DelayedOpenAcc aenv a - -> CIO (Free aenv, PreOpenAcc ExecOpenAcc aenv r) - foreignA ff afun a = case canExecuteAcc ff of - Nothing -> liftA2 (Aforeign ff) <$> pure <$> compileAfun afun <*> travA a - Just _ -> liftA (Aforeign ff err) <$> travA a + foreignA :: (Arrays as, Arrays bs, Foreign asm) + => asm (as -> bs) + -> DelayedAfun (as -> bs) + -> DelayedOpenAcc aenv as + -> CIO (ExecOpenAcc aenv bs) + foreignA ff afun a = + case canExecuteAcc ff of + Nothing -> traverseAcc $ Manifest (Apply (weaken absurd afun) a) + Just{} -> node =<< liftA (Aforeign ff err) <$> travA a where - err = INTERNAL_ERROR(error) "compile" "Executing pure version of a CUDA foreign function" + absurd :: Idx () t -> Idx env t + absurd = absurd + err = $internalError "Aforeign" "failed to recover foreign function a second time" - -- Traverse a scalar expression +-- Traverse a scalar expression +-- +compileOpenExp + :: DelayedOpenExp env aenv e + -> CIO (Free aenv, PreOpenExp ExecOpenAcc env aenv e) +compileOpenExp topExp = + case topExp of + Var ix -> return $ pure (Var ix) + Const c -> return $ pure (Const c) + PrimConst c -> return $ pure (PrimConst c) + IndexAny -> return $ pure IndexAny + IndexNil -> return $ pure IndexNil + Foreign ff f x -> foreignE ff f x -- + Let a b -> liftA2 Let <$> travE a <*> travE b + IndexCons t h -> liftA2 IndexCons <$> travE t <*> travE h + IndexHead h -> liftA IndexHead <$> travE h + IndexTail t -> liftA IndexTail <$> travE t + IndexSlice slix x s -> liftA2 (IndexSlice slix) <$> travE x <*> travE s + IndexFull slix x s -> liftA2 (IndexFull slix) <$> travE x <*> travE s + ToIndex s i -> liftA2 ToIndex <$> travE s <*> travE i + FromIndex s i -> liftA2 FromIndex <$> travE s <*> travE i + Tuple t -> liftA Tuple <$> travT t + Prj ix e -> liftA (Prj ix) <$> travE e + Cond p t e -> liftA3 Cond <$> travE p <*> travE t <*> travE e + While p f x -> liftA3 While <$> travF p <*> travF f <*> travE x + PrimApp f e -> liftA (PrimApp f) <$> travE e + Index a e -> liftA2 Index <$> travA a <*> travE e + LinearIndex a e -> liftA2 LinearIndex <$> travA a <*> travE e + Shape a -> liftA Shape <$> travA a + ShapeSize e -> liftA ShapeSize <$> travE e + Intersect x y -> liftA2 Intersect <$> travE x <*> travE y + Union x y -> liftA2 Union <$> travE x <*> travE y + + where + travA :: (Shape sh, Elt e) + => DelayedOpenAcc aenv (Array sh e) + -> CIO (Free aenv, ExecOpenAcc aenv (Array sh e)) + travA a = do + a' <- compileOpenAcc a + return $ (bind a', a') + + travT :: Tuple (DelayedOpenExp env aenv) t + -> CIO (Free aenv, Tuple (PreOpenExp ExecOpenAcc env aenv) t) + travT NilTup = return (pure NilTup) + travT (SnocTup t e) = liftA2 SnocTup <$> travT t <*> travE e + travE :: DelayedOpenExp env aenv e -> CIO (Free aenv, PreOpenExp ExecOpenAcc env aenv e) - travE exp = - case exp of - Var ix -> return $ pure (Var ix) - Const c -> return $ pure (Const c) - PrimConst c -> return $ pure (PrimConst c) - IndexAny -> return $ pure IndexAny - IndexNil -> return $ pure IndexNil - Foreign ff f x -> foreignE ff f x - -- - Let a b -> liftA2 Let <$> travE a <*> travE b - IndexCons t h -> liftA2 IndexCons <$> travE t <*> travE h - IndexHead h -> liftA IndexHead <$> travE h - IndexTail t -> liftA IndexTail <$> travE t - IndexSlice slix x s -> liftA2 (IndexSlice slix) <$> travE x <*> travE s - IndexFull slix x s -> liftA2 (IndexFull slix) <$> travE x <*> travE s - ToIndex s i -> liftA2 ToIndex <$> travE s <*> travE i - FromIndex s i -> liftA2 FromIndex <$> travE s <*> travE i - Tuple t -> liftA Tuple <$> travT t - Prj ix e -> liftA (Prj ix) <$> travE e - Cond p t e -> liftA3 Cond <$> travE p <*> travE t <*> travE e - While p f x -> liftA3 While <$> travF p <*> travF f <*> travE x - PrimApp f e -> liftA (PrimApp f) <$> travE e - Index a e -> liftA2 Index <$> travA a <*> travE e - LinearIndex a e -> liftA2 LinearIndex <$> travA a <*> travE e - Shape a -> liftA Shape <$> travA a - ShapeSize e -> liftA ShapeSize <$> travE e - Intersect x y -> liftA2 Intersect <$> travE x <*> travE y - - where - travA :: (Shape sh, Elt e) - => DelayedOpenAcc aenv (Array sh e) - -> CIO (Free aenv, ExecOpenAcc aenv (Array sh e)) - travA a = do - a' <- traverseAcc a - return $ (bind a', a') + travE = compileOpenExp - travT :: Tuple (DelayedOpenExp env aenv) t - -> CIO (Free aenv, Tuple (PreOpenExp ExecOpenAcc env aenv) t) - travT NilTup = return (pure NilTup) - travT (SnocTup t e) = liftA2 SnocTup <$> travT t <*> travE e + travF :: DelayedOpenFun env aenv t -> CIO (Free aenv, PreOpenFun ExecOpenAcc env aenv t) + travF (Body b) = liftA Body <$> travE b + travF (Lam f) = liftA Lam <$> travF f - travF :: DelayedOpenFun env aenv t -> CIO (Free aenv, PreOpenFun ExecOpenAcc env aenv t) - travF (Body b) = liftA Body <$> travE b - travF (Lam f) = liftA Lam <$> travF f + foreignE :: (Elt a, Elt b, Foreign asm) + => asm (a -> b) + -> DelayedFun () (a -> b) + -> DelayedOpenExp env aenv a + -> CIO (Free aenv, PreOpenExp ExecOpenAcc env aenv b) + foreignE ff f x = case canExecuteExp ff of + -- If it's a foreign function that we can generate code from, just + -- leave it alone. As the pure function is closed, the array + -- environment needs to be replaced with one of the right type. + -- + Just _ -> liftA2 (Foreign ff) <$> pure <$> snd <$> travF f <*> travE x - foreignE :: (Elt a, Elt b, Foreign f) - => f a b - -> DelayedFun () (a -> b) - -> DelayedOpenExp env aenv a - -> CIO (Free aenv, PreOpenExp ExecOpenAcc env aenv b) - foreignE ff f x = case canExecuteExp ff of - -- If it's a foreign function that we can generate code from, just - -- leave it alone. As the pure function is closed, the array - -- environment needs to be replaced with one of the right type. + -- If the foreign function is not intended for this backend, this node + -- needs to be replaced by a pure accelerate node giving the same + -- result. Due to the lack of an 'apply' node in the scalar language, + -- this is done by substitution. + -- + Nothing -> travE (apply f x) + where + -- Twiddle the environment variables -- - Just _ -> liftA2 (Foreign ff) <$> pure <$> snd <$> travF f <*> travE x + apply :: DelayedFun () (a -> b) -> DelayedOpenExp env aenv a -> DelayedOpenExp env aenv b + apply (Lam (Body b)) e = Let e $ weaken wAcc $ weakenE wExp b + apply _ _ = error "This was a triumph." - -- If the foreign function is not intended for this backend, this node - -- needs to be replaced by a pure accelerate node giving the same - -- result. Due to the lack of an 'apply' node in the scalar language, - -- this is done by substitution. + -- As the expression we want to weaken is closed with respect to the array + -- environment, the index manipulation function becomes a dummy argument. -- - Nothing -> travE (apply f x) - where - -- Twiddle the environment variables - -- - apply :: DelayedFun () (a -> b) -> DelayedOpenExp env aenv a -> DelayedOpenExp env aenv b - apply (Lam (Body b)) e = Let e $ weakenEA rebuildAcc wAcc $ weakenE wExp b - apply _ _ = error "This was a triumph." + wAcc :: Idx () t -> Idx aenv t + wAcc _ = error "I'm making a note here:" - -- As the expression we want to weaken is closed with respect to the array - -- environment, the index manipulation function becomes a dummy argument. + wExp :: Idx ((),a) t -> Idx (env,a) t + wExp ZeroIdx = ZeroIdx + wExp _ = error "HUGE SUCCESS" + + bind :: (Shape sh, Elt e) => ExecOpenAcc aenv (Array sh e) -> Free aenv + bind (ExecAcc _ _ (Avar ix)) = freevar ix + bind _ = $internalError "bind" "expected array variable" + +{-- +compileSeq :: DelayedSeq a -> CIO (ExecSeq a) +compileSeq (DelayedSeq aenv s) = ExecS <$> compileExtend aenv <*> compileOpenSeq s + where + compileExtend :: Extend DelayedOpenAcc aenv aenv' -> CIO (Extend ExecOpenAcc aenv aenv') + compileExtend BaseEnv = return BaseEnv + compileExtend (PushEnv e a) = PushEnv <$> compileExtend e <*> compileOpenAcc a + +compileOpenSeq + :: forall aenv lenv arrs'. + PreOpenSeq DelayedOpenAcc aenv lenv arrs' + -> CIO (ExecOpenSeq aenv lenv arrs') +compileOpenSeq l = + case l of + Producer p l' -> ExecP <$> compileP p <*> compileOpenSeq l' + Consumer c -> ExecC <$> compileC c + Reify ix -> return $ ExecR ix Nothing + where + compileP :: forall a. Producer DelayedOpenAcc aenv lenv a -> CIO (ExecP aenv lenv a) + compileP p = + case p of + ToSeq slix (_ :: proxy slix) acc -> do + case acc of + -- In the case of converting an array that has not already been copied + -- to device memory, we are smart and treat it specially. + Manifest (Use a) -> return $ ExecUseLazy slix (toArr a) ([] :: [slix]) + _ -> do + (free1, acc') <- travA acc + let gamma = makeEnvMap free1 + dev <- asks deviceProperties + -- The array computation passed to 'toSeq' needs to be treated + -- specially. We don't want the entire array to be made manifest + -- if we can help it. In the event it is a delayed array, we make + -- the subarrays manifest one at a time and feed them to the 'Seq' + -- computation. -- - wAcc :: Idx () t -> Idx aenv t - wAcc _ = error "I'm making a note here:" + -- For the purposes of device configuration and launching, this can + -- be seen to work like 'Slice', even though in reality it + -- resembles a delayed 'Slice'. + let acc'' = Manifest (Slice slix acc (Const (zeroSlice slix) :: DelayedExp aenv slix)) - wExp :: Idx ((),a) t -> Idx (env,a) t - wExp ZeroIdx = ZeroIdx - wExp _ = error "HUGE SUCCESS" + kernel <- build1 acc'' (codegenToSeq slix dev acc gamma) + return $ ExecToSeq slix acc' kernel gamma ([] :: [slix]) + StreamIn xs -> return $ ExecStreamIn xs + MapSeq f x -> do + f' <- compileOpenAfun f + return $ ExecMap f' x + ZipWithSeq f x y -> do + f' <- compileOpenAfun f + return $ ExecZipWith f' x y + ScanSeq f a0 x -> do + (_, a0') <- travE a0 + (_, f') <- travF f + return $ ExecScanSeq f' a0' x Nothing + ChunkedMapSeq{} -> error "TODO: @fmma needs to finish this..." - bind :: (Shape sh, Elt e) => ExecOpenAcc aenv (Array sh e) -> Free aenv - bind (ExecAcc _ _ (Avar ix)) = freevar ix - bind _ = INTERNAL_ERROR(error) "bind" "expected array variable" + compileC :: forall a. Consumer DelayedOpenAcc aenv lenv a -> CIO (ExecC aenv lenv a) + compileC c = + case c of + FoldSeq f a0 x -> do + (_, a0') <- travE a0 + (_, f') <- travF f + return $ ExecFoldSeq f' a0' x Nothing + FoldSeqFlatten f acc x -> do + acc' <- compileOpenAcc acc + f' <- compileOpenAfun f + return $ ExecFoldSeqFlatten f' acc' x Nothing + Stuple t -> ExecStuple <$> compileCT t + compileCT :: forall t. Atuple (Consumer DelayedOpenAcc aenv lenv) t -> CIO (Atuple (ExecC aenv lenv) t) + compileCT NilAtup = return NilAtup + compileCT (SnocAtup t c) = SnocAtup <$> compileCT t <*> compileC c + travA :: DelayedOpenAcc aenv a -> CIO (Free aenv, ExecOpenAcc aenv a) + travA acc = case acc of + Manifest{} -> pure <$> compileOpenAcc acc + Delayed{..} -> liftA2 (const EmbedAcc) <$> travF indexD <*> travE extentD + + travE :: DelayedOpenExp env aenv e + -> CIO (Free aenv, PreOpenExp ExecOpenAcc env aenv e) + travE = compileOpenExp + + travF :: DelayedOpenFun env aenv t -> CIO (Free aenv, PreOpenFun ExecOpenAcc env aenv t) + travF (Body b) = liftA Body <$> travE b + travF (Lam f) = liftA Lam <$> travF f + + zeroSlice :: SliceIndex slix sl co sh -> slix + zeroSlice SliceNil = () + zeroSlice (SliceFixed sl) = (zeroSlice sl, 0) + zeroSlice (SliceAll sl) = (zeroSlice sl, ()) +--} + + -- Applicative -- ----------- -- @@ -335,7 +450,7 @@ let (cta,blocks,smem) = launchConfig acc dev occ (mdl,fun,occ) = unsafePerformIO $ do m <- link context table key - f <- CUDA.getFun m entry + f <- withLifetime m $ flip CUDA.getFun entry l <- CUDA.requires f CUDA.MaxKernelThreadsPerBlock o <- determineOccupancy acc dev f l D.when D.dump_cc (stats entry f o) @@ -359,16 +474,16 @@ -- make sure kernel/stats are printed together. Use 'intercalate' rather -- than 'unlines' to avoid a trailing newline. -- - message $ intercalate "\n ... " [msg1, msg2] + message $ intercalate "\n ... " [msg1, msg2] -- Link a compiled binary and update the associated kernel entry in the hash -- table. This may entail waiting for the external compilation process to -- complete. If successful, the temporary files are removed. -- -link :: Context -> KernelTable -> KernelKey -> IO CUDA.Module +link :: Context -> KernelTable -> KernelKey -> IO (Lifetime CUDA.Module) link context table key = - let intErr = INTERNAL_ERROR(error) "link" "missing kernel entry" + let intErr = $internalError "link" "missing kernel entry" ctx = deviceContext context weak_ctx = weakContext context in do @@ -384,17 +499,18 @@ -- the binary object. -- message "waiting for nvcc..." - takeMVar done let cubin = replaceExtension cufile ".cubin" + () <- takeMVar done bin <- B.readFile cubin mdl <- CUDA.loadData bin - addFinalizer mdl (module_finalizer weak_ctx key mdl) + lmdl <- newLifetime mdl + addFinalizer lmdl (module_finalizer weak_ctx key lmdl) -- Update hash tables and stash the binary object into the persistent -- cache -- - KT.insert table key $! KernelObject bin (FL.singleton ctx mdl) - KT.persist cubin key + KT.insert table key $! KernelObject bin (FL.singleton ctx lmdl) + KT.persist table cubin key -- Remove temporary build products. -- If compiling kernels with debugging symbols, leave the source files @@ -405,25 +521,30 @@ removeDirectory (dropFileName cufile) `catchIOError` \_ -> return () -- directory not empty - return mdl + return lmdl -- If we get a real object back, then this will already be in the -- persistent cache, since either it was just read in from there, or we -- had to generate new code and the link step above has added it. -- KernelObject bin active - | Just mdl <- FL.lookup ctx active -> return mdl + | Just lmdl <- FL.lookup ctx active -> return lmdl | otherwise -> do message "re-linking module for current context" mdl <- CUDA.loadData bin - addFinalizer mdl (module_finalizer weak_ctx key mdl) - KT.insert table key $! KernelObject bin (FL.cons ctx mdl active) - return mdl + lmdl <- newLifetime mdl + addFinalizer lmdl (module_finalizer weak_ctx key lmdl) + KT.insert table key $! KernelObject bin (FL.cons ctx lmdl active) + return lmdl -- Generate and compile code for a single open array expression -- -compile :: KernelTable -> CUDA.DeviceProperties -> CUTranslSkel aenv a -> CIO (String, KernelKey) +compile + :: KernelTable + -> CUDA.DeviceProperties + -> CUTranslSkel aenv a + -> CIO (String, KernelKey) compile table dev cunit = do context <- asks activeContext exists <- isJust `fmap` liftIO (KT.lookup context table key) @@ -452,6 +573,8 @@ compileFlags cufile = do CUDA.Compute m n <- CUDA.computeCapability `fmap` asks deviceProperties ddir <- liftIO getDataDir + warnings <- liftIO $ (&&) <$> D.queryFlag D.dump_cc <*> D.queryFlag D.verbose + debug <- liftIO $ D.queryFlag D.debug_cc return $ filter (not . null) $ [ "-I", ddir "cubits" , "-arch=sm_" ++ show m ++ show n @@ -465,12 +588,10 @@ , machine , cufile ] where - warnings = D.mode D.dump_cc && D.mode D.verbose - debug = D.mode D.debug_cc - machine = case (SIZEOF_HTYPE_INT :: Int) of - 4 -> "-m32" - 8 -> "-m64" - _ -> INTERNAL_ERROR(error) "compileFlags" "unknown 'Int' size" + machine = case finiteBitSize (undefined :: Int) of + 32 -> "-m32" + 64 -> "-m64" + _ -> $internalError "compileFlags" "unknown 'Int' size" -- Open a unique file in the temporary directory used for compilation @@ -483,9 +604,13 @@ createDirectoryIfMissing True dir openTempFile dir template -#ifndef VERSION_unix -getProcessID :: ProcessHandle -> IO ProcessId -getProcessID = getProcessId +#if defined(WIN32) +-- TLM: On windows, how do we get either the ProcessID or ProcessHandle of the +-- current process? For new, just use a dummy value (the sound of +-- disappearing down a rabbit hole...) +-- +getProcessID :: IO ProcessId +getProcessID = return 0xaaaa #endif @@ -515,6 +640,10 @@ -- ... and wait for it to complete waitFor pid + -- If compilation fails for some reason, fill the MVar by re-throwing + -- the exception. This prevents the host thread from waiting + -- indefinitely, which then requires the program to be killed manually. + `catch` \(e :: SomeException) -> do putMVar mvar (throw e) ccEnd <- getTime return (diffTime ccBegin ccEnd) @@ -578,9 +707,5 @@ {-# INLINE message #-} message :: MonadIO m => String -> m () -message msg = trace msg $ return () - -{-# INLINE trace #-} -trace :: MonadIO m => String -> m a -> m a -trace msg next = D.message D.dump_cc ("cc: " ++ msg) >> next +message msg = liftIO $ D.traceIO D.dump_cc ("cc: " ++ msg) diff --git a/Data/Array/Accelerate/CUDA/Context.hs b/Data/Array/Accelerate/CUDA/Context.hs --- a/Data/Array/Accelerate/CUDA/Context.hs +++ b/Data/Array/Accelerate/CUDA/Context.hs @@ -3,7 +3,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.CUDA.Context --- Copyright : [2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2013..2014] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell @@ -18,45 +18,45 @@ -- An execution context Context(..), create, push, pop, destroy, - keepAlive, fromDeviceContext + keepAlive, fromDeviceContext, ) where -- friends -import Data.Array.Accelerate.CUDA.Debug ( message, verbose, dump_gc, showFFloatSIBase ) +import Data.Array.Accelerate.CUDA.Debug ( traceIO, verbose, dump_gc, showFFloatSIBase ) import Data.Array.Accelerate.CUDA.Analysis.Device +import Data.Array.Accelerate.Lifetime -- system import Data.Function ( on ) import Control.Exception ( bracket_ ) import Control.Concurrent ( forkIO, threadDelay ) import Control.Monad ( when ) -import GHC.Exts ( Ptr(..), mkWeak# ) -import GHC.Base ( IO(..) ) -import GHC.Weak ( Weak(..) ) +import System.Mem.Weak ( Weak ) import Text.PrettyPrint import qualified Foreign.CUDA.Driver as CUDA hiding ( device ) import qualified Foreign.CUDA.Driver.Context as CUDA +import qualified Foreign.CUDA.Driver.Device as CUDA -- | The execution context -- data Context = Context { - deviceProperties :: {-# UNPACK #-} !CUDA.DeviceProperties, -- information on hardware resources - deviceContext :: {-# UNPACK #-} !CUDA.Context, -- device execution context - weakContext :: {-# UNPACK #-} !(Weak CUDA.Context) -- weak pointer to the context (for memory management) + deviceProperties :: {-# UNPACK #-} !CUDA.DeviceProperties, -- information on hardware resources + deviceContext :: {-# UNPACK #-} !(Lifetime CUDA.Context), -- device execution context + weakContext :: {-# UNPACK #-} !(Weak (Lifetime CUDA.Context)) -- weak pointer to the context (for memory management) } instance Eq Context where (==) = (==) `on` deviceContext - -- | Create a new CUDA context associated with the calling thread -- create :: CUDA.Device -> [CUDA.ContextFlag] -> IO Context create dev flags = do - ctx <- CUDA.create dev flags >> CUDA.pop >>= keepAlive + ctx <- CUDA.create dev flags >> CUDA.pop actx@(Context prp _ _) <- fromDeviceContext dev ctx + _ <- keepAlive actx -- Generated code does not take particular advantage of shared memory, so -- for devices that support it use those banks as an L1 cache instead. @@ -65,30 +65,32 @@ -- TODO: Make the occupancy calculator aware of adjustable shared memory -- when (CUDA.computeCapability prp >= CUDA.Compute 2 0) - $ bracket_ (CUDA.push ctx) CUDA.pop (CUDA.setCacheConfig CUDA.PreferL1) + $ bracket_ (CUDA.push ctx) CUDA.pop (CUDA.setCache CUDA.PreferL1) - message verbose (deviceInfo dev prp) + traceIO verbose (deviceInfo dev prp) return actx -- |Given a device context, construct a new context around it. +-- fromDeviceContext :: CUDA.Device -> CUDA.Context -> IO Context fromDeviceContext dev ctx = do prp <- CUDA.props dev - weak <- mkWeakContext ctx $ do - message dump_gc $ "gc: finalise context #" ++ show (CUDA.useContext ctx) + lctx <- newLifetime ctx + addFinalizer lctx $ do + traceIO dump_gc $ "gc: finalise context #" ++ show (CUDA.useContext ctx) + CUDA.push ctx CUDA.destroy ctx - message dump_gc $ "gc: initialise context #" ++ show (CUDA.useContext ctx) + weak <- mkWeakPtr lctx + traceIO dump_gc $ "gc: initialise context #" ++ show (CUDA.useContext ctx) - return $! Context prp ctx weak + return $! Context prp lctx weak -- | Destroy the specified context. This will fail if the context is more than -- single attachment. -- {-# INLINE destroy #-} destroy :: Context -> IO () -destroy (deviceContext -> ctx) = do - message dump_gc ("gc: destroy context: #" ++ show (CUDA.useContext ctx)) - CUDA.destroy ctx +destroy (deviceContext -> ctx) = finalize ctx -- | Push the given context onto the CPU's thread stack of current contexts. The @@ -96,8 +98,8 @@ -- {-# INLINE push #-} push :: Context -> IO () -push (deviceContext -> ctx) = do - message dump_gc ("gc: push context: #" ++ show (CUDA.useContext ctx)) +push (deviceContext -> lctx) = withLifetime lctx $ \ctx -> do + traceIO dump_gc ("gc: push context: #" ++ show (CUDA.useContext ctx)) CUDA.push ctx @@ -107,17 +109,7 @@ pop :: IO () pop = do ctx <- CUDA.pop - message dump_gc ("gc: pop context: #" ++ show (CUDA.useContext ctx)) - - --- Make a weak pointer to a CUDA context. We need to be careful to put the --- finaliser on the underlying pointer, rather than the box around it as --- 'mkWeak' will do, because unpacking the context will cause the finaliser to --- fire prematurely. --- -mkWeakContext :: CUDA.Context -> IO () -> IO (Weak CUDA.Context) -mkWeakContext c@(CUDA.Context (Ptr c#)) f = IO $ \s -> - case mkWeak# c# c f s of (# s', w #) -> (# s', Weak w #) + traceIO dump_gc ("gc: pop context: #" ++ show (CUDA.useContext ctx)) -- Make sure the GC knows that we want to keep this thing alive past the end of diff --git a/Data/Array/Accelerate/CUDA/Debug.hs b/Data/Array/Accelerate/CUDA/Debug.hs --- a/Data/Array/Accelerate/CUDA/Debug.hs +++ b/Data/Array/Accelerate/CUDA/Debug.hs @@ -1,13 +1,10 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS -fno-warn-incomplete-patterns #-} -{-# OPTIONS -fno-warn-unused-binds #-} -{-# OPTIONS -fno-warn-unused-imports #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS -fno-warn-unused-binds #-} +{-# OPTIONS -fno-warn-unused-imports #-} -- | -- Module : Data.Array.Accelerate.CUDA.Debug --- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller +-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell @@ -20,183 +17,47 @@ module Data.Array.Accelerate.CUDA.Debug ( - showFFloatSIBase, - - message, trace, event, when, unless, mode, timed, elapsed, - verbose, flush_cache, - dump_gc, dump_cc, debug_cc, dump_exec, + module Data.Array.Accelerate.Debug, + module Data.Array.Accelerate.CUDA.Debug, ) where -import Numeric -import Data.List -import Data.Label -import Data.IORef -import Debug.Trace ( traceIO, traceEventIO ) +import Data.Array.Accelerate.Debug hiding ( timed, elapsed ) + +import Control.Concurrent ( forkIO ) import Control.Monad ( void ) import Control.Monad.IO.Class ( liftIO, MonadIO ) -import Control.Concurrent ( forkIO ) +import GHC.Float ( float2Double ) import System.CPUTime import System.IO.Unsafe -import System.Environment -import System.Console.GetOpt -import qualified Foreign.CUDA.Driver.Event as Event -import GHC.Float - - --- ----------------------------------------------------------------------------- --- Pretty-printing - -showFFloatSIBase :: RealFloat a => Maybe Int -> a -> a -> ShowS -showFFloatSIBase p b n - = showString - $ showFFloat p n' (' ':si_unit) - where - n' = n / (b ^^ pow) - pow = (-4) `max` floor (logBase b n) `min` 4 :: Int - si_unit = case pow of - -4 -> "p" - -3 -> "n" - -2 -> "µ" - -1 -> "m" - 0 -> "" - 1 -> "k" - 2 -> "M" - 3 -> "G" - 4 -> "T" - - --- ----------------------------------------------------------------------------- --- Internals - -data Flags = Flags - { - -- debugging - _dump_gc :: !Bool -- garbage collection & memory management - , _dump_cc :: !Bool -- compilation & linking - , _debug_cc :: !Bool -- compile device code with debug symbols - , _dump_exec :: !Bool -- kernel execution - , _verbose :: !Bool -- additional status messages - - -- general options / functionality - , _flush_cache :: !Bool -- delete the persistent cache directory - , _fast_math :: !Bool -- use faster, less accurate maths library operations - } - -$(mkLabels [''Flags]) - -allFlags :: [OptDescr (Flags -> Flags)] -allFlags = - [ - -- debugging - Option [] ["ddump-gc"] (NoArg (set dump_gc True)) "print device memory management trace" - , Option [] ["ddump-cc"] (NoArg (set dump_cc True)) "print generated code and compilation information" - , Option [] ["ddebug-cc"] (NoArg (set debug_cc True)) "generate debug information for device code" - , Option [] ["ddump-exec"] (NoArg (set dump_exec True)) "print kernel execution trace" - , Option [] ["dverbose"] (NoArg (set verbose True)) "print additional information" - - -- functionality / optimisation - , Option [] ["fflush-cache"] (NoArg (set flush_cache True)) "delete the persistent cache directory" - , Option [] ["ffast-math"] (NoArg (set fast_math True)) "use faster, less accurate maths library operations" - ] - -initialise :: IO Flags -initialise = parse `fmap` getArgs - where - defaults = Flags False False False False False False False - parse = foldl parse1 defaults - parse1 opts x = case filter (\(Option _ [f] _ _) -> x `isPrefixOf` ('-':f)) allFlags of - [Option _ _ (NoArg go) _] -> go opts - _ -> opts -- not specified, or ambiguous - -#ifdef ACCELERATE_DEBUG -{-# NOINLINE options #-} -options :: IORef Flags -options = unsafePerformIO $ newIORef =<< initialise -#endif - -{-# INLINE mode #-} -mode :: (Flags :-> Bool) -> Bool -#ifdef ACCELERATE_DEBUG -mode f = unsafePerformIO $ get f `fmap` readIORef options -#else -mode _ = False -#endif - -{-# INLINE message #-} -message :: MonadIO m => (Flags :-> Bool) -> String -> m () -#ifdef ACCELERATE_DEBUG -message f str - = when f . liftIO - $ do psec <- getCPUTime - let sec = fromIntegral psec * 1E-12 :: Double - traceIO $ showFFloat (Just 2) sec (':':str) -#else -message _ _ = return () -#endif - -{-# INLINE event #-} -event :: MonadIO m => (Flags :-> Bool) -> String -> m () -#ifdef ACCELERATE_DEBUG -event f str = when f (liftIO $ traceEventIO str) -#else -event _ _ = return () -#endif - -{-# INLINE trace #-} -trace :: (Flags :-> Bool) -> String -> a -> a -#ifdef ACCELERATE_DEBUG -trace f str next = unsafePerformIO (message f str) `seq` next -#else -trace _ _ next = next -#endif +import Foreign.CUDA.Driver.Stream ( Stream ) +import qualified Foreign.CUDA.Driver.Event as Event -{-# INLINE when #-} -when :: MonadIO m => (Flags :-> Bool) -> m () -> m () -#ifdef ACCELERATE_DEBUG -when f action - | mode f = action - | otherwise = return () -#else -when _ _ = return () -#endif - -{-# INLINE unless #-} -unless :: MonadIO m => (Flags :-> Bool) -> m () -> m () -#ifdef ACCELERATE_DEBUG -unless f action - | mode f = return () - | otherwise = action -#else -unless _ action = action -#endif - -{-# INLINE timed #-} -timed - :: MonadIO m - => (Flags :-> Bool) - -> (Double -> Double -> String) - -> m () - -> m () -timed _f _str action +-- | Execute an action and time the results. The second argument specifies how +-- to format the output string given elapsed GPU and CPU time respectively +-- +timed :: Mode -> (Double -> Double -> String) -> Maybe Stream -> IO () -> IO () #ifdef ACCELERATE_DEBUG - | mode _f - = do - gpuBegin <- liftIO $ Event.create [] - gpuEnd <- liftIO $ Event.create [] - cpuBegin <- liftIO getCPUTime - liftIO $ Event.record gpuBegin Nothing +{-# NOINLINE timed #-} +timed f fmt stream action = do + enabled <- queryFlag f + if enabled + then do + gpuBegin <- Event.create [] + gpuEnd <- Event.create [] + cpuBegin <- getCPUTime + Event.record gpuBegin stream action - liftIO $ Event.record gpuEnd Nothing - cpuEnd <- liftIO getCPUTime + Event.record gpuEnd stream + cpuEnd <- getCPUTime -- Wait for the GPU to finish executing then display the timing execution -- message. Do this in a separate thread so that the remaining kernels can -- be queued asynchronously. -- - _ <- liftIO . forkIO $ do + void . forkIO $ do Event.block gpuEnd diff <- Event.elapsedTime gpuBegin gpuEnd let gpuTime = float2Double $ diff * 1E-3 -- milliseconds @@ -205,13 +66,14 @@ Event.destroy gpuBegin Event.destroy gpuEnd -- - message _f (_str gpuTime cpuTime) - -- - return () + traceIO f (fmt gpuTime cpuTime) - | otherwise + else + action +#else +{-# INLINE timed #-} +timed _ _ _ action = action #endif - = action {-# INLINE elapsed #-} elapsed :: Double -> Double -> String diff --git a/Data/Array/Accelerate/CUDA/Execute.hs b/Data/Array/Accelerate/CUDA/Execute.hs --- a/Data/Array/Accelerate/CUDA/Execute.hs +++ b/Data/Array/Accelerate/CUDA/Execute.hs @@ -6,13 +6,15 @@ {-# LANGUAGE NoForeignFunctionInterface #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} -- | -- Module : Data.Array.Accelerate.CUDA.Execute --- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller +-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell @@ -23,51 +25,54 @@ module Data.Array.Accelerate.CUDA.Execute ( -- * Execute a computation under a CUDA environment - executeAcc, executeAfun1 + executeAcc, executeAfun1, + -- -- * Executing a sequence computation and streaming its output. + -- StreamSeq(..), streamSeq, + ) where -- friends import Data.Array.Accelerate.CUDA.AST -import Data.Array.Accelerate.CUDA.State -import Data.Array.Accelerate.CUDA.FullList ( FullList(..), List(..) ) +import Data.Array.Accelerate.CUDA.Analysis.Shape import Data.Array.Accelerate.CUDA.Array.Data import Data.Array.Accelerate.CUDA.Array.Sugar -import Data.Array.Accelerate.CUDA.Foreign.Import ( canExecuteAcc ) import Data.Array.Accelerate.CUDA.CodeGen.Base ( Name, namesOfArray, groupOfInt ) import Data.Array.Accelerate.CUDA.Execute.Event ( Event ) import Data.Array.Accelerate.CUDA.Execute.Stream ( Stream ) +import Data.Array.Accelerate.CUDA.Foreign.Import ( canExecuteAcc ) +import Data.Array.Accelerate.CUDA.State import qualified Data.Array.Accelerate.CUDA.Array.Prim as Prim import qualified Data.Array.Accelerate.CUDA.Debug as D import qualified Data.Array.Accelerate.CUDA.Execute.Event as Event import qualified Data.Array.Accelerate.CUDA.Execute.Stream as Stream -import Data.Array.Accelerate.Tuple +import Data.Array.Accelerate.Error import Data.Array.Accelerate.Interpreter ( evalPrim, evalPrimConst, evalPrj ) import Data.Array.Accelerate.Array.Data ( ArrayElt, ArrayData ) import Data.Array.Accelerate.Array.Representation ( SliceIndex(..) ) +import Data.Array.Accelerate.FullList ( FullList(..), List(..) ) +import Data.Array.Accelerate.Lifetime ( withLifetime ) import qualified Data.Array.Accelerate.Array.Representation as R -- standard library -import Prelude hiding ( exp, sum, iterate ) import Control.Applicative hiding ( Const ) import Control.Monad ( join, when, liftM ) import Control.Monad.Reader ( asks ) import Control.Monad.State ( gets ) import Control.Monad.Trans ( MonadIO, liftIO ) +import Control.Monad.Trans.Cont ( ContT(..) ) import System.IO.Unsafe ( unsafeInterleaveIO ) import Data.Int import Data.Word -import Data.Maybe +import Prelude hiding ( exp, sum, iterate ) -import Foreign.CUDA.Analysis.Device ( DeviceProperties, computeCapability, Compute(..) ) +import Foreign.CUDA.Analysis.Device ( computeCapability, Compute(..) ) import qualified Foreign.CUDA.Driver as CUDA import qualified Data.HashMap.Strict as Map -#include "accelerate.h" - -- Asynchronous kernel execution -- ----------------------------- @@ -82,13 +87,15 @@ Aempty :: Aval () Apush :: Aval env -> Async t -> Aval (env, t) +-- -- A suspended sequence computation. +-- newtype StreamSeq a = StreamSeq (CIO (Maybe (a, StreamSeq a))) -- Projection of a value from a valuation using a de Bruijn index. -- aprj :: Idx env t -> Aval env -> Async t aprj ZeroIdx (Apush _ x) = x aprj (SuccIdx idx) (Apush val _) = aprj idx val -aprj _ _ = INTERNAL_ERROR(error) "aprj" "inconsistent valuation" +aprj _ _ = $internalError "aprj" "inconsistent valuation" -- All work submitted to the given stream will occur after the asynchronous @@ -108,11 +115,12 @@ -- Execute the given computation in a unique execution stream. -- -streaming :: (Stream -> CIO a) -> CIO (Async a) -streaming action = do +streaming :: (Stream -> CIO a) -> (Async a -> CIO b) -> CIO b +streaming first second = do context <- asks activeContext reservoir <- gets streamReservoir - uncurry Async <$> Stream.streaming context reservoir action + table <- gets eventTable + Stream.streaming context reservoir table first (\e a -> second (Async e a)) -- Array expression evaluation @@ -131,21 +139,23 @@ -- memory allocated for the result, and the kernel(s) that implement the -- skeleton are invoked -- + executeAcc :: Arrays a => ExecAcc a -> CIO a -executeAcc !acc = wait =<< streaming (executeOpenAcc acc Aempty) +executeAcc !acc = streaming (executeOpenAcc acc Aempty) wait executeAfun1 :: (Arrays a, Arrays b) => ExecAfun (a -> b) -> a -> CIO b executeAfun1 !afun !arrs = do - Async event () <- streaming $ \st -> useArrays (arrays arrs) (fromArr arrs) st - executeOpenAfun1 afun Aempty (Async event arrs) + streaming (useArrays (arrays arrs) (fromArr arrs)) + (\(Async event ()) -> executeOpenAfun1 afun Aempty (Async event arrs)) where useArrays :: ArraysR arrs -> arrs -> Stream -> CIO () useArrays ArraysRunit () _ = return () useArrays (ArraysRpair r1 r0) (a1, a0) st = useArrays r1 a1 st >> useArrays r0 a0 st useArrays ArraysRarray arr st = useArrayAsync arr (Just st) + executeOpenAfun1 :: PreOpenAfun ExecOpenAcc aenv (a -> b) -> Aval aenv -> Async a -> CIO b -executeOpenAfun1 (Alam (Abody f)) aenv x = wait =<< streaming (executeOpenAcc f (aenv `Apush` x)) +executeOpenAfun1 (Alam (Abody f)) aenv x = streaming (executeOpenAcc f (aenv `Apush` x)) wait executeOpenAfun1 _ _ _ = error "the sword comes out after you swallow it, right?" @@ -158,25 +168,27 @@ -> Stream -> CIO arrs executeOpenAcc EmbedAcc{} _ _ - = INTERNAL_ERROR(error) "execute" "unexpected delayed array" + = $internalError "execute" "unexpected delayed array" +-- executeOpenAcc (ExecSeq l) !aenv !stream +-- = executeSequence l aenv stream executeOpenAcc (ExecAcc (FL () kernel more) !gamma !pacc) !aenv !stream = case pacc of -- Array introduction Use arr -> return (toArr arr) - Unit x -> newArray Z . const =<< travE x + Unit x -> fromFunction Z . const =<< travE x -- Environment manipulation Avar ix -> after stream (aprj ix aenv) - Alet bnd body -> streamA bnd >>= \x -> executeOpenAcc body (aenv `Apush` x) stream - Atuple tup -> toTuple <$> travT tup - Aprj ix tup -> evalPrj ix . fromTuple <$> travA tup - Apply f a -> executeOpenAfun1 f aenv =<< streamA a + Alet bnd body -> streaming (executeOpenAcc bnd aenv) (\x -> executeOpenAcc body (aenv `Apush` x) stream) + Apply f a -> streaming (executeOpenAcc a aenv) (executeOpenAfun1 f aenv) + Atuple tup -> toAtuple <$> travT tup + Aprj ix tup -> evalPrj ix . fromAtuple <$> travA tup Acond p t e -> travE p >>= \x -> if x then travA t else travA e Awhile p f a -> awhile p f =<< travA a -- Foreign - Aforeign ff afun a -> fromMaybe (executeAfun1 afun) (canExecuteAcc ff) =<< travA a + Aforeign ff afun a -> aforeign ff afun =<< travA a -- Producers Map _ a -> executeOp =<< extent a @@ -200,21 +212,20 @@ Stencil _ _ a -> stencilOp =<< travA a Stencil2 _ _ a1 _ a2 -> join $ stencil2Op <$> travA a1 <*> travA a2 - -- Removed by fusion - Replicate _ _ _ -> fusionError - Slice _ _ _ -> fusionError - ZipWith _ _ _ -> fusionError + -- AST nodes that should be inaccessible at this point + Replicate{} -> fusionError + Slice{} -> fusionError + ZipWith{} -> fusionError + -- Collect{} -> streamingError where - fusionError = INTERNAL_ERROR(error) "executeOpenAcc" "unexpected fusible matter" + fusionError = $internalError "executeOpenAcc" "unexpected fusible matter" + -- streamingError = $internalError "executeOpenAcc" "unexpected sequence computation" -- term traversals travA :: ExecOpenAcc aenv a -> CIO a travA !acc = executeOpenAcc acc aenv stream - streamA :: ExecOpenAcc aenv a -> CIO (Async a) - streamA !acc = streaming $ \st -> executeOpenAcc acc aenv st - travE :: ExecExp aenv t -> CIO t travE !exp = executeExp exp aenv stream @@ -224,15 +235,24 @@ awhile :: PreOpenAfun ExecOpenAcc aenv (a -> Scalar Bool) -> PreOpenAfun ExecOpenAcc aenv (a -> a) -> a -> CIO a awhile p f a = do - nop <- liftIO Event.create -- record event never call, so this is a functional no-op + tbl <- gets eventTable + ctx <- asks activeContext + nop <- liftIO $ Event.create ctx tbl -- record event never call, so this is a functional no-op r <- executeOpenAfun1 p aenv (Async nop a) ok <- indexArray r 0 -- TLM TODO: memory manager should remember what is already on the host if ok then awhile p f =<< executeOpenAfun1 f aenv (Async nop a) else return a + aforeign :: (Arrays as, Arrays bs, Foreign asm) => asm (as -> bs) -> PreAfun ExecOpenAcc (as -> bs) -> as -> CIO bs + aforeign ff next a = + case canExecuteAcc ff of + Just asm -> asm stream a + Nothing -> executeAfun1 next a + -- get the extent of an embedded array extent :: Shape sh => ExecOpenAcc aenv (Array sh e) -> CIO sh - extent ExecAcc{} = INTERNAL_ERROR(error) "executeOpenAcc" "expected delayed array" + extent ExecAcc{} = $internalError "executeOpenAcc" "expected delayed array" + -- extent ExecSeq{} = $internalError "executeOpenAcc" "expected delayed array" extent (EmbedAcc sh) = travE sh -- Skeleton implementation @@ -252,7 +272,7 @@ -- reshapeOp :: Shape sh => sh -> Array sh' e -> Array sh e reshapeOp sh (Array sh' adata) - = BOUNDS_CHECK(check) "reshape" "shape mismatch" (size sh == R.size sh') + = $boundsCheck "reshape" "shape mismatch" (size sh == R.size sh') $ Array (fromElt sh) adata -- Executing fold operations depend on whether we are recursively collapsing @@ -261,7 +281,7 @@ -- fold1Op :: (Shape sh, Elt e) => (sh :. Int) -> CIO (Array sh e) fold1Op !sh@(_ :. sz) - = BOUNDS_CHECK(check) "fold1" "empty array" (sz > 0) + = $boundsCheck "fold1" "empty array" (sz > 0) $ foldCore sh foldOp :: (Shape sh, Elt e) => (sh :. Int) -> CIO (Array sh e) @@ -270,7 +290,7 @@ foldCore :: (Shape sh, Elt e) => (sh :. Int) -> CIO (Array sh e) foldCore !(!sh :. sz) - | dim sh > 0 = executeOp sh + | rank sh > 0 = executeOp sh | otherwise = let !numElements = size sh * sz (_,!numBlocks,_) = configure kernel numElements @@ -295,7 +315,7 @@ foldRec out | otherwise - = INTERNAL_ERROR(error) "foldRec" "missing phase-2 kernel module" + = $internalError "foldRec" "missing phase-2 kernel module" -- Segmented reduction. Subtract one from the size of the segments vector as -- this is the result of an exclusive scan to calculate segment offsets. @@ -305,35 +325,41 @@ -- Scans, all variations on a theme. -- - scanOp :: Elt e => Bool -> (Z :. Int) -> CIO (Vector e) - scanOp !left !(Z :. numElements) = do - arr@(Array _ adata) <- allocateArray (Z :. numElements + 1) - out <- devicePtrsOfArrayData adata - let (!body, !sum) - | left = (out, advancePtrsOfArrayData adata numElements out) - | otherwise = (advancePtrsOfArrayData adata 1 out, out) - -- - scanCore numElements arr body sum - return arr + scanOp :: forall sh e. (Shape sh, Elt e) => Bool -> (sh :. Int) -> CIO (Array (sh:.Int) e) + scanOp !left !(_ :. numElements) + | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) + = do + arr@(Array _ adata) <- allocateArray (Z :. numElements + 1) + withDevicePtrs adata (Just stream) $ \out -> do + let (!body, !sum) + | left = (out, advancePtrsOfArrayData adata numElements out) + | otherwise = (advancePtrsOfArrayData adata 1 out, out) + -- + scanCore numElements arr body sum + return arr - scan1Op :: forall e. Elt e => (Z :. Int) -> CIO (Vector e) - scan1Op !(Z :. numElements) = do - arr@(Array _ adata) <- allocateArray (Z :. numElements + 1) :: CIO (Vector e) - body <- devicePtrsOfArrayData adata - let sum {- to fix type -} = advancePtrsOfArrayData adata numElements body - -- - scanCore numElements arr body sum - return (Array ((),numElements) adata) + scan1Op :: forall sh e. (Shape sh, Elt e) => (sh :. Int) -> CIO (Array (sh:.Int) e) + scan1Op !(_ :. numElements) + | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) + = do + arr@(Array _ adata) <- allocateArray (Z :. numElements + 1) :: CIO (Vector e) + withDevicePtrs adata (Just stream) $ \body -> do + let sum {- to fix type -} = advancePtrsOfArrayData adata numElements body + -- + scanCore numElements arr body sum + return (Array ((),numElements) adata) - scan'Op :: forall e. Elt e => (Z :. Int) -> CIO (Vector e, Scalar e) - scan'Op !(Z :. numElements) = do - vec@(Array _ ad_vec) <- allocateArray (Z :. numElements) :: CIO (Vector e) - sum@(Array _ ad_sum) <- allocateArray Z :: CIO (Scalar e) - d_vec <- devicePtrsOfArrayData ad_vec - d_sum <- devicePtrsOfArrayData ad_sum - -- - scanCore numElements vec d_vec d_sum - return (vec, sum) + scan'Op :: forall sh e. (Shape sh, Elt e) => (sh :. Int) -> CIO (Array (sh:.Int) e, Array sh e) + scan'Op !(_ :. numElements) + | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) + = do + vec@(Array _ ad_vec) <- allocateArray (Z :. numElements) :: CIO (Vector e) + sum@(Array _ ad_sum) <- allocateArray Z :: CIO (Scalar e) + withDevicePtrs ad_vec (Just stream) $ \d_vec -> + withDevicePtrs ad_sum (Just stream) $ \d_sum -> do + -- + scanCore numElements vec d_vec d_sum + return (vec, sum) scanCore :: forall e. Elt e @@ -363,17 +389,24 @@ execute kernel gamma aenv numElements (numElements, d_body, blk, d_sum) stream | otherwise - = INTERNAL_ERROR(error) "scanOp" "missing multi-block kernel module(s)" + = $internalError "scanOp" "missing multi-block kernel module(s)" -- Forward permutation -- - permuteOp :: (Shape sh, Shape sh', Elt e) => sh -> Array sh' e -> CIO (Array sh' e) + permuteOp :: forall sh sh' e. (Shape sh, Shape sh', Elt e) => sh -> Array sh' e -> CIO (Array sh' e) permuteOp !sh !dfs = do - out <- allocateArray (shape dfs) - copyArray dfs out - execute kernel gamma aenv (size sh) out stream - return out + let sh' = shape dfs + n' = size sh' + out <- allocateArray sh' + Array _ locks <- allocateArray sh' :: CIO (Array sh' Int32) + withDevicePtrs locks (Just stream) $ \d_locks -> do + + liftIO $ CUDA.memsetAsync d_locks n' 0 (Just stream) -- TLM: overlap these two operations? + copyArrayAsync dfs out (Just stream) + execute kernel gamma aenv (size sh) (out, d_locks) stream + return out + -- Stencil operations. NOTE: the arguments to 'namesOfArray' must be the -- same as those given in the function 'mkStencil[2]'. -- @@ -384,9 +417,10 @@ dev <- asks deviceProperties if computeCapability dev < Compute 2 0 - then marshalAccTex (namesOfArray "Stencil" (undefined :: a)) kernel arr >> - execute kernel gamma aenv (size sh) (out, sh) stream + then marshalAccTex (namesOfArray "Stencil" (undefined :: a)) kernel arr (Just stream) $ + execute kernel gamma aenv (size sh) (out, sh) stream else execute kernel gamma aenv (size sh) (out, arr) stream + execute kernel gamma aenv (size sh) (out, arr) stream -- return out @@ -404,24 +438,281 @@ dev <- asks deviceProperties if computeCapability dev < Compute 2 0 - then marshalAccTex (namesOfArray "Stencil1" (undefined :: a)) op arr1 >> - marshalAccTex (namesOfArray "Stencil2" (undefined :: b)) op arr2 >> + then marshalAccTex (namesOfArray "Stencil1" (undefined :: a)) op arr1 (Just stream) $ + marshalAccTex (namesOfArray "Stencil2" (undefined :: b)) op arr2 (Just stream) $ execute op gamma aenv (size sh) (out, sh1, sh2) stream else execute op gamma aenv (size sh) (out, arr1, arr2) stream + execute op gamma aenv (size sh) (out, arr1, arr2) stream -- return out | otherwise - = INTERNAL_ERROR(error) "stencil2Op" "missing stencil specialisation kernel" + = $internalError "stencil2Op" "missing stencil specialisation kernel" +{-- +-- Execute a streaming computation +-- +executeSequence + :: forall aenv arrs. Arrays arrs + => ExecOpenSeq aenv () arrs + -> Aval aenv + -> Stream + -> CIO arrs +executeSequence topSequence aenv stream + = initializeOpenSeq topSequence aenv stream >>= loop >>= returnOut + where + loop :: ExecOpenSeq aenv () arrs -> CIO (ExecOpenSeq aenv () arrs) + loop = loop' + where + loop' :: ExecOpenSeq aenv () arrs -> CIO (ExecOpenSeq aenv () arrs) + loop' s = do + ms <- runMaybeT (stepOpenSeq aenv s stream) + case ms of + Nothing -> return s + Just s' -> loop' s' + + returnOut :: forall lenv arrs' . ExecOpenSeq aenv lenv arrs' -> CIO arrs' + returnOut !l = + case l of + ExecP _ l' -> returnOut l' + ExecC c -> readConsumer c + ExecR _ ma -> case ma of + Just a -> return [a] + Nothing -> $internalError "executeSequence" "Expected already executed Sequence" + + where + readConsumer :: forall a . ExecC aenv lenv a -> CIO a + readConsumer c = + case c of + ExecFoldSeq _ _ _ (Just a) -> let a' = fromList Z [a] in useArray a' >> return a' + ExecFoldSeqFlatten _ _ _ (Just a) -> return a + ExecStuple t -> toAtuple <$> rdT t + where + rdT :: forall t. Atuple (ExecC aenv lenv) t -> CIO t + rdT NilAtup = return () + rdT (SnocAtup t' c') = (,) <$> rdT t' <*> readConsumer c' + _ -> $internalError "executeSequence" "Expected already executed consumer" + +initializeSeq + :: Aval aenv + -> ExecOpenSeq aenv () arrs' + -> CIO (ExecOpenSeq aenv () arrs') +initializeSeq aenv s = streaming (initializeOpenSeq s aenv) wait + +initializeOpenSeq + :: forall lenv aenv arrs'. + ExecOpenSeq aenv lenv arrs' + -> Aval aenv + -> Stream + -> CIO (ExecOpenSeq aenv lenv arrs') +initializeOpenSeq l aenv stream = + case l of + ExecP p l' -> ExecP <$> initP p <*> initializeOpenSeq l' aenv stream + ExecC c -> ExecC <$> initC c + ExecR ix a -> return (ExecR ix a) + + where + initP :: forall a. ExecP aenv lenv a -> CIO (ExecP aenv lenv a) + initP (ExecToSeq slix acc k g (_::[slix])) = + do sh <- extent acc + --Lazy evaluation will stop this entire list being generated. + let slices = enumSlices slix sh :: [slix] + return $ ExecToSeq slix acc k g slices + initP (ExecUseLazy slix arr (_::[slix])) = + let sh = shape arr + -- Same as above. + slices = enumSlices slix sh :: [slix] + in return $ ExecUseLazy slix arr slices + initP s@ExecStreamIn{} = return s + initP s@ExecMap{} = return s + initP s@ExecZipWith{} = return s + initP (ExecScanSeq f a0 ix _) = + do a <- executeExp a0 aenv stream + return $ ExecScanSeq f a0 ix (Just a) + + initC :: forall a. ExecC aenv lenv a -> CIO (ExecC aenv lenv a) + initC c = + case c of + ExecFoldSeq f a0 ix _ -> + do a <- executeExp a0 aenv stream + return $ ExecFoldSeq f a0 ix (Just a) + ExecFoldSeqFlatten afun acc ix _ -> + do a <- executeOpenAcc acc aenv stream + return $ ExecFoldSeqFlatten afun acc ix (Just a) + ExecStuple t -> ExecStuple <$> initCT t + + initCT :: forall t. Atuple (ExecC aenv lenv) t -> CIO (Atuple (ExecC aenv lenv) t) + initCT NilAtup = return NilAtup + initCT (SnocAtup t c) = SnocAtup <$> initCT t <*> initC c + + -- get the extent of an embedded array + extent :: Shape sh => ExecOpenAcc aenv (Array sh e) -> CIO sh + extent ExecAcc{} = $internalError "executeOpenAcc" "expected delayed array" + extent ExecSeq{} = $internalError "executeOpenAcc" "expected delayed array" + extent (EmbedAcc sh) = executeExp sh aenv stream + + +-- Turn a sequence computation into a suspended computation that can be forced +-- an element at a time. +-- +streamSeq :: ExecSeq [a] -> StreamSeq a +streamSeq (ExecS binds sequ) = StreamSeq $ do + aenv <- executeExtend binds Aempty + iseq <- initializeSeq aenv sequ + let go s = do + ms <- stepSeq aenv s + case ms of + Nothing -> return Nothing + Just (s', a) -> return (Just (a, StreamSeq (go s'))) + go iseq + + +stepSeq + :: forall a aenv. + Aval aenv + -> ExecOpenSeq aenv () [a] + -> CIO (Maybe (ExecOpenSeq aenv () [a], a)) +stepSeq aenv s = streaming step wait + where + step :: Stream -> CIO (Maybe (ExecOpenSeq aenv () [a], a)) + step stream = do + ms <- runMaybeT (stepOpenSeq aenv s stream) + return $ (,) <$> ms <*> (coll <$> ms) + + coll :: ExecOpenSeq aenv lenv [a] -> a + coll (ExecP _ s') = coll s' + coll (ExecC _) = $internalError "stepSeq" "Unreachable" + coll (ExecR _ ma) = case ma of + Nothing -> $internalError "stepSeq" "Trying to collect the value of an unexecuted sequence" + Just a -> a + +stepOpenSeq + :: forall aenv arrs'. + Aval aenv + -> ExecOpenSeq aenv () arrs' + -> Stream + -> MaybeT CIO (ExecOpenSeq aenv () arrs') +stepOpenSeq aenv !l stream = go l Empty + where + go :: forall lenv. ExecOpenSeq aenv lenv arrs' -> Val lenv -> MaybeT CIO (ExecOpenSeq aenv lenv arrs') + go s lenv = + case s of + ExecP p s' -> do + (p', a) <- produce p + s'' <- go s' (lenv `Push` a) + return $ ExecP p' s'' + ExecC c -> ExecC <$> lift (consume c) + ExecR ix _ -> return $ ExecR ix (Just (prj ix lenv)) + where + produce :: forall a . ExecP aenv lenv a -> MaybeT CIO (ExecP aenv lenv a, a) + produce (ExecToSeq slix acc kernel gamma sls) = + do + sl : sls' <- return sls + lift $ do + sh <- extent acc + out <- allocateArray (sliceShape slix sh) + m <- marshalSlice slix sl + execute kernel gamma aenv (size sh) (m, out) stream + return (ExecToSeq slix acc kernel gamma sls', out) + produce (ExecUseLazy slix arr sls) = + do let sh = shape arr + lift $ do + sl : sls' <- return sls + out <- allocateArray (sliceShape slix sh) + useArraySlice slix sl arr out + return (ExecUseLazy slix arr sls', out) + produce (ExecStreamIn xs) = + let use :: ArraysR arrs -> arrs -> CIO () + use ArraysRunit () = return () + use ArraysRarray arr = useArrayAsync arr Nothing + use (ArraysRpair r1 r2) (a1, a2) = use r1 a1 >> use r2 a2 + in case xs of + [] -> MaybeT (return Nothing) + x:xs' -> lift (use (arrays x) (fromArr x)) >> return (ExecStreamIn xs', x) + produce (ExecMap afun x) = (ExecMap afun x ,) <$> lift (travAfun1 afun (prj x lenv)) + produce (ExecZipWith afun x y) = (ExecZipWith afun x y,) <$> lift (travAfun2 afun (prj x lenv) (prj y lenv)) + produce (ExecScanSeq afun a0 x ma) = + do + a <- MaybeT (return ma) + a' <- lift $ travFun2 afun a (prj x lenv ! Z) + return (ExecScanSeq afun a0 x (Just a'), fromList Z [a']) + + consume :: forall a . ExecC aenv lenv a -> CIO (ExecC aenv lenv a) + consume c = + case c of + ExecFoldSeq afun a0 x (Just a) -> + do b <- indexArray (prj x lenv) 0 + a' <- travFun2 afun a b + return $ ExecFoldSeq afun a0 x (Just a') + ExecFoldSeqFlatten afun a0 x (Just a) -> + do useArray shapes + a' <- travAfun3 afun a shapes elems + return $ ExecFoldSeqFlatten afun a0 x (Just a') + where + Array sh adata = prj x lenv + elems = Array ((), R.size sh) adata + shapes = fromList (Z:.1) [toElt sh] + ExecStuple t -> ExecStuple <$> consumeT t + _ -> $internalError "executeSequence" "Expected already executed consumer" + + consumeT :: forall t. Atuple (ExecC aenv lenv) t -> CIO (Atuple (ExecC aenv lenv) t) + consumeT NilAtup = return NilAtup + consumeT (SnocAtup t c) = SnocAtup <$> consumeT t <*> consume c + + travAfun1 :: forall a b. PreOpenAfun ExecOpenAcc aenv (a -> b) -> a -> CIO b + travAfun1 (Alam (Abody afun)) a = + do nop <- join $ liftIO <$> (Event.create <$> asks activeContext <*> gets eventTable) + executeOpenAcc afun (aenv `Apush` (Async nop a)) stream + travAfun1 _ _ = error "travAfun1" + + travAfun2 :: forall a b c. PreOpenAfun ExecOpenAcc aenv (a -> b -> c) -> a -> b -> CIO c + travAfun2 (Alam (Alam (Abody afun))) a b = + do nop <- join $ liftIO <$> (Event.create <$> asks activeContext <*> gets eventTable) + executeOpenAcc afun (aenv `Apush` (Async nop a) `Apush` (Async nop b)) stream + travAfun2 _ _ _ = error "travAfun2" + + travAfun3 :: forall a b c d. PreOpenAfun ExecOpenAcc aenv (a -> b -> c -> d) -> a -> b -> c -> CIO d + travAfun3 (Alam (Alam (Alam (Abody afun)))) a b c = + do nop <- join $ liftIO <$> (Event.create <$> asks activeContext <*> gets eventTable) + executeOpenAcc afun (aenv `Apush` (Async nop a) `Apush` (Async nop b) `Apush` (Async nop c)) stream + travAfun3 _ _ _ _ = error "travAfun3" + + travFun2 :: forall a b c. PreFun ExecOpenAcc aenv (a -> b -> c) -> a -> b -> CIO c + travFun2 (Lam (Lam (Body c))) a b = executeOpenExp c (Empty `Push` a `Push` b) aenv stream + travFun2 _ _ _ = error "travFun2" + + -- get the extent of an embedded array + extent :: Shape sh => ExecOpenAcc aenv (Array sh e) -> CIO sh + extent ExecAcc{} = $internalError "executeOpenAcc" "expected delayed array" + extent ExecSeq{} = $internalError "executeOpenAcc" "expected delayed array" + extent (EmbedAcc sh) = executeExp sh aenv stream + + +-- Evaluating bindings +-- ------------------- + +executeExtend :: Extend ExecOpenAcc aenv aenv' -> Aval aenv -> CIO (Aval aenv') +executeExtend BaseEnv aenv = return aenv +executeExtend (PushEnv e a) aenv = do + aenv' <- executeExtend e aenv + streaming (executeOpenAcc a aenv') $ \a' -> return $ Apush aenv' a' +--} + + -- Scalar expression evaluation -- ---------------------------- executeExp :: ExecExp aenv t -> Aval aenv -> Stream -> CIO t executeExp !exp !aenv !stream = executeOpenExp exp Empty aenv stream -executeOpenExp :: forall env aenv exp. ExecOpenExp env aenv exp -> Val env -> Aval aenv -> Stream -> CIO exp +executeOpenExp + :: forall env aenv exp. + ExecOpenExp env aenv exp + -> Val env + -> Aval aenv + -> Stream + -> CIO exp executeOpenExp !rootExp !env !aenv !stream = travE rootExp where travE :: ExecOpenExp env aenv t -> CIO t @@ -445,6 +736,7 @@ ToIndex sh ix -> toIndex <$> travE sh <*> travE ix FromIndex sh ix -> fromIndex <$> travE sh <*> travE ix Intersect sh1 sh2 -> intersect <$> travE sh1 <*> travE sh2 + Union sh1 sh2 -> union <$> travE sh1 <*> travE sh2 ShapeSize sh -> size <$> travE sh Shape acc -> shape <$> travA acc Index acc ix -> join $ index <$> travA acc <*> travE ix @@ -507,45 +799,64 @@ -- Marshalling data -- ---------------- +{-- +marshalSlice' + :: SliceIndex slix sl co dim + -> slix + -> CIO [CUDA.FunParam] +marshalSlice' SliceNil () = return [] +marshalSlice' (SliceAll sl) (sh, ()) = marshalSlice' sl sh +marshalSlice' (SliceFixed sl) (sh, n) = + do x <- runContT (marshal n Nothing) return + xs <- marshalSlice' sl sh + return (xs ++ x) + +marshalSlice + :: Elt slix => SliceIndex (EltRepr slix) sl co dim + -> slix + -> CIO [CUDA.FunParam] +marshalSlice slix = marshalSlice' slix . fromElt +--} + -- Data which can be marshalled as function arguments to a kernel invocation. -- class Marshalable a where - marshal :: a -> CIO [CUDA.FunParam] + marshal :: a -> Maybe Stream -> ContT b CIO [CUDA.FunParam] instance Marshalable () where - marshal () = return [] + marshal () _ = return [] instance Marshalable CUDA.FunParam where - marshal !x = return [x] + marshal !x _ = return [x] instance ArrayElt e => Marshalable (ArrayData e) where - marshal !ad = marshalArrayData ad + marshal !ad ms = ContT $ marshalArrayData ad ms instance Shape sh => Marshalable sh where - marshal !sh = marshal (reverse (shapeToList sh)) + marshal !sh ms = marshal (reverse (shapeToList sh)) ms instance Marshalable a => Marshalable [a] where - marshal = concatMapM marshal + marshal xs ms = concatMapM (flip marshal ms) xs instance (Marshalable sh, Elt e) => Marshalable (Array sh e) where - marshal !(Array sh ad) = (++) <$> marshal (toElt sh :: sh) <*> marshal ad + marshal !(Array sh ad) ms = (++) <$> marshal (toElt sh :: sh) ms <*> marshal ad ms instance (Marshalable a, Marshalable b) => Marshalable (a, b) where - marshal (!a, !b) = (++) <$> marshal a <*> marshal b + marshal (!a, !b) ms = (++) <$> marshal a ms <*> marshal b ms instance (Marshalable a, Marshalable b, Marshalable c) => Marshalable (a, b, c) where - marshal (!a, !b, !c) - = concat <$> sequence [marshal a, marshal b, marshal c] + marshal (!a, !b, !c) ms + = concat <$> sequence [marshal a ms, marshal b ms, marshal c ms] instance (Marshalable a, Marshalable b, Marshalable c, Marshalable d) => Marshalable (a, b, c, d) where - marshal (!a, !b, !c, !d) - = concat <$> sequence [marshal a, marshal b, marshal c, marshal d] + marshal (!a, !b, !c, !d) ms + = concat <$> sequence [marshal a ms, marshal b ms, marshal c ms, marshal d ms] #define primMarshalable(ty) \ instance Marshalable (ty) where { \ - marshal !x = return [CUDA.VArg x] } + marshal !x _ = return [CUDA.VArg x] } primMarshalable(Int) primMarshalable(Int8) @@ -579,21 +890,23 @@ -- as to use the larger available caches. -- -marshalAccEnvTex :: AccKernel a -> Aval aenv -> Gamma aenv -> Stream -> CIO [CUDA.FunParam] +marshalAccEnvTex :: AccKernel a -> Aval aenv -> Gamma aenv -> Stream -> ContT b CIO [CUDA.FunParam] marshalAccEnvTex !kernel !aenv (Gamma !gamma) !stream = flip concatMapM (Map.toList gamma) $ \(Idx_ !(idx :: Idx aenv (Array sh e)), i) -> do arr <- after stream (aprj idx aenv) - marshalAccTex (namesOfArray (groupOfInt i) (undefined :: e)) kernel arr - marshal (shape arr) + ContT $ \f -> marshalAccTex (namesOfArray (groupOfInt i) (undefined :: e)) kernel arr (Just stream) (f ()) + marshal (shape arr) (Just stream) -marshalAccTex :: (Name,[Name]) -> AccKernel a -> Array sh e -> CIO () -marshalAccTex (_, !arrIn) (AccKernel _ _ !mdl _ _ _ _) (Array !sh !adata) - = marshalTextureData adata (R.size sh) =<< liftIO (sequence' $ map (CUDA.getTex mdl) (reverse arrIn)) +marshalAccTex :: (Name,[Name]) -> AccKernel a -> Array sh e -> Maybe Stream -> CIO b -> CIO b +marshalAccTex (_, !arrIn) (AccKernel _ _ !lmdl _ _ _ _) (Array !sh !adata) ms run + = do + texs <- liftIO $ withLifetime lmdl $ \mdl -> (sequence' $ map (CUDA.getTex mdl) (reverse arrIn)) + marshalTextureData adata (R.size sh) texs ms (const run) -marshalAccEnvArg :: Aval aenv -> Gamma aenv -> Stream -> CIO [CUDA.FunParam] +marshalAccEnvArg :: Aval aenv -> Gamma aenv -> Stream -> ContT b CIO [CUDA.FunParam] marshalAccEnvArg !aenv (Gamma !gamma) !stream - = concatMapM (\(Idx_ !idx) -> marshal =<< after stream (aprj idx aenv)) (Map.keys gamma) + = concatMapM (\(Idx_ !idx) -> flip marshal (Just stream) =<< after stream (aprj idx aenv)) (Map.keys gamma) -- A lazier version of 'Control.Monad.sequence' @@ -622,45 +935,47 @@ -- texture references, and for newer devices adds the parameters to the front of -- the argument list -- -arguments :: Marshalable args - => AccKernel a - -> Aval aenv - -> Gamma aenv - -> args - -> Stream - -> CIO [CUDA.FunParam] +arguments + :: Marshalable args + => AccKernel a + -> Aval aenv + -> Gamma aenv + -> args + -> Stream + -> ContT b CIO [CUDA.FunParam] arguments !kernel !aenv !gamma !a !stream = do dev <- asks deviceProperties let marshaller | computeCapability dev < Compute 2 0 = marshalAccEnvTex kernel | otherwise = marshalAccEnvArg -- - (++) <$> marshaller aenv gamma stream <*> marshal a + (++) <$> marshaller aenv gamma stream <*> marshal a (Just stream) -- Link the binary object implementing the computation, configure the kernel -- launch parameters, and initiate the computation. This also handles lifting -- and binding of array references from scalar expressions. -- -execute :: Marshalable args - => AccKernel a -- The binary module implementing this kernel - -> Gamma aenv -- variables of arrays embedded in scalar expressions - -> Aval aenv -- the environment - -> Int -- a "size" parameter, typically number of elements in the output - -> args -- arguments to marshal to the kernel function - -> Stream -- Compute stream to execute in - -> CIO () -execute !kernel !gamma !aenv !n !a !stream = do - args <- arguments kernel aenv gamma a stream - launch kernel (configure kernel n) args stream +execute + :: Marshalable args + => AccKernel a -- The binary module implementing this kernel + -> Gamma aenv -- variables of arrays embedded in scalar expressions + -> Aval aenv -- the environment + -> Int -- a "size" parameter, typically number of elements in the output + -> args -- arguments to marshal to the kernel function + -> Stream -- Compute stream to execute in + -> CIO () +execute !kernel !gamma !aenv !n !a !stream = flip runContT return $ do + args <- arguments kernel aenv gamma a stream + liftIO $ launch kernel (configure kernel n) args stream -- Execute a device function, with the given thread configuration and function -- parameters. The tuple contains (threads per block, grid size, shared memory) -- -launch :: AccKernel a -> (Int,Int,Int) -> [CUDA.FunParam] -> Stream -> CIO () +launch :: AccKernel a -> (Int,Int,Int) -> [CUDA.FunParam] -> Stream -> IO () launch (AccKernel entry !fn _ _ _ _ _) !(cta, grid, smem) !args !stream - = D.timed D.dump_exec msg - $ liftIO $ CUDA.launchKernel fn (grid,1,1) (cta,1,1) smem (Just stream) args + = D.timed D.dump_exec msg (Just stream) + $ CUDA.launchKernel fn (grid,1,1) (cta,1,1) smem (Just stream) args where msg gpuTime cpuTime = "exec: " ++ entry ++ "<<< " ++ shows grid ", " ++ shows cta ", " ++ shows smem " >>> " diff --git a/Data/Array/Accelerate/CUDA/Execute/Event.hs b/Data/Array/Accelerate/CUDA/Execute/Event.hs --- a/Data/Array/Accelerate/CUDA/Execute/Event.hs +++ b/Data/Array/Accelerate/CUDA/Execute/Event.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.CUDA.Execute.Event --- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --- [2009..2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2013..2014] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell @@ -13,41 +14,95 @@ -- module Data.Array.Accelerate.CUDA.Execute.Event ( - Event, create, waypoint, after, block, + Event, EventTable, new, create, waypoint, after, block, query, destroy, ) where -- friends +import Data.Array.Accelerate.FullList ( FullList(..) ) +import Data.Array.Accelerate.Lifetime +import Data.Array.Accelerate.CUDA.Context ( Context(..) ) import qualified Data.Array.Accelerate.CUDA.Debug as D +import qualified Data.Array.Accelerate.FullList as FL -- libraries -import Foreign.CUDA.Driver.Event ( Event(..) ) -import Foreign.CUDA.Driver.Stream ( Stream ) +import Control.Concurrent.MVar ( MVar, newMVar, withMVar, mkWeakMVar ) +import Control.Exception ( bracket_ ) +import Data.Hashable ( Hashable(..) ) +import Foreign.CUDA.Driver.Stream ( Stream(..) ) +import Foreign.Ptr ( ptrToIntPtr ) +import qualified Foreign.CUDA.Driver as CUDA import qualified Foreign.CUDA.Driver.Event as Event +import qualified Data.HashTable.IO as HT -import GHC.Base -import GHC.Ptr +type Event = Lifetime Event.Event +type HashTable key val = HT.BasicHashTable key val --- Create a new event that will be automatically garbage collected. The event is --- not suitable for timing purposes. +type EventTable = MVar ( HashTable (Lifetime CUDA.Context) (FullList () Event.Event) ) + +instance Hashable (Lifetime CUDA.Context) where + {-# INLINE hashWithSalt #-} + hashWithSalt salt (unsafeGetValue -> CUDA.Context ctx) + = salt `hashWithSalt` (fromIntegral (ptrToIntPtr ctx) :: Int) + + +-- Generate a new empty event table. -- +new :: IO EventTable +new = do + tbl <- HT.new + ref <- newMVar tbl + _ <- mkWeakMVar ref (flush tbl) + return ref + +-- Create a new event. It will be automatically garbage collected, if a recycled +-- event is available, it will be returned, else a new event is created. +-- {-# INLINE create #-} -create :: IO Event -create = do - event <- Event.create [Event.DisableTiming] - addEventFinalizer event $ trace ("destroy " ++ show event) (Event.destroy event) +create :: Context -> EventTable -> IO Event +create ctx ref = withMVar ref $ \tbl -> do + -- + let key = deviceContext ctx + me <- HT.lookup tbl key + e <- case me of + Nothing -> do + e <- Event.create [Event.DisableTiming] + message ("new " ++ show e) + return e + + Just (FL () e rest) -> do + case rest of + FL.Nil -> HT.delete tbl key + FL.Cons () e' es -> HT.insert tbl key (FL () e' es) + -- + return e + -- + event <- newLifetime e + addFinalizer event $ do + D.traceIO D.dump_gc ("gc: finalise event " ++ showEvent event) + insert ref (deviceContext ctx) e return event +{-# INLINE insert #-} +-- Insert an event into the table. +-- +insert :: EventTable -> Lifetime CUDA.Context -> Event.Event -> IO () +insert ref lctx e = withMVar ref $ \tbl -> do + me <- HT.lookup tbl lctx + case me of + Nothing -> HT.insert tbl lctx (FL.singleton () e) + Just es -> HT.insert tbl lctx (FL.cons () e es) + -- Create a new event marker that will be filled once execution in the specified -- stream has completed all previously submitted work. -- {-# INLINE waypoint #-} -waypoint :: Stream -> IO Event -waypoint stream = do - event <- create - Event.record event (Just stream) --- message $ "waypoint " ++ show event ++ " in " ++ show stream +waypoint :: Context -> EventTable -> Stream -> IO Event +waypoint ctx ref stream = do + event <- create ctx ref + withLifetime event (`Event.record` Just stream) + message $ "waypoint " ++ showEvent event ++ " in " ++ showStream stream return event -- Make all future work submitted to the given stream wait until the event @@ -56,31 +111,50 @@ {-# INLINE after #-} after :: Event -> Stream -> IO () after event stream = do --- message $ "after " ++ show event ++ " in " ++ show stream - Event.wait event (Just stream) [] + message $ "after " ++ showEvent event ++ " in " ++ showStream stream + withLifetime event $ \e -> Event.wait e (Just stream) [] -- Block the calling thread until the event is recorded -- {-# INLINE block #-} block :: Event -> IO () -block = Event.block +block = flip withLifetime Event.block +-- Query the status of the event. +-- +{-# INLINE query #-} +query :: Event -> IO Bool +query = flip withLifetime Event.query --- Add a finaliser to an event token +-- Explicitly destroy the event. -- -addEventFinalizer :: Event -> IO () -> IO () -addEventFinalizer e@(Event (Ptr e#)) f = IO $ \s -> - case mkWeak# e# e f s of (# s', _w #) -> (# s', () #) +{-# INLINE destroy #-} +destroy :: Event -> IO () +destroy = finalize +-- Destroy all events in the table. +-- +flush :: HashTable (Lifetime CUDA.Context) (FullList () Event.Event) -> IO () +flush !tbl = + let clean (!lctx,!es) = do + withLifetime lctx $ \ctx -> bracket_ (CUDA.push ctx) CUDA.pop (FL.mapM_ (const Event.destroy) es) + HT.delete tbl lctx + in + message "flush reservoir" >> HT.mapM_ clean tbl + -- Debug -- ----- -{-# INLINE trace #-} -trace :: String -> IO a -> IO a -trace msg next = D.message D.dump_exec ("event: " ++ msg) >> next +{-# INLINE message #-} +message :: String -> IO () +message msg = D.traceIO D.dump_sched ("event: " ++ msg) --- {-# INLINE message #-} --- message :: String -> IO () --- message s = s `trace` return () +{-# INLINE showEvent #-} +showEvent :: Event -> String +showEvent (unsafeGetValue -> Event.Event e) = show e + +{-# INLINE showStream #-} +showStream :: Stream -> String +showStream (Stream s) = show s diff --git a/Data/Array/Accelerate/CUDA/Execute/Stream.hs b/Data/Array/Accelerate/CUDA/Execute/Stream.hs --- a/Data/Array/Accelerate/CUDA/Execute/Stream.hs +++ b/Data/Array/Accelerate/CUDA/Execute/Stream.hs @@ -1,7 +1,11 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.CUDA.Execute.Stream --- Copyright : [2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2013..2014] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell @@ -16,22 +20,20 @@ ) where -- friends -import Data.Array.Accelerate.CUDA.Array.Nursery ( ) -- hashable CUDA.Context instance import Data.Array.Accelerate.CUDA.Context ( Context(..) ) -import Data.Array.Accelerate.CUDA.FullList ( FullList(..) ) -import Data.Array.Accelerate.CUDA.Execute.Event ( Event ) +import Data.Array.Accelerate.CUDA.Execute.Event ( Event, EventTable ) +import Data.Array.Accelerate.FullList ( FullList(..) ) +import Data.Array.Accelerate.Lifetime ( Lifetime, withLifetime ) import qualified Data.Array.Accelerate.CUDA.Execute.Event as Event -import qualified Data.Array.Accelerate.CUDA.FullList as FL import qualified Data.Array.Accelerate.CUDA.Debug as D +import qualified Data.Array.Accelerate.FullList as FL -- libraries -import Control.Monad ( void ) import Control.Monad.Trans ( MonadIO, liftIO ) import Control.Exception ( bracket_ ) -import Control.Concurrent ( forkIO ) import Control.Concurrent.MVar ( MVar, newMVar, withMVar, mkWeakMVar ) import System.Mem.Weak ( Weak, deRefWeak ) -import Foreign.CUDA.Driver.Stream ( Stream ) +import Foreign.CUDA.Driver.Stream ( Stream(..) ) import qualified Foreign.CUDA.Driver as CUDA import qualified Foreign.CUDA.Driver.Stream as Stream @@ -47,7 +49,7 @@ -- type HashTable key val = HT.BasicHashTable key val -type RSV = MVar ( HashTable CUDA.Context (FullList () Stream) ) +type RSV = MVar ( HashTable (Lifetime CUDA.Context) (FullList () Stream) ) data Reservoir = Reservoir {-# UNPACK #-} !RSV {-# UNPACK #-} !(Weak RSV) @@ -55,16 +57,21 @@ -- Executing operations in streams -- ------------------------------- --- Execute an operation in a unique execution stream. +-- Execute an operation in a unique execution stream. The (asynchronous) result +-- is passed to a second operation together with an event that will be signalled +-- once the operation is complete. The stream and event are released after the +-- second operation completes. -- {-# INLINE streaming #-} -streaming :: MonadIO m => Context -> Reservoir -> (Stream -> m a) -> m (Event, a) -streaming !ctx !rsv@(Reservoir !_ !weak_rsv) !action = do +streaming :: MonadIO m => Context -> Reservoir -> EventTable -> (Stream -> m a) -> (Event -> a -> m b) -> m b +streaming !ctx !rsv@(Reservoir !_ !weak_rsv) !etbl !action !after = do stream <- liftIO $ create ctx rsv - result <- action stream - end <- liftIO $ Event.waypoint stream - liftIO $ merge (weakContext ctx) weak_rsv stream - return $ (end, result) + first <- action stream + end <- liftIO $ Event.waypoint ctx etbl stream + final <- after end first + liftIO $! destroy (weakContext ctx) weak_rsv stream + liftIO $! Event.destroy end + return final -- Primitive operations @@ -86,61 +93,67 @@ -- {-# INLINE create #-} create :: Context -> Reservoir -> IO Stream -create !ctx (Reservoir !ref _) = withMVar ref $ \tbl -> do - let key = deviceContext ctx +create !ctx (Reservoir !ref !_) = withMVar ref $ \tbl -> do -- + let key = deviceContext ctx ms <- HT.lookup tbl key case ms of Nothing -> do - stream <- Stream.create [] - message ("new " ++ showStream stream) - return stream + stream <- Stream.create [] + message ("new " ++ showStream stream) + return stream Just (FL () stream rest) -> do case rest of FL.Nil -> HT.delete tbl key FL.Cons () s ss -> HT.insert tbl key (FL () s ss) - -- + -- return stream --- Merge a stream back into the reservoir. This is done asynchronously, once all +-- Merge a stream back into the reservoir. This must only be done once all -- pending operations in the stream have completed. -- -{-# INLINE merge #-} -merge :: Weak CUDA.Context -> Weak RSV -> Stream -> IO () -merge !weak_ctx !weak_rsv !stream - = void . forkIO - $ do -- wait for all operations to complete - -- Stream.block stream +{-# INLINE destroy #-} +destroy :: Weak (Lifetime CUDA.Context) -> Weak RSV -> Stream -> IO () +destroy !weak_ctx !weak_rsv !stream = do + -- Wait for all preceding operations submitted to the stream to complete. Not + -- necessary because of the setup of 'streaming'. + -- Stream.block stream - -- Now check whether the context and reservoir are still active. Return - -- the stream back to the reservoir for later reuse if we can, otherwise - -- destroy it. - -- - mc <- deRefWeak weak_ctx - case mc of - Nothing -> message ("finalise/dead context " ++ showStream stream) - Just ctx -> do - -- - mr <- deRefWeak weak_rsv - case mr of - Nothing -> trace ("merge/free " ++ showStream stream) $ Stream.destroy stream - Just ref -> trace ("merge/save " ++ showStream stream) $ withMVar ref $ \tbl -> do - -- - ms <- HT.lookup tbl ctx - case ms of - Nothing -> HT.insert tbl ctx (FL.singleton () stream) - Just ss -> HT.insert tbl ctx (FL.cons () stream ss) + -- Now check whether the context and reservoir are still active. Return + -- the stream back to the reservoir for later reuse if we can, otherwise + -- destroy it. + mc <- deRefWeak weak_ctx + case mc of + Nothing -> message ("finalise/dead context " ++ showStream stream) + Just ctx -> do + -- + mr <- deRefWeak weak_rsv + case mr of + Nothing -> trace ("destroy/free " ++ showStream stream) $ Stream.destroy stream + Just ref -> trace ("destroy/save " ++ showStream stream) $ withMVar ref $ \tbl -> do + -- + ms <- HT.lookup tbl ctx + case ms of + Nothing -> HT.insert tbl ctx (FL.singleton () stream) + Just ss -> HT.insert tbl ctx (FL.cons () stream ss) +-- Add a finaliser to an execution stream +-- +-- addStreamFinalizer :: Stream -> IO () -> IO () +-- addStreamFinalizer st@(Stream (Ptr st#)) f = IO $ \s -> +-- case mkWeak# st# st f s of (# s', _w #) -> (# s', () #) + + -- Destroy all streams in the reservoir. -- -flush :: HashTable CUDA.Context (FullList () Stream) -> IO () +flush :: HashTable (Lifetime CUDA.Context) (FullList () Stream) -> IO () flush !tbl = - let clean (!ctx,!ss) = do - bracket_ (CUDA.push ctx) CUDA.pop (FL.mapM_ (const Stream.destroy) ss) - HT.delete tbl ctx + let clean (!lctx,!ss) = do + withLifetime lctx $ \ctx -> bracket_ (CUDA.push ctx) CUDA.pop (FL.mapM_ (const Stream.destroy) ss) + HT.delete tbl lctx in message "flush reservoir" >> HT.mapM_ clean tbl @@ -150,13 +163,13 @@ {-# INLINE trace #-} trace :: String -> IO a -> IO a -trace msg next = D.message D.dump_exec ("stream: " ++ msg) >> next +trace msg next = message msg >> next {-# INLINE message #-} message :: String -> IO () -message s = s `trace` return () +message msg = D.traceIO D.dump_sched ("stream: " ++ msg) {-# INLINE showStream #-} showStream :: Stream -> String -showStream (Stream.Stream s) = show s +showStream (Stream s) = show s diff --git a/Data/Array/Accelerate/CUDA/Foreign.hs b/Data/Array/Accelerate/CUDA/Foreign.hs --- a/Data/Array/Accelerate/CUDA/Foreign.hs +++ b/Data/Array/Accelerate/CUDA/Foreign.hs @@ -1,6 +1,6 @@ -- | -- Module : Data.Array.Accelerate.CUDA.Foreign --- Copyright : [2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell, Robert Clifton-Everest +-- Copyright : [2013..2014] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell, Robert Clifton-Everest -- License : BSD3 -- -- Maintainer : Robert Clifton-Everest diff --git a/Data/Array/Accelerate/CUDA/Foreign/Export.hs b/Data/Array/Accelerate/CUDA/Foreign/Export.hs --- a/Data/Array/Accelerate/CUDA/Foreign/Export.hs +++ b/Data/Array/Accelerate/CUDA/Foreign/Export.hs @@ -1,18 +1,20 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ImpredicativeTypes #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.CUDA.Foreign.Export --- Copyright : [2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell, Robert Clifton-Everest +-- Copyright : [2013..2014] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell, Robert Clifton-Everest -- License : BSD3 -- -- Maintainer : Robert Clifton-Everest @@ -38,24 +40,25 @@ ) where -import Prelude as P import Data.Functor import Control.Applicative +import Control.Monad.State ( liftIO ) import Foreign.StablePtr import Foreign.C.Types import Foreign.Ptr import Foreign.Storable ( Storable(..) ) import Foreign.Marshal.Array ( peekArray, pokeArray, mallocArray ) import Foreign.Marshal.Alloc ( free ) -import Control.Monad.State ( liftIO ) -import qualified Foreign.CUDA.Driver as CUDA import Language.Haskell.TH hiding ( ppr ) +import qualified Foreign.CUDA.Driver as CUDA +import Prelude as P + -- friends import Data.Array.Accelerate.Smart ( Acc ) import Data.Array.Accelerate.Type import Data.Array.Accelerate.Array.Data -import Data.Array.Accelerate.CUDA ( run1In ) +import Data.Array.Accelerate.CUDA ( run1With ) import Data.Array.Accelerate.CUDA.Array.Sugar hiding ( shape, size ) import Data.Array.Accelerate.CUDA.Array.Data hiding ( pokeArray, peekArray, mallocArray ) import Data.Array.Accelerate.CUDA.State @@ -210,12 +213,13 @@ shbuf <- liftIO $ mallocArray (P.length sh') liftIO $ pokeArray shbuf (map fromIntegral sh') - dptrs <- devicePtrsToWordPtrs adata <$> devicePtrsOfArrayData adata - pbuf <- liftIO $ mallocArray (P.length dptrs) - liftIO $ pokeArray pbuf dptrs + withDevicePtrs adata Nothing $ \dptrs -> do + let wptrs = devicePtrsToWordPtrs adata dptrs + pbuf <- liftIO $ mallocArray (P.length wptrs) + liftIO $ pokeArray pbuf wptrs - sa <- liftIO $ newStablePtr (EArray a) - return (shbuf, pbuf, sa) + sa <- liftIO $ newStablePtr (EArray a) + return (shbuf, pbuf, sa) marshalOut (ArraysRpair aR1 aR2) (x,y) ptr = do ptr' <- marshalOut aR1 x ptr @@ -226,13 +230,17 @@ -- a function callable from foreign code with the second argument specifying it's name. exportAfun :: Name -> String -> Q [Dec] exportAfun fname ename = do +#if __GLASGOW_HASKELL__ <= 710 (VarI n ty _ _) <- reify fname +#else + (VarI n ty _) <- reify fname +#endif -- Generate initialisation function genCompileFun n ename ty genCompileFun :: Name -> String -> Type -> Q [Dec] -genCompileFun fname ename ty@(AppT (AppT ArrowT (AppT _ a)) (AppT _ b)) +genCompileFun fname ename (AppT (AppT ArrowT (AppT _ _)) (AppT _ _)) = sequence [sig, dec, expt] where initName = mkName ename @@ -254,14 +262,14 @@ ef :: IO (StablePtr Afun) ef = do ctx <- deRefStablePtr hndl - newStablePtr (Afun (run1In ctx f) (undefined :: a) (undefined :: b)) + newStablePtr (Afun (run1With ctx f) (undefined :: a) (undefined :: b)) -- Utility functions -- ------------------ arrayFromForeignData :: forall sh e. (Shape sh, Elt e) => DevicePtrBuffer -> ShapeBuffer -> CIO (Array sh e) arrayFromForeignData ptrs shape = do - let d = dim (ignore :: sh) -- Using ignore as using dim requires a non-dummy argument + let d = rank (ignore :: sh) -- Using ignore as using dim requires a non-dummy argument let sz = eltSize (eltType (undefined :: e)) lst <- liftIO (peekArray d shape) let sh = listToShape (map fromIntegral lst) :: sh diff --git a/Data/Array/Accelerate/CUDA/Foreign/Import.hs b/Data/Array/Accelerate/CUDA/Foreign/Import.hs --- a/Data/Array/Accelerate/CUDA/Foreign/Import.hs +++ b/Data/Array/Accelerate/CUDA/Foreign/Import.hs @@ -12,7 +12,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.CUDA.Foreign.Import --- Copyright : [2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell, Robert Clifton-Everest +-- Copyright : [2013..2014] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell, Robert Clifton-Everest -- License : BSD3 -- -- Maintainer : Robert Clifton-Everest @@ -44,15 +44,16 @@ -- * Manipulating arrays DevicePtrs, - devicePtrsOfArray, - indexArray, copyArray, + withDevicePtrs, + indexArray, useArray, useArrayAsync, peekArray, peekArrayAsync, pokeArray, pokeArrayAsync, - allocateArray, newArray, + copyArray, copyArrayAsync, + allocateArray, fromFunction, -- * Running IO actions in an Accelerate context - CIO, liftIO, inContext, inDefaultContext + CIO, Stream, liftIO, inContext, inDefaultContext ) where @@ -60,12 +61,15 @@ import Data.Array.Accelerate.CUDA.State import Data.Array.Accelerate.CUDA.Context import Data.Array.Accelerate.CUDA.Array.Sugar -import Data.Array.Accelerate.CUDA.Array.Data +import Data.Array.Accelerate.CUDA.Array.Data hiding ( withDevicePtrs ) +import qualified Data.Array.Accelerate.CUDA.Array.Data as D import Data.Array.Accelerate.CUDA.Array.Prim ( DevicePtrs ) +import Data.Array.Accelerate.CUDA.Execute.Stream ( Stream ) import Data.Typeable import Control.Exception ( bracket_ ) import Control.Monad.Trans ( liftIO ) +import qualified Foreign.CUDA.Driver.Stream as CUDA -- CUDA backend representation of foreign functions @@ -73,12 +77,12 @@ -- |CUDA foreign Acc functions are just CIO functions. -- -data CUDAForeignAcc as bs where +data CUDAForeignAcc f where CUDAForeignAcc :: String -- name of the function - -> (as -> CIO bs) -- operation to execute - -> CUDAForeignAcc as bs + -> (Stream -> as -> CIO bs) -- operation to execute + -> CUDAForeignAcc (as -> bs) -deriving instance Typeable2 CUDAForeignAcc +deriving instance Typeable CUDAForeignAcc instance Foreign CUDAForeignAcc where strForeign (CUDAForeignAcc n _) = n @@ -87,11 +91,11 @@ -- CUDA backend. -- canExecuteAcc - :: (Foreign f, Typeable as, Typeable bs) - => f as bs - -> Maybe (as -> CIO bs) + :: forall asm as bs. (Foreign asm, Typeable as, Typeable bs) + => asm (as -> bs) + -> Maybe (Stream -> as -> CIO bs) canExecuteAcc ff - | Just (CUDAForeignAcc _ fun) <- cast ff + | Just (CUDAForeignAcc _ fun) <- cast ff :: Maybe (CUDAForeignAcc (as -> bs)) = Just fun | otherwise @@ -100,13 +104,13 @@ -- |CUDA foreign Exp functions consist of a list of C header files necessary to call the function -- and the name of the function to call. -- -data CUDAForeignExp x y where +data CUDAForeignExp f where CUDAForeignExp :: IsScalar y => [String] -- header files to be imported -> String -- name of the foreign function - -> CUDAForeignExp x y + -> CUDAForeignExp (x -> y) -deriving instance Typeable2 CUDAForeignExp +deriving instance Typeable CUDAForeignExp instance Foreign CUDAForeignExp where strForeign (CUDAForeignExp _ n) = n @@ -115,11 +119,11 @@ -- for the CUDA backend. -- canExecuteExp - :: forall f x y. (Foreign f, Typeable y, Typeable x) - => f x y + :: forall asm x y. (Foreign asm, Typeable y, Typeable x) + => asm (x -> y) -> Maybe ([String], String) canExecuteExp ff - | Just (CUDAForeignExp hdr fun) <- cast ff :: Maybe (CUDAForeignExp x y) + | Just (CUDAForeignExp hdr fun) <- cast ff :: Maybe (CUDAForeignExp (x -> y)) = Just (hdr, fun) | otherwise @@ -129,10 +133,11 @@ -- User facing utility functions -- ----------------------------- --- |Get the raw CUDA device pointers associated with an array +-- |Get the raw CUDA device pointers associated with an array and call the given +-- continuation. -- -devicePtrsOfArray :: Array sh e -> CIO (DevicePtrs (EltRepr e)) -devicePtrsOfArray (Array _ adata) = devicePtrsOfArrayData adata +withDevicePtrs :: Array sh e -> Maybe CUDA.Stream -> (DevicePtrs (EltRepr e) -> CIO b) -> CIO b +withDevicePtrs (Array _ adata) = D.withDevicePtrs adata -- |Run an IO action within the given Acclerate context -- diff --git a/Data/Array/Accelerate/CUDA/FullList.hs b/Data/Array/Accelerate/CUDA/FullList.hs deleted file mode 100644 --- a/Data/Array/Accelerate/CUDA/FullList.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE PatternGuards #-} --- | --- Module : Data.Array.Accelerate.CUDA.FullList --- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- --- Non-empty lists of key/value pairs. The lists are strict in the key and lazy --- in the values. We assume that keys only occur once. --- - -module Data.Array.Accelerate.CUDA.FullList ( - - FullList(..), - List(..), - - singleton, - cons, - size, - mapM_, - lookup, - lookupDelete, - -) where - -import Prelude hiding ( lookup, mapM_ ) - - -data FullList k v = FL !k v !(List k v) -data List k v = Nil | Cons !k v !(List k v) - -infixr 5 `Cons` - -instance (Eq k, Eq v) => Eq (FullList k v) where - (FL k1 v1 xs) == (FL k2 v2 ys) = k1 == k2 && v1 == v2 && xs == ys - (FL k1 v1 xs) /= (FL k2 v2 ys) = k1 /= k2 || v1 /= v2 || xs /= ys - -instance (Eq k, Eq v) => Eq (List k v) where - (Cons k1 v1 xs) == (Cons k2 v2 ys) = k1 == k2 && v1 == v2 && xs == ys - Nil == Nil = True - _ == _ = False - - (Cons k1 v1 xs) /= (Cons k2 v2 ys) = k1 /= k2 || v1 /= v2 || xs /= ys - Nil /= Nil = False - _ /= _ = True - - --- List-like operations --- -infixr 5 `cons` -cons :: k -> v -> FullList k v -> FullList k v -cons k v (FL k' v' xs) = FL k v (Cons k' v' xs) - -singleton :: k -> v -> FullList k v -singleton k v = FL k v Nil - -size :: FullList k v -> Int -size (FL _ _ xs) = 1 + sizeL xs - -sizeL :: List k v -> Int -sizeL Nil = 0 -sizeL (Cons _ _ xs) = 1 + sizeL xs - -lookup :: Eq k => k -> FullList k v -> Maybe v -lookup key (FL k v xs) - | key == k = Just v - | otherwise = lookupL key xs -{-# INLINABLE lookup #-} -{-# SPECIALISE lookup :: () -> FullList () v -> Maybe v #-} - -lookupL :: Eq k => k -> List k v -> Maybe v -lookupL !key = go - where - go Nil = Nothing - go (Cons k v xs) - | key == k = Just v - | otherwise = go xs -{-# INLINABLE lookupL #-} -{-# SPECIALISE lookupL :: () -> List () v -> Maybe v #-} - -lookupDelete :: Eq k => k -> FullList k v -> (Maybe v, Maybe (FullList k v)) -lookupDelete key (FL k v xs) - | key == k - = case xs of - Nil -> (Just v, Nothing) - Cons k' v' xs' -> (Just v, Just $ FL k' v' xs') - - | (r, xs') <- lookupDeleteL k xs - = (r, Just $ FL k v xs') -{-# INLINABLE lookupDelete #-} -{-# SPECIALISE lookupDelete :: () -> FullList () v -> (Maybe v, Maybe (FullList () v)) #-} - -lookupDeleteL :: Eq k => k -> List k v -> (Maybe v, List k v) -lookupDeleteL !key = go - where - go Nil = (Nothing, Nil) - go (Cons k v xs) - | key == k = (Just v, xs) - | (r, xs') <- go xs = (r, Cons k v xs') -{-# INLINABLE lookupDeleteL #-} -{-# SPECIALISE lookupDeleteL :: () -> List () v -> (Maybe v, List () v) #-} - -mapM_ :: Monad m => (k -> v -> m a) -> FullList k v -> m () -mapM_ !f (FL k v xs) = f k v >> mapML_ f xs -{-# INLINABLE mapM_ #-} - -mapML_ :: Monad m => (k -> v -> m a) -> List k v -> m () -mapML_ !f = go - where - go Nil = return () - go (Cons k v xs) = f k v >> go xs -{-# INLINABLE mapML_ #-} - diff --git a/Data/Array/Accelerate/CUDA/Persistent.hs b/Data/Array/Accelerate/CUDA/Persistent.hs --- a/Data/Array/Accelerate/CUDA/Persistent.hs +++ b/Data/Array/Accelerate/CUDA/Persistent.hs @@ -1,10 +1,11 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.CUDA.Persistent --- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller +-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell @@ -22,33 +23,37 @@ ) where -- friends +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.FullList ( FullList ) +import Data.Array.Accelerate.Lifetime ( Lifetime, withLifetime, newLifetime ) import Data.Array.Accelerate.CUDA.Context -import Data.Array.Accelerate.CUDA.FullList ( FullList ) import qualified Data.Array.Accelerate.CUDA.Debug as D -import qualified Data.Array.Accelerate.CUDA.FullList as FL +import qualified Data.Array.Accelerate.FullList as FL -- libraries -import Prelude hiding ( lookup ) import Numeric -import Data.Char -import System.IO -import System.FilePath -import System.Directory -import System.IO.Error -import System.Mem.Weak import Control.Applicative import Control.Concurrent import Control.Exception -import Control.Monad.Trans -import Data.Version +import Control.Monad ( when ) import Data.Binary -import Data.Hashable import Data.Binary.Get import Data.ByteString ( ByteString ) import Data.ByteString.Internal ( w2c ) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L +import Data.Char +import Data.Hashable +import Data.Maybe ( fromMaybe ) +import Data.Version +import System.Directory +import System.FilePath +import System.IO +import System.IO.Error +import System.Mem.Weak +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Internal as BL import qualified Data.HashTable.IO as HT +import Prelude hiding ( lookup ) import qualified Foreign.CUDA.Driver as CUDA @@ -67,6 +72,8 @@ -- Interface ------------------------------------------------------------------- -- --------- -- +type HashTable key val = HT.BasicHashTable key val + data KernelTable = KT {-# UNPACK #-} !ProgramCache -- first level, in-memory cache {-# UNPACK #-} !PersistentCache -- second level, on-disk cache @@ -76,7 +83,7 @@ cacheDir <- cacheDirectory createDirectoryIfMissing True cacheDir -- - local <- HT.new + local <- newMVar =<< HT.new persistent <- restore (cacheDir "persistent.db") -- return $! KT local persistent @@ -86,7 +93,7 @@ -- the persistent cache, it is loaded and linked into the current context. -- lookup :: Context -> KernelTable -> KernelKey -> IO (Maybe KernelEntry) -lookup context (KT kt pt) !key = do +lookup context (KT !kt_ref !pt_ref) !key = withMVar kt_ref $ \kt -> do -- First check the local cache. If we get a hit, this could be: -- a) currently compiling -- b) compiled, but not linked into the current context @@ -95,7 +102,7 @@ v1 <- HT.lookup kt key case v1 of Just _ -> return v1 - Nothing -> do + Nothing -> withMVar pt_ref $ \pt -> do -- Check the persistent cache. If found, read in the associated object file -- and link it into the current context. Also add to the first-level cache. @@ -109,10 +116,11 @@ Just () -> do message "found/persistent" cubin <- () <$> cacheDirectory <*> pure (cacheFilePath key) - bin <- B.readFile cubin + bin <- BS.readFile cubin !mdl <- CUDA.loadData bin - let obj = KernelObject bin (FL.singleton (deviceContext context) mdl) - addFinalizer mdl (module_finalizer (weakContext context) key mdl) + lmdl <- newLifetime mdl + let obj = KernelObject bin (FL.singleton (deviceContext context) lmdl) + addFinalizer lmdl (module_finalizer (weakContext context) key lmdl) HT.insert kt key obj return $! Just obj @@ -124,19 +132,21 @@ -- exists there already? Would require updating that hash table as new -- entries are added, which the functions currently do not do. -- +{-# INLINE insert #-} insert :: KernelTable -> KernelKey -> KernelEntry -> IO () -insert (KT kt _) !key !val = HT.insert kt key val +insert (KT !kt_ref !_) !key !val = withMVar kt_ref $ \kt -> HT.insert kt key val -- Unload a kernel module from the specified context -- -module_finalizer :: Weak CUDA.Context -> KernelKey -> CUDA.Module -> IO () -module_finalizer weak_ctx key mdl = do +module_finalizer :: Weak (Lifetime CUDA.Context) -> KernelKey -> Lifetime CUDA.Module -> IO () +module_finalizer weak_ctx key lmdl = do mc <- deRefWeak weak_ctx case mc of - Nothing -> D.message D.dump_gc ("gc: finalise module/dead context: " ++ cacheFilePath key) - Just ctx -> D.message D.dump_gc ("gc: finalise module: " ++ cacheFilePath key) - >> bracket_ (CUDA.push ctx) CUDA.pop (CUDA.unload mdl) + Nothing -> D.traceIO D.dump_gc ("gc: finalise module/dead context: " ++ cacheFilePath key) + Just fctx -> D.traceIO D.dump_gc ("gc: finalise module: " ++ cacheFilePath key) + >> withLifetime fctx (\ctx -> withLifetime lmdl (\mdl -> + bracket_ (CUDA.push ctx) CUDA.pop (CUDA.unload mdl))) -- Local cache ----------------------------------------------------------------- @@ -160,7 +170,7 @@ -- computation and no more, but we can not do that. Instead, this is keyed to -- the generated kernel code. -- -type ProgramCache = HT.BasicHashTable KernelKey KernelEntry +type ProgramCache = MVar ( HashTable KernelKey KernelEntry ) type KernelKey = (CUDA.Compute, ByteString) data KernelEntry @@ -176,7 +186,8 @@ -- re-link into the current context. -- | KernelObject {-# UNPACK #-} !ByteString - {-# UNPACK #-} !(FullList CUDA.Context CUDA.Module) + {-# UNPACK #-} !(FullList (Lifetime CUDA.Context) + (Lifetime CUDA.Module)) -- Persistent cache ------------------------------------------------------------ @@ -185,12 +196,16 @@ -- Stash compiled code into the user's home directory so that they are available -- across separate runs of the program. -- --- TLM: we don't have any migration or versioning policy here, so cache files +-- TLM: We don't have any migration or versioning policy here, so cache files -- will be kept around indefinitely. This can easily clutter the cache by -- generating many similar kernels that differ only by, for example, an -- embedded constant value. +-- +-- One way to handle this is to put a maximum size on the cache (either as +-- disk space consumed or number of kernels) and once the maximum size is +-- reached keep only the most recently used files. -type PersistentCache = HT.BasicHashTable KernelKey () +type PersistentCache = MVar ( HashTable KernelKey () ) -- The root directory of where the various persistent cache files live; the @@ -210,7 +225,7 @@ -- cacheFilePath :: KernelKey -> FilePath cacheFilePath (cap, key) = - show cap zEncodeString (B.foldl (flip (showLitChar . w2c)) [] key) + show cap zEncodeString (BS.foldl (flip (showLitChar . w2c)) [] key) -- stolen from compiler/utils/Encoding.hs -- @@ -288,27 +303,45 @@ -- file is created, so that 'persist' can always append elements. -- restore :: FilePath -> IO PersistentCache -restore db = do - D.when D.flush_cache $ do +restore !db = do + mflush <- D.queryFlag D.flush_cache + when (fromMaybe False mflush) $ do message "deleting persistent cache" cacheDir <- cacheDirectory removeDirectoryRecursive cacheDir createDirectoryIfMissing True cacheDir -- exists <- doesFileExist db - case exists of + pt <- case exists of False -> encodeFile db (0::Int) >> HT.new True -> do - store <- L.readFile db - let (n,rest,_) = runGetState get store 0 + store <- BL.readFile db + + -- Just read the start of the input to extract the number of entries + -- in the persistent kernel table. + let (n, rest) = setup (runGetIncremental get) store + + setup (Done s _ r) lbs = (r, BL.Chunk s lbs) + setup (Partial k) lbs = setup (k (takeHeadChunk lbs)) (dropHeadChunk lbs) + setup (Fail _ p msg) _ = $internalError "restore" $ show p ++ ": " ++ msg + + takeHeadChunk (BL.Chunk h _) = Just h + takeHeadChunk _ = Nothing + + dropHeadChunk (BL.Chunk _ t) = t + dropHeadChunk _ = BL.empty + + -- Allocate the persistent hash table and populate it with entries decoded + -- from the index file pt <- HT.newSized n - -- let go [] = return () go (!k:xs) = HT.insert pt k () >> go xs - -- + message $ "persist/restore: " ++ shows n " entries" go (runGet (getMany n) rest) evaluate pt + -- + newMVar pt -- Append a single value to the persistent cache. @@ -316,8 +349,8 @@ -- This moves the compiled object file (first argument) to the appropriate -- location, and updates the database on disk. -- -persist :: FilePath -> KernelKey -> IO () -persist !cubin !key = do +persist :: KernelTable -> FilePath -> KernelKey -> IO () +persist (KT !_ !pt_ref) !cubin !key = withMVar pt_ref $ \_ -> do cacheDir <- cacheDirectory let db = cacheDir "persistent.db" cacheFile = cacheDir cacheFilePath key @@ -335,24 +368,20 @@ withBinaryFile db ReadWriteMode $ \h -> do -- The file opens with the cursor at the beginning of the file -- - n <- runGet (get :: Get Int) `fmap` L.hGet h 8 + n <- runGet (get :: Get Int) `fmap` BL.hGet h 8 hSeek h AbsoluteSeek 0 - L.hPut h (encode (n+1)) + BL.hPut h (encode (n+1)) -- Append the new entry to the end of file -- hSeek h SeekFromEnd 0 - L.hPut h (encode key) + BL.hPut h (encode key) -- Debug -- ----- {-# INLINE message #-} -message :: MonadIO m => String -> m () -message msg = trace msg $ return () - -{-# INLINE trace #-} -trace :: MonadIO m => String -> m a -> m a -trace msg next = D.message D.dump_cc ("cc: " ++ msg) >> next +message :: String -> IO () +message msg = D.traceIO D.dump_cc ("cc: " ++ msg) diff --git a/Data/Array/Accelerate/CUDA/State.hs b/Data/Array/Accelerate/CUDA/State.hs --- a/Data/Array/Accelerate/CUDA/State.hs +++ b/Data/Array/Accelerate/CUDA/State.hs @@ -1,11 +1,11 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} -- | -- Module : Data.Array.Accelerate.CUDA.State --- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller +-- [2009..2014] Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell @@ -20,34 +20,35 @@ module Data.Array.Accelerate.CUDA.State ( -- Evaluating computations - CIO, Context, evalCUDA, + CIO, Context, evalCUDA, evalCUDAState, -- Querying execution state defaultContext, deviceProperties, activeContext, kernelTable, memoryTable, streamReservoir, + eventTable, ) where -- friends +import Data.Array.Accelerate.Error import Data.Array.Accelerate.CUDA.Context -import Data.Array.Accelerate.CUDA.Debug ( message, dump_gc ) +import Data.Array.Accelerate.CUDA.Debug ( traceIO, dump_gc ) import Data.Array.Accelerate.CUDA.Persistent as KT ( KernelTable, new ) -import Data.Array.Accelerate.CUDA.Array.Table as MT ( MemoryTable, new ) +import Data.Array.Accelerate.CUDA.Array.Remote as MT ( MemoryTable, new ) import Data.Array.Accelerate.CUDA.Execute.Stream as ST ( Reservoir, new ) +import Data.Array.Accelerate.CUDA.Execute.Event as ET ( EventTable, new) import Data.Array.Accelerate.CUDA.Analysis.Device -- library -import Control.Applicative ( Applicative ) +import Control.Applicative import Control.Concurrent ( runInBoundThread ) import Control.Exception ( catch, bracket_ ) -import Control.Monad.Trans ( MonadIO ) import Control.Monad.Reader ( MonadReader, ReaderT(..), runReaderT ) import Control.Monad.State.Strict ( MonadState, StateT(..), evalStateT ) -import System.Mem ( performGC ) +import Control.Monad.Trans ( MonadIO ) import System.IO.Unsafe ( unsafePerformIO ) import Foreign.CUDA.Driver.Error import qualified Foreign.CUDA.Driver as CUDA - -#include "accelerate.h" +import Prelude -- Execution State @@ -60,7 +61,8 @@ data State = State { memoryTable :: {-# UNPACK #-} !MemoryTable, -- host/device memory associations kernelTable :: {-# UNPACK #-} !KernelTable, -- compiled kernel object code - streamReservoir :: {-# UNPACK #-} !Reservoir -- kernel execution streams + streamReservoir :: {-# UNPACK #-} !Reservoir, -- kernel execution streams + eventTable :: {-# UNPACK #-} !EventTable -- CUDA events } newtype CIO a = CIO { @@ -83,12 +85,20 @@ evalCUDA !ctx !acc = runInBoundThread (bracket_ setup teardown action) `catch` - \e -> INTERNAL_ERROR(error) "unhandled" (show (e :: CUDAException)) + \e -> $internalError "unhandled" (show (e :: CUDAException)) where setup = push ctx - teardown = pop >> performGC + teardown = pop action = evalStateT (runReaderT (runCIO acc) ctx) theState +-- |Evaluate a CUDA array computation with the specific state. Exceptions are +-- not caught. +-- +-- RCE: This is unfortunately hacky, but necessary to stop device pointers +-- leaking. +evalCUDAState :: Context -> MemoryTable -> KernelTable -> Reservoir -> EventTable -> CIO a -> IO a +evalCUDAState ctx mt kt rsv etbl acc = evalStateT (runReaderT (runCIO acc) ctx) + (State mt kt rsv etbl) -- Top-level mutable state -- ----------------------- @@ -101,11 +111,12 @@ theState :: State theState = unsafePerformIO - $ do message dump_gc "gc: initialise CUDA state" - mtb <- keepAlive =<< MT.new + $ do message "initialise CUDA state" + etbl <- keepAlive =<< ET.new + mtb <- keepAlive =<< MT.new etbl ktb <- keepAlive =<< KT.new rsv <- keepAlive =<< ST.new - return $! State mtb ktb rsv + return $! State mtb ktb rsv etbl -- Select and initialise a default CUDA device, and create a new execution @@ -115,8 +126,16 @@ {-# NOINLINE defaultContext #-} defaultContext :: Context defaultContext = unsafePerformIO $ do - message dump_gc "gc: initialise default context" + message "initialise default context" CUDA.initialise [] (dev,_) <- selectBestDevice create dev [CUDA.SchedAuto] + + +-- Debug +-- ----- + +{-# INLINE message #-} +message :: String -> IO () +message msg = traceIO dump_gc ("gc: " ++ msg) diff --git a/Data/Array/Accelerate/Internal/Check.hs b/Data/Array/Accelerate/Internal/Check.hs deleted file mode 100644 --- a/Data/Array/Accelerate/Internal/Check.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# 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, warning, assert, checkIndex, checkLength, checkSlice - -) where - -import Prelude hiding ( error ) -import Debug.Trace -import qualified Prelude as P - -data Checks = Bounds | Unsafe | Internal deriving( Eq ) - -doBoundsChecks :: Bool -#ifdef ACCELERATE_BOUNDS_CHECKS -doBoundsChecks = True -#else -doBoundsChecks = False -#endif - -doUnsafeChecks :: Bool -#ifdef ACCELERATE_UNSAFE_CHECKS -doUnsafeChecks = True -#else -doUnsafeChecks = False -#endif - -doInternalChecks :: Bool -#ifdef ACCELERATE_INTERNAL_CHECKS -doInternalChecks = True -#else -doInternalChecks = False -#endif - - -doChecks :: Checks -> Bool -{-# INLINE doChecks #-} -doChecks Bounds = doBoundsChecks -doChecks Unsafe = doUnsafeChecks -doChecks Internal = doInternalChecks - -message :: String -> Int -> Checks -> String -> String -> String -{-# INLINE message #-} -message file line kind loc msg - = unlines - $ (if kind == Internal - then (["" - ,"*** Internal error in package accelerate ***" - ,"*** Please submit a bug report at https://github.com/AccelerateHS/accelerate/issues"]++) - else id) - [ file ++ ":" ++ show line ++ " (" ++ loc ++ "): " ++ msg ] - -error :: String -> Int -> Checks -> String -> String -> a -{-# INLINE error #-} -error file line kind loc msg - = P.error (message file line kind loc msg) - -check :: String -> Int -> Checks -> String -> String -> Bool -> a -> a -{-# INLINE check #-} -check file line kind loc msg cond x - | not (doChecks kind) || cond = x - | otherwise = error file line kind loc msg - -warning :: String -> Int -> Checks -> String -> String -> Bool -> a -> a -{-# INLINE warning #-} -warning file line kind loc msg cond x - | not (doChecks kind) || cond = x - | otherwise = trace (message file line kind loc msg) x - -assert_msg :: String -assert_msg = "assertion failure" - -assert :: String -> Int -> Checks -> String -> Bool -> a -> a -{-# INLINE assert #-} -assert file line kind loc = check file line kind loc assert_msg - -checkIndex_msg :: Int -> Int -> String -{-# NOINLINE checkIndex_msg #-} -checkIndex_msg i n = "index out of bounds " ++ show (i,n) - -checkIndex :: String -> Int -> Checks -> String -> Int -> Int -> a -> a -{-# INLINE checkIndex #-} -checkIndex file line kind loc i n x - = check file line kind loc (checkIndex_msg i n) (i >= 0 && i 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/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,20 +1,3 @@ -#! /usr/bin/env runhaskell - -import Control.Monad import Distribution.Simple -import Distribution.Simple.Setup -import Distribution.Simple.Utils -import System.Directory - -main :: IO () -main = defaultMainWithHooks autoconfUserHooks { preConf = preConfHook } - where - preConfHook args flags = do - let verbosity = fromFlag (configVerbosity flags) - - confExists <- doesFileExist "configure" - unless confExists $ - rawSystemExit verbosity "autoconf" [] - - preConf autoconfUserHooks args flags +main = defaultMain diff --git a/accelerate-cuda.buildinfo.in b/accelerate-cuda.buildinfo.in deleted file mode 100644 --- a/accelerate-cuda.buildinfo.in +++ /dev/null @@ -1,3 +0,0 @@ -ghc-options: @ghc_flags@ -cc-options: @cpp_flags@ - diff --git a/accelerate-cuda.cabal b/accelerate-cuda.cabal --- a/accelerate-cuda.cabal +++ b/accelerate-cuda.cabal @@ -1,11 +1,13 @@ Name: accelerate-cuda -Version: 0.14.0.0 +Version: 0.17.0.0 Cabal-version: >= 1.6 -Tested-with: GHC == 7.6.* -Build-type: Custom +Tested-with: GHC >= 7.8 +Build-type: Simple Synopsis: Accelerate backend for NVIDIA GPUs Description: + __This backend has been deprecated in favour of .__ + . This library implements a backend for the /Accelerate/ language instrumented for parallel execution on CUDA-capable NVIDIA GPUs. For further information, refer to the main /Accelerate/ package: @@ -14,7 +16,7 @@ To use this backend you will need: . 1. A CUDA-enabled NVIDIA GPU with, for full functionality, compute - capability 1.2 or greater. See the table on Wikipedia for supported GPUs: + capability 1.3 or greater. See the table on Wikipedia for supported GPUs: . 2. The CUDA SDK, available from the NVIDIA Developer Zone: @@ -42,20 +44,12 @@ Data-files: cubits/accelerate_cuda.h cubits/accelerate_cuda_assert.h + cubits/accelerate_cuda_exceptional.h cubits/accelerate_cuda_function.h cubits/accelerate_cuda_texture.h cubits/accelerate_cuda_type.h include/AccFFI.h -Extra-tmp-files: config.status - config.log - autom4te.cache - accelerate-cuda.buildinfo -- generated by configure - -Extra-source-files: configure - accelerate-cuda.buildinfo.in - include/accelerate.h - Flag debug Description: Enable tracing message flags. These are read from the command-line @@ -90,33 +84,31 @@ Default: False Library - Include-Dirs: include - - Build-depends: accelerate == 0.14.*, + Build-depends: accelerate == 1.0.*, array >= 0.3, - base == 4.6.*, - binary >= 0.5 && < 0.7, - -- binary 0.7 untested - bytestring >= 0.9 && < 0.11, - cryptohash >= 0.7 && < 0.12, - cuda >= 0.5.1.1 && < 0.6, + base >= 4.7 && < 4.9.1, + binary >= 0.7, + bytestring >= 0.9, + containers >= 0.3, + cryptohash >= 0.7, + cuda >= 0.7, directory >= 1.0, - fclabels >= 2.0 && < 2.1, + fclabels >= 2.0, filepath >= 1.0, - hashable >= 1.1 && < 1.3, - hashtables >= 1.0.1 && < 1.2, - language-c-quote >= 0.4.4 && < 0.8, - mainland-pretty >= 0.2 && < 0.3, - mtl >= 2.0 && < 2.2, + hashable >= 1.1, + hashtables >= 1.0.1, + language-c-quote >= 0.4.4, + mainland-pretty >= 0.2, + mtl >= 2.0, old-time >= 1.0, pretty >= 1.0, process >= 1.0, - SafeSemaphore >= 0.9 && < 0.10, - srcloc >= 0.2 && < 0.5, - text >= 0.11 && < 0.12, - template-haskell >= 2.2, - transformers >= 0.2 && < 0.4, - unordered-containers >= 0.1.4 && < 0.3 + SafeSemaphore >= 0.9, + srcloc >= 0.2, + text >= 0.11, + template-haskell, + transformers >= 0.2, + unordered-containers >= 0.1.4 if os(windows) cpp-options: -DWIN32 @@ -131,14 +123,16 @@ Other-modules: Data.Array.Accelerate.CUDA.AST Data.Array.Accelerate.CUDA.Analysis.Device Data.Array.Accelerate.CUDA.Analysis.Launch + Data.Array.Accelerate.CUDA.Analysis.Shape + Data.Array.Accelerate.CUDA.Array.Remote Data.Array.Accelerate.CUDA.Array.Data - Data.Array.Accelerate.CUDA.Array.Nursery Data.Array.Accelerate.CUDA.Array.Prim + Data.Array.Accelerate.CUDA.Array.Slice Data.Array.Accelerate.CUDA.Array.Sugar - Data.Array.Accelerate.CUDA.Array.Table - Data.Array.Accelerate.CUDA.Async Data.Array.Accelerate.CUDA.CodeGen + Data.Array.Accelerate.CUDA.CodeGen.Arithmetic Data.Array.Accelerate.CUDA.CodeGen.Base + Data.Array.Accelerate.CUDA.CodeGen.Constant Data.Array.Accelerate.CUDA.CodeGen.IndexSpace Data.Array.Accelerate.CUDA.CodeGen.Mapping Data.Array.Accelerate.CUDA.CodeGen.Monad @@ -146,6 +140,7 @@ Data.Array.Accelerate.CUDA.CodeGen.Reduction Data.Array.Accelerate.CUDA.CodeGen.Stencil Data.Array.Accelerate.CUDA.CodeGen.Stencil.Extra + Data.Array.Accelerate.CUDA.CodeGen.Streaming Data.Array.Accelerate.CUDA.CodeGen.Type Data.Array.Accelerate.CUDA.Compile Data.Array.Accelerate.CUDA.Context @@ -155,10 +150,8 @@ Data.Array.Accelerate.CUDA.Execute.Stream Data.Array.Accelerate.CUDA.Foreign.Export Data.Array.Accelerate.CUDA.Foreign.Import - Data.Array.Accelerate.CUDA.FullList Data.Array.Accelerate.CUDA.Persistent Data.Array.Accelerate.CUDA.State - Data.Array.Accelerate.Internal.Check Paths_accelerate_cuda if flag(debug) @@ -188,4 +181,11 @@ source-repository head type: git location: https://github.com/AccelerateHS/accelerate-cuda + +source-repository this + type: git + tag: 0.17.0.0 + location: https://github.com/AccelerateHS/accelerate-cuda + +-- vim: nospell diff --git a/configure b/configure deleted file mode 100644 --- a/configure +++ /dev/null @@ -1,3568 +0,0 @@ -#! /bin/sh -# Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.69 for accelerate-cuda 0.14.0.0. -# -# Report bugs to . -# -# -# Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. -# -# -# This configure script is free software; the Free Software Foundation -# gives unlimited permission to copy, distribute and modify it. -## -------------------- ## -## M4sh Initialization. ## -## -------------------- ## - -# Be more Bourne compatible -DUALCASE=1; export DUALCASE # for MKS sh -if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : - emulate sh - NULLCMD=: - # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which - # is contrary to our usage. Disable this feature. - alias -g '${1+"$@"}'='"$@"' - setopt NO_GLOB_SUBST -else - case `(set -o) 2>/dev/null` in #( - *posix*) : - set -o posix ;; #( - *) : - ;; -esac -fi - - -as_nl=' -' -export as_nl -# Printing a long string crashes Solaris 7 /usr/bin/printf. -as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' -as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo -as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo -# Prefer a ksh shell builtin over an external printf program on Solaris, -# but without wasting forks for bash or zsh. -if test -z "$BASH_VERSION$ZSH_VERSION" \ - && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then - as_echo='print -r --' - as_echo_n='print -rn --' -elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then - as_echo='printf %s\n' - as_echo_n='printf %s' -else - if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then - as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' - as_echo_n='/usr/ucb/echo -n' - else - as_echo_body='eval expr "X$1" : "X\\(.*\\)"' - as_echo_n_body='eval - arg=$1; - case $arg in #( - *"$as_nl"*) - expr "X$arg" : "X\\(.*\\)$as_nl"; - arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; - esac; - expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" - ' - export as_echo_n_body - as_echo_n='sh -c $as_echo_n_body as_echo' - fi - export as_echo_body - as_echo='sh -c $as_echo_body as_echo' -fi - -# The user is always right. -if test "${PATH_SEPARATOR+set}" != set; then - PATH_SEPARATOR=: - (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { - (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || - PATH_SEPARATOR=';' - } -fi - - -# IFS -# We need space, tab and new line, in precisely that order. Quoting is -# there to prevent editors from complaining about space-tab. -# (If _AS_PATH_WALK were called with IFS unset, it would disable word -# splitting by setting IFS to empty value.) -IFS=" "" $as_nl" - -# Find who we are. Look in the path if we contain no directory separator. -as_myself= -case $0 in #(( - *[\\/]* ) as_myself=$0 ;; - *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break - done -IFS=$as_save_IFS - - ;; -esac -# We did not find ourselves, most probably we were run as `sh COMMAND' -# in which case we are not to be found in the path. -if test "x$as_myself" = x; then - as_myself=$0 -fi -if test ! -f "$as_myself"; then - $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 - exit 1 -fi - -# Unset variables that we do not need and which cause bugs (e.g. in -# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" -# suppresses any "Segmentation fault" message there. '((' could -# trigger a bug in pdksh 5.2.14. -for as_var in BASH_ENV ENV MAIL MAILPATH -do eval test x\${$as_var+set} = xset \ - && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : -done -PS1='$ ' -PS2='> ' -PS4='+ ' - -# NLS nuisances. -LC_ALL=C -export LC_ALL -LANGUAGE=C -export LANGUAGE - -# CDPATH. -(unset CDPATH) >/dev/null 2>&1 && unset CDPATH - -# Use a proper internal environment variable to ensure we don't fall - # into an infinite loop, continuously re-executing ourselves. - if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then - _as_can_reexec=no; export _as_can_reexec; - # We cannot yet assume a decent shell, so we have to provide a -# neutralization value for shells without unset; and this also -# works around shells that cannot unset nonexistent variables. -# Preserve -v and -x to the replacement shell. -BASH_ENV=/dev/null -ENV=/dev/null -(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV -case $- in # (((( - *v*x* | *x*v* ) as_opts=-vx ;; - *v* ) as_opts=-v ;; - *x* ) as_opts=-x ;; - * ) as_opts= ;; -esac -exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} -# Admittedly, this is quite paranoid, since all the known shells bail -# out after a failed `exec'. -$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 -as_fn_exit 255 - fi - # We don't want this to propagate to other subprocesses. - { _as_can_reexec=; unset _as_can_reexec;} -if test "x$CONFIG_SHELL" = x; then - as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : - emulate sh - NULLCMD=: - # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which - # is contrary to our usage. Disable this feature. - alias -g '\${1+\"\$@\"}'='\"\$@\"' - setopt NO_GLOB_SUBST -else - case \`(set -o) 2>/dev/null\` in #( - *posix*) : - set -o posix ;; #( - *) : - ;; -esac -fi -" - as_required="as_fn_return () { (exit \$1); } -as_fn_success () { as_fn_return 0; } -as_fn_failure () { as_fn_return 1; } -as_fn_ret_success () { return 0; } -as_fn_ret_failure () { return 1; } - -exitcode=0 -as_fn_success || { exitcode=1; echo as_fn_success failed.; } -as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } -as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } -as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } -if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : - -else - exitcode=1; echo positional parameters were not saved. -fi -test x\$exitcode = x0 || exit 1 -test -x / || exit 1" - as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO - as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO - eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && - test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1" - if (eval "$as_required") 2>/dev/null; then : - as_have_required=yes -else - as_have_required=no -fi - if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : - -else - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -as_found=false -for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - as_found=: - case $as_dir in #( - /*) - for as_base in sh bash ksh sh5; do - # Try only shells that exist, to save several forks. - as_shell=$as_dir/$as_base - if { test -f "$as_shell" || test -f "$as_shell.exe"; } && - { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : - CONFIG_SHELL=$as_shell as_have_required=yes - if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : - break 2 -fi -fi - done;; - esac - as_found=false -done -$as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && - { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : - CONFIG_SHELL=$SHELL as_have_required=yes -fi; } -IFS=$as_save_IFS - - - if test "x$CONFIG_SHELL" != x; then : - export CONFIG_SHELL - # We cannot yet assume a decent shell, so we have to provide a -# neutralization value for shells without unset; and this also -# works around shells that cannot unset nonexistent variables. -# Preserve -v and -x to the replacement shell. -BASH_ENV=/dev/null -ENV=/dev/null -(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV -case $- in # (((( - *v*x* | *x*v* ) as_opts=-vx ;; - *v* ) as_opts=-v ;; - *x* ) as_opts=-x ;; - * ) as_opts= ;; -esac -exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} -# Admittedly, this is quite paranoid, since all the known shells bail -# out after a failed `exec'. -$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 -exit 255 -fi - - if test x$as_have_required = xno; then : - $as_echo "$0: This script requires a shell more modern than all" - $as_echo "$0: the shells that I found on your system." - if test x${ZSH_VERSION+set} = xset ; then - $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" - $as_echo "$0: be upgraded to zsh 4.3.4 or later." - else - $as_echo "$0: Please tell bug-autoconf@gnu.org and -$0: accelerate-haskell@googlegroups.com about your system, -$0: including any error possibly output before this -$0: message. Then install a modern shell, or manually run -$0: the script under such a shell if you do have one." - fi - exit 1 -fi -fi -fi -SHELL=${CONFIG_SHELL-/bin/sh} -export SHELL -# Unset more variables known to interfere with behavior of common tools. -CLICOLOR_FORCE= GREP_OPTIONS= -unset CLICOLOR_FORCE GREP_OPTIONS - -## --------------------- ## -## M4sh Shell Functions. ## -## --------------------- ## -# as_fn_unset VAR -# --------------- -# Portably unset VAR. -as_fn_unset () -{ - { eval $1=; unset $1;} -} -as_unset=as_fn_unset - -# as_fn_set_status STATUS -# ----------------------- -# Set $? to STATUS, without forking. -as_fn_set_status () -{ - return $1 -} # as_fn_set_status - -# as_fn_exit STATUS -# ----------------- -# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. -as_fn_exit () -{ - set +e - as_fn_set_status $1 - exit $1 -} # as_fn_exit - -# as_fn_mkdir_p -# ------------- -# Create "$as_dir" as a directory, including parents if necessary. -as_fn_mkdir_p () -{ - - case $as_dir in #( - -*) as_dir=./$as_dir;; - esac - test -d "$as_dir" || eval $as_mkdir_p || { - as_dirs= - while :; do - case $as_dir in #( - *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( - *) as_qdir=$as_dir;; - esac - as_dirs="'$as_qdir' $as_dirs" - as_dir=`$as_dirname -- "$as_dir" || -$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_dir" : 'X\(//\)[^/]' \| \ - X"$as_dir" : 'X\(//\)$' \| \ - X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$as_dir" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - test -d "$as_dir" && break - done - test -z "$as_dirs" || eval "mkdir $as_dirs" - } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" - - -} # as_fn_mkdir_p - -# as_fn_executable_p FILE -# ----------------------- -# Test if FILE is an executable regular file. -as_fn_executable_p () -{ - test -f "$1" && test -x "$1" -} # as_fn_executable_p -# as_fn_append VAR VALUE -# ---------------------- -# Append the text in VALUE to the end of the definition contained in VAR. Take -# advantage of any shell optimizations that allow amortized linear growth over -# repeated appends, instead of the typical quadratic growth present in naive -# implementations. -if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : - eval 'as_fn_append () - { - eval $1+=\$2 - }' -else - as_fn_append () - { - eval $1=\$$1\$2 - } -fi # as_fn_append - -# as_fn_arith ARG... -# ------------------ -# Perform arithmetic evaluation on the ARGs, and store the result in the -# global $as_val. Take advantage of shells that can avoid forks. The arguments -# must be portable across $(()) and expr. -if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : - eval 'as_fn_arith () - { - as_val=$(( $* )) - }' -else - as_fn_arith () - { - as_val=`expr "$@" || test $? -eq 1` - } -fi # as_fn_arith - - -# as_fn_error STATUS ERROR [LINENO LOG_FD] -# ---------------------------------------- -# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are -# provided, also output the error to LOG_FD, referencing LINENO. Then exit the -# script with STATUS, using 1 if that was 0. -as_fn_error () -{ - as_status=$1; test $as_status -eq 0 && as_status=1 - if test "$4"; then - as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 - fi - $as_echo "$as_me: error: $2" >&2 - as_fn_exit $as_status -} # as_fn_error - -if expr a : '\(a\)' >/dev/null 2>&1 && - test "X`expr 00001 : '.*\(...\)'`" = X001; then - as_expr=expr -else - as_expr=false -fi - -if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then - as_basename=basename -else - as_basename=false -fi - -if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then - as_dirname=dirname -else - as_dirname=false -fi - -as_me=`$as_basename -- "$0" || -$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ - X"$0" : 'X\(//\)$' \| \ - X"$0" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X/"$0" | - sed '/^.*\/\([^/][^/]*\)\/*$/{ - s//\1/ - q - } - /^X\/\(\/\/\)$/{ - s//\1/ - q - } - /^X\/\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - -# Avoid depending upon Character Ranges. -as_cr_letters='abcdefghijklmnopqrstuvwxyz' -as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' -as_cr_Letters=$as_cr_letters$as_cr_LETTERS -as_cr_digits='0123456789' -as_cr_alnum=$as_cr_Letters$as_cr_digits - - - as_lineno_1=$LINENO as_lineno_1a=$LINENO - as_lineno_2=$LINENO as_lineno_2a=$LINENO - eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && - test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { - # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) - sed -n ' - p - /[$]LINENO/= - ' <$as_myself | - sed ' - s/[$]LINENO.*/&-/ - t lineno - b - :lineno - N - :loop - s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ - t loop - s/-\n.*// - ' >$as_me.lineno && - chmod +x "$as_me.lineno" || - { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } - - # If we had to re-execute with $CONFIG_SHELL, we're ensured to have - # already done that, so ensure we don't try to do so again and fall - # in an infinite loop. This has already happened in practice. - _as_can_reexec=no; export _as_can_reexec - # Don't try to exec as it changes $[0], causing all sort of problems - # (the dirname of $[0] is not the place where we might find the - # original and so on. Autoconf is especially sensitive to this). - . "./$as_me.lineno" - # Exit status is that of the last command. - exit -} - -ECHO_C= ECHO_N= ECHO_T= -case `echo -n x` in #((((( --n*) - case `echo 'xy\c'` in - *c*) ECHO_T=' ';; # ECHO_T is single tab character. - xy) ECHO_C='\c';; - *) echo `echo ksh88 bug on AIX 6.1` > /dev/null - ECHO_T=' ';; - esac;; -*) - ECHO_N='-n';; -esac - -rm -f conf$$ conf$$.exe conf$$.file -if test -d conf$$.dir; then - rm -f conf$$.dir/conf$$.file -else - rm -f conf$$.dir - mkdir conf$$.dir 2>/dev/null -fi -if (echo >conf$$.file) 2>/dev/null; then - if ln -s conf$$.file conf$$ 2>/dev/null; then - as_ln_s='ln -s' - # ... but there are two gotchas: - # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. - # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. - # In both cases, we have to default to `cp -pR'. - ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || - as_ln_s='cp -pR' - elif ln conf$$.file conf$$ 2>/dev/null; then - as_ln_s=ln - else - as_ln_s='cp -pR' - fi -else - as_ln_s='cp -pR' -fi -rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file -rmdir conf$$.dir 2>/dev/null - -if mkdir -p . 2>/dev/null; then - as_mkdir_p='mkdir -p "$as_dir"' -else - test -d ./-p && rmdir ./-p - as_mkdir_p=false -fi - -as_test_x='test -x' -as_executable_p=as_fn_executable_p - -# Sed expression to map a string onto a valid CPP name. -as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" - -# Sed expression to map a string onto a valid variable name. -as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" - - -test -n "$DJDIR" || exec 7<&0 &1 - -# Name of the host. -# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, -# so uname gets run too. -ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` - -# -# Initializations. -# -ac_default_prefix=/usr/local -ac_clean_files= -ac_config_libobj_dir=. -LIBOBJS= -cross_compiling=no -subdirs= -MFLAGS= -MAKEFLAGS= - -# Identity of this package. -PACKAGE_NAME='accelerate-cuda' -PACKAGE_TARNAME='accelerate-cuda' -PACKAGE_VERSION='0.14.0.0' -PACKAGE_STRING='accelerate-cuda 0.14.0.0' -PACKAGE_BUGREPORT='accelerate-haskell@googlegroups.com' -PACKAGE_URL='' - -ac_unique_file="Data/Array/Accelerate/CUDA.hs" -ac_subst_vars='LTLIBOBJS -LIBOBJS -cpp_flags -ghc_flags -OBJEXT -EXEEXT -ac_ct_CXX -CPPFLAGS -LDFLAGS -CXXFLAGS -CXX -GHC -target_alias -host_alias -build_alias -LIBS -ECHO_T -ECHO_N -ECHO_C -DEFS -mandir -localedir -libdir -psdir -pdfdir -dvidir -htmldir -infodir -docdir -oldincludedir -includedir -localstatedir -sharedstatedir -sysconfdir -datadir -datarootdir -libexecdir -sbindir -bindir -program_transform_name -prefix -exec_prefix -PACKAGE_URL -PACKAGE_BUGREPORT -PACKAGE_STRING -PACKAGE_VERSION -PACKAGE_TARNAME -PACKAGE_NAME -PATH_SEPARATOR -SHELL' -ac_subst_files='' -ac_user_opts=' -enable_option_checking -with_compiler -with_nvcc -with_gcc -' - ac_precious_vars='build_alias -host_alias -target_alias -CXX -CXXFLAGS -LDFLAGS -LIBS -CPPFLAGS -CCC' - - -# Initialize some variables set by options. -ac_init_help= -ac_init_version=false -ac_unrecognized_opts= -ac_unrecognized_sep= -# The variables have the same names as the options, with -# dashes changed to underlines. -cache_file=/dev/null -exec_prefix=NONE -no_create= -no_recursion= -prefix=NONE -program_prefix=NONE -program_suffix=NONE -program_transform_name=s,x,x, -silent= -site= -srcdir= -verbose= -x_includes=NONE -x_libraries=NONE - -# Installation directory options. -# These are left unexpanded so users can "make install exec_prefix=/foo" -# and all the variables that are supposed to be based on exec_prefix -# by default will actually change. -# Use braces instead of parens because sh, perl, etc. also accept them. -# (The list follows the same order as the GNU Coding Standards.) -bindir='${exec_prefix}/bin' -sbindir='${exec_prefix}/sbin' -libexecdir='${exec_prefix}/libexec' -datarootdir='${prefix}/share' -datadir='${datarootdir}' -sysconfdir='${prefix}/etc' -sharedstatedir='${prefix}/com' -localstatedir='${prefix}/var' -includedir='${prefix}/include' -oldincludedir='/usr/include' -docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' -infodir='${datarootdir}/info' -htmldir='${docdir}' -dvidir='${docdir}' -pdfdir='${docdir}' -psdir='${docdir}' -libdir='${exec_prefix}/lib' -localedir='${datarootdir}/locale' -mandir='${datarootdir}/man' - -ac_prev= -ac_dashdash= -for ac_option -do - # If the previous option needs an argument, assign it. - if test -n "$ac_prev"; then - eval $ac_prev=\$ac_option - ac_prev= - continue - fi - - case $ac_option in - *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; - *=) ac_optarg= ;; - *) ac_optarg=yes ;; - esac - - # Accept the important Cygnus configure options, so we can diagnose typos. - - case $ac_dashdash$ac_option in - --) - ac_dashdash=yes ;; - - -bindir | --bindir | --bindi | --bind | --bin | --bi) - ac_prev=bindir ;; - -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) - bindir=$ac_optarg ;; - - -build | --build | --buil | --bui | --bu) - ac_prev=build_alias ;; - -build=* | --build=* | --buil=* | --bui=* | --bu=*) - build_alias=$ac_optarg ;; - - -cache-file | --cache-file | --cache-fil | --cache-fi \ - | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) - ac_prev=cache_file ;; - -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ - | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) - cache_file=$ac_optarg ;; - - --config-cache | -C) - cache_file=config.cache ;; - - -datadir | --datadir | --datadi | --datad) - ac_prev=datadir ;; - -datadir=* | --datadir=* | --datadi=* | --datad=*) - datadir=$ac_optarg ;; - - -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ - | --dataroo | --dataro | --datar) - ac_prev=datarootdir ;; - -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ - | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) - datarootdir=$ac_optarg ;; - - -disable-* | --disable-*) - ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid feature name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"enable_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" - ac_unrecognized_sep=', ';; - esac - eval enable_$ac_useropt=no ;; - - -docdir | --docdir | --docdi | --doc | --do) - ac_prev=docdir ;; - -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) - docdir=$ac_optarg ;; - - -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) - ac_prev=dvidir ;; - -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) - dvidir=$ac_optarg ;; - - -enable-* | --enable-*) - ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid feature name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"enable_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" - ac_unrecognized_sep=', ';; - esac - eval enable_$ac_useropt=\$ac_optarg ;; - - -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ - | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ - | --exec | --exe | --ex) - ac_prev=exec_prefix ;; - -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ - | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ - | --exec=* | --exe=* | --ex=*) - exec_prefix=$ac_optarg ;; - - -gas | --gas | --ga | --g) - # Obsolete; use --with-gas. - with_gas=yes ;; - - -help | --help | --hel | --he | -h) - ac_init_help=long ;; - -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) - ac_init_help=recursive ;; - -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) - ac_init_help=short ;; - - -host | --host | --hos | --ho) - ac_prev=host_alias ;; - -host=* | --host=* | --hos=* | --ho=*) - host_alias=$ac_optarg ;; - - -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) - ac_prev=htmldir ;; - -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ - | --ht=*) - htmldir=$ac_optarg ;; - - -includedir | --includedir | --includedi | --included | --include \ - | --includ | --inclu | --incl | --inc) - ac_prev=includedir ;; - -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ - | --includ=* | --inclu=* | --incl=* | --inc=*) - includedir=$ac_optarg ;; - - -infodir | --infodir | --infodi | --infod | --info | --inf) - ac_prev=infodir ;; - -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) - infodir=$ac_optarg ;; - - -libdir | --libdir | --libdi | --libd) - ac_prev=libdir ;; - -libdir=* | --libdir=* | --libdi=* | --libd=*) - libdir=$ac_optarg ;; - - -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ - | --libexe | --libex | --libe) - ac_prev=libexecdir ;; - -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ - | --libexe=* | --libex=* | --libe=*) - libexecdir=$ac_optarg ;; - - -localedir | --localedir | --localedi | --localed | --locale) - ac_prev=localedir ;; - -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) - localedir=$ac_optarg ;; - - -localstatedir | --localstatedir | --localstatedi | --localstated \ - | --localstate | --localstat | --localsta | --localst | --locals) - ac_prev=localstatedir ;; - -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ - | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) - localstatedir=$ac_optarg ;; - - -mandir | --mandir | --mandi | --mand | --man | --ma | --m) - ac_prev=mandir ;; - -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) - mandir=$ac_optarg ;; - - -nfp | --nfp | --nf) - # Obsolete; use --without-fp. - with_fp=no ;; - - -no-create | --no-create | --no-creat | --no-crea | --no-cre \ - | --no-cr | --no-c | -n) - no_create=yes ;; - - -no-recursion | --no-recursion | --no-recursio | --no-recursi \ - | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) - no_recursion=yes ;; - - -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ - | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ - | --oldin | --oldi | --old | --ol | --o) - ac_prev=oldincludedir ;; - -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ - | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ - | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) - oldincludedir=$ac_optarg ;; - - -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) - ac_prev=prefix ;; - -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) - prefix=$ac_optarg ;; - - -program-prefix | --program-prefix | --program-prefi | --program-pref \ - | --program-pre | --program-pr | --program-p) - ac_prev=program_prefix ;; - -program-prefix=* | --program-prefix=* | --program-prefi=* \ - | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) - program_prefix=$ac_optarg ;; - - -program-suffix | --program-suffix | --program-suffi | --program-suff \ - | --program-suf | --program-su | --program-s) - ac_prev=program_suffix ;; - -program-suffix=* | --program-suffix=* | --program-suffi=* \ - | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) - program_suffix=$ac_optarg ;; - - -program-transform-name | --program-transform-name \ - | --program-transform-nam | --program-transform-na \ - | --program-transform-n | --program-transform- \ - | --program-transform | --program-transfor \ - | --program-transfo | --program-transf \ - | --program-trans | --program-tran \ - | --progr-tra | --program-tr | --program-t) - ac_prev=program_transform_name ;; - -program-transform-name=* | --program-transform-name=* \ - | --program-transform-nam=* | --program-transform-na=* \ - | --program-transform-n=* | --program-transform-=* \ - | --program-transform=* | --program-transfor=* \ - | --program-transfo=* | --program-transf=* \ - | --program-trans=* | --program-tran=* \ - | --progr-tra=* | --program-tr=* | --program-t=*) - program_transform_name=$ac_optarg ;; - - -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) - ac_prev=pdfdir ;; - -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) - pdfdir=$ac_optarg ;; - - -psdir | --psdir | --psdi | --psd | --ps) - ac_prev=psdir ;; - -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) - psdir=$ac_optarg ;; - - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ - | -silent | --silent | --silen | --sile | --sil) - silent=yes ;; - - -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) - ac_prev=sbindir ;; - -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ - | --sbi=* | --sb=*) - sbindir=$ac_optarg ;; - - -sharedstatedir | --sharedstatedir | --sharedstatedi \ - | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ - | --sharedst | --shareds | --shared | --share | --shar \ - | --sha | --sh) - ac_prev=sharedstatedir ;; - -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ - | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ - | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ - | --sha=* | --sh=*) - sharedstatedir=$ac_optarg ;; - - -site | --site | --sit) - ac_prev=site ;; - -site=* | --site=* | --sit=*) - site=$ac_optarg ;; - - -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) - ac_prev=srcdir ;; - -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) - srcdir=$ac_optarg ;; - - -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ - | --syscon | --sysco | --sysc | --sys | --sy) - ac_prev=sysconfdir ;; - -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ - | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) - sysconfdir=$ac_optarg ;; - - -target | --target | --targe | --targ | --tar | --ta | --t) - ac_prev=target_alias ;; - -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) - target_alias=$ac_optarg ;; - - -v | -verbose | --verbose | --verbos | --verbo | --verb) - verbose=yes ;; - - -version | --version | --versio | --versi | --vers | -V) - ac_init_version=: ;; - - -with-* | --with-*) - ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid package name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"with_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" - ac_unrecognized_sep=', ';; - esac - eval with_$ac_useropt=\$ac_optarg ;; - - -without-* | --without-*) - ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid package name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"with_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" - ac_unrecognized_sep=', ';; - esac - eval with_$ac_useropt=no ;; - - --x) - # Obsolete; use --with-x. - with_x=yes ;; - - -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ - | --x-incl | --x-inc | --x-in | --x-i) - ac_prev=x_includes ;; - -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ - | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) - x_includes=$ac_optarg ;; - - -x-libraries | --x-libraries | --x-librarie | --x-librari \ - | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) - ac_prev=x_libraries ;; - -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ - | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) - x_libraries=$ac_optarg ;; - - -*) as_fn_error $? "unrecognized option: \`$ac_option' -Try \`$0 --help' for more information" - ;; - - *=*) - ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` - # Reject names that are not valid shell variable names. - case $ac_envvar in #( - '' | [0-9]* | *[!_$as_cr_alnum]* ) - as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; - esac - eval $ac_envvar=\$ac_optarg - export $ac_envvar ;; - - *) - # FIXME: should be removed in autoconf 3.0. - $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 - expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && - $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 - : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" - ;; - - esac -done - -if test -n "$ac_prev"; then - ac_option=--`echo $ac_prev | sed 's/_/-/g'` - as_fn_error $? "missing argument to $ac_option" -fi - -if test -n "$ac_unrecognized_opts"; then - case $enable_option_checking in - no) ;; - fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; - *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; - esac -fi - -# Check all directory arguments for consistency. -for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ - datadir sysconfdir sharedstatedir localstatedir includedir \ - oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ - libdir localedir mandir -do - eval ac_val=\$$ac_var - # Remove trailing slashes. - case $ac_val in - */ ) - ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` - eval $ac_var=\$ac_val;; - esac - # Be sure to have absolute directory names. - case $ac_val in - [\\/$]* | ?:[\\/]* ) continue;; - NONE | '' ) case $ac_var in *prefix ) continue;; esac;; - esac - as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" -done - -# There might be people who depend on the old broken behavior: `$host' -# used to hold the argument of --host etc. -# FIXME: To remove some day. -build=$build_alias -host=$host_alias -target=$target_alias - -# FIXME: To remove some day. -if test "x$host_alias" != x; then - if test "x$build_alias" = x; then - cross_compiling=maybe - elif test "x$build_alias" != "x$host_alias"; then - cross_compiling=yes - fi -fi - -ac_tool_prefix= -test -n "$host_alias" && ac_tool_prefix=$host_alias- - -test "$silent" = yes && exec 6>/dev/null - - -ac_pwd=`pwd` && test -n "$ac_pwd" && -ac_ls_di=`ls -di .` && -ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || - as_fn_error $? "working directory cannot be determined" -test "X$ac_ls_di" = "X$ac_pwd_ls_di" || - as_fn_error $? "pwd does not report name of working directory" - - -# Find the source files, if location was not specified. -if test -z "$srcdir"; then - ac_srcdir_defaulted=yes - # Try the directory containing this script, then the parent directory. - ac_confdir=`$as_dirname -- "$as_myself" || -$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_myself" : 'X\(//\)[^/]' \| \ - X"$as_myself" : 'X\(//\)$' \| \ - X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$as_myself" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - srcdir=$ac_confdir - if test ! -r "$srcdir/$ac_unique_file"; then - srcdir=.. - fi -else - ac_srcdir_defaulted=no -fi -if test ! -r "$srcdir/$ac_unique_file"; then - test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." - as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" -fi -ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" -ac_abs_confdir=`( - cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" - pwd)` -# When building in place, set srcdir=. -if test "$ac_abs_confdir" = "$ac_pwd"; then - srcdir=. -fi -# Remove unnecessary trailing slashes from srcdir. -# Double slashes in file names in object file debugging info -# mess up M-x gdb in Emacs. -case $srcdir in -*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; -esac -for ac_var in $ac_precious_vars; do - eval ac_env_${ac_var}_set=\${${ac_var}+set} - eval ac_env_${ac_var}_value=\$${ac_var} - eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} - eval ac_cv_env_${ac_var}_value=\$${ac_var} -done - -# -# Report the --help message. -# -if test "$ac_init_help" = "long"; then - # Omit some internal or obsolete options to make the list less imposing. - # This message is too long to be a string in the A/UX 3.1 sh. - cat <<_ACEOF -\`configure' configures accelerate-cuda 0.14.0.0 to adapt to many kinds of systems. - -Usage: $0 [OPTION]... [VAR=VALUE]... - -To assign environment variables (e.g., CC, CFLAGS...), specify them as -VAR=VALUE. See below for descriptions of some of the useful variables. - -Defaults for the options are specified in brackets. - -Configuration: - -h, --help display this help and exit - --help=short display options specific to this package - --help=recursive display the short help of all the included packages - -V, --version display version information and exit - -q, --quiet, --silent do not print \`checking ...' messages - --cache-file=FILE cache test results in FILE [disabled] - -C, --config-cache alias for \`--cache-file=config.cache' - -n, --no-create do not create output files - --srcdir=DIR find the sources in DIR [configure dir or \`..'] - -Installation directories: - --prefix=PREFIX install architecture-independent files in PREFIX - [$ac_default_prefix] - --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX - [PREFIX] - -By default, \`make install' will install all the files in -\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify -an installation prefix other than \`$ac_default_prefix' using \`--prefix', -for instance \`--prefix=\$HOME'. - -For better control, use the options below. - -Fine tuning of the installation directories: - --bindir=DIR user executables [EPREFIX/bin] - --sbindir=DIR system admin executables [EPREFIX/sbin] - --libexecdir=DIR program executables [EPREFIX/libexec] - --sysconfdir=DIR read-only single-machine data [PREFIX/etc] - --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] - --localstatedir=DIR modifiable single-machine data [PREFIX/var] - --libdir=DIR object code libraries [EPREFIX/lib] - --includedir=DIR C header files [PREFIX/include] - --oldincludedir=DIR C header files for non-gcc [/usr/include] - --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] - --datadir=DIR read-only architecture-independent data [DATAROOTDIR] - --infodir=DIR info documentation [DATAROOTDIR/info] - --localedir=DIR locale-dependent data [DATAROOTDIR/locale] - --mandir=DIR man documentation [DATAROOTDIR/man] - --docdir=DIR documentation root [DATAROOTDIR/doc/accelerate-cuda] - --htmldir=DIR html documentation [DOCDIR] - --dvidir=DIR dvi documentation [DOCDIR] - --pdfdir=DIR pdf documentation [DOCDIR] - --psdir=DIR ps documentation [DOCDIR] -_ACEOF - - cat <<\_ACEOF -_ACEOF -fi - -if test -n "$ac_init_help"; then - case $ac_init_help in - short | recursive ) echo "Configuration of accelerate-cuda 0.14.0.0:";; - esac - cat <<\_ACEOF - -Optional Packages: - --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] - --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) -Haskell compiler -CUDA compiler -C compiler - -Some influential environment variables: - CXX C++ compiler command - CXXFLAGS C++ compiler flags - LDFLAGS linker flags, e.g. -L 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.14.0.0 -generated by GNU Autoconf 2.69 - -Copyright (C) 2012 Free Software Foundation, Inc. -This configure script is free software; the Free Software Foundation -gives unlimited permission to copy, distribute and modify it. -_ACEOF - exit -fi - -## ------------------------ ## -## Autoconf initialization. ## -## ------------------------ ## - -# ac_fn_cxx_try_compile LINENO -# ---------------------------- -# Try to compile conftest.$ac_ext, and return whether this succeeded. -ac_fn_cxx_try_compile () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - rm -f conftest.$ac_objext - if { { ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_compile") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - grep -v '^ *+' conftest.err >conftest.er1 - cat conftest.er1 >&5 - mv -f conftest.er1 conftest.err - fi - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } && { - test -z "$ac_cxx_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then : - ac_retval=0 -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_retval=1 -fi - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_cxx_try_compile -cat >config.log <<_ACEOF -This file contains any messages produced by compilers while -running configure, to aid debugging if configure makes a mistake. - -It was created by accelerate-cuda $as_me 0.14.0.0, which was -generated by GNU Autoconf 2.69. Invocation command line was - - $ $0 $@ - -_ACEOF -exec 5>>config.log -{ -cat <<_ASUNAME -## --------- ## -## Platform. ## -## --------- ## - -hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` -uname -m = `(uname -m) 2>/dev/null || echo unknown` -uname -r = `(uname -r) 2>/dev/null || echo unknown` -uname -s = `(uname -s) 2>/dev/null || echo unknown` -uname -v = `(uname -v) 2>/dev/null || echo unknown` - -/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` -/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` - -/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` -/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` -/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` -/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` -/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` -/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` -/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` - -_ASUNAME - -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - $as_echo "PATH: $as_dir" - done -IFS=$as_save_IFS - -} >&5 - -cat >&5 <<_ACEOF - - -## ----------- ## -## Core tests. ## -## ----------- ## - -_ACEOF - - -# Keep a trace of the command line. -# Strip out --no-create and --no-recursion so they do not pile up. -# Strip out --silent because we don't want to record it for future runs. -# Also quote any args containing shell meta-characters. -# Make two passes to allow for proper duplicate-argument suppression. -ac_configure_args= -ac_configure_args0= -ac_configure_args1= -ac_must_keep_next=false -for ac_pass in 1 2 -do - for ac_arg - do - case $ac_arg in - -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ - | -silent | --silent | --silen | --sile | --sil) - continue ;; - *\'*) - ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; - esac - case $ac_pass in - 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; - 2) - as_fn_append ac_configure_args1 " '$ac_arg'" - if test $ac_must_keep_next = true; then - ac_must_keep_next=false # Got value, back to normal. - else - case $ac_arg in - *=* | --config-cache | -C | -disable-* | --disable-* \ - | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ - | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ - | -with-* | --with-* | -without-* | --without-* | --x) - case "$ac_configure_args0 " in - "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; - esac - ;; - -* ) ac_must_keep_next=true ;; - esac - fi - as_fn_append ac_configure_args " '$ac_arg'" - ;; - esac - done -done -{ ac_configure_args0=; unset ac_configure_args0;} -{ ac_configure_args1=; unset ac_configure_args1;} - -# When interrupted or exit'd, cleanup temporary files, and complete -# config.log. We remove comments because anyway the quotes in there -# would cause problems or look ugly. -# WARNING: Use '\'' to represent an apostrophe within the trap. -# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. -trap 'exit_status=$? - # Save into config.log some information that might help in debugging. - { - echo - - $as_echo "## ---------------- ## -## Cache variables. ## -## ---------------- ##" - echo - # The following way of writing the cache mishandles newlines in values, -( - for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do - eval ac_val=\$$ac_var - case $ac_val in #( - *${as_nl}*) - case $ac_var in #( - *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 -$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; - esac - case $ac_var in #( - _ | IFS | as_nl) ;; #( - BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( - *) { eval $ac_var=; unset $ac_var;} ;; - esac ;; - esac - done - (set) 2>&1 | - case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( - *${as_nl}ac_space=\ *) - sed -n \ - "s/'\''/'\''\\\\'\'''\''/g; - s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" - ;; #( - *) - sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" - ;; - esac | - sort -) - echo - - $as_echo "## ----------------- ## -## Output variables. ## -## ----------------- ##" - echo - for ac_var in $ac_subst_vars - do - eval ac_val=\$$ac_var - case $ac_val in - *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; - esac - $as_echo "$ac_var='\''$ac_val'\''" - done | sort - echo - - if test -n "$ac_subst_files"; then - $as_echo "## ------------------- ## -## File substitutions. ## -## ------------------- ##" - echo - for ac_var in $ac_subst_files - do - eval ac_val=\$$ac_var - case $ac_val in - *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; - esac - $as_echo "$ac_var='\''$ac_val'\''" - done | sort - echo - fi - - if test -s confdefs.h; then - $as_echo "## ----------- ## -## confdefs.h. ## -## ----------- ##" - echo - cat confdefs.h - echo - fi - test "$ac_signal" != 0 && - $as_echo "$as_me: caught signal $ac_signal" - $as_echo "$as_me: exit $exit_status" - } >&5 - rm -f core *.core core.conftest.* && - rm -f -r conftest* confdefs* conf$$* $ac_clean_files && - exit $exit_status -' 0 -for ac_signal in 1 2 13 15; do - trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal -done -ac_signal=0 - -# confdefs.h avoids OS command line length limits that DEFS can exceed. -rm -f -r conftest* confdefs.h - -$as_echo "/* confdefs.h */" > confdefs.h - -# Predefined preprocessor variables. - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_NAME "$PACKAGE_NAME" -_ACEOF - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_TARNAME "$PACKAGE_TARNAME" -_ACEOF - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_VERSION "$PACKAGE_VERSION" -_ACEOF - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_STRING "$PACKAGE_STRING" -_ACEOF - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" -_ACEOF - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_URL "$PACKAGE_URL" -_ACEOF - - -# Let the site file select an alternate cache file if it wants to. -# Prefer an explicitly selected file to automatically selected ones. -ac_site_file1=NONE -ac_site_file2=NONE -if test -n "$CONFIG_SITE"; then - # We do not want a PATH search for config.site. - case $CONFIG_SITE in #(( - -*) ac_site_file1=./$CONFIG_SITE;; - */*) ac_site_file1=$CONFIG_SITE;; - *) ac_site_file1=./$CONFIG_SITE;; - esac -elif test "x$prefix" != xNONE; then - ac_site_file1=$prefix/share/config.site - ac_site_file2=$prefix/etc/config.site -else - ac_site_file1=$ac_default_prefix/share/config.site - ac_site_file2=$ac_default_prefix/etc/config.site -fi -for ac_site_file in "$ac_site_file1" "$ac_site_file2" -do - test "x$ac_site_file" = xNONE && continue - if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 -$as_echo "$as_me: loading site script $ac_site_file" >&6;} - sed 's/^/| /' "$ac_site_file" >&5 - . "$ac_site_file" \ - || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "failed to load site script $ac_site_file -See \`config.log' for more details" "$LINENO" 5; } - fi -done - -if test -r "$cache_file"; then - # Some versions of bash will fail to source /dev/null (special files - # actually), so we avoid doing that. DJGPP emulates it as a regular file. - if test /dev/null != "$cache_file" && test -f "$cache_file"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 -$as_echo "$as_me: loading cache $cache_file" >&6;} - case $cache_file in - [\\/]* | ?:[\\/]* ) . "$cache_file";; - *) . "./$cache_file";; - esac - fi -else - { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 -$as_echo "$as_me: creating cache $cache_file" >&6;} - >$cache_file -fi - -# Check that the precious variables saved in the cache have kept the same -# value. -ac_cache_corrupted=false -for ac_var in $ac_precious_vars; do - eval ac_old_set=\$ac_cv_env_${ac_var}_set - eval ac_new_set=\$ac_env_${ac_var}_set - eval ac_old_val=\$ac_cv_env_${ac_var}_value - eval ac_new_val=\$ac_env_${ac_var}_value - case $ac_old_set,$ac_new_set in - set,) - { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 -$as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} - ac_cache_corrupted=: ;; - ,set) - { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 -$as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} - ac_cache_corrupted=: ;; - ,);; - *) - if test "x$ac_old_val" != "x$ac_new_val"; then - # differences in whitespace do not lead to failure. - ac_old_val_w=`echo x $ac_old_val` - ac_new_val_w=`echo x $ac_new_val` - if test "$ac_old_val_w" != "$ac_new_val_w"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 -$as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} - ac_cache_corrupted=: - else - { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 -$as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} - eval $ac_var=\$ac_old_val - fi - { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 -$as_echo "$as_me: former value: \`$ac_old_val'" >&2;} - { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 -$as_echo "$as_me: current value: \`$ac_new_val'" >&2;} - fi;; - esac - # Pass precious variables to config.status. - if test "$ac_new_set" = set; then - case $ac_new_val in - *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; - *) ac_arg=$ac_var=$ac_new_val ;; - esac - case " $ac_configure_args " in - *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. - *) as_fn_append ac_configure_args " '$ac_arg'" ;; - esac - fi -done -if $ac_cache_corrupted; then - { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} - { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 -$as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} - as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 -fi -## -------------------- ## -## Main body of script. ## -## -------------------- ## - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - - -ac_config_files="$ac_config_files accelerate-cuda.buildinfo" - - - -# Check whether --with-compiler was given. -if test "${with_compiler+set}" = set; then : - withval=$with_compiler; GHC=$withval -else - # Extract the first word of "ghc", so it can be a program name with args. -set dummy ghc; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_path_GHC+:} false; then : - $as_echo_n "(cached) " >&6 -else - case $GHC in - [\\/]* | ?:[\\/]*) - ac_cv_path_GHC="$GHC" # Let the user override the test with a path. - ;; - *) - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_path_GHC="$as_dir/$ac_word$ac_exec_ext" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - - ;; -esac -fi -GHC=$ac_cv_path_GHC -if test -n "$GHC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $GHC" >&5 -$as_echo "$GHC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - -fi - - -# Check whether --with-nvcc was given. -if test "${with_nvcc+set}" = set; then : - withval=$with_nvcc; NVCC=$withval -else - ac_ext=cpp -ac_cpp='$CXXCPP $CPPFLAGS' -ac_compile='$CXX -c $CXXFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CXX -o conftest$ac_exeext $CXXFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_cxx_compiler_gnu -if test -z "$CXX"; then - if test -n "$CCC"; then - CXX=$CCC - else - if test -n "$ac_tool_prefix"; then - for ac_prog in nvcc - do - # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. -set dummy $ac_tool_prefix$ac_prog; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_CXX+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$CXX"; then - ac_cv_prog_CXX="$CXX" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_CXX="$ac_tool_prefix$ac_prog" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -CXX=$ac_cv_prog_CXX -if test -n "$CXX"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CXX" >&5 -$as_echo "$CXX" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - - test -n "$CXX" && break - done -fi -if test -z "$CXX"; then - ac_ct_CXX=$CXX - for ac_prog in nvcc -do - # Extract the first word of "$ac_prog", so it can be a program name with args. -set dummy $ac_prog; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_ac_ct_CXX+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$ac_ct_CXX"; then - ac_cv_prog_ac_ct_CXX="$ac_ct_CXX" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_ac_ct_CXX="$ac_prog" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -ac_ct_CXX=$ac_cv_prog_ac_ct_CXX -if test -n "$ac_ct_CXX"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CXX" >&5 -$as_echo "$ac_ct_CXX" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - - test -n "$ac_ct_CXX" && break -done - - if test "x$ac_ct_CXX" = x; then - CXX="g++" - else - case $cross_compiling:$ac_tool_warned in -yes:) -{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 -$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} -ac_tool_warned=yes ;; -esac - CXX=$ac_ct_CXX - fi -fi - - fi -fi -# Provide some information about the compiler. -$as_echo "$as_me:${as_lineno-$LINENO}: checking for C++ compiler version" >&5 -set X $ac_compile -ac_compiler=$2 -for ac_option in --version -v -V -qversion; do - { { ac_try="$ac_compiler $ac_option >&5" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_compiler $ac_option >&5") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - sed '10a\ -... rest of stderr output deleted ... - 10q' conftest.err >conftest.er1 - cat conftest.er1 >&5 - fi - rm -f conftest.er1 conftest.err - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } -done - -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -ac_clean_files_save=$ac_clean_files -ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" -# Try to create an executable without -o first, disregard a.out. -# It will help us diagnose broken compilers, and finding out an intuition -# of exeext. -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the C++ compiler works" >&5 -$as_echo_n "checking whether the C++ compiler works... " >&6; } -ac_link_default=`$as_echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` - -# The possible output files: -ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" - -ac_rmfiles= -for ac_file in $ac_files -do - case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; - * ) ac_rmfiles="$ac_rmfiles $ac_file";; - esac -done -rm -f $ac_rmfiles - -if { { ac_try="$ac_link_default" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_link_default") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; then : - # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. -# So ignore a value of `no', otherwise this would lead to `EXEEXT = no' -# in a Makefile. We should not override ac_cv_exeext if it was cached, -# so that the user can short-circuit this test for compilers unknown to -# Autoconf. -for ac_file in $ac_files '' -do - test -f "$ac_file" || continue - case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) - ;; - [ab].out ) - # We found the default executable, but exeext='' is most - # certainly right. - break;; - *.* ) - if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no; - then :; else - ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` - fi - # We set ac_cv_exeext here because the later test for it is not - # safe: cross compilers may not add the suffix if given an `-o' - # argument, so we may need to know it at that point already. - # Even if this section looks crufty: it has the advantage of - # actually working. - break;; - * ) - break;; - esac -done -test "$ac_cv_exeext" = no && ac_cv_exeext= - -else - ac_file='' -fi -if test -z "$ac_file"; then : - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -$as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error 77 "C++ compiler cannot create executables -See \`config.log' for more details" "$LINENO" 5; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for C++ compiler default output file name" >&5 -$as_echo_n "checking for C++ compiler default output file name... " >&6; } -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 -$as_echo "$ac_file" >&6; } -ac_exeext=$ac_cv_exeext - -rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out -ac_clean_files=$ac_clean_files_save -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 -$as_echo_n "checking for suffix of executables... " >&6; } -if { { ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_link") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; then : - # If both `conftest.exe' and `conftest' are `present' (well, observable) -# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will -# work properly (i.e., refer to `conftest.exe'), while it won't with -# `rm'. -for ac_file in conftest.exe conftest conftest.*; do - test -f "$ac_file" || continue - case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; - *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` - break;; - * ) break;; - esac -done -else - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "cannot compute suffix of executables: cannot compile and link -See \`config.log' for more details" "$LINENO" 5; } -fi -rm -f conftest conftest$ac_cv_exeext -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 -$as_echo "$ac_cv_exeext" >&6; } - -rm -f conftest.$ac_ext -EXEEXT=$ac_cv_exeext -ac_exeext=$EXEEXT -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include -int -main () -{ -FILE *f = fopen ("conftest.out", "w"); - return ferror (f) || fclose (f) != 0; - - ; - return 0; -} -_ACEOF -ac_clean_files="$ac_clean_files conftest.out" -# Check that the compiler produces executables we can run. If not, either -# the compiler is broken, or we cross compile. -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 -$as_echo_n "checking whether we are cross compiling... " >&6; } -if test "$cross_compiling" != yes; then - { { ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_link") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } - if { ac_try='./conftest$ac_cv_exeext' - { { case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_try") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; }; then - cross_compiling=no - else - if test "$cross_compiling" = maybe; then - cross_compiling=yes - else - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "cannot run C++ compiled programs. -If you meant to cross compile, use \`--host'. -See \`config.log' for more details" "$LINENO" 5; } - fi - fi -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 -$as_echo "$cross_compiling" >&6; } - -rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out -ac_clean_files=$ac_clean_files_save -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 -$as_echo_n "checking for suffix of object files... " >&6; } -if ${ac_cv_objext+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -rm -f conftest.o conftest.obj -if { { ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_compile") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; then : - for ac_file in conftest.o conftest.obj conftest.*; do - test -f "$ac_file" || continue; - case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; - *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` - break;; - esac -done -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "cannot compute suffix of object files: cannot compile -See \`config.log' for more details" "$LINENO" 5; } -fi -rm -f conftest.$ac_cv_objext conftest.$ac_ext -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 -$as_echo "$ac_cv_objext" >&6; } -OBJEXT=$ac_cv_objext -ac_objext=$OBJEXT -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C++ compiler" >&5 -$as_echo_n "checking whether we are using the GNU C++ compiler... " >&6; } -if ${ac_cv_cxx_compiler_gnu+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ -#ifndef __GNUC__ - choke me -#endif - - ; - return 0; -} -_ACEOF -if ac_fn_cxx_try_compile "$LINENO"; then : - ac_compiler_gnu=yes -else - ac_compiler_gnu=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -ac_cv_cxx_compiler_gnu=$ac_compiler_gnu - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_cxx_compiler_gnu" >&5 -$as_echo "$ac_cv_cxx_compiler_gnu" >&6; } -if test $ac_compiler_gnu = yes; then - GXX=yes -else - GXX= -fi -ac_test_CXXFLAGS=${CXXFLAGS+set} -ac_save_CXXFLAGS=$CXXFLAGS -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CXX accepts -g" >&5 -$as_echo_n "checking whether $CXX accepts -g... " >&6; } -if ${ac_cv_prog_cxx_g+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_save_cxx_werror_flag=$ac_cxx_werror_flag - ac_cxx_werror_flag=yes - ac_cv_prog_cxx_g=no - CXXFLAGS="-g" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_cxx_try_compile "$LINENO"; then : - ac_cv_prog_cxx_g=yes -else - CXXFLAGS="" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_cxx_try_compile "$LINENO"; then : - -else - ac_cxx_werror_flag=$ac_save_cxx_werror_flag - CXXFLAGS="-g" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_cxx_try_compile "$LINENO"; then : - ac_cv_prog_cxx_g=yes -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - ac_cxx_werror_flag=$ac_save_cxx_werror_flag -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cxx_g" >&5 -$as_echo "$ac_cv_prog_cxx_g" >&6; } -if test "$ac_test_CXXFLAGS" = set; then - CXXFLAGS=$ac_save_CXXFLAGS -elif test $ac_cv_prog_cxx_g = yes; then - if test "$GXX" = yes; then - CXXFLAGS="-g -O2" - else - CXXFLAGS="-g" - fi -else - if test "$GXX" = yes; then - CXXFLAGS="-O2" - else - CXXFLAGS= - fi -fi -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - -fi - - -# Check whether --with-gcc was given. -if test "${with_gcc+set}" = set; then : - withval=$with_gcc; CC=$withval -fi - - - - - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of Int" >&5 -$as_echo_n "checking size of Int... " >&6; } - - sizeof_hs_Int=`$GHC -w -ignore-dot-ghci -e "import Foreign" -e "import Foreign.C" -e "putStr . show $ sizeOf (undefined::Int)"` - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $sizeof_hs_Int" >&5 -$as_echo "$sizeof_hs_Int" >&6; } - - case $sizeof_hs_Int in - 4) type_hs_int=Int32 ;; - 8) type_hs_int=Int64 ;; - esac - - # The type name - def="-DHTYPE_INT=$type_hs_int" - cpp_flags="$cpp_flags $def" - ghc_flags="$ghc_flags -optP$def" - - # And size - def="-DSIZEOF_HTYPE_INT=$sizeof_hs_Int" - cpp_flags="$cpp_flags $def" - ghc_flags="$ghc_flags -optP$def" - - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of Word" >&5 -$as_echo_n "checking size of Word... " >&6; } - - sizeof_hs_Word=`$GHC -w -ignore-dot-ghci -e "import Foreign" -e "import Foreign.C" -e "putStr . show $ sizeOf (undefined::Word)"` - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $sizeof_hs_Word" >&5 -$as_echo "$sizeof_hs_Word" >&6; } - - case $sizeof_hs_Word in - 4) type_hs_word=Word32 ;; - 8) type_hs_word=Word64 ;; - esac - - # The type name - def="-DHTYPE_WORD=$type_hs_word" - cpp_flags="$cpp_flags $def" - ghc_flags="$ghc_flags -optP$def" - - # And size - def="-DSIZEOF_HTYPE_WORD=$sizeof_hs_Word" - cpp_flags="$cpp_flags $def" - ghc_flags="$ghc_flags -optP$def" - - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of CLong" >&5 -$as_echo_n "checking size of CLong... " >&6; } - - sizeof_hs_CLong=`$GHC -w -ignore-dot-ghci -e "import Foreign" -e "import Foreign.C" -e "putStr . show $ sizeOf (undefined::CLong)"` - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $sizeof_hs_CLong" >&5 -$as_echo "$sizeof_hs_CLong" >&6; } - - case $sizeof_hs_CLong in - 4) type_hs_long=Int32 ;; - 8) type_hs_long=Int64 ;; - esac - - # The type name - def="-DHTYPE_LONG=$type_hs_long" - cpp_flags="$cpp_flags $def" - ghc_flags="$ghc_flags -optP$def" - - # And size - def="-DSIZEOF_HTYPE_LONG=$sizeof_hs_CLong" - cpp_flags="$cpp_flags $def" - ghc_flags="$ghc_flags -optP$def" - - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of CULong" >&5 -$as_echo_n "checking size of CULong... " >&6; } - - sizeof_hs_CULong=`$GHC -w -ignore-dot-ghci -e "import Foreign" -e "import Foreign.C" -e "putStr . show $ sizeOf (undefined::CULong)"` - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $sizeof_hs_CULong" >&5 -$as_echo "$sizeof_hs_CULong" >&6; } - - case $sizeof_hs_CULong in - 4) type_hs_unsigned_long=Word32 ;; - 8) type_hs_unsigned_long=Word64 ;; - esac - - # The type name - def="-DHTYPE_UNSIGNED_LONG=$type_hs_unsigned_long" - cpp_flags="$cpp_flags $def" - ghc_flags="$ghc_flags -optP$def" - - # And size - def="-DSIZEOF_HTYPE_UNSIGNED_LONG=$sizeof_hs_CULong" - cpp_flags="$cpp_flags $def" - ghc_flags="$ghc_flags -optP$def" - - - - -cat >confcache <<\_ACEOF -# This file is a shell script that caches the results of configure -# tests run on this system so they can be shared between configure -# scripts and configure runs, see configure's option --config-cache. -# It is not useful on other systems. If it contains results you don't -# want to keep, you may remove or edit it. -# -# config.status only pays attention to the cache file if you give it -# the --recheck option to rerun configure. -# -# `ac_cv_env_foo' variables (set or unset) will be overridden when -# loading this file, other *unset* `ac_cv_foo' will be assigned the -# following values. - -_ACEOF - -# The following way of writing the cache mishandles newlines in values, -# but we know of no workaround that is simple, portable, and efficient. -# So, we kill variables containing newlines. -# Ultrix sh set writes to stderr and can't be redirected directly, -# and sets the high bit in the cache file unless we assign to the vars. -( - for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do - eval ac_val=\$$ac_var - case $ac_val in #( - *${as_nl}*) - case $ac_var in #( - *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 -$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; - esac - case $ac_var in #( - _ | IFS | as_nl) ;; #( - BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( - *) { eval $ac_var=; unset $ac_var;} ;; - esac ;; - esac - done - - (set) 2>&1 | - case $as_nl`(ac_space=' '; set) 2>&1` in #( - *${as_nl}ac_space=\ *) - # `set' does not quote correctly, so add quotes: double-quote - # substitution turns \\\\ into \\, and sed turns \\ into \. - sed -n \ - "s/'/'\\\\''/g; - s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" - ;; #( - *) - # `set' quotes correctly as required by POSIX, so do not add quotes. - sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" - ;; - esac | - sort -) | - sed ' - /^ac_cv_env_/b end - t clear - :clear - s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ - t end - s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ - :end' >>confcache -if diff "$cache_file" confcache >/dev/null 2>&1; then :; else - if test -w "$cache_file"; then - if test "x$cache_file" != "x/dev/null"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 -$as_echo "$as_me: updating cache $cache_file" >&6;} - if test ! -f "$cache_file" || test -h "$cache_file"; then - cat confcache >"$cache_file" - else - case $cache_file in #( - */* | ?:*) - mv -f confcache "$cache_file"$$ && - mv -f "$cache_file"$$ "$cache_file" ;; #( - *) - mv -f confcache "$cache_file" ;; - esac - fi - fi - else - { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 -$as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} - fi -fi -rm -f confcache - -test "x$prefix" = xNONE && prefix=$ac_default_prefix -# Let make expand exec_prefix. -test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' - -# Transform confdefs.h into DEFS. -# Protect against shell expansion while executing Makefile rules. -# Protect against Makefile macro expansion. -# -# If the first sed substitution is executed (which looks for macros that -# take arguments), then branch to the quote section. Otherwise, -# look for a macro that doesn't take arguments. -ac_script=' -:mline -/\\$/{ - N - s,\\\n,, - b mline -} -t clear -:clear -s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g -t quote -s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g -t quote -b any -:quote -s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g -s/\[/\\&/g -s/\]/\\&/g -s/\$/$$/g -H -:any -${ - g - s/^\n// - s/\n/ /g - p -} -' -DEFS=`sed -n "$ac_script" confdefs.h` - - -ac_libobjs= -ac_ltlibobjs= -U= -for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue - # 1. Remove the extension, and $U if already installed. - ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' - ac_i=`$as_echo "$ac_i" | sed "$ac_script"` - # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR - # will be set to the directory where LIBOBJS objects are built. - as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" - as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' -done -LIBOBJS=$ac_libobjs - -LTLIBOBJS=$ac_ltlibobjs - - - -: "${CONFIG_STATUS=./config.status}" -ac_write_fail=0 -ac_clean_files_save=$ac_clean_files -ac_clean_files="$ac_clean_files $CONFIG_STATUS" -{ $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 -$as_echo "$as_me: creating $CONFIG_STATUS" >&6;} -as_write_fail=0 -cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 -#! $SHELL -# Generated by $as_me. -# Run this file to recreate the current configuration. -# Compiler output produced by configure, useful for debugging -# configure, is in config.log if it exists. - -debug=false -ac_cs_recheck=false -ac_cs_silent=false - -SHELL=\${CONFIG_SHELL-$SHELL} -export SHELL -_ASEOF -cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 -## -------------------- ## -## M4sh Initialization. ## -## -------------------- ## - -# Be more Bourne compatible -DUALCASE=1; export DUALCASE # for MKS sh -if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : - emulate sh - NULLCMD=: - # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which - # is contrary to our usage. Disable this feature. - alias -g '${1+"$@"}'='"$@"' - setopt NO_GLOB_SUBST -else - case `(set -o) 2>/dev/null` in #( - *posix*) : - set -o posix ;; #( - *) : - ;; -esac -fi - - -as_nl=' -' -export as_nl -# Printing a long string crashes Solaris 7 /usr/bin/printf. -as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' -as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo -as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo -# Prefer a ksh shell builtin over an external printf program on Solaris, -# but without wasting forks for bash or zsh. -if test -z "$BASH_VERSION$ZSH_VERSION" \ - && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then - as_echo='print -r --' - as_echo_n='print -rn --' -elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then - as_echo='printf %s\n' - as_echo_n='printf %s' -else - if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then - as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' - as_echo_n='/usr/ucb/echo -n' - else - as_echo_body='eval expr "X$1" : "X\\(.*\\)"' - as_echo_n_body='eval - arg=$1; - case $arg in #( - *"$as_nl"*) - expr "X$arg" : "X\\(.*\\)$as_nl"; - arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; - esac; - expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" - ' - export as_echo_n_body - as_echo_n='sh -c $as_echo_n_body as_echo' - fi - export as_echo_body - as_echo='sh -c $as_echo_body as_echo' -fi - -# The user is always right. -if test "${PATH_SEPARATOR+set}" != set; then - PATH_SEPARATOR=: - (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { - (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || - PATH_SEPARATOR=';' - } -fi - - -# IFS -# We need space, tab and new line, in precisely that order. Quoting is -# there to prevent editors from complaining about space-tab. -# (If _AS_PATH_WALK were called with IFS unset, it would disable word -# splitting by setting IFS to empty value.) -IFS=" "" $as_nl" - -# Find who we are. Look in the path if we contain no directory separator. -as_myself= -case $0 in #(( - *[\\/]* ) as_myself=$0 ;; - *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break - done -IFS=$as_save_IFS - - ;; -esac -# We did not find ourselves, most probably we were run as `sh COMMAND' -# in which case we are not to be found in the path. -if test "x$as_myself" = x; then - as_myself=$0 -fi -if test ! -f "$as_myself"; then - $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 - exit 1 -fi - -# Unset variables that we do not need and which cause bugs (e.g. in -# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" -# suppresses any "Segmentation fault" message there. '((' could -# trigger a bug in pdksh 5.2.14. -for as_var in BASH_ENV ENV MAIL MAILPATH -do eval test x\${$as_var+set} = xset \ - && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : -done -PS1='$ ' -PS2='> ' -PS4='+ ' - -# NLS nuisances. -LC_ALL=C -export LC_ALL -LANGUAGE=C -export LANGUAGE - -# CDPATH. -(unset CDPATH) >/dev/null 2>&1 && unset CDPATH - - -# as_fn_error STATUS ERROR [LINENO LOG_FD] -# ---------------------------------------- -# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are -# provided, also output the error to LOG_FD, referencing LINENO. Then exit the -# script with STATUS, using 1 if that was 0. -as_fn_error () -{ - as_status=$1; test $as_status -eq 0 && as_status=1 - if test "$4"; then - as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 - fi - $as_echo "$as_me: error: $2" >&2 - as_fn_exit $as_status -} # as_fn_error - - -# as_fn_set_status STATUS -# ----------------------- -# Set $? to STATUS, without forking. -as_fn_set_status () -{ - return $1 -} # as_fn_set_status - -# as_fn_exit STATUS -# ----------------- -# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. -as_fn_exit () -{ - set +e - as_fn_set_status $1 - exit $1 -} # as_fn_exit - -# as_fn_unset VAR -# --------------- -# Portably unset VAR. -as_fn_unset () -{ - { eval $1=; unset $1;} -} -as_unset=as_fn_unset -# as_fn_append VAR VALUE -# ---------------------- -# Append the text in VALUE to the end of the definition contained in VAR. Take -# advantage of any shell optimizations that allow amortized linear growth over -# repeated appends, instead of the typical quadratic growth present in naive -# implementations. -if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : - eval 'as_fn_append () - { - eval $1+=\$2 - }' -else - as_fn_append () - { - eval $1=\$$1\$2 - } -fi # as_fn_append - -# as_fn_arith ARG... -# ------------------ -# Perform arithmetic evaluation on the ARGs, and store the result in the -# global $as_val. Take advantage of shells that can avoid forks. The arguments -# must be portable across $(()) and expr. -if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : - eval 'as_fn_arith () - { - as_val=$(( $* )) - }' -else - as_fn_arith () - { - as_val=`expr "$@" || test $? -eq 1` - } -fi # as_fn_arith - - -if expr a : '\(a\)' >/dev/null 2>&1 && - test "X`expr 00001 : '.*\(...\)'`" = X001; then - as_expr=expr -else - as_expr=false -fi - -if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then - as_basename=basename -else - as_basename=false -fi - -if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then - as_dirname=dirname -else - as_dirname=false -fi - -as_me=`$as_basename -- "$0" || -$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ - X"$0" : 'X\(//\)$' \| \ - X"$0" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X/"$0" | - sed '/^.*\/\([^/][^/]*\)\/*$/{ - s//\1/ - q - } - /^X\/\(\/\/\)$/{ - s//\1/ - q - } - /^X\/\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - -# Avoid depending upon Character Ranges. -as_cr_letters='abcdefghijklmnopqrstuvwxyz' -as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' -as_cr_Letters=$as_cr_letters$as_cr_LETTERS -as_cr_digits='0123456789' -as_cr_alnum=$as_cr_Letters$as_cr_digits - -ECHO_C= ECHO_N= ECHO_T= -case `echo -n x` in #((((( --n*) - case `echo 'xy\c'` in - *c*) ECHO_T=' ';; # ECHO_T is single tab character. - xy) ECHO_C='\c';; - *) echo `echo ksh88 bug on AIX 6.1` > /dev/null - ECHO_T=' ';; - esac;; -*) - ECHO_N='-n';; -esac - -rm -f conf$$ conf$$.exe conf$$.file -if test -d conf$$.dir; then - rm -f conf$$.dir/conf$$.file -else - rm -f conf$$.dir - mkdir conf$$.dir 2>/dev/null -fi -if (echo >conf$$.file) 2>/dev/null; then - if ln -s conf$$.file conf$$ 2>/dev/null; then - as_ln_s='ln -s' - # ... but there are two gotchas: - # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. - # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. - # In both cases, we have to default to `cp -pR'. - ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || - as_ln_s='cp -pR' - elif ln conf$$.file conf$$ 2>/dev/null; then - as_ln_s=ln - else - as_ln_s='cp -pR' - fi -else - as_ln_s='cp -pR' -fi -rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file -rmdir conf$$.dir 2>/dev/null - - -# as_fn_mkdir_p -# ------------- -# Create "$as_dir" as a directory, including parents if necessary. -as_fn_mkdir_p () -{ - - case $as_dir in #( - -*) as_dir=./$as_dir;; - esac - test -d "$as_dir" || eval $as_mkdir_p || { - as_dirs= - while :; do - case $as_dir in #( - *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( - *) as_qdir=$as_dir;; - esac - as_dirs="'$as_qdir' $as_dirs" - as_dir=`$as_dirname -- "$as_dir" || -$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_dir" : 'X\(//\)[^/]' \| \ - X"$as_dir" : 'X\(//\)$' \| \ - X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$as_dir" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - test -d "$as_dir" && break - done - test -z "$as_dirs" || eval "mkdir $as_dirs" - } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" - - -} # as_fn_mkdir_p -if mkdir -p . 2>/dev/null; then - as_mkdir_p='mkdir -p "$as_dir"' -else - test -d ./-p && rmdir ./-p - as_mkdir_p=false -fi - - -# as_fn_executable_p FILE -# ----------------------- -# Test if FILE is an executable regular file. -as_fn_executable_p () -{ - test -f "$1" && test -x "$1" -} # as_fn_executable_p -as_test_x='test -x' -as_executable_p=as_fn_executable_p - -# Sed expression to map a string onto a valid CPP name. -as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" - -# Sed expression to map a string onto a valid variable name. -as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" - - -exec 6>&1 -## ----------------------------------- ## -## Main body of $CONFIG_STATUS script. ## -## ----------------------------------- ## -_ASEOF -test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -# Save the log message, to keep $0 and so on meaningful, and to -# report actual input values of CONFIG_FILES etc. instead of their -# values after options handling. -ac_log=" -This file was extended by accelerate-cuda $as_me 0.14.0.0, which was -generated by GNU Autoconf 2.69. Invocation command line was - - CONFIG_FILES = $CONFIG_FILES - CONFIG_HEADERS = $CONFIG_HEADERS - CONFIG_LINKS = $CONFIG_LINKS - CONFIG_COMMANDS = $CONFIG_COMMANDS - $ $0 $@ - -on `(hostname || uname -n) 2>/dev/null | sed 1q` -" - -_ACEOF - -case $ac_config_files in *" -"*) set x $ac_config_files; shift; ac_config_files=$*;; -esac - - - -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -# Files that config.status was made for. -config_files="$ac_config_files" - -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -ac_cs_usage="\ -\`$as_me' instantiates files and other configuration actions -from templates according to the current configuration. Unless the files -and actions are specified as TAGs, all are instantiated by default. - -Usage: $0 [OPTION]... [TAG]... - - -h, --help print this help, then exit - -V, --version print version number and configuration settings, then exit - --config print configuration, then exit - -q, --quiet, --silent - do not print progress messages - -d, --debug don't remove temporary files - --recheck update $as_me by reconfiguring in the same conditions - --file=FILE[:TEMPLATE] - instantiate the configuration file FILE - -Configuration files: -$config_files - -Report bugs to ." - -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" -ac_cs_version="\\ -accelerate-cuda config.status 0.14.0.0 -configured by $0, generated by GNU Autoconf 2.69, - with options \\"\$ac_cs_config\\" - -Copyright (C) 2012 Free Software Foundation, Inc. -This config.status script is free software; the Free Software Foundation -gives unlimited permission to copy, distribute and modify it." - -ac_pwd='$ac_pwd' -srcdir='$srcdir' -test -n "\$AWK" || AWK=awk -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -# The default lists apply if the user does not specify any file. -ac_need_defaults=: -while test $# != 0 -do - case $1 in - --*=?*) - ac_option=`expr "X$1" : 'X\([^=]*\)='` - ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` - ac_shift=: - ;; - --*=) - ac_option=`expr "X$1" : 'X\([^=]*\)='` - ac_optarg= - ac_shift=: - ;; - *) - ac_option=$1 - ac_optarg=$2 - ac_shift=shift - ;; - esac - - case $ac_option in - # Handling of the options. - -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) - ac_cs_recheck=: ;; - --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) - $as_echo "$ac_cs_version"; exit ;; - --config | --confi | --conf | --con | --co | --c ) - $as_echo "$ac_cs_config"; exit ;; - --debug | --debu | --deb | --de | --d | -d ) - debug=: ;; - --file | --fil | --fi | --f ) - $ac_shift - case $ac_optarg in - *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; - '') as_fn_error $? "missing file argument" ;; - esac - as_fn_append CONFIG_FILES " '$ac_optarg'" - ac_need_defaults=false;; - --he | --h | --help | --hel | -h ) - $as_echo "$ac_cs_usage"; exit ;; - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ - | -silent | --silent | --silen | --sile | --sil | --si | --s) - ac_cs_silent=: ;; - - # This is an error. - -*) as_fn_error $? "unrecognized option: \`$1' -Try \`$0 --help' for more information." ;; - - *) as_fn_append ac_config_targets " $1" - ac_need_defaults=false ;; - - esac - shift -done - -ac_configure_extra_args= - -if $ac_cs_silent; then - exec 6>/dev/null - ac_configure_extra_args="$ac_configure_extra_args --silent" -fi - -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -if \$ac_cs_recheck; then - set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion - shift - \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 - CONFIG_SHELL='$SHELL' - export CONFIG_SHELL - exec "\$@" -fi - -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -exec 5>>config.log -{ - echo - sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX -## Running $as_me. ## -_ASBOX - $as_echo "$ac_log" -} >&5 - -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 - -# Handling of arguments. -for ac_config_target in $ac_config_targets -do - case $ac_config_target in - "accelerate-cuda.buildinfo") CONFIG_FILES="$CONFIG_FILES accelerate-cuda.buildinfo" ;; - - *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; - esac -done - - -# If the user did not use the arguments to specify the items to instantiate, -# then the envvar interface is used. Set only those that are not. -# We use the long form for the default assignment because of an extremely -# bizarre bug on SunOS 4.1.3. -if $ac_need_defaults; then - test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files -fi - -# Have a temporary directory for convenience. Make it in the build tree -# simply because there is no reason against having it here, and in addition, -# creating and moving files from /tmp can sometimes cause problems. -# Hook for its removal unless debugging. -# Note that there is a small window in which the directory will not be cleaned: -# after its creation but before its name has been assigned to `$tmp'. -$debug || -{ - tmp= ac_tmp= - trap 'exit_status=$? - : "${ac_tmp:=$tmp}" - { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status -' 0 - trap 'as_fn_exit 1' 1 2 13 15 -} -# Create a (secure) tmp directory for tmp files. - -{ - tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && - test -d "$tmp" -} || -{ - tmp=./conf$$-$RANDOM - (umask 077 && mkdir "$tmp") -} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 -ac_tmp=$tmp - -# Set up the scripts for CONFIG_FILES section. -# No need to generate them if there are no CONFIG_FILES. -# This happens for instance with `./config.status config.h'. -if test -n "$CONFIG_FILES"; then - - -ac_cr=`echo X | tr X '\015'` -# On cygwin, bash can eat \r inside `` if the user requested igncr. -# But we know of no other shell where ac_cr would be empty at this -# point, so we can use a bashism as a fallback. -if test "x$ac_cr" = x; then - eval ac_cr=\$\'\\r\' -fi -ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` -if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then - ac_cs_awk_cr='\\r' -else - ac_cs_awk_cr=$ac_cr -fi - -echo 'BEGIN {' >"$ac_tmp/subs1.awk" && -_ACEOF - - -{ - echo "cat >conf$$subs.awk <<_ACEOF" && - echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && - echo "_ACEOF" -} >conf$$subs.sh || - as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 -ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` -ac_delim='%!_!# ' -for ac_last_try in false false false false false :; do - . ./conf$$subs.sh || - as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 - - ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` - if test $ac_delim_n = $ac_delim_num; then - break - elif $ac_last_try; then - as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 - else - ac_delim="$ac_delim!$ac_delim _$ac_delim!! " - fi -done -rm -f conf$$subs.sh - -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && -_ACEOF -sed -n ' -h -s/^/S["/; s/!.*/"]=/ -p -g -s/^[^!]*!// -:repl -t repl -s/'"$ac_delim"'$// -t delim -:nl -h -s/\(.\{148\}\)..*/\1/ -t more1 -s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ -p -n -b repl -:more1 -s/["\\]/\\&/g; s/^/"/; s/$/"\\/ -p -g -s/.\{148\}// -t nl -:delim -h -s/\(.\{148\}\)..*/\1/ -t more2 -s/["\\]/\\&/g; s/^/"/; s/$/"/ -p -b -:more2 -s/["\\]/\\&/g; s/^/"/; s/$/"\\/ -p -g -s/.\{148\}// -t delim -' >$CONFIG_STATUS || ac_write_fail=1 -rm -f conf$$subs.awk -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -_ACAWK -cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && - for (key in S) S_is_set[key] = 1 - FS = "" - -} -{ - line = $ 0 - nfields = split(line, field, "@") - substed = 0 - len = length(field[1]) - for (i = 2; i < nfields; i++) { - key = field[i] - keylen = length(key) - if (S_is_set[key]) { - value = S[key] - line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) - len += length(value) + length(field[++i]) - substed = 1 - } else - len += 1 + keylen - } - - print line -} - -_ACAWK -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then - sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" -else - cat -fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ - || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 -_ACEOF - -# VPATH may cause trouble with some makes, so we remove sole $(srcdir), -# ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and -# trailing colons and then remove the whole line if VPATH becomes empty -# (actually we leave an empty line to preserve line numbers). -if test "x$srcdir" = x.; then - ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ -h -s/// -s/^/:/ -s/[ ]*$/:/ -s/:\$(srcdir):/:/g -s/:\${srcdir}:/:/g -s/:@srcdir@:/:/g -s/^:*// -s/:*$// -x -s/\(=[ ]*\).*/\1/ -G -s/\n// -s/^[^=]*=[ ]*$// -}' -fi - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -fi # test -n "$CONFIG_FILES" - - -eval set X " :F $CONFIG_FILES " -shift -for ac_tag -do - case $ac_tag in - :[FHLC]) ac_mode=$ac_tag; continue;; - esac - case $ac_mode$ac_tag in - :[FHL]*:*);; - :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; - :[FH]-) ac_tag=-:-;; - :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; - esac - ac_save_IFS=$IFS - IFS=: - set x $ac_tag - IFS=$ac_save_IFS - shift - ac_file=$1 - shift - - case $ac_mode in - :L) ac_source=$1;; - :[FH]) - ac_file_inputs= - for ac_f - do - case $ac_f in - -) ac_f="$ac_tmp/stdin";; - *) # Look for the file first in the build tree, then in the source tree - # (if the path is not absolute). The absolute path cannot be DOS-style, - # because $ac_f cannot contain `:'. - test -f "$ac_f" || - case $ac_f in - [\\/$]*) false;; - *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; - esac || - as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; - esac - case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac - as_fn_append ac_file_inputs " '$ac_f'" - done - - # Let's still pretend it is `configure' which instantiates (i.e., don't - # use $as_me), people would be surprised to read: - # /* config.h. Generated by config.status. */ - configure_input='Generated from '` - $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' - `' by configure.' - if test x"$ac_file" != x-; then - configure_input="$ac_file. $configure_input" - { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 -$as_echo "$as_me: creating $ac_file" >&6;} - fi - # Neutralize special characters interpreted by sed in replacement strings. - case $configure_input in #( - *\&* | *\|* | *\\* ) - ac_sed_conf_input=`$as_echo "$configure_input" | - sed 's/[\\\\&|]/\\\\&/g'`;; #( - *) ac_sed_conf_input=$configure_input;; - esac - - case $ac_tag in - *:-:* | *:-) cat >"$ac_tmp/stdin" \ - || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; - esac - ;; - esac - - ac_dir=`$as_dirname -- "$ac_file" || -$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$ac_file" : 'X\(//\)[^/]' \| \ - X"$ac_file" : 'X\(//\)$' \| \ - X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$ac_file" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - as_dir="$ac_dir"; as_fn_mkdir_p - ac_builddir=. - -case "$ac_dir" in -.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; -*) - ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` - # A ".." for each directory in $ac_dir_suffix. - ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` - case $ac_top_builddir_sub in - "") ac_top_builddir_sub=. ac_top_build_prefix= ;; - *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; - esac ;; -esac -ac_abs_top_builddir=$ac_pwd -ac_abs_builddir=$ac_pwd$ac_dir_suffix -# for backward compatibility: -ac_top_builddir=$ac_top_build_prefix - -case $srcdir in - .) # We are building in place. - ac_srcdir=. - ac_top_srcdir=$ac_top_builddir_sub - ac_abs_top_srcdir=$ac_pwd ;; - [\\/]* | ?:[\\/]* ) # Absolute name. - ac_srcdir=$srcdir$ac_dir_suffix; - ac_top_srcdir=$srcdir - ac_abs_top_srcdir=$srcdir ;; - *) # Relative name. - ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix - ac_top_srcdir=$ac_top_build_prefix$srcdir - ac_abs_top_srcdir=$ac_pwd/$srcdir ;; -esac -ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix - - - case $ac_mode in - :F) - # - # CONFIG_FILE - # - -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -# If the template does not know about datarootdir, expand it. -# FIXME: This hack should be removed a few years after 2.60. -ac_datarootdir_hack=; ac_datarootdir_seen= -ac_sed_dataroot=' -/datarootdir/ { - p - q -} -/@datadir@/p -/@docdir@/p -/@infodir@/p -/@localedir@/p -/@mandir@/p' -case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in -*datarootdir*) ac_datarootdir_seen=yes;; -*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 -$as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 - ac_datarootdir_hack=' - s&@datadir@&$datadir&g - s&@docdir@&$docdir&g - s&@infodir@&$infodir&g - s&@localedir@&$localedir&g - s&@mandir@&$mandir&g - s&\\\${datarootdir}&$datarootdir&g' ;; -esac -_ACEOF - -# Neutralize VPATH when `$srcdir' = `.'. -# Shell code in configure.ac might set extrasub. -# FIXME: do we really want to maintain this feature? -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -ac_sed_extra="$ac_vpsub -$extrasub -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -:t -/@[a-zA-Z_][a-zA-Z_0-9]*@/!b -s|@configure_input@|$ac_sed_conf_input|;t t -s&@top_builddir@&$ac_top_builddir_sub&;t t -s&@top_build_prefix@&$ac_top_build_prefix&;t t -s&@srcdir@&$ac_srcdir&;t t -s&@abs_srcdir@&$ac_abs_srcdir&;t t -s&@top_srcdir@&$ac_top_srcdir&;t t -s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t -s&@builddir@&$ac_builddir&;t t -s&@abs_builddir@&$ac_abs_builddir&;t t -s&@abs_top_builddir@&$ac_abs_top_builddir&;t t -$ac_datarootdir_hack -" -eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ - >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - -test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && - { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && - { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ - "$ac_tmp/out"`; test -z "$ac_out"; } && - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' -which seems to be undefined. Please make sure it is defined" >&5 -$as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' -which seems to be undefined. Please make sure it is defined" >&2;} - - rm -f "$ac_tmp/stdin" - case $ac_file in - -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; - *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; - esac \ - || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - ;; - - - - esac - -done # for ac_tag - - -as_fn_exit 0 -_ACEOF -ac_clean_files=$ac_clean_files_save - -test $ac_write_fail = 0 || - as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 - - -# configure is writing to config.log, and then calls config.status. -# config.status does its own redirection, appending to config.log. -# Unfortunately, on DOS this fails, as config.log is still kept open -# by configure, so config.status won't be able to write to it; its -# output is simply discarded. So we exec the FD to /dev/null, -# effectively closing config.log, so it can be properly (re)opened and -# appended to by config.status. When coming back to configure, we -# need to make the FD available again. -if test "$no_create" != yes; then - ac_cs_success=: - ac_config_status_args= - test "$silent" = yes && - ac_config_status_args="$ac_config_status_args --quiet" - exec 5>/dev/null - $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false - exec 5>>config.log - # Use ||, not &&, to avoid exiting from the if with $? = 1, which - # would make configure fail if this is the last instruction. - $ac_cs_success || as_fn_exit 1 -fi -if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 -$as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} -fi - - diff --git a/cubits/accelerate_cuda.h b/cubits/accelerate_cuda.h --- a/cubits/accelerate_cuda.h +++ b/cubits/accelerate_cuda.h @@ -1,8 +1,8 @@ /* ----------------------------------------------------------------------------- * * Module : Accelerate-CUDA - * Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee - * [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell + * Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller + * [2009..2014] Trevor L. McDonell * License : BSD3 * * Maintainer : Trevor L. McDonell @@ -14,6 +14,7 @@ #define __ACCELERATE_CUDA_H__ #include "accelerate_cuda_assert.h" +#include "accelerate_cuda_exceptional.h" #include "accelerate_cuda_function.h" #include "accelerate_cuda_texture.h" #include "accelerate_cuda_type.h" diff --git a/cubits/accelerate_cuda_assert.h b/cubits/accelerate_cuda_assert.h --- a/cubits/accelerate_cuda_assert.h +++ b/cubits/accelerate_cuda_assert.h @@ -1,8 +1,8 @@ /* ----------------------------------------------------------------------------- * * Module : Assert - * Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee - * [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell + * Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller + * [2009..2014] Trevor L. McDonell * License : BSD3 * * Maintainer : Trevor L. McDonell diff --git a/cubits/accelerate_cuda_exceptional.h b/cubits/accelerate_cuda_exceptional.h new file mode 100644 --- /dev/null +++ b/cubits/accelerate_cuda_exceptional.h @@ -0,0 +1,26 @@ +/* ----------------------------------------------------------------------------- + * + * Module : Exceptional + * Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller + * [2009..2014] Trevor L. McDonell + * License : BSD3 + * + * Maintainer : Trevor L. McDonell + * Stability : experimental + * + * ---------------------------------------------------------------------------*/ + +#ifndef __ACCELERATE_CUDA_EXCEPTIONAL_H__ +#define __ACCELERATE_CUDA_EXCEPTIONAL_H__ + +/* + * Exceptional values have slightly different names than what are produced by + * the code generator. + */ +#include + +#define Infinity INFINITY +#define NaN NAN + +#endif + diff --git a/cubits/accelerate_cuda_function.h b/cubits/accelerate_cuda_function.h --- a/cubits/accelerate_cuda_function.h +++ b/cubits/accelerate_cuda_function.h @@ -1,8 +1,8 @@ /* ----------------------------------------------------------------------------- * * Module : Function - * Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee - * [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell + * Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller + * [2009..2014] Trevor L. McDonell * License : BSD3 * * Maintainer : Trevor L. McDonell @@ -23,93 +23,6 @@ * -------------------------------------------------------------------------- */ /* - * Left/Right bitwise rotation - */ -template -static __inline__ __device__ T rotateL(const T x, const Int32 i) -{ - const Int32 i8 = i & 8 * sizeof(x) - 1; - return i8 == 0 ? x : x << i8 | x >> 8 * sizeof(x) - i8; -} - -template -static __inline__ __device__ T rotateR(const T x, const Int32 i) -{ - const Int32 i8 = i & 8 * sizeof(x) - 1; - return i8 == 0 ? x : x >> i8 | x << 8 * sizeof(x) - i8; -} - -/* - * Integer division, truncated towards negative infinity - */ -template -static __inline__ __device__ T idiv(const T x, const T y) -{ - return x > 0 && y < 0 ? (x - y - 1) / y : (x < 0 && y > 0 ? (x - y + 1) / y : x / y); -} - -template <> -static __inline__ __device__ Word8 idiv(const Word8 x, const Word8 y) -{ - return x / y; -} - -template <> -static __inline__ __device__ Word16 idiv(const Word16 x, const Word16 y) -{ - return x / y; -} - -template <> -static __inline__ __device__ Word32 idiv(const Word32 x, const Word32 y) -{ - return x / y; -} - -template <> -static __inline__ __device__ Word64 idiv(const Word64 x, const Word64 y) -{ - return x / y; -} - - -/* - * Integer modulus, Haskell style - */ -template -static __inline__ __device__ T mod(const T x, const T y) -{ - const T r = x % y; - return x > 0 && y < 0 || x < 0 && y > 0 ? (r != 0 ? r + y : 0) : r; -} - -template <> -static __inline__ __device__ Word8 mod(const Word8 x, const Word8 y) -{ - return x % y; -} - -template <> -static __inline__ __device__ Word16 mod(const Word16 x, const Word16 y) -{ - return x % y; -} - -template <> -static __inline__ __device__ Word32 mod(const Word32 x, const Word32 y) -{ - return x % y; -} - -template <> -static __inline__ __device__ Word64 mod(const Word64 x, const Word64 y) -{ - return x % y; -} - - - -/* * Type coercion */ template @@ -122,13 +35,13 @@ } template <> -static __inline__ __device__ Word32 reinterpret32(const Word32 x) +__inline__ __device__ Word32 reinterpret32(const Word32 x) { return x; } template <> -static __inline__ __device__ Word32 reinterpret32(const float x) +__inline__ __device__ Word32 reinterpret32(const float x) { return __float_as_int(x); } @@ -143,14 +56,14 @@ } template <> -static __inline__ __device__ Word64 reinterpret64(const Word64 x) +__inline__ __device__ Word64 reinterpret64(const Word64 x) { return x; } #if !defined(__CUDA_ARCH__) || __CUDA_ARCH__ >= 130 template <> -static __inline__ __device__ Word64 reinterpret64(const double x) +__inline__ __device__ Word64 reinterpret64(const double x) { return __double_as_longlong(x); } @@ -171,13 +84,13 @@ #if !defined(__CUDA_ARCH__) || __CUDA_ARCH__ >= 110 template <> -static __inline__ __device__ Int32 atomicCAS32(Int32* address, Int32 compare, Int32 val) +__inline__ __device__ Int32 atomicCAS32(Int32* address, Int32 compare, Int32 val) { return atomicCAS(address, compare, val); } template <> -static __inline__ __device__ Word32 atomicCAS32(Word32* address, Word32 compare, Word32 val) +__inline__ __device__ Word32 atomicCAS32(Word32* address, Word32 compare, Word32 val) { return atomicCAS(address, compare, val); } @@ -194,7 +107,7 @@ } template <> -static __inline__ __device__ Word64 atomicCAS64(Word64* address, Word64 compare, Word64 val) +__inline__ __device__ Word64 atomicCAS64(Word64* address, Word64 compare, Word64 val) { return atomicCAS(address, compare, val); } @@ -217,13 +130,13 @@ } template <> -static __inline__ __device__ int shfl_up32(int var, unsigned int delta, int width) +__inline__ __device__ int shfl_up32(int var, unsigned int delta, int width) { return __shfl_up(var, delta, width); } template <> -static __inline__ __device__ float shfl_up32(float var, unsigned int delta, int width) +__inline__ __device__ float shfl_up32(float var, unsigned int delta, int width) { return __shfl_up(var, delta, width); } @@ -254,13 +167,13 @@ } template <> -static __inline__ __device__ int shfl_xor32(int var, int laneMask, int width) +__inline__ __device__ int shfl_xor32(int var, int laneMask, int width) { return __shfl_xor(var, laneMask, width); } template <> -static __inline__ __device__ float shfl_xor32(float var, int laneMask, int width) +__inline__ __device__ float shfl_xor32(float var, int laneMask, int width) { return __shfl_xor(var, laneMask, width); } diff --git a/cubits/accelerate_cuda_texture.h b/cubits/accelerate_cuda_texture.h --- a/cubits/accelerate_cuda_texture.h +++ b/cubits/accelerate_cuda_texture.h @@ -1,8 +1,8 @@ /* ----------------------------------------------------------------------------- * * Module : Texture - * Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee - * [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell + * Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller + * [2009..2014] Trevor L. McDonell * License : BSD3 * * Maintainer : Trevor L. McDonell diff --git a/cubits/accelerate_cuda_type.h b/cubits/accelerate_cuda_type.h --- a/cubits/accelerate_cuda_type.h +++ b/cubits/accelerate_cuda_type.h @@ -1,8 +1,8 @@ /* ----------------------------------------------------------------------------- * * Module : Type - * Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee - * [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell + * Copyright : [2008..2014] Manuel M T Chakravarty, Gabriele Keller + * [2009..2014] Trevor L. McDonell * License : BSD3 * * Maintainer : Trevor L. McDonell @@ -30,3 +30,4 @@ typedef unsigned long long Word64; #endif + diff --git a/include/accelerate.h b/include/accelerate.h deleted file mode 100644 --- a/include/accelerate.h +++ /dev/null @@ -1,31 +0,0 @@ - -#ifndef ACCELERATE_H -#define ACCELERATE_H -import qualified Data.Array.Accelerate.Internal.Check as Ck - - -/* - * Internal checks - */ -#define ERROR(f) (Ck.f __FILE__ __LINE__) -#define ASSERT (Ck.assert __FILE__ __LINE__) -#define ENSURE (Ck.f __FILE__ __LINE__) -#define CHECK(f) (Ck.f __FILE__ __LINE__) - -#define BOUNDS_ERROR(f) (ERROR(f) Ck.Bounds) -#define BOUNDS_ASSERT (ASSERT Ck.Bounds) -#define BOUNDS_ENSURE (ENSURE Ck.Bounds) -#define BOUNDS_CHECK(f) (CHECK(f) Ck.Bounds) - -#define UNSAFE_ERROR(f) (ERROR(f) Ck.Unsafe) -#define UNSAFE_ASSERT (ASSERT Ck.Unsafe) -#define UNSAFE_ENSURE (ENSURE Ck.Unsafe) -#define UNSAFE_CHECK(f) (CHECK(f) Ck.Unsafe) - -#define INTERNAL_ERROR(f) (ERROR(f) Ck.Internal) -#define INTERNAL_ASSERT (ASSERT Ck.Internal) -#define INTERNAL_ENSURE (ENSURE Ck.Internal) -#define INTERNAL_CHECK(f) (CHECK(f) Ck.Internal) - -#endif -