{-# LINE 1 "src/Foreign/CUDA/Driver/Context/Base.chs" #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE EmptyCase #-}
module Foreign.CUDA.Driver.Context.Base (
Context(..), ContextFlag(..),
create, destroy, device, pop, push, sync, get, set,
attach, detach,
) where
import qualified Foreign.C.Types as C2HSImp
import qualified Foreign.Ptr as C2HSImp
{-# LINE 31 "src/Foreign/CUDA/Driver/Context/Base.chs" #-}
import Foreign.CUDA.Driver.Device ( Device(..) )
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Internal.C2HS
import Foreign
import Foreign.C
import Control.Monad ( liftM )
newtype Context = Context { Context -> Ptr ()
useContext :: ((C2HSImp.Ptr ()))}
deriving (Context -> Context -> Bool
(Context -> Context -> Bool)
-> (Context -> Context -> Bool) -> Eq Context
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Context -> Context -> Bool
== :: Context -> Context -> Bool
$c/= :: Context -> Context -> Bool
/= :: Context -> Context -> Bool
Eq, Int -> Context -> ShowS
[Context] -> ShowS
Context -> String
(Int -> Context -> ShowS)
-> (Context -> String) -> ([Context] -> ShowS) -> Show Context
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Context -> ShowS
showsPrec :: Int -> Context -> ShowS
$cshow :: Context -> String
show :: Context -> String
$cshowList :: [Context] -> ShowS
showList :: [Context] -> ShowS
Show)
data ContextFlag = SchedAuto
| SchedSpin
| SchedYield
| SchedBlockingSync
| BlockingSync
| SchedMask
| MapHost
| LmemResizeToMax
| FlagsMask
deriving (ContextFlag -> ContextFlag -> Bool
(ContextFlag -> ContextFlag -> Bool)
-> (ContextFlag -> ContextFlag -> Bool) -> Eq ContextFlag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ContextFlag -> ContextFlag -> Bool
== :: ContextFlag -> ContextFlag -> Bool
$c/= :: ContextFlag -> ContextFlag -> Bool
/= :: ContextFlag -> ContextFlag -> Bool
Eq,Int -> ContextFlag -> ShowS
[ContextFlag] -> ShowS
ContextFlag -> String
(Int -> ContextFlag -> ShowS)
-> (ContextFlag -> String)
-> ([ContextFlag] -> ShowS)
-> Show ContextFlag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ContextFlag -> ShowS
showsPrec :: Int -> ContextFlag -> ShowS
$cshow :: ContextFlag -> String
show :: ContextFlag -> String
$cshowList :: [ContextFlag] -> ShowS
showList :: [ContextFlag] -> ShowS
Show,ContextFlag
ContextFlag -> ContextFlag -> Bounded ContextFlag
forall a. a -> a -> Bounded a
$cminBound :: ContextFlag
minBound :: ContextFlag
$cmaxBound :: ContextFlag
maxBound :: ContextFlag
Bounded)
instance Enum ContextFlag where
succ :: ContextFlag -> ContextFlag
succ ContextFlag
SchedAuto = ContextFlag
SchedSpin
succ ContextFlag
SchedSpin = ContextFlag
SchedYield
succ ContextFlag
SchedYield = ContextFlag
SchedBlockingSync
succ ContextFlag
SchedBlockingSync = ContextFlag
SchedMask
succ ContextFlag
BlockingSync = ContextFlag
SchedMask
succ ContextFlag
SchedMask = ContextFlag
MapHost
succ ContextFlag
MapHost = ContextFlag
LmemResizeToMax
succ ContextFlag
LmemResizeToMax = ContextFlag
FlagsMask
succ ContextFlag
FlagsMask = String -> ContextFlag
forall a. HasCallStack => String -> a
error String
"ContextFlag.succ: FlagsMask has no successor"
pred :: ContextFlag -> ContextFlag
pred ContextFlag
SchedSpin = ContextFlag
SchedAuto
pred SchedYield = SchedSpin
pred SchedBlockingSync = SchedYield
pred BlockingSync = SchedYield
pred ContextFlag
SchedMask = ContextFlag
SchedBlockingSync
pred MapHost = SchedMask
pred LmemResizeToMax = MapHost
pred ContextFlag
FlagsMask = ContextFlag
LmemResizeToMax
pred ContextFlag
SchedAuto = String -> ContextFlag
forall a. HasCallStack => String -> a
error String
"ContextFlag.pred: SchedAuto has no predecessor"
enumFromTo :: ContextFlag -> ContextFlag -> [ContextFlag]
enumFromTo ContextFlag
from ContextFlag
to = ContextFlag -> [ContextFlag]
forall {t}. Enum t => t -> [t]
go ContextFlag
from
where
end :: Int
end = ContextFlag -> Int
forall a. Enum a => a -> Int
fromEnum ContextFlag
to
go :: t -> [t]
go t
v = case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (t -> Int
forall a. Enum a => a -> Int
fromEnum t
v) Int
end of
Ordering
LT -> t
v t -> [t] -> [t]
forall a. a -> [a] -> [a]
: t -> [t]
go (t -> t
forall a. Enum a => a -> a
succ t
v)
Ordering
EQ -> [t
v]
Ordering
GT -> []
enumFrom :: ContextFlag -> [ContextFlag]
enumFrom ContextFlag
from = ContextFlag -> ContextFlag -> [ContextFlag]
forall a. Enum a => a -> a -> [a]
enumFromTo ContextFlag
from ContextFlag
FlagsMask
fromEnum SchedAuto = 0
fromEnum SchedSpin = 1
fromEnum SchedYield = 2
fromEnum SchedBlockingSync = 4
fromEnum BlockingSync = 4
fromEnum SchedMask = 7
fromEnum MapHost = 8
fromEnum LmemResizeToMax = 16
fromEnum FlagsMask = 31
toEnum 0 = SchedAuto
toEnum 1 = SchedSpin
toEnum 2 = SchedYield
toEnum 4 = SchedBlockingSync
toEnum 7 = SchedMask
toEnum 8 = MapHost
toEnum 16 = LmemResizeToMax
toEnum 31 = FlagsMask
toEnum unmatched = error ("ContextFlag.toEnum: Cannot match " ++ show unmatched)
{-# LINE 60 "src/Foreign/CUDA/Driver/Context/Base.chs" #-}
{-# DEPRECATED attach, detach "as of CUDA-4.0" #-}
{-# DEPRECATED BlockingSync "use SchedBlockingSync instead" #-}
{-# INLINEABLE create #-}
create :: Device -> [ContextFlag] -> IO Context
create !dev !flags = resultIfOk =<< cuCtxCreate flags dev
{-# INLINE cuCtxCreate #-}
cuCtxCreate :: ([ContextFlag]) -> (Device) -> IO ((Status), (Context))
cuCtxCreate a2 a3 =
alloca $ \a1' ->
let {a2' = combineBitMasks a2} in
let {a3' = useDevice a3} in
cuCtxCreate'_ a1' a2' a3' >>= \res ->
let {res' = cToEnum res} in
peekCtx a1'>>= \a1'' ->
return (res', a1'')
{-# LINE 90 "src/Foreign/CUDA/Driver/Context/Base.chs" #-}
where peekCtx = liftM Context . peek
{-# INLINEABLE attach #-}
attach :: Context -> [ContextFlag] -> IO ()
attach !ctx !flags = nothingIfOk =<< cuCtxAttach ctx flags
{-# INLINE cuCtxAttach #-}
cuCtxAttach :: (Context) -> ([ContextFlag]) -> IO ((Status))
cuCtxAttach a1 a2 =
withCtx a1 $ \a1' ->
let {a2' = combineBitMasks a2} in
cuCtxAttach'_ a1' a2' >>= \res ->
let {res' = cToEnum res} in
return (res')
{-# LINE 105 "src/Foreign/CUDA/Driver/Context/Base.chs" #-}
where withCtx = with . useContext
{-# INLINEABLE detach #-}
detach :: Context -> IO ()
detach !ctx = nothingIfOk =<< cuCtxDetach ctx
{-# INLINE cuCtxDetach #-}
cuCtxDetach :: (Context) -> IO ((Status))
cuCtxDetach a1 =
let {a1' = useContext a1} in
cuCtxDetach'_ a1' >>= \res ->
let {res' = cToEnum res} in
return (res')
{-# LINE 118 "src/Foreign/CUDA/Driver/Context/Base.chs" #-}
{-# INLINEABLE destroy #-}
destroy :: Context -> IO ()
destroy :: Context -> IO ()
destroy !Context
ctx = Status -> IO ()
nothingIfOk (Status -> IO ()) -> IO Status -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Context -> IO Status
cuCtxDestroy Context
ctx
{-# INLINE cuCtxDestroy #-}
cuCtxDestroy :: (Context) -> IO ((Status))
cuCtxDestroy :: Context -> IO Status
cuCtxDestroy Context
a1 =
let {a1' :: Ptr ()
a1' = Context -> Ptr ()
useContext Context
a1} in
Ptr () -> IO CInt
cuCtxDestroy'_ Ptr ()
a1' IO CInt -> (CInt -> IO Status) -> IO Status
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CInt
res ->
let {res' :: Status
res' = CInt -> Status
forall i e. (Integral i, Enum e) => i -> e
cToEnum CInt
res} in
Status -> IO Status
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Status
res')
{-# LINE 136 "src/Foreign/CUDA/Driver/Context/Base.chs" #-}
{-# INLINEABLE get #-}
get :: IO (Maybe Context)
get :: IO (Maybe Context)
get = (Status, Maybe Context) -> IO (Maybe Context)
forall a. (Status, a) -> IO a
resultIfOk ((Status, Maybe Context) -> IO (Maybe Context))
-> IO (Status, Maybe Context) -> IO (Maybe Context)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Status, Maybe Context)
cuCtxGetCurrent
{-# INLINE cuCtxGetCurrent #-}
cuCtxGetCurrent :: IO ((Status), (Maybe Context))
cuCtxGetCurrent :: IO (Status, Maybe Context)
cuCtxGetCurrent =
(Ptr (Ptr ()) -> IO (Status, Maybe Context))
-> IO (Status, Maybe Context)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr (Ptr ()) -> IO (Status, Maybe Context))
-> IO (Status, Maybe Context))
-> (Ptr (Ptr ()) -> IO (Status, Maybe Context))
-> IO (Status, Maybe Context)
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr ())
a1' ->
Ptr (Ptr ()) -> IO CInt
cuCtxGetCurrent'_ Ptr (Ptr ())
a1' IO CInt
-> (CInt -> IO (Status, Maybe Context))
-> IO (Status, Maybe Context)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CInt
res ->
let {res' :: Status
res' = CInt -> Status
forall i e. (Integral i, Enum e) => i -> e
cToEnum CInt
res} in
Ptr (Ptr ()) -> IO (Maybe Context)
peekCtx Ptr (Ptr ())
a1'IO (Maybe Context)
-> (Maybe Context -> IO (Status, Maybe Context))
-> IO (Status, Maybe Context)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe Context
a1'' ->
(Status, Maybe Context) -> IO (Status, Maybe Context)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Status
res', Maybe Context
a1'')
{-# LINE 155 "src/Foreign/CUDA/Driver/Context/Base.chs" #-}
where peekCtx = liftM (nothingIfNull Context) . peek
{-# INLINEABLE set #-}
set :: Context -> IO ()
set :: Context -> IO ()
set !Context
ctx = Status -> IO ()
nothingIfOk (Status -> IO ()) -> IO Status -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Context -> IO Status
cuCtxSetCurrent Context
ctx
{-# INLINE cuCtxSetCurrent #-}
cuCtxSetCurrent :: (Context) -> IO ((Status))
cuCtxSetCurrent :: Context -> IO Status
cuCtxSetCurrent Context
a1 =
let {a1' :: Ptr ()
a1' = Context -> Ptr ()
useContext Context
a1} in
Ptr () -> IO CInt
cuCtxSetCurrent'_ Ptr ()
a1' IO CInt -> (CInt -> IO Status) -> IO Status
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CInt
res ->
let {res' :: Status
res' = CInt -> Status
forall i e. (Integral i, Enum e) => i -> e
cToEnum CInt
res} in
Status -> IO Status
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Status
res')
{-# LINE 177 "src/Foreign/CUDA/Driver/Context/Base.chs" #-}
{-# INLINEABLE device #-}
device :: IO Device
device :: IO Device
device = (Status, Device) -> IO Device
forall a. (Status, a) -> IO a
resultIfOk ((Status, Device) -> IO Device) -> IO (Status, Device) -> IO Device
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Status, Device)
cuCtxGetDevice
{-# INLINE cuCtxGetDevice #-}
cuCtxGetDevice :: IO ((Status), (Device))
cuCtxGetDevice :: IO (Status, Device)
cuCtxGetDevice =
(Ptr CInt -> IO (Status, Device)) -> IO (Status, Device)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO (Status, Device)) -> IO (Status, Device))
-> (Ptr CInt -> IO (Status, Device)) -> IO (Status, Device)
forall a b. (a -> b) -> a -> b
$ \a1' ->
Ptr CInt -> IO CInt
cuCtxGetDevice'_ Ptr CInt
a1' IO CInt -> (CInt -> IO (Status, Device)) -> IO (Status, Device)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CInt
res ->
let {res' :: Status
res' = CInt -> Status
forall i e. (Integral i, Enum e) => i -> e
cToEnum CInt
res} in
Ptr CInt -> IO Device
dev Ptr CInt
a1'IO Device -> (Device -> IO (Status, Device)) -> IO (Status, Device)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Device
a1'' ->
(Status, Device) -> IO (Status, Device)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Status
res', Device
a1'')
{-# LINE 191 "src/Foreign/CUDA/Driver/Context/Base.chs" #-}
where dev = liftM Device . peekIntConv
{-# INLINEABLE pop #-}
pop :: IO Context
pop :: IO Context
pop = (Status, Context) -> IO Context
forall a. (Status, a) -> IO a
resultIfOk ((Status, Context) -> IO Context)
-> IO (Status, Context) -> IO Context
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Status, Context)
cuCtxPopCurrent
{-# INLINE cuCtxPopCurrent #-}
cuCtxPopCurrent :: IO ((Status), (Context))
cuCtxPopCurrent :: IO (Status, Context)
cuCtxPopCurrent =
(Ptr (Ptr ()) -> IO (Status, Context)) -> IO (Status, Context)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr (Ptr ()) -> IO (Status, Context)) -> IO (Status, Context))
-> (Ptr (Ptr ()) -> IO (Status, Context)) -> IO (Status, Context)
forall a b. (a -> b) -> a -> b
$ \a1' ->
Ptr (Ptr ()) -> IO CInt
cuCtxPopCurrent'_ Ptr (Ptr ())
a1' IO CInt -> (CInt -> IO (Status, Context)) -> IO (Status, Context)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CInt
res ->
let {res' :: Status
res' = CInt -> Status
forall i e. (Integral i, Enum e) => i -> e
cToEnum CInt
res} in
Ptr (Ptr ()) -> IO Context
peekCtx Ptr (Ptr ())
a1'IO Context
-> (Context -> IO (Status, Context)) -> IO (Status, Context)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Context
a1'' ->
(Status, Context) -> IO (Status, Context)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Status
res', Context
a1'')
{-# LINE 207 "src/Foreign/CUDA/Driver/Context/Base.chs" #-}
where peekCtx = liftM Context . peek
{-# INLINEABLE push #-}
push :: Context -> IO ()
push :: Context -> IO ()
push !Context
ctx = Status -> IO ()
nothingIfOk (Status -> IO ()) -> IO Status -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Context -> IO Status
cuCtxPushCurrent Context
ctx
{-# INLINE cuCtxPushCurrent #-}
cuCtxPushCurrent :: (Context) -> IO ((Status))
cuCtxPushCurrent :: Context -> IO Status
cuCtxPushCurrent Context
a1 =
let {a1' :: Ptr ()
a1' = Context -> Ptr ()
useContext Context
a1} in
Ptr () -> IO CInt
cuCtxPushCurrent'_ Ptr ()
a1' IO CInt -> (CInt -> IO Status) -> IO Status
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CInt
res ->
let {res' :: Status
res' = CInt -> Status
forall i e. (Integral i, Enum e) => i -> e
cToEnum CInt
res} in
Status -> IO Status
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Status
res')
{-# LINE 224 "src/Foreign/CUDA/Driver/Context/Base.chs" #-}
{-# INLINEABLE sync #-}
sync :: IO ()
sync :: IO ()
sync = Status -> IO ()
nothingIfOk (Status -> IO ()) -> IO Status -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Status
cuCtxSynchronize
{-# INLINE cuCtxSynchronize #-}
cuCtxSynchronize :: IO ((Status))
cuCtxSynchronize :: IO Status
cuCtxSynchronize =
IO CInt
cuCtxSynchronize'_ IO CInt -> (CInt -> IO Status) -> IO Status
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CInt
res ->
let {res' :: Status
res' = CInt -> Status
forall i e. (Integral i, Enum e) => i -> e
cToEnum CInt
res} in
Status -> IO Status
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Status
res')
{-# LINE 240 "src/Foreign/CUDA/Driver/Context/Base.chs" #-}
foreign import ccall unsafe "Foreign/CUDA/Driver/Context/Base.chs.h cuCtxCreate"
cuCtxCreate'_ :: ((C2HSImp.Ptr (C2HSImp.Ptr ())) -> (C2HSImp.CUInt -> (C2HSImp.CInt -> (IO C2HSImp.CInt))))
foreign import ccall unsafe "Foreign/CUDA/Driver/Context/Base.chs.h cuCtxAttach"
cuCtxAttach'_ :: ((C2HSImp.Ptr (C2HSImp.Ptr ())) -> (C2HSImp.CUInt -> (IO C2HSImp.CInt)))
foreign import ccall unsafe "Foreign/CUDA/Driver/Context/Base.chs.h cuCtxDetach"
cuCtxDetach'_ :: ((C2HSImp.Ptr ()) -> (IO C2HSImp.CInt))
foreign import ccall unsafe "Foreign/CUDA/Driver/Context/Base.chs.h cuCtxDestroy"
cuCtxDestroy'_ :: ((C2HSImp.Ptr ()) -> (IO C2HSImp.CInt))
foreign import ccall unsafe "Foreign/CUDA/Driver/Context/Base.chs.h cuCtxGetCurrent"
cuCtxGetCurrent'_ :: ((C2HSImp.Ptr (C2HSImp.Ptr ())) -> (IO C2HSImp.CInt))
foreign import ccall unsafe "Foreign/CUDA/Driver/Context/Base.chs.h cuCtxSetCurrent"
cuCtxSetCurrent'_ :: ((C2HSImp.Ptr ()) -> (IO C2HSImp.CInt))
foreign import ccall unsafe "Foreign/CUDA/Driver/Context/Base.chs.h cuCtxGetDevice"
cuCtxGetDevice'_ :: ((C2HSImp.Ptr C2HSImp.CInt) -> (IO C2HSImp.CInt))
foreign import ccall unsafe "Foreign/CUDA/Driver/Context/Base.chs.h cuCtxPopCurrent"
cuCtxPopCurrent'_ :: ((C2HSImp.Ptr (C2HSImp.Ptr ())) -> (IO C2HSImp.CInt))
foreign import ccall unsafe "Foreign/CUDA/Driver/Context/Base.chs.h cuCtxPushCurrent"
cuCtxPushCurrent'_ :: ((C2HSImp.Ptr ()) -> (IO C2HSImp.CInt))
foreign import ccall safe "Foreign/CUDA/Driver/Context/Base.chs.h cuCtxSynchronize"
cuCtxSynchronize'_ :: (IO C2HSImp.CInt)