diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -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 diff --git a/Foreign/CUDA/Analysis/Device.chs b/Foreign/CUDA/Analysis/Device.chs --- a/Foreign/CUDA/Analysis/Device.chs +++ b/Foreign/CUDA/Analysis/Device.chs @@ -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 diff --git a/Foreign/CUDA/Analysis/Occupancy.hs b/Foreign/CUDA/Analysis/Occupancy.hs --- a/Foreign/CUDA/Analysis/Occupancy.hs +++ b/Foreign/CUDA/Analysis/Occupancy.hs @@ -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 diff --git a/Foreign/CUDA/Driver/Context/Config.chs b/Foreign/CUDA/Driver/Context/Config.chs --- a/Foreign/CUDA/Driver/Context/Config.chs +++ b/Foreign/CUDA/Driver/Context/Config.chs @@ -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 -- -- -- {-# 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 -- -- -- {-# 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 diff --git a/Foreign/CUDA/Driver/Device.chs b/Foreign/CUDA/Driver/Device.chs --- a/Foreign/CUDA/Driver/Device.chs +++ b/Foreign/CUDA/Driver/Device.chs @@ -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 diff --git a/Foreign/CUDA/Driver/Error.chs b/Foreign/CUDA/Driver/Error.chs --- a/Foreign/CUDA/Driver/Error.chs +++ b/Foreign/CUDA/Driver/Error.chs @@ -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 diff --git a/Foreign/CUDA/Driver/IPC/Event.chs b/Foreign/CUDA/Driver/IPC/Event.chs --- a/Foreign/CUDA/Driver/IPC/Event.chs +++ b/Foreign/CUDA/Driver/IPC/Event.chs @@ -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 diff --git a/Foreign/CUDA/Driver/IPC/Marshal.chs b/Foreign/CUDA/Driver/IPC/Marshal.chs --- a/Foreign/CUDA/Driver/IPC/Marshal.chs +++ b/Foreign/CUDA/Driver/IPC/Marshal.chs @@ -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. -- -- -- {-# 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. -- -- -- {-# 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. -- -- -- {-# 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 diff --git a/Foreign/CUDA/Driver/Marshal.chs b/Foreign/CUDA/Driver/Marshal.chs --- a/Foreign/CUDA/Driver/Marshal.chs +++ b/Foreign/CUDA/Driver/Marshal.chs @@ -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. diff --git a/Foreign/CUDA/Driver/Module/Base.chs b/Foreign/CUDA/Driver/Module/Base.chs --- a/Foreign/CUDA/Driver/Module/Base.chs +++ b/Foreign/CUDA/Driver/Module/Base.chs @@ -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 diff --git a/Foreign/CUDA/Driver/Module/Link.chs b/Foreign/CUDA/Driver/Module/Link.chs --- a/Foreign/CUDA/Driver/Module/Link.chs +++ b/Foreign/CUDA/Driver/Module/Link.chs @@ -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 diff --git a/Foreign/CUDA/Driver/Profiler.chs b/Foreign/CUDA/Driver/Profiler.chs new file mode 100644 --- /dev/null +++ b/Foreign/CUDA/Driver/Profiler.chs @@ -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. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# INLINEABLE stop #-} +stop :: IO () +stop = nothingIfOk =<< cuProfilerStop + +{-# INLINE cuProfilerStop #-} +{# fun unsafe cuProfilerStop + { } -> `Status' cToEnum #} + diff --git a/Foreign/CUDA/Runtime/Error.chs b/Foreign/CUDA/Runtime/Error.chs --- a/Foreign/CUDA/Runtime/Error.chs +++ b/Foreign/CUDA/Runtime/Error.chs @@ -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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 diff --git a/cbits/init.c b/cbits/init.c new file mode 100644 --- /dev/null +++ b/cbits/init.c @@ -0,0 +1,52 @@ +#include "cbits/stubs.h" +#include + +/* + * 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 + } +} + diff --git a/cbits/stubs.c b/cbits/stubs.c --- a/cbits/stubs.c +++ b/cbits/stubs.c @@ -20,12 +20,6 @@ return cudaConfigureCall(gridDim, blockDim, sharedMem, stream); } -const char* -cudaGetErrorStringWrapper(cudaError_t error) -{ - return cudaGetErrorString(error); -} - CUresult cuTexRefSetAddress2DSimple ( diff --git a/cbits/stubs.h b/cbits/stubs.h --- a/cbits/stubs.h +++ b/cbits/stubs.h @@ -12,12 +12,15 @@ #endif #include +#include #include #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 diff --git a/cuda.cabal b/cuda.cabal --- a/cuda.cabal +++ b/cuda.cabal @@ -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 @@ . . - 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: + . + * + . + * + . For additional notes on installing on Windows, see: . - + * . License: BSD3 License-file: LICENSE -Copyright: Copyright (c) [2009..2015]. Trevor L. McDonell +Copyright: Copyright (c) [2009..2016]. Trevor L. McDonell Author: Trevor L. McDonell Maintainer: Trevor L. McDonell 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