diff options
Diffstat (limited to 'src/LambdaCube/Compiler/CoreToIR.hs')
-rw-r--r-- | src/LambdaCube/Compiler/CoreToIR.hs | 52 |
1 files changed, 34 insertions, 18 deletions
diff --git a/src/LambdaCube/Compiler/CoreToIR.hs b/src/LambdaCube/Compiler/CoreToIR.hs index 2ad8d26d..7f4f9561 100644 --- a/src/LambdaCube/Compiler/CoreToIR.hs +++ b/src/LambdaCube/Compiler/CoreToIR.hs | |||
@@ -134,13 +134,13 @@ getCommands backend e = case e of | |||
134 | 134 | ||
135 | A3 "Accumulate" actx (getFragmentShader -> (frag, getFragFilter -> (ffilter, x1))) fbuf -> case x1 of | 135 | A3 "Accumulate" actx (getFragmentShader -> (frag, getFragFilter -> (ffilter, x1))) fbuf -> case x1 of |
136 | 136 | ||
137 | A3 "foldr" (A0 "++") (A0 "Nil") (A2 "map" (EtaPrim3 "rasterizePrimitive" ints rctx) (getVertexShader -> (vert, input_))) -> mdo | 137 | A3 "foldr" (A0 "++") (A0 "Nil") (A2 "map" (EtaPrim3 "rasterizePrimitive" ints rctx) ex@(getVertexShader -> (vert, input_, hasCount))) -> mdo |
138 | 138 | ||
139 | let | 139 | let |
140 | (vertexInput, pUniforms, vertSrc, fragSrc) = case backend of | 140 | (vertexInput, pUniforms, vertSrc, fragSrc) = case backend of |
141 | -- disabled DX11 codegen, due to it's incomplete | 141 | -- disabled DX11 codegen, due to it's incomplete |
142 | --IR.DirectX11 -> genHLSLs backend (compRC' rctx) ints vert frag ffilter | 142 | --IR.DirectX11 -> genHLSLs backend (compRC' rctx) ints vert frag ffilter |
143 | _ -> genGLSLs backend (compRC' rctx) ints vert frag ffilter | 143 | _ -> genGLSLs backend (compRC' rctx) ints hasCount vert frag ffilter |
144 | 144 | ||
145 | pUniforms' = snd <$> Map.filter ((\case UTexture2D{} -> False; _ -> True) . fst) pUniforms | 145 | pUniforms' = snd <$> Map.filter ((\case UTexture2D{} -> False; _ -> True) . fst) pUniforms |
146 | 146 | ||
@@ -176,8 +176,7 @@ getCommands backend e = case e of | |||
176 | 176 | ||
177 | (smpBindings, txtCmds) <- mconcat <$> traverse (uncurry getRenderTextureCommands) (Map.toList $ fst <$> pUniforms) | 177 | (smpBindings, txtCmds) <- mconcat <$> traverse (uncurry getRenderTextureCommands) (Map.toList $ fst <$> pUniforms) |
178 | 178 | ||
179 | (renderCommand,input) <- case input_ of | 179 | let grokFetch slotName attrs = do |
180 | A2 "fetch" (EString slotName) attrs -> do | ||
181 | i <- IR.RenderSlot <$> addL' slotLens slotName (flip mergeSlot) IR.Slot | 180 | i <- IR.RenderSlot <$> addL' slotLens slotName (flip mergeSlot) IR.Slot |
182 | { IR.slotName = slotName | 181 | { IR.slotName = slotName |
183 | , IR.slotUniforms = IR.programUniforms prg | 182 | , IR.slotUniforms = IR.programUniforms prg |
@@ -193,6 +192,12 @@ getCommands backend e = case e of | |||
193 | , IR.slotStreams = IR.slotStreams a <> IR.slotStreams b | 192 | , IR.slotStreams = IR.slotStreams a <> IR.slotStreams b |
194 | , IR.slotPrograms = IR.slotPrograms a <> IR.slotPrograms b | 193 | , IR.slotPrograms = IR.slotPrograms a <> IR.slotPrograms b |
195 | } | 194 | } |
195 | |||
196 | (renderCommand,input) <- case input_ of | ||
197 | A2 "fetch" (EString slotName) attrs -> grokFetch slotName attrs | ||
198 | A1 "zipCount" (A2 "fetch" (EString slotName) attrs) -> do | ||
199 | (rc,inp) <- grokFetch slotName attrs | ||
200 | return (rc,inp) | ||
196 | A1 "fetchArrays" (unzip . compAttributeValue -> (tys, values)) -> do | 201 | A1 "fetchArrays" (unzip . compAttributeValue -> (tys, values)) -> do |
197 | i <- IR.RenderStream <$> addL streamLens IR.StreamData | 202 | i <- IR.RenderStream <$> addL streamLens IR.StreamData |
198 | { IR.streamData = Map.fromList $ zip names values | 203 | { IR.streamData = Map.fromList $ zip names values |
@@ -302,11 +307,15 @@ getFragFilter :: ExpTV -> (Maybe ExpTV, ExpTV) | |||
302 | getFragFilter (A2 "map" (EtaPrim2 "filterFragment" p) x) = (Just p, x) | 307 | getFragFilter (A2 "map" (EtaPrim2 "filterFragment" p) x) = (Just p, x) |
303 | getFragFilter x = (Nothing, x) | 308 | getFragFilter x = (Nothing, x) |
304 | 309 | ||
305 | getVertexShader :: ExpTV -> ((Maybe ExpTV, Ty), ExpTV) | 310 | getVertexShader :: ExpTV -> ((Maybe ExpTV, Ty), ExpTV, Bool) |
306 | getVertexShader (A2 "map" (EtaPrim2 "mapPrimitive" f@(etaReds -> Just (_, o))) x) = ((Just f, tyOf o), x) | 311 | getVertexShader xx@(A2 "map" (EtaPrim2 "mapPrimitive" f@(etaReds -> Just (_, o))) x) = |
312 | let hasCount = case x of | ||
313 | A1 "zipCount" _ -> True | ||
314 | _ -> False | ||
315 | in ((Just f, tyOf o), x, hasCount) | ||
307 | --getVertexShader (A2 "map" (EtaPrim2 "mapPrimitive" f) x) = error $ "gff: " ++ show (case f of ExpTV x _ _ -> x) --ppShow (mapVal unFunc' f) | 316 | --getVertexShader (A2 "map" (EtaPrim2 "mapPrimitive" f) x) = error $ "gff: " ++ show (case f of ExpTV x _ _ -> x) --ppShow (mapVal unFunc' f) |
308 | --getVertexShader x = error $ "gf: " ++ ppShow x | 317 | --getVertexShader x = error $ "gf: " ++ ppShow x |
309 | getVertexShader x = ((Nothing, getPrim' $ tyOf x), x) | 318 | getVertexShader x = ((Nothing, getPrim' $ tyOf x), x, False {- hasCount: TODO: is this right? -}) |
310 | 319 | ||
311 | getFragmentShader :: ExpTV -> ((Maybe ExpTV, Ty), ExpTV) | 320 | getFragmentShader :: ExpTV -> ((Maybe ExpTV, Ty), ExpTV) |
312 | getFragmentShader (A2 "map" (EtaPrim2 "mapFragment" f@(etaReds -> Just (_, o))) x) = ((Just f, tyOf o), x) | 321 | getFragmentShader (A2 "map" (EtaPrim2 "mapFragment" f@(etaReds -> Just (_, o))) x) = ((Just f, tyOf o), x) |
@@ -662,18 +671,20 @@ genGLSLs | |||
662 | :: Backend | 671 | :: Backend |
663 | -> Maybe ExpTV | 672 | -> Maybe ExpTV |
664 | -> ExpTV | 673 | -> ExpTV |
674 | -> Bool | ||
665 | -> (Maybe ExpTV, ExpTV) | 675 | -> (Maybe ExpTV, ExpTV) |
666 | -> (Maybe ExpTV, ExpTV) | 676 | -> (Maybe ExpTV, ExpTV) |
667 | -> Maybe ExpTV | 677 | -> Maybe ExpTV |
668 | -> ([[Char]], Uniforms, Doc, Doc) | 678 | -> ([[Char]], Uniforms, Doc, Doc) |
669 | genGLSLs backend | 679 | genGLSLs backend |
670 | rp -- program point size | 680 | rp -- program point size |
671 | (ETuple ints) -- interpolations | 681 | (ETuple ints) -- interpolations |
672 | (vert, tvert) -- vertex shader | 682 | hasCount -- True if vertex shader uses gl_VertexID |
673 | (frag, tfrag) -- fragment shader | 683 | (vert, tvert) -- vertex shader |
674 | ffilter -- fragment filter | 684 | (frag, tfrag) -- fragment shader |
685 | ffilter -- fragment filter | ||
675 | = ( -- vertex input | 686 | = ( -- vertex input |
676 | vertInNames | 687 | (if hasCount then drop 1 else id) vertInNames |
677 | 688 | ||
678 | , -- uniforms | 689 | , -- uniforms |
679 | vertUniforms <> fragUniforms | 690 | vertUniforms <> fragUniforms |
@@ -681,7 +692,7 @@ genGLSLs backend | |||
681 | , -- vertex shader code | 692 | , -- vertex shader code |
682 | shader $ | 693 | shader $ |
683 | uniformDecls vertUniforms | 694 | uniformDecls vertUniforms |
684 | <> [shaderDecl (caseWO "attribute" "in") (text t) (text n) | (n, t) <- zip vertInNames vertIns] | 695 | <> (if hasCount then drop 1 else id) [shaderDecl (caseWO "attribute" "in") (text t) (text n) | (n, t) <- zip vertInNames vertIns] |
685 | <> vertOutDecls "out" | 696 | <> vertOutDecls "out" |
686 | <> vertFuncs | 697 | <> vertFuncs |
687 | <> [mainFunc $ | 698 | <> [mainFunc $ |
@@ -711,9 +722,11 @@ genGLSLs backend | |||
711 | 1 -> [caseWO "gl_FragColor" "f0"] | 722 | 1 -> [caseWO "gl_FragColor" "f0"] |
712 | 723 | ||
713 | (vertIns, verts) = case vert of | 724 | (vertIns, verts) = case vert of |
714 | Just (etaReds -> Just (xs, ETuple ys)) -> (toGLSLType "3" <$> xs, ys) | 725 | Just (etaReds -> Just (xs, expr)) -> case expr of |
726 | ETuple ys -> (toGLSLType "3" <$> xs, ys) | ||
727 | _ -> error ("mapPrimitives function body is not a tuple: " ++ ppShow expr) | ||
715 | Nothing -> ([toGLSLType "4" tvert], [mkTVar 0 tvert]) | 728 | Nothing -> ([toGLSLType "4" tvert], [mkTVar 0 tvert]) |
716 | Just wut -> error $ show wut | 729 | Just wut -> error $ ppShow (etaReds wut, wut) |
717 | 730 | ||
718 | (fragOuts, frags) = case frag of | 731 | (fragOuts, frags) = case frag of |
719 | Just (etaReds -> Just (xs, ETuple ys)) -> (toGLSLType "31" . tyOf <$> ys, ys) | 732 | Just (etaReds -> Just (xs, ETuple ys)) -> (toGLSLType "31" . tyOf <$> ys, ys) |
@@ -754,7 +767,10 @@ genGLSLs backend | |||
754 | 767 | ||
755 | funArgs = map (("z" ++) . show) [0..] | 768 | funArgs = map (("z" ++) . show) [0..] |
756 | shaderNames = map (("s" ++) . show) [0..] | 769 | shaderNames = map (("s" ++) . show) [0..] |
757 | vertInNames = map (("vi" ++) . show) [1..length vertIns] | 770 | vertInNames = let vns = map (("vi" ++) . show) [1..] |
771 | ns | hasCount = "gl_VertexID" : vns | ||
772 | | otherwise = vns | ||
773 | in zipWith const ns vertIns | ||
758 | vertOutNames = map (("vo" ++) . show) [1..length vertOuts] | 774 | vertOutNames = map (("vo" ++) . show) [1..length vertOuts] |
759 | vertOutNamesWithPosition = "gl_Position": vertOutNames | 775 | vertOutNamesWithPosition = "gl_Position": vertOutNames |
760 | 776 | ||
@@ -1537,7 +1553,7 @@ genHLSLs backend | |||
1537 | 1553 | ||
1538 | funArgs = map (("z" ++) . show) [0..] | 1554 | funArgs = map (("z" ++) . show) [0..] |
1539 | shaderNames = map (("s" ++) . show) [0..] | 1555 | shaderNames = map (("s" ++) . show) [0..] |
1540 | vertInNames = map (("vi" ++) . show) [1..length vertIns] | 1556 | vertInNames = map (("vi" ++) . show) [1..length vertIns] -- TODO: hasCount support? |
1541 | vertOutNames = map (("vo" ++) . show) [1..length vertOuts] | 1557 | vertOutNames = map (("vo" ++) . show) [1..length vertOuts] |
1542 | vertOutNamesWithPosition = "gl_Position": vertOutNames | 1558 | vertOutNamesWithPosition = "gl_Position": vertOutNames |
1543 | 1559 | ||