{-# LINE 1 "./Foreign/NVVM/Compile.chs" #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UnboxedTuples #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
module Foreign.NVVM.Compile (
Program,
Result(..),
CompileOption(..),
compileModule, compileModules,
create,
destroy,
addModule, addModuleFromPtr,
addModuleLazy, addModuleLazyFromPtr,
compile,
verify
) where
import qualified Foreign.C.Types as C2HSImp
import qualified Foreign.Ptr as C2HSImp
import Foreign.CUDA.Analysis
import Foreign.NVVM.Error
import Foreign.NVVM.Internal.C2HS
import Foreign.C
import Foreign.Marshal
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Storable
import Control.Exception
import Data.Word
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(..) )
{-# LINE 61 "./Foreign/NVVM/Compile.chs" #-}
newtype Program = Program { useProgram :: ((C2HSImp.Ptr ())) }
deriving ( Eq, Show )
data Result = Result
{ compileResult :: !ByteString
, compileLog :: !ByteString
}
data CompileOption
= OptimisationLevel !Int
| Target !Compute
| FlushToZero
| NoFMA
| FastSqrt
| FastDiv
| GenerateDebugInfo
deriving ( Eq, Show )
{-# INLINEABLE compileModule #-}
compileModule
:: ShortByteString
-> ByteString
-> [CompileOption]
-> IO Result
compileModule !name !bs !opts =
compileModules [(name,bs)] opts
{-# INLINEABLE compileModules #-}
compileModules
:: [(ShortByteString, ByteString)]
-> [CompileOption]
-> IO Result
compileModules !bss !opts =
bracket create destroy $ \prg -> do
mapM_ (uncurry (addModule prg)) bss
(messages, result) <- compile prg opts
case result of
Nothing -> nvvmErrorIO (B.unpack messages)
Just ptx -> return $ Result ptx messages
{-# INLINEABLE create #-}
create :: IO ((Program))
create =
alloca $ \a1' ->
create'_ a1' >>= \res ->
checkStatus res >>
peekProgram a1'>>= \a1'' ->
return (a1'')
{-# LINE 127 "./Foreign/NVVM/Compile.chs" #-}
{-# INLINEABLE destroy #-}
destroy :: (Program) -> IO ()
destroy a1 =
withProgram a1 $ \a1' ->
destroy'_ a1' >>= \res ->
checkStatus res >>
return ()
{-# LINE 140 "./Foreign/NVVM/Compile.chs" #-}
{-# INLINEABLE addModule #-}
addModule
:: Program
-> ShortByteString
-> ByteString
-> IO ()
addModule !prg !name !bs =
B.unsafeUseAsCStringLen bs $ \(ptr,len) ->
addModuleFromPtr prg name len (castPtr ptr)
{-# INLINEABLE addModuleFromPtr #-}
addModuleFromPtr
:: Program
-> ShortByteString
-> Int
-> Ptr Word8
-> IO ()
addModuleFromPtr !prg !name !size !buffer =
nvvmAddModuleToProgram prg buffer size name
where
nvvmAddModuleToProgram :: (Program) -> (Ptr Word8) -> (Int) -> (ShortByteString) -> IO ()
nvvmAddModuleToProgram a1 a2 a3 a4 =
let {a1' = useProgram a1} in
let {a2' = castPtr a2} in
let {a3' = cIntConv a3} in
useAsCString a4 $ \a4' ->
nvvmAddModuleToProgram'_ a1' a2' a3' a4' >>= \res ->
checkStatus res >>
return ()
{-# LINE 179 "./Foreign/NVVM/Compile.chs" #-}
{-# INLINEABLE addModuleLazy #-}
addModuleLazy
:: Program
-> ShortByteString
-> ByteString
-> IO ()
addModuleLazy !prg !name !bs =
B.unsafeUseAsCStringLen bs $ \(buffer, size) ->
addModuleLazyFromPtr prg name size (castPtr buffer)
{-# INLINEABLE addModuleLazyFromPtr #-}
addModuleLazyFromPtr
:: Program
-> ShortByteString
-> Int
-> Ptr Word8
-> IO ()
addModuleLazyFromPtr !prg !name !size !buffer =
nvvmLazyAddModuleToProgram prg buffer size name
where
nvvmLazyAddModuleToProgram :: (Program) -> (Ptr Word8) -> (Int) -> (ShortByteString) -> IO ()
nvvmLazyAddModuleToProgram a1 a2 a3 a4 =
let {a1' = useProgram a1} in
let {a2' = castPtr a2} in
let {a3' = cIntConv a3} in
useAsCString a4 $ \a4' ->
nvvmLazyAddModuleToProgram'_ a1' a2' a3' a4' >>= \res ->
checkStatus res >>
return ()
{-# LINE 238 "./Foreign/NVVM/Compile.chs" #-}
{-# INLINEABLE compile #-}
compile :: Program -> [CompileOption] -> IO (ByteString, Maybe ByteString)
compile !prg !opts = do
status <- withCompileOptions opts (nvvmCompileProgram prg)
messages <- retrieve (nvvmGetProgramLogSize prg) (nvvmGetProgramLog prg)
case status of
Success -> do ptx <- retrieve (nvvmGetCompiledResultSize prg) (nvvmGetCompiledResult prg)
return (messages, Just ptx)
_ -> return (messages, Nothing)
where
nvvmCompileProgram :: (Program) -> (Int) -> (Ptr CString) -> IO ((Status))
nvvmCompileProgram a1 a2 a3 =
let {a1' = useProgram a1} in
let {a2' = cIntConv a2} in
let {a3' = id a3} in
nvvmCompileProgram'_ a1' a2' a3' >>= \res ->
let {res' = cToEnum res} in
return (res')
{-# LINE 262 "./Foreign/NVVM/Compile.chs" #-}
nvvmGetCompiledResultSize :: (Program) -> IO ((Int))
nvvmGetCompiledResultSize a1 =
let {a1' = useProgram a1} in
alloca $ \a2' ->
nvvmGetCompiledResultSize'_ a1' a2' >>= \res ->
checkStatus res >>
peekIntConv a2'>>= \a2'' ->
return (a2'')
{-# LINE 269 "./Foreign/NVVM/Compile.chs" #-}
nvvmGetCompiledResult :: (Program) -> (ForeignPtr Word8) -> IO ()
nvvmGetCompiledResult a1 a2 =
let {a1' = useProgram a1} in
withForeignPtr' a2 $ \a2' ->
nvvmGetCompiledResult'_ a1' a2' >>= \res ->
checkStatus res >>
return ()
{-# LINE 276 "./Foreign/NVVM/Compile.chs" #-}
{-# INLINEABLE verify #-}
verify :: Program -> [CompileOption] -> IO (Status, ByteString)
verify !prg !opts = do
status <- withCompileOptions opts (nvvmVerifyProgram prg)
messages <- retrieve (nvvmGetProgramLogSize prg) (nvvmGetProgramLog prg)
return (status, messages)
where
nvvmVerifyProgram :: (Program) -> (Int) -> (Ptr CString) -> IO ((Status))
nvvmVerifyProgram a1 a2 a3 =
let {a1' = useProgram a1} in
let {a2' = cIntConv a2} in
let {a3' = id a3} in
nvvmVerifyProgram'_ a1' a2' a3' >>= \res ->
let {res' = cToEnum res} in
return (res')
{-# LINE 296 "./Foreign/NVVM/Compile.chs" #-}
nvvmGetProgramLogSize :: (Program) -> IO ((Int))
nvvmGetProgramLogSize a1 =
let {a1' = useProgram a1} in
alloca $ \a2' ->
nvvmGetProgramLogSize'_ a1' a2' >>= \res ->
checkStatus res >>
peekIntConv a2'>>= \a2'' ->
return (a2'')
{-# LINE 304 "./Foreign/NVVM/Compile.chs" #-}
nvvmGetProgramLog :: (Program) -> (ForeignPtr Word8) -> IO ()
nvvmGetProgramLog a1 a2 =
let {a1' = useProgram a1} in
withForeignPtr' a2 $ \a2' ->
nvvmGetProgramLog'_ a1' a2' >>= \res ->
checkStatus res >>
return ()
{-# LINE 311 "./Foreign/NVVM/Compile.chs" #-}
{-# INLINEABLE withForeignPtr' #-}
withForeignPtr' :: ForeignPtr Word8 -> (Ptr CChar -> IO a) -> IO a
withForeignPtr' fp f = withForeignPtr fp (f . castPtr)
{-# INLINEABLE withCompileOptions #-}
withCompileOptions :: [CompileOption] -> (Int -> Ptr CString -> IO a) -> IO a
withCompileOptions opts next =
withMany withCString (map toStr opts) $ \cs -> withArrayLen cs next
where
toStr :: CompileOption -> String
toStr (OptimisationLevel n) = printf "-opt=%d" n
toStr (Target (Compute n m)) = printf "-arch=compute_%d%d" n m
toStr FlushToZero = "-ftz=1"
toStr NoFMA = "-fma=0"
toStr FastSqrt = "-prec-sqrt=0"
toStr FastDiv = "-prec-div=0"
toStr GenerateDebugInfo = "-g"
{-# INLINEABLE retrieve #-}
retrieve :: IO Int -> (ForeignPtr Word8 -> IO ()) -> IO ByteString
retrieve size fill = do
bytes <- size
if bytes <= 1
then return B.empty
else do fp <- mallocForeignPtrBytes bytes
_ <- fill fp
return (B.fromForeignPtr fp 0 bytes)
{-# INLINEABLE peekProgram #-}
peekProgram :: Ptr ((C2HSImp.Ptr ())) -> IO Program
peekProgram p = Program `fmap` peek p
{-# INLINEABLE withProgram #-}
withProgram :: Program -> (Ptr ((C2HSImp.Ptr ())) -> IO a) -> IO a
withProgram p = with (useProgram p)
{-# 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 #)
}}}}}}}}
foreign import ccall unsafe "Foreign/NVVM/Compile.chs.h nvvmCreateProgram"
create'_ :: ((C2HSImp.Ptr (C2HSImp.Ptr ())) -> (IO C2HSImp.CInt))
foreign import ccall unsafe "Foreign/NVVM/Compile.chs.h nvvmDestroyProgram"
destroy'_ :: ((C2HSImp.Ptr (C2HSImp.Ptr ())) -> (IO C2HSImp.CInt))
foreign import ccall unsafe "Foreign/NVVM/Compile.chs.h nvvmAddModuleToProgram"
nvvmAddModuleToProgram'_ :: ((C2HSImp.Ptr ()) -> ((C2HSImp.Ptr C2HSImp.CChar) -> (C2HSImp.CULong -> ((C2HSImp.Ptr C2HSImp.CChar) -> (IO C2HSImp.CInt)))))
foreign import ccall unsafe "Foreign/NVVM/Compile.chs.h nvvmLazyAddModuleToProgram"
nvvmLazyAddModuleToProgram'_ :: ((C2HSImp.Ptr ()) -> ((C2HSImp.Ptr C2HSImp.CChar) -> (C2HSImp.CULong -> ((C2HSImp.Ptr C2HSImp.CChar) -> (IO C2HSImp.CInt)))))
foreign import ccall unsafe "Foreign/NVVM/Compile.chs.h nvvmCompileProgram"
nvvmCompileProgram'_ :: ((C2HSImp.Ptr ()) -> (C2HSImp.CInt -> ((C2HSImp.Ptr (C2HSImp.Ptr C2HSImp.CChar)) -> (IO C2HSImp.CInt))))
foreign import ccall unsafe "Foreign/NVVM/Compile.chs.h nvvmGetCompiledResultSize"
nvvmGetCompiledResultSize'_ :: ((C2HSImp.Ptr ()) -> ((C2HSImp.Ptr C2HSImp.CULong) -> (IO C2HSImp.CInt)))
foreign import ccall unsafe "Foreign/NVVM/Compile.chs.h nvvmGetCompiledResult"
nvvmGetCompiledResult'_ :: ((C2HSImp.Ptr ()) -> ((C2HSImp.Ptr C2HSImp.CChar) -> (IO C2HSImp.CInt)))
foreign import ccall unsafe "Foreign/NVVM/Compile.chs.h nvvmVerifyProgram"
nvvmVerifyProgram'_ :: ((C2HSImp.Ptr ()) -> (C2HSImp.CInt -> ((C2HSImp.Ptr (C2HSImp.Ptr C2HSImp.CChar)) -> (IO C2HSImp.CInt))))
foreign import ccall unsafe "Foreign/NVVM/Compile.chs.h nvvmGetProgramLogSize"
nvvmGetProgramLogSize'_ :: ((C2HSImp.Ptr ()) -> ((C2HSImp.Ptr C2HSImp.CULong) -> (IO C2HSImp.CInt)))
foreign import ccall unsafe "Foreign/NVVM/Compile.chs.h nvvmGetProgramLog"
nvvmGetProgramLog'_ :: ((C2HSImp.Ptr ()) -> ((C2HSImp.Ptr C2HSImp.CChar) -> (IO C2HSImp.CInt)))