diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +### 2.1.6 + +- Adding support for normal Floats, Int32s and Word32s in PrimitiveStreams +- Runtime optimizations + ### 2.1.5 - Fixed bug in clear where masks weren't set diff --git a/GPipe.cabal b/GPipe.cabal --- a/GPipe.cabal +++ b/GPipe.cabal @@ -1,5 +1,5 @@ name: GPipe -version: 2.1.5 +version: 2.1.6 cabal-version: >= 1.8 build-type: Simple author: Tobias Bexelius diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,21 +1,21 @@ -The MIT License (MIT) - -Copyright (c) 2015 Tobias Bexelius - -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in -all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +The MIT License (MIT) + +Copyright (c) 2015 Tobias Bexelius + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/src/Data/SNMap.hs b/src/Data/SNMap.hs --- a/src/Data/SNMap.hs +++ b/src/Data/SNMap.hs @@ -5,13 +5,13 @@ SNMapReaderT, runSNMapReaderT, newSNMap, - memoize, + memoize, memoizeM, scopedM )where -import System.Mem.StableName -import qualified Data.HashTable.IO as HT +import System.Mem.StableName +import qualified Data.HashTable.IO as HT import Data.Functor import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Monad.Trans.Class @@ -27,12 +27,12 @@ memoize :: MonadIO m => m (SNMap m a) -> m a -> m a memoize getter m = do s <- liftIO $ makeStableName $! m - (SNMap h) <- getter + (SNMap h) <- getter x <- liftIO $ HT.lookup h s case x of Just a -> return a Nothing -> do a <- m - (SNMap h') <- getter --Need to redo because of scope + (SNMap h') <- getter --Need to redo because of scope liftIO $ HT.insert h' s a return a @@ -40,7 +40,7 @@ runSNMapReaderT :: MonadIO m => SNMapReaderT a m b -> m b runSNMapReaderT (SNMapReaderT m) = do h <- liftIO newSNMap - evalStateT m h + evalStateT m h instance MonadTrans (SNMapReaderT a) where lift = SNMapReaderT . lift diff --git a/src/Graphics/GPipe/Internal/Buffer.hs b/src/Graphics/GPipe/Internal/Buffer.hs --- a/src/Graphics/GPipe/Internal/Buffer.hs +++ b/src/Graphics/GPipe/Internal/Buffer.hs @@ -7,7 +7,7 @@ BufferFormat(..), BufferColor, Buffer(), - ToBuffer(), + ToBuffer(..), B(..), B2(..), B3(..), B4(..), toB22, toB3, toB21, toB12, toB11, Uniform(..), Normalized(..), BPacked(), @@ -27,7 +27,6 @@ import Foreign.Marshal.Alloc import Prelude hiding ((.), id) -import Control.Monad.Trans.State import Control.Category import Control.Arrow import Control.Monad (void) @@ -36,11 +35,12 @@ import Control.Monad.IO.Class import Data.Word import Data.Int +import Control.Monad.Trans.State.Strict +import Control.Monad.Trans.Writer.Strict import Control.Monad.Trans.Reader import Control.Monad.Trans.Class (lift) import Data.IORef import Control.Applicative ((<$>)) -import Control.Monad.Trans.Writer.Lazy import Linear.V4 import Linear.V3 import Linear.V2 @@ -90,21 +90,22 @@ data BInput = BInput {bInSkipElems :: Int, bInInstanceDiv :: Int} -type ToBufferInput = (BufferName, Stride, BInput) - type UniformAlignment = Int data AlignmentMode = Align4 | AlignUniform | AlignPackedIndices | AlignUnknown deriving (Eq) -- | The arrow type for 'toBuffer'. data ToBuffer a b = ToBuffer - (Kleisli (StateT Offset (WriterT [Int] (Reader (ToBufferInput, UniformAlignment, AlignmentMode)))) a b) -- Normal = aligned to 4 bytes - (Kleisli (StateT (Ptr (), [Int]) IO) a b) -- Normal = aligned to 4 bytes - AlignmentMode + !(Kleisli (StateT Offset (WriterT [Int] (Reader (UniformAlignment, AlignmentMode)))) a b) -- Normal = aligned to 4 bytes + !(Kleisli (StateT Offset (Reader (BufferName, Stride, BInput))) a b) + !(Kleisli (StateT (Ptr (), [Int]) IO) a b) -- Normal = aligned to 4 bytes + !AlignmentMode instance Category ToBuffer where - id = ToBuffer id id AlignUnknown - ToBuffer a b m1 . ToBuffer x y m2 = ToBuffer (a.x) (b.y) (comb m1 m2) + {-# INLINE id #-} + id = ToBuffer id id id AlignUnknown + {-# INLINE (.) #-} + ToBuffer a b c m1 . ToBuffer x y z m2 = ToBuffer (a.x) (b.y) (c.z) (comb m1 m2) where -- If only one uniform or one PackedIndices, use that, otherwise use Align4 comb AlignUniform AlignUnknown = AlignUniform @@ -115,8 +116,10 @@ comb _ _ = Align4 instance Arrow ToBuffer where - arr f = ToBuffer (arr f) (arr f) AlignUnknown - first (ToBuffer a b m) = ToBuffer (first a) (first b) m + {-# INLINE arr #-} + arr f = ToBuffer (arr f) (arr f) (arr f) AlignUnknown + {-# INLINE first #-} + first (ToBuffer a b c m) = ToBuffer (first a) (first b) (first c) m -- | The atomic buffer value that represents a host value of type 'a'. data B a = B { bName :: IORef GLuint, bOffset :: Int, bStride :: Int, bSkipElems :: Int, bInstanceDiv :: Int} @@ -162,14 +165,18 @@ toBufferBUnaligned :: forall a. Storable a => ToBuffer a (B a) toBufferBUnaligned = ToBuffer (Kleisli $ const static) + (Kleisli $ const valueProd) (Kleisli writer) Align4 where size = sizeOf (undefined :: a) - static = do ((name, stride, bIn),_,_) <- lift $ lift ask - offset <- get + static = do offset <- get put $ offset + size - return $ B name offset stride (bInSkipElems bIn) (bInInstanceDiv bIn) + return undefined + valueProd = do (name, stride, bIn) <- lift ask + offset <- get + put $ offset + size + return $ B name offset stride (bInSkipElems bIn) (bInInstanceDiv bIn) writer a = do (ptr,pads) <- get put (ptr `plusPtr` size, pads) liftIO $ poke (castPtr ptr) a @@ -204,15 +211,16 @@ instance BufferFormat a => BufferFormat (Uniform a) where type HostFormat (Uniform a) = HostFormat a toBuffer = arr Uniform . ToBuffer + (Kleisli preStep) (Kleisli elementBuilderA) (Kleisli writerA) AlignUniform where - ToBuffer (Kleisli elementBuilderA') (Kleisli writerA') _ = toBuffer :: ToBuffer (HostFormat a) a - elementBuilderA a = do (_,x,_) <- lift $ lift ask - a' <- elementBuilderA' a - setElemAlignM [(AlignUniform, x)] () - return a' + ToBuffer (Kleisli preStep') (Kleisli elementBuilderA) (Kleisli writerA') _ = toBuffer :: ToBuffer (HostFormat a) a + preStep a = do (x,_) <- lift $ lift ask + a' <- preStep' a + setElemAlignM [(AlignUniform, x)] () + return a' writerA a = do a' <- writerA' a setWriterAlignM () return a' @@ -368,11 +376,11 @@ ---------------------------------------------- alignWhen :: [(AlignmentMode, Int)] -> ToBuffer a a -alignWhen x = ToBuffer (Kleisli $ setElemAlignM x) (Kleisli setWriterAlignM) AlignUniform where +alignWhen x = ToBuffer (Kleisli $ setElemAlignM x) (Kleisli $ return) (Kleisli setWriterAlignM) AlignUniform where -setElemAlignM :: [(AlignmentMode, Int)] -> b -> StateT Offset (WriterT [Int] (Reader (ToBufferInput, UniformAlignment, AlignmentMode))) b +setElemAlignM :: [(AlignmentMode, Int)] -> b -> StateT Offset (WriterT [Int] (Reader (UniformAlignment, AlignmentMode))) b setElemAlignM x a = do - (_,_,m) <- lift $ lift ask + (_,m) <- lift $ lift ask pad <- case lookup m x of Nothing -> return 0 Just al -> do @@ -394,12 +402,11 @@ makeBuffer :: forall os b. BufferFormat b => BufferName -> Int -> UniformAlignment -> Buffer os b makeBuffer name elementCount uniformAlignment = do - let ToBuffer a b m = toBuffer :: ToBuffer (HostFormat b) b - err = error "toBuffer, toVertex or toUniform are creating values that are dependant on the actual HostFormat values, this is not allowed since it doesn't allow static creation of shaders" :: HostFormat b - elementM = runWriterT (runStateT (runKleisli a err) 0) - ((_,elementSize),pads) = runReader elementM ((name, undefined, undefined), uniformAlignment, m) - elementF bIn = (fst . fst) $ runReader elementM ((name, elementSize, bIn), uniformAlignment, m) - writer ptr x = void $ runStateT (runKleisli b x) (ptr,pads) + let ToBuffer a b c m = toBuffer :: ToBuffer (HostFormat b) b + err = error "toBuffer is creating values that are dependant on the actual HostFormat values, this is not allowed since it doesn't allow static creation of shaders" :: HostFormat b + ((_,elementSize),pads) = runReader (runWriterT (runStateT (runKleisli a err) 0)) (uniformAlignment, m) + elementF bIn = fst $ runReader (runStateT (runKleisli b err) 0) (name, elementSize, bIn) + writer ptr x = void $ runStateT (runKleisli c x) (ptr,pads) Buffer name elementSize elementCount elementF writer -- | This type family restricts what host and buffer types a texture format may be converted into. @@ -494,14 +501,14 @@ instance BufferFormat (BPacked Word16) where type HostFormat (BPacked Word16) = Word16 - toBuffer = let ToBuffer a b _ = toBufferB :: ToBuffer Word16 (B Word16) in arr BPacked . ToBuffer a b AlignPackedIndices + toBuffer = let ToBuffer a b c _ = toBufferB :: ToBuffer Word16 (B Word16) in arr BPacked . ToBuffer a b c AlignPackedIndices getGlType _ = GL_UNSIGNED_SHORT peekPixel = peekPixel1 getGlPaddedFormat _ = GL_RED_INTEGER instance BufferFormat (BPacked Word8) where type HostFormat (BPacked Word8) = Word8 - toBuffer = let ToBuffer a b _ = toBufferB :: ToBuffer Word8 (B Word8) in arr BPacked . ToBuffer a b AlignPackedIndices + toBuffer = let ToBuffer a b c _ = toBufferB :: ToBuffer Word8 (B Word8) in arr BPacked . ToBuffer a b c AlignPackedIndices getGlType _ = GL_UNSIGNED_BYTE peekPixel = peekPixel1 getGlPaddedFormat _ = GL_RED_INTEGER diff --git a/src/Graphics/GPipe/Internal/Compiler.hs b/src/Graphics/GPipe/Internal/Compiler.hs --- a/src/Graphics/GPipe/Internal/Compiler.hs +++ b/src/Graphics/GPipe/Internal/Compiler.hs @@ -12,6 +12,7 @@ import Control.Monad.Trans.Class (lift) import Graphics.GL.Core33 +import Graphics.GL.Types import Foreign.Marshal.Utils import Foreign.Marshal.Alloc (alloca) import Foreign.Storable (peek) @@ -34,8 +35,9 @@ usedVUniforms :: [Int], usedVSamplers :: [Int], usedFUniforms :: [Int], - usedFSamplers :: [Int] - } + usedFSamplers :: [Int], + primStrUBufferSize :: Int -- The size of the ubuffer for uniforms in primitive stream + } -- index/binding refers to what is used in the final shader. Index space is limited, usually 16 -- attribname is what was declared, but all might not be used. Attribname share namespace with uniforms and textures and is unlimited(TM) @@ -44,49 +46,49 @@ -- TODO: Add usedBuffers to RenderIOState, ie Map.IntMap (s -> (Binding -> IO (), Int)) and the like -- then create a function that checks that none of the input buffers are used as output, and throws if it is -data RenderIOState s = RenderIOState +data RenderIOState s = RenderIOState { uniformNameToRenderIO :: Map.IntMap (s -> Binding -> IO ()), -- TODO: Return buffer name here when we start writing to buffers during rendering (transform feedback, buffer textures) samplerNameToRenderIO :: Map.IntMap (s -> Binding -> IO Int), -- IO returns texturename for validating that it isnt used as render target rasterizationNameToRenderIO :: Map.IntMap (s -> IO ()), - inputArrayToRenderIOs :: Map.IntMap (s -> [[Binding] -> ((IO [VAOKey], IO ()), IO ())]) - } - + inputArrayToRenderIOs :: Map.IntMap (s -> [([Binding], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ())]) + } + newRenderIOState :: RenderIOState s newRenderIOState = RenderIOState Map.empty Map.empty Map.empty Map.empty mapRenderIOState :: (s -> s') -> RenderIOState s' -> RenderIOState s -> RenderIOState s mapRenderIOState f (RenderIOState a b c d) (RenderIOState i j k l) = let g x = x . f in RenderIOState (Map.union i $ Map.map g a) (Map.union j $ Map.map g b) (Map.union k $ Map.map g c) (Map.union l $ Map.map g d) -data BoundState = BoundState { - boundUniforms :: Map.IntMap Int, +data BoundState = BoundState { + boundUniforms :: Map.IntMap Int, boundSamplers :: Map.IntMap Int, boundRasterizerN :: Int - } + } --- | May throw a GPipeException +-- | May throw a GPipeException compile :: (Monad m, MonadIO m, MonadException m) => [IO (Drawcall s)] -> RenderIOState s -> ContextT w os f m (ContextData -> s -> Asserter Int -> IO (Maybe String)) compile dcs s = do drawcalls <- liftIO $ sequence dcs -- IO only for SNMap - (maxUnis, + (maxUnis, maxSamplers, maxVUnis, maxVSamplers, maxFUnis, - maxFSamplers) <- liftContextIO $ do + maxFSamplers) <- liftContextIO $ do maxUnis <- alloca (\ptr -> glGetIntegerv GL_MAX_COMBINED_UNIFORM_BLOCKS ptr >> peek ptr) maxSamplers <- alloca (\ptr -> glGetIntegerv GL_MAX_COMBINED_TEXTURE_IMAGE_UNITS ptr >> peek ptr) maxVUnis <- alloca (\ptr -> glGetIntegerv GL_MAX_VERTEX_UNIFORM_BLOCKS ptr >> peek ptr) maxVSamplers <- alloca (\ptr -> glGetIntegerv GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS ptr >> peek ptr) maxFUnis <- alloca (\ptr -> glGetIntegerv GL_MAX_FRAGMENT_UNIFORM_BLOCKS ptr >> peek ptr) maxFSamplers <- alloca (\ptr -> glGetIntegerv GL_MAX_TEXTURE_IMAGE_UNITS ptr >> peek ptr) - return - (fromIntegral maxUnis, + return + (fromIntegral maxUnis, fromIntegral maxSamplers, - fromIntegral maxVUnis, + fromIntegral maxVUnis, fromIntegral maxVSamplers, - fromIntegral maxFUnis, + fromIntegral maxFUnis, fromIntegral maxFSamplers) let vUnisPerDc = map usedVUniforms drawcalls @@ -95,51 +97,56 @@ fSampsPerDc = map usedFSamplers drawcalls unisPerDc = zipWith orderedUnion vUnisPerDc fUnisPerDc sampsPerDc = zipWith orderedUnion vSampsPerDc fSampsPerDc - + limitErrors = concat [ - ["Too many uniform blocks used in a single shader program\n" | any (\ xs -> length xs >= maxUnis) unisPerDc], + ["Too many uniform blocks used in a single shader program\n" | any (\ xs -> length xs >= maxUnis) unisPerDc], ["Too many textures used in a single shader program\n" | any (\ xs -> length xs >= maxSamplers) sampsPerDc], ["Too many uniform blocks used in a single vertex shader\n" | any (\ xs -> length xs >= maxVUnis) vUnisPerDc], ["Too many textures used in a single vertex shader\n" | any (\ xs -> length xs >= maxVSamplers) vSampsPerDc], ["Too many uniform blocks used in a single fragment shader\n" | any (\ xs -> length xs >= maxFUnis) fUnisPerDc], ["Too many textures used in a single fragment shader\n" | any (\ xs -> length xs >= maxFSamplers) fSampsPerDc] ] - - allocatedUniforms = allocate maxUnis unisPerDc + + allocatedUniforms = allocate maxUnis unisPerDc allocatedSamplers = allocate maxSamplers sampsPerDc compRet <- evalStateT (mapM comp (zip5 drawcalls unisPerDc sampsPerDc allocatedUniforms allocatedSamplers)) (BoundState Map.empty Map.empty (-1)) fAdd <- getContextFinalizerAdder let (errs, ret) = partitionEithers compRet (pnames, fs) = unzip ret - fr cd x asserter = foldl (\ io f -> do + fr cd x asserter = foldl (\ io f -> do mErr <- io mErr2 <- f x asserter cd fAdd return $ mErr <> mErr2) - (return Nothing) + (return Nothing) fs allErrs = limitErrors ++ errs - if null allErrs - then do - forM_ pnames (\pNameRef -> do pName <- liftIO $ readIORef pNameRef - addContextFinalizer pNameRef (glDeleteProgram pName)) + if null allErrs + then do + forM_ pnames (\(pNameRef,pStrUDeleter) -> do pName <- liftIO $ readIORef pNameRef + addContextFinalizer pNameRef (glDeleteProgram pName >> pStrUDeleter)) return fr else do - liftContextIOAsync $ mapM_ (readIORef >=> glDeleteProgram) pnames - liftIO $ throwIO $ GPipeException $ concat allErrs - where - comp (Drawcall fboSetup primN rastN vsource fsource inps _ _ _ _, unis, samps, ubinds, sbinds) = do + liftContextIOAsync $ mapM_ (\(pNameRef, pStrUDeleter) -> readIORef pNameRef >>= glDeleteProgram >> pStrUDeleter) pnames + liftIO $ throwIO $ GPipeException $ concat allErrs + where + comp (Drawcall fboSetup primN rastN vsource fsource inps _ _ _ _ pstrUSize', unis, samps, ubinds, sbinds) = do + let pstrUSize = if 0 `elem` unis then pstrUSize' else 0 + let uNameToRenderIOmap = uniformNameToRenderIO s + pstrUBuf <- createUBuffer pstrUSize -- Create uniform buffer for primiveStream uniforms + let pStrUDeleter = if pstrUSize > 0 then with pstrUBuf (glDeleteBuffers 1) else return () + let uNameToRenderIOmap' = addPstrUniform pstrUBuf pstrUSize uNameToRenderIOmap BoundState uniState sampState boundRastN <- get - let (bindUni, uniState') = makeBind uniState (uniformNameToRenderIO s) (zip unis ubinds) + let (bindUni, uniState') = makeBind uniState uNameToRenderIOmap' (zip unis ubinds) let (bindSamp, sampState') = makeBind sampState (samplerNameToRenderIO s) $ zip samps sbinds - let bindRast = if rastN == boundRastN then const $ return () else rasterizationNameToRenderIO s ! rastN + let bindRast = if rastN == boundRastN then const $ return () else rasterizationNameToRenderIO s ! rastN put $ BoundState uniState' sampState' rastN - + lift $ do ePname <- liftContextIO $ do vShader <- glCreateShader GL_VERTEX_SHADER mErrV <- compileShader vShader vsource - fShader <- glCreateShader GL_FRAGMENT_SHADER + fShader <- glCreateShader GL_FRAGMENT_SHADER mErrF <- compileShader fShader fsource - if isNothing mErrV && isNothing mErrV + if isNothing mErrV && isNothing mErrV then do pName <- glCreateProgram glAttachShader pName vShader glAttachShader pName fShader @@ -150,28 +157,30 @@ glDeleteShader vShader glDeleteShader fShader case mPErr of - Just errP -> do glDeleteProgram pName + Just errP -> do glDeleteProgram pName + pStrUDeleter return $ Left $ "Linking a GPU progam failed:\n" ++ errP ++ "\nVertex source:\n" ++ vsource ++ "\nFragment source:\n" ++ fsource Nothing -> return $ Right pName else do glDeleteShader vShader glDeleteShader fShader + pStrUDeleter let err = maybe "" (\e -> "A vertex shader compilation failed:\n" ++ e ++ "\nSource:\n" ++ vsource) mErrV ++ maybe "" (\e -> "A fragment shader compilation failed:\n" ++ e ++ "\nSource:\n" ++ fsource) mErrF return $ Left err - case ePname of + case ePname of Left err -> return $ Left err - Right pName -> liftContextIO $ do + Right pName -> liftContextIO $ do forM_ (zip unis ubinds) $ \(name, bind) -> do uix <- withCString ("uBlock" ++ show name) $ glGetUniformBlockIndex pName glUniformBlockBinding pName uix (fromIntegral bind) - + glUseProgram pName -- For setting texture uniforms forM_ (zip samps sbinds) $ \(name, bind) -> do six <- withCString ("s" ++ show name) $ glGetUniformLocation pName glUniform1i six (fromIntegral bind) pNameRef <- newIORef pName - - return $ Right (pNameRef, \x asserter cd fAdd -> do + + return $ Right ((pNameRef, pStrUDeleter), \x asserter cd fAdd -> do -- Drawing with program -- pName' <- readIORef pNameRef -- Cant use pName, need to touch pNameRef glUseProgram pName' @@ -196,13 +205,13 @@ setFBO cd fbokey fbo glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo' glEnable GL_FRAMEBUFFER_SRGB - fboio + fboio let numColors = length $ fboColors fbokey withArray [GL_COLOR_ATTACHMENT0 .. (GL_COLOR_ATTACHMENT0 + fromIntegral numColors - 1)] $ glDrawBuffers (fromIntegral numColors) - getFBOerror - when (isNothing mError) $ + getFBOerror + when (isNothing mError) $ -- Draw each Vertex Array -- - forM_ (map ($ inps) ((inputArrayToRenderIOs s ! primN) x)) $ \ ((keyio, vaoio), drawio) -> do + forM_ (map ($ (inps, pstrUBuf, pstrUSize)) ((inputArrayToRenderIOs s ! primN) x)) $ \ ((keyio, vaoio), drawio) -> do key <- keyio mvao <- getVAO cd key case mvao of @@ -217,7 +226,7 @@ drawio return mError) - compileShader name source = do + compileShader name source = do withCStringLen source $ \ (ptr, len) -> with ptr $ \ pptr -> with (fromIntegral len) $ \ plen -> @@ -230,7 +239,7 @@ let logLen' = fromIntegral logLen liftM Just $ allocaArray logLen' $ \ ptr -> do glGetShaderInfoLog name logLen nullPtr ptr - peekCString ptr + peekCString ptr linkProgram name = do glLinkProgram name linkStatus <- alloca $ \ ptr -> glGetProgramiv name GL_LINK_STATUS ptr >> peek ptr if linkStatus /= GL_FALSE @@ -239,8 +248,18 @@ let logLen' = fromIntegral logLen liftM Just $ allocaArray logLen' $ \ ptr -> do glGetProgramInfoLog name logLen nullPtr ptr - peekCString ptr + peekCString ptr + createUBuffer 0 = return undefined + createUBuffer uSize = lift $ liftContextIO $ do bname <- alloca (\ptr -> glGenBuffers 1 ptr >> peek ptr) + glBindBuffer GL_COPY_WRITE_BUFFER bname + glBufferData GL_COPY_WRITE_BUFFER (fromIntegral uSize) nullPtr GL_STREAM_DRAW + return bname + addPstrUniform _ 0 = id + addPstrUniform bname uSize = Map.insert 0 $ \_ bind -> glBindBufferRange GL_UNIFORM_BUFFER (fromIntegral bind) bname 0 (fromIntegral uSize) + + + orderedUnion :: Ord a => [a] -> [a] -> [a] orderedUnion xxs@(x:xs) yys@(y:ys) | x == y = x : orderedUnion xs ys | x < y = x : orderedUnion xs yys @@ -253,30 +272,30 @@ -- Optimization, save gl calls to already bound buffers/samplers makeBind :: Map.IntMap Int -> Map.IntMap (s -> Binding -> IO x) -> [(Int, Int)] -> (s -> Asserter x -> IO (), Map.IntMap Int) makeBind m iom ((n,b):xs) = (g, m'') - where + where (f, m') = makeBind m iom xs (io, m'') = case Map.lookup b m' of Just x | x == n -> (\_ _ -> return (), m') - _ -> (\s asserter -> (iom ! n) s b >>= asserter, Map.insert b n m') - g s a = f s a >> io s a -makeBind m _ [] = (\_ _ -> return (), m) + _ -> (\s asserter -> (iom ! n) s b >>= asserter, Map.insert b n m') + g s a = f s a >> io s a +makeBind m _ [] = (\_ _ -> return (), m) allocate :: Int -> [[Int]] -> [[Int]] allocate mx = allocate' Map.empty [] - where allocate' m ys ((x:xs):xss) | Just a <- Map.lookup x m = allocate' m (a:ys) (xs:xss) + where allocate' m ys ((x:xs):xss) | Just a <- Map.lookup x m = allocate' m (a:ys) (xs:xss) | ms <- Map.size m, ms < mx = allocate' (Map.insert x ms m) (ms:ys) (xs:xss) | otherwise = let (ek,ev) = findLastUsed m mx (ys ++ xs ++ concat xss) in allocate' (Map.insert x ev (Map.delete ek m)) (ev:ys) (xs:xss) - allocate' m ys (_:xss) = reverse ys : allocate' m [] xss + allocate' m ys (_:xss) = reverse ys : allocate' m [] xss allocate' _ _ [] = [] - - findLastUsed m n (x:xs) | n > 1 = let (a, m') = Map.updateLookupWithKey (const $ const Nothing) x m + + findLastUsed m n (x:xs) | n > 1 = let (a, m') = Map.updateLookupWithKey (const $ const Nothing) x m n' = if isJust a then n-1 else n in findLastUsed m' n' xs - findLastUsed m _ _ = head $ Map.toList m - -getFBOerror :: MonadIO m => m (Maybe String) + findLastUsed m _ _ = head $ Map.toList m + +getFBOerror :: MonadIO m => m (Maybe String) getFBOerror = do status <- glCheckFramebufferStatus GL_DRAW_FRAMEBUFFER return $ case status of GL_FRAMEBUFFER_COMPLETE -> Nothing GL_FRAMEBUFFER_UNSUPPORTED -> Just "The combination of draw images (FBO) used in the render call is unsupported by this graphics driver\n" - _ -> error "GPipe internal FBO error" + _ -> error "GPipe internal FBO error" diff --git a/src/Graphics/GPipe/Internal/FrameBuffer.hs b/src/Graphics/GPipe/Internal/FrameBuffer.hs --- a/src/Graphics/GPipe/Internal/FrameBuffer.hs +++ b/src/Graphics/GPipe/Internal/FrameBuffer.hs @@ -149,10 +149,10 @@ mapM_ g xs makeDrawcall :: (ExprM (), GlobDeclM (), s -> (Maybe (IO FBOKeys, IO ()), IO ())) -> FragmentStreamData -> IO (Drawcall s) -makeDrawcall (sh, shd, io) (FragmentStreamData rastN shaderpos (PrimitiveStreamData primN) keep) = +makeDrawcall (sh, shd, io) (FragmentStreamData rastN shaderpos (PrimitiveStreamData primN ubuff) keep) = do (fsource, funis, fsamps, _, prevDecls, prevS) <- runExprM shd (discard keep >> sh) (vsource, vunis, vsamps, vinps, _, _) <- runExprM prevDecls (prevS >> shaderpos) - return $ Drawcall io primN rastN vsource fsource vinps vunis vsamps funis fsamps + return $ Drawcall io primN rastN vsource fsource vinps vunis vsamps funis fsamps ubuff setColor :: forall c. ColorSampleable c => c -> Int -> FragColor c -> (ExprM (), GlobDeclM ()) setColor ct n c = let name = "out" ++ show n diff --git a/src/Graphics/GPipe/Internal/PrimitiveStream.hs b/src/Graphics/GPipe/Internal/PrimitiveStream.hs --- a/src/Graphics/GPipe/Internal/PrimitiveStream.hs +++ b/src/Graphics/GPipe/Internal/PrimitiveStream.hs @@ -3,8 +3,8 @@ module Graphics.GPipe.Internal.PrimitiveStream where import Control.Monad.Trans.Class -import Control.Monad.Trans.Writer.Lazy -import Control.Monad.Trans.State.Lazy +import Control.Monad.Trans.State.Strict +import Control.Monad.Trans.Reader import Prelude hiding (length, id, (.)) import Graphics.GPipe.Internal.Buffer import Graphics.GPipe.Internal.Expr @@ -12,16 +12,21 @@ import Graphics.GPipe.Internal.Compiler import Graphics.GPipe.Internal.PrimitiveArray import Graphics.GPipe.Internal.Context +import Graphics.GPipe.Internal.Uniform import Control.Category import Control.Arrow +import Control.Monad (void) import Data.Monoid (Monoid(..)) import Data.IntMap.Lazy (insert) import Data.Word import Data.Int +import Foreign.Storable +import Foreign.Ptr +import qualified Data.IntMap as Map import Graphics.GL.Core33 +import Graphics.GL.Types import Foreign.Marshal.Utils -import Foreign.Ptr (intPtrToPtr) import Data.IORef import Linear.V4 import Linear.V3 @@ -34,7 +39,8 @@ import Data.Maybe (fromMaybe) type DrawCallName = Int -data PrimitiveStreamData = PrimitiveStreamData DrawCallName +type USize = Int +data PrimitiveStreamData = PrimitiveStreamData DrawCallName USize -- | A @'PrimitiveStream' t a @ is a stream of primitives of type @t@ where the vertices are values of type @a@. You -- can operate a stream's vertex values using the 'Functor' instance (this will result in a shader running on the GPU). @@ -46,7 +52,7 @@ fmap f (PrimitiveStream xs) = PrimitiveStream $ map (first f) xs -- | This class constraints which buffer types can be turned into vertex values, and what type those values have. -class BufferFormat a => VertexInput a where +class VertexInput a where -- | The type the buffer value will be turned into once it becomes a vertex value. type VertexFormat a -- | An arrow action that turns a value from it's buffer representation to it's vertex representation. Use 'toVertex' from @@ -56,20 +62,38 @@ -- @proc ~pattern -> do ...@. toVertex :: ToVertex a (VertexFormat a) +type UniOffset = Int + -- | The arrow type for 'toVertex'. -newtype ToVertex a b = ToVertex (Kleisli (StateT Int (Writer [Binding -> (IO VAOKey, IO ())])) a b) deriving (Category, Arrow) +data ToVertex a b = ToVertex + !(Kleisli (StateT (Ptr ()) IO) a b) + !(Kleisli (StateT (Int, UniOffset, OffsetToSType) (Reader (Int -> ExprM String))) a b) + !(Kleisli (State [Binding -> (IO VAOKey, IO ())]) a b) +instance Category ToVertex where + {-# INLINE id #-} + id = ToVertex id id id + {-# INLINE (.) #-} + ToVertex a b c . ToVertex x y z = ToVertex (a.x) (b.y) (c.z) +instance Arrow ToVertex where + {-# INLINE arr #-} + arr f = ToVertex (arr f) (arr f) (arr f) + {-# INLINE first #-} + first (ToVertex a b c) = ToVertex (first a) (first b) (first c) + + -- | Create a primitive stream from a primitive array provided from the shader environment. toPrimitiveStream :: forall os f s a p. VertexInput a => (s -> PrimitiveArray p a) -> Shader os f s (PrimitiveStream p (VertexFormat a)) toPrimitiveStream sf = Shader $ do n <- getName uniAl <- askUniformAlignment - let sampleBuffer = makeBuffer undefined undefined uniAl :: Buffer os a - x = fst $ runWriter (evalStateT (mf $ bufBElement sampleBuffer $ BInput 0 0) 0) + let err = error "toPrimitiveStream is creating values that are dependant on the actual HostFormat values, this is not allowed since it doesn't allow static creation of shaders" + (x,(_,uSize, offToStype)) = runReader (runStateT (mf err) (0,0,mempty)) (useUniform (buildUDecl offToStype) 0) -- 0 is special blockname for the one used by primitive stream doForInputArray n (map drawcall . getPrimitiveArray . sf) - return $ PrimitiveStream [(x, (Nothing, PrimitiveStreamData n))] + + return $ PrimitiveStream [(x, (Nothing, PrimitiveStreamData n uSize))] where - ToVertex (Kleisli mf) = toVertex :: ToVertex a (VertexFormat a) + ToVertex (Kleisli uWriter) (Kleisli mf) (Kleisli bindingm) = toVertex :: ToVertex a (VertexFormat a) drawcall (PrimitiveArraySimple p l a) binds = (attribs a binds, glDrawArrays (toGLtopology p) 0 (fromIntegral l)) drawcall (PrimitiveArrayIndexed p i a) binds = (attribs a binds, do bindIndexBuffer i @@ -94,11 +118,21 @@ assignIxs _ _ [] _ = [] assignIxs _ _ _ _ = error "Too few attributes generated in toPrimitiveStream" - attribs a binds = first sequence $ second sequence_ $ unzip $ assignIxs 0 0 binds $ execWriter (runStateT (mf a) 0) + attribs a (binds, uBname, uSize) = let + (_,bindsAssoc) = runState (bindingm a) [] + (ioVaokeys, ios) = unzip $ assignIxs 0 0 binds $ reverse bindsAssoc + in (writeUBuffer uBname uSize a >> sequence ioVaokeys, sequence_ ios) - doForInputArray :: Int -> (s -> [[Binding] -> ((IO [VAOKey], IO ()), IO ())]) -> ShaderM s () + doForInputArray :: Int -> (s -> [([Binding], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ())]) -> ShaderM s () doForInputArray n io = modifyRenderIO (\s -> s { inputArrayToRenderIOs = insert n io (inputArrayToRenderIOs s) } ) + writeUBuffer _ 0 _ = return () -- If the uniform buffer is size 0 there is no buffer + writeUBuffer bname size a = do + glBindBuffer GL_COPY_WRITE_BUFFER bname + ptr <- glMapBufferRange GL_COPY_WRITE_BUFFER 0 (fromIntegral size) (GL_MAP_WRITE_BIT + GL_MAP_INVALIDATE_BUFFER_BIT) + void $ runStateT (uWriter a) ptr + void $ glUnmapBuffer GL_COPY_WRITE_BUFFER + data InputIndices = InputIndices { inputVertexID :: VInt, inputInstanceID :: VInt @@ -115,37 +149,73 @@ withPointSize :: (a -> PointSize -> (b, PointSize)) -> PrimitiveStream Points a -> PrimitiveStream Points b withPointSize f (PrimitiveStream xs) = PrimitiveStream $ map (\(a, (ps, d)) -> let (b, ps') = f a (fromMaybe (scalarS' "1") ps) in (b, (Just ps', d))) xs -makeVertexFx norm x f styp typ b = do - n <- get - put $ n + 1 - let combOffset = bStride b * bSkipElems b + bOffset b - lift $ tell [\ix -> ( do bn <- readIORef $ bName b - return $ VAOKey bn combOffset x norm (bInstanceDiv b) - , do bn <- readIORef $ bName b - let ix' = fromIntegral ix - glEnableVertexAttribArray ix' - glBindBuffer GL_ARRAY_BUFFER bn - glVertexAttribDivisor ix' (fromIntegral $ bInstanceDiv b) - glVertexAttribPointer ix' x typ (fromBool norm) (fromIntegral $ bStride b) (intPtrToPtr $ fromIntegral combOffset))] - return (f styp $ useVInput styp n) +makeVertexF x f styp _ = do + (n,uoffset,m) <- get + put (n + 1, uoffset,m) + return (f styp $ useVInput styp n) -makeVertexFnorm = makeVertexFx True -makeVertexF = makeVertexFx False +append x = modify (x:) -makeVertexI x f styp typ b = do - n <- get - put $ n + 1 - let combOffset = bStride b * bSkipElems b + bOffset b - lift $ tell [\ix -> ( do bn <- readIORef $ bName b - return $ VAOKey bn combOffset x False (bInstanceDiv b) - , do bn <- readIORef $ bName b - let ix' = fromIntegral ix - glEnableVertexAttribArray ix' - glBindBuffer GL_ARRAY_BUFFER bn - glVertexAttribDivisor ix' (fromIntegral $ bInstanceDiv b) - glVertexAttribIPointer ix' x typ (fromIntegral $ bStride b) (intPtrToPtr $ fromIntegral combOffset))] - return (f styp $ useVInput styp n) +makeBindVertexFx norm x typ b = do + let combOffset = bStride b * bSkipElems b + bOffset b + append (\ix -> ( do bn <- readIORef $ bName b + return $ VAOKey bn combOffset x norm (bInstanceDiv b) + , do bn <- readIORef $ bName b + let ix' = fromIntegral ix + glEnableVertexAttribArray ix' + glBindBuffer GL_ARRAY_BUFFER bn + glVertexAttribDivisor ix' (fromIntegral $ bInstanceDiv b) + glVertexAttribPointer ix' x typ (fromBool norm) (fromIntegral $ bStride b) (intPtrToPtr $ fromIntegral combOffset))) + return undefined +makeBindVertexFnorm = makeBindVertexFx True +makeBindVertexF = makeBindVertexFx False + +makeVertexI x f styp _ = do + (n, uoffset,m) <- get + put (n + 1, uoffset,m) + return (f styp $ useVInput styp n) +makeBindVertexI x typ b = do + let combOffset = bStride b * bSkipElems b + bOffset b + append (\ix -> ( do bn <- readIORef $ bName b + return $ VAOKey bn combOffset x False (bInstanceDiv b) + , do bn <- readIORef $ bName b + let ix' = fromIntegral ix + glEnableVertexAttribArray ix' + glBindBuffer GL_ARRAY_BUFFER bn + glVertexAttribDivisor ix' (fromIntegral $ bInstanceDiv b) + glVertexAttribIPointer ix' x typ (fromIntegral $ bStride b) (intPtrToPtr $ fromIntegral combOffset))) + return undefined +noWriter = Kleisli (const $ return undefined) + +-- Uniform values + +toUniformVertex :: forall a b. Storable a => SType -> ToVertex a (S V b) +toUniformVertex styp = ToVertex (Kleisli uWriter) (Kleisli makeV) (Kleisli makeBind) + where + size = sizeOf (undefined :: a) + uWriter a = do ptr <- get + put (ptr `plusPtr` size) + lift $ poke (castPtr ptr) a + return undefined + makeV a = do (n, uoffset,m) <- get + put (n, uoffset + size, Map.insert uoffset styp m) + useF <- lift ask + return $ S $ useF uoffset + makeBind a = return undefined + +instance VertexInput Float where + type VertexFormat Float = VFloat + toVertex = toUniformVertex STypeFloat + +instance VertexInput Int32 where + type VertexFormat Int32 = VInt + toVertex = toUniformVertex STypeInt + +instance VertexInput Word32 where + type VertexFormat Word32 = VWord + toVertex = toUniformVertex STypeUInt + -- scalars unBnorm :: Normalized t -> t @@ -153,134 +223,134 @@ instance VertexInput (B Float) where type VertexFormat (B Float) = VFloat - toVertex = ToVertex $ Kleisli $ makeVertexF 1 (const S) STypeFloat GL_FLOAT + toVertex = ToVertex noWriter (Kleisli $ makeVertexF 1 (const S) STypeFloat) (Kleisli $ makeBindVertexF 1 GL_FLOAT) instance VertexInput (Normalized (B Int32)) where type VertexFormat (Normalized (B Int32)) = VFloat - toVertex = ToVertex $ Kleisli $ makeVertexFnorm 1 (const S) STypeFloat GL_INT . unBnorm + toVertex = ToVertex noWriter (Kleisli $ makeVertexF 1 (const S) STypeFloat . unBnorm) (Kleisli $ makeBindVertexFnorm 1 GL_INT . unBnorm) instance VertexInput (Normalized (B Word32)) where type VertexFormat (Normalized (B Word32)) = VFloat - toVertex = ToVertex $ Kleisli $ makeVertexFnorm 1 (const S) STypeFloat GL_UNSIGNED_INT . unBnorm + toVertex = ToVertex noWriter (Kleisli $ makeVertexF 1 (const S) STypeFloat . unBnorm) (Kleisli $ makeBindVertexFnorm 1 GL_UNSIGNED_INT . unBnorm) instance VertexInput (B Int32) where type VertexFormat (B Int32) = VInt - toVertex = ToVertex $ Kleisli $ makeVertexI 1 (const S) STypeInt GL_INT + toVertex = ToVertex noWriter (Kleisli $ makeVertexI 1 (const S) STypeInt) (Kleisli $ makeBindVertexI 1 GL_INT) instance VertexInput (B Word32) where type VertexFormat (B Word32) = VWord - toVertex = ToVertex $ Kleisli $ makeVertexI 1 (const S) STypeUInt GL_UNSIGNED_INT + toVertex = ToVertex noWriter (Kleisli $ makeVertexI 1 (const S) STypeUInt) (Kleisli $ makeBindVertexI 1 GL_UNSIGNED_INT) -- B2 instance VertexInput (B2 Float) where type VertexFormat (B2 Float) = V2 VFloat - toVertex = ToVertex $ Kleisli $ makeVertexF 2 vec2S (STypeVec 2) GL_FLOAT . unB2 + toVertex = ToVertex noWriter (Kleisli $ makeVertexF 2 vec2S (STypeVec 2) . unB2) (Kleisli $ makeBindVertexF 2 GL_FLOAT . unB2) instance VertexInput (Normalized (B2 Int32)) where type VertexFormat (Normalized (B2 Int32)) = V2 VFloat - toVertex = ToVertex $ Kleisli $ makeVertexFnorm 2 vec2S (STypeVec 2) GL_INT . unB2 . unBnorm + toVertex = ToVertex noWriter (Kleisli $ makeVertexF 2 vec2S (STypeVec 2) . unB2 . unBnorm) (Kleisli $ makeBindVertexFnorm 2 GL_INT . unB2 . unBnorm) instance VertexInput (Normalized (B2 Int16)) where type VertexFormat (Normalized (B2 Int16)) = V2 VFloat - toVertex = ToVertex $ Kleisli $ makeVertexFnorm 2 vec2S (STypeVec 2) GL_SHORT . unB2 . unBnorm + toVertex = ToVertex noWriter (Kleisli $ makeVertexF 2 vec2S (STypeVec 2) . unB2 . unBnorm) (Kleisli $ makeBindVertexFnorm 2 GL_SHORT . unB2 . unBnorm) instance VertexInput (Normalized (B2 Word32)) where type VertexFormat (Normalized (B2 Word32)) = V2 VFloat - toVertex = ToVertex $ Kleisli $ makeVertexFnorm 2 vec2S (STypeVec 2) GL_UNSIGNED_INT . unB2 . unBnorm + toVertex = ToVertex noWriter (Kleisli $ makeVertexF 2 vec2S (STypeVec 2) . unB2 . unBnorm) (Kleisli $ makeBindVertexFnorm 2 GL_UNSIGNED_INT . unB2 . unBnorm) instance VertexInput (Normalized (B2 Word16)) where type VertexFormat (Normalized (B2 Word16)) = V2 VFloat - toVertex = ToVertex $ Kleisli $ makeVertexFnorm 2 vec2S (STypeVec 2) GL_UNSIGNED_SHORT . unB2 . unBnorm + toVertex = ToVertex noWriter (Kleisli $ makeVertexF 2 vec2S (STypeVec 2) . unB2 . unBnorm) (Kleisli $ makeBindVertexFnorm 2 GL_UNSIGNED_SHORT . unB2 . unBnorm) instance VertexInput (B2 Int32) where type VertexFormat (B2 Int32) = V2 VInt - toVertex = ToVertex $ Kleisli $ makeVertexI 2 vec2S (STypeIVec 2) GL_INT . unB2 + toVertex = ToVertex noWriter (Kleisli $ makeVertexI 2 vec2S (STypeIVec 2) . unB2) (Kleisli $ makeBindVertexI 2 GL_INT . unB2) instance VertexInput (B2 Int16) where type VertexFormat (B2 Int16) = V2 VInt - toVertex = ToVertex $ Kleisli $ makeVertexI 2 vec2S (STypeIVec 2) GL_SHORT . unB2 + toVertex = ToVertex noWriter (Kleisli $ makeVertexI 2 vec2S (STypeIVec 2) . unB2) (Kleisli $ makeBindVertexI 2 GL_SHORT . unB2) instance VertexInput (B2 Word32) where type VertexFormat (B2 Word32) = V2 VWord - toVertex = ToVertex $ Kleisli $ makeVertexI 2 vec2S (STypeUVec 2) GL_UNSIGNED_INT . unB2 + toVertex = ToVertex noWriter (Kleisli $ makeVertexI 2 vec2S (STypeUVec 2) . unB2) (Kleisli $ makeBindVertexI 2 GL_UNSIGNED_INT . unB2) instance VertexInput (B2 Word16) where type VertexFormat (B2 Word16) = V2 VWord - toVertex = ToVertex $ Kleisli $ makeVertexI 2 vec2S (STypeUVec 2) GL_UNSIGNED_SHORT . unB2 + toVertex = ToVertex noWriter (Kleisli $ makeVertexI 2 vec2S (STypeUVec 2) . unB2) (Kleisli $ makeBindVertexI 2 GL_UNSIGNED_SHORT . unB2) -- B3 instance VertexInput (B3 Float) where type VertexFormat (B3 Float) = V3 VFloat - toVertex = ToVertex $ Kleisli $ makeVertexF 3 vec3S (STypeVec 3) GL_FLOAT . unB3 + toVertex = ToVertex noWriter (Kleisli $ makeVertexF 3 vec3S (STypeVec 3) . unB3) (Kleisli $ makeBindVertexF 3 GL_FLOAT . unB3) instance VertexInput (Normalized (B3 Int32)) where type VertexFormat (Normalized (B3 Int32)) = V3 VFloat - toVertex = ToVertex $ Kleisli $ makeVertexFnorm 3 vec3S (STypeVec 3) GL_INT . unB3 . unBnorm + toVertex = ToVertex noWriter (Kleisli $ makeVertexF 3 vec3S (STypeVec 3) . unB3 . unBnorm) (Kleisli $ makeBindVertexFnorm 3 GL_INT . unB3 . unBnorm) instance VertexInput (Normalized (B3 Int16)) where type VertexFormat (Normalized (B3 Int16)) = V3 VFloat - toVertex = ToVertex $ Kleisli $ makeVertexFnorm 3 vec3S (STypeVec 3) GL_SHORT . unB3 . unBnorm + toVertex = ToVertex noWriter (Kleisli $ makeVertexF 3 vec3S (STypeVec 3) . unB3 . unBnorm) (Kleisli $ makeBindVertexFnorm 3 GL_SHORT . unB3 . unBnorm) instance VertexInput (Normalized (B3 Int8)) where type VertexFormat (Normalized (B3 Int8)) = V3 VFloat - toVertex = ToVertex $ Kleisli $ makeVertexFnorm 3 vec3S (STypeVec 3) GL_BYTE . unB3 . unBnorm + toVertex = ToVertex noWriter (Kleisli $ makeVertexF 3 vec3S (STypeVec 3) . unB3 . unBnorm) (Kleisli $ makeBindVertexFnorm 3 GL_BYTE . unB3 . unBnorm) instance VertexInput (Normalized (B3 Word32)) where type VertexFormat (Normalized (B3 Word32)) = V3 VFloat - toVertex = ToVertex $ Kleisli $ makeVertexFnorm 3 vec3S (STypeVec 3) GL_UNSIGNED_INT . unB3 . unBnorm + toVertex = ToVertex noWriter (Kleisli $ makeVertexF 3 vec3S (STypeVec 3) . unB3 . unBnorm) (Kleisli $ makeBindVertexFnorm 3 GL_UNSIGNED_INT . unB3 . unBnorm) instance VertexInput (Normalized (B3 Word16)) where type VertexFormat (Normalized (B3 Word16)) = V3 VFloat - toVertex = ToVertex $ Kleisli $ makeVertexFnorm 3 vec3S (STypeVec 3) GL_UNSIGNED_SHORT . unB3 . unBnorm + toVertex = ToVertex noWriter (Kleisli $ makeVertexF 3 vec3S (STypeVec 3) . unB3 . unBnorm) (Kleisli $ makeBindVertexFnorm 3 GL_UNSIGNED_SHORT . unB3 . unBnorm) instance VertexInput (Normalized (B3 Word8)) where type VertexFormat (Normalized (B3 Word8)) = V3 VFloat - toVertex = ToVertex $ Kleisli $ makeVertexFnorm 3 vec3S (STypeVec 3) GL_UNSIGNED_BYTE . unB3 . unBnorm + toVertex = ToVertex noWriter (Kleisli $ makeVertexF 3 vec3S (STypeVec 3) . unB3 . unBnorm) (Kleisli $ makeBindVertexFnorm 3 GL_UNSIGNED_BYTE . unB3 . unBnorm) instance VertexInput (B3 Int32) where type VertexFormat (B3 Int32) = V3 VInt - toVertex = ToVertex $ Kleisli $ makeVertexI 3 vec3S (STypeIVec 3) GL_INT . unB3 + toVertex = ToVertex noWriter (Kleisli $ makeVertexI 3 vec3S (STypeIVec 3) . unB3) (Kleisli $ makeBindVertexI 3 GL_INT . unB3) instance VertexInput (B3 Int16) where type VertexFormat (B3 Int16) = V3 VInt - toVertex = ToVertex $ Kleisli $ makeVertexI 3 vec3S (STypeIVec 3) GL_SHORT . unB3 + toVertex = ToVertex noWriter (Kleisli $ makeVertexI 3 vec3S (STypeIVec 3) . unB3) (Kleisli $ makeBindVertexI 3 GL_SHORT . unB3) instance VertexInput (B3 Int8) where type VertexFormat (B3 Int8) = V3 VInt - toVertex = ToVertex $ Kleisli $ makeVertexI 3 vec3S (STypeIVec 3) GL_BYTE . unB3 + toVertex = ToVertex noWriter (Kleisli $ makeVertexI 3 vec3S (STypeIVec 3) . unB3) (Kleisli $ makeBindVertexI 3 GL_BYTE . unB3) instance VertexInput (B3 Word32) where type VertexFormat (B3 Word32) = V3 VWord - toVertex = ToVertex $ Kleisli $ makeVertexI 3 vec3S (STypeUVec 3) GL_UNSIGNED_INT . unB3 + toVertex = ToVertex noWriter (Kleisli $ makeVertexI 3 vec3S (STypeUVec 3) . unB3) (Kleisli $ makeBindVertexI 3 GL_UNSIGNED_INT . unB3) instance VertexInput (B3 Word16) where type VertexFormat (B3 Word16) = V3 VWord - toVertex = ToVertex $ Kleisli $ makeVertexI 3 vec3S (STypeUVec 3) GL_UNSIGNED_SHORT . unB3 + toVertex = ToVertex noWriter (Kleisli $ makeVertexI 3 vec3S (STypeUVec 3) . unB3) (Kleisli $ makeBindVertexI 3 GL_UNSIGNED_SHORT . unB3) instance VertexInput (B3 Word8) where type VertexFormat (B3 Word8) = V3 VWord - toVertex = ToVertex $ Kleisli $ makeVertexI 3 vec3S (STypeUVec 3) GL_UNSIGNED_BYTE . unB3 + toVertex = ToVertex noWriter (Kleisli $ makeVertexI 3 vec3S (STypeUVec 3) . unB3) (Kleisli $ makeBindVertexI 3 GL_UNSIGNED_BYTE . unB3) -- B4 instance VertexInput (B4 Float) where type VertexFormat (B4 Float) = V4 VFloat - toVertex = ToVertex $ Kleisli $ makeVertexF 4 vec4S (STypeVec 4) GL_FLOAT . unB4 + toVertex = ToVertex noWriter (Kleisli $ makeVertexF 4 vec4S (STypeVec 4) . unB4) (Kleisli $ makeBindVertexF 4 GL_FLOAT . unB4) instance VertexInput (Normalized (B4 Int32)) where type VertexFormat (Normalized (B4 Int32)) = V4 VFloat - toVertex = ToVertex $ Kleisli $ makeVertexFnorm 4 vec4S (STypeVec 4) GL_INT . unB4 . unBnorm + toVertex = ToVertex noWriter (Kleisli $ makeVertexF 4 vec4S (STypeVec 4) . unB4 . unBnorm) (Kleisli $ makeBindVertexFnorm 4 GL_INT . unB4 . unBnorm) instance VertexInput (Normalized (B4 Int16)) where type VertexFormat (Normalized (B4 Int16)) = V4 VFloat - toVertex = ToVertex $ Kleisli $ makeVertexFnorm 4 vec4S (STypeVec 4) GL_SHORT . unB4 . unBnorm + toVertex = ToVertex noWriter (Kleisli $ makeVertexF 4 vec4S (STypeVec 4) . unB4 . unBnorm) (Kleisli $ makeBindVertexFnorm 4 GL_SHORT . unB4 . unBnorm) instance VertexInput (Normalized (B4 Int8)) where type VertexFormat (Normalized (B4 Int8)) = V4 VFloat - toVertex = ToVertex $ Kleisli $ makeVertexFnorm 4 vec4S (STypeVec 4) GL_BYTE . unB4 . unBnorm + toVertex = ToVertex noWriter (Kleisli $ makeVertexF 4 vec4S (STypeVec 4) . unB4 . unBnorm) (Kleisli $ makeBindVertexFnorm 4 GL_BYTE . unB4 . unBnorm) instance VertexInput (Normalized (B4 Word32)) where type VertexFormat (Normalized (B4 Word32)) = V4 VFloat - toVertex = ToVertex $ Kleisli $ makeVertexFnorm 4 vec4S (STypeVec 4) GL_UNSIGNED_INT . unB4 . unBnorm + toVertex = ToVertex noWriter (Kleisli $ makeVertexF 4 vec4S (STypeVec 4) . unB4 . unBnorm) (Kleisli $ makeBindVertexFnorm 4 GL_UNSIGNED_INT . unB4 . unBnorm) instance VertexInput (Normalized (B4 Word16)) where type VertexFormat (Normalized (B4 Word16)) = V4 VFloat - toVertex = ToVertex $ Kleisli $ makeVertexFnorm 4 vec4S (STypeVec 4) GL_UNSIGNED_SHORT . unB4 . unBnorm + toVertex = ToVertex noWriter (Kleisli $ makeVertexF 4 vec4S (STypeVec 4) . unB4 . unBnorm) (Kleisli $ makeBindVertexFnorm 4 GL_UNSIGNED_SHORT . unB4 . unBnorm) instance VertexInput (Normalized (B4 Word8)) where type VertexFormat (Normalized (B4 Word8)) = V4 VFloat - toVertex = ToVertex $ Kleisli $ makeVertexFnorm 4 vec4S (STypeVec 4) GL_UNSIGNED_BYTE . unB4 . unBnorm + toVertex = ToVertex noWriter (Kleisli $ makeVertexF 4 vec4S (STypeVec 4) . unB4 . unBnorm) (Kleisli $ makeBindVertexFnorm 4 GL_UNSIGNED_BYTE . unB4 . unBnorm) instance VertexInput (B4 Int32) where type VertexFormat (B4 Int32) = V4 VInt - toVertex = ToVertex $ Kleisli $ makeVertexI 4 vec4S (STypeIVec 4) GL_INT . unB4 + toVertex = ToVertex noWriter (Kleisli $ makeVertexI 4 vec4S (STypeIVec 4) . unB4) (Kleisli $ makeBindVertexI 4 GL_INT . unB4) instance VertexInput (B4 Int16) where type VertexFormat (B4 Int16) = V4 VInt - toVertex = ToVertex $ Kleisli $ makeVertexI 4 vec4S (STypeIVec 4) GL_SHORT . unB4 + toVertex = ToVertex noWriter (Kleisli $ makeVertexI 4 vec4S (STypeIVec 4) . unB4) (Kleisli $ makeBindVertexI 4 GL_SHORT . unB4) instance VertexInput (B4 Int8) where type VertexFormat (B4 Int8) = V4 VInt - toVertex = ToVertex $ Kleisli $ makeVertexI 4 vec4S (STypeIVec 4) GL_BYTE . unB4 + toVertex = ToVertex noWriter (Kleisli $ makeVertexI 4 vec4S (STypeIVec 4) . unB4) (Kleisli $ makeBindVertexI 4 GL_BYTE . unB4) instance VertexInput (B4 Word32) where type VertexFormat (B4 Word32) = V4 VWord - toVertex = ToVertex $ Kleisli $ makeVertexI 4 vec4S (STypeUVec 4) GL_UNSIGNED_INT . unB4 + toVertex = ToVertex noWriter (Kleisli $ makeVertexI 4 vec4S (STypeUVec 4) . unB4) (Kleisli $ makeBindVertexI 4 GL_UNSIGNED_INT . unB4) instance VertexInput (B4 Word16) where type VertexFormat (B4 Word16) = V4 VWord - toVertex = ToVertex $ Kleisli $ makeVertexI 4 vec4S (STypeUVec 4) GL_UNSIGNED_SHORT . unB4 + toVertex = ToVertex noWriter (Kleisli $ makeVertexI 4 vec4S (STypeUVec 4) . unB4) (Kleisli $ makeBindVertexI 4 GL_UNSIGNED_SHORT . unB4) instance VertexInput (B4 Word8) where type VertexFormat (B4 Word8) = V4 VWord - toVertex = ToVertex $ Kleisli $ makeVertexI 4 vec4S (STypeUVec 4) GL_UNSIGNED_BYTE . unB4 + toVertex = ToVertex noWriter (Kleisli $ makeVertexI 4 vec4S (STypeUVec 4) . unB4) (Kleisli $ makeBindVertexI 4 GL_UNSIGNED_BYTE . unB4) instance VertexInput () where type VertexFormat () = () diff --git a/src/Graphics/GPipe/Internal/Shader.hs b/src/Graphics/GPipe/Internal/Shader.hs --- a/src/Graphics/GPipe/Internal/Shader.hs +++ b/src/Graphics/GPipe/Internal/Shader.hs @@ -6,7 +6,7 @@ Shader(..), ShaderM(..), ShaderState(..), - CompiledShader, + CompiledShader, Render(..), getName, tellDrawcall, @@ -26,10 +26,10 @@ import Graphics.GPipe.Internal.Compiler import Graphics.GPipe.Internal.Context import Graphics.GPipe.Internal.Buffer -import Control.Monad.Trans.State -import qualified Control.Monad.Trans.State.Strict as StrictState +import Control.Monad.Trans.State +import qualified Control.Monad.Trans.State.Strict as StrictState import Control.Monad.IO.Class -import qualified Data.IntSet as Set +import qualified Data.IntSet as Set import Control.Monad.Trans.Writer.Lazy (tell, WriterT(..), runWriterT) import Control.Monad.Exception (MonadException) import Control.Applicative (Applicative, Alternative, (<|>)) @@ -45,55 +45,55 @@ data ShaderState s = ShaderState Int (RenderIOState s) newShaderState :: ShaderState s -newShaderState = ShaderState 0 newRenderIOState +newShaderState = ShaderState 1 newRenderIOState getName :: ShaderM s Int getName = do ShaderState n r <- ShaderM $ lift $ lift $ lift get ShaderM $ lift $ lift $ lift $ put $ ShaderState (n+1) r return n -askUniformAlignment = ShaderM ask +askUniformAlignment = ShaderM ask modifyRenderIO :: (RenderIOState s -> RenderIOState s) -> ShaderM s () modifyRenderIO f = ShaderM $ lift $ lift $ lift $ modify (\(ShaderState a s) -> ShaderState a (f s)) tellDrawcall :: IO (Drawcall s) -> ShaderM s () -tellDrawcall dc = ShaderM $ lift $ tell ([dc], mempty) +tellDrawcall dc = ShaderM $ lift $ tell ([dc], mempty) mapDrawcall :: (s -> s') -> Drawcall s' -> Drawcall s -mapDrawcall f (Drawcall a b c d e g h i j k) = Drawcall (a . f) b c d e g h i j k +mapDrawcall f (Drawcall a b c d e g h i j k m) = Drawcall (a . f) b c d e g h i j k m newtype ShaderM s a = ShaderM (ReaderT UniformAlignment (WriterT ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s)))) a) deriving (MonadPlus, Monad, Alternative, Applicative, Functor) --- | The monad in which all GPU computations are done. 'Shader os f s a' lives in an object space 'os' and a context with format 'f', closing over an environent of type 's'. +-- | The monad in which all GPU computations are done. 'Shader os f s a' lives in an object space 'os' and a context with format 'f', closing over an environent of type 's'. newtype Shader os f s a = Shader (ShaderM s a) deriving (MonadPlus, Monad, Alternative, Applicative, Functor) --- | Map the environment to a different environment and run a Shader in that sub environment, returning it's result. +-- | Map the environment to a different environment and run a Shader in that sub environment, returning it's result. mapShader :: (s -> s') -> Shader os f s' a -> Shader os f s a mapShader f (Shader (ShaderM m)) = Shader $ ShaderM $ do uniAl <- ask lift $ WriterT $ ListT $ do ShaderState x s <- get let (adcs, ShaderState x' s') = runState (runListT (runWriterT (runReaderT m uniAl))) (ShaderState x newRenderIOState) - put $ ShaderState x' (mapRenderIOState f s' s) + put $ ShaderState x' (mapRenderIOState f s' s) return $ map (\(a,(dcs, disc)) -> (a, (map (>>= (return . mapDrawcall f)) dcs, disc . f))) adcs --- | Conditionally run the effects of a shader when a 'Maybe' value is 'Just' something. +-- | Conditionally run the effects of a shader when a 'Maybe' value is 'Just' something. maybeShader :: (s -> Maybe s') -> Shader os f s' () -> Shader os f s () -maybeShader f m = (guard' (isJust . f) >> mapShader (fromJust . f) m) <|> guard' (isNothing . f) +maybeShader f m = (guard' (isJust . f) >> mapShader (fromJust . f) m) <|> guard' (isNothing . f) -- | Like 'guard', but dependent on the 'Shaders' environment value. Since this will be evaluated at shader run time, as opposed to shader compile time for 'guard', -- using this to do recursion will make 'compileShader' diverge. You can break that divergence by combining it with a normal 'guard' and a maximum loop count. guard' :: (s -> Bool) -> Shader os f s () -guard' f = Shader $ ShaderM $ lift $ tell (mempty, All . f) +guard' f = Shader $ ShaderM $ lift $ tell (mempty, All . f) -- | Select one of two 'Shader' actions based on whether an 'Either' value is 'Left' or 'Right'. chooseShader :: (s -> Either s' s'') -> Shader os f s' a -> Shader os f s'' a -> Shader os f s a -chooseShader f a b = (guard' (isLeft . f) >> mapShader (fromLeft . f) a) <|> (guard' (isRight . f) >> mapShader (fromRight . f) b) +chooseShader f a b = (guard' (isLeft . f) >> mapShader (fromLeft . f) a) <|> (guard' (isRight . f) >> mapShader (fromRight . f) b) where fromLeft (Left x) = x - fromRight (Right x) = x + fromRight (Right x) = x --- | Discard all effects of a 'Shader' action (i.e., dont draw anything) and just return the resulting value. This makes it possible to use a 'Shader' written for a different context format. +-- | Discard all effects of a 'Shader' action (i.e., dont draw anything) and just return the resulting value. This makes it possible to use a 'Shader' written for a different context format. silenceShader :: Shader os f' s a -> Shader os f s a silenceShader (Shader (ShaderM m)) = Shader $ ShaderM $ do uniAl <- ask @@ -103,10 +103,10 @@ put s' return $ map (\ (a, (_, disc)) -> (a, ([], disc))) adcs --- | A compiled shader is just a function that takes an environment and returns a 'Render' action +-- | A compiled shader is just a function that takes an environment and returns a 'Render' action type CompiledShader os f s = s -> Render os f () --- | Compiles a shader into a 'CompiledShader'. This action will usually take a second or more, so put it during a loading sequence or something. +-- | Compiles a shader into a 'CompiledShader'. This action will usually take a second or more, so put it during a loading sequence or something. -- -- May throw a 'GPipeException' if the graphics driver doesn't support something in this shader (e.g. too many interpolated floats sent between a vertex and a fragment shader), -- or if shader evaluates to 'mzero'. @@ -116,20 +116,20 @@ let (adcs, ShaderState _ s) = runState (runListT (runWriterT (runReaderT m uniAl))) newShaderState f ((disc, runF):ys) e@(cd, env, asserter) = if getAll (disc env) then runF cd env asserter else f ys e f [] _ = error "render: Shader evaluated to mzero\n" - xs <- mapM (\(_,(dcs, disc)) -> do + xs <- mapM (\(_,(dcs, disc)) -> do runF <- compile dcs s return (disc, runF)) adcs return $ \ s -> Render $ do cd <- lift $ lift $ asks $ fst . snd texmap <- lift StrictState.get - let asserter x = when (Set.member x texmap) $ error "render: Running shader that samples from texture that currently has an image borrowed from it. Try run this shader from a separate render call where no images from the same texture are drawn to or cleared." + let asserter x = when (Set.member x texmap) $ error "render: Running shader that samples from texture that currently has an image borrowed from it. Try run this shader from a separate render call where no images from the same texture are drawn to or cleared." throwFromMaybe $ lift $ lift $ lift $ f xs (cd, s, asserter) throwFromMaybe m = do mErr <- m case mErr of Just err -> throwError err Nothing -> return () - + -- | Use this to run a shader that doesn't reference the context frame buffer, allowing the same shader to be run in another context with a different context format (but still with same object space). withoutContext :: Render os () () -> Render os f () -withoutContext (Render m) = Render m +withoutContext (Render m) = Render m