module Graphics.Caramia.Buffer
(
newBuffer
, Buffer()
, AccessFrequency(..)
, AccessNature(..)
, AccessFlags(..)
, MapFlag(..)
, BufferCreation(..)
, defaultBufferCreation
, invalidateBuffer
, map
, map2
, unmap
, copy
, withMapping
, withMapping2
, uploadVector
, viewSize
, viewAllowedMappings
, BufferCorruption(..)
)
where
import Graphics.Caramia.Prelude hiding ( map )
import Graphics.Caramia.Buffer.Internal
import Graphics.Caramia.Resource
import Graphics.Caramia.Internal.OpenGLCApi
import qualified Data.Vector.Storable as V
import qualified Data.Set as S
import Data.Bits
import Foreign
import Control.Exception
data AccessFrequency =
Stream
| Static
| Dynamic
deriving ( Eq, Ord, Show, Read )
data AccessNature =
Draw
| Read
| Copy
deriving ( Eq, Ord, Show, Read )
canMapWith :: AccessFlags -> AccessFlags -> Bool
canMapWith ReadWriteAccess _ = True
canMapWith WriteAccess WriteAccess = True
canMapWith WriteAccess _ = False
canMapWith ReadAccess ReadAccess = True
canMapWith ReadAccess _ = False
canMapWith NoAccess NoAccess = True
canMapWith NoAccess _ = False
toConstant :: AccessFrequency -> AccessNature -> GLuint
toConstant Stream Draw = gl_STREAM_DRAW
toConstant Stream Read = gl_STREAM_READ
toConstant Stream Copy = gl_STREAM_COPY
toConstant Static Draw = gl_STATIC_DRAW
toConstant Static Read = gl_STATIC_READ
toConstant Static Copy = gl_STATIC_COPY
toConstant Dynamic Draw = gl_DYNAMIC_DRAW
toConstant Dynamic Read = gl_DYNAMIC_READ
toConstant Dynamic Copy = gl_DYNAMIC_COPY
toConstantF :: AccessFlags -> GLbitfield
toConstantF ReadAccess = gl_MAP_READ_BIT
toConstantF WriteAccess = gl_MAP_WRITE_BIT
toConstantF ReadWriteAccess = gl_MAP_READ_BIT .|. gl_MAP_WRITE_BIT
toConstantF NoAccess = 0
toConstantMF :: S.Set MapFlag -> GLbitfield
toConstantMF ss
| S.null ss = 0
| otherwise =
if UnSynchronized `S.member` ss
then gl_MAP_UNSYNCHRONIZED_BIT
else 0
data BufferCreation = BufferCreation
{ accessHints :: !(AccessFrequency, AccessNature)
, size :: !Int
, initialData ::
!(Maybe (Ptr ()))
, accessFlags :: !AccessFlags
}
defaultBufferCreation :: BufferCreation
defaultBufferCreation = BufferCreation {
accessHints = (Dynamic, Draw)
, size = 0
, initialData = Nothing
, accessFlags = ReadWriteAccess }
newBuffer :: BufferCreation
-> IO Buffer
newBuffer creation
| size creation <= 0 =
error "newBuffer: size must be positive."
| otherwise = mask_ $ do
resource <-
newResource createBuffer
(\(Buffer_ bufname) -> mglDeleteBuffer bufname)
(return ())
initial_status <- newIORef BufferStatus { mapped = False }
oi <- atomicModifyIORef' bufferOrdIndex $ \old -> ( old+1, old )
return Buffer { resource = resource
, status = initial_status
, viewAllowedMappings = accessFlags creation
, viewSize = size creation
, ordIndex = oi }
where
initial_data = fromMaybe nullPtr (assertNotNull <$> initialData creation)
safe_size = safeFromIntegral $ size creation
(usage, access) = accessHints creation
createBuffer = do
buf <- mglGenBuffer
mglNamedBufferData buf
safe_size
(castPtr initial_data)
(toConstant usage access)
return (Buffer_ buf)
assertNotNull ptr
| ptr == nullPtr = error "newBuffer: initial data is a null pointer."
| otherwise = ptr
map2 :: S.Set MapFlag
-> Int
-> Int
-> AccessFlags
-> Buffer
-> IO (Ptr ())
map2 map_flags offset num_bytes access_flags buffer
| offset < 0 || offset >= viewSize buffer ||
num_bytes <= 0 ||
offset + num_bytes > viewSize buffer =
error $ "map: requested mapping has invalid offset " <>
"and/or range. " <>
"Buffer size is " <> show (viewSize buffer) <> ", " <>
"requested mapping was [" <> show offset <> ".." <>
show (offset + num_bytes 1) <> "]."
| otherwise =
withResource (resource buffer) $ \(Buffer_ buf) -> mask_ $ do
bufstatus <- readIORef (status buffer)
when (mapped bufstatus) $
error "map: buffer is already mapped."
unless (canMapWith (viewAllowedMappings buffer) access_flags) $
error $ "map: attempted to map buffer with " <> show access_flags
<> ", allowed mappings are: " <>
show (viewAllowedMappings buffer)
ptr <- mglMapNamedBufferRange
buf
(safeFromIntegral offset)
(safeFromIntegral num_bytes)
(toConstantF access_flags .|. toConstantMF map_flags)
when (ptr == nullPtr) $
error $ "map: for some reason, mapping a buffer failed. " <>
"You might want to check OpenGL debug log."
atomicModifyIORef' (status buffer) $ \old ->
( old { mapped = True }, () )
return ptr
map :: Int
-> Int
-> AccessFlags
-> Buffer
-> IO (Ptr ())
map = map2 S.empty
data BufferCorruption = BufferCorruption Buffer
deriving ( Eq, Typeable )
instance Show BufferCorruption where
show _ = "BufferCorruption <#Buffer>"
instance Exception BufferCorruption
unmap :: Buffer -> IO ()
unmap buffer = do
bufstatus <- readIORef (status buffer)
when (mapped bufstatus) $
withResource (resource buffer) $ \(Buffer_ buf) -> mask_ $ do
result <- mglUnmapNamedBuffer buf
when (fromIntegral result == gl_FALSE) $
throwIO $ BufferCorruption buffer
atomicModifyIORef' (status buffer) $ \old ->
( old { mapped = False }, () )
withMapping2 :: S.Set MapFlag
-> Int
-> Int
-> AccessFlags
-> Buffer
-> (Ptr () -> IO a)
-> IO a
withMapping2 map_flags offset num_bytes access_flags buffer action =
mask $ \restore -> do
ptr <- map2 map_flags offset num_bytes access_flags buffer
did_it_work <- try $ restore $ action ptr
did_unmapping_work <- try $ unmap buffer
case did_it_work of
Left exc -> throwIO (exc :: SomeException)
Right result ->
case did_unmapping_work of
Left no -> throwIO (no :: BufferCorruption)
Right () -> return result
withMapping :: Int
-> Int
-> AccessFlags
-> Buffer
-> (Ptr () -> IO a)
-> IO a
withMapping = withMapping2 S.empty
uploadVector :: V.Storable a
=> V.Vector a
-> Int
-> Buffer
-> IO ()
uploadVector vec offset buffer =
V.unsafeWith vec $ \src_ptr ->
withMapping offset byte_size WriteAccess buffer $ \tgt_ptr ->
copyBytes tgt_ptr (castPtr src_ptr) byte_size
where
byte_size = V.length vec * sizeOf (undefined `asTypeOf` (vec V.! 0))
copy :: Buffer
-> Int
-> Buffer
-> Int
-> Int
-> IO ()
copy dst_buffer dst_offset src_buffer src_offset num_bytes
| dst_offset < 0 ||
src_offset < 0 ||
dst_offset + num_bytes > viewSize dst_buffer ||
src_offset + num_bytes > viewSize src_buffer ||
num_bytes < 0 =
error "copy: invalid offsets/byte sizes to make a buffer copy."
| overlaps = error "copy: copying area overlaps."
| otherwise =
withResource (resource dst_buffer) $ \(Buffer_ dst) ->
withResource (resource src_buffer) $ \(Buffer_ src) -> do
dst_status <- readIORef (status dst_buffer)
when (mapped dst_status) $
error "copy: destination buffer is mapped."
src_status <- readIORef (status src_buffer)
when (mapped src_status) $
error "copy: source buffer is mapped."
when (num_bytes > 0) $
mglNamedCopyBufferSubData
src
dst
(safeFromIntegral src_offset)
(safeFromIntegral dst_offset)
(safeFromIntegral num_bytes)
where
overlaps
| dst_buffer /= src_buffer = False
| dst_offset + num_bytes 1 < src_offset ||
dst_offset > src_offset + num_bytes 1 = False
| otherwise = True
invalidateBuffer :: Buffer -> IO ()
invalidateBuffer buf = do
has_it <- has_GL_ARB_invalidate_subdata
when has_it $
withResource (resource buf) $ \(Buffer_ name) ->
glInvalidateBufferData name