diff options
author | Joe Crayne <joe@jerkface.net> | 2019-05-10 22:08:11 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2019-05-14 14:38:04 -0400 |
commit | 1e229efbbe69b5fac07a3604ce50e3e8ded06eef (patch) | |
tree | 30ec786209428fa5a357da8f7ee20ed4b132eb0c /src/LambdaCube | |
parent | d1d0946d084dac6666fb5e65ea71b1be9b8017eb (diff) |
TextureBuffer support.
Diffstat (limited to 'src/LambdaCube')
-rw-r--r-- | src/LambdaCube/GL.hs | 2 | ||||
-rw-r--r-- | src/LambdaCube/GL/Backend.hs | 2 | ||||
-rw-r--r-- | src/LambdaCube/GL/Data.hs | 44 | ||||
-rw-r--r-- | src/LambdaCube/GL/Type.hs | 15 | ||||
-rw-r--r-- | src/LambdaCube/GL/Util.hs | 8 |
5 files changed, 65 insertions, 6 deletions
diff --git a/src/LambdaCube/GL.hs b/src/LambdaCube/GL.hs index 47c97d8..8d795a6 100644 --- a/src/LambdaCube/GL.hs +++ b/src/LambdaCube/GL.hs | |||
@@ -17,6 +17,7 @@ module LambdaCube.GL ( | |||
17 | SetterFun, | 17 | SetterFun, |
18 | TextureData, | 18 | TextureData, |
19 | TextureCubeData, | 19 | TextureCubeData, |
20 | TextureBufferData, | ||
20 | InputSetter(..), | 21 | InputSetter(..), |
21 | fromStreamType, | 22 | fromStreamType, |
22 | sizeOfArrayType, | 23 | sizeOfArrayType, |
@@ -31,6 +32,7 @@ module LambdaCube.GL ( | |||
31 | uploadTexture2DToGPU', | 32 | uploadTexture2DToGPU', |
32 | disposeTexture, | 33 | disposeTexture, |
33 | disposeTextureCube, | 34 | disposeTextureCube, |
35 | disposeTextureBuffer, | ||
34 | 36 | ||
35 | -- GL: Renderer, Storage, Object | 37 | -- GL: Renderer, Storage, Object |
36 | GLUniformName, | 38 | GLUniformName, |
diff --git a/src/LambdaCube/GL/Backend.hs b/src/LambdaCube/GL/Backend.hs index 50d0d3f..8c533f2 100644 --- a/src/LambdaCube/GL/Backend.hs +++ b/src/LambdaCube/GL/Backend.hs | |||
@@ -775,7 +775,7 @@ renderSlot glDrawCallCounterRef glVertexBufferRef glIndexBufferRef cmds = forM_ | |||
775 | GLSetUniform idx (GLTypedUniform ty ref) -> setUniform idx ty (readIORef ref) | 775 | GLSetUniform idx (GLTypedUniform ty ref) -> setUniform idx ty (readIORef ref) |
776 | GLSetUniform idx (GLUniform ref) -> return () -- putStrLn $ "TODO: setUniform FTexture2D" | 776 | GLSetUniform idx (GLUniform ref) -> return () -- putStrLn $ "TODO: setUniform FTexture2D" |
777 | GLBindTexture txTarget tuRef (GLUniform ref) -> do | 777 | GLBindTexture txTarget tuRef (GLUniform ref) -> do |
778 | txObj <- coerce <$> readIORef ref | 778 | txObj <- objectName <$> readIORef ref |
779 | do | 779 | do |
780 | texUnit <- readIORef tuRef | 780 | texUnit <- readIORef tuRef |
781 | glActiveTexture $ GL_TEXTURE0 + fromIntegral texUnit | 781 | glActiveTexture $ GL_TEXTURE0 + fromIntegral texUnit |
diff --git a/src/LambdaCube/GL/Data.hs b/src/LambdaCube/GL/Data.hs index 952e14a..4e6dcae 100644 --- a/src/LambdaCube/GL/Data.hs +++ b/src/LambdaCube/GL/Data.hs | |||
@@ -66,6 +66,12 @@ disposeTexture (Texture2DName to) = withArray [to] $ glDeleteTextures 1 | |||
66 | disposeTextureCube :: TextureCubeData -> IO () | 66 | disposeTextureCube :: TextureCubeData -> IO () |
67 | disposeTextureCube (TextureCubeName to) = withArray [to] $ glDeleteTextures 1 | 67 | disposeTextureCube (TextureCubeName to) = withArray [to] $ glDeleteTextures 1 |
68 | 68 | ||
69 | disposeTextureBuffer :: TextureBufferData -> IO () | ||
70 | disposeTextureBuffer TextureBufferData{ textureBufferName = to, textureBufferObject = bo } = do | ||
71 | withArray [to] $ glDeleteTextures 1 | ||
72 | withArray [bo] $ glDeleteBuffers 1 | ||
73 | |||
74 | |||
69 | -- FIXME: Temporary implemenation | 75 | -- FIXME: Temporary implemenation |
70 | uploadTexture2DToGPU :: DynamicImage -> IO TextureData | 76 | uploadTexture2DToGPU :: DynamicImage -> IO TextureData |
71 | uploadTexture2DToGPU = uploadTexture2DToGPU' True False True False | 77 | uploadTexture2DToGPU = uploadTexture2DToGPU' True False True False |
@@ -182,3 +188,41 @@ uploadCubeMapToGPU' isFiltered isSRGB isMip isClamped (bitmap':bitmaps') = do | |||
182 | -- A GL_INVALID_OPERATION error will be generated if target is GL_TEXTURE_CUBE_MAP, | 188 | -- A GL_INVALID_OPERATION error will be generated if target is GL_TEXTURE_CUBE_MAP, |
183 | -- and not all cube-map faces are initialized and consistent. | 189 | -- and not all cube-map faces are initialized and consistent. |
184 | return $ TextureCubeName to | 190 | return $ TextureCubeName to |
191 | |||
192 | uploadTextureBufferToGPU :: Int -- ^ count of floats in buffer to allocate | ||
193 | -> IO TextureBufferData | ||
194 | uploadTextureBufferToGPU size = do | ||
195 | bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo | ||
196 | glBindBuffer GL_TEXTURE_BUFFER bo | ||
197 | glBufferData GL_TEXTURE_BUFFER (4 * fromIntegral size) nullPtr GL_DYNAMIC_DRAW | ||
198 | to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto | ||
199 | glBindTexture GL_TEXTURE_BUFFER to | ||
200 | glTexBuffer GL_TEXTURE_BUFFER GL_R32F bo -- GL_R32F Means 32-bit floats. | ||
201 | glBindBuffer GL_TEXTURE_BUFFER 0 | ||
202 | return TextureBufferData { textureBufferName = to | ||
203 | , textureBufferObject = bo | ||
204 | } | ||
205 | |||
206 | updateTextureBuffer :: TextureBufferData | ||
207 | -> Int -- ^ index | ||
208 | -> Int -- ^ count | ||
209 | -> Ptr Float -- ^ source floats to copy | ||
210 | -> IO () | ||
211 | updateTextureBuffer t off sz ptr = do | ||
212 | glBindBuffer GL_TEXTURE_BUFFER $ textureBufferObject t | ||
213 | glBufferSubData GL_TEXTURE_BUFFER (4*fromIntegral off) (4*fromIntegral sz) ptr | ||
214 | glBindBuffer GL_TEXTURE_BUFFER 0 | ||
215 | |||
216 | |||
217 | readTextureBuffer :: TextureBufferData | ||
218 | -> Int -- ^ index | ||
219 | -> Int -- ^ count | ||
220 | -> (Ptr Float -> IO b) | ||
221 | -> IO b | ||
222 | readTextureBuffer t off sz f = do | ||
223 | glBindBuffer GL_TEXTURE_BUFFER $ textureBufferObject t | ||
224 | ptr <- glMapBufferRange GL_TEXTURE_BUFFER (4*fromIntegral off) (4*fromIntegral sz) GL_MAP_READ_BIT | ||
225 | b <- f ptr | ||
226 | glUnmapBuffer GL_TEXTURE_BUFFER | ||
227 | glBindBuffer GL_TEXTURE_BUFFER 0 | ||
228 | return b | ||
diff --git a/src/LambdaCube/GL/Type.hs b/src/LambdaCube/GL/Type.hs index ce3a365..57f7df0 100644 --- a/src/LambdaCube/GL/Type.hs +++ b/src/LambdaCube/GL/Type.hs | |||
@@ -1,5 +1,6 @@ | |||
1 | {-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} | 1 | {-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} |
2 | {-# LANGUAGE FlexibleContexts #-} | 2 | {-# LANGUAGE DefaultSignatures #-} |
3 | {-# LANGUAGE FlexibleContexts #-} | ||
3 | module LambdaCube.GL.Type where | 4 | module LambdaCube.GL.Type where |
4 | 5 | ||
5 | import Data.Coerce | 6 | import Data.Coerce |
@@ -76,9 +77,14 @@ data GLUniform = forall c. Typeable c => GLTypedUniform (TypeTag c) (IORef (GLUn | |||
76 | 77 | ||
77 | data GLUniformValue c = forall a. GLData a c => GLUniformValue a | 78 | data GLUniformValue c = forall a. GLData a c => GLUniformValue a |
78 | 79 | ||
79 | class (Coercible t Word32, Typeable t) => IsGLObject t where | 80 | class Typeable t => IsGLObject t where |
80 | objectType :: p t -> InputType | 81 | objectType :: p t -> InputType |
81 | 82 | ||
83 | objectName :: t -> Word32 | ||
84 | |||
85 | default objectName :: Coercible t Word32 => t -> Word32 | ||
86 | objectName = coerce | ||
87 | |||
82 | instance Show GLUniform where | 88 | instance Show GLUniform where |
83 | showsPrec d (GLTypedUniform t _) = paren '(' | 89 | showsPrec d (GLTypedUniform t _) = paren '(' |
84 | . mappend "GLUniform " | 90 | . mappend "GLUniform " |
@@ -407,6 +413,11 @@ instance IsGLObject TextureData where objectType _ = FTexture2D | |||
407 | newtype TextureCubeData = TextureCubeName GLuint | 413 | newtype TextureCubeData = TextureCubeName GLuint |
408 | instance IsGLObject TextureCubeData where objectType _ = FTextureCube | 414 | instance IsGLObject TextureCubeData where objectType _ = FTextureCube |
409 | 415 | ||
416 | data TextureBufferData = TextureBufferData { textureBufferName :: GLuint | ||
417 | , textureBufferObject :: GLuint } | ||
418 | instance IsGLObject TextureBufferData where | ||
419 | objectType _ = FTextureBuffer | ||
420 | objectName = textureBufferName | ||
410 | 421 | ||
411 | data Primitive | 422 | data Primitive |
412 | = TriangleStrip | 423 | = TriangleStrip |
diff --git a/src/LambdaCube/GL/Util.hs b/src/LambdaCube/GL/Util.hs index 1320f7d..fe027a9 100644 --- a/src/LambdaCube/GL/Util.hs +++ b/src/LambdaCube/GL/Util.hs | |||
@@ -143,6 +143,7 @@ instance Uniformable (V4 V4F) where uniformContexts _ = contexts $ supports Type | |||
143 | 143 | ||
144 | instance Uniformable TextureData where uniformContexts _ = DMap.empty | 144 | instance Uniformable TextureData where uniformContexts _ = DMap.empty |
145 | instance Uniformable TextureCubeData where uniformContexts _ = DMap.empty | 145 | instance Uniformable TextureCubeData where uniformContexts _ = DMap.empty |
146 | instance Uniformable TextureBufferData where uniformContexts _ = DMap.empty | ||
146 | 147 | ||
147 | mkU :: GLData a c => TypeTag c -> a -> IO GLUniform | 148 | mkU :: GLData a c => TypeTag c -> a -> IO GLUniform |
148 | mkU ty a = GLTypedUniform ty <$> newIORef (GLUniformValue a) | 149 | mkU ty a = GLTypedUniform ty <$> newIORef (GLUniformValue a) |
@@ -178,9 +179,10 @@ initializeUniform t = case witnessType t of | |||
178 | TypeM44F -> mkU ty (V4 z4 z4 z4 z4) | 179 | TypeM44F -> mkU ty (V4 z4 z4 z4 z4) |
179 | 180 | ||
180 | Nothing -> case t of | 181 | Nothing -> case t of |
181 | FTexture2D -> GLUniform <$> newIORef (Texture2DName 0) | 182 | FTexture2D -> GLUniform <$> newIORef (Texture2DName 0) |
182 | FTextureCube -> GLUniform <$> newIORef (TextureCubeName 0) | 183 | FTextureCube -> GLUniform <$> newIORef (TextureCubeName 0) |
183 | _ -> fail $ "initializeUniform: " ++ show t | 184 | FTextureBuffer -> GLUniform <$> newIORef (TextureBufferData 0 0) |
185 | _ -> fail $ "initializeUniform: " ++ show t | ||
184 | 186 | ||
185 | 187 | ||
186 | data TypeMismatch c a = TypeMismatch | 188 | data TypeMismatch c a = TypeMismatch |