module Graphics.Caramia.Buffer
(
newBuffer
, newBufferFromBS
, newBufferFromList
, newBufferFromVector
, Buffer()
, AccessFrequency(..)
, AccessNature(..)
, AccessFlags(..)
, MapFlag(..)
, BufferCreation(..)
, defaultBufferCreation
, invalidateBuffer
, bufferMap
, bufferMap2
, bufferUnmap
, copy
, withMapping
, withMapping2
, uploadVector
, viewSize
, viewAllowedMappings
, BufferCorruption(..)
)
where
import Control.Monad.Catch
import Control.Monad.IO.Class
import Data.Bits
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as B
import qualified Data.Set as S
import qualified Data.Vector.Storable as V
import Foreign
import Graphics.Caramia.Buffer.Internal
import Graphics.Caramia.Internal.OpenGLCApi
import Graphics.Caramia.Prelude hiding ( map )
import Graphics.Caramia.Resource
import Graphics.GL.Ext.ARB.BufferStorage
import Graphics.GL.Ext.ARB.InvalidateSubdata
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 :: MonadIO m
=> BufferCreation
-> m Buffer
newBuffer creation
| size creation <= 0 =
fail "newBuffer: size must be positive."
| otherwise = liftIO $ mask_ $ do
resource <-
newResource createBuffer
(\(Buffer_ bufname) -> mglDeleteBuffer bufname)
(return ())
initial_status <- newIORef BufferStatus { mapped = False }
oi <- newUnique
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
if gl_ARB_buffer_storage
then createBufferByBufferStorage
else createBufferOldWay
createBufferByBufferStorage = do
buf <- mglGenBuffer
mglNamedBufferStorage buf
safe_size
(castPtr initial_data)
(toConstantF $ accessFlags creation)
return (Buffer_ buf)
createBufferOldWay = 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
newBufferFromVector :: (Storable a, MonadIO m)
=> V.Vector a
-> (BufferCreation -> BufferCreation)
-> m Buffer
newBufferFromVector vec modifier = liftIO $
V.unsafeWith vec $ \src_ptr ->
newBuffer (modifier defaultBufferCreation {
accessHints = (Static, Draw)
, size = byte_size
, initialData = Just $ castPtr src_ptr
, accessFlags = NoAccess })
where
byte_size = V.length vec * sizeOf (undefined `asTypeOf` (vec V.! 0))
newBufferFromList :: (Storable a, MonadIO m)
=> [a]
-> (BufferCreation -> BufferCreation)
-> m Buffer
newBufferFromList lst modifier = liftIO $
withArrayLen lst $ \num_items ptr ->
let byte_size = num_items*sizeOf (undefined `asTypeOf` (lst !! 0))
in newBuffer (modifier defaultBufferCreation {
accessHints = (Static, Draw)
, size = byte_size
, initialData = Just $ castPtr ptr
, accessFlags = NoAccess })
newBufferFromBS :: MonadIO m
=> B.ByteString
-> (BufferCreation -> BufferCreation)
-> m Buffer
newBufferFromBS bs modifier = liftIO $
B.unsafeUseAsCStringLen bs $ \(ptr, size) ->
newBuffer (modifier defaultBufferCreation {
accessHints = (Static, Draw)
, size = size
, initialData = Just $ castPtr ptr
, accessFlags = NoAccess })
bufferMap2 :: MonadIO m
=> S.Set MapFlag
-> Int
-> Int
-> AccessFlags
-> Buffer
-> m (Ptr ())
bufferMap2 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 =
liftIO $ 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
bufferMap :: MonadIO m
=> Int
-> Int
-> AccessFlags
-> Buffer
-> m (Ptr ())
bufferMap = bufferMap2 S.empty
data BufferCorruption = BufferCorruption Buffer
deriving ( Eq, Typeable )
instance Show BufferCorruption where
show _ = "BufferCorruption <#Buffer>"
instance Exception BufferCorruption
bufferUnmap :: MonadIO m => Buffer -> m ()
bufferUnmap buffer = liftIO $ do
bufstatus <- readIORef (status buffer)
when (mapped bufstatus) $
withResource (resource buffer) $ \(Buffer_ buf) -> mask_ $ do
result <- mglUnmapNamedBuffer buf
when (result == GL_FALSE) $
throwM $ BufferCorruption buffer
atomicModifyIORef' (status buffer) $ \old ->
( old { mapped = False }, () )
withMapping2 :: (MonadIO m, MonadMask m)
=> S.Set MapFlag
-> Int
-> Int
-> AccessFlags
-> Buffer
-> (Ptr () -> m a)
-> m a
withMapping2 map_flags offset num_bytes access_flags buffer action =
mask $ \restore -> do
ptr <- bufferMap2 map_flags offset num_bytes access_flags buffer
did_it_work <- try $ restore $ action ptr
did_unmapping_work <- try $ bufferUnmap buffer
case did_it_work of
Left exc -> throwM (exc :: SomeException)
Right result ->
case did_unmapping_work of
Left no -> throwM (no :: BufferCorruption)
Right () -> return result
withMapping :: (MonadIO m, MonadMask m)
=> Int
-> Int
-> AccessFlags
-> Buffer
-> (Ptr () -> m a)
-> m a
withMapping = withMapping2 S.empty
uploadVector :: (MonadIO m, MonadMask m, V.Storable a)
=> V.Vector a
-> Int
-> Buffer
-> m ()
uploadVector vec offset buffer =
liftIO $ 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 :: MonadIO m
=> Buffer
-> Int
-> Buffer
-> Int
-> Int
-> m ()
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 =
liftIO $ 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 :: MonadIO m => Buffer -> m ()
invalidateBuffer buf =
when gl_ARB_invalidate_subdata $
withResource (resource buf) $ \(Buffer_ name) ->
glInvalidateBufferData name