lambdacube-gl-0.5.2.3: src/LambdaCube/GL/Backend.hs
{-# LANGUAGE TupleSections, MonadComprehensions, RecordWildCards, LambdaCase, FlexibleContexts #-}
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
-- LC IR imports
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
-- 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 :: Program -> IO GLProgram
compileProgram p = do
po <- glCreateProgram
--putStrLn $ "compile program: " ++ show po
let createAndAttach src t = do
o <- glCreateShader t
compileShader o [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 n t,i) -> withCString 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
log <- printProgramLog po
-- check link status
status <- glGetProgramiv1 GL_LINK_STATUS po
when (status /= fromIntegral GL_TRUE) $ fail $ unlines ["link program failed:",log]
-- check program input
(uniforms,uniformsType) <- queryUniforms po
(attributes,attributesType) <- queryStreams po
--print uniforms
--print attributes
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)
-- the public (user) pipeline and program input is encoded by the objectArrays, therefore the programs does not distinct the render and slot textures input
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
{-
unless (S.fromList prgInTextures == S.fromList uniInTextures) $ fail $ unlines
[ "shader program uniform texture input mismatch!"
, "expected: " ++ show prgInTextures
, "actual: " ++ show uniInTextures
, "vertex shader:"
, vertexShader p
, "geometry shader:"
, fromMaybe "" (geometryShader p)
, "fragment shader:"
, fragmentShader p
]
-}
--putStrLn $ "uniTrie: " ++ show (Map.keys uniTrie)
--putStrLn $ "inUniNames: " ++ show inUniNames
--putStrLn $ "inUniforms: " ++ show inUniforms
--putStrLn $ "inTextureNames: " ++ show inTextureNames
--putStrLn $ "inTextures: " ++ show inTextures
--putStrLn $ "texUnis: " ++ show texUnis
let valA = Map.toList $ attributes
valB = Map.toList $ programStreams p
--putStrLn "------------"
--print $ Map.toList $ attributes
--print $ 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
{-
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 = 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
-- object draw command
drawCmd = GLDrawArrays prim 0 (fromIntegral count)
where
prim = primitiveToGLType primitive
count = head [c | Stream _ _ _ _ c <- Map.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 = 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
-- object attribute stream commands
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)
-- constant generic attribute
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
-- texture unit mapping ioref trie
-- texUnitMapRefs :: Map UniformName (IORef TextureUnit)
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 = 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)
{-
data ObjectArraySchema
= ObjectArraySchema
{ primitive :: FetchPrimitive
, attributes :: Trie StreamType
}
deriving Show
data PipelineSchema
= PipelineSchema
{ objectArrays :: Trie ObjectArraySchema
, uniforms :: Trie InputType
}
deriving Show
-}
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
-- 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 Map.lookup n (uniforms sch) of
Nothing -> throw $ userError $ "Unknown uniform: " ++ show n
_ -> return ()
case Map.lookup slotName (objectArrays sch) of
Nothing -> throw $ userError $ "Unknown slot: " ++ show slotName
Just (ObjectArraySchema 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
]
-}
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
-- TODO: check matching input schema
{-
case input' of
Nothing -> return ()
Just input -> schemaFromPipeline p
-}
{-
deletion:
- remove pipeline's object commands from used objectArrays
- remove pipeline from attached pipelines vector
-}
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)]
{-
addition:
- get an id from pipeline input
- add to attached pipelines
- generate slot mappings
- update used objectArrays, and generate object commands for objects in the related objectArrays
-}
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
-- 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, 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
-- generate object commands for related objectArrays
{-
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
--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) $ \(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)]
-- generate stream commands
V.forM_ glStreams $ \s -> do
writeIORef (glStreamCommands s) $ createStreamCommands glTexUnitMapping topUnis (glStreamAttributes s) (glStreamPrimitive s) (progV ! glStreamProgram s)
return Nothing
{-
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 :: 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
-- 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
--putStrLn $ "to texture unit " ++ show texUnit ++ " texture object " ++ show txObj
GLSetVertexAttrib idx val -> do
glDisableVertexAttribArray idx
setVertexAttrib idx val
--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 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
--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
{ drawCommands :: [GLCommand]
-- draw context data
, rasterContext :: RasterContext
, accumulationContext :: AccumulationContext
, renderTarget :: GLRenderTarget
, currentProgram :: ProgramName
, samplerUniformMapping :: IntMap GLSamplerUniform
, textureMapping :: IntMap GLTexture
, samplerMapping :: IntMap GLSampler
}
initCGState = CGState
{ 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
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 () -- 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 -> 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 <- 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
{-
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)
-}