diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,16 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/). +## [0.9.0.0] - 2018-10-02 +### Fixed + * Build fix for ghc-8.6 + +### Added + * `addModuleLazy` and `addModuleLazyFromPtr` from CUDA-10.0 + +### Changed + * Replace uses of `String` with `ShortByteString` + ## [0.8.0.3] - 2018-03-12 ### Fixed * Build fix for Cabal-2.2 (ghc-8.4) @@ -32,6 +42,7 @@ * First version. Released on an unsuspecting world. +[0.9.0.0]: https://github.com/tmcdonell/nvvm/compare/v0.8.0.3...v0.9.0.0 [0.8.0.3]: https://github.com/tmcdonell/nvvm/compare/v0.8.0.2...v0.8.0.3 [0.8.0.2]: https://github.com/tmcdonell/nvvm/compare/v0.8.0.1...v0.8.0.2 [0.8.0.1]: https://github.com/tmcdonell/nvvm/compare/v0.8.0.0...v0.8.0.1 diff --git a/Foreign/NVVM/Compile.chs b/Foreign/NVVM/Compile.chs --- a/Foreign/NVVM/Compile.chs +++ b/Foreign/NVVM/Compile.chs @@ -1,4 +1,9 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -------------------------------------------------------------------------------- -- | @@ -20,7 +25,8 @@ create, destroy, - addModule, addModuleFromPtr, + addModule, addModuleFromPtr, + addModuleLazy, addModuleLazyFromPtr, compile, verify @@ -38,13 +44,19 @@ import Control.Exception import Data.Word -import Data.ByteString ( ByteString ) import Text.Printf +import Data.ByteString ( ByteString ) +import Data.ByteString.Short ( ShortByteString ) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Unsafe as B import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Short as BS +import qualified Data.ByteString.Short.Internal as BSI +import GHC.Exts +import GHC.Base ( IO(..) ) + #include "cbits/stubs.h" {# context lib="nvvm" #} @@ -79,7 +91,7 @@ -- {-# INLINEABLE compileModule #-} compileModule - :: String -- ^ name of the module + :: ShortByteString -- ^ name of the module -> ByteString -- ^ NVVM IR in either textual or bitcode representation -> [CompileOption] -- ^ compiler options -> IO Result @@ -91,8 +103,8 @@ -- {-# INLINEABLE compileModules #-} compileModules - :: [(String, ByteString)] -- ^ (module name, module NVVM IR) pairs to compile - -> [CompileOption] -- ^ compiler options + :: [(ShortByteString, ByteString)] -- ^ (module name, module NVVM IR) pairs to compile + -> [CompileOption] -- ^ compiler options -> IO Result compileModules !bss !opts = bracket create destroy $ \prg -> do @@ -108,16 +120,11 @@ -- -- {-# INLINEABLE create #-} -create :: IO Program -create = resultIfOk =<< nvvmCreateProgram - where - peekProgram ptr = Program `fmap` peek ptr - {# - fun unsafe nvvmCreateProgram - { alloca- `Program' peekProgram* - } - -> `Status' cToEnum - #} +{# fun unsafe nvvmCreateProgram as create + { alloca- `Program' peekProgram* + } + -> `()' checkStatus*- +#} -- | Destroy a 'Program' @@ -125,16 +132,12 @@ -- -- {-# INLINEABLE destroy #-} -destroy :: Program -> IO () -destroy !prg = nothingIfOk =<< nvvmDestroyProgram prg - where - withProgram p = with (useProgram p) - {# - fun unsafe nvvmDestroyProgram - { withProgram* `Program' - } - -> `Status' cToEnum - #} +{# + fun unsafe nvvmDestroyProgram as destroy + { withProgram* `Program' + } + -> `()' checkStatus*- +#} -- | Add a module level NVVM IR to a program @@ -143,9 +146,9 @@ -- {-# INLINEABLE addModule #-} addModule - :: Program -- ^ NVVM program to add to - -> String -- ^ Name of the module (defaults to \"@\@\" if empty) - -> ByteString -- ^ NVVM IR module in either bitcode or textual representation + :: Program -- ^ NVVM program to add to + -> ShortByteString -- ^ Name of the module (defaults to \"@\@\" if empty) + -> ByteString -- ^ NVVM IR module in either bitcode or textual representation -> IO () addModule !prg !name !bs = B.unsafeUseAsCStringLen bs $ \(ptr,len) -> @@ -157,25 +160,84 @@ -- {-# INLINEABLE addModuleFromPtr #-} addModuleFromPtr - :: Program -- ^ NVVM program to add to - -> String -- ^ Name of the module (defaults to \"@\@\" if empty) - -> Int -- ^ Number of bytes in the module - -> Ptr Word8 -- ^ NVVM IR module in bitcode or textual representation + :: Program -- ^ NVVM program to add to + -> ShortByteString -- ^ Name of the module (defaults to \"@\@\" if empty) + -> Int -- ^ Number of bytes in the module + -> Ptr Word8 -- ^ NVVM IR module in bitcode or textual representation -> IO () addModuleFromPtr !prg !name !size !buffer = - nothingIfOk =<< nvvmAddModuleToProgram prg buffer size name + nvvmAddModuleToProgram prg buffer size name where {# fun unsafe nvvmAddModuleToProgram - { useProgram `Program' - , castPtr `Ptr Word8' - , cIntConv `Int' - , withCString* `String' + { useProgram `Program' + , castPtr `Ptr Word8' + , cIntConv `Int' + , useAsCString* `ShortByteString' } - -> `Status' cToEnum + -> `()' checkStatus*- #} +-- | Add a module level NVVM IR to a program. +-- +-- The module is loaded lazily: only symbols required by modules loaded using +-- 'addModule' or 'addModuleFromPtr' will be loaded. +-- +-- Requires CUDA-10.0 +-- +-- +-- +-- @since 0.9.0.0 +-- +{-# INLINEABLE addModuleLazy #-} +addModuleLazy + :: Program -- ^ NVVM program to add to + -> ShortByteString -- ^ Name of the module (defaults to \"@\@\" if empty) + -> ByteString -- ^ NVVM IR module in either bitcode or textual representation + -> IO () +#if CUDA_VERSION < 10000 +addModuleLazy = requireSDK 'addModuleLazy 10.0 +#else +addModuleLazy !prg !name !bs = + B.unsafeUseAsCStringLen bs $ \(buffer, size) -> + addModuleLazyFromPtr prg name size (castPtr buffer) +#endif + + +-- | As with 'addModuleLazy', but read the specified number of bytes from the +-- given pointer (the symbols are loaded lazily, the data in the buffer will be +-- read immediately). +-- +-- Requires CUDA-10.0 +-- +-- @since 0.9.0.0 +-- +{-# INLINEABLE addModuleLazyFromPtr #-} +addModuleLazyFromPtr + :: Program -- ^ NVVM program to add to + -> ShortByteString -- ^ Name of the module (defaults to \"@\@\" if empty) + -> Int -- ^ Number of bytes in the module + -> Ptr Word8 -- ^ NVVM IR in bitcode or textual representation + -> IO () +#if CUDA_VERSION < 10000 +addModuleLazyFromPtr = requireSDK 'addModuleLazyFromPtr 10.0 +#else +addModuleLazyFromPtr !prg !name !size !buffer = + nvvmLazyAddModuleToProgram prg buffer size name + where + {# + fun unsafe nvvmLazyAddModuleToProgram + { useProgram `Program' + , castPtr `Ptr Word8' + , cIntConv `Int' + , useAsCString* `ShortByteString' + } + -> `()' checkStatus*- + #} +#endif + + -- | Compile the NVVM program. Returns the log from the compiler/verifier and, -- if successful, the compiled program. -- @@ -203,14 +265,14 @@ { useProgram `Program' , alloca- `Int' peekIntConv* } - -> `Status' cToEnum + -> `()' checkStatus*- #} {# fun unsafe nvvmGetCompiledResult { useProgram `Program' , withForeignPtr'* `ForeignPtr Word8' } - -> `Status' cToEnum + -> `()' checkStatus*- #} @@ -238,14 +300,14 @@ { useProgram `Program' , alloca- `Int' peekIntConv* } - -> `Status' cToEnum + -> `()' checkStatus*- #} {# fun unsafe nvvmGetProgramLog { useProgram `Program' , withForeignPtr'* `ForeignPtr Word8' } - -> `Status' cToEnum + -> `()' checkStatus*- #} @@ -272,12 +334,40 @@ toStr GenerateDebugInfo = "-g" {-# INLINEABLE retrieve #-} -retrieve :: IO (Status, Int) -> (ForeignPtr Word8 -> IO Status) -> IO ByteString -retrieve size payload = do - bytes <- resultIfOk =<< size - if bytes <= 1 -- size includes NULL terminator +retrieve :: IO Int -> (ForeignPtr Word8 -> IO ()) -> IO ByteString +retrieve size fill = do + bytes <- size + if bytes <= 1 -- size includes NULL terminator then return B.empty else do fp <- mallocForeignPtrBytes bytes - _ <- nothingIfOk =<< payload fp + _ <- fill fp return (B.fromForeignPtr fp 0 bytes) + +{-# INLINEABLE peekProgram #-} +peekProgram :: Ptr {# type nvvmProgram #} -> IO Program +peekProgram p = Program `fmap` peek p + +{-# INLINEABLE withProgram #-} +withProgram :: Program -> (Ptr {# type nvvmProgram #} -> IO a) -> IO a +withProgram p = with (useProgram p) + + +-- [Short]ByteStrings are not null-terminated, so can't be passed directly to C. +-- +-- unsafeUseAsCString :: ShortByteString -> CString +-- unsafeUseAsCString (BI.SBS ba#) = Ptr (byteArrayContents# ba#) + +{-# INLINE useAsCString #-} +useAsCString :: ShortByteString -> (CString -> IO a) -> IO a +useAsCString (BSI.SBS ba#) action = IO $ \s0 -> + case sizeofByteArray# ba# of { n# -> + case newPinnedByteArray# (n# +# 1#) s0 of { (# s1, mba# #) -> + case byteArrayContents# (unsafeCoerce# mba#) of { addr# -> + case copyByteArrayToAddr# ba# 0# addr# n# s1 of { s2 -> + case writeWord8OffAddr# addr# n# 0## s2 of { s3 -> + case action (Ptr addr#) of { IO action' -> + case action' s3 of { (# s4, r #) -> + case touch# mba# s4 of { s5 -> + (# s5, r #) + }}}}}}}} diff --git a/Foreign/NVVM/Error.chs b/Foreign/NVVM/Error.chs --- a/Foreign/NVVM/Error.chs +++ b/Foreign/NVVM/Error.chs @@ -13,7 +13,7 @@ Status(..), describe, - resultIfOk, nothingIfOk, + resultIfOk, nothingIfOk, checkStatus, nvvmError, nvvmErrorIO, requireSDK, ) where @@ -113,4 +113,8 @@ case status of Success -> return () _ -> throwIO (ExitCode status) + +{-# INLINE checkStatus #-} +checkStatus :: CInt -> IO () +checkStatus = nothingIfOk . cToEnum diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -50,8 +50,8 @@ customBuildInfoFilePath :: FilePath customBuildInfoFilePath = "nvvm" <.> "buildinfo" -generatedBuldInfoFilePath :: FilePath -generatedBuldInfoFilePath = customBuildInfoFilePath <.> "generated" +generatedBuildInfoFilePath :: FilePath +generatedBuildInfoFilePath = customBuildInfoFilePath <.> "generated" -- Location of the NVVM library relative to the base CUDA installation -- @@ -125,7 +125,7 @@ compilerId_ = compilerId (compiler lbi) -- noExtraFlags args - generateAndStoreBuildInfo verbosity profile currentPlatform compilerId_ generatedBuldInfoFilePath + generateAndStoreBuildInfo verbosity profile currentPlatform compilerId_ generatedBuildInfoFilePath validateLinker verbosity currentPlatform $ withPrograms lbi -- actualBuildInfoToUse <- getHookedBuildInfo verbosity @@ -153,7 +153,11 @@ -- False -> [| head (componentLibraries (getComponentLocalBuildInfo lbi CLibName)) |] ) #endif - sharedLib = buildDir lbi mkSharedLibName cid uid +#if MIN_VERSION_Cabal(2,3,0) + sharedLib = buildDir lbi mkSharedLibName platform cid uid +#else + sharedLib = buildDir lbi mkSharedLibName cid uid +#endif Just extraLibDirs' = extraLibDirs . libBuildInfo <$> library pkg_descr -- updateLibraryRPATHs verbosity platform sharedLib extraLibDirs' @@ -202,14 +206,14 @@ notice verbosity $ printf "The user-provided buildinfo from file '%s' will be used. To use default settings, delete this file." customBuildInfoFilePath readHookedBuildInfo verbosity customBuildInfoFilePath else do - generatedBuildInfoExists <- doesFileExist generatedBuldInfoFilePath + generatedBuildInfoExists <- doesFileExist generatedBuildInfoFilePath if generatedBuildInfoExists then do - notice verbosity $ printf "Using build information from '%s'" generatedBuldInfoFilePath + notice verbosity $ printf "Using build information from '%s'" generatedBuildInfoFilePath notice verbosity $ printf "Provide a '%s' file to override this behaviour" customBuildInfoFilePath - readHookedBuildInfo verbosity generatedBuldInfoFilePath + readHookedBuildInfo verbosity generatedBuildInfoFilePath else - die' verbosity $ printf "Unexpected failure: neither the default '%s' nor custom '%s' exist" generatedBuldInfoFilePath customBuildInfoFilePath + die' verbosity $ printf "Unexpected failure: neither the default '%s' nor custom '%s' exist" generatedBuildInfoFilePath customBuildInfoFilePath -- Runs CUDA detection procedure and stores .buildinfo to a file. diff --git a/nvvm.cabal b/nvvm.cabal --- a/nvvm.cabal +++ b/nvvm.cabal @@ -1,5 +1,5 @@ name: nvvm -version: 0.8.0.3 +version: 0.9.0.0 synopsis: FFI bindings to NVVM description: The NVVM library compiles NVVM IR (a subset of LLVM IR) into PTX code which @@ -23,8 +23,8 @@ license: BSD3 license-file: LICENSE homepage: https://github.com/tmcdonell/nvvm -author: Trevor L. McDonell -maintainer: Trevor L. McDonell +author: Trevor L. McDonell +maintainer: Trevor L. McDonell copyright: [2016] Trevor L. McDonell category: Foreign build-type: Custom @@ -83,7 +83,7 @@ source-repository this type: git location: https://github.com/tmcdonell/nvvm - tag: v0.8.0.3 + tag: v0.9.0.0 -- vim: nospell