cuda 0.7.0.0 → 0.7.5.0

raw patch · 18 files changed

+648/−420 lines, 18 filessetup-changed

Files

• CHANGELOG.markdown +6/−0
• Foreign/CUDA/Analysis/Device.chs +2/−1
• Foreign/CUDA/Analysis/Occupancy.hs +14/−17
• Foreign/CUDA/Driver/Context/Config.chs +7/−7
• Foreign/CUDA/Driver/Device.chs +4/−1
• Foreign/CUDA/Driver/Error.chs +13/−4
• Foreign/CUDA/Driver/IPC/Event.chs +9/−5
• Foreign/CUDA/Driver/IPC/Marshal.chs +18/−9
• Foreign/CUDA/Driver/Marshal.chs +21/−1
• Foreign/CUDA/Driver/Module/Base.chs +14/−3
• Foreign/CUDA/Driver/Module/Link.chs +6/−1
• Foreign/CUDA/Driver/Profiler.chs +100/−0
• Foreign/CUDA/Runtime/Error.chs +1/−1
• Setup.hs +335/−350
• cbits/init.c +52/−0
• cbits/stubs.c +0/−6
• cbits/stubs.h +3/−3
• cuda.cabal +43/−11

@@ -1,3 +1,9 @@+0.7.1.0++  * mallocHostForeignPtr++  * Add profiler control functions+ 0.7.0.0    * Add support for operations from CUDA-7.0

@@ -160,11 +160,12 @@       Compute 2 0 -> DeviceResources 32 1536  8 48  32  49152 128  32768  64 2  63 Warp   -- Fermi GF100       Compute 2 1 -> DeviceResources 32 1536  8 48  48  49152 128  32768  64 2  63 Warp   -- Fermi GF10x       Compute 3 0 -> DeviceResources 32 2048 16 64 192  49152 256  65536 256 4  63 Warp   -- Kepler GK10x-      Compute 3 2 -> DeviceResources 32 2048 16 64 192  49152 256  65536 256 4 255 Warp   -- Jetson TK1 (speculative)+      Compute 3 2 -> DeviceResources 32 2048 16 64 192  49152 256  65536 256 4 255 Warp   -- Jetson TK1       Compute 3 5 -> DeviceResources 32 2048 16 64 192  49152 256  65536 256 4 255 Warp   -- Kepler GK11x       Compute 3 7 -> DeviceResources 32 2048 16 64 192 114688 256 131072 256 4 266 Warp   -- Kepler GK21x       Compute 5 0 -> DeviceResources 32 2048 32 64 128  65536 256  65536 256 4 255 Warp   -- Maxwell GM10x       Compute 5 2 -> DeviceResources 32 2048 32 64 128  98304 256  65536 256 4 255 Warp   -- Maxwell GM20x+      Compute 5 3 -> DeviceResources 32 2048 32 64 128  65536 256  65536 256 4 255 Warp   -- Maxwell GM20B        -- Something might have gone wrong, or the library just needs to be       -- updated for the next generation of hardware, in which case we just want

@@ -49,7 +49,7 @@ module Foreign.CUDA.Analysis.Occupancy (      Occupancy(..),-    occupancy, optimalBlockSize, optimalBlockSizeBy, maxResidentBlocks,+    occupancy, optimalBlockSize, optimalBlockSizeOf, maxResidentBlocks,     incPow2, incWarp, decPow2, decWarp  ) where@@ -93,7 +93,6 @@     regs' = 1 `max` regs     smem' = 1 `max` smem -    floor'        = floor   :: Double -> Int     ceiling'      = ceiling :: Double -> Int     ceilingBy x s = s * ceiling' (fromIntegral x / fromIntegral s) @@ -111,9 +110,9 @@      -- Maximum thread blocks per multiprocessor     ---    limitWarpBlock = threadBlocksPerMP gpu `min` floor' (fromIntegral (warpsPerMP gpu)     / fromIntegral warps)-    limitRegMP     = threadBlocksPerMP gpu `min` floor' (fromIntegral (regFileSize gpu)    / fromIntegral registers)-    limitSMemMP    = threadBlocksPerMP gpu `min` floor' (fromIntegral (sharedMemPerMP gpu) / fromIntegral sharedMem)+    limitWarpBlock = threadBlocksPerMP gpu `min` (warpsPerMP gpu     `div` warps)+    limitRegMP     = threadBlocksPerMP gpu `min` (regFileSize gpu    `div` registers)+    limitSMemMP    = threadBlocksPerMP gpu `min` (sharedMemPerMP gpu `div` sharedMem)   -- |@@ -127,7 +126,7 @@     -> (Int -> Int)             -- ^ Register count as a function of thread block size     -> (Int -> Int)             -- ^ Shared memory usage (bytes) as a function of thread block size     -> (Int, Occupancy)-optimalBlockSize = flip optimalBlockSizeBy decWarp+optimalBlockSize dev = optimalBlockSizeOf dev (decWarp dev)   -- |@@ -137,18 +136,16 @@ -- should be monotonically decreasing to return the smallest block size yielding -- maximum occupancy, and vice-versa. ---{-# INLINEABLE optimalBlockSizeBy #-}-optimalBlockSizeBy-    :: DeviceProperties-    -> (DeviceProperties -> [Int])-    -> (Int -> Int)-    -> (Int -> Int)+{-# INLINEABLE optimalBlockSizeOf #-}+optimalBlockSizeOf+    :: DeviceProperties         -- ^ Architecture to optimise for+    -> [Int]                    -- ^ Thread block sizes to consider+    -> (Int -> Int)             -- ^ Register count as a function of thread block size+    -> (Int -> Int)             -- ^ Shared memory usage (bytes) as a function of thread block size     -> (Int, Occupancy)-optimalBlockSizeBy !dev !fblk !freg !fsmem-  = maximumBy (comparing (occupancy100 . snd)) $ zip threads residency-  where-    residency = map (\t -> occupancy dev t (freg t) (fsmem t)) threads-    threads   = fblk dev+optimalBlockSizeOf !dev !threads !freg !fsmem+  = maximumBy (comparing (occupancy100 . snd))+  $ [ (t, occupancy dev t (freg t) (fsmem t)) | t <- threads ]   -- | Increments in powers-of-two, over the range of supported thread block sizes

@@ -85,7 +85,7 @@ -- | -- Device shared memory configuration preference ---#if CUDA_VERSION < 3020+#if CUDA_VERSION < 4020 data SharedMem #else {# enum CUsharedconfig as SharedMem@@ -218,14 +218,14 @@ -- devices without configurable shared memory, this function returns the -- fixed bank size of the hardware. ----- Requires CUDA-3.2+-- Requires CUDA-4.2 -- -- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__CTX.html#group__CUDA__CTX_1g17153a1b8b8c756f7ab8505686a4ad74> -- {-# INLINEABLE getSharedMem #-} getSharedMem :: IO SharedMem-#if CUDA_VERSION < 3020-getSharedMem = requireSDK 'getSharedMem 3.2+#if CUDA_VERSION < 4020+getSharedMem = requireSDK 'getSharedMem 4.2 #else getSharedMem = resultIfOk =<< cuCtxGetSharedMemConfig @@ -249,14 +249,14 @@ -- allow for greater potential bandwidth to shared memory, but change the -- kinds of accesses which result in bank conflicts. ----- Requires CUDA-3.2+-- Requires CUDA-4.2 -- -- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__CTX.html#group__CUDA__CTX_1g2574235fa643f8f251bf7bc28fac3692> -- {-# INLINEABLE setSharedMem #-} setSharedMem :: SharedMem -> IO ()-#if CUDA_VERSION < 3020-setSharedMem _  = requireSDK 'setSharedMem 3.2+#if CUDA_VERSION < 4020+setSharedMem _  = requireSDK 'setSharedMem 4.2 #else setSharedMem !c = nothingIfOk =<< cuCtxSetSharedMemConfig c 

@@ -141,7 +141,10 @@ -- {-# INLINEABLE initialise #-} initialise :: [InitFlag] -> IO ()-initialise !flags = nothingIfOk =<< cuInit flags+initialise !flags = nothingIfOk =<< cuInit flags <* enable_constructors++{-# INLINE enable_constructors #-}+{# fun unsafe enable_constructors { } -> `()' #}  {-# INLINE cuInit #-} {# fun unsafe cuInit

@@ -16,7 +16,7 @@   -- * CUDA Errors   Status(..), CUDAException(..),   describe,-  cudaError, requireSDK,+  cudaError, cudaErrorIO, requireSDK,   resultIfOk, nothingIfOk,  ) where@@ -159,15 +159,24 @@   -- |+-- Raise a CUDAException. Exceptions can be thrown from pure code, but can only+-- be caught in the 'IO' monad.+--+{-# RULES "cudaError/IO" cudaError = cudaErrorIO #-}+{-# NOINLINE [1] cudaError #-}+cudaError :: String -> a+cudaError s = throw (UserError s)++-- | -- Raise a CUDAException in the IO Monad ---cudaError :: String -> IO a-cudaError s = throwIO (UserError s)+cudaErrorIO :: String -> IO a+cudaErrorIO s = throwIO (UserError s)  -- | -- A specially formatted error message ---requireSDK :: Name -> Double -> IO a+requireSDK :: Name -> Double -> a requireSDK n v = cudaError $ printf "'%s' requires at least cuda-%3.1f\n" (show n) v  

@@ -13,7 +13,7 @@ -- Restricted to devices which support unified addressing on Linux -- operating systems. ----- Since CUDA-4.0.+-- Since CUDA-4.1. -- -------------------------------------------------------------------------------- @@ -77,8 +77,8 @@ -- {-# INLINEABLE export #-} export :: Event -> IO IPCEvent-#if CUDA_VERSION < 4000-export _   = requireSDK 'create 4.0+#if CUDA_VERSION < 4010+export _   = requireSDK 'create 4.1 #else export !ev = do   h <- newIPCEventHandle@@ -109,8 +109,8 @@ -- {-# INLINEABLE open #-} open :: IPCEvent -> IO Event-#if CUDA_VERSION < 4000-open _    = requireSDK 'open 4.0+#if CUDA_VERSION < 4010+open _    = requireSDK 'open 4.1 #else open !ev = resultIfOk =<< cuIpcOpenEventHandle (useIPCEvent ev) @@ -132,5 +132,9 @@ type IPCEventHandle = ForeignPtr ()  newIPCEventHandle :: IO IPCEventHandle+#if CUDA_VERSION < 4010+newIPCEventHandle = requireSDK 'newIPCEventHandle 4.1+#else newIPCEventHandle = mallocForeignPtrBytes {#sizeof CUipcEventHandle#}+#endif 

@@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns             #-} {-# LANGUAGE CPP                      #-}+{-# LANGUAGE EmptyDataDecls           #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE TemplateHaskell          #-} --------------------------------------------------------------------------------@@ -58,9 +59,13 @@ -- | -- Flags for controlling IPC memory access --+#if CUDA_VERSION < 4010+data IPCFlag+#else {# enum CUipcMem_flags as IPCFlag   { underscoreToCase }   with prefix="CU_IPC_MEM" deriving (Eq, Show, Bounded) #}+#endif   --------------------------------------------------------------------------------@@ -72,14 +77,14 @@ -- allocation. The handle can then be sent to another process and made -- available to that process via 'open'. ----- Requires CUDA-4.0.+-- Requires CUDA-4.1. -- -- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1g6f1b5be767b275f016523b2ac49ebec1> -- {-# INLINEABLE export #-} export :: DevicePtr a -> IO (IPCDevicePtr a)-#if CUDA_VERSION < 4000-export _     = requireSDK 'create 4.0+#if CUDA_VERSION < 4010+export _     = requireSDK 'export 4.1 #else export !dptr = do   h <- newIPCMemHandle@@ -109,14 +114,14 @@ -- context per device per other process. Memory returned by 'open' must be -- freed via 'close'. ----- Requires CUDA-4.0.+-- Requires CUDA-4.1. -- -- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1ga8bd126fcff919a0c996b7640f197b79> -- {-# INLINEABLE open #-} open :: IPCDevicePtr a -> [IPCFlag]-> IO (DevicePtr a)-#if CUDA_VERSION < 4000-open _    _      = requireSDK 'open 4.0+#if CUDA_VERSION < 4010+open _    _      = requireSDK 'open 4.1 #else open !hdl !flags = resultIfOk =<< cuIpcOpenMemHandle (useIPCDevicePtr hdl) flags @@ -138,14 +143,14 @@ -- Any resources used to enable peer access will be freed if this is the -- last mapping using them. ----- Requires CUDA-4.0.+-- Requires CUDA-4.1. -- -- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1gd6f5d5bcf6376c6853b64635b0157b9e> -- {-# INLINEABLE close #-} close :: DevicePtr a -> IO ()-#if CUDA_VERSION < 4000-close _     = requireSDK 'close 4.0+#if CUDA_VERSION < 4010+close _     = requireSDK 'close 4.1 #else close !dptr = nothingIfOk =<< cuIpcCloseMemHandle dptr @@ -164,5 +169,9 @@ type IPCMemHandle = ForeignPtr ()  newIPCMemHandle :: IO IPCMemHandle+#if CUDA_VERSION < 4010+newIPCMemHandle = requireSDK 'newIPCMemHandle 4.1+#else newIPCMemHandle = mallocForeignPtrBytes {#sizeof CUipcMemHandle#}+#endif 

@@ -18,7 +18,8 @@    -- * Host Allocation   AllocFlag(..),-  mallocHostArray, freeHost, registerArray, unregisterArray,+  mallocHostArray, mallocHostForeignPtr, freeHost,+  registerArray, unregisterArray,    -- * Device Allocation   mallocArray, allocaArray, free,@@ -59,6 +60,7 @@ -- System import Data.Int import Data.Maybe+import Data.Word import Unsafe.Coerce import Control.Applicative import Control.Exception@@ -66,6 +68,7 @@  import Foreign.C import Foreign.Ptr+import Foreign.ForeignPtr import Foreign.Storable import qualified Foreign.Marshal                        as F @@ -111,6 +114,18 @@     doMalloc :: Storable a' => a' -> Int -> IO (HostPtr a')     doMalloc x !n = resultIfOk =<< cuMemHostAlloc (n * sizeOf x) flags +-- |+-- As 'mallocHostArray', but return a 'ForeignPtr' instead. The array will be+-- deallocated automatically once the last reference to the 'ForeignPtr' is+-- dropped.+--+{-# INLINEABLE mallocHostForeignPtr #-}+{-# SPECIALISE mallocHostForeignPtr :: [AllocFlag] -> Int -> IO (ForeignPtr Word8) #-}+mallocHostForeignPtr :: Storable a => [AllocFlag] -> Int -> IO (ForeignPtr a)+mallocHostForeignPtr !flags !size = do+  HostPtr ptr <- mallocHostArray flags size+  newForeignPtr finalizerMemFreeHost ptr+ {-# INLINE cuMemHostAlloc #-} {# fun unsafe cuMemHostAlloc   { alloca'-        `HostPtr a'   peekHP*@@ -120,6 +135,11 @@     alloca' !f = F.alloca $ \ !p -> poke p nullPtr >> f (castPtr p)     peekHP !p  = HostPtr . castPtr <$> peek p +-- Pointer to the foreign function to release host arrays, which may be used as+-- a finalizer. Technically this function has a non-void return type, but I am+-- hoping that that doesn't matter...+--+foreign import ccall "&cuMemFreeHost" finalizerMemFreeHost :: FinalizerPtr a  -- | -- Free a section of page-locked host memory.

@@ -1,5 +1,8 @@ {-# LANGUAGE BangPatterns             #-}+{-# LANGUAGE CPP                      #-}+{-# LANGUAGE EmptyDataDecls           #-} {-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE TemplateHaskell          #-} {-# OPTIONS_HADDOCK prune #-} -------------------------------------------------------------------------------- -- |@@ -102,10 +105,14 @@ -- | -- Device code formats that can be used for online linking --+#if CUDA_VERSION < 5050+data JITInputType+#else {# enum CUjitInputType as JITInputType     { underscoreToCase     , CU_JIT_INPUT_PTX as PTX }     with prefix="CU_JIT_INPUT" deriving (Eq, Show) #}+#endif  {# enum CUjit_option as JITOptionInternal     { }@@ -207,12 +214,14 @@   (s,mdl) <- cuModuleLoadDataEx img i p_opts p_vals    case s of-    Success     -> do+    Success -> do       time    <- peek (castPtr p_vals)-      infoLog <- B.fromForeignPtr (castForeignPtr fp_ilog) 0 `fmap` c_strnlen p_ilog logSize+      bytes   <- c_strnlen p_ilog logSize+      let infoLog | bytes == 0 = B.empty+                  | otherwise  = B.fromForeignPtr (castForeignPtr fp_ilog) 0 bytes       return  $! JITResult time infoLog mdl -    _           -> do+    _       -> do       errLog  <- peekCString p_elog       cudaError (unlines [describe s, errLog]) @@ -275,8 +284,10 @@ jitTargetOfCompute (Compute 1 3) = Compute13 jitTargetOfCompute (Compute 2 0) = Compute20 jitTargetOfCompute (Compute 2 1) = Compute21+#if CUDA_VERSION >= 5000 jitTargetOfCompute (Compute 3 0) = Compute30 jitTargetOfCompute (Compute 3 5) = Compute35+#endif #if CUDA_VERSION >= 6000 jitTargetOfCompute (Compute 3 2) = Compute32 jitTargetOfCompute (Compute 5 0) = Compute50

@@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns             #-} {-# LANGUAGE CPP                      #-}+{-# LANGUAGE EmptyDataDecls           #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE TemplateHaskell          #-} --------------------------------------------------------------------------------@@ -50,8 +51,12 @@ -- | -- A pending JIT linker state --+#if CUDA_VERSION < 5050+data LinkState+#else newtype LinkState = LinkState { useLinkState :: {# type CUlinkState #} }   deriving (Show)+#endif   --------------------------------------------------------------------------------@@ -149,7 +154,7 @@ {-# INLINEABLE addFile #-} addFile :: LinkState -> FilePath -> JITInputType -> [JITOption] -> IO () #if CUDA_VERSION < 5050-addFile _ _ _ _ = requireSDK 'addile 5.5+addFile _ _ _ _ = requireSDK 'addFile 5.5 #else addFile !ls !fp !t !options =   let (opt,val) = unzip $ map jitOptionUnpack options

@@ -0,0 +1,100 @@+{-# LANGUAGE ForeignFunctionInterface #-}+--------------------------------------------------------------------------------+-- |+-- Module    : Foreign.CUDA.Driver.Profiler+-- Copyright : [2009..2014] Trevor L. McDonell+-- License   : BSD+--+-- Profiler control for low-level driver interface+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Driver.Profiler (++  OutputMode(..),+  initialise,+  start, stop,++) where++#include "cbits/stubs.h"+{# context lib="cuda" #}++-- friends+import Foreign.CUDA.Driver.Error+import Foreign.CUDA.Internal.C2HS++-- system+import Foreign+import Foreign.C+++-- | Profiler output mode+--+{# enum CUoutput_mode as OutputMode+    { underscoreToCase+    , CU_OUT_CSV as CSV }+    with prefix="CU_OUT" deriving (Eq, Show) #}+++-- | Initialise the CUDA profiler.+--+-- The configuration file is used to specify profiling options and profiling+-- counters. Refer to the "Compute Command Line Profiler User Guide" for+-- supported profiler options and counters.+--+-- Note that the CUDA profiler can not be initialised with this function if+-- another profiling tool is already active.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__PROFILER.html#group__CUDA__PROFILER>+--+{-# INLINEABLE initialise #-}+initialise+    :: FilePath     -- ^ configuration file that itemises which counters and/or options to profile+    -> FilePath     -- ^ output file where profiling results will be stored+    -> OutputMode+    -> IO ()+initialise config output mode+  = nothingIfOk =<< cuProfilerInitialize config output mode++{-# INLINE cuProfilerInitialize #-}+{# fun unsafe cuProfilerInitialize+  {           `String'+  ,           `String'+  , cFromEnum `OutputMode'+  }+  -> `Status' cToEnum #}+++-- | Begin profiling collection by the active profiling tool for the current+-- context. If profiling is already enabled, then this has no effect.+--+-- 'start' and 'stop' can be used to programatically control profiling+-- granularity, by allowing profiling to be done only on selected pieces of+-- code.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__PROFILER.html#group__CUDA__PROFILER_1g8a5314de2292c2efac83ac7fcfa9190e>+--+{-# INLINEABLE start #-}+start :: IO ()+start = nothingIfOk =<< cuProfilerStart++{-# INLINE cuProfilerStart #-}+{# fun unsafe cuProfilerStart+  { } -> `Status' cToEnum #}+++-- | Stop profiling collection by the active profiling tool for the current+-- context, and force all pending profiler events to be written to the output+-- file. If profiling is already inactive, this has no effect.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__PROFILER.html#group__CUDA__PROFILER_1g4d8edef6174fd90165e6ac838f320a5f>+--+{-# INLINEABLE stop #-}+stop :: IO ()+stop = nothingIfOk =<< cuProfilerStop++{-# INLINE cuProfilerStop #-}+{# fun unsafe cuProfilerStop+  { } -> `Status' cToEnum #}+

@@ -83,7 +83,7 @@ -- | -- Return the descriptive string associated with a particular error code ---{# fun pure unsafe cudaGetErrorStringWrapper as describe+{# fun pure unsafe cudaGetErrorString as describe     { cFromEnum `Status' } -> `String' #} -- -- Logically, this must be a pure function, returning a pointer to a statically

@@ -1,3 +1,4 @@+ import Distribution.PackageDescription import Distribution.PackageDescription.Parse import Distribution.Simple@@ -5,7 +6,7 @@ import Distribution.Simple.Command import Distribution.Simple.Program.Db import Distribution.Simple.LocalBuildInfo-import Distribution.Simple.PreProcess           hiding (ppC2hs)+import Distribution.Simple.PreProcess                               hiding ( ppC2hs ) import Distribution.Simple.Program import Distribution.Simple.Setup import Distribution.Simple.Utils@@ -15,23 +16,190 @@ import Control.Exception import Control.Monad import Data.Function-import Data.List                                hiding (isInfixOf)+import Data.List import Data.Maybe import System.Directory import System.Environment-import System.Exit                              hiding (die) import System.FilePath-import System.IO.Error                          hiding (catch)+import System.IO.Error import Text.Printf-import Prelude                                  hiding (catch)+import Prelude  -newtype CudaPath = CudaPath { cudaPath :: String }-  deriving (Eq, Ord, Show, Read)+-- Configuration+-- ------------- +customBuildInfoFilePath :: FilePath+customBuildInfoFilePath = "cuda" <.> "buildinfo" +generatedBuildInfoFilePath :: FilePath+generatedBuildInfoFilePath = customBuildInfoFilePath <.> "generated"++defaultCUDAInstallPath :: Platform -> FilePath+defaultCUDAInstallPath _ = "/usr/local/cuda"  -- windows?+++-- Build setup+-- -----------++main :: IO ()+main = defaultMainWithHooks customHooks+  where+    readHook get_verbosity a flags = do+        noExtraFlags a+        getHookedBuildInfo (fromFlag (get_verbosity flags))++    preprocessors = hookedPreProcessors simpleUserHooks++    -- Our readHook implementation uses our getHookedBuildInfo. We can't rely on+    -- cabal's autoconfUserHooks since they don't handle user overwrites to+    -- buildinfo like we do.+    --+    customHooks =+      simpleUserHooks+        { preBuild            = preBuildHook -- not using 'readHook' here because 'build' takes; extra args+        , preClean            = readHook cleanVerbosity+        , preCopy             = readHook copyVerbosity+        , preInst             = readHook installVerbosity+        , preHscolour         = readHook hscolourVerbosity+        , preHaddock          = readHook haddockVerbosity+        , preReg              = readHook regVerbosity+        , preUnreg            = readHook regVerbosity+        , postConf            = postConfHook+        , hookedPreProcessors = ("chs", ppC2hs) : filter (\x -> fst x /= "chs") preprocessors+        }++    -- The hook just loads the HookedBuildInfo generated by postConfHook,+    -- unless there is user-provided info that overwrites it.+    --+    preBuildHook :: Args -> BuildFlags -> IO HookedBuildInfo+    preBuildHook _ flags = getHookedBuildInfo $ fromFlag $ buildVerbosity flags++    -- The hook scans system in search for CUDA Toolkit. If the toolkit is not+    -- found, an error is raised. Otherwise the toolkit location is used to+    -- create a `cuda.buildinfo.generated` file with all the resulting flags.+    --+    postConfHook :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ()+    postConfHook args flags pkg_descr lbi = do+      let+          verbosity       = fromFlag (configVerbosity flags)+          currentPlatform = hostPlatform lbi+          compilerId_     = compilerId (compiler lbi)+      --+      noExtraFlags args+      generateAndStoreBuildInfo verbosity currentPlatform compilerId_ generatedBuildInfoFilePath+      validateLinker verbosity currentPlatform $ withPrograms lbi+      --+      actualBuildInfoToUse <- getHookedBuildInfo verbosity+      let pkg_descr' = updatePackageDescription actualBuildInfoToUse pkg_descr+      postConf simpleUserHooks args flags pkg_descr' lbi+++-- Generates build info with flags needed for CUDA Toolkit to be properly+-- visible to underlying build tools.+--+libraryBuildInfo :: FilePath -> Platform -> Version -> IO HookedBuildInfo+libraryBuildInfo installPath platform@(Platform arch os) ghcVersion = do+  let+      libraryPaths      = [cudaLibraryPath platform installPath]+      includePaths      = [cudaIncludePath platform installPath]++      -- options for GHC+      extraLibDirs'     = libraryPaths+      ccOptions'        = map ("-I"++) includePaths+      ldOptions'        = map ("-L"++) libraryPaths+      ghcOptions        = map ("-optc"++) ccOptions'+                       ++ map ("-optl"++) ldOptions'+                       ++ if os /= Windows+                            then map ("-optl-Wl,-rpath,"++) extraLibDirs'+                            else []+      extraLibs'        = cudaLibraries platform+      frameworks'       = [ "CUDA" | os == OSX ]++      -- options or c2hs+      archFlag          = case arch of+                            I386   -> "-m32"+                            X86_64 -> "-m64"+                            _      -> ""+      emptyCase         = ["-DUSE_EMPTY_CASE" | versionBranch ghcVersion >= [7,8]]+      blocksExtension   = [ "-U__BLOCKS__" | os == OSX ]+      c2hsOptions       = unwords $ map ("--cppopts="++) ("-E" : archFlag : emptyCase ++ blocksExtension)+      c2hsExtraOptions  = ("x-extra-c2hs-options", c2hsOptions)++      addSystemSpecificOptions :: BuildInfo -> IO BuildInfo+      addSystemSpecificOptions bi =+        case os of+          _ -> return bi++  extraGHCiLibs' <- cudaGHCiLibraries platform installPath extraLibs'+  buildInfo'     <- addSystemSpecificOptions $ emptyBuildInfo+    { ccOptions      = ccOptions'+    , ldOptions      = ldOptions'+    , extraLibs      = extraLibs'+    , extraGHCiLibs  = extraGHCiLibs'+    , extraLibDirs   = extraLibDirs'+    , frameworks     = frameworks'+    , options        = [(GHC, ghcOptions) | os /= Windows]+    , customFieldsBI = [c2hsExtraOptions]+    }++  return (Just buildInfo', [])+++-- Return the location of the include directory relative to the base CUDA+-- installation.+--+cudaIncludePath :: Platform -> FilePath -> FilePath+cudaIncludePath _ installPath = installPath </> "include"+++-- Return the location of the libraries relative to the base CUDA installation.+--+cudaLibraryPath :: Platform -> FilePath -> FilePath+cudaLibraryPath (Platform arch os) installPath = installPath </> libpath+  where+    libpath =+      case (os, arch) of+        (Windows, I386)   -> "Win32"+        (Windows, X86_64) -> "x64"+        (OSX,     _)      -> "lib"    -- MacOS does not distinguish 32- vs. 64-bit paths+        (_,       X86_64) -> "lib64"  -- treat all others similarly+        _                 -> "lib"+++-- On Windows and OSX we use different libraries depending on whether we are+-- linking statically (executables) or dynamically (ghci).+--+cudaLibraries :: Platform -> [String]+cudaLibraries (Platform _ os) =+  case os of+    OSX -> ["cudadevrt", "cudart_static"]+    _   -> ["cudart", "cuda"]++cudaGHCiLibraries :: Platform -> FilePath -> [String] -> IO [String]+cudaGHCiLibraries platform@(Platform _ os) installPath libraries =+  case os of+    Windows -> cudaGhciLibrariesWindows platform installPath libraries+    OSX     -> return ["cudart"]+    _       -> return []+ -- Windows compatibility function. --+-- The function is used to populate the extraGHCiLibs list on Windows+-- platform. It takes libraries directory and .lib filenames and returns+-- their corresponding dll filename. (Both filenames are stripped from+-- extensions)+--+-- Eg: "C:\cuda\toolkit\lib\x64" -> ["cudart", "cuda"] -> ["cudart64_65", "ncuda"]+--+cudaGhciLibrariesWindows :: Platform -> FilePath -> [FilePath] -> IO [FilePath]+cudaGhciLibrariesWindows platform installPath libraries = do+  candidates <- mapM importLibraryToDLLFileName [ cudaLibraryPath platform installPath </> lib <.> "lib" | lib <- libraries ]+  return [ dropExtension dll | Just dll <- candidates ]+++-- Windows compatibility function.+-- -- CUDA toolkit uses different names for import libraries and their -- respective DLLs. For example, on 32-bit architecture and version 7.0 of -- toolkit, `cudart.lib` imports functions from `cudart32_70`.@@ -50,8 +218,8 @@ -- The function is meant to be used on Windows. Other platforms may or may -- not work. ---importLibraryToDllFileName :: FilePath -> IO (Maybe FilePath)-importLibraryToDllFileName importLibPath = do+importLibraryToDLLFileName :: FilePath -> IO (Maybe FilePath)+importLibraryToDLLFileName importLibPath = do   -- Sample output nm generates on cudart.lib   --   -- nvcuda.dll:@@ -67,76 +235,18 @@   nmOutput <- getProgramInvocationOutput normal (simpleProgramInvocation "nm" [importLibPath])   return $ find (isInfixOf ("" <.> dllExtension)) (lines nmOutput) --- Windows compatibility function.------ The function is used to populate the extraGHCiLibs list on Windows--- platform. It takes libraries directory and .lib filenames and returns--- their corresponding dll filename. (Both filenames are stripped from--- extensions)------ Eg: "C:\cuda\toolkit\lib\x64" -> ["cudart", "cuda"] -> ["cudart64_65", "ncuda"]----additionalGhciLibraries :: FilePath -> [FilePath] -> IO [FilePath]-additionalGhciLibraries libdir importLibs = do-  let libsAbsolutePaths = map (\libname -> libdir </> libname <.> "lib") importLibs-  candidateNames <- mapM importLibraryToDllFileName libsAbsolutePaths-  let dllNames = map (\(Just dllname) -> dropExtension dllname) (filter isJust candidateNames)-  return dllNames --- Mac OS X compatibility function------ Returns [] or ["U__BLOCKS__"]----getAppleBlocksOption :: IO [String]-getAppleBlocksOption = do-  let handler :: IOError -> IO String-      handler = (\_ -> return "")-  -- If file does not exist, we'll end up wth an empty string.-  fileContents <- catch (readFile "/usr/include/stdlib.h") handler-  return ["-U__BLOCKS__"  |  "__BLOCKS__" `isInfixOf` fileContents]--getCudaIncludePath :: CudaPath -> FilePath-getCudaIncludePath (CudaPath path) = path </> "include"--getCudaLibraryPath :: CudaPath -> Platform -> FilePath-getCudaLibraryPath (CudaPath path) (Platform arch os) = path </> libSubpath-  where-    libSubpath = case os of-      Windows -> "lib" </> case arch of-         I386   -> "Win32"-         X86_64 -> "x64"-         _      -> error $ printf "Unexpected Windows architecture %s.\nPlease report this issue to https://github.com/tmcdonell/cuda/issues\n" (show arch)--      OSX       -> "lib"--      -- For now just treat all other systems similarly-      _ -> case arch of-         X86_64 -> "lib64"-         I386   -> "lib"-         _      -> "lib"  -- TODO: how should this be handled?----- On OS X we don't link against the CUDA and CUDART libraries directly.--- Instead, we only link against CUDA.framework. This means that we will--- not need to set the DYLD_LIBRARY_PATH environment variable in order to--- compile or execute programs.+-- Slightly modified version of `words` from base - it takes predicate saying on+-- which characters split. ---getCudaLibraries :: Platform -> [String]-getCudaLibraries (Platform _ os) =-  case os of-    OSX -> []-    _   -> ["cudart", "cuda"]----- Slightly modified version of `words` from base - it takes predicate saying on which characters split. splitOn :: (Char -> Bool) -> String -> [String]-splitOn p s =  case dropWhile p s of-                      "" -> []-                      s' -> w : splitOn p s''-                            where (w, s'') = break p s'+splitOn p s =+  case dropWhile p s of+    [] -> []+    s' -> let (w, s'') = break p s'+          in  w : splitOn p s'' --- Tries to obtain the version `ld`.--- Throws an exception if failed.+-- Tries to obtain the version `ld`. Throws an exception if failed. -- getLdVersion :: Verbosity -> FilePath -> IO (Maybe [Int]) getLdVersion verbosity ldPath = do@@ -144,24 +254,26 @@   --                            or `GNU ld (GNU Binutils) 2.20.51.20100613`   ldVersionString <- getProgramInvocationOutput normal (simpleProgramInvocation ldPath ["-v"]) -  let versionText = last $ words ldVersionString -- takes e. g. "2.25.1"-  let versionParts = splitOn (== '.') versionText-  let versionParsed = Just $ map read versionParts+  let versionText   = last $ words ldVersionString -- takes e. g. "2.25.1"+      versionParts  = splitOn (== '.') versionText+      versionParsed = Just $ map read versionParts -  -- last and read above may throw and message would be not understandable for user,-  -- so we'll intercept exception and rethrow it with more useful message.-  let handleError :: SomeException -> IO (Maybe [Int])+      -- last and read above may throw and message would be not understandable+      -- for user, so we'll intercept exception and rethrow it with more useful+      -- message.+      handleError :: SomeException -> IO (Maybe [Int])       handleError e = do           warn verbosity $ printf "cannot parse ld version string: `%s`. Parsing exception: `%s`" ldVersionString (show e)           return Nothing -  catch (evaluate versionParsed) handleError-+  evaluate versionParsed `catch` handleError   -- On Windows GHC package comes with two copies of ld.exe.--- ProgramDb knows about the first one - ghcpath\mingw\bin\ld.exe--- This function returns the other one - ghcpath\mingw\x86_64-w64-mingw32\bin\ld.exe+--+--  1. ProgramDb knows about the first one: ghcpath\mingw\bin\ld.exe+--  2. This function returns the other one: ghcpath\mingw\x86_64-w64-mingw32\bin\ld.exe+-- -- The second one is the one that does actual linking and code generation. -- See: https://github.com/tmcdonell/cuda/issues/31#issuecomment-149181376 --@@ -169,17 +281,21 @@ -- getRealLdPath :: Verbosity -> ProgramDb -> IO (Maybe FilePath) getRealLdPath verbosity programDb =-  -- This should ideally work `programFindVersion ldProgram` but for some reason it does not.-  -- The issue should be investigated at some time.+  -- TODO: This should ideally work `programFindVersion ldProgram` but for some+  -- reason it does not. The issue should be investigated at some time.+  --   case lookupProgram ghcProgram programDb of-    Nothing -> return Nothing+    Nothing            -> return Nothing     Just configuredGhc -> do       let ghcPath        = locationPath $ programLocation configuredGhc           presumedLdPath = (takeDirectory . takeDirectory) ghcPath </> "mingw" </> "x86_64-w64-mingw32" </> "bin" </> "ld.exe"       info verbosity $ "Presuming ld location" ++ presumedLdPath       presumedLdExists <- doesFileExist presumedLdPath-      return $ if presumedLdExists then Just presumedLdPath else Nothing+      return $ if presumedLdExists+                 then Just presumedLdPath+                 else Nothing + -- On Windows platform the binutils linker targeting x64 is bugged and cannot -- properly link with import libraries generated by MS compiler (like the CUDA ones). -- The programs would correctly compile and crash as soon as the first FFI call is made.@@ -188,25 +304,26 @@ -- with guidelines on how to fix the problem. -- validateLinker :: Verbosity -> Platform -> ProgramDb -> IO ()-validateLinker verbosity (Platform X86_64 Windows) db = do-  maybeLdPath <- getRealLdPath verbosity db-  case maybeLdPath of-    Nothing -> warn verbosity $ "Cannot find ld.exe to check if it is new enough. If generated executables crash when making calls to CUDA, please see " ++ helpfulPageLinkForWindows-    Just ldPath -> do-      debug verbosity $ "Checking if ld.exe at " ++ ldPath ++ " is new enough"-      maybeVersion <- getLdVersion verbosity ldPath-      case maybeVersion of-        Nothing -> warn verbosity $ "Unknown ld.exe version. If generated executables crash when making calls to CUDA, please see " ++ helpfulPageLinkForWindows-        Just ldVersion -> do-          debug verbosity $ "Found ld.exe version: " ++ show ldVersion-          when (ldVersion < [2,25,1]) $ die $ linkerBugOnWindowsMsg ldPath-validateLinker _ _ _ = return () -- The linker bug is present only on Win64 platform+validateLinker verbosity (Platform arch os) db =+  when (arch == X86_64 && os == Windows) $ do+    maybeLdPath <- getRealLdPath verbosity db+    case maybeLdPath of+      Nothing     -> warn verbosity $ "Cannot find ld.exe to check if it is new enough. If generated executables crash when making calls to CUDA, please see " ++ windowsHelpPage+      Just ldPath -> do+        debug verbosity $ "Checking if ld.exe at " ++ ldPath ++ " is new enough"+        maybeVersion <- getLdVersion verbosity ldPath+        case maybeVersion of+          Nothing        -> warn verbosity $ "Unknown ld.exe version. If generated executables crash when making calls to CUDA, please see " ++ windowsHelpPage+          Just ldVersion -> do+            debug verbosity $ "Found ld.exe version: " ++ show ldVersion+            when (ldVersion < [2,25,1]) $ die $ windowsLinkerBugMsg ldPath -helpfulPageLinkForWindows :: String-helpfulPageLinkForWindows = "https://github.com/tmcdonell/cuda/blob/master/WINDOWS.markdown" -linkerBugOnWindowsMsg :: FilePath -> String-linkerBugOnWindowsMsg ldPath = printf (unlines msg) ldPath+windowsHelpPage :: String+windowsHelpPage = "https://github.com/tmcdonell/cuda/blob/master/WINDOWS.markdown"++windowsLinkerBugMsg :: FilePath -> String+windowsLinkerBugMsg ldPath = printf (unlines msg) windowsHelpPage ldPath   where     msg =       [ "********************************************************************************"@@ -215,7 +332,7 @@       , ""       , "To fix this issue, replace the `ld.exe` in your GHC installation with the correct binary. See the following page for details:"       , ""-      , "  " ++ helpfulPageLinkForWindows+      , "  %s"       , ""       , "The full path to the outdated `ld.exe` detected in your installation:"       , ""@@ -228,185 +345,48 @@       , "********************************************************************************"       ] --- Generates build info with flags needed for CUDA Toolkit to be properly--- visible to underlying build tools.----cudaLibraryBuildInfo :: CudaPath -> Platform -> Version -> IO HookedBuildInfo-cudaLibraryBuildInfo cudaPath platform@(Platform arch os) ghcVersion = do-  let cudaLibraryPath   = getCudaLibraryPath cudaPath platform -  -- Extra lib dirs are not needed on Mac OS. On Windows or Linux their-  -- lack would cause an error: /usr/bin/ld: cannot find -lcudart-  let extraLibDirs_     = case os of-                            OSX     -> []-                            _       -> [cudaLibraryPath]--  let includeDirs       = [getCudaIncludePath cudaPath]-  let ccOptions_        = map ("-I" ++) includeDirs-  let ldOptions_        = map ("-L" ++) extraLibDirs_-  let ghcOptions        = map ("-optc" ++) ccOptions_  ++  map ("-optl" ++ ) ldOptions_-  let extraLibs_        = getCudaLibraries platform--  -- Options for C2HS-  let c2hsArchitectureFlag = case arch of-                               I386   -> ["-m32"]-                               X86_64 -> ["-m64"]-                               _      -> []-  let c2hsEmptyCaseFlag = ["-DUSE_EMPTY_CASE" | versionBranch ghcVersion >= [7,8]]-  let c2hsCppOptions    = c2hsArchitectureFlag ++ c2hsEmptyCaseFlag ++ ["-E"]--  let c2hsOptions       = unwords . map ("--cppopts=" ++)-  let extraOptionsC2Hs  = ("x-extra-c2hs-options", c2hsOptions c2hsCppOptions)-  let buildInfo         = emptyBuildInfo-          { ccOptions      = ccOptions_-          , ldOptions      = ldOptions_-          , extraLibs      = extraLibs_-          , extraLibDirs   = extraLibDirs_-          -- Are ghc-options below  needed for anything?-          -- On Windows they need to be disabled because Cabal does not escape-          -- them (quotes and backslashes) causing build fails on machines-          -- with CUDA_PATH containing spaces.-          , options        = [(GHC, ghcOptions) | os /= Windows]-          , customFieldsBI = [extraOptionsC2Hs]-          }--  let addSystemSpecificOptions :: Platform -> IO BuildInfo-      addSystemSpecificOptions (Platform _ Windows) = do-        -- Workaround issue with ghci linker not being able to find DLLs-        -- with names different from their import LIBs.-        extraGHCiLibs_ <- additionalGhciLibraries cudaLibraryPath extraLibs_-        return buildInfo { extraGHCiLibs = extraGHCiLibs  buildInfo ++ extraGHCiLibs_ }--      addSystemSpecificOptions (Platform _ OSX) = do-        -- On OS X tell the linker about the CUDA framework. It seems like-        -- this shouldn't be necessary, since we also specify this in the-        -- frameworks field. Possibly haskell/cabal#2724?-        ---        -- We also might need to add one or more options to c2hs cpp.-        appleBlocksOption <- getAppleBlocksOption-        return buildInfo-          { ldOptions      = ldOptions      buildInfo ++ ["-framework", "CUDA"]-          , customFieldsBI = unionWith (+++) []-                           $ customFieldsBI buildInfo ++ [("frameworks", "CUDA")-                                                         ,("x-extra-c2hs-options", c2hsOptions appleBlocksOption)]-          }--      addSystemSpecificOptions _ = return buildInfo--  adjustedBuildInfo <-addSystemSpecificOptions platform-  return (Just adjustedBuildInfo, [])---unionWith :: Ord k => (a -> a -> a) -> a -> [(k,a)] -> [(k,a)]-unionWith f z-  = map (\kv -> let (k,v) = unzip kv in (head k, foldr f z v))-  . groupBy ((==) `on` fst)-  . sortBy (compare `on` fst)--(+++) :: String -> String -> String-[] +++ ys = ys-xs +++ [] = xs-xs +++ ys = xs ++ ' ':ys----- Checks whether given location looks like a valid CUDA toolkit directory+-- Runs CUDA detection procedure and stores .buildinfo to a file. ---validateLocation :: Verbosity -> FilePath -> IO Bool-validateLocation verbosity path = do-  -- TODO: Ideally this should check also for cudart.lib and whether cudart-  -- exports relevant symbols. This should be achievable with some `nm`-  -- trickery-  let testedPath = path </> "include" </> "cuda.h"-  exists <- doesFileExist testedPath-  info verbosity $-    if exists-      then printf "Path accepted: %s\n" path-      else printf "Path rejected: %s\nDoes not exist: %s\n" path testedPath-  return exists+generateAndStoreBuildInfo :: Verbosity -> Platform -> CompilerId -> FilePath -> IO ()+generateAndStoreBuildInfo verbosity platform (CompilerId _ghcFlavor ghcVersion) path = do+  installPath <- findCUDAInstallPath verbosity platform+  hbi         <- libraryBuildInfo installPath platform ghcVersion+  storeHookedBuildInfo verbosity path hbi --- Evaluates IO to obtain the path, handling any possible exceptions.--- If path is evaluable and points to valid CUDA toolkit returns True.----validateIOLocation :: Verbosity -> IO FilePath -> IO Bool-validateIOLocation verbosity iopath =-  let handler :: IOError -> IO Bool-      handler err = do-        info verbosity (show err)-        return False-  in-  catch (iopath >>= validateLocation verbosity) handler+storeHookedBuildInfo :: Verbosity -> FilePath -> HookedBuildInfo -> IO ()+storeHookedBuildInfo verbosity path hbi = do+  notice verbosity $ "Storing parameters to " ++ path+  writeHookedBuildInfo path hbi --- Function iterates over action yielding possible locations, evaluating them--- and returning the first valid one. Retuns Nothing if no location matches.----findFirstValidLocation :: Verbosity -> [(IO FilePath, String)] -> IO (Maybe FilePath)-findFirstValidLocation _         []                          = return Nothing-findFirstValidLocation verbosity ((locate,description):rest) = do-  info verbosity $ printf "checking for %s\n" description-  found <- validateIOLocation verbosity locate-  if found-    then Just `fmap` locate-    else findFirstValidLocation verbosity rest -nvccProgramName :: String-nvccProgramName = "nvcc"---- NOTE: this function throws an exception when there is no `nvcc` in PATH.--- The exception contains a meaningful message.----findProgramLocationThrowing :: String -> IO FilePath-findProgramLocationThrowing execName = do-  location <- findProgramLocation normal execName-  case location of-    Just validLocation -> return validLocation-    Nothing            -> ioError $ mkIOError doesNotExistErrorType ("not found: " ++ execName) Nothing Nothing---- Returns pairs (action yielding candidate path, String description of that location)+-- Try to locate CUDA installation by checking (in order): ---candidateCudaLocation :: [(IO FilePath, String)]-candidateCudaLocation =-  [ env "CUDA_PATH"-  , (nvccLocation, "nvcc compiler in PATH")-  , defaultPath "/usr/local/cuda"-  ]-  where-    env s         = (getEnv s, printf "environment variable %s" s)-    defaultPath p = (return p, printf "default location %s" p)-    ---    nvccLocation :: IO FilePath-    nvccLocation = do-      nvccPath <- findProgramLocationThrowing nvccProgramName-      -- The obtained path is likely TOOLKIT/bin/nvcc-      -- We want to extract the TOOLKIT part-      let ret = takeDirectory $ takeDirectory nvccPath-      return ret----- Try to locate CUDA installation on the drive.--- Currently this means (in order)---  1) Checking the CUDA_PATH environment variable---  2) Looking for `nvcc` in `PATH`---  3) Checking /usr/local/cuda+--  1. CUDA_PATH environment variable+--  2. Looking for `nvcc` in `PATH`+--  3. Checking /usr/local/cuda -- -- In case of failure, calls die with the pretty long message from below.-findCudaLocation :: Verbosity -> IO CudaPath-findCudaLocation verbosity = do-  firstValidLocation <- findFirstValidLocation verbosity candidateCudaLocation-  case firstValidLocation of-    Just validLocation -> do-      notice verbosity $ "Found CUDA toolkit at: " ++ validLocation-      return $ CudaPath validLocation-    Nothing -> die longError+--+findCUDAInstallPath :: Verbosity -> Platform -> IO FilePath+findCUDAInstallPath verbosity platform = do+  result <- findFirstValidLocation verbosity platform (candidateCUDAInstallPaths verbosity platform)+  case result of+    Just installPath -> do+      notice verbosity $ printf "Found CUDA toolkit at: %s" installPath+      return installPath+    Nothing -> die cudaNotFoundMsg -longError :: String-longError = unlines++cudaNotFoundMsg :: String+cudaNotFoundMsg = unlines   [ "********************************************************************************"   , ""   , "The configuration process failed to locate your CUDA installation. Ensure that you have installed both the developer driver and toolkit, available from:"   , ""   , "> http://developer.nvidia.com/cuda-downloads"   , ""-  , "and make sure that `nvcc` is available in your PATH. Check the above output log and run the command directly to ensure it can be located."+  , "and make sure that `nvcc` is available in your PATH, or set the CUDA_PATH environment variable appropriately. Check the above output log and run the command directly to ensure it can be located."   , ""   , "If you have a non-standard installation, you can add additional search paths using --extra-include-dirs and --extra-lib-dirs. Note that 64-bit Linux flavours often require both `lib64` and `lib` library paths, in that order."   , ""@@ -414,77 +394,90 @@   ]  --- Runs CUDA detection procedure and stores .buildinfo to a file.+-- Function iterates over action yielding possible locations, evaluating them+-- and returning the first valid one. Returns Nothing if no location matches. ---generateAndStoreBuildInfo :: Verbosity -> Platform -> CompilerId -> FilePath -> IO ()-generateAndStoreBuildInfo verbosity platform (CompilerId _ghcFlavor ghcVersion) path = do-  cudalocation <- findCudaLocation verbosity-  pbi          <- cudaLibraryBuildInfo cudalocation platform ghcVersion-  storeHookedBuildInfo verbosity path pbi+findFirstValidLocation :: Verbosity -> Platform -> [(IO FilePath, String)] -> IO (Maybe FilePath)+findFirstValidLocation verbosity platform = go+  where+    go :: [(IO FilePath, String)] -> IO (Maybe FilePath)+    go []     = return Nothing+    go (x:xs) = do+      let (path,desc) = x+      info verbosity $ printf "checking for %s" desc+      found <- validateIOLocation verbosity platform path+      if found+        then Just `fmap` path+        else go xs -customBuildinfoFilepath :: FilePath-customBuildinfoFilepath = "cuda" <.> "buildinfo" -generatedBuldinfoFilepath :: FilePath-generatedBuldinfoFilepath = customBuildinfoFilepath <.> "generated"+-- Evaluates IO to obtain the path, handling any possible exceptions.+-- If path is evaluable and points to valid CUDA toolkit returns True.+--+validateIOLocation :: Verbosity -> Platform -> IO FilePath -> IO Bool+validateIOLocation verbosity platform iopath =+  let handler :: IOError -> IO Bool+      handler err = do+        info verbosity (show err)+        return False+  in+  (iopath >>= validateLocation verbosity platform) `catch` handler -main :: IO ()-main = defaultMainWithHooks customHooks-  where-    readHook :: (a -> Distribution.Simple.Setup.Flag Verbosity) -> Args -> a -> IO HookedBuildInfo-    readHook get_verbosity a flags = do-        noExtraFlags a-        getHookedBuildInfo verbosity-      where-        verbosity = fromFlag (get_verbosity flags) -    preprocessors = hookedPreProcessors simpleUserHooks+-- Checks whether given location looks like a valid CUDA toolkit directory+--+validateLocation :: Verbosity -> Platform -> FilePath -> IO Bool+validateLocation verbosity platform path = do+  -- TODO: Ideally this should check for e.g. cuda.lib and whether it exports+  -- relevant symbols. This should be achievable with some `nm` trickery+  --+  let cudaHeader = cudaIncludePath platform path </> "cuda.h"+  --+  exists <- doesFileExist cudaHeader+  info verbosity $+    if exists+      then printf "Path accepted: %s\n" path+      else printf "Path rejected: %s\nDoes not exist: %s\n" path cudaHeader+  return exists -    -- Our readHook implementation usees our getHookedBuildInfo.-    -- We can't rely on cabal's autoconfUserHooks since they don't handle user-    -- overwrites to buildinfo like we do.-    customHooks   = simpleUserHooks-      { preBuild    = preBuildHook -- not using 'readHook' here because 'build' takes; extra args-      , preClean    = readHook cleanVerbosity-      , preCopy     = readHook copyVerbosity-      , preInst     = readHook installVerbosity-      , preHscolour = readHook hscolourVerbosity-      , preHaddock  = readHook haddockVerbosity-      , preReg      = readHook regVerbosity-      , preUnreg    = readHook regVerbosity-      , postConf    = postConfHook-      , hookedPreProcessors = ("chs", ppC2hs) : filter (\x -> fst x /= "chs") preprocessors-      }+-- Returns pairs of (action yielding candidate path, String description of that location)+--+candidateCUDAInstallPaths :: Verbosity -> Platform -> [(IO FilePath, String)]+candidateCUDAInstallPaths verbosity platform =+  [ (getEnv "CUDA_PATH", "environment variable CUDA_PATH")+  , (findInPath,         "nvcc compiler executable in PATH")+  , (return defaultPath, printf "default install location (%s)" defaultPath)+  ]+  where+    findInPath :: IO FilePath+    findInPath = do+      nvccPath <- findProgramLocationOrError verbosity "nvcc"+      -- The obtained path is likely TOOLKIT/bin/nvcc. We want to extract the+      -- TOOLKIT part+      return (takeDirectory $ takeDirectory nvccPath) -    -- The hook just loads the HookedBuildInfo generated by postConfHook,-    -- unless there is user-provided info that overwrites it.-    preBuildHook :: Args -> BuildFlags -> IO HookedBuildInfo-    preBuildHook _ flags = getHookedBuildInfo $ fromFlag $ buildVerbosity flags+    defaultPath :: FilePath+    defaultPath = defaultCUDAInstallPath platform -    -- The hook scans system in search for CUDA Toolkit. If the toolkit is not-    -- found, an error is raised. Otherwise the toolkit location is used to-    -- create a `cuda.buildinfo.generated` file with all the resulting flags.-    postConfHook :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ()-    postConfHook args flags pkg_descr lbi = do-      let-          verbosity = fromFlag (configVerbosity flags)-          currentPlatform = hostPlatform lbi-          compilerId_ = (compilerId $ compiler lbi)-      ---      noExtraFlags args-      generateAndStoreBuildInfo verbosity currentPlatform compilerId_ generatedBuldinfoFilepath-      validateLinker verbosity currentPlatform $ withPrograms lbi-      ---      actualBuildInfoToUse <- getHookedBuildInfo verbosity-      let pkg_descr' = updatePackageDescription actualBuildInfoToUse pkg_descr-      postConf simpleUserHooks args flags pkg_descr' lbi +-- NOTE: this function throws an exception when there is no `nvcc` in PATH.+-- The exception contains a meaningful message.+--+findProgramLocationOrError :: Verbosity -> String -> IO FilePath+findProgramLocationOrError verbosity execName = do+  location <- findProgram verbosity execName+  case location of+    Just path -> return path+    Nothing   -> ioError $ mkIOError doesNotExistErrorType ("not found: " ++ execName) Nothing Nothing -storeHookedBuildInfo :: Verbosity -> FilePath -> HookedBuildInfo -> IO ()-storeHookedBuildInfo verbosity path hbi = do-    notice verbosity $ "Storing parameters to " ++ path-    writeHookedBuildInfo path hbi+findProgram :: Verbosity -> FilePath -> IO (Maybe FilePath)+findProgram verbosity prog = do+  result <- findProgramOnSearchPath verbosity defaultProgramSearchPath prog+  case result of+    Nothing       -> return Nothing+    Just (path,_) -> return (Just path) + -- Reads user-provided `cuda.buildinfo` if present, otherwise loads `cuda.buildinfo.generated` -- Outputs message informing about the other possibility. -- Calls die when neither of the files is available.@@ -492,20 +485,20 @@ -- getHookedBuildInfo :: Verbosity -> IO HookedBuildInfo getHookedBuildInfo verbosity = do-  doesCustomBuildInfoExists <- doesFileExist customBuildinfoFilepath+  doesCustomBuildInfoExists <- doesFileExist customBuildInfoFilePath   if doesCustomBuildInfoExists     then do-      notice verbosity $ printf "The user-provided buildinfo from file %s will be used. To use default settings, delete this file.\n" customBuildinfoFilepath-      readHookedBuildInfo verbosity customBuildinfoFilepath+      notice verbosity $ printf "The user-provided buildinfo from file %s will be used. To use default settings, delete this file.\n" customBuildInfoFilePath+      readHookedBuildInfo verbosity customBuildInfoFilePath     else do-      doesGeneratedBuildInfoExists <- doesFileExist generatedBuldinfoFilepath+      doesGeneratedBuildInfoExists <- doesFileExist generatedBuildInfoFilePath       if doesGeneratedBuildInfoExists         then do-          notice verbosity $ printf "Using build information from '%s'.\n" generatedBuldinfoFilepath-          notice verbosity $ printf "Provide a '%s' file to override this behaviour.\n" customBuildinfoFilepath-          readHookedBuildInfo verbosity generatedBuldinfoFilepath+          notice verbosity $ printf "Using build information from '%s'.\n" generatedBuildInfoFilePath+          notice verbosity $ printf "Provide a '%s' file to override this behaviour.\n" customBuildInfoFilePath+          readHookedBuildInfo verbosity generatedBuildInfoFilePath         else-          die $ printf "Unexpected failure. Neither the default %s nor custom %s exist.\n" generatedBuldinfoFilepath customBuildinfoFilepath+          die $ printf "Unexpected failure. Neither the default %s nor custom %s exist.\n" generatedBuildInfoFilePath customBuildInfoFilePath   -- Replicate the default C2HS preprocessor hook here, and inject a value for@@ -548,15 +541,7 @@ -- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all the other -- compilers. Check if that's really what they want. versionInt :: Version -> String-versionInt (Version { versionBranch = [] }) = "1"-versionInt (Version { versionBranch = [n] }) = show n-versionInt (Version { versionBranch = n1:n2:_ })-  = -- 6.8.x -> 608-    -- 6.10.x -> 610-    let s1 = show n1-        s2 = show n2-        middle = case s2 of-                 _ : _ : _ -> ""-                 _         -> "0"-    in s1 ++ middle ++ s2+versionInt (Version { versionBranch = [] })      = "1"+versionInt (Version { versionBranch = [n] })     = show n+versionInt (Version { versionBranch = n1:n2:_ }) = printf "%d%02d" n1 n2 

@@ -0,0 +1,52 @@+#include "cbits/stubs.h"+#include <stdio.h>++/*+ * Make sure that the linker always touches this module so that it notices the+ * below constructor function. Calling this empty function as part of+ * 'Foreign.CUDA.Driver.initialise' should be sufficient to prevent it from ever+ * being stripped.+ */+void enable_constructors() { }++/*+ * GHC-8 introduced a new (simpler) 64-bit allocator, which on startup 'mmap's+ * 1TB of address space and then commits sub-portions of that memory as needed.+ *+ * The CUDA driver also appears to 'mmap' a large chunk of address space on+ * 'cuInit', probably as the arena for shuffling memory to and from the device,+ * but attempts to do so at a _fixed_ address. If the GHC RTS has already taken+ * that address at the time we call 'cuInit', driver initialisation will fail+ * with an "out of memory" error.+ *+ * The workaround is to call 'cuInit' before initialising the RTS. Then the+ * RTS's allocation will avoid CUDA's allocation, since the RTS doesn't care+ * where in the address space it gets that memory. Embedding the following+ * __attribute__((constructor)) function in the library does the trick nicely,+ * and the linker will ensure that this gets executed when the shared library is+ * loaded (during program startup).+ *+ * Another way around this, without actually calling 'cuInit', would be to just+ * reserve the regions that 'cuInit' requires in the constructor function so+ * that the RTS avoids them, then release them before calling 'cuInit'. However,+ * since the CUDA driver is closed and we don't know exactly which regions to+ * reserve, that approach would be fragile.+ *+ * See: https://github.com/tmcdonell/cuda/issues/39+ */+__attribute__((constructor)) void preinitialise_cuda()+{+    CUresult status = cuInit (0);++    if ( status != CUDA_SUCCESS ) {+#if CUDA_VERSION >= 6000+        const char* str = NULL;++        cuGetErrorString(status, &str);+        fprintf(stderr, "Failed to pre-initialise CUDA: %s\n", str);+#else+        fprintf(stderr, "Failed to pre-initialise CUDA (%d)\n", status);+#endif+    }+}+

@@ -20,12 +20,6 @@     return cudaConfigureCall(gridDim, blockDim, sharedMem, stream); } -const char*-cudaGetErrorStringWrapper(cudaError_t error)-{-    return cudaGetErrorString(error);-}- CUresult cuTexRefSetAddress2DSimple (

@@ -12,12 +12,15 @@ #endif  #include <cuda.h>+#include <cudaProfiler.h> #include <cuda_runtime_api.h>  #ifdef __cplusplus extern "C" { #endif +void enable_constructors();+ cudaError_t cudaConfigureCallSimple (@@ -26,9 +29,6 @@     size_t sharedMem,     cudaStream_t stream );--const char*-cudaGetErrorStringWrapper(cudaError_t error);  CUresult cuTexRefSetAddress2DSimple

@@ -1,5 +1,5 @@ Name:                   cuda-Version:                0.7.0.0+Version:                0.7.5.0 Synopsis:               FFI binding to the CUDA interface for programming NVIDIA GPUs Description:     The CUDA library provides a direct, general purpose C-like SPMD programming@@ -10,45 +10,67 @@     .     <http://developer.nvidia.com/cuda-downloads>     .-    The configure script will look for your CUDA installation in the standard+    The setup script will look for your CUDA installation in the standard     places, and if the nvcc compiler is found in your PATH, relative to that.     .     This library provides bindings to both the CUDA Driver and Runtime APIs. To     get started, see one of:     .-    * "Foreign.CUDA.Driver"+    * "Foreign.CUDA.Driver" (a short tutorial is available here)     .     * "Foreign.CUDA.Runtime"     .-    This release tested with versions 6.0, 6.5, and 7.0 of the CUDA toolkit.+    This release tested with versions 6.0, 6.5, 7.0, and 7.5 of the CUDA toolkit.     .+    [/NOTES:/]+    .+    The setup script for this package requires at least Cabal-1.24. To upgrade,+    execute one of:+    .+    * cabal users: @cabal install Cabal --constraint="Cabal >= 1.24"@+    .+    * stack users: @stack setup --upgrade-cabal@+    .+    Due to an interaction between GHC-8 and unified virtual address spaces in+    CUDA, this package does not currently work with GHCi on ghc-8.0.1 (compiled+    programs should work). See the following for more details:+    .+    * <https://github.com/tmcdonell/cuda/issues/39>+    .+    * <https://ghc.haskell.org/trac/ghc/ticket/12573>+    .     For additional notes on installing on Windows, see:     .-    <https://github.com/tmcdonell/cuda/blob/master/WINDOWS.markdown>+    * <https://github.com/tmcdonell/cuda/blob/master/WINDOWS.markdown>     .  License:                BSD3 License-file:           LICENSE-Copyright:              Copyright (c) [2009..2015]. Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+Copyright:              Copyright (c) [2009..2016]. Trevor L. McDonell <tmcdonell@cse.unsw.edu.au> Author:                 Trevor L. McDonell <tmcdonell@cse.unsw.edu.au> Maintainer:             Trevor L. McDonell <tmcdonell@cse.unsw.edu.au> Homepage:               https://github.com/tmcdonell/cuda Bug-reports:            https://github.com/tmcdonell/cuda/issues Category:               Foreign-Cabal-version:          >= 1.22+Cabal-version:          >= 1.24 Tested-with:            GHC >= 7.6  Build-type:             Custom  Extra-tmp-files:        cuda.buildinfo.generated-                        config.status-                        config.log  Extra-source-files:     cbits/stubs.h                         CHANGELOG.markdown                         README.markdown                         WINDOWS.markdown +custom-setup+  setup-depends:+      base              >= 4.6+    , Cabal             >= 1.24+    , directory         >= 1.0+    , filepath          >= 1.0+ Library   Exposed-Modules:      Foreign.CUDA                         Foreign.CUDA.Ptr@@ -82,6 +104,7 @@                         Foreign.CUDA.Driver.Module.Base                         Foreign.CUDA.Driver.Module.Link                         Foreign.CUDA.Driver.Module.Query+                        Foreign.CUDA.Driver.Profiler                         Foreign.CUDA.Driver.Stream                         Foreign.CUDA.Driver.Texture                         Foreign.CUDA.Driver.Utils@@ -90,6 +113,7 @@    Include-dirs:         .   C-sources:            cbits/stubs.c+                        cbits/init.c    Build-tools:          c2hs >= 0.21   Build-depends:@@ -99,7 +123,12 @@    default-language:     Haskell98   Extensions:-  ghc-options:          -Wall -O2 -funbox-strict-fields -fwarn-tabs+  ghc-options:          -Wall+                        -O2+                        -funbox-strict-fields+                        -fwarn-tabs+                        -fno-warn-unused-imports+   ghc-prof-options:     -fprof-auto -fprof-cafs  @@ -115,7 +144,10 @@   default-language:     Haskell98  -source-repository head+source-repository this     type:               git     location:           https://github.com/tmcdonell/cuda+    tag:                0.7.5.0++-- vim: nospell