{-# LANGUAGE TupleSections, MonadComprehensions, ViewPatterns #-} module Backend.GL.Backend where import Control.Applicative import Control.Monad import Control.Monad.State import Data.Bits import Data.ByteString.Char8 (ByteString,pack) import Data.IORef import Data.IntMap (IntMap) import Data.Maybe (isNothing,fromJust) import Data.Set (Set) import Data.Trie as T import Data.Trie.Convenience as T import Data.Vector (Vector,(!),(//)) import qualified Data.ByteString.Char8 as SB import qualified Data.Foldable as F import qualified Data.IntMap as IM import qualified Data.Map as Map import qualified Data.List as L import qualified Data.Set as S import qualified Data.Vector as V import qualified Data.Vector.Storable as SV import Graphics.Rendering.OpenGL.Raw.Core33 import Foreign -- LC IR imports import Linear import IR hiding (streamType) import qualified IR as IR import Backend.GL.Type import Backend.GL.Util import Backend.GL.Data import Backend.GL.Input setupRasterContext :: RasterContext -> IO () setupRasterContext = cvt where cff :: FrontFace -> GLenum cff CCW = gl_CCW cff CW = gl_CW setProvokingVertex :: ProvokingVertex -> IO () setProvokingVertex pv = glProvokingVertex $ case pv of FirstVertex -> gl_FIRST_VERTEX_CONVENTION LastVertex -> gl_LAST_VERTEX_CONVENTION setPointSize :: PointSize -> IO () setPointSize ps = case ps of ProgramPointSize -> glEnable gl_PROGRAM_POINT_SIZE PointSize s -> do glDisable gl_PROGRAM_POINT_SIZE glPointSize $ realToFrac s cvt :: RasterContext -> IO () cvt (PointCtx ps fts sc) = do setPointSize ps glPointParameterf gl_POINT_FADE_THRESHOLD_SIZE (realToFrac fts) glPointParameterf gl_POINT_SPRITE_COORD_ORIGIN $ realToFrac $ case sc of LowerLeft -> gl_LOWER_LEFT UpperLeft -> gl_UPPER_LEFT cvt (LineCtx lw pv) = do glLineWidth (realToFrac lw) setProvokingVertex pv cvt (TriangleCtx cm pm po pv) = do -- cull mode case cm of CullNone -> glDisable gl_CULL_FACE CullFront f -> do glEnable gl_CULL_FACE glCullFace gl_FRONT glFrontFace $ cff f CullBack f -> do glEnable gl_CULL_FACE glCullFace gl_BACK glFrontFace $ cff f -- polygon mode case pm of PolygonPoint ps -> do setPointSize ps glPolygonMode gl_FRONT_AND_BACK gl_POINT PolygonLine lw -> do glLineWidth (realToFrac lw) glPolygonMode gl_FRONT_AND_BACK gl_LINE PolygonFill -> glPolygonMode gl_FRONT_AND_BACK gl_FILL -- polygon offset glDisable gl_POLYGON_OFFSET_POINT glDisable gl_POLYGON_OFFSET_LINE glDisable gl_POLYGON_OFFSET_FILL case po of NoOffset -> return () Offset f u -> do glPolygonOffset (realToFrac f) (realToFrac u) glEnable $ case pm of PolygonPoint _ -> gl_POLYGON_OFFSET_POINT PolygonLine _ -> gl_POLYGON_OFFSET_LINE PolygonFill -> gl_POLYGON_OFFSET_FILL -- provoking vertex setProvokingVertex pv setupAccumulationContext :: AccumulationContext -> IO () setupAccumulationContext (AccumulationContext n ops) = cvt ops where cvt :: [FragmentOperation] -> IO () cvt (StencilOp a b c : DepthOp f m : xs) = do -- TODO cvtC 0 xs cvt (StencilOp a b c : xs) = do -- TODO cvtC 0 xs cvt (DepthOp df dm : xs) = do -- TODO glDisable gl_STENCIL_TEST case df == Always && dm == False of True -> glDisable gl_DEPTH_TEST False -> do glEnable gl_DEPTH_TEST glDepthFunc $! comparisonFunctionToGLType df glDepthMask (cvtBool dm) cvtC 0 xs cvt xs = do glDisable gl_DEPTH_TEST glDisable gl_STENCIL_TEST cvtC 0 xs cvtC :: Int -> [FragmentOperation] -> IO () cvtC i (ColorOp b m : xs) = do -- TODO case b of NoBlending -> do -- FIXME: requires GL 3.1 --glDisablei gl_BLEND $ fromIntegral gl_DRAW_BUFFER0 + fromIntegral i glDisable gl_BLEND -- workaround glDisable gl_COLOR_LOGIC_OP BlendLogicOp op -> do glDisable gl_BLEND glEnable gl_COLOR_LOGIC_OP glLogicOp $ logicOperationToGLType op Blend cEq aEq scF dcF saF daF (V4 r g b a) -> do glDisable gl_COLOR_LOGIC_OP -- FIXME: requires GL 3.1 --glEnablei gl_BLEND $ fromIntegral gl_DRAW_BUFFER0 + fromIntegral i glEnable gl_BLEND -- workaround glBlendEquationSeparate (blendEquationToGLType cEq) (blendEquationToGLType aEq) glBlendFuncSeparate (blendingFactorToGLType scF) (blendingFactorToGLType dcF) (blendingFactorToGLType saF) (blendingFactorToGLType daF) glBlendColor (realToFrac r) (realToFrac g) (realToFrac b) (realToFrac a) let cvt True = 1 cvt False = 0 (mr,mg,mb,ma) = case m of VBool r -> (cvt r, 1, 1, 1) VV2B (V2 r g) -> (cvt r, cvt g, 1, 1) VV3B (V3 r g b) -> (cvt r, cvt g, cvt b, 1) VV4B (V4 r g b a) -> (cvt r, cvt g, cvt b, cvt a) _ -> (1,1,1,1) glColorMask mr mg mb ma cvtC (i + 1) xs cvtC _ [] = return () cvtBool :: Bool -> GLboolean cvtBool True = 1 cvtBool False = 0 clearRenderTarget :: [ClearImage] -> IO () clearRenderTarget values = do let setClearValue (m,i) value = case value of ClearImage Depth (VFloat v) -> do glDepthMask 1 glClearDepth $ realToFrac v return (m .|. gl_DEPTH_BUFFER_BIT, i) ClearImage Stencil (VWord v) -> do glClearStencil $ fromIntegral v return (m .|. gl_STENCIL_BUFFER_BIT, i) ClearImage Color c -> do let (r,g,b,a) = case c of VFloat r -> (realToFrac r, 0, 0, 1) VV2F (V2 r g) -> (realToFrac r, realToFrac g, 0, 1) VV3F (V3 r g b) -> (realToFrac r, realToFrac g, realToFrac b, 1) VV4F (V4 r g b a) -> (realToFrac r, realToFrac g, realToFrac b, realToFrac a) _ -> (0,0,0,1) glColorMask 1 1 1 1 glClearColor r g b a return (m .|. gl_COLOR_BUFFER_BIT, i+1) _ -> error "internal error (clearRenderTarget)" (mask,_) <- foldM setClearValue (0,0) values glClear $ fromIntegral mask printGLStatus = checkGL >>= print printFBOStatus = checkFBO >>= print compileProgram :: Trie InputType -> Program -> IO GLProgram compileProgram uniTrie p = do po <- glCreateProgram putStrLn $ "compile program: " ++ show po let createAndAttach src t = do o <- glCreateShader t compileShader o $ map pack [src] glAttachShader po o putStr " + compile shader source: " >> printGLStatus return o objs <- sequence $ createAndAttach (vertexShader p) gl_VERTEX_SHADER : createAndAttach (fragmentShader p) gl_FRAGMENT_SHADER : case geometryShader p of Nothing -> [] Just s -> [createAndAttach s gl_GEOMETRY_SHADER] forM_ (zip (V.toList $ programOutput p) [0..]) $ \(Parameter (pack -> n) t,i) -> SB.useAsCString n $ \pn -> do putStrLn ("variable " ++ show n ++ " attached to color number #" ++ show i) glBindFragDataLocation po i $ castPtr pn putStr " + setup shader output mapping: " >> printGLStatus glLinkProgram po printProgramLog po -- check link status status <- glGetProgramiv1 gl_LINK_STATUS po when (status /= fromIntegral gl_TRUE) $ fail "link program failed!" -- check program input (uniforms,uniformsType) <- queryUniforms po (attributes,attributesType) <- queryStreams po print uniforms print attributes let lcUniforms = (toTrie $ programUniforms p) `unionL` (toTrie $ programInTextures p) lcStreams = fmap ty (toTrie $ programStreams p) check a m = and $ map go $ T.toList m where go (k,b) = case T.lookup k a of Nothing -> True Just x -> x == b unless (check lcUniforms uniformsType) $ do putStrLn $ "expected: " ++ show lcUniforms putStrLn $ "actual: " ++ show uniformsType fail "shader program uniform input mismatch!" unless (check lcStreams attributesType) $ fail $ "shader program stream input mismatch! " ++ show (attributesType,lcStreams) -- the public (user) pipeline and program input is encoded by the slots, therefore the programs does not distinct the render and slot textures input let inUniNames = toTrie $ programUniforms p (inUniforms,inTextures) = L.partition (\(n,v) -> T.member n inUniNames) $ T.toList $ uniforms texUnis = [n | (n,_) <- inTextures, T.member n uniTrie] return $ GLProgram { shaderObjects = objs , programObject = po , inputUniforms = T.fromList inUniforms , inputTextures = T.fromList inTextures , inputTextureUniforms = S.fromList $ texUnis , inputStreams = T.fromList [(n,(idx, pack attrName)) | ((n,idx),(_,(Parameter attrName _))) <- zip (T.toList $ attributes) (T.toList $ toTrie $ programStreams p)] } compileSampler :: SamplerDescriptor -> IO GLSampler compileSampler s = return $ GLSampler {} {- data ImageIndex = TextureImage TextureName Int (Maybe Int) -- Texture name, mip index, array index | Framebuffer ImageSemantic data ImageSemantic = Depth | Stencil | Color -} {- = RenderTarget { renderTargets :: [(ImageSemantic,Maybe ImageIndex)] -- render texture or default framebuffer (semantic, render texture for the program output) } -} {- glDrawBuffers GL_NONE --GL_FRONT_LEFT --GL_FRONT_RIGHT GL_BACK_LEFT --GL_BACK_RIGHT GL_COLOR_ATTACHMENTn -} compileRenderTarget :: Vector TextureDescriptor -> Vector GLTexture -> RenderTarget -> IO GLRenderTarget compileRenderTarget texs glTexs (RenderTarget targets) = do let isFB (Framebuffer _) = True isFB _ = False images = [img | TargetItem _ (Just img) <- V.toList targets] case all isFB images of True -> do let bufs = [cvt img | TargetItem Color img <- V.toList targets] cvt a = case a of Nothing -> gl_NONE Just (Framebuffer Color) -> gl_BACK_LEFT _ -> error "internal error (compileRenderTarget)!" return $ GLRenderTarget { framebufferObject = 0 , framebufferDrawbuffers = Just bufs } False -> do when (any isFB images) $ fail "internal error (compileRenderTarget)!" fbo <- alloca $! \pbo -> glGenFramebuffers 1 pbo >> peek pbo glBindFramebuffer gl_DRAW_FRAMEBUFFER fbo {- void glFramebufferTexture1D(GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level); GL_TEXTURE_1D void glFramebufferTexture2D(GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level); GL_TEXTURE_2D GL_TEXTURE_RECTANGLE GL_TEXTURE_CUBE_MAP_POSITIVE_X GL_TEXTURE_CUBE_MAP_POSITIVE_Y GL_TEXTURE_CUBE_MAP_POSITIVE_Z GL_TEXTURE_CUBE_MAP_NEGATIVE_X GL_TEXTURE_CUBE_MAP_NEGATIVE_Y GL_TEXTURE_CUBE_MAP_NEGATIVE_Z GL_TEXTURE_2D_MULTISAMPLE void glFramebufferTextureLayer(GLenum target, GLenum attachment, GLuint texture, GLint level, GLint layer); void glFramebufferRenderbuffer(GLenum target, GLenum attachment, GLenum renderbuffertarget, GLuint renderbuffer); void glFramebufferTexture(GLenum target, GLenum attachment, GLuint texture, GLint level); -} let attach attachment (TextureImage texIdx level (Just layer)) = glFramebufferTextureLayer gl_DRAW_FRAMEBUFFER attachment (glTextureTarget $ glTexs ! texIdx) (fromIntegral level) (fromIntegral layer) attach attachment (TextureImage texIdx level Nothing) = do let glTex = glTexs ! texIdx tex = texs ! texIdx txLevel = fromIntegral level txTarget = glTextureTarget glTex txObj = glTextureObject glTex attachArray = glFramebufferTexture gl_DRAW_FRAMEBUFFER attachment txObj txLevel attach2D = glFramebufferTexture2D gl_DRAW_FRAMEBUFFER attachment txTarget txObj txLevel case textureType tex of Texture1D _ n | n > 1 -> attachArray | otherwise -> glFramebufferTexture1D gl_DRAW_FRAMEBUFFER attachment txTarget txObj txLevel Texture2D _ n | n > 1 -> attachArray | otherwise -> attach2D Texture3D _ -> attachArray TextureCube _ -> attachArray TextureRect _ -> attach2D Texture2DMS _ n _ _ | n > 1 -> attachArray | otherwise -> attach2D TextureBuffer _ -> fail "internalError (compileRenderTarget/TextureBuffer)!" go a (TargetItem Stencil (Just img)) = do fail "Stencil support is not implemented yet!" return a go a (TargetItem Depth (Just img)) = do attach gl_DEPTH_ATTACHMENT img return a go (bufs,colorIdx) (TargetItem Color (Just img)) = do let attachment = gl_COLOR_ATTACHMENT0 + fromIntegral colorIdx attach attachment img return (attachment : bufs, colorIdx + 1) go (bufs,colorIdx) (TargetItem Color Nothing) = return (gl_NONE : bufs, colorIdx + 1) go a _ = return a (bufs,_) <- foldM go ([],0) targets withArray (reverse bufs) $ glDrawBuffers (fromIntegral $ length bufs) return $ GLRenderTarget { framebufferObject = fbo , framebufferDrawbuffers = Nothing } compileStreamData :: StreamData -> IO GLStream compileStreamData s = do let withV w a f = w a (\p -> f $ castPtr p) let compileAttr (VFloatArray v) = Array ArrFloat (V.length v) (withV (SV.unsafeWith . V.convert) v) compileAttr (VIntArray v) = Array ArrInt32 (V.length v) (withV (SV.unsafeWith . V.convert) v) compileAttr (VWordArray v) = Array ArrWord32 (V.length v) (withV (SV.unsafeWith . V.convert) v) --TODO: compileAttr (VBoolArray v) = Array ArrWord32 (length v) (withV withArray v) (indexMap,arrays) = unzip [((n,i),compileAttr d) | (i,(n,d)) <- zip [0..] $ Map.toList $ streamData s] getLength n = l `div` c where l = case Map.lookup n $ IR.streamData s of Just (VFloatArray v) -> V.length v Just (VIntArray v) -> V.length v Just (VWordArray v) -> V.length v _ -> error "compileStreamData - getLength" c = case Map.lookup n $ IR.streamType s of Just Bool -> 1 Just V2B -> 2 Just V3B -> 3 Just V4B -> 4 Just Word -> 1 Just V2U -> 2 Just V3U -> 3 Just V4U -> 4 Just Int -> 1 Just V2I -> 2 Just V3I -> 3 Just V4I -> 4 Just Float -> 1 Just V2F -> 2 Just V3F -> 3 Just V4F -> 4 Just M22F -> 4 Just M23F -> 6 Just M24F -> 8 Just M32F -> 6 Just M33F -> 9 Just M34F -> 12 Just M42F -> 8 Just M43F -> 12 Just M44F -> 16 _ -> error "compileStreamData - getLength element count" buffer <- compileBuffer arrays cmdRef <- newIORef [] let toStream (n,i) = (n,Stream { streamType = fromJust $ toStreamType =<< Map.lookup n (IR.streamType s) , streamBuffer = buffer , streamArrIdx = i , streamStart = 0 , streamLength = getLength n }) return $ GLStream { glStreamCommands = cmdRef , glStreamPrimitive = case streamPrimitive s of Points -> PointList Lines -> LineList Triangles -> TriangleList LinesAdjacency -> LineListAdjacency TrianglesAdjacency -> TriangleListAdjacency , glStreamAttributes = toTrie $ Map.fromList $ map toStream indexMap , glStreamProgram = V.head $ streamPrograms s } createStreamCommands :: Trie (IORef GLint) -> Trie GLUniform -> Trie (Stream Buffer) -> Primitive -> GLProgram -> [GLObjectCommand] createStreamCommands texUnitMap topUnis attrs primitive prg = streamUniCmds ++ streamCmds ++ [drawCmd] where -- object draw command drawCmd = GLDrawArrays prim 0 (fromIntegral count) where prim = primitiveToGLType primitive count = head [c | Stream _ _ _ _ c <- T.elems attrs] -- object uniform commands -- texture slot setup commands streamUniCmds = uniCmds ++ texCmds where uniCmds = [GLSetUniform i u | (n,i) <- uniMap, let u = topUni n] uniMap = T.toList $ inputUniforms prg topUni n = T.lookupWithDefault (error "internal error (createStreamCommands)!") n topUnis texUnis = S.toList $ inputTextureUniforms prg texCmds = [ GLBindTexture (inputTypeToTextureTarget $ uniInputType u) texUnit u | n <- texUnis , let u = topUni n , let texUnit = T.lookupWithDefault (error "internal error (createStreamCommands - Texture Unit)") n texUnitMap ] uniInputType (GLUniform ty _) = ty -- object attribute stream commands streamCmds = [attrCmd i s | (i,name) <- T.elems attrMap, let Just s = T.lookup name attrs] where attrMap = inputStreams prg attrCmd i s = case s of Stream ty (Buffer arrs bo) arrIdx start len -> case ty of TWord -> setIntAttrib 1 TV2U -> setIntAttrib 2 TV3U -> setIntAttrib 3 TV4U -> setIntAttrib 4 TInt -> setIntAttrib 1 TV2I -> setIntAttrib 2 TV3I -> setIntAttrib 3 TV4I -> setIntAttrib 4 TFloat -> setFloatAttrib 1 TV2F -> setFloatAttrib 2 TV3F -> setFloatAttrib 3 TV4F -> setFloatAttrib 4 TM22F -> setFloatAttrib 4 TM23F -> setFloatAttrib 6 TM24F -> setFloatAttrib 8 TM32F -> setFloatAttrib 6 TM33F -> setFloatAttrib 9 TM34F -> setFloatAttrib 12 TM42F -> setFloatAttrib 8 TM43F -> setFloatAttrib 12 TM44F -> setFloatAttrib 16 where setFloatAttrib n = GLSetVertexAttribArray i bo n glType (ptr n) setIntAttrib n = GLSetVertexAttribIArray i bo n glType (ptr n) ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx glType = arrayTypeToGLType arrType ptr compCnt = intPtrToPtr $! fromIntegral (arrOffs + start * fromIntegral compCnt * sizeOfArrayType arrType) -- constant generic attribute constAttr -> GLSetVertexAttrib i constAttr allocPipeline :: Pipeline -> IO GLPipeline allocPipeline p = do let uniTrie = uniforms $ schemaFromPipeline p smps <- V.mapM compileSampler $ samplers p texs <- V.mapM compileTexture $ textures p trgs <- V.mapM (compileRenderTarget (textures p) texs) $ targets p prgs <- V.mapM (compileProgram uniTrie) $ programs p -- texture unit mapping ioref trie texUnitMapRefs <- T.fromList <$> mapM (\k -> (k,) <$> newIORef 0) (S.toList $ S.fromList $ concat $ V.toList $ V.map (T.keys . toTrie . programInTextures) $ programs p) let (cmds,st) = runState (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 return $ GLPipeline { glPrograms = prgs , glTextures = texs , glSamplers = smps , glTargets = trgs , glCommands = cmds , glSlotPrograms = V.map (V.toList . slotPrograms) $ IR.slots p , glInput = input , glSlotNames = V.map (pack . slotName) $ IR.slots p , glVAO = vao , glTexUnitMapping = texUnitMapRefs , glStreams = strs } disposePipeline :: GLPipeline -> IO () disposePipeline p = do setPipelineInput p Nothing V.forM_ (glPrograms p) $ \prg -> do glDeleteProgram $ programObject prg mapM_ glDeleteShader $ shaderObjects prg let targets = glTargets p withArray (map framebufferObject $ V.toList targets) $ (glDeleteFramebuffers $ fromIntegral $ V.length targets) let textures = glTextures p withArray (map glTextureObject $ V.toList textures) $ (glDeleteTextures $ fromIntegral $ V.length textures) with (glVAO p) $ (glDeleteVertexArrays 1) {- data SlotSchema = SlotSchema { primitive :: FetchPrimitive , attributes :: Trie StreamType } deriving Show data PipelineSchema = PipelineSchema { slots :: Trie SlotSchema , uniforms :: Trie InputType } deriving Show -} isSubTrie :: (a -> a -> Bool) -> Trie a -> Trie a -> Bool isSubTrie eqFun universe subset = and [isMember a (T.lookup n universe) | (n,a) <- T.toList subset] where isMember a Nothing = False isMember a (Just b) = eqFun a b -- TODO: if there is a mismatch thow detailed error message in the excoeption, containing the missing attributes and uniforms {- let sch = schema input forM_ uniformNames $ \n -> case T.lookup n (uniforms sch) of Nothing -> throw $ userError $ "Unknown uniform: " ++ show n _ -> return () case T.lookup slotName (slots sch) of Nothing -> throw $ userError $ "Unknown slot: " ++ show slotName Just (SlotSchema sPrim sAttrs) -> do when (sPrim /= (primitiveToFetchPrimitive prim)) $ throw $ userError $ "Primitive mismatch for slot (" ++ show slotName ++ ") expected " ++ show sPrim ++ " but got " ++ show prim let sType = fmap streamToStreamType attribs when (sType /= sAttrs) $ throw $ userError $ unlines $ [ "Attribute stream mismatch for slot (" ++ show slotName ++ ") expected " , show sAttrs , " but got " , show sType ] -} setPipelineInput :: GLPipeline -> Maybe GLPipelineInput -> IO () setPipelineInput p input' = do -- TODO: check matching input schema {- case input' of Nothing -> return () Just input -> schemaFromPipeline p -} {- deletion: - remove pipeline's object commands from used slots - remove pipeline from attached pipelines vector -} ic' <- readIORef $ glInput p case ic' of Nothing -> return () Just ic -> do let idx = icId ic oldInput = icInput ic slotMask = icSlotMapPipelineToInput ic slotRefs = slotVector oldInput modifyIORef (pipelines oldInput) $ \v -> v // [(idx,Nothing)] V.forM_ slotMask $ \slotIdx -> do slot <- readIORef (slotRefs ! slotIdx) forM_ (IM.elems $ objectMap slot) $ \obj -> do modifyIORef (objCommands obj) $ \v -> v // [(idx,V.empty)] {- addition: - get an id from pipeline input - add to attached pipelines - generate slot mappings - update used slots, and generate object commands for objects in the related slots -} case input' of Nothing -> writeIORef (glInput p) Nothing Just input -> do let pipelinesRef = pipelines input oldPipelineV <- readIORef pipelinesRef (idx,shouldExtend) <- case V.findIndex isNothing oldPipelineV of Nothing -> do -- we don't have empty space, hence we double the vector size let len = V.length oldPipelineV modifyIORef pipelinesRef $ \v -> (V.concat [v,V.replicate len Nothing]) // [(len,Just p)] return (len,Just len) Just i -> do modifyIORef pipelinesRef $ \v -> v // [(i,Just p)] return (i,Nothing) -- create input connection let sm = slotMap input pToI = [i | n <- glSlotNames p, let Just i = T.lookup n sm] iToP = V.update (V.replicate (T.size sm) Nothing) (V.imap (\i v -> (v, Just i)) pToI) writeIORef (glInput p) $ Just $ InputConnection idx input pToI iToP -- generate object commands for related slots {- for each slot in pipeline: map slot name to input slot name for each object: generate command program vector => for each dependent program: generate object commands -} let slotV = slotVector input progV = glPrograms p texUnitMap = glTexUnitMapping p topUnis = uniformSetup input emptyV = V.replicate (V.length progV) [] extend v = case shouldExtend of Nothing -> v Just l -> V.concat [v,V.replicate l V.empty] V.forM_ (V.zip pToI (glSlotPrograms p)) $ \(slotIdx,prgs) -> do slot <- readIORef $ slotV ! slotIdx forM_ (IM.elems $ objectMap slot) $ \obj -> do let cmdV = emptyV // [(prgIdx,createObjectCommands texUnitMap topUnis obj (progV ! prgIdx)) | prgIdx <- prgs] modifyIORef (objCommands obj) $ \v -> extend v // [(idx,cmdV)] -- generate stream commands V.forM_ (glStreams p) $ \s -> do writeIORef (glStreamCommands s) $ createStreamCommands texUnitMap topUnis (glStreamAttributes s) (glStreamPrimitive s) (progV ! glStreamProgram s) {- track state: - render target - binded textures -} {- render steps: - update uniforms - per uniform setup - buffer setup (one buffer per object, which has per at least one object uniform) - new command: set uniform buffer (binds uniform buffer to program's buffer slot) - render slot steps: - set uniform buffer or set uniforms separately - set vertex and index array - call draw command -} {- storage alternatives: - interleaved / separated - VAO or VBOs -} {- strategy: step 1: generate commands for an object step 2: sort object merge and do optimization by filtering redundant commands -} {- design: runtime eleminiation of redundant buffer bind commands and redundant texture bind commands -} {- track: buffer binding on various targets: gl_ARRAY_BUFFER, GL_ELEMENT_ARRAY_BUFFER glEnable/DisableVertexAttribArray -} renderSlot :: [GLObjectCommand] -> IO () renderSlot cmds = forM_ cmds $ \cmd -> do case cmd of GLSetVertexAttribArray idx buf size typ ptr -> do 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 glEnableVertexAttribArray idx glVertexAttribIPointer idx size typ 0 ptr GLDrawArrays mode first count -> glDrawArrays mode first count GLDrawElements mode count typ buf indicesPtr -> do glBindBuffer gl_ELEMENT_ARRAY_BUFFER buf glDrawElements mode count typ indicesPtr GLSetUniform idx (GLUniform ty ref) -> setUniform idx ty ref GLBindTexture txTarget tuRef (GLUniform _ ref) -> do txObjVal <- readIORef ref -- HINT: ugly and hacky with txObjVal $ \txObjPtr -> do txObj <- peek $ castPtr txObjPtr :: IO GLuint texUnit <- readIORef tuRef glActiveTexture $ gl_TEXTURE0 + fromIntegral texUnit glBindTexture txTarget txObj GLSetVertexAttrib idx val -> do glDisableVertexAttribArray idx setVertexAttrib idx val --isOk <- checkGL --putStrLn $ SB.unpack isOk ++ " - " ++ show cmd renderPipeline :: GLPipeline -> IO () renderPipeline glp = do glBindVertexArray (glVAO glp) forM_ (glCommands glp) $ \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 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 GLSlot _ objs _ <- readIORef (slotVector (icInput ic) ! (icSlotMapPipelineToInput ic ! slotIdx)) --putStrLn $ "Rendering " ++ show (V.length objs) ++ " objects" V.forM_ objs $ \(_,obj) -> do enabled <- readIORef $ objEnabled obj when enabled $ do cmd <- readIORef $ objCommands obj --putStrLn "Render object" renderSlot ((cmd ! icId ic) ! progIdx) {- GLSetSampler GLSaveImage GLLoadImage -} --isOk <- checkGL --putStrLn $ SB.unpack isOk ++ " - " ++ show cmd data CGState = CGState { currentProgram :: ProgramName , textureBinding :: IntMap GLTexture } initCGState = CGState { currentProgram = error "CGState: empty currentProgram" , textureBinding = IM.empty } type CG a = State CGState a compileCommand :: Trie (IORef GLint) -> Vector GLSampler -> Vector GLTexture -> Vector GLRenderTarget -> Vector GLProgram -> Command -> CG GLCommand 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 SetSamplerUniform n tu -> do p <- currentProgram <$> get case T.lookup (pack n) (inputTextures $ programs ! p) of Nothing -> fail "internal error (SetSamplerUniform)!" Just i -> case T.lookup (pack n) texUnitMap of Nothing -> fail "internal error (SetSamplerUniform - IORef)!" 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 -> liftIO $ do glBindSampler (fromIntegral tu) (samplerObject $ glSamplers glp ! s) -} RenderSlot slot -> do p <- currentProgram <$> get return $ GLRenderSlot slot p RenderStream stream -> do p <- currentProgram <$> get return $ GLRenderStream stream p ClearRenderTarget vals -> return $ GLClearRenderTarget $ 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 -}