summaryrefslogtreecommitdiff
path: root/Backend.hs
diff options
context:
space:
mode:
authorJoe Crayne <joe@jerkface.net>2019-04-08 07:12:01 -0400
committerJoe Crayne <joe@jerkface.net>2019-04-08 07:12:01 -0400
commitaf59e929e402efcdf3b1303559cb216013f526d9 (patch)
treee1da2f684b5999eff4a67f507c3fa094d87c70b7 /Backend.hs
parented50070ff44c18a133143c0c0d9aa386f01e430d (diff)
Forgot to add Backend copy.
Diffstat (limited to 'Backend.hs')
-rw-r--r--Backend.hs944
1 files changed, 944 insertions, 0 deletions
diff --git a/Backend.hs b/Backend.hs
new file mode 100644
index 0000000..5869907
--- /dev/null
+++ b/Backend.hs
@@ -0,0 +1,944 @@
1{-# LANGUAGE TupleSections, MonadComprehensions, RecordWildCards, LambdaCase, FlexibleContexts #-}
2module Backend where
3
4import Control.Applicative
5import Control.Monad
6import Control.Monad.State.Strict
7import Data.Maybe
8import Data.Bits
9import Data.IORef
10import Data.IntMap (IntMap)
11import Data.Maybe (isNothing,fromJust)
12import Data.Map (Map)
13import Data.Set (Set)
14import Data.Vector (Vector,(!),(//))
15import qualified Data.Foldable as F
16import qualified Data.IntMap as IntMap
17import qualified Data.Map as Map
18import qualified Data.List as L
19import qualified Data.Set as Set
20import qualified Data.Vector as V
21import qualified Data.Vector.Storable as SV
22
23-- import Graphics.GL.Core33
24import GL
25import Foreign
26import Foreign.C.String
27
28-- LC IR imports
29import LambdaCube.PipelineSchema
30import LambdaCube.Linear
31import LambdaCube.IR hiding (streamType)
32import qualified LambdaCube.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 :: GLRenderTarget -> [ClearImage] -> IO ()
174clearRenderTarget GLRenderTarget{..} 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 glColorMask 1 1 1 1
185 if framebufferObject == 0
186 then
187 clearDefaultFB >>
188 pure (m .|. GL_COLOR_BUFFER_BIT, i+1)
189 else
190 clearFBColorAttachment >>
191 pure (m, i+1)
192 where
193 clearDefaultFB = do
194 let (r,g,b,a) = case c of
195 VFloat r -> (realToFrac r, 0, 0, 1)
196 VV2F (V2 r g) -> (realToFrac r, realToFrac g, 0, 1)
197 VV3F (V3 r g b) -> (realToFrac r, realToFrac g, realToFrac b, 1)
198 VV4F (V4 r g b a) -> (realToFrac r, realToFrac g, realToFrac b, realToFrac a)
199 _ -> (0,0,0,1)
200 glClearColor r g b a
201 clearFBColorAttachment = do
202 let buf = GL_COLOR
203 case c of -- there must be some clever way to extract the generality here, I'm sure..
204 VFloat r -> with (V4 r 0 0 1) $ glClearBufferfv buf i . castPtr
205 VV2F (V2 r g) -> with (V4 r g 0 1) $ glClearBufferfv buf i . castPtr
206 VV3F (V3 r g b) -> with (V4 r g b 1) $ glClearBufferfv buf i . castPtr
207 VV4F (V4 r g b a) -> with (V4 r g b a) $ glClearBufferfv buf i . castPtr
208
209 VInt r -> with (V4 r 0 0 1) $ glClearBufferiv buf i . castPtr
210 VV2I (V2 r g) -> with (V4 r g 0 1) $ glClearBufferiv buf i . castPtr
211 VV3I (V3 r g b) -> with (V4 r g b 1) $ glClearBufferiv buf i . castPtr
212 VV4I (V4 r g b a) -> with (V4 r g b a) $ glClearBufferiv buf i . castPtr
213
214 VWord r -> with (V4 r 0 0 1) $ glClearBufferiv buf i . castPtr
215 VV2U (V2 r g) -> with (V4 r g 0 1) $ glClearBufferiv buf i . castPtr
216 VV3U (V3 r g b) -> with (V4 r g b 1) $ glClearBufferiv buf i . castPtr
217 VV4U (V4 r g b a) -> with (V4 r g b a) $ glClearBufferiv buf i . castPtr
218 _ -> error $ "internal error: unsupported color attachment format: " ++ show c
219
220 _ -> error "internal error (clearRenderTarget)"
221 (mask,_) <- foldM setClearValue (0,0) values
222 glClear $ fromIntegral mask
223
224printGLStatus = checkGL >>= print
225printFBOStatus = checkFBO >>= print
226
227compileProgram :: Program -> IO GLProgram
228compileProgram p = do
229 po <- glCreateProgram
230 --putStrLn $ "compile program: " ++ show po
231 let createAndAttach src t = do
232 o <- glCreateShader t
233 compileShader o [src]
234 glAttachShader po o
235 --putStr " + compile shader source: " >> printGLStatus
236 return o
237
238 objs <- sequence $ createAndAttach (vertexShader p) GL_VERTEX_SHADER : createAndAttach (fragmentShader p) GL_FRAGMENT_SHADER : case geometryShader p of
239 Nothing -> []
240 Just s -> [createAndAttach s GL_GEOMETRY_SHADER]
241
242 forM_ (zip (V.toList $ programOutput p) [0..]) $ \(Parameter n t,i) -> withCString n $ \pn -> do
243 --putStrLn ("variable " ++ show n ++ " attached to color number #" ++ show i)
244 glBindFragDataLocation po i $ castPtr pn
245 --putStr " + setup shader output mapping: " >> printGLStatus
246
247 glLinkProgram po
248 log <- printProgramLog po
249
250 -- check link status
251 status <- glGetProgramiv1 GL_LINK_STATUS po
252 when (status /= fromIntegral GL_TRUE) $ fail $ unlines ["link program failed:",log]
253
254 -- check program input
255 (uniforms,uniformsType) <- queryUniforms po
256 (attributes,attributesType) <- queryStreams po
257 --print uniforms
258 --print attributes
259 let lcUniforms = (programUniforms p) `Map.union` (programInTextures p)
260 lcStreams = fmap ty (programStreams p)
261 check a m = and $ map go $ Map.toList m
262 where go (k,b) = case Map.lookup k a of
263 Nothing -> False
264 Just x -> x == b
265 unless (check lcUniforms uniformsType) $ fail $ unlines
266 [ "shader program uniform input mismatch!"
267 , "expected: " ++ show lcUniforms
268 , "actual: " ++ show uniformsType
269 ]
270 unless (check lcStreams attributesType) $ fail $ "shader program stream input mismatch! " ++ show (attributesType,lcStreams)
271 -- the public (user) pipeline and program input is encoded by the objectArrays, therefore the programs does not distinct the render and slot textures input
272 let inUniNames = programUniforms p
273 inUniforms = L.filter (\(n,v) -> Map.member n inUniNames) $ Map.toList $ uniforms
274 inTextureNames = programInTextures p
275 inTextures = L.filter (\(n,v) -> Map.member n inTextureNames) $ Map.toList $ uniforms
276 texUnis = [n | (n,_) <- inTextures, Map.member n (programUniforms p)]
277 let prgInTextures = Map.keys inTextureNames
278 uniInTextures = map fst inTextures
279 {-
280 unless (S.fromList prgInTextures == S.fromList uniInTextures) $ fail $ unlines
281 [ "shader program uniform texture input mismatch!"
282 , "expected: " ++ show prgInTextures
283 , "actual: " ++ show uniInTextures
284 , "vertex shader:"
285 , vertexShader p
286 , "geometry shader:"
287 , fromMaybe "" (geometryShader p)
288 , "fragment shader:"
289 , fragmentShader p
290 ]
291 -}
292 --putStrLn $ "uniTrie: " ++ show (Map.keys uniTrie)
293 --putStrLn $ "inUniNames: " ++ show inUniNames
294 --putStrLn $ "inUniforms: " ++ show inUniforms
295 --putStrLn $ "inTextureNames: " ++ show inTextureNames
296 --putStrLn $ "inTextures: " ++ show inTextures
297 --putStrLn $ "texUnis: " ++ show texUnis
298 let valA = Map.toList $ attributes
299 valB = Map.toList $ programStreams p
300 --putStrLn "------------"
301 --print $ Map.toList $ attributes
302 --print $ Map.toList $ programStreams p
303 let lcStreamName = fmap name (programStreams p)
304 return $ GLProgram
305 { shaderObjects = objs
306 , programObject = po
307 , inputUniforms = Map.fromList inUniforms
308 , inputTextures = Map.fromList inTextures
309 , inputTextureUniforms = Set.fromList $ texUnis
310 , inputStreams = Map.fromList [(n,(idx, attrName)) | (n,idx) <- Map.toList $ attributes, let attrName = fromMaybe (error $ "missing attribute: " ++ n) $ Map.lookup n lcStreamName]
311 }
312
313renderTargetOutputs :: Vector GLTexture -> RenderTarget -> GLRenderTarget -> [GLOutput]
314renderTargetOutputs glTexs (RenderTarget targetItems) (GLRenderTarget fbo bufs) =
315 let isFB (Framebuffer _) = True
316 isFB _ = False
317 images = [img | TargetItem _ (Just img) <- V.toList targetItems]
318 in case all isFB images of
319 True -> fromMaybe [] $ (GLOutputDrawBuffer fbo <$>) <$> bufs
320 False -> (\(TextureImage texIdx _ _)-> GLOutputRenderTexture fbo $ glTexs ! texIdx) <$> images
321
322compileRenderTarget :: Vector TextureDescriptor -> Vector GLTexture -> RenderTarget -> IO GLRenderTarget
323compileRenderTarget texs glTexs (RenderTarget targets) = do
324 let isFB (Framebuffer _) = True
325 isFB _ = False
326 images = [img | TargetItem _ (Just img) <- V.toList targets]
327 case all isFB images of
328 True -> do
329 let bufs = [cvt img | TargetItem Color img <- V.toList targets]
330 cvt a = case a of
331 Nothing -> GL_NONE
332 Just (Framebuffer Color) -> GL_BACK_LEFT
333 _ -> error "internal error (compileRenderTarget)!"
334 return $ GLRenderTarget
335 { framebufferObject = 0
336 , framebufferDrawbuffers = Just bufs
337 }
338 False -> do
339 when (any isFB images) $ fail "internal error (compileRenderTarget)!"
340 fbo <- alloca $! \pbo -> glGenFramebuffers 1 pbo >> peek pbo
341 glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo
342 {-
343 void glFramebufferTexture1D(GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level);
344 GL_TEXTURE_1D
345 void glFramebufferTexture2D(GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level);
346 GL_TEXTURE_2D
347 GL_TEXTURE_RECTANGLE
348 GL_TEXTURE_CUBE_MAP_POSITIVE_X
349 GL_TEXTURE_CUBE_MAP_POSITIVE_Y
350 GL_TEXTURE_CUBE_MAP_POSITIVE_Z
351 GL_TEXTURE_CUBE_MAP_NEGATIVE_X
352 GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
353 GL_TEXTURE_CUBE_MAP_NEGATIVE_Z
354 GL_TEXTURE_2D_MULTISAMPLE
355 void glFramebufferTextureLayer(GLenum target, GLenum attachment, GLuint texture, GLint level, GLint layer);
356 void glFramebufferRenderbuffer(GLenum target, GLenum attachment, GLenum renderbuffertarget, GLuint renderbuffer);
357 void glFramebufferTexture(GLenum target, GLenum attachment, GLuint texture, GLint level);
358 -}
359 let attach attachment (TextureImage texIdx level (Just layer)) =
360 glFramebufferTextureLayer GL_DRAW_FRAMEBUFFER attachment (glTextureTarget $ glTexs ! texIdx) (fromIntegral level) (fromIntegral layer)
361 attach attachment (TextureImage texIdx level Nothing) = do
362 let glTex = glTexs ! texIdx
363 tex = texs ! texIdx
364 txLevel = fromIntegral level
365 txTarget = glTextureTarget glTex
366 txObj = glTextureObject glTex
367 attachArray = glFramebufferTexture GL_DRAW_FRAMEBUFFER attachment txObj txLevel
368 attach2D = glFramebufferTexture2D GL_DRAW_FRAMEBUFFER attachment txTarget txObj txLevel
369 case textureType tex of
370 Texture1D _ n
371 | n > 1 -> attachArray
372 | otherwise -> glFramebufferTexture1D GL_DRAW_FRAMEBUFFER attachment txTarget txObj txLevel
373 Texture2D _ n
374 | n > 1 -> attachArray
375 | otherwise -> attach2D
376 Texture3D _ -> attachArray
377 TextureCube _ -> attachArray
378 TextureRect _ -> attach2D
379 Texture2DMS _ n _ _
380 | n > 1 -> attachArray
381 | otherwise -> attach2D
382 TextureBuffer _ -> fail "internalError (compileRenderTarget/TextureBuffer)!"
383
384 go a (TargetItem Stencil (Just img)) = do
385 fail "Stencil support is not implemented yet!"
386 return a
387 go a (TargetItem Depth (Just img)) = do
388 attach GL_DEPTH_ATTACHMENT img
389 return a
390 go (bufs,colorIdx) (TargetItem Color (Just img)) = do
391 let attachment = GL_COLOR_ATTACHMENT0 + fromIntegral colorIdx
392 attach attachment img
393 return (attachment : bufs, colorIdx + 1)
394 go (bufs,colorIdx) (TargetItem Color Nothing) = return (GL_NONE : bufs, colorIdx + 1)
395 go a _ = return a
396 (bufs,_) <- foldM go ([],0) targets
397 withArray (reverse bufs) $ glDrawBuffers (fromIntegral $ length bufs)
398 return $ GLRenderTarget
399 { framebufferObject = fbo
400 , framebufferDrawbuffers = Nothing
401 }
402
403compileStreamData :: StreamData -> IO GLStream
404compileStreamData s = do
405 let withV w a f = w a (\p -> f $ castPtr p)
406 let compileAttr (VFloatArray v) = Array ArrFloat (V.length v) (withV (SV.unsafeWith . V.convert) v)
407 compileAttr (VIntArray v) = Array ArrInt32 (V.length v) (withV (SV.unsafeWith . V.convert) v)
408 compileAttr (VWordArray v) = Array ArrWord32 (V.length v) (withV (SV.unsafeWith . V.convert) v)
409 --TODO: compileAttr (VBoolArray v) = Array ArrWord32 (length v) (withV withArray v)
410 (indexMap,arrays) = unzip [((n,i),compileAttr d) | (i,(n,d)) <- zip [0..] $ Map.toList $ streamData s]
411 getLength n = l `div` c
412 where
413 l = case Map.lookup n $ IR.streamData s of
414 Just (VFloatArray v) -> V.length v
415 Just (VIntArray v) -> V.length v
416 Just (VWordArray v) -> V.length v
417 _ -> error "compileStreamData - getLength"
418 c = case Map.lookup n $ IR.streamType s of
419 Just Bool -> 1
420 Just V2B -> 2
421 Just V3B -> 3
422 Just V4B -> 4
423 Just Word -> 1
424 Just V2U -> 2
425 Just V3U -> 3
426 Just V4U -> 4
427 Just Int -> 1
428 Just V2I -> 2
429 Just V3I -> 3
430 Just V4I -> 4
431 Just Float -> 1
432 Just V2F -> 2
433 Just V3F -> 3
434 Just V4F -> 4
435 Just M22F -> 4
436 Just M23F -> 6
437 Just M24F -> 8
438 Just M32F -> 6
439 Just M33F -> 9
440 Just M34F -> 12
441 Just M42F -> 8
442 Just M43F -> 12
443 Just M44F -> 16
444 _ -> error "compileStreamData - getLength element count"
445 buffer <- compileBuffer arrays
446 cmdRef <- newIORef []
447 let toStream (n,i) = (n,Stream
448 { streamType = fromMaybe (error $ "missing attribute: " ++ n) $ toStreamType =<< Map.lookup n (IR.streamType s)
449 , streamBuffer = buffer
450 , streamArrIdx = i
451 , streamStart = 0
452 , streamLength = getLength n
453 })
454 return $ GLStream
455 { glStreamCommands = cmdRef
456 , glStreamPrimitive = case streamPrimitive s of
457 Points -> PointList
458 Lines -> LineList
459 Triangles -> TriangleList
460 LinesAdjacency -> LineListAdjacency
461 TrianglesAdjacency -> TriangleListAdjacency
462 , glStreamAttributes = Map.fromList $ map toStream indexMap
463 , glStreamProgram = V.head $ streamPrograms s
464 }
465
466createStreamCommands :: Map String (IORef GLint) -> Map String GLUniform -> Map String (Stream Buffer) -> Primitive -> GLProgram -> [GLObjectCommand]
467createStreamCommands texUnitMap topUnis attrs primitive prg = streamUniCmds ++ streamCmds ++ [drawCmd]
468 where
469 -- object draw command
470 drawCmd = GLDrawArrays prim 0 (fromIntegral count)
471 where
472 prim = primitiveToGLType primitive
473 count = head [c | Stream _ _ _ _ c <- Map.elems attrs]
474
475 -- object uniform commands
476 -- texture slot setup commands
477 streamUniCmds = uniCmds ++ texCmds
478 where
479 uniCmds = [GLSetUniform i u | (n,i) <- uniMap, let u = topUni n]
480 uniMap = Map.toList $ inputUniforms prg
481 topUni n = Map.findWithDefault (error "internal error (createStreamCommands)!") n topUnis
482 texUnis = Set.toList $ inputTextureUniforms prg
483 texCmds = [ GLBindTexture (inputTypeToTextureTarget $ uniInputType u) texUnit u
484 | n <- texUnis
485 , let u = topUni n
486 , let texUnit = Map.findWithDefault (error "internal error (createStreamCommands - Texture Unit)") n texUnitMap
487 ]
488 uniInputType (GLUniform ty _) = ty
489
490 -- object attribute stream commands
491 streamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let s = fromMaybe (error $ "missing attribute: " ++ name) $ Map.lookup name attrs]
492 where
493 attrMap = inputStreams prg
494 attrCmd i s = case s of
495 Stream ty (Buffer arrs bo) arrIdx start len -> case ty of
496 Attribute_Word -> setIntAttrib 1
497 Attribute_V2U -> setIntAttrib 2
498 Attribute_V3U -> setIntAttrib 3
499 Attribute_V4U -> setIntAttrib 4
500 Attribute_Int -> setIntAttrib 1
501 Attribute_V2I -> setIntAttrib 2
502 Attribute_V3I -> setIntAttrib 3
503 Attribute_V4I -> setIntAttrib 4
504 Attribute_Float -> setFloatAttrib 1
505 Attribute_V2F -> setFloatAttrib 2
506 Attribute_V3F -> setFloatAttrib 3
507 Attribute_V4F -> setFloatAttrib 4
508 Attribute_M22F -> setFloatAttrib 4
509 Attribute_M23F -> setFloatAttrib 6
510 Attribute_M24F -> setFloatAttrib 8
511 Attribute_M32F -> setFloatAttrib 6
512 Attribute_M33F -> setFloatAttrib 9
513 Attribute_M34F -> setFloatAttrib 12
514 Attribute_M42F -> setFloatAttrib 8
515 Attribute_M43F -> setFloatAttrib 12
516 Attribute_M44F -> setFloatAttrib 16
517 where
518 setFloatAttrib n = GLSetVertexAttribArray i bo n glType (ptr n)
519 setIntAttrib n = GLSetVertexAttribIArray i bo n glType (ptr n)
520 ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx
521 glType = arrayTypeToGLType arrType
522 ptr compCnt = intPtrToPtr $! fromIntegral (arrOffs + start * fromIntegral compCnt * sizeOfArrayType arrType)
523
524 -- constant generic attribute
525 constAttr -> GLSetVertexAttrib i constAttr
526
527outputIsRenderTexture :: GLOutput -> Bool
528outputIsRenderTexture GLOutputRenderTexture{..} = True
529outputIsRenderTexture _ = False
530
531allocRenderer :: Pipeline -> IO GLRenderer
532allocRenderer p = do
533 smps <- V.mapM compileSampler $ samplers p
534 texs <- V.mapM compileTexture $ textures p
535 let cmds = V.toList $ commands p
536 finalRenderTargetIdx = head [i | SetRenderTarget i <- reverse $ cmds]
537 trgs <- traverse (compileRenderTarget (textures p) texs) $ targets p
538 let finalRenderTarget = targets p ! finalRenderTargetIdx
539 finalGLRenderTarget = trgs ! finalRenderTargetIdx
540 outs = renderTargetOutputs texs finalRenderTarget finalGLRenderTarget
541 prgs <- V.mapM compileProgram $ programs p
542 -- texture unit mapping ioref trie
543 -- texUnitMapRefs :: Map UniformName (IORef TextureUnit)
544 texUnitMapRefs <- Map.fromList <$> mapM (\k -> (k,) <$> newIORef 0) (Set.toList $ Set.fromList $ concat $ V.toList $ V.map (Map.keys . programInTextures) $ programs p)
545 let st = execState (mapM_ (compileCommand texUnitMapRefs smps texs trgs prgs) cmds) initCGState
546 input <- newIORef Nothing
547 -- default Vertex Array Object
548 vao <- alloca $! \pvao -> glGenVertexArrays 1 pvao >> peek pvao
549 strs <- V.mapM compileStreamData $ streams p
550 drawContextRef <- newIORef $ error "missing DrawContext"
551 forceSetup <- newIORef True
552 vertexBufferRef <- newIORef 0
553 indexBufferRef <- newIORef 0
554 drawCallCounterRef <- newIORef 0
555 return $ GLRenderer
556 { glPrograms = prgs
557 , glTextures = texs
558 , glSamplers = smps
559 , glTargets = trgs
560 , glCommands = reverse $ drawCommands st
561 , glSlotPrograms = V.map (V.toList . slotPrograms) $ IR.slots p
562 , glInput = input
563 , glOutputs = outs
564 , glSlotNames = V.map slotName $ IR.slots p
565 , glVAO = vao
566 , glTexUnitMapping = texUnitMapRefs
567 , glStreams = strs
568 , glDrawContextRef = drawContextRef
569 , glForceSetup = forceSetup
570 , glVertexBufferRef = vertexBufferRef
571 , glIndexBufferRef = indexBufferRef
572 , glDrawCallCounterRef = drawCallCounterRef
573 }
574
575disposeRenderer :: GLRenderer -> IO ()
576disposeRenderer p = do
577 setStorage' p Nothing
578 V.forM_ (glPrograms p) $ \prg -> do
579 glDeleteProgram $ programObject prg
580 mapM_ glDeleteShader $ shaderObjects prg
581 let targets = glTargets p
582 withArray (map framebufferObject $ V.toList targets) $ (glDeleteFramebuffers $ fromIntegral $ V.length targets)
583 let textures = glTextures p
584 withArray (map glTextureObject $ V.toList textures) $ (glDeleteTextures $ fromIntegral $ V.length textures)
585 let samplers = glSamplers p
586 withArray (map glSamplerObject $ V.toList samplers) $ (glDeleteSamplers . fromIntegral . V.length $ glSamplers p)
587 with (glVAO p) $ (glDeleteVertexArrays 1)
588
589{-
590data ObjectArraySchema
591 = ObjectArraySchema
592 { primitive :: FetchPrimitive
593 , attributes :: Trie StreamType
594 }
595 deriving Show
596
597data PipelineSchema
598 = PipelineSchema
599 { objectArrays :: Trie ObjectArraySchema
600 , uniforms :: Trie InputType
601 }
602 deriving Show
603-}
604isSubTrie :: (a -> a -> Bool) -> Map String a -> Map String a -> Bool
605isSubTrie eqFun universe subset = and [isMember a (Map.lookup n universe) | (n,a) <- Map.toList subset]
606 where
607 isMember a Nothing = False
608 isMember a (Just b) = eqFun a b
609
610-- TODO: if there is a mismatch thow detailed error message in the excoeption, containing the missing attributes and uniforms
611{-
612 let sch = schema input
613 forM_ uniformNames $ \n -> case Map.lookup n (uniforms sch) of
614 Nothing -> throw $ userError $ "Unknown uniform: " ++ show n
615 _ -> return ()
616 case Map.lookup slotName (objectArrays sch) of
617 Nothing -> throw $ userError $ "Unknown slot: " ++ show slotName
618 Just (ObjectArraySchema sPrim sAttrs) -> do
619 when (sPrim /= (primitiveToFetchPrimitive prim)) $ throw $ userError $
620 "Primitive mismatch for slot (" ++ show slotName ++ ") expected " ++ show sPrim ++ " but got " ++ show prim
621 let sType = fmap streamToStreamType attribs
622 when (sType /= sAttrs) $ throw $ userError $ unlines $
623 [ "Attribute stream mismatch for slot (" ++ show slotName ++ ") expected "
624 , show sAttrs
625 , " but got "
626 , show sType
627 ]
628-}
629
630setStorage :: GLRenderer -> GLStorage -> IO (Maybe String)
631setStorage p input' = setStorage' p (Just input')
632
633setStorage' :: GLRenderer -> Maybe GLStorage -> IO (Maybe String)
634setStorage' p@GLRenderer{..} input' = do
635 -- TODO: check matching input schema
636 {-
637 case input' of
638 Nothing -> return ()
639 Just input -> schemaFromPipeline p
640 -}
641 {-
642 deletion:
643 - remove pipeline's object commands from used objectArrays
644 - remove pipeline from attached pipelines vector
645 -}
646 readIORef glInput >>= \case
647 Nothing -> return ()
648 Just InputConnection{..} -> do
649 let slotRefs = slotVector icInput
650 modifyIORef (pipelines icInput) $ \v -> v // [(icId,Nothing)]
651 V.forM_ icSlotMapPipelineToInput $ \slotIdx -> do
652 slot <- readIORef (slotRefs ! slotIdx)
653 forM_ (objectMap slot) $ \obj -> do
654 modifyIORef (objCommands obj) $ \v -> v // [(icId,V.empty)]
655 {-
656 addition:
657 - get an id from pipeline input
658 - add to attached pipelines
659 - generate slot mappings
660 - update used objectArrays, and generate object commands for objects in the related objectArrays
661 -}
662 case input' of
663 Nothing -> writeIORef glInput Nothing >> return Nothing
664 Just input -> do
665 let pipelinesRef = pipelines input
666 oldPipelineV <- readIORef pipelinesRef
667 (idx,shouldExtend) <- case V.findIndex isNothing oldPipelineV of
668 Nothing -> do
669 -- we don't have empty space, hence we double the vector size
670 let len = V.length oldPipelineV
671 modifyIORef pipelinesRef $ \v -> (V.concat [v,V.replicate len Nothing]) // [(len,Just p)]
672 return (len,Just len)
673 Just i -> do
674 modifyIORef pipelinesRef $ \v -> v // [(i,Just p)]
675 return (i,Nothing)
676 -- create input connection
677 let sm = slotMap input
678 pToI = [i | n <- glSlotNames, let i = fromMaybe (error $ "setStorage - missing object array: " ++ n) $ Map.lookup n sm]
679 iToP = V.update (V.replicate (Map.size sm) Nothing) (V.imap (\i v -> (v, Just i)) pToI)
680 writeIORef glInput $ Just $ InputConnection idx input pToI iToP
681
682 -- generate object commands for related objectArrays
683 {-
684 for each slot in pipeline:
685 map slot name to input slot name
686 for each object:
687 generate command program vector => for each dependent program:
688 generate object commands
689 -}
690 let slotV = slotVector input
691 progV = glPrograms
692 --texUnitMap = glTexUnitMapping p
693 topUnis = uniformSetup input
694 emptyV = V.replicate (V.length progV) []
695 extend v = case shouldExtend of
696 Nothing -> v
697 Just l -> V.concat [v,V.replicate l V.empty]
698 V.forM_ (V.zip pToI glSlotPrograms) $ \(slotIdx,prgs) -> do
699 slot <- readIORef $ slotV ! slotIdx
700 forM_ (objectMap slot) $ \obj -> do
701 let cmdV = emptyV // [(prgIdx,createObjectCommands glTexUnitMapping topUnis obj (progV ! prgIdx)) | prgIdx <- prgs]
702 modifyIORef (objCommands obj) $ \v -> extend v // [(idx,cmdV)]
703 -- generate stream commands
704 V.forM_ glStreams $ \s -> do
705 writeIORef (glStreamCommands s) $ createStreamCommands glTexUnitMapping topUnis (glStreamAttributes s) (glStreamPrimitive s) (progV ! glStreamProgram s)
706 return Nothing
707{-
708 track state:
709 - render target
710 - binded textures
711-}
712
713{-
714 render steps:
715 - update uniforms
716 - per uniform setup
717 - buffer setup (one buffer per object, which has per at least one object uniform)
718 - new command: set uniform buffer (binds uniform buffer to program's buffer slot)
719 - render slot steps:
720 - set uniform buffer or set uniforms separately
721 - set vertex and index array
722 - call draw command
723-}
724{-
725 storage alternatives:
726 - interleaved / separated
727 - VAO or VBOs
728-}
729 {-
730 strategy:
731 step 1: generate commands for an object
732 step 2: sort object merge and do optimization by filtering redundant commands
733 -}
734{-
735 design:
736 runtime eleminiation of redundant buffer bind commands and redundant texture bind commands
737-}
738{-
739 track:
740 buffer binding on various targets: GL_ARRAY_BUFFER, GL_ELEMENT_ARRAY_BUFFER
741 glEnable/DisableVertexAttribArray
742-}
743renderSlot :: IORef Int -> IORef GLuint -> IORef GLuint -> [GLObjectCommand] -> IO ()
744renderSlot glDrawCallCounterRef glVertexBufferRef glIndexBufferRef cmds = forM_ cmds $ \cmd -> do
745 let setup ref v m = do
746 old <- readIORef ref
747 unless (old == v) $ do
748 writeIORef ref v
749 m
750
751 case cmd of
752 GLSetVertexAttribArray idx buf size typ ptr -> do
753 setup glVertexBufferRef buf $ glBindBuffer GL_ARRAY_BUFFER buf
754 glEnableVertexAttribArray idx
755 glVertexAttribPointer idx size typ (fromIntegral GL_FALSE) 0 ptr
756 GLSetVertexAttribIArray idx buf size typ ptr -> do
757 setup glVertexBufferRef buf $ glBindBuffer GL_ARRAY_BUFFER buf
758 glEnableVertexAttribArray idx
759 glVertexAttribIPointer idx size typ 0 ptr
760 GLDrawArrays mode first count -> glDrawArrays mode first count >> modifyIORef glDrawCallCounterRef succ
761 GLDrawElements mode count typ buf indicesPtr -> do
762 setup glIndexBufferRef buf $ glBindBuffer GL_ELEMENT_ARRAY_BUFFER buf
763 glDrawElements mode count typ indicesPtr
764 modifyIORef glDrawCallCounterRef succ
765 GLSetUniform idx (GLUniform ty ref) -> setUniform idx ty ref
766 GLBindTexture txTarget tuRef (GLUniform _ ref) -> do
767 txObjVal <- readIORef ref
768 -- HINT: ugly and hacky
769 with txObjVal $ \txObjPtr -> do
770 txObj <- peek $ castPtr txObjPtr :: IO GLuint
771 texUnit <- readIORef tuRef
772 glActiveTexture $ GL_TEXTURE0 + fromIntegral texUnit
773 glBindTexture txTarget txObj
774 --putStrLn $ "to texture unit " ++ show texUnit ++ " texture object " ++ show txObj
775 GLSetVertexAttrib idx val -> do
776 glDisableVertexAttribArray idx
777 setVertexAttrib idx val
778 --isOk <- checkGL
779 --putStrLn $ isOk ++ " - " ++ show cmd
780
781setupRenderTarget glInput GLRenderTarget{..} = do
782 -- set target viewport
783 ic' <- readIORef glInput
784 case ic' of
785 Nothing -> return ()
786 Just ic -> do
787 let input = icInput ic
788 (w,h) <- readIORef $ screenSize input
789 glViewport 0 0 (fromIntegral w) (fromIntegral h)
790 -- TODO: set FBO target viewport
791 glBindFramebuffer GL_DRAW_FRAMEBUFFER framebufferObject
792 case framebufferDrawbuffers of
793 Nothing -> return ()
794 Just bl -> withArray bl $ glDrawBuffers (fromIntegral $ length bl)
795
796setupDrawContext glForceSetup glDrawContextRef glInput new = do
797 old <- readIORef glDrawContextRef
798 writeIORef glDrawContextRef new
799 force <- readIORef glForceSetup
800 writeIORef glForceSetup False
801
802 let setup :: Eq a => (GLDrawContext -> a) -> (a -> IO ()) -> IO ()
803 setup f m = case force of
804 True -> m $ f new
805 False -> do
806 let a = f new
807 unless (a == f old) $ m a
808
809 setup glRenderTarget $ setupRenderTarget glInput
810 setup glRasterContext $ setupRasterContext
811 setup glAccumulationContext setupAccumulationContext
812 setup glProgram glUseProgram
813
814 -- setup texture mapping
815 setup glTextureMapping $ mapM_ $ \(textureUnit,GLTexture{..}) -> do
816 glActiveTexture (GL_TEXTURE0 + fromIntegral textureUnit)
817 glBindTexture glTextureTarget glTextureObject
818
819 -- setup sampler mapping
820 setup glSamplerMapping $ mapM_ $ \(textureUnit,GLSampler{..}) -> do
821 glBindSampler (GL_TEXTURE0 + fromIntegral textureUnit) glSamplerObject
822
823 -- setup sampler uniform mapping
824 forM_ (glSamplerUniformMapping new) $ \(textureUnit,GLSamplerUniform{..}) -> do
825 glUniform1i glUniformBinding (fromIntegral textureUnit)
826 writeIORef glUniformBindingRef (fromIntegral textureUnit)
827
828renderFrame :: GLRenderer -> IO ()
829renderFrame GLRenderer{..} = do
830 writeIORef glForceSetup True
831 writeIORef glVertexBufferRef 0
832 writeIORef glIndexBufferRef 0
833 writeIORef glDrawCallCounterRef 0
834 glBindVertexArray glVAO
835 forM_ glCommands $ \cmd -> do
836 case cmd of
837 GLClearRenderTarget rt vals -> do
838 setupRenderTarget glInput rt
839 clearRenderTarget rt vals
840 modifyIORef glDrawContextRef $ \ctx -> ctx {glRenderTarget = rt}
841
842 GLRenderStream ctx streamIdx progIdx -> do
843 setupDrawContext glForceSetup glDrawContextRef glInput ctx
844 drawcmd <- readIORef (glStreamCommands $ glStreams ! streamIdx)
845 renderSlot glDrawCallCounterRef glVertexBufferRef glIndexBufferRef drawcmd
846
847 GLRenderSlot ctx slotIdx progIdx -> do
848 input <- readIORef glInput
849 case input of
850 Nothing -> putStrLn "Warning: No pipeline input!" >> return ()
851 Just ic -> do
852 let draw setupDone obj = readIORef (objEnabled obj) >>= \case
853 False -> return setupDone
854 True -> do
855 unless setupDone $ setupDrawContext glForceSetup glDrawContextRef glInput ctx
856 drawcmd <- readIORef $ objCommands obj
857 --putStrLn "Render object"
858 renderSlot glDrawCallCounterRef glVertexBufferRef glIndexBufferRef ((drawcmd ! icId ic) ! progIdx)
859 return True
860 --putStrLn $ "Rendering " ++ show (V.length objs) ++ " objects"
861 readIORef (slotVector (icInput ic) ! (icSlotMapPipelineToInput ic ! slotIdx)) >>= \case
862 GLSlot _ objs Ordered -> foldM_ (\a -> draw a . snd) False objs
863 GLSlot objMap _ _ -> foldM_ draw False objMap
864
865 --isOk <- checkGL
866 --putStrLn $ isOk ++ " - " ++ show cmd
867 --readIORef glDrawCallCounterRef >>= \n -> putStrLn (show n ++ " draw calls")
868
869data CGState
870 = CGState
871 { drawCommands :: [GLCommand]
872 -- draw context data
873 , rasterContext :: RasterContext
874 , accumulationContext :: AccumulationContext
875 , renderTarget :: GLRenderTarget
876 , currentProgram :: ProgramName
877 , samplerUniformMapping :: IntMap GLSamplerUniform
878 , textureMapping :: IntMap GLTexture
879 , samplerMapping :: IntMap GLSampler
880 }
881
882initCGState = CGState
883 { drawCommands = mempty
884 -- draw context data
885 , rasterContext = error "compileCommand: missing RasterContext"
886 , accumulationContext = error "compileCommand: missing AccumulationContext"
887 , renderTarget = error "compileCommand: missing RenderTarget"
888 , currentProgram = error "compileCommand: missing Program"
889 , samplerUniformMapping = mempty
890 , textureMapping = mempty
891 , samplerMapping = mempty
892 }
893
894type CG a = State CGState a
895
896emit :: GLCommand -> CG ()
897emit cmd = modify $ \s -> s {drawCommands = cmd : drawCommands s}
898
899drawContext programs = do
900 GLProgram{..} <- (programs !) <$> gets currentProgram
901 let f = take (Map.size inputTextures) . IntMap.toList
902 GLDrawContext <$> gets rasterContext
903 <*> gets accumulationContext
904 <*> gets renderTarget
905 <*> pure programObject
906 <*> gets (f . textureMapping)
907 <*> gets (f . samplerMapping)
908 <*> gets (f . samplerUniformMapping)
909
910compileCommand :: Map String (IORef GLint) -> Vector GLSampler -> Vector GLTexture -> Vector GLRenderTarget -> Vector GLProgram -> Command -> CG ()
911compileCommand texUnitMap samplers textures targets programs cmd = case cmd of
912 SetRasterContext rCtx -> modify $ \s -> s {rasterContext = rCtx}
913 SetAccumulationContext aCtx -> modify $ \s -> s {accumulationContext = aCtx}
914 SetRenderTarget rt -> modify $ \s -> s {renderTarget = targets ! rt}
915 SetProgram p -> modify $ \s -> s {currentProgram = p}
916 SetSamplerUniform n tu -> do
917 p <- currentProgram <$> get
918 case Map.lookup n (inputTextures $ programs ! p) of
919 Nothing -> return () -- TODO: some drivers does heavy cross stage (vertex/fragment) dead code elimination; fail $ "internal error (SetSamplerUniform)! - " ++ show cmd
920 Just i -> case Map.lookup n texUnitMap of
921 Nothing -> fail $ "internal error (SetSamplerUniform - IORef)! - " ++ show cmd
922 Just r -> modify $ \s -> s {samplerUniformMapping = IntMap.insert tu (GLSamplerUniform i r) $ samplerUniformMapping s}
923 SetTexture tu t -> modify $ \s -> s {textureMapping = IntMap.insert tu (textures ! t) $ textureMapping s}
924 SetSampler tu i -> modify $ \s -> s {samplerMapping = IntMap.insert tu (maybe (GLSampler 0) (samplers !) i) $ samplerMapping s}
925
926 -- draw commands
927 RenderSlot slot -> do
928 p <- gets currentProgram
929 ctx <- drawContext programs
930 emit $ GLRenderSlot ctx slot p
931 RenderStream stream -> do
932 p <- gets currentProgram
933 ctx <- drawContext programs
934 emit $ GLRenderStream ctx stream p
935 ClearRenderTarget vals -> do
936 rt <- gets renderTarget
937 emit $ GLClearRenderTarget rt $ V.toList vals
938{-
939 GenerateMipMap tu -> do
940 tb <- textureBinding <$> get
941 case IM.lookup tu tb of
942 Nothing -> fail "internal error (GenerateMipMap)!"
943 Just tex -> return $ GLGenerateMipMap (GL_TEXTURE0 + fromIntegral tu) (glTextureTarget tex)
944-}
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-20 18:46:53 +0000