diff --git a/lambdacube-gl.cabal b/lambdacube-gl.cabal --- a/lambdacube-gl.cabal +++ b/lambdacube-gl.cabal @@ -1,5 +1,5 @@ name: lambdacube-gl -version: 0.5.2.0 +version: 0.5.2.2 synopsis: OpenGL 3.3 Core Profile backend for LambdaCube 3D description: OpenGL 3.3 Core Profile backend for LambdaCube 3D homepage: http://lambdacube3d.com @@ -125,7 +125,7 @@ base < 5, containers >=0.5 && <0.6, text >= 1.2 && <1.3, - time >= 1.5 && <1.6, + time >= 1.5 && <1.7, exceptions >= 0.8 && <0.9, bytestring >=0.10 && <0.11, base64-bytestring >=1 && <1.1, diff --git a/src/LambdaCube/GL/Backend.hs b/src/LambdaCube/GL/Backend.hs --- a/src/LambdaCube/GL/Backend.hs +++ b/src/LambdaCube/GL/Backend.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE TupleSections, MonadComprehensions, RecordWildCards, LambdaCase #-} +{-# LANGUAGE TupleSections, MonadComprehensions, RecordWildCards, LambdaCase, FlexibleContexts #-} module LambdaCube.GL.Backend where import Control.Applicative import Control.Monad -import Control.Monad.State +import Control.Monad.State.Strict import Data.Maybe import Data.Bits import Data.IORef @@ -13,10 +13,10 @@ import Data.Set (Set) import Data.Vector (Vector,(!),(//)) import qualified Data.Foldable as F -import qualified Data.IntMap as IM +import qualified Data.IntMap as IntMap import qualified Data.Map as Map import qualified Data.List as L -import qualified Data.Set as S +import qualified Data.Set as Set import qualified Data.Vector as V import qualified Data.Vector.Storable as SV @@ -279,7 +279,7 @@ , programObject = po , inputUniforms = Map.fromList inUniforms , inputTextures = Map.fromList inTextures - , inputTextureUniforms = S.fromList $ texUnis + , inputTextureUniforms = Set.fromList $ texUnis , inputStreams = Map.fromList [(n,(idx, attrName)) | (n,idx) <- Map.toList $ attributes, let attrName = fromMaybe (error $ "missing attribute: " ++ n) $ Map.lookup n lcStreamName] } @@ -443,7 +443,7 @@ uniCmds = [GLSetUniform i u | (n,i) <- uniMap, let u = topUni n] uniMap = Map.toList $ inputUniforms prg topUni n = Map.findWithDefault (error "internal error (createStreamCommands)!") n topUnis - texUnis = S.toList $ inputTextureUniforms prg + texUnis = Set.toList $ inputTextureUniforms prg texCmds = [ GLBindTexture (inputTypeToTextureTarget $ uniInputType u) texUnit u | n <- texUnis , let u = topUni n @@ -496,24 +496,34 @@ prgs <- V.mapM compileProgram $ programs p -- texture unit mapping ioref trie -- texUnitMapRefs :: Map UniformName (IORef TextureUnit) - texUnitMapRefs <- Map.fromList <$> mapM (\k -> (k,) <$> newIORef 0) (S.toList $ S.fromList $ concat $ V.toList $ V.map (Map.keys . programInTextures) $ programs p) - let (cmds,st) = runState (mapM (compileCommand texUnitMapRefs smps texs trgs prgs) $ V.toList $ commands p) initCGState + texUnitMapRefs <- Map.fromList <$> mapM (\k -> (k,) <$> newIORef 0) (Set.toList $ Set.fromList $ concat $ V.toList $ V.map (Map.keys . programInTextures) $ programs p) + let st = execState (mapM_ (compileCommand texUnitMapRefs smps texs trgs prgs) (V.toList $ commands p)) initCGState input <- newIORef Nothing -- default Vertex Array Object vao <- alloca $! \pvao -> glGenVertexArrays 1 pvao >> peek pvao strs <- V.mapM compileStreamData $ streams p + drawContextRef <- newIORef $ error "missing DrawContext" + forceSetup <- newIORef True + vertexBufferRef <- newIORef 0 + indexBufferRef <- newIORef 0 + drawCallCounterRef <- newIORef 0 return $ GLRenderer { glPrograms = prgs , glTextures = texs , glSamplers = smps , glTargets = trgs - , glCommands = cmds + , glCommands = reverse $ drawCommands st , glSlotPrograms = V.map (V.toList . slotPrograms) $ IR.slots p , glInput = input , glSlotNames = V.map slotName $ IR.slots p , glVAO = vao , glTexUnitMapping = texUnitMapRefs , glStreams = strs + , glDrawContextRef = drawContextRef + , glForceSetup = forceSetup + , glVertexBufferRef = vertexBufferRef + , glIndexBufferRef = indexBufferRef + , glDrawCallCounterRef = drawCallCounterRef } disposeRenderer :: GLRenderer -> IO () @@ -594,7 +604,7 @@ modifyIORef (pipelines icInput) $ \v -> v // [(icId,Nothing)] V.forM_ icSlotMapPipelineToInput $ \slotIdx -> do slot <- readIORef (slotRefs ! slotIdx) - forM_ (IM.elems $ objectMap slot) $ \obj -> do + forM_ (objectMap slot) $ \obj -> do modifyIORef (objCommands obj) $ \v -> v // [(icId,V.empty)] {- addition: @@ -619,7 +629,7 @@ return (i,Nothing) -- create input connection let sm = slotMap input - pToI = [i | n <- glSlotNames, let i = fromMaybe (error $ "missing object array: " ++ n) $ Map.lookup n sm] + pToI = [i | n <- glSlotNames, let i = fromMaybe (error $ "setStorage - missing object array: " ++ n) $ Map.lookup n sm] iToP = V.update (V.replicate (Map.size sm) Nothing) (V.imap (\i v -> (v, Just i)) pToI) writeIORef glInput $ Just $ InputConnection idx input pToI iToP @@ -641,7 +651,7 @@ Just l -> V.concat [v,V.replicate l V.empty] V.forM_ (V.zip pToI glSlotPrograms) $ \(slotIdx,prgs) -> do slot <- readIORef $ slotV ! slotIdx - forM_ (IM.elems $ objectMap slot) $ \obj -> do + forM_ (objectMap slot) $ \obj -> do let cmdV = emptyV // [(prgIdx,createObjectCommands glTexUnitMapping topUnis obj (progV ! prgIdx)) | prgIdx <- prgs] modifyIORef (objCommands obj) $ \v -> extend v // [(idx,cmdV)] -- generate stream commands @@ -684,21 +694,28 @@ buffer binding on various targets: GL_ARRAY_BUFFER, GL_ELEMENT_ARRAY_BUFFER glEnable/DisableVertexAttribArray -} -renderSlot :: [GLObjectCommand] -> IO () -renderSlot cmds = forM_ cmds $ \cmd -> do +renderSlot :: IORef Int -> IORef GLuint -> IORef GLuint -> [GLObjectCommand] -> IO () +renderSlot glDrawCallCounterRef glVertexBufferRef glIndexBufferRef cmds = forM_ cmds $ \cmd -> do + let setup ref v m = do + old <- readIORef ref + unless (old == v) $ do + writeIORef ref v + m + case cmd of GLSetVertexAttribArray idx buf size typ ptr -> do - glBindBuffer GL_ARRAY_BUFFER buf + setup glVertexBufferRef buf $ glBindBuffer GL_ARRAY_BUFFER buf glEnableVertexAttribArray idx glVertexAttribPointer idx size typ (fromIntegral GL_FALSE) 0 ptr GLSetVertexAttribIArray idx buf size typ ptr -> do - glBindBuffer GL_ARRAY_BUFFER buf + setup glVertexBufferRef buf $ glBindBuffer GL_ARRAY_BUFFER buf glEnableVertexAttribArray idx glVertexAttribIPointer idx size typ 0 ptr - GLDrawArrays mode first count -> glDrawArrays mode first count + GLDrawArrays mode first count -> glDrawArrays mode first count >> modifyIORef glDrawCallCounterRef succ GLDrawElements mode count typ buf indicesPtr -> do - glBindBuffer GL_ELEMENT_ARRAY_BUFFER buf + setup glIndexBufferRef buf $ glBindBuffer GL_ELEMENT_ARRAY_BUFFER buf glDrawElements mode count typ indicesPtr + modifyIORef glDrawCallCounterRef succ GLSetUniform idx (GLUniform ty ref) -> setUniform idx ty ref GLBindTexture txTarget tuRef (GLUniform _ ref) -> do txObjVal <- readIORef ref @@ -715,105 +732,167 @@ --isOk <- checkGL --putStrLn $ isOk ++ " - " ++ show cmd +setupRenderTarget glInput GLRenderTarget{..} = do + -- set target viewport + ic' <- readIORef glInput + case ic' of + Nothing -> return () + Just ic -> do + let input = icInput ic + (w,h) <- readIORef $ screenSize input + glViewport 0 0 (fromIntegral w) (fromIntegral h) + -- TODO: set FBO target viewport + glBindFramebuffer GL_DRAW_FRAMEBUFFER framebufferObject + case framebufferDrawbuffers of + Nothing -> return () + Just bl -> withArray bl $ glDrawBuffers (fromIntegral $ length bl) + +setupDrawContext glForceSetup glDrawContextRef glInput new = do + old <- readIORef glDrawContextRef + writeIORef glDrawContextRef new + force <- readIORef glForceSetup + writeIORef glForceSetup False + + let setup :: Eq a => (GLDrawContext -> a) -> (a -> IO ()) -> IO () + setup f m = case force of + True -> m $ f new + False -> do + let a = f new + unless (a == f old) $ m a + + setup glRenderTarget $ setupRenderTarget glInput + setup glRasterContext $ setupRasterContext + setup glAccumulationContext setupAccumulationContext + setup glProgram glUseProgram + + -- setup texture mapping + setup glTextureMapping $ mapM_ $ \(textureUnit,GLTexture{..}) -> do + glActiveTexture (GL_TEXTURE0 + fromIntegral textureUnit) + glBindTexture glTextureTarget glTextureObject + + -- setup sampler mapping + setup glSamplerMapping $ mapM_ $ \(textureUnit,GLSampler{..}) -> do + glBindSampler (GL_TEXTURE0 + fromIntegral textureUnit) glSamplerObject + + -- setup sampler uniform mapping + forM_ (glSamplerUniformMapping new) $ \(textureUnit,GLSamplerUniform{..}) -> do + glUniform1i glUniformBinding (fromIntegral textureUnit) + writeIORef glUniformBindingRef (fromIntegral textureUnit) + renderFrame :: GLRenderer -> IO () -renderFrame glp = do - glBindVertexArray (glVAO glp) - forM_ (glCommands glp) $ \cmd -> do +renderFrame GLRenderer{..} = do + writeIORef glForceSetup True + writeIORef glVertexBufferRef 0 + writeIORef glIndexBufferRef 0 + writeIORef glDrawCallCounterRef 0 + glBindVertexArray glVAO + forM_ glCommands $ \cmd -> do case cmd of - GLSetRasterContext rCtx -> setupRasterContext rCtx - GLSetAccumulationContext aCtx -> setupAccumulationContext aCtx - GLSetRenderTarget rt bufs -> do - -- set target viewport - --when (rt == 0) $ do -- screen out - ic' <- readIORef $ glInput glp - case ic' of - Nothing -> return () - Just ic -> do - let input = icInput ic - (w,h) <- readIORef $ screenSize input - glViewport 0 0 (fromIntegral w) (fromIntegral h) - -- TODO: set FBO target viewport - glBindFramebuffer GL_DRAW_FRAMEBUFFER rt - case bufs of - Nothing -> return () - Just bl -> withArray bl $ glDrawBuffers (fromIntegral $ length bl) - GLSetProgram p -> glUseProgram p - GLSetSamplerUniform i tu ref -> glUniform1i i tu >> writeIORef ref tu - GLSetTexture tu target tx -> glActiveTexture tu >> glBindTexture target tx - GLSetSampler tu s -> glBindSampler tu s - GLClearRenderTarget vals -> clearRenderTarget vals - GLGenerateMipMap tu target -> glActiveTexture tu >> glGenerateMipmap target - GLRenderStream streamIdx progIdx -> do - renderSlot =<< readIORef (glStreamCommands $ glStreams glp ! streamIdx) - GLRenderSlot slotIdx progIdx -> do - input <- readIORef (glInput glp) - case input of - Nothing -> putStrLn "Warning: No pipeline input!" >> return () - Just ic -> do - let draw obj = do - enabled <- readIORef $ objEnabled obj - when enabled $ do - cmd <- readIORef $ objCommands obj - --putStrLn "Render object" - renderSlot ((cmd ! icId ic) ! progIdx) - --putStrLn $ "Rendering " ++ show (V.length objs) ++ " objects" - readIORef (slotVector (icInput ic) ! (icSlotMapPipelineToInput ic ! slotIdx)) >>= \case - GLSlot _ objs Ordered -> forM_ objs $ draw . snd - GLSlot objMap _ _ -> forM_ objMap draw - {- - GLSetSampler - GLSaveImage - GLLoadImage - -} + GLClearRenderTarget rt vals -> do + setupRenderTarget glInput rt + clearRenderTarget vals + modifyIORef glDrawContextRef $ \ctx -> ctx {glRenderTarget = rt} + + GLRenderStream ctx streamIdx progIdx -> do + setupDrawContext glForceSetup glDrawContextRef glInput ctx + drawcmd <- readIORef (glStreamCommands $ glStreams ! streamIdx) + renderSlot glDrawCallCounterRef glVertexBufferRef glIndexBufferRef drawcmd + + GLRenderSlot ctx slotIdx progIdx -> do + input <- readIORef glInput + case input of + Nothing -> putStrLn "Warning: No pipeline input!" >> return () + Just ic -> do + let draw setupDone obj = readIORef (objEnabled obj) >>= \case + False -> return setupDone + True -> do + unless setupDone $ setupDrawContext glForceSetup glDrawContextRef glInput ctx + drawcmd <- readIORef $ objCommands obj + --putStrLn "Render object" + renderSlot glDrawCallCounterRef glVertexBufferRef glIndexBufferRef ((drawcmd ! icId ic) ! progIdx) + return True + --putStrLn $ "Rendering " ++ show (V.length objs) ++ " objects" + readIORef (slotVector (icInput ic) ! (icSlotMapPipelineToInput ic ! slotIdx)) >>= \case + GLSlot _ objs Ordered -> foldM_ (\a -> draw a . snd) False objs + GLSlot objMap _ _ -> foldM_ draw False objMap + --isOk <- checkGL --putStrLn $ isOk ++ " - " ++ show cmd + --readIORef glDrawCallCounterRef >>= \n -> putStrLn (show n ++ " draw calls") data CGState - = CGState - { currentProgram :: ProgramName - , textureBinding :: IntMap GLTexture - } + = CGState + { drawCommands :: [GLCommand] + -- draw context data + , rasterContext :: RasterContext + , accumulationContext :: AccumulationContext + , renderTarget :: GLRenderTarget + , currentProgram :: ProgramName + , samplerUniformMapping :: IntMap GLSamplerUniform + , textureMapping :: IntMap GLTexture + , samplerMapping :: IntMap GLSampler + } initCGState = CGState - { currentProgram = error "CGState: empty currentProgram" - , textureBinding = IM.empty - } + { drawCommands = mempty + -- draw context data + , rasterContext = error "compileCommand: missing RasterContext" + , accumulationContext = error "compileCommand: missing AccumulationContext" + , renderTarget = error "compileCommand: missing RenderTarget" + , currentProgram = error "compileCommand: missing Program" + , samplerUniformMapping = mempty + , textureMapping = mempty + , samplerMapping = mempty + } type CG a = State CGState a -compileCommand :: Map String (IORef GLint) -> Vector GLSampler -> Vector GLTexture -> Vector GLRenderTarget -> Vector GLProgram -> Command -> CG GLCommand +emit :: GLCommand -> CG () +emit cmd = modify $ \s -> s {drawCommands = cmd : drawCommands s} + +drawContext programs = do + GLProgram{..} <- (programs !) <$> gets currentProgram + let f = take (Set.size inputTextureUniforms) . IntMap.toList + GLDrawContext <$> gets rasterContext + <*> gets accumulationContext + <*> gets renderTarget + <*> pure programObject + <*> gets (f . textureMapping) + <*> gets (f . samplerMapping) + <*> gets (f . samplerUniformMapping) + +compileCommand :: Map String (IORef GLint) -> Vector GLSampler -> Vector GLTexture -> Vector GLRenderTarget -> Vector GLProgram -> Command -> CG () compileCommand texUnitMap samplers textures targets programs cmd = case cmd of - SetRasterContext rCtx -> return $ GLSetRasterContext rCtx - SetAccumulationContext aCtx -> return $ GLSetAccumulationContext aCtx - SetRenderTarget rt -> let GLRenderTarget fbo bufs = targets ! rt in return $ GLSetRenderTarget fbo bufs - SetProgram p -> do - modify (\s -> s {currentProgram = p}) - return $ GLSetProgram $ programObject $ programs ! p + SetRasterContext rCtx -> modify $ \s -> s {rasterContext = rCtx} + SetAccumulationContext aCtx -> modify $ \s -> s {accumulationContext = aCtx} + SetRenderTarget rt -> modify $ \s -> s {renderTarget = targets ! rt} + SetProgram p -> modify $ \s -> s {currentProgram = p} SetSamplerUniform n tu -> do p <- currentProgram <$> get case Map.lookup n (inputTextures $ programs ! p) of - Nothing -> return (GLSetProgram (programObject $ programs ! p) {-HACK!!! we have to emit something-}) -- TODO: some drivers does heavy cross stage (vertex/fragment) dead code elimination; fail $ "internal error (SetSamplerUniform)! - " ++ show cmd + Nothing -> return () -- TODO: some drivers does heavy cross stage (vertex/fragment) dead code elimination; fail $ "internal error (SetSamplerUniform)! - " ++ show cmd Just i -> case Map.lookup n texUnitMap of Nothing -> fail $ "internal error (SetSamplerUniform - IORef)! - " ++ show cmd - Just r -> return $ GLSetSamplerUniform i (fromIntegral tu) r - SetTexture tu t -> do - let tex = textures ! t - modify (\s -> s {textureBinding = IM.insert tu tex $ textureBinding s}) - return $ GLSetTexture (GL_TEXTURE0 + fromIntegral tu) (glTextureTarget tex) (glTextureObject tex) - SetSampler tu s -> return $ GLSetSampler (GL_TEXTURE0 + fromIntegral tu) (maybe 0 (glSamplerObject . (samplers !)) s) + Just r -> modify $ \s -> s {samplerUniformMapping = IntMap.insert tu (GLSamplerUniform i r) $ samplerUniformMapping s} + SetTexture tu t -> modify $ \s -> s {textureMapping = IntMap.insert tu (textures ! t) $ textureMapping s} + SetSampler tu i -> modify $ \s -> s {samplerMapping = IntMap.insert tu (maybe (GLSampler 0) (samplers !) i) $ samplerMapping s} + + -- draw commands RenderSlot slot -> do - p <- currentProgram <$> get - return $ GLRenderSlot slot p + p <- gets currentProgram + ctx <- drawContext programs + emit $ GLRenderSlot ctx slot p RenderStream stream -> do - p <- currentProgram <$> get - return $ GLRenderStream stream p - ClearRenderTarget vals -> return $ GLClearRenderTarget $ V.toList vals + p <- gets currentProgram + ctx <- drawContext programs + emit $ GLRenderStream ctx stream p + ClearRenderTarget vals -> do + rt <- gets renderTarget + emit $ GLClearRenderTarget rt $ V.toList vals +{- GenerateMipMap tu -> do tb <- textureBinding <$> get case IM.lookup tu tb of Nothing -> fail "internal error (GenerateMipMap)!" Just tex -> return $ GLGenerateMipMap (GL_TEXTURE0 + fromIntegral tu) (glTextureTarget tex) -{- - SaveImage _ _ -> undefined - LoadImage _ _ -> undefined -} diff --git a/src/LambdaCube/GL/Mesh.hs b/src/LambdaCube/GL/Mesh.hs --- a/src/LambdaCube/GL/Mesh.hs +++ b/src/LambdaCube/GL/Mesh.hs @@ -50,7 +50,7 @@ addMeshToObjectArray :: GLStorage -> String -> [String] -> GPUMesh -> IO Object addMeshToObjectArray input slotName objUniNames (GPUMesh _ (GPUData prim streams indices _)) = do -- select proper attributes - let (ObjectArraySchema slotPrim slotStreams) = fromMaybe (error $ "missing object array: " ++ slotName) $ Map.lookup slotName $! objectArrays $! schema input + let (ObjectArraySchema slotPrim slotStreams) = fromMaybe (error $ "addMeshToObjectArray - missing object array: " ++ slotName) $ Map.lookup slotName $! objectArrays $! schema input filterStream n _ = Map.member n slotStreams addObject input slotName prim indices (Map.filterWithKey filterStream streams) objUniNames diff --git a/src/LambdaCube/GL/Type.hs b/src/LambdaCube/GL/Type.hs --- a/src/LambdaCube/GL/Type.hs +++ b/src/LambdaCube/GL/Type.hs @@ -128,7 +128,7 @@ = GLTexture { glTextureObject :: GLuint , glTextureTarget :: GLenum - } + } deriving Eq data InputConnection = InputConnection @@ -159,34 +159,51 @@ , glVAO :: GLuint , glTexUnitMapping :: Map String (IORef GLint) -- maps texture uniforms to texture units , glStreams :: Vector GLStream + , glDrawContextRef :: IORef GLDrawContext + , glForceSetup :: IORef Bool + , glVertexBufferRef :: IORef GLuint + , glIndexBufferRef :: IORef GLuint + , glDrawCallCounterRef :: IORef Int } data GLSampler = GLSampler { glSamplerObject :: GLuint - } + } deriving Eq data GLRenderTarget = GLRenderTarget { framebufferObject :: GLuint , framebufferDrawbuffers :: Maybe [GLenum] - } + } deriving Eq +type GLTextureUnit = Int +type GLUniformBinding = GLint + +data GLSamplerUniform + = GLSamplerUniform + { glUniformBinding :: !GLUniformBinding + , glUniformBindingRef :: IORef GLUniformBinding + } + +instance Eq GLSamplerUniform where + a == b = glUniformBinding a == glUniformBinding b + +data GLDrawContext + = GLDrawContext + { glRasterContext :: !RasterContext + , glAccumulationContext :: !AccumulationContext + , glRenderTarget :: !GLRenderTarget + , glProgram :: !GLuint + , glTextureMapping :: ![(GLTextureUnit,GLTexture)] + , glSamplerMapping :: ![(GLTextureUnit,GLSampler)] + , glSamplerUniformMapping :: ![(GLTextureUnit,GLSamplerUniform)] + } + data GLCommand - = GLSetRasterContext !RasterContext - | GLSetAccumulationContext !AccumulationContext - | GLSetRenderTarget !GLuint !(Maybe [GLenum]) - | GLSetProgram !GLuint - | GLSetSamplerUniform !GLint !GLint (IORef GLint) -- sampler index, texture unit, IORef stores the actual texture unit mapping - | GLSetTexture !GLenum !GLuint !GLuint - | GLSetSampler !GLuint !GLuint - | GLRenderSlot !SlotName !ProgramName - | GLRenderStream !StreamName !ProgramName - | GLClearRenderTarget [ClearImage] - | GLGenerateMipMap !GLenum !GLenum - | GLSaveImage FrameBufferComponent ImageRef -- from framebuffer component to texture (image) - | GLLoadImage ImageRef FrameBufferComponent -- from texture (image) to framebuffer component - deriving Show + = GLRenderSlot !GLDrawContext !SlotName !ProgramName + | GLRenderStream !GLDrawContext !StreamName !ProgramName + | GLClearRenderTarget !GLRenderTarget ![ClearImage] instance Show (IORef GLint) where show _ = "(IORef GLint)"