diff options
Diffstat (limited to 'src/LambdaCube/Compiler')
-rw-r--r-- | src/LambdaCube/Compiler/CoreToIR.hs | 118 |
1 files changed, 111 insertions, 7 deletions
diff --git a/src/LambdaCube/Compiler/CoreToIR.hs b/src/LambdaCube/Compiler/CoreToIR.hs index 4b75c182..feb1d6e2 100644 --- a/src/LambdaCube/Compiler/CoreToIR.hs +++ b/src/LambdaCube/Compiler/CoreToIR.hs | |||
@@ -21,6 +21,8 @@ import Data.List | |||
21 | import qualified Data.Map as Map | 21 | import qualified Data.Map as Map |
22 | import qualified Data.Set as Set | 22 | import qualified Data.Set as Set |
23 | import qualified Data.Vector as Vector | 23 | import qualified Data.Vector as Vector |
24 | import GHC.Stack | ||
25 | import GHC.Word | ||
24 | import Control.Arrow hiding ((<+>)) | 26 | import Control.Arrow hiding ((<+>)) |
25 | import Control.Monad.Writer | 27 | import Control.Monad.Writer |
26 | import Control.Monad.State | 28 | import Control.Monad.State |
@@ -36,6 +38,8 @@ import LambdaCube.Compiler.Core (Subst(..), down, nType) | |||
36 | import qualified LambdaCube.Compiler.Core as I | 38 | import qualified LambdaCube.Compiler.Core as I |
37 | import LambdaCube.Compiler.Infer (neutType', makeCaseFunPars') | 39 | import LambdaCube.Compiler.Infer (neutType', makeCaseFunPars') |
38 | 40 | ||
41 | import Debug.Trace | ||
42 | |||
39 | import Data.Version | 43 | import Data.Version |
40 | import Paths_lambdacube_compiler (version) | 44 | import Paths_lambdacube_compiler (version) |
41 | 45 | ||
@@ -57,7 +61,12 @@ compilePipeline backend exp = IR.Pipeline | |||
57 | ((subCmds,cmds), (streams, programs, targets, slots, textures)) | 61 | ((subCmds,cmds), (streams, programs, targets, slots, textures)) |
58 | = flip runState ((0, mempty), mempty, (0, mempty), mempty, (0, mempty)) $ case toExp exp of | 62 | = flip runState ((0, mempty), mempty, (0, mempty), mempty, (0, mempty)) $ case toExp exp of |
59 | A1 "ScreenOut" a -> addTarget backend a [IR.TargetItem s $ Just $ IR.Framebuffer s | s <- getSemantics a] | 63 | A1 "ScreenOut" a -> addTarget backend a [IR.TargetItem s $ Just $ IR.Framebuffer s | s <- getSemantics a] |
60 | x -> error $ "ScreenOut expected inststead of " ++ ppShow x | 64 | A2 "TextureOut" rtexDimE rtexE -> do |
65 | let rtexDim = case compValue rtexDimE of | ||
66 | IR.VV2I v -> fromIntegral <$> v | ||
67 | x -> error "Render texture dimensions should be a pair of non-negative integrals." | ||
68 | getTextureRenderTargetCommands backend rtexDim rtexE | ||
69 | x -> error $ "ScreenOut or TextureOut expected inststead of " ++ ppShow x | ||
61 | 70 | ||
62 | type CG = State (List IR.StreamData, Map IR.Program Int, List IR.RenderTarget, Map String (Int, IR.Slot), List IR.TextureDescriptor) | 71 | type CG = State (List IR.StreamData, Map IR.Program Int, List IR.RenderTarget, Map String (Int, IR.Slot), List IR.TextureDescriptor) |
63 | 72 | ||
@@ -77,11 +86,16 @@ addLEq l x = modL l $ \sv -> maybe (let i = length sv in i `seq` (i, Map.insert | |||
77 | 86 | ||
78 | --------------------------------------------------------- | 87 | --------------------------------------------------------- |
79 | 88 | ||
89 | addTarget | ||
90 | :: Backend | ||
91 | -> ExpTV | ||
92 | -> [IR.TargetItem] | ||
93 | -> CG ([IR.Command], [IR.Command]) | ||
80 | addTarget backend a tl = do | 94 | addTarget backend a tl = do |
81 | rt <- addL targetLens $ IR.RenderTarget $ Vector.fromList tl | 95 | rt <- addL targetLens $ IR.RenderTarget $ Vector.fromList tl |
82 | second (IR.SetRenderTarget rt:) <$> getCommands backend a | 96 | second (IR.SetRenderTarget rt:) <$> getCommands backend a |
83 | 97 | ||
84 | getCommands :: Backend -> ExpTV{-FrameBuffer-} -> CG ([IR.Command],[IR.Command]) | 98 | getCommands :: HasCallStack => Backend -> ExpTV{-FrameBuffer-} -> CG ([IR.Command],[IR.Command]) |
85 | getCommands backend e = case e of | 99 | getCommands backend e = case e of |
86 | 100 | ||
87 | A1 "FrameBuffer" (ETuple a) -> return ([], [IR.ClearRenderTarget $ Vector.fromList $ map compFrameBuffer a]) | 101 | A1 "FrameBuffer" (ETuple a) -> return ([], [IR.ClearRenderTarget $ Vector.fromList $ map compFrameBuffer a]) |
@@ -90,7 +104,7 @@ getCommands backend e = case e of | |||
90 | 104 | ||
91 | A3 "foldr" (A0 "++") (A0 "Nil") (A2 "map" (EtaPrim3 "rasterizePrimitive" ints rctx) (getVertexShader -> (vert, input_))) -> mdo | 105 | A3 "foldr" (A0 "++") (A0 "Nil") (A2 "map" (EtaPrim3 "rasterizePrimitive" ints rctx) (getVertexShader -> (vert, input_))) -> mdo |
92 | 106 | ||
93 | let | 107 | let |
94 | (vertexInput, pUniforms, vertSrc, fragSrc) = case backend of | 108 | (vertexInput, pUniforms, vertSrc, fragSrc) = case backend of |
95 | -- disabled DX11 codegen, due to it's incomplete | 109 | -- disabled DX11 codegen, due to it's incomplete |
96 | --IR.DirectX11 -> genHLSLs backend (compRC' rctx) ints vert frag ffilter | 110 | --IR.DirectX11 -> genHLSLs backend (compRC' rctx) ints vert frag ffilter |
@@ -98,11 +112,20 @@ getCommands backend e = case e of | |||
98 | 112 | ||
99 | pUniforms' = snd <$> Map.filter ((\case UTexture2D{} -> False; _ -> True) . fst) pUniforms | 113 | pUniforms' = snd <$> Map.filter ((\case UTexture2D{} -> False; _ -> True) . fst) pUniforms |
100 | 114 | ||
115 | imageSemantics = getSemantics e | ||
116 | imageTypes = getImageInputTypes e | ||
117 | outImageType | ||
118 | = case imageTypes of | ||
119 | [] -> error "Component-free pipelines are not supported." | ||
120 | [x] -> x | ||
121 | xs -> flip fromMaybe (lookup IR.Color $ zip imageSemantics xs) $ | ||
122 | error "Multiple outputs, but no Color buffer?" | ||
123 | |||
101 | prg = IR.Program | 124 | prg = IR.Program |
102 | { IR.programUniforms = pUniforms' | 125 | { IR.programUniforms = pUniforms' |
103 | , IR.programStreams = Map.fromList $ zip vertexInput $ map (uncurry IR.Parameter) input | 126 | , IR.programStreams = Map.fromList $ zip vertexInput $ map (uncurry IR.Parameter) input |
104 | , IR.programInTextures = snd <$> Map.filter ((\case UUniform{} -> False; _ -> True) . fst) pUniforms | 127 | , IR.programInTextures = snd <$> Map.filter ((\case UUniform{} -> False; _ -> True) . fst) pUniforms |
105 | , IR.programOutput = pure $ IR.Parameter "f0" IR.V4F -- TODO | 128 | , IR.programOutput = pure $ IR.Parameter "f0" outImageType |
106 | , IR.vertexShader = show vertSrc | 129 | , IR.vertexShader = show vertSrc |
107 | , IR.geometryShader = mempty -- TODO | 130 | , IR.geometryShader = mempty -- TODO |
108 | , IR.fragmentShader = show fragSrc | 131 | , IR.fragmentShader = show fragSrc |
@@ -168,6 +191,7 @@ getCommands backend e = case e of | |||
168 | let (a, tf) = case img of | 191 | let (a, tf) = case img of |
169 | A1 "PrjImageColor" a -> (,) a $ \[_, x] -> x | 192 | A1 "PrjImageColor" a -> (,) a $ \[_, x] -> x |
170 | A1 "PrjImage" a -> (,) a $ \[x] -> x | 193 | A1 "PrjImage" a -> (,) a $ \[x] -> x |
194 | x -> error $ "Unexpected image: " <> ppShow x | ||
171 | tl <- forM (getSemantics a) $ \semantic -> do | 195 | tl <- forM (getSemantics a) $ \semantic -> do |
172 | texture <- addL textureLens IR.TextureDescriptor | 196 | texture <- addL textureLens IR.TextureDescriptor |
173 | { IR.textureType = IR.Texture2D (if semantic == IR.Color then IR.FloatT IR.RGBA else IR.FloatT IR.Red) 1 | 197 | { IR.textureType = IR.Texture2D (if semantic == IR.Color then IR.FloatT IR.RGBA else IR.FloatT IR.Red) 1 |
@@ -194,6 +218,37 @@ getCommands backend e = case e of | |||
194 | return ([(n, tx)], subCmds ++ cmds) | 218 | return ([(n, tx)], subCmds ++ cmds) |
195 | _ -> return mempty | 219 | _ -> return mempty |
196 | 220 | ||
221 | getTextureRenderTargetCommands :: IR.Backend -> IR.V2 Word32 -> ExpTV -> CG ([IR.Command],[IR.Command]) | ||
222 | getTextureRenderTargetCommands backend dim body = do | ||
223 | let semantics = getSemantics body | ||
224 | imageTypes = getImageTextureTypes body | ||
225 | targetItems <- forM (zip semantics imageTypes) | ||
226 | $ \(semantic, imageType) -> do | ||
227 | texture <- addL textureLens IR.TextureDescriptor | ||
228 | { IR.textureType = IR.Texture2D (if semantic == IR.Color | ||
229 | then imageType IR.RGBA | ||
230 | else IR.FloatT IR.Red) | ||
231 | 1 | ||
232 | , IR.textureSize = IR.VV2U dim | ||
233 | , IR.textureSemantic = semantic | ||
234 | , IR.textureSampler = IR.SamplerDescriptor | ||
235 | { IR.samplerWrapS = IR.Repeat | ||
236 | , IR.samplerWrapT = Just IR.Repeat | ||
237 | , IR.samplerWrapR = Nothing | ||
238 | , IR.samplerMinFilter = IR.Nearest | ||
239 | , IR.samplerMagFilter = IR.Nearest | ||
240 | , IR.samplerBorderColor = IR.VV4F (IR.V4 0 0 0 1) | ||
241 | , IR.samplerMinLod = Nothing | ||
242 | , IR.samplerMaxLod = Nothing | ||
243 | , IR.samplerLodBias = 0 | ||
244 | , IR.samplerCompareFunc = Nothing | ||
245 | } | ||
246 | , IR.textureBaseLevel = 0 | ||
247 | , IR.textureMaxLevel = 0 | ||
248 | } | ||
249 | return $ IR.TargetItem semantic $ Just $ IR.TextureImage texture 0 Nothing | ||
250 | addTarget backend body targetItems | ||
251 | |||
197 | type SamplerBinding = (IR.UniformName,IR.ImageRef) | 252 | type SamplerBinding = (IR.UniformName,IR.ImageRef) |
198 | 253 | ||
199 | ---------------------------------------------------------------- | 254 | ---------------------------------------------------------------- |
@@ -201,7 +256,17 @@ type SamplerBinding = (IR.UniformName,IR.ImageRef) | |||
201 | frameBufferType (A2 "FrameBuffer" _ ty) = ty | 256 | frameBufferType (A2 "FrameBuffer" _ ty) = ty |
202 | frameBufferType x = error $ "illegal target type: " ++ ppShow x | 257 | frameBufferType x = error $ "illegal target type: " ++ ppShow x |
203 | 258 | ||
204 | getSemantics = compSemantics . frameBufferType . tyOf | 259 | getFramebufferType :: ExpTV -> [ExpTV] |
260 | getFramebufferType = compList . frameBufferType . tyOf | ||
261 | |||
262 | getSemantics :: ExpTV -> [IR.ImageSemantic] | ||
263 | getSemantics = map compSemantic . getFramebufferType | ||
264 | |||
265 | getImageTextureTypes :: ExpTV -> [IR.ColorArity -> IR.TextureDataType] | ||
266 | getImageTextureTypes = map (imageInputTypeTextureType . compImageInputType) . getFramebufferType | ||
267 | |||
268 | getImageInputTypes :: ExpTV -> [IR.InputType] | ||
269 | getImageInputTypes = map compImageInputType . getFramebufferType | ||
205 | 270 | ||
206 | getFragFilter (A2 "map" (EtaPrim2 "filterFragment" p) x) = (Just p, x) | 271 | getFragFilter (A2 "map" (EtaPrim2 "filterFragment" p) x) = (Just p, x) |
207 | getFragFilter x = (Nothing, x) | 272 | getFragFilter x = (Nothing, x) |
@@ -226,8 +291,6 @@ compFrameBuffer = \case | |||
226 | A1 "ColorImage" a -> IR.ClearImage IR.Color $ compValue a | 291 | A1 "ColorImage" a -> IR.ClearImage IR.Color $ compValue a |
227 | x -> error $ "compFrameBuffer " ++ ppShow x | 292 | x -> error $ "compFrameBuffer " ++ ppShow x |
228 | 293 | ||
229 | compSemantics = map compSemantic . compList | ||
230 | |||
231 | compList (A2 ":" a x) = a : compList x | 294 | compList (A2 ":" a x) = a : compList x |
232 | compList (A0 "Nil") = [] | 295 | compList (A0 "Nil") = [] |
233 | compList x = error $ "compList: " ++ ppShow x | 296 | compList x = error $ "compList: " ++ ppShow x |
@@ -249,6 +312,34 @@ compSemantic = \case | |||
249 | A1 "Color" _ -> IR.Color | 312 | A1 "Color" _ -> IR.Color |
250 | x -> error $ "compSemantic: " ++ ppShow x | 313 | x -> error $ "compSemantic: " ++ ppShow x |
251 | 314 | ||
315 | imageInputTypeTextureType :: HasCallStack => IR.InputType -> (IR.ColorArity -> IR.TextureDataType) | ||
316 | imageInputTypeTextureType = \case | ||
317 | IR.Float -> IR.FloatT | ||
318 | IR.Int -> IR.IntT | ||
319 | IR.V2I -> IR.IntT | ||
320 | IR.V3I -> IR.IntT | ||
321 | IR.V4I -> IR.IntT | ||
322 | IR.V2F -> IR.FloatT | ||
323 | IR.V3F -> IR.FloatT | ||
324 | IR.V4F -> IR.FloatT | ||
325 | x -> error $ "Unsupported input type: " <> show x | ||
326 | |||
327 | -- mirrors Builtins.lc:imageType | ||
328 | compImageInputType :: HasCallStack => ExpTV -> IR.InputType | ||
329 | compImageInputType = \case | ||
330 | A0 "Depth" -> IR.Float | ||
331 | A0 "Stencil" -> IR.Int | ||
332 | A1 "Color" c -> case c of | ||
333 | (A2 "VecS" x y) -> flip fromMaybe (compInputType_ c) $ | ||
334 | error $ "Unexpected (compInputType) color image element type: " <> ppShow c | ||
335 | -- -> case x of | ||
336 | -- A0 "Float" -> (IR.Float, y) | ||
337 | -- A0 "Int" -> (IR.Int, y) | ||
338 | -- A0 "Word" -> (IR.Int, y) | ||
339 | -- _ -> error $ "Unexpected color image component type: " <> ppShow x | ||
340 | _ -> error $ "Unexpected color image element type: " <> ppShow c | ||
341 | x -> error $ "compImageType: " ++ ppShow x | ||
342 | |||
252 | compAC (ETuple x) = IR.AccumulationContext Nothing $ map compFrag x | 343 | compAC (ETuple x) = IR.AccumulationContext Nothing $ map compFrag x |
253 | 344 | ||
254 | compBlending x = case x of | 345 | compBlending x = case x of |
@@ -359,6 +450,7 @@ showGLSLType msg = \case | |||
359 | 450 | ||
360 | supType = isJust . compInputType_ | 451 | supType = isJust . compInputType_ |
361 | 452 | ||
453 | compInputType_ :: ExpTV -> Maybe IR.InputType | ||
362 | compInputType_ x = case x of | 454 | compInputType_ x = case x of |
363 | TFloat -> Just IR.Float | 455 | TFloat -> Just IR.Float |
364 | TVec 2 TFloat -> Just IR.V2F | 456 | TVec 2 TFloat -> Just IR.V2F |
@@ -428,12 +520,16 @@ compFetchPrimitive x = case x of | |||
428 | A0 "TriangleAdjacency" -> IR.TrianglesAdjacency | 520 | A0 "TriangleAdjacency" -> IR.TrianglesAdjacency |
429 | x -> error $ "compFetchPrimitive " ++ ppShow x | 521 | x -> error $ "compFetchPrimitive " ++ ppShow x |
430 | 522 | ||
523 | compValue :: HasCallStack => ExpTV -> IR.Value | ||
431 | compValue x = case x of | 524 | compValue x = case x of |
432 | EFloat a -> IR.VFloat $ realToFrac a | 525 | EFloat a -> IR.VFloat $ realToFrac a |
433 | EInt a -> IR.VInt $ fromIntegral a | 526 | EInt a -> IR.VInt $ fromIntegral a |
434 | A2 "V2" (EFloat a) (EFloat b) -> IR.VV2F $ IR.V2 (realToFrac a) (realToFrac b) | 527 | A2 "V2" (EFloat a) (EFloat b) -> IR.VV2F $ IR.V2 (realToFrac a) (realToFrac b) |
435 | A3 "V3" (EFloat a) (EFloat b) (EFloat c) -> IR.VV3F $ IR.V3 (realToFrac a) (realToFrac b) (realToFrac c) | 528 | A3 "V3" (EFloat a) (EFloat b) (EFloat c) -> IR.VV3F $ IR.V3 (realToFrac a) (realToFrac b) (realToFrac c) |
436 | A4 "V4" (EFloat a) (EFloat b) (EFloat c) (EFloat d) -> IR.VV4F $ IR.V4 (realToFrac a) (realToFrac b) (realToFrac c) (realToFrac d) | 529 | A4 "V4" (EFloat a) (EFloat b) (EFloat c) (EFloat d) -> IR.VV4F $ IR.V4 (realToFrac a) (realToFrac b) (realToFrac c) (realToFrac d) |
530 | A2 "V2" (EInt a) (EInt b) -> IR.VV2I $ fromIntegral <$> IR.V2 a b | ||
531 | A3 "V3" (EInt a) (EInt b) (EInt c) -> IR.VV3I $ fromIntegral <$> IR.V3 a b c | ||
532 | A4 "V4" (EInt a) (EInt b) (EInt c) (EInt d) -> IR.VV4I $ fromIntegral <$> IR.V4 a b c d | ||
437 | A2 "V2" (EBool a) (EBool b) -> IR.VV2B $ IR.V2 a b | 533 | A2 "V2" (EBool a) (EBool b) -> IR.VV2B $ IR.V2 a b |
438 | A3 "V3" (EBool a) (EBool b) (EBool c) -> IR.VV3B $ IR.V3 a b c | 534 | A3 "V3" (EBool a) (EBool b) (EBool c) -> IR.VV3B $ IR.V3 a b c |
439 | A4 "V4" (EBool a) (EBool b) (EBool c) (EBool d) -> IR.VV4B $ IR.V4 a b c d | 535 | A4 "V4" (EBool a) (EBool b) (EBool c) (EBool d) -> IR.VV4B $ IR.V4 a b c d |
@@ -492,6 +588,14 @@ compPV x = case x of | |||
492 | 588 | ||
493 | --------------------------------------------------------------- GLSL generation | 589 | --------------------------------------------------------------- GLSL generation |
494 | 590 | ||
591 | genGLSLs | ||
592 | :: Backend | ||
593 | -> Maybe ExpTV | ||
594 | -> ExpTV | ||
595 | -> (Maybe ExpTV, ExpTV) | ||
596 | -> (Maybe ExpTV, ExpTV) | ||
597 | -> Maybe ExpTV | ||
598 | -> ([[Char]], Uniforms, Doc, Doc) | ||
495 | genGLSLs backend | 599 | genGLSLs backend |
496 | rp -- program point size | 600 | rp -- program point size |
497 | (ETuple ints) -- interpolations | 601 | (ETuple ints) -- interpolations |