module LambdaCube.GL.Backend where
import Control.Applicative
import Control.Monad
import Control.Monad.State.Strict
import Data.Maybe
import Data.Bits
import Data.IORef
import Data.IntMap (IntMap)
import Data.Maybe (isNothing,fromJust)
import Data.Map (Map)
import Data.Set (Set)
import Data.Vector (Vector,(!),(//))
import qualified Data.Foldable as F
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import qualified Data.List as L
import qualified Data.Set as Set
import qualified Data.Vector as V
import qualified Data.Vector.Storable as SV
import Graphics.GL.Core33
import Foreign
import Foreign.C.String
import LambdaCube.PipelineSchema
import LambdaCube.Linear
import LambdaCube.IR hiding (streamType)
import qualified LambdaCube.IR as IR
import LambdaCube.GL.Type
import LambdaCube.GL.Util
import LambdaCube.GL.Data
import LambdaCube.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
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
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
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
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
cvtC 0 xs
cvt (StencilOp a b c : xs) = do
cvtC 0 xs
cvt (DepthOp df dm : xs) = do
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
case b of
NoBlending -> do
glDisable GL_BLEND
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
glEnable GL_BLEND
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 :: Program -> IO GLProgram
compileProgram p = do
po <- glCreateProgram
let createAndAttach src t = do
o <- glCreateShader t
compileShader o [src]
glAttachShader po o
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 n t,i) -> withCString n $ \pn -> do
glBindFragDataLocation po i $ castPtr pn
glLinkProgram po
log <- printProgramLog po
status <- glGetProgramiv1 GL_LINK_STATUS po
when (status /= fromIntegral GL_TRUE) $ fail $ unlines ["link program failed:",log]
(uniforms,uniformsType) <- queryUniforms po
(attributes,attributesType) <- queryStreams po
let lcUniforms = (programUniforms p) `Map.union` (programInTextures p)
lcStreams = fmap ty (programStreams p)
check a m = and $ map go $ Map.toList m
where go (k,b) = case Map.lookup k a of
Nothing -> False
Just x -> x == b
unless (check lcUniforms uniformsType) $ fail $ unlines
[ "shader program uniform input mismatch!"
, "expected: " ++ show lcUniforms
, "actual: " ++ show uniformsType
]
unless (check lcStreams attributesType) $ fail $ "shader program stream input mismatch! " ++ show (attributesType,lcStreams)
let inUniNames = programUniforms p
inUniforms = L.filter (\(n,v) -> Map.member n inUniNames) $ Map.toList $ uniforms
inTextureNames = programInTextures p
inTextures = L.filter (\(n,v) -> Map.member n inTextureNames) $ Map.toList $ uniforms
texUnis = [n | (n,_) <- inTextures, Map.member n (programUniforms p)]
let prgInTextures = Map.keys inTextureNames
uniInTextures = map fst inTextures
let valA = Map.toList $ attributes
valB = Map.toList $ programStreams p
let lcStreamName = fmap name (programStreams p)
return $ GLProgram
{ shaderObjects = objs
, programObject = po
, inputUniforms = Map.fromList inUniforms
, inputTextures = Map.fromList inTextures
, 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]
}
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
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)
(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 = fromMaybe (error $ "missing attribute: " ++ n) $ 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 = Map.fromList $ map toStream indexMap
, glStreamProgram = V.head $ streamPrograms s
}
createStreamCommands :: Map String (IORef GLint) -> Map String GLUniform -> Map String (Stream Buffer) -> Primitive -> GLProgram -> [GLObjectCommand]
createStreamCommands texUnitMap topUnis attrs primitive prg = streamUniCmds ++ streamCmds ++ [drawCmd]
where
drawCmd = GLDrawArrays prim 0 (fromIntegral count)
where
prim = primitiveToGLType primitive
count = head [c | Stream _ _ _ _ c <- Map.elems attrs]
streamUniCmds = uniCmds ++ texCmds
where
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 = Set.toList $ inputTextureUniforms prg
texCmds = [ GLBindTexture (inputTypeToTextureTarget $ uniInputType u) texUnit u
| n <- texUnis
, let u = topUni n
, let texUnit = Map.findWithDefault (error "internal error (createStreamCommands - Texture Unit)") n texUnitMap
]
uniInputType (GLUniform ty _) = ty
streamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let s = fromMaybe (error $ "missing attribute: " ++ name) $ Map.lookup name attrs]
where
attrMap = inputStreams prg
attrCmd i s = case s of
Stream ty (Buffer arrs bo) arrIdx start len -> case ty of
Attribute_Word -> setIntAttrib 1
Attribute_V2U -> setIntAttrib 2
Attribute_V3U -> setIntAttrib 3
Attribute_V4U -> setIntAttrib 4
Attribute_Int -> setIntAttrib 1
Attribute_V2I -> setIntAttrib 2
Attribute_V3I -> setIntAttrib 3
Attribute_V4I -> setIntAttrib 4
Attribute_Float -> setFloatAttrib 1
Attribute_V2F -> setFloatAttrib 2
Attribute_V3F -> setFloatAttrib 3
Attribute_V4F -> setFloatAttrib 4
Attribute_M22F -> setFloatAttrib 4
Attribute_M23F -> setFloatAttrib 6
Attribute_M24F -> setFloatAttrib 8
Attribute_M32F -> setFloatAttrib 6
Attribute_M33F -> setFloatAttrib 9
Attribute_M34F -> setFloatAttrib 12
Attribute_M42F -> setFloatAttrib 8
Attribute_M43F -> setFloatAttrib 12
Attribute_M44F -> 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)
constAttr -> GLSetVertexAttrib i constAttr
allocRenderer :: Pipeline -> IO GLRenderer
allocRenderer p = do
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 $ programs p
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
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 = 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 ()
disposeRenderer p = do
setStorage' 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)
let samplers = glSamplers p
withArray (map glSamplerObject $ V.toList samplers) $ (glDeleteSamplers . fromIntegral . V.length $ glSamplers p)
with (glVAO p) $ (glDeleteVertexArrays 1)
isSubTrie :: (a -> a -> Bool) -> Map String a -> Map String a -> Bool
isSubTrie eqFun universe subset = and [isMember a (Map.lookup n universe) | (n,a) <- Map.toList subset]
where
isMember a Nothing = False
isMember a (Just b) = eqFun a b
setStorage :: GLRenderer -> GLStorage -> IO (Maybe String)
setStorage p input' = setStorage' p (Just input')
setStorage' :: GLRenderer -> Maybe GLStorage -> IO (Maybe String)
setStorage' p@GLRenderer{..} input' = do
readIORef glInput >>= \case
Nothing -> return ()
Just InputConnection{..} -> do
let slotRefs = slotVector icInput
modifyIORef (pipelines icInput) $ \v -> v // [(icId,Nothing)]
V.forM_ icSlotMapPipelineToInput $ \slotIdx -> do
slot <- readIORef (slotRefs ! slotIdx)
forM_ (objectMap slot) $ \obj -> do
modifyIORef (objCommands obj) $ \v -> v // [(icId,V.empty)]
case input' of
Nothing -> writeIORef glInput Nothing >> return Nothing
Just input -> do
let pipelinesRef = pipelines input
oldPipelineV <- readIORef pipelinesRef
(idx,shouldExtend) <- case V.findIndex isNothing oldPipelineV of
Nothing -> do
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)
let sm = slotMap input
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
let slotV = slotVector input
progV = glPrograms
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) $ \(slotIdx,prgs) -> do
slot <- readIORef $ slotV ! slotIdx
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)]
V.forM_ glStreams $ \s -> do
writeIORef (glStreamCommands s) $ createStreamCommands glTexUnitMapping topUnis (glStreamAttributes s) (glStreamPrimitive s) (progV ! glStreamProgram s)
return Nothing
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
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
setup glVertexBufferRef buf $ glBindBuffer GL_ARRAY_BUFFER buf
glEnableVertexAttribArray idx
glVertexAttribIPointer idx size typ 0 ptr
GLDrawArrays mode first count -> glDrawArrays mode first count >> modifyIORef glDrawCallCounterRef succ
GLDrawElements mode count typ buf indicesPtr -> do
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
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
setupRenderTarget glInput GLRenderTarget{..} = do
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)
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 glTextureMapping $ mapM_ $ \(textureUnit,GLTexture{..}) -> do
glActiveTexture (GL_TEXTURE0 + fromIntegral textureUnit)
glBindTexture glTextureTarget glTextureObject
setup glSamplerMapping $ mapM_ $ \(textureUnit,GLSampler{..}) -> do
glBindSampler (GL_TEXTURE0 + fromIntegral textureUnit) glSamplerObject
forM_ (glSamplerUniformMapping new) $ \(textureUnit,GLSamplerUniform{..}) -> do
glUniform1i glUniformBinding (fromIntegral textureUnit)
writeIORef glUniformBindingRef (fromIntegral textureUnit)
renderFrame :: GLRenderer -> IO ()
renderFrame GLRenderer{..} = do
writeIORef glForceSetup True
writeIORef glVertexBufferRef 0
writeIORef glIndexBufferRef 0
writeIORef glDrawCallCounterRef 0
glBindVertexArray glVAO
forM_ glCommands $ \cmd -> do
case cmd of
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
renderSlot glDrawCallCounterRef glVertexBufferRef glIndexBufferRef ((drawcmd ! icId ic) ! progIdx)
return True
readIORef (slotVector (icInput ic) ! (icSlotMapPipelineToInput ic ! slotIdx)) >>= \case
GLSlot _ objs Ordered -> foldM_ (\a -> draw a . snd) False objs
GLSlot objMap _ _ -> foldM_ draw False objMap
data CGState
= CGState
{ drawCommands :: [GLCommand]
, rasterContext :: RasterContext
, accumulationContext :: AccumulationContext
, renderTarget :: GLRenderTarget
, currentProgram :: ProgramName
, samplerUniformMapping :: IntMap GLSamplerUniform
, textureMapping :: IntMap GLTexture
, samplerMapping :: IntMap GLSampler
}
initCGState = CGState
{ drawCommands = mempty
, 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
emit :: GLCommand -> CG ()
emit cmd = modify $ \s -> s {drawCommands = cmd : drawCommands s}
drawContext programs = do
GLProgram{..} <- (programs !) <$> gets currentProgram
let f = take (Map.size inputTextures) . 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 -> 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 ()
Just i -> case Map.lookup n texUnitMap of
Nothing -> fail $ "internal error (SetSamplerUniform - IORef)! - " ++ show cmd
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}
RenderSlot slot -> do
p <- gets currentProgram
ctx <- drawContext programs
emit $ GLRenderSlot ctx slot p
RenderStream stream -> do
p <- gets currentProgram
ctx <- drawContext programs
emit $ GLRenderStream ctx stream p
ClearRenderTarget vals -> do
rt <- gets renderTarget
emit $ GLClearRenderTarget rt $ V.toList vals