module Foreign.CUDA.Runtime.Texture (
Texture(..), FormatKind(..), AddressMode(..), FilterMode(..), FormatDesc(..),
bind, bind2D
) where
import Foreign.CUDA.Ptr
import Foreign.CUDA.Runtime.Error
import Foreign.CUDA.Internal.C2HS
import Foreign.CUDA.Internal.Offsets
import Data.Int
import Foreign
import Foreign.C
type TextureReference = Ptr (Texture)
data Texture = Texture
{
normalised :: !Bool,
filtering :: !FilterMode,
addressing :: !(AddressMode, AddressMode, AddressMode),
format :: !FormatDesc
}
deriving (Eq, Show)
data FormatKind = Signed
| Unsigned
| Float
| None
deriving (Eq,Show)
instance Enum FormatKind where
succ Signed = Unsigned
succ Unsigned = Float
succ Float = None
succ None = error "FormatKind.succ: None has no successor"
pred Unsigned = Signed
pred Float = Unsigned
pred None = Float
pred Signed = error "FormatKind.pred: Signed 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 None
fromEnum Signed = 0
fromEnum Unsigned = 1
fromEnum Float = 2
fromEnum None = 3
toEnum 0 = Signed
toEnum 1 = Unsigned
toEnum 2 = Float
toEnum 3 = None
toEnum unmatched = error ("FormatKind.toEnum: Cannot match " ++ show unmatched)
data AddressMode = Wrap
| Clamp
| Mirror
| Border
deriving (Eq,Show)
instance Enum AddressMode where
succ Wrap = Clamp
succ Clamp = Mirror
succ Mirror = Border
succ Border = error "AddressMode.succ: Border has no successor"
pred Clamp = Wrap
pred Mirror = Clamp
pred Border = Mirror
pred Wrap = error "AddressMode.pred: Wrap 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 Border
fromEnum Wrap = 0
fromEnum Clamp = 1
fromEnum Mirror = 2
fromEnum Border = 3
toEnum 0 = Wrap
toEnum 1 = Clamp
toEnum 2 = Mirror
toEnum 3 = Border
toEnum unmatched = error ("AddressMode.toEnum: Cannot match " ++ show unmatched)
data FilterMode = Point
| Linear
deriving (Eq,Show)
instance Enum FilterMode where
succ Point = Linear
succ Linear = error "FilterMode.succ: Linear has no successor"
pred Linear = Point
pred Point = error "FilterMode.pred: Point 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 Linear
fromEnum Point = 0
fromEnum Linear = 1
toEnum 0 = Point
toEnum 1 = Linear
toEnum unmatched = error ("FilterMode.toEnum: Cannot match " ++ show unmatched)
data FormatDesc = FormatDesc
{
depth :: !(Int,Int,Int,Int),
kind :: !FormatKind
}
deriving (Eq, Show)
instance Storable FormatDesc where
sizeOf _ = 20
alignment _ = alignment (undefined :: Ptr ())
peek p = do
dx <- cIntConv `fmap` (\ptr -> do {peekByteOff ptr 0 ::IO CInt}) p
dy <- cIntConv `fmap` (\ptr -> do {peekByteOff ptr 4 ::IO CInt}) p
dz <- cIntConv `fmap` (\ptr -> do {peekByteOff ptr 8 ::IO CInt}) p
dw <- cIntConv `fmap` (\ptr -> do {peekByteOff ptr 12 ::IO CInt}) p
df <- cToEnum `fmap` (\ptr -> do {peekByteOff ptr 16 ::IO CInt}) p
return $ FormatDesc (dx,dy,dz,dw) df
poke p (FormatDesc (x,y,z,w) k) = do
(\ptr val -> do {pokeByteOff ptr 0 (val::CInt)}) p (cIntConv x)
(\ptr val -> do {pokeByteOff ptr 4 (val::CInt)}) p (cIntConv y)
(\ptr val -> do {pokeByteOff ptr 8 (val::CInt)}) p (cIntConv z)
(\ptr val -> do {pokeByteOff ptr 12 (val::CInt)}) p (cIntConv w)
(\ptr val -> do {pokeByteOff ptr 16 (val::CInt)}) p (cFromEnum k)
instance Storable Texture where
sizeOf _ = 124
alignment _ = alignment (undefined :: Ptr ())
peek p = do
norm <- cToBool `fmap` (\ptr -> do {peekByteOff ptr 0 ::IO CInt}) p
fmt <- cToEnum `fmap` (\ptr -> do {peekByteOff ptr 4 ::IO CInt}) p
[x,y,z] <- map cToEnum `fmap` (peekArray 3 (p `plusPtr` texRefAddressModeOffset :: Ptr CInt))
dsc <- peekByteOff p texRefChannelDescOffset
return $ Texture norm fmt (x,y,z) dsc
poke p (Texture norm fmt (x,y,z) dsc) = do
(\ptr val -> do {pokeByteOff ptr 0 (val::CInt)}) p (cFromBool norm)
(\ptr val -> do {pokeByteOff ptr 4 (val::CInt)}) p (cFromEnum fmt)
pokeArray (p `plusPtr` texRefAddressModeOffset :: Ptr CInt) (map cFromEnum [x,y,z])
pokeByteOff p texRefChannelDescOffset dsc
bind :: String -> Texture -> DevicePtr a -> Int64 -> IO ()
bind !name !tex !dptr !bytes = do
ref <- getTex name
poke ref tex
nothingIfOk =<< cudaBindTexture ref dptr (format tex) bytes
cudaBindTexture :: (TextureReference) -> (DevicePtr a) -> (FormatDesc) -> (Int64) -> IO ((Status))
cudaBindTexture a2 a3 a4 a5 =
alloca $ \a1' ->
let {a2' = id a2} in
let {a3' = dptr a3} in
with_ a4 $ \a4' ->
let {a5' = fromIntegral a5} in
cudaBindTexture'_ a1' a2' a3' a4' a5' >>= \res ->
let {res' = cToEnum res} in
return (res')
where dptr = useDevicePtr . castDevPtr
bind2D :: String -> Texture -> DevicePtr a -> (Int,Int) -> Int64 -> IO ()
bind2D !name !tex !dptr (!width,!height) !bytes = do
ref <- getTex name
poke ref tex
nothingIfOk =<< cudaBindTexture2D ref dptr (format tex) width height bytes
cudaBindTexture2D :: (TextureReference) -> (DevicePtr a) -> (FormatDesc) -> (Int) -> (Int) -> (Int64) -> IO ((Status))
cudaBindTexture2D a2 a3 a4 a5 a6 a7 =
alloca $ \a1' ->
let {a2' = id a2} in
let {a3' = dptr a3} in
with_ a4 $ \a4' ->
let {a5' = fromIntegral a5} in
let {a6' = fromIntegral a6} in
let {a7' = fromIntegral a7} in
cudaBindTexture2D'_ a1' a2' a3' a4' a5' a6' a7' >>= \res ->
let {res' = cToEnum res} in
return (res')
where dptr = useDevicePtr . castDevPtr
getTex :: String -> IO TextureReference
getTex !name = resultIfOk =<< cudaGetTextureReference name
cudaGetTextureReference :: (String) -> IO ((Status), (Ptr Texture))
cudaGetTextureReference a2 =
alloca $ \a1' ->
withCString_ a2 $ \a2' ->
cudaGetTextureReference'_ a1' a2' >>= \res ->
let {res' = cToEnum res} in
peek a1'>>= \a1'' ->
return (res', a1'')
with_ :: Storable a => a -> (Ptr a -> IO b) -> IO b
with_ = with
withCString_ :: String -> (Ptr a -> IO b) -> IO b
withCString_ !str !fn = withCString str (fn . castPtr)
foreign import ccall unsafe "Foreign/CUDA/Runtime/Texture.chs.h cudaBindTexture"
cudaBindTexture'_ :: ((Ptr CULong) -> ((TextureReference) -> ((Ptr ()) -> ((Ptr (FormatDesc)) -> (CULong -> (IO CInt))))))
foreign import ccall unsafe "Foreign/CUDA/Runtime/Texture.chs.h cudaBindTexture2D"
cudaBindTexture2D'_ :: ((Ptr CULong) -> ((TextureReference) -> ((Ptr ()) -> ((Ptr (FormatDesc)) -> (CULong -> (CULong -> (CULong -> (IO CInt))))))))
foreign import ccall unsafe "Foreign/CUDA/Runtime/Texture.chs.h cudaGetTextureReference"
cudaGetTextureReference'_ :: ((Ptr (TextureReference)) -> ((Ptr ()) -> (IO CInt)))