summaryrefslogtreecommitdiff
path: root/Backend/GL/Backend.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Backend/GL/Backend.hs')
-rw-r--r--Backend/GL/Backend.hs833
1 files changed, 0 insertions, 833 deletions
diff --git a/Backend/GL/Backend.hs b/Backend/GL/Backend.hs
deleted file mode 100644
index 55ae443..0000000
--- a/Backend/GL/Backend.hs
+++ /dev/null
@@ -1,833 +0,0 @@
1{-# LANGUAGE TupleSections, MonadComprehensions, ViewPatterns, RecordWildCards #-}
2module Backend.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.Rendering.OpenGL.Raw.Core33
27import Foreign
28
29-- LC IR imports
30import Linear
31import IR hiding (streamType)
32import qualified IR as IR
33
34import Backend.GL.Type
35import Backend.GL.Util
36
37import Backend.GL.Data
38import Backend.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 {}
273
274{-
275data ImageIndex
276 = TextureImage TextureName Int (Maybe Int) -- Texture name, mip index, array index
277 | Framebuffer ImageSemantic
278
279data ImageSemantic
280 = Depth
281 | Stencil
282 | Color
283-}
284{-
285 = RenderTarget
286 { renderTargets :: [(ImageSemantic,Maybe ImageIndex)] -- render texture or default framebuffer (semantic, render texture for the program output)
287 }
288-}
289{-
290 glDrawBuffers
291 GL_NONE
292 --GL_FRONT_LEFT
293 --GL_FRONT_RIGHT
294 GL_BACK_LEFT
295 --GL_BACK_RIGHT
296 GL_COLOR_ATTACHMENTn
297-}
298compileRenderTarget :: Vector TextureDescriptor -> Vector GLTexture -> RenderTarget -> IO GLRenderTarget
299compileRenderTarget texs glTexs (RenderTarget targets) = do
300 let isFB (Framebuffer _) = True
301 isFB _ = False
302 images = [img | TargetItem _ (Just img) <- V.toList targets]
303 case all isFB images of
304 True -> do
305 let bufs = [cvt img | TargetItem Color img <- V.toList targets]
306 cvt a = case a of
307 Nothing -> gl_NONE
308 Just (Framebuffer Color) -> gl_BACK_LEFT
309 _ -> error "internal error (compileRenderTarget)!"
310 return $ GLRenderTarget
311 { framebufferObject = 0
312 , framebufferDrawbuffers = Just bufs
313 }
314 False -> do
315 when (any isFB images) $ fail "internal error (compileRenderTarget)!"
316 fbo <- alloca $! \pbo -> glGenFramebuffers 1 pbo >> peek pbo
317 glBindFramebuffer gl_DRAW_FRAMEBUFFER fbo
318 {-
319 void glFramebufferTexture1D(GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level);
320 GL_TEXTURE_1D
321 void glFramebufferTexture2D(GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level);
322 GL_TEXTURE_2D
323 GL_TEXTURE_RECTANGLE
324 GL_TEXTURE_CUBE_MAP_POSITIVE_X
325 GL_TEXTURE_CUBE_MAP_POSITIVE_Y
326 GL_TEXTURE_CUBE_MAP_POSITIVE_Z
327 GL_TEXTURE_CUBE_MAP_NEGATIVE_X
328 GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
329 GL_TEXTURE_CUBE_MAP_NEGATIVE_Z
330 GL_TEXTURE_2D_MULTISAMPLE
331 void glFramebufferTextureLayer(GLenum target, GLenum attachment, GLuint texture, GLint level, GLint layer);
332 void glFramebufferRenderbuffer(GLenum target, GLenum attachment, GLenum renderbuffertarget, GLuint renderbuffer);
333 void glFramebufferTexture(GLenum target, GLenum attachment, GLuint texture, GLint level);
334 -}
335 let attach attachment (TextureImage texIdx level (Just layer)) =
336 glFramebufferTextureLayer gl_DRAW_FRAMEBUFFER attachment (glTextureTarget $ glTexs ! texIdx) (fromIntegral level) (fromIntegral layer)
337 attach attachment (TextureImage texIdx level Nothing) = do
338 let glTex = glTexs ! texIdx
339 tex = texs ! texIdx
340 txLevel = fromIntegral level
341 txTarget = glTextureTarget glTex
342 txObj = glTextureObject glTex
343 attachArray = glFramebufferTexture gl_DRAW_FRAMEBUFFER attachment txObj txLevel
344 attach2D = glFramebufferTexture2D gl_DRAW_FRAMEBUFFER attachment txTarget txObj txLevel
345 case textureType tex of
346 Texture1D _ n
347 | n > 1 -> attachArray
348 | otherwise -> glFramebufferTexture1D gl_DRAW_FRAMEBUFFER attachment txTarget txObj txLevel
349 Texture2D _ n
350 | n > 1 -> attachArray
351 | otherwise -> attach2D
352 Texture3D _ -> attachArray
353 TextureCube _ -> attachArray
354 TextureRect _ -> attach2D
355 Texture2DMS _ n _ _
356 | n > 1 -> attachArray
357 | otherwise -> attach2D
358 TextureBuffer _ -> fail "internalError (compileRenderTarget/TextureBuffer)!"
359
360 go a (TargetItem Stencil (Just img)) = do
361 fail "Stencil support is not implemented yet!"
362 return a
363 go a (TargetItem Depth (Just img)) = do
364 attach gl_DEPTH_ATTACHMENT img
365 return a
366 go (bufs,colorIdx) (TargetItem Color (Just img)) = do
367 let attachment = gl_COLOR_ATTACHMENT0 + fromIntegral colorIdx
368 attach attachment img
369 return (attachment : bufs, colorIdx + 1)
370 go (bufs,colorIdx) (TargetItem Color Nothing) = return (gl_NONE : bufs, colorIdx + 1)
371 go a _ = return a
372 (bufs,_) <- foldM go ([],0) targets
373 withArray (reverse bufs) $ glDrawBuffers (fromIntegral $ length bufs)
374 return $ GLRenderTarget
375 { framebufferObject = fbo
376 , framebufferDrawbuffers = Nothing
377 }
378
379compileStreamData :: StreamData -> IO GLStream
380compileStreamData s = do
381 let withV w a f = w a (\p -> f $ castPtr p)
382 let compileAttr (VFloatArray v) = Array ArrFloat (V.length v) (withV (SV.unsafeWith . V.convert) v)
383 compileAttr (VIntArray v) = Array ArrInt32 (V.length v) (withV (SV.unsafeWith . V.convert) v)
384 compileAttr (VWordArray v) = Array ArrWord32 (V.length v) (withV (SV.unsafeWith . V.convert) v)
385 --TODO: compileAttr (VBoolArray v) = Array ArrWord32 (length v) (withV withArray v)
386 (indexMap,arrays) = unzip [((n,i),compileAttr d) | (i,(n,d)) <- zip [0..] $ Map.toList $ streamData s]
387 getLength n = l `div` c
388 where
389 l = case Map.lookup n $ IR.streamData s of
390 Just (VFloatArray v) -> V.length v
391 Just (VIntArray v) -> V.length v
392 Just (VWordArray v) -> V.length v
393 _ -> error "compileStreamData - getLength"
394 c = case Map.lookup n $ IR.streamType s of
395 Just Bool -> 1
396 Just V2B -> 2
397 Just V3B -> 3
398 Just V4B -> 4
399 Just Word -> 1
400 Just V2U -> 2
401 Just V3U -> 3
402 Just V4U -> 4
403 Just Int -> 1
404 Just V2I -> 2
405 Just V3I -> 3
406 Just V4I -> 4
407 Just Float -> 1
408 Just V2F -> 2
409 Just V3F -> 3
410 Just V4F -> 4
411 Just M22F -> 4
412 Just M23F -> 6
413 Just M24F -> 8
414 Just M32F -> 6
415 Just M33F -> 9
416 Just M34F -> 12
417 Just M42F -> 8
418 Just M43F -> 12
419 Just M44F -> 16
420 _ -> error "compileStreamData - getLength element count"
421 buffer <- compileBuffer arrays
422 cmdRef <- newIORef []
423 let toStream (n,i) = (n,Stream
424 { streamType = fromJust $ toStreamType =<< Map.lookup n (IR.streamType s)
425 , streamBuffer = buffer
426 , streamArrIdx = i
427 , streamStart = 0
428 , streamLength = getLength n
429 })
430 return $ GLStream
431 { glStreamCommands = cmdRef
432 , glStreamPrimitive = case streamPrimitive s of
433 Points -> PointList
434 Lines -> LineList
435 Triangles -> TriangleList
436 LinesAdjacency -> LineListAdjacency
437 TrianglesAdjacency -> TriangleListAdjacency
438 , glStreamAttributes = toTrie $ Map.fromList $ map toStream indexMap
439 , glStreamProgram = V.head $ streamPrograms s
440 }
441
442createStreamCommands :: Trie (IORef GLint) -> Trie GLUniform -> Trie (Stream Buffer) -> Primitive -> GLProgram -> [GLObjectCommand]
443createStreamCommands texUnitMap topUnis attrs primitive prg = streamUniCmds ++ streamCmds ++ [drawCmd]
444 where
445 -- object draw command
446 drawCmd = GLDrawArrays prim 0 (fromIntegral count)
447 where
448 prim = primitiveToGLType primitive
449 count = head [c | Stream _ _ _ _ c <- T.elems attrs]
450
451 -- object uniform commands
452 -- texture slot setup commands
453 streamUniCmds = uniCmds ++ texCmds
454 where
455 uniCmds = [GLSetUniform i u | (n,i) <- uniMap, let u = topUni n]
456 uniMap = T.toList $ inputUniforms prg
457 topUni n = T.lookupWithDefault (error "internal error (createStreamCommands)!") n topUnis
458 texUnis = S.toList $ inputTextureUniforms prg
459 texCmds = [ GLBindTexture (inputTypeToTextureTarget $ uniInputType u) texUnit u
460 | n <- texUnis
461 , let u = topUni n
462 , let texUnit = T.lookupWithDefault (error "internal error (createStreamCommands - Texture Unit)") n texUnitMap
463 ]
464 uniInputType (GLUniform ty _) = ty
465
466 -- object attribute stream commands
467 streamCmds = [attrCmd i s | (i,name) <- T.elems attrMap, let Just s = T.lookup name attrs]
468 where
469 attrMap = inputStreams prg
470 attrCmd i s = case s of
471 Stream ty (Buffer arrs bo) arrIdx start len -> case ty of
472 TWord -> setIntAttrib 1
473 TV2U -> setIntAttrib 2
474 TV3U -> setIntAttrib 3
475 TV4U -> setIntAttrib 4
476 TInt -> setIntAttrib 1
477 TV2I -> setIntAttrib 2
478 TV3I -> setIntAttrib 3
479 TV4I -> setIntAttrib 4
480 TFloat -> setFloatAttrib 1
481 TV2F -> setFloatAttrib 2
482 TV3F -> setFloatAttrib 3
483 TV4F -> setFloatAttrib 4
484 TM22F -> setFloatAttrib 4
485 TM23F -> setFloatAttrib 6
486 TM24F -> setFloatAttrib 8
487 TM32F -> setFloatAttrib 6
488 TM33F -> setFloatAttrib 9
489 TM34F -> setFloatAttrib 12
490 TM42F -> setFloatAttrib 8
491 TM43F -> setFloatAttrib 12
492 TM44F -> setFloatAttrib 16
493 where
494 setFloatAttrib n = GLSetVertexAttribArray i bo n glType (ptr n)
495 setIntAttrib n = GLSetVertexAttribIArray i bo n glType (ptr n)
496 ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx
497 glType = arrayTypeToGLType arrType
498 ptr compCnt = intPtrToPtr $! fromIntegral (arrOffs + start * fromIntegral compCnt * sizeOfArrayType arrType)
499
500 -- constant generic attribute
501 constAttr -> GLSetVertexAttrib i constAttr
502
503allocPipeline :: Pipeline -> IO GLPipeline
504allocPipeline p = do
505 let uniTrie = uniforms $ schemaFromPipeline p
506 smps <- V.mapM compileSampler $ samplers p
507 texs <- V.mapM compileTexture $ textures p
508 trgs <- V.mapM (compileRenderTarget (textures p) texs) $ targets p
509 prgs <- V.mapM (compileProgram uniTrie) $ programs p
510 -- texture unit mapping ioref trie
511 -- texUnitMapRefs :: Map UniformName (IORef TextureUnit)
512 texUnitMapRefs <- T.fromList <$> mapM (\k -> (k,) <$> newIORef 0) (S.toList $ S.fromList $ concat $ V.toList $ V.map (T.keys . toTrie . programInTextures) $ programs p)
513 let (cmds,st) = runState (mapM (compileCommand texUnitMapRefs smps texs trgs prgs) $ V.toList $ commands p) initCGState
514 input <- newIORef Nothing
515 -- default Vertex Array Object
516 vao <- alloca $! \pvao -> glGenVertexArrays 1 pvao >> peek pvao
517 strs <- V.mapM compileStreamData $ streams p
518 return $ GLPipeline
519 { glPrograms = prgs
520 , glTextures = texs
521 , glSamplers = smps
522 , glTargets = trgs
523 , glCommands = cmds
524 , glSlotPrograms = V.map (V.toList . slotPrograms) $ IR.slots p
525 , glInput = input
526 , glSlotNames = V.map (pack . slotName) $ IR.slots p
527 , glVAO = vao
528 , glTexUnitMapping = texUnitMapRefs
529 , glStreams = strs
530 }
531
532disposePipeline :: GLPipeline -> IO ()
533disposePipeline p = do
534 setPipelineInput p Nothing
535 V.forM_ (glPrograms p) $ \prg -> do
536 glDeleteProgram $ programObject prg
537 mapM_ glDeleteShader $ shaderObjects prg
538 let targets = glTargets p
539 withArray (map framebufferObject $ V.toList targets) $ (glDeleteFramebuffers $ fromIntegral $ V.length targets)
540 let textures = glTextures p
541 withArray (map glTextureObject $ V.toList textures) $ (glDeleteTextures $ fromIntegral $ V.length textures)
542 with (glVAO p) $ (glDeleteVertexArrays 1)
543
544{-
545data SlotSchema
546 = SlotSchema
547 { primitive :: FetchPrimitive
548 , attributes :: Trie StreamType
549 }
550 deriving Show
551
552data PipelineSchema
553 = PipelineSchema
554 { slots :: Trie SlotSchema
555 , uniforms :: Trie InputType
556 }
557 deriving Show
558-}
559isSubTrie :: (a -> a -> Bool) -> Trie a -> Trie a -> Bool
560isSubTrie eqFun universe subset = and [isMember a (T.lookup n universe) | (n,a) <- T.toList subset]
561 where
562 isMember a Nothing = False
563 isMember a (Just b) = eqFun a b
564
565-- TODO: if there is a mismatch thow detailed error message in the excoeption, containing the missing attributes and uniforms
566{-
567 let sch = schema input
568 forM_ uniformNames $ \n -> case T.lookup n (uniforms sch) of
569 Nothing -> throw $ userError $ "Unknown uniform: " ++ show n
570 _ -> return ()
571 case T.lookup slotName (slots sch) of
572 Nothing -> throw $ userError $ "Unknown slot: " ++ show slotName
573 Just (SlotSchema sPrim sAttrs) -> do
574 when (sPrim /= (primitiveToFetchPrimitive prim)) $ throw $ userError $
575 "Primitive mismatch for slot (" ++ show slotName ++ ") expected " ++ show sPrim ++ " but got " ++ show prim
576 let sType = fmap streamToStreamType attribs
577 when (sType /= sAttrs) $ throw $ userError $ unlines $
578 [ "Attribute stream mismatch for slot (" ++ show slotName ++ ") expected "
579 , show sAttrs
580 , " but got "
581 , show sType
582 ]
583-}
584setPipelineInput :: GLPipeline -> Maybe GLPipelineInput -> IO ()
585setPipelineInput p input' = do
586 -- TODO: check matching input schema
587 {-
588 case input' of
589 Nothing -> return ()
590 Just input -> schemaFromPipeline p
591 -}
592 {-
593 deletion:
594 - remove pipeline's object commands from used slots
595 - remove pipeline from attached pipelines vector
596 -}
597 ic' <- readIORef $ glInput p
598 case ic' of
599 Nothing -> return ()
600 Just ic -> do
601 let idx = icId ic
602 oldInput = icInput ic
603 slotMask = icSlotMapPipelineToInput ic
604 slotRefs = slotVector oldInput
605 modifyIORef (pipelines oldInput) $ \v -> v // [(idx,Nothing)]
606 V.forM_ slotMask $ \slotIdx -> do
607 slot <- readIORef (slotRefs ! slotIdx)
608 forM_ (IM.elems $ objectMap slot) $ \obj -> do
609 modifyIORef (objCommands obj) $ \v -> v // [(idx,V.empty)]
610 {-
611 addition:
612 - get an id from pipeline input
613 - add to attached pipelines
614 - generate slot mappings
615 - update used slots, and generate object commands for objects in the related slots
616 -}
617 case input' of
618 Nothing -> writeIORef (glInput p) Nothing
619 Just input -> do
620 let pipelinesRef = pipelines input
621 oldPipelineV <- readIORef pipelinesRef
622 (idx,shouldExtend) <- case V.findIndex isNothing oldPipelineV of
623 Nothing -> do
624 -- we don't have empty space, hence we double the vector size
625 let len = V.length oldPipelineV
626 modifyIORef pipelinesRef $ \v -> (V.concat [v,V.replicate len Nothing]) // [(len,Just p)]
627 return (len,Just len)
628 Just i -> do
629 modifyIORef pipelinesRef $ \v -> v // [(i,Just p)]
630 return (i,Nothing)
631 -- create input connection
632 let sm = slotMap input
633 pToI = [i | n <- glSlotNames p, let Just i = T.lookup n sm]
634 iToP = V.update (V.replicate (T.size sm) Nothing) (V.imap (\i v -> (v, Just i)) pToI)
635 writeIORef (glInput p) $ Just $ InputConnection idx input pToI iToP
636
637 -- generate object commands for related slots
638 {-
639 for each slot in pipeline:
640 map slot name to input slot name
641 for each object:
642 generate command program vector => for each dependent program:
643 generate object commands
644 -}
645 let slotV = slotVector input
646 progV = glPrograms p
647 texUnitMap = glTexUnitMapping p
648 topUnis = uniformSetup input
649 emptyV = V.replicate (V.length progV) []
650 extend v = case shouldExtend of
651 Nothing -> v
652 Just l -> V.concat [v,V.replicate l V.empty]
653 V.forM_ (V.zip pToI (glSlotPrograms p)) $ \(slotIdx,prgs) -> do
654 slot <- readIORef $ slotV ! slotIdx
655 forM_ (IM.elems $ objectMap slot) $ \obj -> do
656 let cmdV = emptyV // [(prgIdx,createObjectCommands texUnitMap topUnis obj (progV ! prgIdx)) | prgIdx <- prgs]
657 modifyIORef (objCommands obj) $ \v -> extend v // [(idx,cmdV)]
658 -- generate stream commands
659 V.forM_ (glStreams p) $ \s -> do
660 writeIORef (glStreamCommands s) $ createStreamCommands texUnitMap topUnis (glStreamAttributes s) (glStreamPrimitive s) (progV ! glStreamProgram s)
661{-
662 track state:
663 - render target
664 - binded textures
665-}
666
667{-
668 render steps:
669 - update uniforms
670 - per uniform setup
671 - buffer setup (one buffer per object, which has per at least one object uniform)
672 - new command: set uniform buffer (binds uniform buffer to program's buffer slot)
673 - render slot steps:
674 - set uniform buffer or set uniforms separately
675 - set vertex and index array
676 - call draw command
677-}
678{-
679 storage alternatives:
680 - interleaved / separated
681 - VAO or VBOs
682-}
683 {-
684 strategy:
685 step 1: generate commands for an object
686 step 2: sort object merge and do optimization by filtering redundant commands
687 -}
688{-
689 design:
690 runtime eleminiation of redundant buffer bind commands and redundant texture bind commands
691-}
692{-
693 track:
694 buffer binding on various targets: gl_ARRAY_BUFFER, GL_ELEMENT_ARRAY_BUFFER
695 glEnable/DisableVertexAttribArray
696-}
697renderSlot :: [GLObjectCommand] -> IO ()
698renderSlot cmds = forM_ cmds $ \cmd -> do
699 case cmd of
700 GLSetVertexAttribArray idx buf size typ ptr -> do
701 glBindBuffer gl_ARRAY_BUFFER buf
702 glEnableVertexAttribArray idx
703 glVertexAttribPointer idx size typ (fromIntegral gl_FALSE) 0 ptr
704 GLSetVertexAttribIArray idx buf size typ ptr -> do
705 glBindBuffer gl_ARRAY_BUFFER buf
706 glEnableVertexAttribArray idx
707 glVertexAttribIPointer idx size typ 0 ptr
708 GLDrawArrays mode first count -> glDrawArrays mode first count
709 GLDrawElements mode count typ buf indicesPtr -> do
710 glBindBuffer gl_ELEMENT_ARRAY_BUFFER buf
711 glDrawElements mode count typ indicesPtr
712 GLSetUniform idx (GLUniform ty ref) -> setUniform idx ty ref
713 GLBindTexture txTarget tuRef (GLUniform _ ref) -> do
714 txObjVal <- readIORef ref
715 -- HINT: ugly and hacky
716 with txObjVal $ \txObjPtr -> do
717 txObj <- peek $ castPtr txObjPtr :: IO GLuint
718 texUnit <- readIORef tuRef
719 glActiveTexture $ gl_TEXTURE0 + fromIntegral texUnit
720 glBindTexture txTarget txObj
721 putStrLn $ "to texture unit " ++ show texUnit ++ " texture object " ++ show txObj
722 GLSetVertexAttrib idx val -> do
723 glDisableVertexAttribArray idx
724 setVertexAttrib idx val
725 isOk <- checkGL
726 putStrLn $ SB.unpack isOk ++ " - " ++ show cmd
727
728renderPipeline :: GLPipeline -> IO ()
729renderPipeline glp = do
730 glBindVertexArray (glVAO glp)
731 forM_ (glCommands glp) $ \cmd -> do
732 case cmd of
733 GLSetRasterContext rCtx -> setupRasterContext rCtx
734 GLSetAccumulationContext aCtx -> setupAccumulationContext aCtx
735 GLSetRenderTarget rt bufs -> do
736 -- set target viewport
737 --when (rt == 0) $ do -- screen out
738 ic' <- readIORef $ glInput glp
739 case ic' of
740 Nothing -> return ()
741 Just ic -> do
742 let input = icInput ic
743 (w,h) <- readIORef $ screenSize input
744 glViewport 0 0 (fromIntegral w) (fromIntegral h)
745 -- TODO: set FBO target viewport
746 glBindFramebuffer gl_DRAW_FRAMEBUFFER rt
747 case bufs of
748 Nothing -> return ()
749 Just bl -> withArray bl $ glDrawBuffers (fromIntegral $ length bl)
750 GLSetProgram p -> glUseProgram p
751 GLSetSamplerUniform i tu ref -> glUniform1i i tu >> writeIORef ref tu
752 GLSetTexture tu target tx -> glActiveTexture tu >> glBindTexture target tx
753 GLClearRenderTarget vals -> clearRenderTarget vals
754 GLGenerateMipMap tu target -> glActiveTexture tu >> glGenerateMipmap target
755 GLRenderStream streamIdx progIdx -> do
756 renderSlot =<< readIORef (glStreamCommands $ glStreams glp ! streamIdx)
757 GLRenderSlot slotIdx progIdx -> do
758 input <- readIORef (glInput glp)
759 case input of
760 Nothing -> putStrLn "Warning: No pipeline input!" >> return ()
761 Just ic -> do
762 GLSlot _ objs _ <- readIORef (slotVector (icInput ic) ! (icSlotMapPipelineToInput ic ! slotIdx))
763 --putStrLn $ "Rendering " ++ show (V.length objs) ++ " objects"
764 V.forM_ objs $ \(_,obj) -> do
765 enabled <- readIORef $ objEnabled obj
766 when enabled $ do
767 cmd <- readIORef $ objCommands obj
768 --putStrLn "Render object"
769 renderSlot ((cmd ! icId ic) ! progIdx)
770 {-
771 GLSetSampler
772 GLSaveImage
773 GLLoadImage
774 -}
775 isOk <- checkGL
776 putStrLn $ SB.unpack isOk ++ " - " ++ show cmd
777
778data CGState
779 = CGState
780 { currentProgram :: ProgramName
781 , textureBinding :: IntMap GLTexture
782 , samplerUniforms :: Map UniformName TextureUnit
783 }
784
785initCGState = CGState
786 { currentProgram = error "CGState: empty currentProgram"
787 , textureBinding = IM.empty
788 , samplerUniforms = mempty
789 }
790
791type CG a = State CGState a
792
793compileCommand :: Trie (IORef GLint) -> Vector GLSampler -> Vector GLTexture -> Vector GLRenderTarget -> Vector GLProgram -> Command -> CG GLCommand
794compileCommand texUnitMap samplers textures targets programs cmd = case cmd of
795 SetRasterContext rCtx -> return $ GLSetRasterContext rCtx
796 SetAccumulationContext aCtx -> return $ GLSetAccumulationContext aCtx
797 SetRenderTarget rt -> let GLRenderTarget fbo bufs = targets ! rt in return $ GLSetRenderTarget fbo bufs
798 SetProgram p -> do
799 modify (\s -> s {currentProgram = p})
800 return $ GLSetProgram $ programObject $ programs ! p
801 SetSamplerUniform n tu -> do
802 modify (\s@CGState{..} -> s {samplerUniforms = Map.insert n tu samplerUniforms})
803 p <- currentProgram <$> get
804 case T.lookup (pack n) (inputTextures $ programs ! p) of
805 Nothing -> fail $ "internal error (SetSamplerUniform)! - " ++ show cmd
806 Just i -> case T.lookup (pack n) texUnitMap of
807 Nothing -> fail $ "internal error (SetSamplerUniform - IORef)! - " ++ show cmd
808 Just r -> return $ GLSetSamplerUniform i (fromIntegral tu) r
809 SetTexture tu t -> do
810 let tex = textures ! t
811 modify (\s -> s {textureBinding = IM.insert tu tex $ textureBinding s})
812 return $ GLSetTexture (gl_TEXTURE0 + fromIntegral tu) (glTextureTarget tex) (glTextureObject tex)
813{-
814 SetSampler tu s -> liftIO $ do
815 glBindSampler (fromIntegral tu) (samplerObject $ glSamplers glp ! s)
816-}
817 RenderSlot slot -> do
818 smpUnis <- samplerUniforms <$> get
819 p <- currentProgram <$> get
820 return $ GLRenderSlot slot p
821 RenderStream stream -> do
822 p <- currentProgram <$> get
823 return $ GLRenderStream stream p
824 ClearRenderTarget vals -> return $ GLClearRenderTarget $ V.toList vals
825 GenerateMipMap tu -> do
826 tb <- textureBinding <$> get
827 case IM.lookup tu tb of
828 Nothing -> fail "internal error (GenerateMipMap)!"
829 Just tex -> return $ GLGenerateMipMap (gl_TEXTURE0 + fromIntegral tu) (glTextureTarget tex)
830{-
831 SaveImage _ _ -> undefined
832 LoadImage _ _ -> undefined
833-}
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-06 02:46:19 +0000