summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorCsaba Hruska <csaba.hruska@gmail.com>2015-12-18 21:06:20 +0100
committerCsaba Hruska <csaba.hruska@gmail.com>2015-12-18 21:06:20 +0100
commit5cf60478c3b58ea8f4a80967689a3cbbd261ea6d (patch)
treed27788d92d6902b9ea8cbd80d0a21c34c825e269
parent6c0c6a8c4f51d2b2a7ef5cb708bfe5632ba8afe8 (diff)
adjust for generated IR
-rw-r--r--Backend/GL/Backend.hs42
-rw-r--r--Backend/GL/Input.hs2
2 files changed, 22 insertions, 22 deletions
diff --git a/Backend/GL/Backend.hs b/Backend/GL/Backend.hs
index e748682..4780966 100644
--- a/Backend/GL/Backend.hs
+++ b/Backend/GL/Backend.hs
@@ -20,7 +20,7 @@ import qualified Data.Map as Map
20import qualified Data.List as L 20import qualified Data.List as L
21import qualified Data.Set as S 21import qualified Data.Set as S
22import qualified Data.Vector as V 22import qualified Data.Vector as V
23import qualified Data.Vector.Mutable as MV 23import qualified Data.Vector.Storable as SV
24 24
25import Graphics.Rendering.OpenGL.Raw.Core33 25import Graphics.Rendering.OpenGL.Raw.Core33
26import Foreign 26import Foreign
@@ -212,7 +212,7 @@ compileProgram uniTrie p = do
212 Nothing -> [] 212 Nothing -> []
213 Just s -> [createAndAttach s gl_GEOMETRY_SHADER] 213 Just s -> [createAndAttach s gl_GEOMETRY_SHADER]
214 214
215 forM_ (zip (programOutput p) [0..]) $ \(Parameter (pack -> n) t,i) -> SB.useAsCString n $ \pn -> do 215 forM_ (zip (V.toList $ programOutput p) [0..]) $ \(Parameter (pack -> n) t,i) -> SB.useAsCString n $ \pn -> do
216 putStrLn ("variable " ++ show n ++ " attached to color number #" ++ show i) 216 putStrLn ("variable " ++ show n ++ " attached to color number #" ++ show i)
217 glBindFragDataLocation po i $ castPtr pn 217 glBindFragDataLocation po i $ castPtr pn
218 putStr " + setup shader output mapping: " >> printGLStatus 218 putStr " + setup shader output mapping: " >> printGLStatus
@@ -284,10 +284,10 @@ compileRenderTarget :: Vector TextureDescriptor -> Vector GLTexture -> RenderTar
284compileRenderTarget texs glTexs (RenderTarget targets) = do 284compileRenderTarget texs glTexs (RenderTarget targets) = do
285 let isFB (Framebuffer _) = True 285 let isFB (Framebuffer _) = True
286 isFB _ = False 286 isFB _ = False
287 images = [img | TargetItem _ (Just img) <- targets] 287 images = [img | TargetItem _ (Just img) <- V.toList targets]
288 case all isFB images of 288 case all isFB images of
289 True -> do 289 True -> do
290 let bufs = [cvt img | TargetItem Color img <- targets] 290 let bufs = [cvt img | TargetItem Color img <- V.toList targets]
291 cvt a = case a of 291 cvt a = case a of
292 Nothing -> gl_NONE 292 Nothing -> gl_NONE
293 Just (Framebuffer Color) -> gl_BACK_LEFT 293 Just (Framebuffer Color) -> gl_BACK_LEFT
@@ -364,17 +364,17 @@ compileRenderTarget texs glTexs (RenderTarget targets) = do
364compileStreamData :: StreamData -> IO GLStream 364compileStreamData :: StreamData -> IO GLStream
365compileStreamData s = do 365compileStreamData s = do
366 let withV w a f = w a (\p -> f $ castPtr p) 366 let withV w a f = w a (\p -> f $ castPtr p)
367 let compileAttr (VFloatArray v) = Array ArrFloat (length v) (withV withArray v) 367 let compileAttr (VFloatArray v) = Array ArrFloat (V.length v) (withV (SV.unsafeWith . V.convert) v)
368 compileAttr (VIntArray v) = Array ArrInt32 (length v) (withV withArray v) 368 compileAttr (VIntArray v) = Array ArrInt32 (V.length v) (withV (SV.unsafeWith . V.convert) v)
369 compileAttr (VWordArray v) = Array ArrWord32 (length v) (withV withArray v) 369 compileAttr (VWordArray v) = Array ArrWord32 (V.length v) (withV (SV.unsafeWith . V.convert) v)
370 --TODO: compileAttr (VBoolArray v) = Array ArrWord32 (length v) (withV withArray v) 370 --TODO: compileAttr (VBoolArray v) = Array ArrWord32 (length v) (withV withArray v)
371 (indexMap,arrays) = unzip [((n,i),compileAttr d) | (i,(n,d)) <- zip [0..] $ Map.toList $ streamData s] 371 (indexMap,arrays) = unzip [((n,i),compileAttr d) | (i,(n,d)) <- zip [0..] $ Map.toList $ streamData s]
372 getLength n = l `div` c 372 getLength n = l `div` c
373 where 373 where
374 l = case Map.lookup n $ IR.streamData s of 374 l = case Map.lookup n $ IR.streamData s of
375 Just (VFloatArray v) -> length v 375 Just (VFloatArray v) -> V.length v
376 Just (VIntArray v) -> length v 376 Just (VIntArray v) -> V.length v
377 Just (VWordArray v) -> length v 377 Just (VWordArray v) -> V.length v
378 _ -> error "compileStreamData - getLength" 378 _ -> error "compileStreamData - getLength"
379 c = case Map.lookup n $ IR.streamType s of 379 c = case Map.lookup n $ IR.streamType s of
380 Just Bool -> 1 380 Just Bool -> 1
@@ -421,7 +421,7 @@ compileStreamData s = do
421 LinesAdjacency -> LineListAdjacency 421 LinesAdjacency -> LineListAdjacency
422 TrianglesAdjacency -> TriangleListAdjacency 422 TrianglesAdjacency -> TriangleListAdjacency
423 , glStreamAttributes = toTrie $ Map.fromList $ map toStream indexMap 423 , glStreamAttributes = toTrie $ Map.fromList $ map toStream indexMap
424 , glStreamProgram = head $ streamPrograms s 424 , glStreamProgram = V.head $ streamPrograms s
425 } 425 }
426 426
427createStreamCommands :: Trie (IORef GLint) -> Trie GLUniform -> Trie (Stream Buffer) -> Primitive -> GLProgram -> [GLObjectCommand] 427createStreamCommands :: Trie (IORef GLint) -> Trie GLUniform -> Trie (Stream Buffer) -> Primitive -> GLProgram -> [GLObjectCommand]
@@ -488,26 +488,26 @@ createStreamCommands texUnitMap topUnis attrs primitive prg = streamUniCmds ++ s
488allocPipeline :: Pipeline -> IO GLPipeline 488allocPipeline :: Pipeline -> IO GLPipeline
489allocPipeline p = do 489allocPipeline p = do
490 let uniTrie = uniforms $ schemaFromPipeline p 490 let uniTrie = uniforms $ schemaFromPipeline p
491 smps <- V.mapM compileSampler $ V.fromList $ samplers p 491 smps <- V.mapM compileSampler $ samplers p
492 texs <- V.mapM compileTexture $ V.fromList $ textures p 492 texs <- V.mapM compileTexture $ textures p
493 trgs <- V.mapM (compileRenderTarget (V.fromList $ textures p) texs) $ V.fromList $ targets p 493 trgs <- V.mapM (compileRenderTarget (textures p) texs) $ targets p
494 prgs <- V.mapM (compileProgram uniTrie) $ V.fromList $ programs p 494 prgs <- V.mapM (compileProgram uniTrie) $ programs p
495 -- texture unit mapping ioref trie 495 -- texture unit mapping ioref trie
496 texUnitMapRefs <- T.fromList <$> mapM (\k -> (k,) <$> newIORef 0) (S.toList $ S.fromList $ concat $ V.toList $ V.map (T.keys . toTrie . programInTextures) $ V.fromList $ programs p) 496 texUnitMapRefs <- T.fromList <$> mapM (\k -> (k,) <$> newIORef 0) (S.toList $ S.fromList $ concat $ V.toList $ V.map (T.keys . toTrie . programInTextures) $ programs p)
497 let (cmds,st) = runState (mapM (compileCommand texUnitMapRefs smps texs trgs prgs) $ commands p) initCGState 497 let (cmds,st) = runState (mapM (compileCommand texUnitMapRefs smps texs trgs prgs) $ V.toList $ commands p) initCGState
498 input <- newIORef Nothing 498 input <- newIORef Nothing
499 -- default Vertex Array Object 499 -- default Vertex Array Object
500 vao <- alloca $! \pvao -> glGenVertexArrays 1 pvao >> peek pvao 500 vao <- alloca $! \pvao -> glGenVertexArrays 1 pvao >> peek pvao
501 strs <- V.mapM compileStreamData $ V.fromList $ streams p 501 strs <- V.mapM compileStreamData $ streams p
502 return $ GLPipeline 502 return $ GLPipeline
503 { glPrograms = prgs 503 { glPrograms = prgs
504 , glTextures = texs 504 , glTextures = texs
505 , glSamplers = smps 505 , glSamplers = smps
506 , glTargets = trgs 506 , glTargets = trgs
507 , glCommands = cmds 507 , glCommands = cmds
508 , glSlotPrograms = V.map slotPrograms $ V.fromList $ IR.slots p 508 , glSlotPrograms = V.map (V.toList . slotPrograms) $ IR.slots p
509 , glInput = input 509 , glInput = input
510 , glSlotNames = V.map (pack . slotName) $ V.fromList $ IR.slots p 510 , glSlotNames = V.map (pack . slotName) $ IR.slots p
511 , glVAO = vao 511 , glVAO = vao
512 , glTexUnitMapping = texUnitMapRefs 512 , glTexUnitMapping = texUnitMapRefs
513 , glStreams = strs 513 , glStreams = strs
@@ -800,7 +800,7 @@ compileCommand texUnitMap samplers textures targets programs cmd = case cmd of
800 RenderStream stream -> do 800 RenderStream stream -> do
801 p <- currentProgram <$> get 801 p <- currentProgram <$> get
802 return $ GLRenderStream stream p 802 return $ GLRenderStream stream p
803 ClearRenderTarget vals -> return $ GLClearRenderTarget vals 803 ClearRenderTarget vals -> return $ GLClearRenderTarget $ V.toList vals
804 GenerateMipMap tu -> do 804 GenerateMipMap tu -> do
805 tb <- textureBinding <$> get 805 tb <- textureBinding <$> get
806 case IM.lookup tu tb of 806 case IM.lookup tu tb of
diff --git a/Backend/GL/Input.hs b/Backend/GL/Input.hs
index 2a3500e..2b7c3d3 100644
--- a/Backend/GL/Input.hs
+++ b/Backend/GL/Input.hs
@@ -31,7 +31,7 @@ import qualified IR as IR
31schemaFromPipeline :: IR.Pipeline -> PipelineSchema 31schemaFromPipeline :: IR.Pipeline -> PipelineSchema
32schemaFromPipeline a = PipelineSchema (T.fromList sl) (foldl T.unionL T.empty ul) 32schemaFromPipeline a = PipelineSchema (T.fromList sl) (foldl T.unionL T.empty ul)
33 where 33 where
34 (sl,ul) = unzip [((pack n,SlotSchema p (fmap cvt (toTrie s))),toTrie u) | IR.Slot n u s p _ <- IR.slots a] 34 (sl,ul) = unzip [((pack n,SlotSchema p (fmap cvt (toTrie s))),toTrie u) | IR.Slot n u s p _ <- V.toList $ IR.slots a]
35 cvt a = case toStreamType a of 35 cvt a = case toStreamType a of
36 Just v -> v 36 Just v -> v
37 Nothing -> error "internal error (schemaFromPipeline)" 37 Nothing -> error "internal error (schemaFromPipeline)"