diff options
author | Péter Diviánszky <divipp@gmail.com> | 2016-01-18 16:01:55 +0100 |
---|---|---|
committer | Péter Diviánszky <divipp@gmail.com> | 2016-01-18 16:02:30 +0100 |
commit | 0f709c3726f484d83075abd5d14cb848148ce0df (patch) | |
tree | 6236f2fdbdae55c3a245557e6bc22cbf4ddd6136 /src/LambdaCube | |
parent | 0b08b23492a5dad05dfbda3a94d485dab1e9e270 (diff) |
fix glsl code generation
Diffstat (limited to 'src/LambdaCube')
-rw-r--r-- | src/LambdaCube/Compiler/CoreToIR.hs | 24 |
1 files changed, 12 insertions, 12 deletions
diff --git a/src/LambdaCube/Compiler/CoreToIR.hs b/src/LambdaCube/Compiler/CoreToIR.hs index e65c0027..b8eac6d4 100644 --- a/src/LambdaCube/Compiler/CoreToIR.hs +++ b/src/LambdaCube/Compiler/CoreToIR.hs | |||
@@ -165,11 +165,12 @@ getProgram :: [(String,IR.InputType)] -> IR.Command -> Exp -> Exp -> Exp -> Exp | |||
165 | getProgram input slot rp is vert frag ffilter = do | 165 | getProgram input slot rp is vert frag ffilter = do |
166 | backend <- gets IR.backend | 166 | backend <- gets IR.backend |
167 | let ((vertexInput,vertOut),vertSrc) = genVertexGLSL backend rp is vert | 167 | let ((vertexInput,vertOut),vertSrc) = genVertexGLSL backend rp is vert |
168 | fragSrc = genFragmentGLSL backend vertOut frag ffilter | 168 | fragSrc = genFragmentGLSL backend pUniforms vertOut frag ffilter |
169 | pUniforms = Map.fromList $ Set.toList $ getUniforms vert <> getUniforms rp <> getUniforms frag <> maybe mempty getUniforms ffilter | ||
169 | prg = IR.Program | 170 | prg = IR.Program |
170 | { IR.programUniforms = Map.fromList $ Set.toList $ getUniforms vert <> getUniforms rp <> getUniforms frag | 171 | { IR.programUniforms = pUniforms |
171 | , IR.programStreams = Map.fromList $ zip vertexInput $ map (uncurry IR.Parameter) input | 172 | , IR.programStreams = Map.fromList $ zip vertexInput $ map (uncurry IR.Parameter) input |
172 | , IR.programInTextures = Map.fromList $ Set.toList $ getSamplerUniforms vert <> getSamplerUniforms rp <> getSamplerUniforms frag | 173 | , IR.programInTextures = Map.fromList $ Set.toList $ getSamplerUniforms vert <> getSamplerUniforms rp <> getSamplerUniforms frag <> maybe mempty getSamplerUniforms ffilter |
173 | , IR.programOutput = pure $ IR.Parameter "f0" IR.V4F -- TODO | 174 | , IR.programOutput = pure $ IR.Parameter "f0" IR.V4F -- TODO |
174 | , IR.vertexShader = vertSrc | 175 | , IR.vertexShader = vertSrc |
175 | , IR.geometryShader = mempty -- TODO | 176 | , IR.geometryShader = mempty -- TODO |
@@ -224,7 +225,7 @@ getCommands e = case e of | |||
224 | return (subCmds,IR.SetRenderTarget rt : cmds) | 225 | return (subCmds,IR.SetRenderTarget rt : cmds) |
225 | A3 "Accumulate" actx (getFragmentShader . removeDepthHandler -> (frag, getFragFilter -> (ffilter, Prim2 "mapStream" (EtaPrim4 "rasterize_" rp is rctx) (getVertexShader -> (vert, input))))) fbuf -> do | 226 | A3 "Accumulate" actx (getFragmentShader . removeDepthHandler -> (frag, getFragFilter -> (ffilter, Prim2 "mapStream" (EtaPrim4 "rasterize_" rp is rctx) (getVertexShader -> (vert, input))))) fbuf -> do |
226 | (smpBindingsV,vertCmds) <- getRenderTextureCommands vert | 227 | (smpBindingsV,vertCmds) <- getRenderTextureCommands vert |
227 | -- (smpBindingsR,rastCmds) <- getRenderTextureCommands rt | 228 | (smpBindingsR,rastCmds) <- maybe (return mempty) getRenderTextureCommands ffilter |
228 | (smpBindingsP,raspCmds) <- getRenderTextureCommands rp | 229 | (smpBindingsP,raspCmds) <- getRenderTextureCommands rp |
229 | (smpBindingsF,fragCmds) <- getRenderTextureCommands frag | 230 | (smpBindingsF,fragCmds) <- getRenderTextureCommands frag |
230 | (renderCommand,input) <- getSlot input | 231 | (renderCommand,input) <- getSlot input |
@@ -238,13 +239,13 @@ getCommands e = case e of | |||
238 | concat -- TODO: generate IR.SetSamplerUniform commands for texture slots | 239 | concat -- TODO: generate IR.SetSamplerUniform commands for texture slots |
239 | [ [ IR.SetTexture textureUnit texture | 240 | [ [ IR.SetTexture textureUnit texture |
240 | , IR.SetSamplerUniform name textureUnit | 241 | , IR.SetSamplerUniform name textureUnit |
241 | ] | (textureUnit,(name,IR.TextureImage texture _ _)) <- zip [length textureUniforms..] (smpBindingsV <> smpBindingsP <> smpBindingsF) | 242 | ] | (textureUnit,(name,IR.TextureImage texture _ _)) <- zip [length textureUniforms..] (smpBindingsV <> smpBindingsP <> smpBindingsR <> smpBindingsF) |
242 | ] <> | 243 | ] <> |
243 | [ IR.SetRasterContext (compRC rctx) | 244 | [ IR.SetRasterContext (compRC rctx) |
244 | , IR.SetAccumulationContext (compAC actx) | 245 | , IR.SetAccumulationContext (compAC actx) |
245 | , renderCommand | 246 | , renderCommand |
246 | ] | 247 | ] |
247 | return (subFbufCmds <> vertCmds <> raspCmds <> fragCmds, fbufCommands <> cmds) | 248 | return (subFbufCmds <> vertCmds <> raspCmds <> rastCmds <> fragCmds, fbufCommands <> cmds) |
248 | A1 "FrameBuffer" a -> return ([],[IR.ClearRenderTarget (Vector.fromList $ map (uncurry IR.ClearImage) $ compFrameBuffer a)]) | 249 | A1 "FrameBuffer" a -> return ([],[IR.ClearRenderTarget (Vector.fromList $ map (uncurry IR.ClearImage) $ compFrameBuffer a)]) |
249 | x -> error $ "getCommands " ++ ppShow x | 250 | x -> error $ "getCommands " ++ ppShow x |
250 | 251 | ||
@@ -568,8 +569,7 @@ genVertexGLSL backend rp@(etaRed -> ELam is s) ints e@(etaRed -> ELam i o) = id | |||
568 | tell ["#version 100"] | 569 | tell ["#version 100"] |
569 | tell ["precision highp float;"] | 570 | tell ["precision highp float;"] |
570 | tell ["precision highp int;"] | 571 | tell ["precision highp int;"] |
571 | mapM_ tell $ genUniforms e | 572 | mapM_ tell $ foldMap genUniforms [e, rp] |
572 | mapM_ tell $ genUniforms rp | ||
573 | input <- genStreamInput backend i | 573 | input <- genStreamInput backend i |
574 | out <- genStreamOutput backend ints $ tail $ eTuple o | 574 | out <- genStreamOutput backend ints $ tail $ eTuple o |
575 | tell ["void main() {"] | 575 | tell ["void main() {"] |
@@ -583,8 +583,8 @@ genVertexGLSL _ _ _ e = error $ "genVertexGLSL: " ++ ppShow e | |||
583 | genGLSL :: Exp -> String | 583 | genGLSL :: Exp -> String |
584 | genGLSL e = show $ genGLSLSubst mempty e | 584 | genGLSL e = show $ genGLSLSubst mempty e |
585 | 585 | ||
586 | genFragmentGLSL :: Backend -> [(String,String,String)] -> Exp -> Maybe Exp -> String | 586 | genFragmentGLSL :: Backend -> Map String IR.InputType -> [(String,String,String)] -> Exp -> Maybe Exp -> String |
587 | genFragmentGLSL backend s e@(etaRed -> ELam i o) ffilter = unlines $ execWriter $ do | 587 | genFragmentGLSL backend unifs s e@(etaRed -> ELam i o) ffilter = unlines $ execWriter $ do |
588 | case backend of | 588 | case backend of |
589 | OpenGL33 -> do | 589 | OpenGL33 -> do |
590 | tell ["#version 330 core"] | 590 | tell ["#version 330 core"] |
@@ -593,7 +593,7 @@ genFragmentGLSL backend s e@(etaRed -> ELam i o) ffilter = unlines $ execWriter | |||
593 | tell ["#version 100"] | 593 | tell ["#version 100"] |
594 | tell ["precision highp float;"] | 594 | tell ["precision highp float;"] |
595 | tell ["precision highp int;"] | 595 | tell ["precision highp int;"] |
596 | mapM_ tell $ genUniforms e | 596 | mapM_ tell $ foldMap genUniforms $ maybe [e] ((e:) . (:[])) ffilter -- todo: use unifs? |
597 | genFragmentInput backend s | 597 | genFragmentInput backend s |
598 | hasOutput <- genFragmentOutput backend o | 598 | hasOutput <- genFragmentOutput backend o |
599 | tell ["void main() {"] | 599 | tell ["void main() {"] |
@@ -605,7 +605,7 @@ genFragmentGLSL backend s e@(etaRed -> ELam i o) ffilter = unlines $ execWriter | |||
605 | WebGL1 -> tell ["gl_FragColor = " <> show (genGLSLSubst (makeSubst i s) o) <> ";"] | 605 | WebGL1 -> tell ["gl_FragColor = " <> show (genGLSLSubst (makeSubst i s) o) <> ";"] |
606 | tell ["}"] | 606 | tell ["}"] |
607 | 607 | ||
608 | genFragmentGLSL _ _ e ff = error $ "genFragmentGLSL: " ++ ppShow e ++ ppShow ff | 608 | genFragmentGLSL _ _ _ e ff = error $ "genFragmentGLSL: " ++ ppShow e ++ ppShow ff |
609 | 609 | ||
610 | makeSubst (PVar _ x) [(_,_,n)] = Map.singleton x n | 610 | makeSubst (PVar _ x) [(_,_,n)] = Map.singleton x n |
611 | makeSubst (PTuple l) x = Map.fromList $ go l x where | 611 | makeSubst (PTuple l) x = Map.fromList $ go l x where |