summaryrefslogtreecommitdiff
path: root/src/LambdaCube/GL/Backend.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/LambdaCube/GL/Backend.hs')
-rw-r--r--src/LambdaCube/GL/Backend.hs814
1 files changed, 814 insertions, 0 deletions
diff --git a/src/LambdaCube/GL/Backend.hs b/src/LambdaCube/GL/Backend.hs
new file mode 100644
index 0000000..7251a78
--- /dev/null
+++ b/src/LambdaCube/GL/Backend.hs
@@ -0,0 +1,814 @@
1{-# LANGUAGE TupleSections, MonadComprehensions, ViewPatterns, RecordWildCards #-}
2module LambdaCube.GL.Backend where
3
4import Control.Applicative
5import Control.Monad
6import Control.Monad.State
7import Data.Bits
8import Data.ByteString.Char8 (ByteString,pack)
9import Data.IORef
10import Data.IntMap (IntMap)
11import Data.Maybe (isNothing,fromJust)
12import Data.Map (Map)
13import Data.Set (Set)
14import Data.Trie as T
15import Data.Trie.Convenience as T
16import Data.Vector (Vector,(!),(//))
17import qualified Data.ByteString.Char8 as SB
18import qualified Data.Foldable as F
19import qualified Data.IntMap as IM
20import qualified Data.Map as Map
21import qualified Data.List as L
22import qualified Data.Set as S
23import qualified Data.Vector as V
24import qualified Data.Vector.Storable as SV
25
26import Graphics.GL.Core33
27import Foreign
28
29-- LC IR imports
30import Linear
31import IR hiding (streamType)
32import qualified IR as IR
33
34import LambdaCube.GL.Type
35import LambdaCube.GL.Util
36
37import LambdaCube.GL.Data
38import LambdaCube.GL.Input
39
40setupRasterContext :: RasterContext -> IO ()
41setupRasterContext = cvt
42 where
43 cff :: FrontFace -> GLenum
44 cff CCW = GL_CCW
45 cff CW = GL_CW
46
47 setProvokingVertex :: ProvokingVertex -> IO ()
48 setProvokingVertex pv = glProvokingVertex $ case pv of
49 FirstVertex -> GL_FIRST_VERTEX_CONVENTION
50 LastVertex -> GL_LAST_VERTEX_CONVENTION
51
52 setPointSize :: PointSize -> IO ()
53 setPointSize ps = case ps of
54 ProgramPointSize -> glEnable GL_PROGRAM_POINT_SIZE
55 PointSize s -> do
56 glDisable GL_PROGRAM_POINT_SIZE
57 glPointSize $ realToFrac s
58
59 cvt :: RasterContext -> IO ()
60 cvt (PointCtx ps fts sc) = do
61 setPointSize ps
62 glPointParameterf GL_POINT_FADE_THRESHOLD_SIZE (realToFrac fts)
63 glPointParameterf GL_POINT_SPRITE_COORD_ORIGIN $ realToFrac $ case sc of
64 LowerLeft -> GL_LOWER_LEFT
65 UpperLeft -> GL_UPPER_LEFT
66
67 cvt (LineCtx lw pv) = do
68 glLineWidth (realToFrac lw)
69 setProvokingVertex pv
70
71 cvt (TriangleCtx cm pm po pv) = do
72 -- cull mode
73 case cm of
74 CullNone -> glDisable GL_CULL_FACE
75 CullFront f -> do
76 glEnable GL_CULL_FACE
77 glCullFace GL_FRONT
78 glFrontFace $ cff f
79 CullBack f -> do
80 glEnable GL_CULL_FACE
81 glCullFace GL_BACK
82 glFrontFace $ cff f
83
84 -- polygon mode
85 case pm of
86 PolygonPoint ps -> do
87 setPointSize ps
88 glPolygonMode GL_FRONT_AND_BACK GL_POINT
89 PolygonLine lw -> do
90 glLineWidth (realToFrac lw)
91 glPolygonMode GL_FRONT_AND_BACK GL_LINE
92 PolygonFill -> glPolygonMode GL_FRONT_AND_BACK GL_FILL
93
94 -- polygon offset
95 glDisable GL_POLYGON_OFFSET_POINT
96 glDisable GL_POLYGON_OFFSET_LINE
97 glDisable GL_POLYGON_OFFSET_FILL
98 case po of
99 NoOffset -> return ()
100 Offset f u -> do
101 glPolygonOffset (realToFrac f) (realToFrac u)
102 glEnable $ case pm of
103 PolygonPoint _ -> GL_POLYGON_OFFSET_POINT
104 PolygonLine _ -> GL_POLYGON_OFFSET_LINE
105 PolygonFill -> GL_POLYGON_OFFSET_FILL
106
107 -- provoking vertex
108 setProvokingVertex pv
109
110setupAccumulationContext :: AccumulationContext -> IO ()
111setupAccumulationContext (AccumulationContext n ops) = cvt ops
112 where
113 cvt :: [FragmentOperation] -> IO ()
114 cvt (StencilOp a b c : DepthOp f m : xs) = do
115 -- TODO
116 cvtC 0 xs
117 cvt (StencilOp a b c : xs) = do
118 -- TODO
119 cvtC 0 xs
120 cvt (DepthOp df dm : xs) = do
121 -- TODO
122 glDisable GL_STENCIL_TEST
123 case df == Always && dm == False of
124 True -> glDisable GL_DEPTH_TEST
125 False -> do
126 glEnable GL_DEPTH_TEST
127 glDepthFunc $! comparisonFunctionToGLType df
128 glDepthMask (cvtBool dm)
129 cvtC 0 xs
130 cvt xs = do
131 glDisable GL_DEPTH_TEST
132 glDisable GL_STENCIL_TEST
133 cvtC 0 xs
134
135 cvtC :: Int -> [FragmentOperation] -> IO ()
136 cvtC i (ColorOp b m : xs) = do
137 -- TODO
138 case b of
139 NoBlending -> do
140 -- FIXME: requires GL 3.1
141 --glDisablei GL_BLEND $ fromIntegral GL_DRAW_BUFFER0 + fromIntegral i
142 glDisable GL_BLEND -- workaround
143 glDisable GL_COLOR_LOGIC_OP
144 BlendLogicOp op -> do
145 glDisable GL_BLEND
146 glEnable GL_COLOR_LOGIC_OP
147 glLogicOp $ logicOperationToGLType op
148 Blend cEq aEq scF dcF saF daF (V4 r g b a) -> do
149 glDisable GL_COLOR_LOGIC_OP
150 -- FIXME: requires GL 3.1
151 --glEnablei GL_BLEND $ fromIntegral GL_DRAW_BUFFER0 + fromIntegral i
152 glEnable GL_BLEND -- workaround
153 glBlendEquationSeparate (blendEquationToGLType cEq) (blendEquationToGLType aEq)
154 glBlendFuncSeparate (blendingFactorToGLType scF) (blendingFactorToGLType dcF)
155 (blendingFactorToGLType saF) (blendingFactorToGLType daF)
156 glBlendColor (realToFrac r) (realToFrac g) (realToFrac b) (realToFrac a)
157 let cvt True = 1
158 cvt False = 0
159 (mr,mg,mb,ma) = case m of
160 VBool r -> (cvt r, 1, 1, 1)
161 VV2B (V2 r g) -> (cvt r, cvt g, 1, 1)
162 VV3B (V3 r g b) -> (cvt r, cvt g, cvt b, 1)
163 VV4B (V4 r g b a) -> (cvt r, cvt g, cvt b, cvt a)
164 _ -> (1,1,1,1)
165 glColorMask mr mg mb ma
166 cvtC (i + 1) xs
167 cvtC _ [] = return ()
168
169 cvtBool :: Bool -> GLboolean
170 cvtBool True = 1
171 cvtBool False = 0
172
173clearRenderTarget :: [ClearImage] -> IO ()
174clearRenderTarget values = do
175 let setClearValue (m,i) value = case value of
176 ClearImage Depth (VFloat v) -> do
177 glDepthMask 1
178 glClearDepth $ realToFrac v
179 return (m .|. GL_DEPTH_BUFFER_BIT, i)
180 ClearImage Stencil (VWord v) -> do
181 glClearStencil $ fromIntegral v
182 return (m .|. GL_STENCIL_BUFFER_BIT, i)
183 ClearImage Color c -> do
184 let (r,g,b,a) = case c of
185 VFloat r -> (realToFrac r, 0, 0, 1)
186 VV2F (V2 r g) -> (realToFrac r, realToFrac g, 0, 1)
187 VV3F (V3 r g b) -> (realToFrac r, realToFrac g, realToFrac b, 1)
188 VV4F (V4 r g b a) -> (realToFrac r, realToFrac g, realToFrac b, realToFrac a)
189 _ -> (0,0,0,1)
190 glColorMask 1 1 1 1
191 glClearColor r g b a
192 return (m .|. GL_COLOR_BUFFER_BIT, i+1)
193 _ -> error "internal error (clearRenderTarget)"
194 (mask,_) <- foldM setClearValue (0,0) values
195 glClear $ fromIntegral mask
196
197
198printGLStatus = checkGL >>= print
199printFBOStatus = checkFBO >>= print
200
201compileProgram :: Trie InputType -> Program -> IO GLProgram
202compileProgram uniTrie p = do
203 po <- glCreateProgram
204 putStrLn $ "compile program: " ++ show po
205 let createAndAttach src t = do
206 o <- glCreateShader t
207 compileShader o $ map pack [src]
208 glAttachShader po o
209 putStr " + compile shader source: " >> printGLStatus
210 return o
211
212 objs <- sequence $ createAndAttach (vertexShader p) GL_VERTEX_SHADER : createAndAttach (fragmentShader p) GL_FRAGMENT_SHADER : case geometryShader p of
213 Nothing -> []
214 Just s -> [createAndAttach s GL_GEOMETRY_SHADER]
215
216 forM_ (zip (V.toList $ programOutput p) [0..]) $ \(Parameter (pack -> n) t,i) -> SB.useAsCString n $ \pn -> do
217 putStrLn ("variable " ++ show n ++ " attached to color number #" ++ show i)
218 glBindFragDataLocation po i $ castPtr pn
219 putStr " + setup shader output mapping: " >> printGLStatus
220
221 glLinkProgram po
222 printProgramLog po
223
224 -- check link status
225 status <- glGetProgramiv1 GL_LINK_STATUS po
226 when (status /= fromIntegral GL_TRUE) $ fail "link program failed!"
227
228 -- check program input
229 (uniforms,uniformsType) <- queryUniforms po
230 (attributes,attributesType) <- queryStreams po
231 print uniforms
232 print attributes
233 let lcUniforms = (toTrie $ programUniforms p) `unionL` (toTrie $ programInTextures p)
234 lcStreams = fmap ty (toTrie $ programStreams p)
235 check a m = and $ map go $ T.toList m
236 where go (k,b) = case T.lookup k a of
237 Nothing -> False
238 Just x -> x == b
239 unless (check lcUniforms uniformsType) $ do
240 putStrLn $ "expected: " ++ show lcUniforms
241 putStrLn $ "actual: " ++ show uniformsType
242 fail "shader program uniform input mismatch!"
243 unless (check lcStreams attributesType) $ fail $ "shader program stream input mismatch! " ++ show (attributesType,lcStreams)
244 -- the public (user) pipeline and program input is encoded by the slots, therefore the programs does not distinct the render and slot textures input
245 let inUniNames = toTrie $ programUniforms p
246 inUniforms = L.filter (\(n,v) -> T.member n inUniNames) $ T.toList $ uniforms
247 inTextureNames = toTrie $ programInTextures p
248 inTextures = L.filter (\(n,v) -> T.member n inTextureNames) $ T.toList $ uniforms
249 texUnis = [n | (n,_) <- inTextures, T.member n uniTrie]
250 putStrLn $ "uniTrie: " ++ show (T.keys uniTrie)
251 putStrLn $ "inUniNames: " ++ show inUniNames
252 putStrLn $ "inUniforms: " ++ show inUniforms
253 putStrLn $ "inTextureNames: " ++ show inTextureNames
254 putStrLn $ "inTextures: " ++ show inTextures
255 putStrLn $ "texUnis: " ++ show texUnis
256 let valA = T.toList $ attributes
257 valB = T.toList $ toTrie $ programStreams p
258 putStrLn "------------"
259 print $ T.toList $ attributes
260 print $ T.toList $ toTrie $ programStreams p
261 let lcStreamName = fmap name (toTrie $ programStreams p)
262 return $ GLProgram
263 { shaderObjects = objs
264 , programObject = po
265 , inputUniforms = T.fromList inUniforms
266 , inputTextures = T.fromList inTextures
267 , inputTextureUniforms = S.fromList $ texUnis
268 , inputStreams = T.fromList [(n,(idx, pack attrName)) | (n,idx) <- T.toList $ attributes, let Just attrName = T.lookup n lcStreamName]
269 }
270
271compileSampler :: SamplerDescriptor -> IO GLSampler
272compileSampler s = return $ GLSampler {} -- TODO
273
274compileRenderTarget :: Vector TextureDescriptor -> Vector GLTexture -> RenderTarget -> IO GLRenderTarget
275compileRenderTarget texs glTexs (RenderTarget targets) = do
276 let isFB (Framebuffer _) = True
277 isFB _ = False
278 images = [img | TargetItem _ (Just img) <- V.toList targets]
279 case all isFB images of
280 True -> do
281 let bufs = [cvt img | TargetItem Color img <- V.toList targets]
282 cvt a = case a of
283 Nothing -> GL_NONE
284 Just (Framebuffer Color) -> GL_BACK_LEFT
285 _ -> error "internal error (compileRenderTarget)!"
286 return $ GLRenderTarget
287 { framebufferObject = 0
288 , framebufferDrawbuffers = Just bufs
289 }
290 False -> do
291 when (any isFB images) $ fail "internal error (compileRenderTarget)!"
292 fbo <- alloca $! \pbo -> glGenFramebuffers 1 pbo >> peek pbo
293 glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo
294 {-
295 void glFramebufferTexture1D(GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level);
296 GL_TEXTURE_1D
297 void glFramebufferTexture2D(GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level);
298 GL_TEXTURE_2D
299 GL_TEXTURE_RECTANGLE
300 GL_TEXTURE_CUBE_MAP_POSITIVE_X
301 GL_TEXTURE_CUBE_MAP_POSITIVE_Y
302 GL_TEXTURE_CUBE_MAP_POSITIVE_Z
303 GL_TEXTURE_CUBE_MAP_NEGATIVE_X
304 GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
305 GL_TEXTURE_CUBE_MAP_NEGATIVE_Z
306 GL_TEXTURE_2D_MULTISAMPLE
307 void glFramebufferTextureLayer(GLenum target, GLenum attachment, GLuint texture, GLint level, GLint layer);
308 void glFramebufferRenderbuffer(GLenum target, GLenum attachment, GLenum renderbuffertarget, GLuint renderbuffer);
309 void glFramebufferTexture(GLenum target, GLenum attachment, GLuint texture, GLint level);
310 -}
311 let attach attachment (TextureImage texIdx level (Just layer)) =
312 glFramebufferTextureLayer GL_DRAW_FRAMEBUFFER attachment (glTextureTarget $ glTexs ! texIdx) (fromIntegral level) (fromIntegral layer)
313 attach attachment (TextureImage texIdx level Nothing) = do
314 let glTex = glTexs ! texIdx
315 tex = texs ! texIdx
316 txLevel = fromIntegral level
317 txTarget = glTextureTarget glTex
318 txObj = glTextureObject glTex
319 attachArray = glFramebufferTexture GL_DRAW_FRAMEBUFFER attachment txObj txLevel
320 attach2D = glFramebufferTexture2D GL_DRAW_FRAMEBUFFER attachment txTarget txObj txLevel
321 case textureType tex of
322 Texture1D _ n
323 | n > 1 -> attachArray
324 | otherwise -> glFramebufferTexture1D GL_DRAW_FRAMEBUFFER attachment txTarget txObj txLevel
325 Texture2D _ n
326 | n > 1 -> attachArray
327 | otherwise -> attach2D
328 Texture3D _ -> attachArray
329 TextureCube _ -> attachArray
330 TextureRect _ -> attach2D
331 Texture2DMS _ n _ _
332 | n > 1 -> attachArray
333 | otherwise -> attach2D
334 TextureBuffer _ -> fail "internalError (compileRenderTarget/TextureBuffer)!"
335
336 go a (TargetItem Stencil (Just img)) = do
337 fail "Stencil support is not implemented yet!"
338 return a
339 go a (TargetItem Depth (Just img)) = do
340 attach GL_DEPTH_ATTACHMENT img
341 return a
342 go (bufs,colorIdx) (TargetItem Color (Just img)) = do
343 let attachment = GL_COLOR_ATTACHMENT0 + fromIntegral colorIdx
344 attach attachment img
345 return (attachment : bufs, colorIdx + 1)
346 go (bufs,colorIdx) (TargetItem Color Nothing) = return (GL_NONE : bufs, colorIdx + 1)
347 go a _ = return a
348 (bufs,_) <- foldM go ([],0) targets
349 withArray (reverse bufs) $ glDrawBuffers (fromIntegral $ length bufs)
350 return $ GLRenderTarget
351 { framebufferObject = fbo
352 , framebufferDrawbuffers = Nothing
353 }
354
355compileStreamData :: StreamData -> IO GLStream
356compileStreamData s = do
357 let withV w a f = w a (\p -> f $ castPtr p)
358 let compileAttr (VFloatArray v) = Array ArrFloat (V.length v) (withV (SV.unsafeWith . V.convert) v)
359 compileAttr (VIntArray v) = Array ArrInt32 (V.length v) (withV (SV.unsafeWith . V.convert) v)
360 compileAttr (VWordArray v) = Array ArrWord32 (V.length v) (withV (SV.unsafeWith . V.convert) v)
361 --TODO: compileAttr (VBoolArray v) = Array ArrWord32 (length v) (withV withArray v)
362 (indexMap,arrays) = unzip [((n,i),compileAttr d) | (i,(n,d)) <- zip [0..] $ Map.toList $ streamData s]
363 getLength n = l `div` c
364 where
365 l = case Map.lookup n $ IR.streamData s of
366 Just (VFloatArray v) -> V.length v
367 Just (VIntArray v) -> V.length v
368 Just (VWordArray v) -> V.length v
369 _ -> error "compileStreamData - getLength"
370 c = case Map.lookup n $ IR.streamType s of
371 Just Bool -> 1
372 Just V2B -> 2
373 Just V3B -> 3
374 Just V4B -> 4
375 Just Word -> 1
376 Just V2U -> 2
377 Just V3U -> 3
378 Just V4U -> 4
379 Just Int -> 1
380 Just V2I -> 2
381 Just V3I -> 3
382 Just V4I -> 4
383 Just Float -> 1
384 Just V2F -> 2
385 Just V3F -> 3
386 Just V4F -> 4
387 Just M22F -> 4
388 Just M23F -> 6
389 Just M24F -> 8
390 Just M32F -> 6
391 Just M33F -> 9
392 Just M34F -> 12
393 Just M42F -> 8
394 Just M43F -> 12
395 Just M44F -> 16
396 _ -> error "compileStreamData - getLength element count"
397 buffer <- compileBuffer arrays
398 cmdRef <- newIORef []
399 let toStream (n,i) = (n,Stream
400 { streamType = fromJust $ toStreamType =<< Map.lookup n (IR.streamType s)
401 , streamBuffer = buffer
402 , streamArrIdx = i
403 , streamStart = 0
404 , streamLength = getLength n
405 })
406 return $ GLStream
407 { glStreamCommands = cmdRef
408 , glStreamPrimitive = case streamPrimitive s of
409 Points -> PointList
410 Lines -> LineList
411 Triangles -> TriangleList
412 LinesAdjacency -> LineListAdjacency
413 TrianglesAdjacency -> TriangleListAdjacency
414 , glStreamAttributes = toTrie $ Map.fromList $ map toStream indexMap
415 , glStreamProgram = V.head $ streamPrograms s
416 }
417
418createStreamCommands :: Trie (IORef GLint) -> Trie GLUniform -> Trie (Stream Buffer) -> Primitive -> GLProgram -> [GLObjectCommand]
419createStreamCommands texUnitMap topUnis attrs primitive prg = streamUniCmds ++ streamCmds ++ [drawCmd]
420 where
421 -- object draw command
422 drawCmd = GLDrawArrays prim 0 (fromIntegral count)
423 where
424 prim = primitiveToGLType primitive
425 count = head [c | Stream _ _ _ _ c <- T.elems attrs]
426
427 -- object uniform commands
428 -- texture slot setup commands
429 streamUniCmds = uniCmds ++ texCmds
430 where
431 uniCmds = [GLSetUniform i u | (n,i) <- uniMap, let u = topUni n]
432 uniMap = T.toList $ inputUniforms prg
433 topUni n = T.lookupWithDefault (error "internal error (createStreamCommands)!") n topUnis
434 texUnis = S.toList $ inputTextureUniforms prg
435 texCmds = [ GLBindTexture (inputTypeToTextureTarget $ uniInputType u) texUnit u
436 | n <- texUnis
437 , let u = topUni n
438 , let texUnit = T.lookupWithDefault (error "internal error (createStreamCommands - Texture Unit)") n texUnitMap
439 ]
440 uniInputType (GLUniform ty _) = ty
441
442 -- object attribute stream commands
443 streamCmds = [attrCmd i s | (i,name) <- T.elems attrMap, let Just s = T.lookup name attrs]
444 where
445 attrMap = inputStreams prg
446 attrCmd i s = case s of
447 Stream ty (Buffer arrs bo) arrIdx start len -> case ty of
448 Attribute_Word -> setIntAttrib 1
449 Attribute_V2U -> setIntAttrib 2
450 Attribute_V3U -> setIntAttrib 3
451 Attribute_V4U -> setIntAttrib 4
452 Attribute_Int -> setIntAttrib 1
453 Attribute_V2I -> setIntAttrib 2
454 Attribute_V3I -> setIntAttrib 3
455 Attribute_V4I -> setIntAttrib 4
456 Attribute_Float -> setFloatAttrib 1
457 Attribute_V2F -> setFloatAttrib 2
458 Attribute_V3F -> setFloatAttrib 3
459 Attribute_V4F -> setFloatAttrib 4
460 Attribute_M22F -> setFloatAttrib 4
461 Attribute_M23F -> setFloatAttrib 6
462 Attribute_M24F -> setFloatAttrib 8
463 Attribute_M32F -> setFloatAttrib 6
464 Attribute_M33F -> setFloatAttrib 9
465 Attribute_M34F -> setFloatAttrib 12
466 Attribute_M42F -> setFloatAttrib 8
467 Attribute_M43F -> setFloatAttrib 12
468 Attribute_M44F -> setFloatAttrib 16
469 where
470 setFloatAttrib n = GLSetVertexAttribArray i bo n glType (ptr n)
471 setIntAttrib n = GLSetVertexAttribIArray i bo n glType (ptr n)
472 ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx
473 glType = arrayTypeToGLType arrType
474 ptr compCnt = intPtrToPtr $! fromIntegral (arrOffs + start * fromIntegral compCnt * sizeOfArrayType arrType)
475
476 -- constant generic attribute
477 constAttr -> GLSetVertexAttrib i constAttr
478
479allocRenderer :: Pipeline -> IO GLRenderer
480allocRenderer p = do
481 let uniTrie = uniforms $ schemaFromPipeline p
482 smps <- V.mapM compileSampler $ samplers p
483 texs <- V.mapM compileTexture $ textures p
484 trgs <- V.mapM (compileRenderTarget (textures p) texs) $ targets p
485 prgs <- V.mapM (compileProgram uniTrie) $ programs p
486 -- texture unit mapping ioref trie
487 -- texUnitMapRefs :: Map UniformName (IORef TextureUnit)
488 texUnitMapRefs <- T.fromList <$> mapM (\k -> (k,) <$> newIORef 0) (S.toList $ S.fromList $ concat $ V.toList $ V.map (T.keys . toTrie . programInTextures) $ programs p)
489 let (cmds,st) = runState (mapM (compileCommand texUnitMapRefs smps texs trgs prgs) $ V.toList $ commands p) initCGState
490 input <- newIORef Nothing
491 -- default Vertex Array Object
492 vao <- alloca $! \pvao -> glGenVertexArrays 1 pvao >> peek pvao
493 strs <- V.mapM compileStreamData $ streams p
494 return $ GLRenderer
495 { glPrograms = prgs
496 , glTextures = texs
497 , glSamplers = smps
498 , glTargets = trgs
499 , glCommands = cmds
500 , glSlotPrograms = V.map (V.toList . slotPrograms) $ IR.slots p
501 , glInput = input
502 , glSlotNames = V.map (pack . slotName) $ IR.slots p
503 , glVAO = vao
504 , glTexUnitMapping = texUnitMapRefs
505 , glStreams = strs
506 }
507
508disposeRenderer :: GLRenderer -> IO ()
509disposeRenderer p = do
510 setStorage' p Nothing
511 V.forM_ (glPrograms p) $ \prg -> do
512 glDeleteProgram $ programObject prg
513 mapM_ glDeleteShader $ shaderObjects prg
514 let targets = glTargets p
515 withArray (map framebufferObject $ V.toList targets) $ (glDeleteFramebuffers $ fromIntegral $ V.length targets)
516 let textures = glTextures p
517 withArray (map glTextureObject $ V.toList textures) $ (glDeleteTextures $ fromIntegral $ V.length textures)
518 with (glVAO p) $ (glDeleteVertexArrays 1)
519
520{-
521data SlotSchema
522 = SlotSchema
523 { primitive :: FetchPrimitive
524 , attributes :: Trie StreamType
525 }
526 deriving Show
527
528data PipelineSchema
529 = PipelineSchema
530 { slots :: Trie SlotSchema
531 , uniforms :: Trie InputType
532 }
533 deriving Show
534-}
535isSubTrie :: (a -> a -> Bool) -> Trie a -> Trie a -> Bool
536isSubTrie eqFun universe subset = and [isMember a (T.lookup n universe) | (n,a) <- T.toList subset]
537 where
538 isMember a Nothing = False
539 isMember a (Just b) = eqFun a b
540
541-- TODO: if there is a mismatch thow detailed error message in the excoeption, containing the missing attributes and uniforms
542{-
543 let sch = schema input
544 forM_ uniformNames $ \n -> case T.lookup n (uniforms sch) of
545 Nothing -> throw $ userError $ "Unknown uniform: " ++ show n
546 _ -> return ()
547 case T.lookup slotName (slots sch) of
548 Nothing -> throw $ userError $ "Unknown slot: " ++ show slotName
549 Just (SlotSchema sPrim sAttrs) -> do
550 when (sPrim /= (primitiveToFetchPrimitive prim)) $ throw $ userError $
551 "Primitive mismatch for slot (" ++ show slotName ++ ") expected " ++ show sPrim ++ " but got " ++ show prim
552 let sType = fmap streamToStreamType attribs
553 when (sType /= sAttrs) $ throw $ userError $ unlines $
554 [ "Attribute stream mismatch for slot (" ++ show slotName ++ ") expected "
555 , show sAttrs
556 , " but got "
557 , show sType
558 ]
559-}
560
561setStorage :: GLRenderer -> GLStorage -> IO (Maybe String)
562setStorage p input' = setStorage' p (Just input')
563
564setStorage' :: GLRenderer -> Maybe GLStorage -> IO (Maybe String)
565setStorage' p input' = do
566 -- TODO: check matching input schema
567 {-
568 case input' of
569 Nothing -> return ()
570 Just input -> schemaFromPipeline p
571 -}
572 {-
573 deletion:
574 - remove pipeline's object commands from used slots
575 - remove pipeline from attached pipelines vector
576 -}
577 ic' <- readIORef $ glInput p
578 case ic' of
579 Nothing -> return ()
580 Just ic -> do
581 let idx = icId ic
582 oldInput = icInput ic
583 slotMask = icSlotMapPipelineToInput ic
584 slotRefs = slotVector oldInput
585 modifyIORef (pipelines oldInput) $ \v -> v // [(idx,Nothing)]
586 V.forM_ slotMask $ \slotIdx -> do
587 slot <- readIORef (slotRefs ! slotIdx)
588 forM_ (IM.elems $ objectMap slot) $ \obj -> do
589 modifyIORef (objCommands obj) $ \v -> v // [(idx,V.empty)]
590 {-
591 addition:
592 - get an id from pipeline input
593 - add to attached pipelines
594 - generate slot mappings
595 - update used slots, and generate object commands for objects in the related slots
596 -}
597 case input' of
598 Nothing -> writeIORef (glInput p) Nothing >> return Nothing
599 Just input -> do
600 let pipelinesRef = pipelines input
601 oldPipelineV <- readIORef pipelinesRef
602 (idx,shouldExtend) <- case V.findIndex isNothing oldPipelineV of
603 Nothing -> do
604 -- we don't have empty space, hence we double the vector size
605 let len = V.length oldPipelineV
606 modifyIORef pipelinesRef $ \v -> (V.concat [v,V.replicate len Nothing]) // [(len,Just p)]
607 return (len,Just len)
608 Just i -> do
609 modifyIORef pipelinesRef $ \v -> v // [(i,Just p)]
610 return (i,Nothing)
611 -- create input connection
612 let sm = slotMap input
613 pToI = [i | n <- glSlotNames p, let Just i = T.lookup n sm]
614 iToP = V.update (V.replicate (T.size sm) Nothing) (V.imap (\i v -> (v, Just i)) pToI)
615 writeIORef (glInput p) $ Just $ InputConnection idx input pToI iToP
616
617 -- generate object commands for related slots
618 {-
619 for each slot in pipeline:
620 map slot name to input slot name
621 for each object:
622 generate command program vector => for each dependent program:
623 generate object commands
624 -}
625 let slotV = slotVector input
626 progV = glPrograms p
627 texUnitMap = glTexUnitMapping p
628 topUnis = uniformSetup input
629 emptyV = V.replicate (V.length progV) []
630 extend v = case shouldExtend of
631 Nothing -> v
632 Just l -> V.concat [v,V.replicate l V.empty]
633 V.forM_ (V.zip pToI (glSlotPrograms p)) $ \(slotIdx,prgs) -> do
634 slot <- readIORef $ slotV ! slotIdx
635 forM_ (IM.elems $ objectMap slot) $ \obj -> do
636 let cmdV = emptyV // [(prgIdx,createObjectCommands texUnitMap topUnis obj (progV ! prgIdx)) | prgIdx <- prgs]
637 modifyIORef (objCommands obj) $ \v -> extend v // [(idx,cmdV)]
638 -- generate stream commands
639 V.forM_ (glStreams p) $ \s -> do
640 writeIORef (glStreamCommands s) $ createStreamCommands texUnitMap topUnis (glStreamAttributes s) (glStreamPrimitive s) (progV ! glStreamProgram s)
641 return Nothing
642{-
643 track state:
644 - render target
645 - binded textures
646-}
647
648{-
649 render steps:
650 - update uniforms
651 - per uniform setup
652 - buffer setup (one buffer per object, which has per at least one object uniform)
653 - new command: set uniform buffer (binds uniform buffer to program's buffer slot)
654 - render slot steps:
655 - set uniform buffer or set uniforms separately
656 - set vertex and index array
657 - call draw command
658-}
659{-
660 storage alternatives:
661 - interleaved / separated
662 - VAO or VBOs
663-}
664 {-
665 strategy:
666 step 1: generate commands for an object
667 step 2: sort object merge and do optimization by filtering redundant commands
668 -}
669{-
670 design:
671 runtime eleminiation of redundant buffer bind commands and redundant texture bind commands
672-}
673{-
674 track:
675 buffer binding on various targets: GL_ARRAY_BUFFER, GL_ELEMENT_ARRAY_BUFFER
676 glEnable/DisableVertexAttribArray
677-}
678renderSlot :: [GLObjectCommand] -> IO ()
679renderSlot cmds = forM_ cmds $ \cmd -> do
680 case cmd of
681 GLSetVertexAttribArray idx buf size typ ptr -> do
682 glBindBuffer GL_ARRAY_BUFFER buf
683 glEnableVertexAttribArray idx
684 glVertexAttribPointer idx size typ (fromIntegral GL_FALSE) 0 ptr
685 GLSetVertexAttribIArray idx buf size typ ptr -> do
686 glBindBuffer GL_ARRAY_BUFFER buf
687 glEnableVertexAttribArray idx
688 glVertexAttribIPointer idx size typ 0 ptr
689 GLDrawArrays mode first count -> glDrawArrays mode first count
690 GLDrawElements mode count typ buf indicesPtr -> do
691 glBindBuffer GL_ELEMENT_ARRAY_BUFFER buf
692 glDrawElements mode count typ indicesPtr
693 GLSetUniform idx (GLUniform ty ref) -> setUniform idx ty ref
694 GLBindTexture txTarget tuRef (GLUniform _ ref) -> do
695 txObjVal <- readIORef ref
696 -- HINT: ugly and hacky
697 with txObjVal $ \txObjPtr -> do
698 txObj <- peek $ castPtr txObjPtr :: IO GLuint
699 texUnit <- readIORef tuRef
700 glActiveTexture $ GL_TEXTURE0 + fromIntegral texUnit
701 glBindTexture txTarget txObj
702 putStrLn $ "to texture unit " ++ show texUnit ++ " texture object " ++ show txObj
703 GLSetVertexAttrib idx val -> do
704 glDisableVertexAttribArray idx
705 setVertexAttrib idx val
706 isOk <- checkGL
707 putStrLn $ SB.unpack isOk ++ " - " ++ show cmd
708
709renderFrame :: GLRenderer -> IO ()
710renderFrame glp = do
711 glBindVertexArray (glVAO glp)
712 forM_ (glCommands glp) $ \cmd -> do
713 case cmd of
714 GLSetRasterContext rCtx -> setupRasterContext rCtx
715 GLSetAccumulationContext aCtx -> setupAccumulationContext aCtx
716 GLSetRenderTarget rt bufs -> do
717 -- set target viewport
718 --when (rt == 0) $ do -- screen out
719 ic' <- readIORef $ glInput glp
720 case ic' of
721 Nothing -> return ()
722 Just ic -> do
723 let input = icInput ic
724 (w,h) <- readIORef $ screenSize input
725 glViewport 0 0 (fromIntegral w) (fromIntegral h)
726 -- TODO: set FBO target viewport
727 glBindFramebuffer GL_DRAW_FRAMEBUFFER rt
728 case bufs of
729 Nothing -> return ()
730 Just bl -> withArray bl $ glDrawBuffers (fromIntegral $ length bl)
731 GLSetProgram p -> glUseProgram p
732 GLSetSamplerUniform i tu ref -> glUniform1i i tu >> writeIORef ref tu
733 GLSetTexture tu target tx -> glActiveTexture tu >> glBindTexture target tx
734 GLClearRenderTarget vals -> clearRenderTarget vals
735 GLGenerateMipMap tu target -> glActiveTexture tu >> glGenerateMipmap target
736 GLRenderStream streamIdx progIdx -> do
737 renderSlot =<< readIORef (glStreamCommands $ glStreams glp ! streamIdx)
738 GLRenderSlot slotIdx progIdx -> do
739 input <- readIORef (glInput glp)
740 case input of
741 Nothing -> putStrLn "Warning: No pipeline input!" >> return ()
742 Just ic -> do
743 GLSlot _ objs _ <- readIORef (slotVector (icInput ic) ! (icSlotMapPipelineToInput ic ! slotIdx))
744 --putStrLn $ "Rendering " ++ show (V.length objs) ++ " objects"
745 V.forM_ objs $ \(_,obj) -> do
746 enabled <- readIORef $ objEnabled obj
747 when enabled $ do
748 cmd <- readIORef $ objCommands obj
749 --putStrLn "Render object"
750 renderSlot ((cmd ! icId ic) ! progIdx)
751 {-
752 GLSetSampler
753 GLSaveImage
754 GLLoadImage
755 -}
756 isOk <- checkGL
757 putStrLn $ SB.unpack isOk ++ " - " ++ show cmd
758
759data CGState
760 = CGState
761 { currentProgram :: ProgramName
762 , textureBinding :: IntMap GLTexture
763 , samplerUniforms :: Map UniformName TextureUnit
764 }
765
766initCGState = CGState
767 { currentProgram = error "CGState: empty currentProgram"
768 , textureBinding = IM.empty
769 , samplerUniforms = mempty
770 }
771
772type CG a = State CGState a
773
774compileCommand :: Trie (IORef GLint) -> Vector GLSampler -> Vector GLTexture -> Vector GLRenderTarget -> Vector GLProgram -> Command -> CG GLCommand
775compileCommand texUnitMap samplers textures targets programs cmd = case cmd of
776 SetRasterContext rCtx -> return $ GLSetRasterContext rCtx
777 SetAccumulationContext aCtx -> return $ GLSetAccumulationContext aCtx
778 SetRenderTarget rt -> let GLRenderTarget fbo bufs = targets ! rt in return $ GLSetRenderTarget fbo bufs
779 SetProgram p -> do
780 modify (\s -> s {currentProgram = p})
781 return $ GLSetProgram $ programObject $ programs ! p
782 SetSamplerUniform n tu -> do
783 modify (\s@CGState{..} -> s {samplerUniforms = Map.insert n tu samplerUniforms})
784 p <- currentProgram <$> get
785 case T.lookup (pack n) (inputTextures $ programs ! p) of
786 Nothing -> fail $ "internal error (SetSamplerUniform)! - " ++ show cmd
787 Just i -> case T.lookup (pack n) texUnitMap of
788 Nothing -> fail $ "internal error (SetSamplerUniform - IORef)! - " ++ show cmd
789 Just r -> return $ GLSetSamplerUniform i (fromIntegral tu) r
790 SetTexture tu t -> do
791 let tex = textures ! t
792 modify (\s -> s {textureBinding = IM.insert tu tex $ textureBinding s})
793 return $ GLSetTexture (GL_TEXTURE0 + fromIntegral tu) (glTextureTarget tex) (glTextureObject tex)
794{-
795 SetSampler tu s -> liftIO $ do
796 glBindSampler (fromIntegral tu) (samplerObject $ glSamplers glp ! s)
797-}
798 RenderSlot slot -> do
799 smpUnis <- samplerUniforms <$> get
800 p <- currentProgram <$> get
801 return $ GLRenderSlot slot p
802 RenderStream stream -> do
803 p <- currentProgram <$> get
804 return $ GLRenderStream stream p
805 ClearRenderTarget vals -> return $ GLClearRenderTarget $ V.toList vals
806 GenerateMipMap tu -> do
807 tb <- textureBinding <$> get
808 case IM.lookup tu tb of
809 Nothing -> fail "internal error (GenerateMipMap)!"
810 Just tex -> return $ GLGenerateMipMap (GL_TEXTURE0 + fromIntegral tu) (glTextureTarget tex)
811{-
812 SaveImage _ _ -> undefined
813 LoadImage _ _ -> undefined
814-}
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-05 02:43:55 +0000