{-# LINE 1 "src/Foreign/CUDA/Driver/Unified.chs" #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_HADDOCK prune #-}
module Foreign.CUDA.Driver.Unified (
PointerAttributes(..), MemoryType(..),
getAttributes,
Advice(..),
setSyncMemops,
advise,
) where
import qualified Foreign.C.Types as C2HSImp
import qualified Foreign.Ptr as C2HSImp
{-# LINE 96 "src/Foreign/CUDA/Driver/Unified.chs" #-}
import Foreign.CUDA.Driver.Context
import Foreign.CUDA.Driver.Device
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Driver.Marshal
import Foreign.CUDA.Internal.C2HS
import Foreign.CUDA.Ptr
import Control.Applicative
import Control.Monad
import Data.Maybe
import Foreign
import Foreign.C
import Foreign.Storable
import Prelude
data PointerAttributes a = PointerAttributes
{ PointerAttributes a -> Context
ptrContext :: {-# UNPACK #-} !Context
, PointerAttributes a -> DevicePtr a
ptrDevice :: {-# UNPACK #-} !(DevicePtr a)
, PointerAttributes a -> HostPtr a
ptrHost :: {-# UNPACK #-} !(HostPtr a)
, PointerAttributes a -> CULLong
ptrBufferID :: {-# UNPACK #-} !CULLong
, PointerAttributes a -> MemoryType
ptrMemoryType :: !MemoryType
, PointerAttributes a -> Bool
ptrSyncMemops :: !Bool
, PointerAttributes a -> Bool
ptrIsManaged :: !Bool
}
deriving Int -> PointerAttributes a -> ShowS
[PointerAttributes a] -> ShowS
PointerAttributes a -> String
(Int -> PointerAttributes a -> ShowS)
-> (PointerAttributes a -> String)
-> ([PointerAttributes a] -> ShowS)
-> Show (PointerAttributes a)
forall a. Int -> PointerAttributes a -> ShowS
forall a. [PointerAttributes a] -> ShowS
forall a. PointerAttributes a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PointerAttributes a] -> ShowS
$cshowList :: forall a. [PointerAttributes a] -> ShowS
show :: PointerAttributes a -> String
$cshow :: forall a. PointerAttributes a -> String
showsPrec :: Int -> PointerAttributes a -> ShowS
$cshowsPrec :: forall a. Int -> PointerAttributes a -> ShowS
Show
data MemoryType = HostMemory
| DeviceMemory
| ArrayMemory
| UnifiedMemory
deriving (MemoryType -> MemoryType -> Bool
(MemoryType -> MemoryType -> Bool)
-> (MemoryType -> MemoryType -> Bool) -> Eq MemoryType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MemoryType -> MemoryType -> Bool
$c/= :: MemoryType -> MemoryType -> Bool
== :: MemoryType -> MemoryType -> Bool
$c== :: MemoryType -> MemoryType -> Bool
Eq,Int -> MemoryType -> ShowS
[MemoryType] -> ShowS
MemoryType -> String
(Int -> MemoryType -> ShowS)
-> (MemoryType -> String)
-> ([MemoryType] -> ShowS)
-> Show MemoryType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MemoryType] -> ShowS
$cshowList :: [MemoryType] -> ShowS
show :: MemoryType -> String
$cshow :: MemoryType -> String
showsPrec :: Int -> MemoryType -> ShowS
$cshowsPrec :: Int -> MemoryType -> ShowS
Show,MemoryType
MemoryType -> MemoryType -> Bounded MemoryType
forall a. a -> a -> Bounded a
maxBound :: MemoryType
$cmaxBound :: MemoryType
minBound :: MemoryType
$cminBound :: MemoryType
Bounded)
instance Enum MemoryType where
succ :: MemoryType -> MemoryType
succ MemoryType
HostMemory = MemoryType
DeviceMemory
succ MemoryType
DeviceMemory = MemoryType
ArrayMemory
succ MemoryType
ArrayMemory = MemoryType
UnifiedMemory
succ MemoryType
UnifiedMemory = String -> MemoryType
forall a. HasCallStack => String -> a
error String
"MemoryType.succ: UnifiedMemory has no successor"
pred :: MemoryType -> MemoryType
pred MemoryType
DeviceMemory = MemoryType
HostMemory
pred MemoryType
ArrayMemory = MemoryType
DeviceMemory
pred MemoryType
UnifiedMemory = MemoryType
ArrayMemory
pred MemoryType
HostMemory = String -> MemoryType
forall a. HasCallStack => String -> a
error String
"MemoryType.pred: HostMemory has no predecessor"
enumFromTo :: MemoryType -> MemoryType -> [MemoryType]
enumFromTo MemoryType
from MemoryType
to = MemoryType -> [MemoryType]
forall t. Enum t => t -> [t]
go MemoryType
from
where
end :: Int
end = MemoryType -> Int
forall a. Enum a => a -> Int
fromEnum MemoryType
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 :: MemoryType -> [MemoryType]
enumFrom MemoryType
from = MemoryType -> MemoryType -> [MemoryType]
forall a. Enum a => a -> a -> [a]
enumFromTo MemoryType
from MemoryType
UnifiedMemory
fromEnum HostMemory = 1
fromEnum DeviceMemory = 2
fromEnum ArrayMemory = 3
fromEnum UnifiedMemory = 4
toEnum :: Int -> MemoryType
toEnum Int
1 = MemoryType
HostMemory
toEnum 2 = DeviceMemory
toEnum 3 = ArrayMemory
toEnum Int
4 = MemoryType
UnifiedMemory
toEnum Int
unmatched = String -> MemoryType
forall a. HasCallStack => String -> a
error (String
"MemoryType.toEnum: Cannot match " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
unmatched)
{-# LINE 139 "src/Foreign/CUDA/Driver/Unified.chs" #-}
data PointerAttribute = AttributeContext
| AttributeMemoryType
| AttributeDevicePointer
| AttributeHostPointer
| AttributeP2pTokens
| AttributeSyncMemops
| AttributeBufferId
| AttributeIsManaged
| AttributeDeviceOrdinal
| AttributeIsLegacyCudaIpcCapable
| AttributeRangeStartAddr
| AttributeRangeSize
| AttributeMapped
| AttributeAllowedHandleTypes
deriving (Eq,Show,Bounded)
instance Enum PointerAttribute where
succ AttributeContext = AttributeMemoryType
succ AttributeMemoryType = AttributeDevicePointer
succ AttributeDevicePointer = AttributeHostPointer
succ AttributeHostPointer = AttributeP2pTokens
pred :: Advice -> Advice
succ AttributeP2pTokens = AttributeSyncMemops
succ AttributeSyncMemops = AttributeBufferId
succ AttributeBufferId = AttributeIsManaged
succ AttributeIsManaged = AttributeDeviceOrdinal
succ AttributeDeviceOrdinal = AttributeIsLegacyCudaIpcCapable
succ AttributeIsLegacyCudaIpcCapable = AttributeRangeStartAddr
succ AttributeRangeStartAddr = AttributeRangeSize
succ AttributeRangeSize = AttributeMapped
succ AttributeMapped = AttributeAllowedHandleTypes
succ AttributeAllowedHandleTypes = error "PointerAttribute.succ: AttributeAllowedHandleTypes has no successor"
pred AttributeMemoryType = AttributeContext
pred AttributeDevicePointer = AttributeMemoryType
pred AttributeHostPointer = AttributeDevicePointer
pred AttributeP2pTokens = AttributeHostPointer
pred AttributeSyncMemops = AttributeP2pTokens
pred AttributeBufferId = AttributeSyncMemops
pred AttributeIsManaged = AttributeBufferId
pred AttributeDeviceOrdinal = AttributeIsManaged
pred AttributeIsLegacyCudaIpcCapable = AttributeDeviceOrdinal
pred AttributeRangeStartAddr = AttributeIsLegacyCudaIpcCapable
pred AttributeRangeSize = AttributeRangeStartAddr
pred AttributeMapped = AttributeRangeSize
pred AttributeAllowedHandleTypes = AttributeMapped
pred AttributeContext = error "PointerAttribute.pred: AttributeContext has no predecessor"
enumFromTo from to = go from
where
end = fromEnum to
go v = case compare (fromEnum v) end of
LT -> v : go (succ v)
EQ -> [v]
GT -> []
enumFrom from = enumFromTo from AttributeAllowedHandleTypes
fromEnum :: PointerAttribute -> Int
fromEnum PointerAttribute
AttributeContext = Int
1
fromEnum PointerAttribute
AttributeMemoryType = Int
2
fromEnum PointerAttribute
AttributeDevicePointer = Int
3
fromEnum PointerAttribute
AttributeHostPointer = Int
4
fromEnum PointerAttribute
AttributeP2pTokens = Int
5
fromEnum PointerAttribute
AttributeSyncMemops = Int
6
fromEnum PointerAttribute
AttributeBufferId = Int
7
fromEnum PointerAttribute
AttributeIsManaged = Int
8
fromEnum PointerAttribute
AttributeDeviceOrdinal = Int
9
fromEnum PointerAttribute
AttributeIsLegacyCudaIpcCapable = Int
10
fromEnum PointerAttribute
AttributeRangeStartAddr = Int
11
fromEnum PointerAttribute
AttributeRangeSize = Int
12
fromEnum PointerAttribute
AttributeMapped = Int
13
fromEnum PointerAttribute
AttributeAllowedHandleTypes = Int
14
toEnum :: Int -> PointerAttribute
toEnum Int
1 = PointerAttribute
AttributeContext
toEnum Int
2 = PointerAttribute
AttributeMemoryType
toEnum Int
3 = PointerAttribute
AttributeDevicePointer
toEnum Int
4 = PointerAttribute
AttributeHostPointer
toEnum Int
5 = PointerAttribute
AttributeP2pTokens
toEnum Int
6 = PointerAttribute
AttributeSyncMemops
toEnum Int
7 = PointerAttribute
AttributeBufferId
toEnum Int
8 = PointerAttribute
AttributeIsManaged
toEnum Int
9 = PointerAttribute
AttributeDeviceOrdinal
toEnum Int
10 = PointerAttribute
AttributeIsLegacyCudaIpcCapable
toEnum 11 = AttributeRangeStartAddr
toEnum Int
12 = PointerAttribute
AttributeRangeSize
toEnum 13 = AttributeMapped
toEnum 14 = AttributeAllowedHandleTypes
toEnum Int
unmatched = String -> PointerAttribute
forall a. HasCallStack => String -> a
error (String
"PointerAttribute.toEnum: Cannot match " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
unmatched)
{-# LINE 144 "src/Foreign/CUDA/Driver/Unified.chs" #-}
data Advice = SetReadMostly
| UnsetReadMostly
| SetPreferredLocation
| UnsetPreferredLocation
| SetAccessedBy
| UnsetAccessedBy
deriving (Eq,Show,Bounded)
instance Enum Advice where
succ SetReadMostly = UnsetReadMostly
succ UnsetReadMostly = SetPreferredLocation
succ SetPreferredLocation = UnsetPreferredLocation
succ UnsetPreferredLocation = SetAccessedBy
succ SetAccessedBy = UnsetAccessedBy
succ UnsetAccessedBy = error "Advice.succ: UnsetAccessedBy has no successor"
pred UnsetReadMostly = SetReadMostly
pred SetPreferredLocation = UnsetReadMostly
pred UnsetPreferredLocation = SetPreferredLocation
pred SetAccessedBy = UnsetPreferredLocation
pred UnsetAccessedBy = SetAccessedBy
pred SetReadMostly = error "Advice.pred: SetReadMostly has no predecessor"
enumFromTo from to = go from
where
end = fromEnum to
go v = case compare (fromEnum v) end of
LT -> v : go (succ v)
EQ -> [v]
GT -> []
enumFrom from = enumFromTo from UnsetAccessedBy
fromEnum SetReadMostly = 1
fromEnum UnsetReadMostly = 2
fromEnum SetPreferredLocation = 3
fromEnum UnsetPreferredLocation = 4
fromEnum SetAccessedBy = 5
fromEnum UnsetAccessedBy = 6
toEnum 1 = SetReadMostly
toEnum 2 = UnsetReadMostly
toEnum 3 = SetPreferredLocation
toEnum 4 = UnsetPreferredLocation
toEnum 5 = SetAccessedBy
toEnum 6 = UnsetAccessedBy
toEnum unmatched = error ("Advice.toEnum: Cannot match " ++ show unmatched)
{-# LINE 152 "src/Foreign/CUDA/Driver/Unified.chs" #-}
{-# INLINEABLE getAttributes #-}
getAttributes :: Ptr a -> IO (PointerAttributes a)
getAttributes ptr =
alloca $ \p_ctx ->
alloca $ \p_dptr ->
alloca $ \p_hptr ->
alloca $ \(p_bid :: Ptr CULLong) ->
alloca $ \(p_mt :: Ptr CUInt) ->
alloca $ \(p_sm :: Ptr CInt) ->
alloca $ \(p_im :: Ptr CInt) -> do
let n = length as
(as,ps) = unzip [ (AttributeContext, castPtr p_ctx)
, (AttributeDevicePointer, castPtr p_dptr)
, (AttributeHostPointer, castPtr p_hptr)
, (AttributeBufferId, castPtr p_bid)
, (AttributeMemoryType, castPtr p_mt)
, (AttributeSyncMemops, castPtr p_sm)
, (AttributeIsManaged, castPtr p_im)
]
nothingIfOk =<< cuPointerGetAttributes n as ps ptr
PointerAttributes
<$> liftM Context (peek p_ctx)
<*> liftM DevicePtr (peek p_dptr)
<*> liftM HostPtr (peek p_hptr)
<*> peek p_bid
<*> liftM cToEnum (peek p_mt)
<*> liftM cToBool (peek p_sm)
<*> liftM cToBool (peek p_im)
{-# INLINE cuPointerGetAttributes #-}
cuPointerGetAttributes :: (Int) -> ([PointerAttribute]) -> ([Ptr ()]) -> (Ptr a) -> IO ((Status))
cuPointerGetAttributes a1 a2 a3 a4 =
let {a1' = fromIntegral a1} in
withAttrs a2 $ \a2' ->
withArray a3 $ \a3' ->
let {a4' = useHandle a4} in
cuPointerGetAttributes'_ a1' a2' a3' a4' >>= \res ->
let {res' = cToEnum res} in
return (res')
{-# LINE 201 "src/Foreign/CUDA/Driver/Unified.chs" #-}
where
withAttrs as = withArray (map cFromEnum as)
useHandle = fromIntegral . ptrToIntPtr
{-# INLINE setSyncMemops #-}
setSyncMemops :: Ptr a -> Bool -> IO ()
setSyncMemops ptr val = nothingIfOk =<< cuPointerSetAttribute val AttributeSyncMemops ptr
{-# INLINE cuPointerSetAttribute #-}
cuPointerSetAttribute :: (Bool) -> (PointerAttribute) -> (Ptr a) -> IO ((Status))
cuPointerSetAttribute a1 a2 a3 =
withBool' a1 $ \a1' ->
let {a2' = cFromEnum a2} in
let {a3' = useHandle a3} in
cuPointerSetAttribute'_ a1' a2' a3' >>= \res ->
let {res' = cToEnum res} in
return (res')
{-# LINE 234 "src/Foreign/CUDA/Driver/Unified.chs" #-}
where
withBool' :: Bool -> (Ptr () -> IO b) -> IO b
withBool' v k = with (fromBool v :: CUInt) (k . castPtr)
useHandle = fromIntegral . ptrToIntPtr
{-# INLINEABLE advise #-}
advise :: Storable a => Ptr a -> Int -> Advice -> Maybe Device -> IO ()
advise :: Ptr a -> Int -> Advice -> Maybe Device -> IO ()
advise Ptr a
ptr Int
n Advice
a Maybe Device
mdev = a -> Ptr a -> IO ()
forall a'. Storable a' => a' -> Ptr a' -> IO ()
go a
forall a. HasCallStack => a
undefined Ptr a
ptr
where
go :: Storable a' => a' -> Ptr a' -> IO ()
go :: a' -> Ptr a' -> IO ()
go a'
x Ptr a'
_ = Status -> IO ()
nothingIfOk (Status -> IO ()) -> IO Status -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr a -> Int -> Advice -> CInt -> IO Status
forall a. Ptr a -> Int -> Advice -> CInt -> IO Status
cuMemAdvise Ptr a
ptr (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* a' -> Int
forall a. Storable a => a -> Int
sizeOf a'
x) Advice
a (CInt -> (Device -> CInt) -> Maybe Device -> CInt
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (-CInt
1) Device -> CInt
useDevice Maybe Device
mdev)
{-# INLINE cuMemAdvise #-}
cuMemAdvise :: (Ptr a) -> (Int) -> (Advice) -> (CInt) -> IO ((Status))
cuMemAdvise :: Ptr a -> Int -> Advice -> CInt -> IO Status
cuMemAdvise Ptr a
a1 Int
a2 Advice
a3 CInt
a4 =
let {a1' :: CULLong
a1' = Ptr a -> CULLong
forall a. Ptr a -> CULLong
useHandle Ptr a
a1} in
let {a2' :: CULong
a2' = Int -> CULong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
a2} in
let {a3' :: CInt
a3' = Advice -> CInt
forall e i. (Enum e, Integral i) => e -> i
cFromEnum Advice
a3} in
let {a4' :: CInt
a4' = CInt -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
a4} in
CULLong -> CULong -> CInt -> CInt -> IO CInt
cuMemAdvise'_ CULLong
a1' CULong
a2' CInt
a3' CInt
a4' IO CInt -> (CInt -> IO Status) -> IO Status
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 (m :: * -> *) a. Monad m => a -> m a
return (Status
res')
{-# LINE 267 "src/Foreign/CUDA/Driver/Unified.chs" #-}
where
useHandle :: Ptr a -> CULLong
useHandle = IntPtr -> CULLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral (IntPtr -> CULLong) -> (Ptr a -> IntPtr) -> Ptr a -> CULLong
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr a -> IntPtr
forall a. Ptr a -> IntPtr
ptrToIntPtr
foreign import ccall unsafe "Foreign/CUDA/Driver/Unified.chs.h cuPointerGetAttributes"
cuPointerGetAttributes'_ :: (C2HSImp.CUInt -> ((C2HSImp.Ptr C2HSImp.CInt) -> ((C2HSImp.Ptr (C2HSImp.Ptr ())) -> (C2HSImp.CULLong -> (IO C2HSImp.CInt)))))
foreign import ccall unsafe "Foreign/CUDA/Driver/Unified.chs.h cuPointerSetAttribute"
cuPointerSetAttribute'_ :: ((C2HSImp.Ptr ()) -> (C2HSImp.CInt -> (C2HSImp.CULLong -> (IO C2HSImp.CInt))))
foreign import ccall unsafe "Foreign/CUDA/Driver/Unified.chs.h cuMemAdvise"
cuMemAdvise'_ :: (C2HSImp.CULLong -> (C2HSImp.CULong -> (C2HSImp.CInt -> (C2HSImp.CInt -> (IO C2HSImp.CInt)))))