summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lambdacube-compiler.cabal6
-rw-r--r--src/LambdaCube/Compiler/CGExp.hs276
-rw-r--r--src/LambdaCube/Compiler/CoreToGLSL.hs357
-rw-r--r--src/LambdaCube/Compiler/CoreToIR.hs611
-rw-r--r--src/LambdaCube/Compiler/Driver.hs11
-rw-r--r--test/runTests.hs1
6 files changed, 612 insertions, 650 deletions
diff --git a/lambdacube-compiler.cabal b/lambdacube-compiler.cabal
index 4c43bf99..aa5ac44d 100644
--- a/lambdacube-compiler.cabal
+++ b/lambdacube-compiler.cabal
@@ -19,13 +19,11 @@ Flag profiling
19library 19library
20 exposed-modules: 20 exposed-modules:
21 -- Compiler 21 -- Compiler
22 LambdaCube.Compiler.Token
22 LambdaCube.Compiler.Pretty 23 LambdaCube.Compiler.Pretty
23 LambdaCube.Compiler.CoreToIR
24 LambdaCube.Compiler.CoreToGLSL
25 LambdaCube.Compiler.Infer 24 LambdaCube.Compiler.Infer
26 LambdaCube.Compiler.CGExp 25 LambdaCube.Compiler.CoreToIR
27 LambdaCube.Compiler.Driver 26 LambdaCube.Compiler.Driver
28 LambdaCube.Compiler.Token
29 other-extensions: 27 other-extensions:
30 LambdaCase 28 LambdaCase
31 PatternSynonyms 29 PatternSynonyms
diff --git a/src/LambdaCube/Compiler/CGExp.hs b/src/LambdaCube/Compiler/CGExp.hs
deleted file mode 100644
index b2f19c9f..00000000
--- a/src/LambdaCube/Compiler/CGExp.hs
+++ /dev/null
@@ -1,276 +0,0 @@
1{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE ViewPatterns #-}
3{-# LANGUAGE PatternSynonyms #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE NoMonomorphismRestriction #-}
7{-# LANGUAGE DeriveFunctor #-}
8{-# LANGUAGE DeriveFoldable #-}
9{-# LANGUAGE DeriveTraversable #-}
10{-# LANGUAGE RecursiveDo #-}
11module LambdaCube.Compiler.CGExp where
12
13import Control.Monad.Reader
14import Control.Monad.State
15import Control.Monad.Except
16import Control.Monad.Identity
17import Control.Monad.Writer
18import Control.Arrow
19import qualified Data.Set as S
20import qualified Data.Map as M
21import Text.Parsec.Pos
22import Debug.Trace
23
24import LambdaCube.Compiler.Pretty
25import qualified LambdaCube.Compiler.Infer as I
26import LambdaCube.Compiler.Infer (SName, Lit(..), Visibility(..))
27
28--------------------------------------------------------------------------------
29
30data Exp_ a
31 = Pi_ Visibility SName a a
32 | Lam_ Visibility Pat a a
33 | Con_ (SName, a) [a]
34 | ELit_ Lit
35 | Fun_ (SName, a) [a]
36 | App_ a a
37 | Var_ SName a
38 | TType_
39 | Let_ Pat a a
40 deriving (Show, Eq, Functor, Foldable, Traversable)
41
42instance PShow Exp where pShowPrec p = text . show
43
44pattern Pi h n a b = Exp (Pi_ h n a b)
45pattern Lam h n a b = Exp (Lam_ h n a b)
46pattern Con a b = Exp (Con_ a b)
47pattern ELit a = Exp (ELit_ a)
48pattern Fun a b = Exp (Fun_ a b)
49pattern EApp a b = Exp (App_ a b)
50pattern Var a b = Exp (Var_ a b)
51pattern TType = Exp TType_
52pattern ELet a b c = Exp (Let_ a b c)
53
54pattern EString s = ELit (LString s)
55pattern EFloat s = ELit (LFloat s)
56pattern EInt s = ELit (LInt s)
57
58newtype Exp = Exp (Exp_ Exp)
59 deriving (Show, Eq)
60
61toExp :: I.Exp -> Exp
62toExp = flip runReader [] . flip evalStateT freshTypeVars . f
63 where
64 freshTypeVars = (flip (:) <$> map show [0..] <*> ['a'..'z'])
65 newName = gets head <* modify tail
66 f = \case
67 I.Var i -> asks (!!! i)
68 I.Pi b x (I.downE 0 -> Just y) -> Pi b "" <$> f x <*> f y
69 I.Pi b x y -> newName >>= \n -> do
70 t <- f x
71 Pi b n t <$> local (Var n t:) (f y)
72 I.Lam b x y -> newName >>= \n -> do
73 t <- f x
74 Lam b (PVar t n) t <$> local (Var n t:) (f y)
75 I.Con (I.ConName s _ _ t) xs -> con s <$> f t <*> mapM f xs
76 I.TyCon (I.TyConName s _ _ t _ _) xs -> con s <$> f t <*> mapM f xs
77 I.ELit l -> pure $ ELit l
78 I.Fun (I.FunName s _ t) xs -> fun s <$> f t <*> mapM f xs
79 I.CaseFun x@(I.CaseFunName _ t _) xs -> fun (show x) <$> f t <*> mapM f xs
80 I.App a b -> app' <$> f a <*> f b
81 I.PMLabel x _ -> f x
82 I.FixLabel _ x -> f x
83 I.TType -> pure TType
84 I.LabelEnd x -> f x
85 z -> error $ "toExp: " ++ show z
86
87 xs !!! i | i < 0 || i >= length xs = error $ show xs ++ " !! " ++ show i
88 xs !!! i = xs !! i
89
90 untick ('\'': s) = s
91 untick s = s
92
93 fun s t xs = Fun (untick s, t) xs
94 con s t xs = Con (untick s, t) xs
95
96freeVars :: Exp -> S.Set SName
97freeVars = \case
98 Var n _ -> S.singleton n
99 Con _ xs -> S.unions $ map freeVars xs
100 ELit _ -> mempty
101 Fun _ xs -> S.unions $ map freeVars xs
102 EApp a b -> freeVars a `S.union` freeVars b
103 Pi _ n a b -> freeVars a `S.union` (S.delete n $ freeVars b)
104 Lam _ n a b -> freeVars a `S.union` (foldr S.delete (freeVars b) (patVars n))
105 TType -> mempty
106 ELet n a b -> freeVars a `S.union` (foldr S.delete (freeVars b) (patVars n))
107
108type Ty = Exp
109
110tyOf :: Exp -> Ty
111tyOf = \case
112 Lam h (PVar _ n) t x -> Pi h n t $ tyOf x
113 EApp f x -> app (tyOf f) x
114 Var _ t -> t
115 Pi{} -> TType
116 Con (_, t) xs -> foldl app t xs
117 Fun (_, t) xs -> foldl app t xs
118 ELit l -> toExp $ I.litType l
119 TType -> TType
120 ELet a b c -> tyOf $ EApp (ELam a c) b
121 x -> error $ "tyOf: " ++ show x
122 where
123 app (Pi _ n a b) x = substE n x b
124
125substE n x = \case
126 z@(Var n' _) | n' == n -> x
127 | otherwise -> z
128 Pi h n' a b | n == n' -> Pi h n' (substE n x a) b
129 Pi h n' a b -> Pi h n' (substE n x a) (substE n x b)
130 Lam h n' a b -> Lam h n' (substE n x a) $ if n `elem` patVars n' then b else substE n x b
131 Con cn xs -> Con cn (map (substE n x) xs)
132 Fun cn xs -> Fun cn (map (substE n x) xs)
133 TType -> TType
134 EApp a b -> app' (substE n x a) (substE n x b)
135 z -> error $ "substE: " ++ show z
136
137app' (Lam _ (PVar _ n) _ x) b = substE n b x
138app' a b = EApp a b
139
140--------------------------------------------------------------------------------
141
142data Pat
143 = PVar Exp SName
144 | PTuple [Pat]
145 deriving (Eq, Show)
146
147instance PShow Pat where pShowPrec p = text . show
148
149patVars (PVar _ n) = [n]
150patVars (PTuple ps) = concatMap patVars ps
151
152patTy (PVar t _) = t
153patTy (PTuple ps) = Con ("Tuple" ++ show (length ps), tupTy $ length ps) $ map patTy ps
154
155tupTy n = foldr (:~>) TType $ replicate n TType
156
157-- workaround for backward compatibility
158etaRed (ELam (PVar _ n) (EApp f (EVar n'))) | n == n' && n `S.notMember` freeVars f = f
159etaRed (ELam (PVar _ n) (Prim3 (tupCaseName -> Just k) _ x (EVar n'))) | n == n' && n `S.notMember` freeVars x = uncurry (\ps e -> ELam (PTuple ps) e) $ getPats k x
160etaRed x = x
161
162tupCaseName "Tuple2Case" = Just 2
163tupCaseName "Tuple3Case" = Just 3
164tupCaseName "Tuple4Case" = Just 4
165tupCaseName "Tuple5Case" = Just 5
166tupCaseName "Tuple6Case" = Just 6
167tupCaseName "Tuple7Case" = Just 7
168tupCaseName _ = Nothing
169
170getPats 0 e = ([], e)
171getPats i (ELam p e) = (p:) *** id $ getPats (i-1) e
172
173-------------
174
175pattern EVar n <- Var n _
176pattern TVar t n = Var n t
177
178pattern ELam n b <- Lam Visible n _ b where ELam n b = Lam Visible n (patTy n) b
179
180pattern a :~> b = Pi Visible "" a b
181infixr 1 :~>
182
183pattern PrimN n xs <- Fun (n, t) (filterRelevant (n, 0) t -> xs) where PrimN n xs = Fun (n, builtinType n) xs
184pattern Prim1 n a = PrimN n [a]
185pattern Prim2 n a b = PrimN n [a, b]
186pattern Prim3 n a b c <- PrimN n [a, b, c]
187pattern Prim4 n a b c d <- PrimN n [a, b, c, d]
188pattern Prim5 n a b c d e <- PrimN n [a, b, c, d, e]
189
190builtinType = \case
191 "Output" -> TType
192 "Bool" -> TType
193 "Float" -> TType
194 "Nat" -> TType
195 "Zero" -> TNat
196 "Succ" -> TNat :~> TNat
197 "String" -> TType
198 "Sampler" -> TType
199 "VecS" -> TType :~> TNat :~> TType
200 n -> error $ "type of " ++ show n
201
202filterRelevant _ _ [] = []
203filterRelevant i (Pi h n t t') (x: xs) = (if h == Visible then (x:) else id) $ filterRelevant (id *** (+1) $ i) (substE n x t') xs
204
205pattern AN n xs <- Con (n, t) (filterRelevant (n, 0) t -> xs) where AN n xs = Con (n, builtinType n) xs
206pattern A0 n = AN n []
207pattern A1 n a = AN n [a]
208pattern A2 n a b = AN n [a, b]
209pattern A3 n a b c <- AN n [a, b, c]
210pattern A4 n a b c d <- AN n [a, b, c, d]
211pattern A5 n a b c d e <- AN n [a, b, c, d, e]
212
213pattern TCon0 n = A0 n
214pattern TCon t n = Con (n, t) []
215
216pattern TUnit <- A0 "Tuple0"
217pattern TBool = A0 "Bool"
218pattern TWord <- A0 "Word"
219pattern TInt <- A0 "Int"
220pattern TNat = A0 "Nat"
221pattern TFloat = A0 "Float"
222pattern TString = A0 "String"
223
224pattern Uniform n <- Prim1 "Uniform" n
225
226pattern Zero = A0 "Zero"
227pattern Succ n = A1 "Succ" n
228
229pattern TVec n a = A2 "VecS" a (Nat n)
230pattern TMat i j a <- A3 "Mat" (Nat i) (Nat j) a
231
232pattern Nat n <- (fromNat -> Just n) where Nat = toNat
233
234toNat :: Int -> Exp
235toNat 0 = Zero
236toNat n = Succ (toNat $ n-1)
237
238fromNat :: Exp -> Maybe Int
239fromNat Zero = Just 0
240fromNat (Succ n) = (1 +) <$> fromNat n
241fromNat _ = Nothing
242
243pattern TTuple xs <- (getTuple -> Just xs)
244pattern ETuple xs <- (getTuple -> Just xs)
245
246getTuple (AN (tupName -> Just n) xs) | length xs == n = Just xs
247getTuple _ = Nothing
248
249tupName = \case
250 "Tuple0" -> Just 0
251 "Tuple2" -> Just 2
252 "Tuple3" -> Just 3
253 "Tuple4" -> Just 4
254 "Tuple5" -> Just 5
255 "Tuple6" -> Just 6
256 "Tuple7" -> Just 7
257 _ -> Nothing
258
259pattern SwizzProj a b <- (getSwizzProj -> Just (a, b))
260
261getSwizzProj = \case
262 Prim2 "swizzscalar" e (getSwizzChar -> Just s) -> Just (e, [s])
263 Prim2 "swizzvector" e (AN ((`elem` ["V2","V3","V4"]) -> True) (traverse getSwizzChar -> Just s)) -> Just (e, s)
264 _ -> Nothing
265
266getSwizzChar = \case
267 A0 "Sx" -> Just 'x'
268 A0 "Sy" -> Just 'y'
269 A0 "Sz" -> Just 'z'
270 A0 "Sw" -> Just 'w'
271 _ -> Nothing
272
273outputType = TCon0 "Output"
274boolType = TBool
275trueExp = TCon TBool "True"
276
diff --git a/src/LambdaCube/Compiler/CoreToGLSL.hs b/src/LambdaCube/Compiler/CoreToGLSL.hs
deleted file mode 100644
index 9247db17..00000000
--- a/src/LambdaCube/Compiler/CoreToGLSL.hs
+++ /dev/null
@@ -1,357 +0,0 @@
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE PatternSynonyms #-}
3{-# LANGUAGE ViewPatterns #-}
4{-# LANGUAGE PackageImports #-}
5{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE LambdaCase #-}
7module LambdaCube.Compiler.CoreToGLSL
8 ( genVertexGLSL
9 , genFragmentGLSL
10 ) where
11
12import Debug.Trace
13
14import Data.Char
15import Data.List
16import Data.Maybe
17import Data.Set (Set)
18import qualified Data.Set as Set
19import Data.Map (Map)
20import qualified Data.Map as Map
21
22import Control.Arrow hiding ((<+>))
23import Control.Monad.Writer
24
25import LambdaCube.Compiler.Pretty hiding (parens)
26import LambdaCube.Compiler.CGExp
27import IR(Backend(..))
28{-
29mangleIdent :: String -> String
30mangleIdent n = '_': concatMap encodeChar n
31 where
32 encodeChar = \case
33 c | isAlphaNum c -> [c]
34 '_' -> "__"
35 '.' -> "_dot"
36 '$' -> "_dollar"
37 '~' -> "_tilde"
38 '=' -> "_eq"
39 '<' -> "_less"
40 '>' -> "_greater"
41 '!' -> "_bang"
42 '#' -> "_hash"
43 '%' -> "_percent"
44 '^' -> "_up"
45 '&' -> "_amp"
46 '|' -> "_bar"
47 '*' -> "_times"
48 '/' -> "_div"
49 '+' -> "_plus"
50 '-' -> "_minus"
51 ':' -> "_colon"
52 '\\' -> "_bslash"
53 '?' -> "_qmark"
54 '@' -> "_at"
55 '\'' -> "_prime"
56 c -> '$' : show (ord c)
57-}
58
59genUniforms :: Exp -> Set [String]
60genUniforms e = case e of
61 Uniform (EString s) -> Set.singleton [unwords ["uniform",toGLSLType "1" $ tyOf e,s,";"]]
62 ELet (PVar _ _) (A3 "Sampler" _ _ (A1 "Texture2DSlot" (EString n))) _ -> Set.singleton [unwords ["uniform","sampler2D",n,";"]]
63 ELet (PVar _ n) (A3 "Sampler" _ _ (A2 "Texture2D" _ _)) _ -> Set.singleton [unwords ["uniform","sampler2D",n,";"]]
64 Exp e -> foldMap genUniforms e
65
66type GLSL = Writer [String]
67
68genStreamInput :: Backend -> Pat -> GLSL [String]
69genStreamInput backend i = fmap concat $ mapM input $ case i of
70 PTuple l -> l
71 x -> [x]
72 where
73 input (PVar t n) = tell [unwords [inputDef,toGLSLType (n ++ "\n") t,n,";"]] >> return [n]
74 input a = error $ "genStreamInput " ++ ppShow a
75 inputDef = case backend of
76 OpenGL33 -> "in"
77 WebGL1 -> "attribute"
78
79genStreamOutput :: Backend -> Exp -> GLSL [(String, String, String)]
80genStreamOutput backend (eTuple -> l) = fmap concat $ zipWithM go (map (("v" ++) . show) [0..]) l
81 where
82 go var (A1 (f -> i) (toGLSLType "3" . tyOf -> t)) = do
83 tell $ case backend of
84 WebGL1 -> [unwords ["varying",t,var,";"]]
85 OpenGL33 -> [unwords [i,"out",t,var,";"]]
86 return [(i,t,var)]
87 f "Smooth" = "smooth"
88 f "Flat" = "flat"
89 f "NoPerspective" = "noperspective"
90
91eTuple (ETuple l) = l
92eTuple x = [x]
93
94genFragmentInput :: Backend -> [(String, String, String)] -> GLSL ()
95genFragmentInput OpenGL33 s = tell [unwords [i,"in",t,n,";"] | (i,t,n) <- s]
96genFragmentInput WebGL1 s = tell [unwords ["varying",t,n,";"] | (i,t,n) <- s]
97genFragmentOutput backend (tyOf -> a@(toGLSLType "4" -> t)) = case a of
98 TUnit -> return False
99 _ -> case backend of
100 OpenGL33 -> tell [unwords ["out",t,"f0",";"]] >> return True
101 WebGL1 -> return True
102
103genVertexGLSL :: Backend -> Exp -> (([String],[(String,String,String)]),String)
104genVertexGLSL backend e@(etaRed -> ELam i (A4 "VertexOut" p s c o)) = id *** unlines $ runWriter $ do
105 case backend of
106 OpenGL33 -> do
107 tell ["#version 330 core"]
108 tell ["vec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}"]
109 WebGL1 -> do
110 tell ["#version 100"]
111 tell ["precision highp float;"]
112 tell ["precision highp int;"]
113 mapM_ tell $ genUniforms e
114 input <- genStreamInput backend i
115 out <- genStreamOutput backend o
116 tell ["void main() {"]
117 unless (null out) $ sequence_ [tell $ [var <> " = " <> genGLSL x <> ";"] | ((_,_,var),x) <- zip out $ eTuple o]
118 tell ["gl_Position = " <> genGLSL p <> ";"]
119 tell ["gl_PointSize = " <> genGLSL s <> ";"]
120 tell ["}"]
121 return (input,out)
122genVertexGLSL _ e = error $ "genVertexGLSL: " ++ ppShow e
123
124genGLSL :: Exp -> String
125genGLSL e = show $ genGLSLSubst mempty e
126
127genFragmentGLSL :: Backend -> [(String,String,String)] -> Exp -> Exp -> String
128genFragmentGLSL backend s e@(etaRed -> ELam i fragOut) ffilter{-TODO-} = unlines $ execWriter $ do
129 case backend of
130 OpenGL33 -> do
131 tell ["#version 330 core"]
132 tell ["vec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}"]
133 WebGL1 -> do
134 tell ["#version 100"]
135 tell ["precision highp float;"]
136 tell ["precision highp int;"]
137 mapM_ tell $ genUniforms e
138 genFragmentInput backend s
139 let o = case fragOut of
140 A1 "FragmentOutRastDepth" o -> o
141 A1 "FragmentOut" o -> o
142 _ -> error $ "genFragmentGLSL fragOut " ++ ppShow fragOut
143 hasOutput <- genFragmentOutput backend o
144 tell ["void main() {"]
145 case ffilter of
146 A0 "PassAll" -> return ()
147 A1 "Filter" (etaRed -> ELam i o) -> tell ["if (!(" <> show (genGLSLSubst (makeSubst i s) o) <> ")) discard;"]
148 when hasOutput $ case backend of
149 OpenGL33 -> tell ["f0 = " <> show (genGLSLSubst (makeSubst i s) o) <> ";"]
150 WebGL1 -> tell ["gl_FragColor = " <> show (genGLSLSubst (makeSubst i s) o) <> ";"]
151 tell ["}"]
152genFragmentGLSL _ _ e ff = error $ "genFragmentGLSL: " ++ ppShow e ++ ppShow ff
153
154makeSubst (PVar _ x) [(_,_,n)] = Map.singleton x n
155makeSubst (PTuple l) x = Map.fromList $ go l x where
156 go [] [] = []
157 go (PVar _ x: al) ((_,_,n):bl) = (x,n) : go al bl
158 go i s = error $ "genFragmentGLSL illegal input " ++ ppShow i ++ " " ++ show s
159
160parens a = "(" <+> a <+> ")"
161
162-- todo: (on hold) name mangling to prevent name collisions
163-- todo: reader monad
164genGLSLSubst :: Map String String -> Exp -> Doc
165genGLSLSubst s e = case e of
166 ELit a -> text $ show a
167 EVar a -> text $ Map.findWithDefault a a s
168 Uniform (EString s) -> text s
169 -- texturing
170 A3 "Sampler" _ _ _ -> error $ "sampler GLSL codegen is not supported"
171 PrimN "texture2D" xs -> functionCall "texture2D" xs
172 -- interpolation
173 A1 "Smooth" a -> gen a
174 A1 "Flat" a -> gen a
175 A1 "NoPerspecitve" a -> gen a
176
177 -- temp builtins FIXME: get rid of these
178 Prim1 "primIntToWord" a -> error $ "WebGL 1 does not support uint types: " ++ ppShow e
179 Prim1 "primIntToFloat" a -> gen a -- FIXME: does GLSL support implicit int to float cast???
180 Prim2 "primCompareInt" a b -> error $ "GLSL codegen does not support: " ++ ppShow e
181 Prim2 "primCompareWord" a b -> error $ "GLSL codegen does not support: " ++ ppShow e
182 Prim2 "primCompareFloat" a b -> error $ "GLSL codegen does not support: " ++ ppShow e
183 Prim1 "primNegateInt" a -> text "-" <+> parens (gen a)
184 Prim1 "primNegateWord" a -> error $ "WebGL 1 does not support uint types: " ++ ppShow e
185 Prim1 "primNegateFloat" a -> text "-" <+> parens (gen a)
186
187 -- vectors
188 AN n xs | n `elem` ["V2", "V3", "V4"], Just s <- vecConName $ tyOf e -> functionCall s xs
189 -- bool
190 A0 "True" -> text "true"
191 A0 "False" -> text "false"
192 -- matrices
193 AN "M22F" xs -> functionCall "mat2" xs
194 AN "M23F" xs -> error "WebGL 1 does not support matrices with this dimension"
195 AN "M24F" xs -> error "WebGL 1 does not support matrices with this dimension"
196 AN "M32F" xs -> error "WebGL 1 does not support matrices with this dimension"
197 AN "M33F" xs -> functionCall "mat3" xs
198 AN "M34F" xs -> error "WebGL 1 does not support matrices with this dimension"
199 AN "M42F" xs -> error "WebGL 1 does not support matrices with this dimension"
200 AN "M43F" xs -> error "WebGL 1 does not support matrices with this dimension"
201 AN "M44F" xs -> functionCall "mat4" xs -- where gen = gen
202
203 Prim3 "primIfThenElse" a b c -> gen a <+> "?" <+> gen b <+> ":" <+> gen c
204 -- TODO: Texture Lookup Functions
205 SwizzProj a x -> "(" <+> gen a <+> (")." <> text x)
206 ELam _ _ -> error "GLSL codegen for lambda function is not supported yet"
207 ELet (PVar _ _) (A3 "Sampler" _ _ (A1 "Texture2DSlot" (EString n))) _ -> text n
208 ELet (PVar _ n) (A3 "Sampler" _ _ (A2 "Texture2D" _ _)) _ -> text n
209 ELet _ _ _ -> error "GLSL codegen for let is not supported yet"
210 ETuple _ -> error "GLSL codegen for tuple is not supported yet"
211
212 -- Primitive Functions
213 PrimN ('P':'r':'i':'m':n) xs | n'@(_:_) <- trName (dropS n) -> case n' of
214 (c:_) | isAlpha c -> functionCall n' xs
215 [op, '_'] -> prefixOp [op] xs
216 n' -> binOp n' xs
217 where
218 ifType p a b = if all (p . tyOf) xs then a else b
219
220 dropS n
221 | last n == 'S' && init n `elem` ["Add", "Sub", "Div", "Mod", "BAnd", "BOr", "BXor", "BShiftL", "BShiftR", "Min", "Max", "Clamp", "Mix", "Step", "SmoothStep"] = init n
222 | otherwise = n
223
224 trName = \case
225
226 -- Arithmetic Functions
227 "Add" -> "+"
228 "Sub" -> "-"
229 "Neg" -> "-_"
230 "Mul" -> ifType isMatrix "matrixCompMult" "*"
231 "MulS" -> "*"
232 "Div" -> "/"
233 "Mod" -> ifType isIntegral "%" "mod"
234
235 -- Bit-wise Functions
236 "BAnd" -> "&"
237 "BOr" -> "|"
238 "BXor" -> "^"
239 "BNot" -> "~_"
240 "BShiftL" -> "<<"
241 "BShiftR" -> ">>"
242
243 -- Logic Functions
244 "And" -> "&&"
245 "Or" -> "||"
246 "Xor" -> "^"
247 "Not" -> ifType isScalar "!_" "not"
248
249 -- Integer/Float Conversion Functions
250 "FloatBitsToInt" -> "floatBitsToInt"
251 "FloatBitsToUInt" -> "floatBitsToUint"
252 "IntBitsToFloat" -> "intBitsToFloat"
253 "UIntBitsToFloat" -> "uintBitsToFloat"
254
255 -- Matrix Functions
256 "OuterProduct" -> "outerProduct"
257 "MulMatVec" -> "*"
258 "MulVecMat" -> "*"
259 "MulMatMat" -> "*"
260
261 -- Fragment Processing Functions
262 "DFdx" -> "dFdx"
263 "DFdy" -> "dFdy"
264
265 -- Vector and Scalar Relational Functions
266 "LessThan" -> ifType isScalarNum "<" "lessThan"
267 "LessThanEqual" -> ifType isScalarNum "<=" "lessThanEqual"
268 "GreaterThan" -> ifType isScalarNum ">" "greaterThan"
269 "GreaterThanEqual" -> ifType isScalarNum ">=" "greaterThanEqual"
270 "Equal" -> "=="
271 "EqualV" -> ifType isScalar "==" "equal"
272 "NotEqual" -> "!="
273 "NotEqualV" -> ifType isScalar "!=" "notEqual"
274
275 -- Angle and Trigonometry Functions
276 "ATan2" -> "atan"
277 -- Exponential Functions
278 "InvSqrt" -> "inversesqrt"
279 -- Common Functions
280 "RoundEven" -> "roundEven"
281 "ModF" -> error "PrimModF is not implemented yet!" -- TODO
282 "MixB" -> "mix"
283
284 n | n `elem`
285 -- Logic Functions
286 [ "Any", "All"
287 -- Angle and Trigonometry Functions
288 , "ACos", "ACosH", "ASin", "ASinH", "ATan", "ATanH", "Cos", "CosH", "Degrees", "Radians", "Sin", "SinH", "Tan", "TanH"
289 -- Exponential Functions
290 , "Pow", "Exp", "Exp2", "Log2", "Sqrt"
291 -- Common Functions
292 , "IsNan", "IsInf", "Abs", "Sign", "Floor", "Trunc", "Round", "Ceil", "Fract", "Min", "Max", "Mix", "Step", "SmoothStep"
293 -- Geometric Functions
294 , "Length", "Distance", "Dot", "Cross", "Normalize", "FaceForward", "Reflect", "Refract"
295 -- Matrix Functions
296 , "Transpose", "Determinant", "Inverse"
297 -- Fragment Processing Functions
298 , "FWidth"
299 -- Noise Functions
300 , "Noise1", "Noise2", "Noise3", "Noise4"
301 ] -> map toLower n
302
303 _ -> ""
304
305 x -> error $ "GLSL codegen - unsupported expression: " ++ ppShow x
306 where
307 prefixOp o [a] = text o <+> parens (gen a)
308 binOp o [a, b] = parens (gen a) <+> text o <+> parens (gen b)
309 functionCall f a = text f <+> parens (hcat $ intersperse "," $ map gen a)
310
311 gen = genGLSLSubst s
312
313isMatrix :: Ty -> Bool
314isMatrix (TMat{}) = True
315isMatrix _ = False
316
317isIntegral :: Ty -> Bool
318isIntegral TWord = True
319isIntegral TInt = True
320isIntegral (TVec _ TWord) = True
321isIntegral (TVec _ TInt) = True
322isIntegral _ = False
323
324isScalarNum :: Ty -> Bool
325isScalarNum = \case
326 TInt -> True
327 TWord -> True
328 TFloat -> True
329 _ -> False
330
331isScalar :: Ty -> Bool
332isScalar = isJust . scalarType
333
334scalarType = \case
335 TBool -> Just "b"
336 TWord -> Just "u"
337 TInt -> Just "i"
338 TFloat -> Just ""
339 _ -> Nothing
340
341vecConName = \case
342 TVec n t | is234 n, Just s <- scalarType t -> Just $ s ++ "vec" ++ show n
343 t -> Nothing
344
345toGLSLType msg = \case
346 TBool -> "bool"
347 TWord -> "uint"
348 TInt -> "int"
349 TFloat -> "float"
350 x@(TVec n t) | Just s <- vecConName x -> s
351 TMat i j TFloat | is234 i && is234 j -> "mat" ++ if i == j then show i else show i ++ "x" ++ show j
352 TTuple [] -> "void"
353 t -> error $ "toGLSLType: " ++ msg ++ " " ++ ppShow t
354
355is234 = (`elem` [2,3,4])
356
357
diff --git a/src/LambdaCube/Compiler/CoreToIR.hs b/src/LambdaCube/Compiler/CoreToIR.hs
index 66624afa..f37f13e5 100644
--- a/src/LambdaCube/Compiler/CoreToIR.hs
+++ b/src/LambdaCube/Compiler/CoreToIR.hs
@@ -4,13 +4,17 @@
4{-# LANGUAGE FlexibleContexts #-} 4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE LambdaCase #-} 5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE PackageImports #-} 6{-# LANGUAGE PackageImports #-}
7{-# LANGUAGE DeriveFunctor #-}
8{-# LANGUAGE DeriveFoldable #-}
9{-# LANGUAGE DeriveTraversable #-}
7module LambdaCube.Compiler.CoreToIR 10module LambdaCube.Compiler.CoreToIR
8 ( compilePipeline 11 ( compilePipeline
12 , Exp, toExp, tyOf, outputType, boolType, trueExp
9 ) where 13 ) where
10 14
11import Debug.Trace 15import Data.Char
12import Control.Applicative 16import Data.List
13import Control.Monad.State 17import Data.Maybe
14import Data.Monoid 18import Data.Monoid
15import Data.Set (Set) 19import Data.Set (Set)
16import qualified Data.Set as Set 20import qualified Data.Set as Set
@@ -18,13 +22,26 @@ import Data.Map (Map)
18import qualified Data.Map as Map 22import qualified Data.Map as Map
19import Data.Vector (Vector,(!)) 23import Data.Vector (Vector,(!))
20import qualified Data.Vector as Vector 24import qualified Data.Vector as Vector
25import Control.Applicative
26import Control.Arrow hiding ((<+>))
27import Control.Monad.Writer
28import Control.Monad.State
29import Control.Monad.Reader
30import Control.Monad.Except
31import Control.Monad.Identity
32import Text.Parsec.Pos
33import Debug.Trace
21 34
22import LambdaCube.Compiler.Pretty 35import IR(Backend(..))
23import LambdaCube.Compiler.CGExp
24import LambdaCube.Compiler.CoreToGLSL
25import qualified IR as IR 36import qualified IR as IR
26import qualified "lambdacube-ir" Linear as IR 37import qualified "lambdacube-ir" Linear as IR
27 38
39import LambdaCube.Compiler.Pretty hiding (parens)
40import qualified LambdaCube.Compiler.Infer as I
41import LambdaCube.Compiler.Infer (SName, Lit(..), Visibility(..))
42
43--------------------------------------------------------------------------
44
28type CG = State IR.Pipeline 45type CG = State IR.Pipeline
29 46
30pattern TFrameBuffer a b <- A2 "FrameBuffer" a b 47pattern TFrameBuffer a b <- A2 "FrameBuffer" a b
@@ -449,3 +466,585 @@ compPV x = case x of
449 A0 "FirstVertex" -> IR.FirstVertex 466 A0 "FirstVertex" -> IR.FirstVertex
450 A0 "LastVertex" -> IR.LastVertex 467 A0 "LastVertex" -> IR.LastVertex
451 x -> error $ "compPV " ++ ppShow x 468 x -> error $ "compPV " ++ ppShow x
469
470--------------------------------------------------------------- GLSL generation
471
472{-
473mangleIdent :: String -> String
474mangleIdent n = '_': concatMap encodeChar n
475 where
476 encodeChar = \case
477 c | isAlphaNum c -> [c]
478 '_' -> "__"
479 '.' -> "_dot"
480 '$' -> "_dollar"
481 '~' -> "_tilde"
482 '=' -> "_eq"
483 '<' -> "_less"
484 '>' -> "_greater"
485 '!' -> "_bang"
486 '#' -> "_hash"
487 '%' -> "_percent"
488 '^' -> "_up"
489 '&' -> "_amp"
490 '|' -> "_bar"
491 '*' -> "_times"
492 '/' -> "_div"
493 '+' -> "_plus"
494 '-' -> "_minus"
495 ':' -> "_colon"
496 '\\' -> "_bslash"
497 '?' -> "_qmark"
498 '@' -> "_at"
499 '\'' -> "_prime"
500 c -> '$' : show (ord c)
501-}
502
503genUniforms :: Exp -> Set [String]
504genUniforms e = case e of
505 Uniform (EString s) -> Set.singleton [unwords ["uniform",toGLSLType "1" $ tyOf e,s,";"]]
506 ELet (PVar _ _) (A3 "Sampler" _ _ (A1 "Texture2DSlot" (EString n))) _ -> Set.singleton [unwords ["uniform","sampler2D",n,";"]]
507 ELet (PVar _ n) (A3 "Sampler" _ _ (A2 "Texture2D" _ _)) _ -> Set.singleton [unwords ["uniform","sampler2D",n,";"]]
508 Exp e -> foldMap genUniforms e
509
510type GLSL = Writer [String]
511
512genStreamInput :: Backend -> Pat -> GLSL [String]
513genStreamInput backend i = fmap concat $ mapM input $ case i of
514 PTuple l -> l
515 x -> [x]
516 where
517 input (PVar t n) = tell [unwords [inputDef,toGLSLType (n ++ "\n") t,n,";"]] >> return [n]
518 input a = error $ "genStreamInput " ++ ppShow a
519 inputDef = case backend of
520 OpenGL33 -> "in"
521 WebGL1 -> "attribute"
522
523genStreamOutput :: Backend -> Exp -> GLSL [(String, String, String)]
524genStreamOutput backend (eTuple -> l) = fmap concat $ zipWithM go (map (("v" ++) . show) [0..]) l
525 where
526 go var (A1 (f -> i) (toGLSLType "3" . tyOf -> t)) = do
527 tell $ case backend of
528 WebGL1 -> [unwords ["varying",t,var,";"]]
529 OpenGL33 -> [unwords [i,"out",t,var,";"]]
530 return [(i,t,var)]
531 f "Smooth" = "smooth"
532 f "Flat" = "flat"
533 f "NoPerspective" = "noperspective"
534
535eTuple (ETuple l) = l
536eTuple x = [x]
537
538genFragmentInput :: Backend -> [(String, String, String)] -> GLSL ()
539genFragmentInput OpenGL33 s = tell [unwords [i,"in",t,n,";"] | (i,t,n) <- s]
540genFragmentInput WebGL1 s = tell [unwords ["varying",t,n,";"] | (i,t,n) <- s]
541genFragmentOutput backend (tyOf -> a@(toGLSLType "4" -> t)) = case a of
542 TUnit -> return False
543 _ -> case backend of
544 OpenGL33 -> tell [unwords ["out",t,"f0",";"]] >> return True
545 WebGL1 -> return True
546
547genVertexGLSL :: Backend -> Exp -> (([String],[(String,String,String)]),String)
548genVertexGLSL backend e@(etaRed -> ELam i (A4 "VertexOut" p s c o)) = id *** unlines $ runWriter $ do
549 case backend of
550 OpenGL33 -> do
551 tell ["#version 330 core"]
552 tell ["vec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}"]
553 WebGL1 -> do
554 tell ["#version 100"]
555 tell ["precision highp float;"]
556 tell ["precision highp int;"]
557 mapM_ tell $ genUniforms e
558 input <- genStreamInput backend i
559 out <- genStreamOutput backend o
560 tell ["void main() {"]
561 unless (null out) $ sequence_ [tell $ [var <> " = " <> genGLSL x <> ";"] | ((_,_,var),x) <- zip out $ eTuple o]
562 tell ["gl_Position = " <> genGLSL p <> ";"]
563 tell ["gl_PointSize = " <> genGLSL s <> ";"]
564 tell ["}"]
565 return (input,out)
566genVertexGLSL _ e = error $ "genVertexGLSL: " ++ ppShow e
567
568genGLSL :: Exp -> String
569genGLSL e = show $ genGLSLSubst mempty e
570
571genFragmentGLSL :: Backend -> [(String,String,String)] -> Exp -> Exp -> String
572genFragmentGLSL backend s e@(etaRed -> ELam i fragOut) ffilter{-TODO-} = unlines $ execWriter $ do
573 case backend of
574 OpenGL33 -> do
575 tell ["#version 330 core"]
576 tell ["vec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}"]
577 WebGL1 -> do
578 tell ["#version 100"]
579 tell ["precision highp float;"]
580 tell ["precision highp int;"]
581 mapM_ tell $ genUniforms e
582 genFragmentInput backend s
583 let o = case fragOut of
584 A1 "FragmentOutRastDepth" o -> o
585 A1 "FragmentOut" o -> o
586 _ -> error $ "genFragmentGLSL fragOut " ++ ppShow fragOut
587 hasOutput <- genFragmentOutput backend o
588 tell ["void main() {"]
589 case ffilter of
590 A0 "PassAll" -> return ()
591 A1 "Filter" (etaRed -> ELam i o) -> tell ["if (!(" <> show (genGLSLSubst (makeSubst i s) o) <> ")) discard;"]
592 when hasOutput $ case backend of
593 OpenGL33 -> tell ["f0 = " <> show (genGLSLSubst (makeSubst i s) o) <> ";"]
594 WebGL1 -> tell ["gl_FragColor = " <> show (genGLSLSubst (makeSubst i s) o) <> ";"]
595 tell ["}"]
596genFragmentGLSL _ _ e ff = error $ "genFragmentGLSL: " ++ ppShow e ++ ppShow ff
597
598makeSubst (PVar _ x) [(_,_,n)] = Map.singleton x n
599makeSubst (PTuple l) x = Map.fromList $ go l x where
600 go [] [] = []
601 go (PVar _ x: al) ((_,_,n):bl) = (x,n) : go al bl
602 go i s = error $ "genFragmentGLSL illegal input " ++ ppShow i ++ " " ++ show s
603
604parens a = "(" <+> a <+> ")"
605
606-- todo: (on hold) name mangling to prevent name collisions
607-- todo: reader monad
608genGLSLSubst :: Map String String -> Exp -> Doc
609genGLSLSubst s e = case e of
610 ELit a -> text $ show a
611 EVar a -> text $ Map.findWithDefault a a s
612 Uniform (EString s) -> text s
613 -- texturing
614 A3 "Sampler" _ _ _ -> error $ "sampler GLSL codegen is not supported"
615 PrimN "texture2D" xs -> functionCall "texture2D" xs
616 -- interpolation
617 A1 "Smooth" a -> gen a
618 A1 "Flat" a -> gen a
619 A1 "NoPerspecitve" a -> gen a
620
621 -- temp builtins FIXME: get rid of these
622 Prim1 "primIntToWord" a -> error $ "WebGL 1 does not support uint types: " ++ ppShow e
623 Prim1 "primIntToFloat" a -> gen a -- FIXME: does GLSL support implicit int to float cast???
624 Prim2 "primCompareInt" a b -> error $ "GLSL codegen does not support: " ++ ppShow e
625 Prim2 "primCompareWord" a b -> error $ "GLSL codegen does not support: " ++ ppShow e
626 Prim2 "primCompareFloat" a b -> error $ "GLSL codegen does not support: " ++ ppShow e
627 Prim1 "primNegateInt" a -> text "-" <+> parens (gen a)
628 Prim1 "primNegateWord" a -> error $ "WebGL 1 does not support uint types: " ++ ppShow e
629 Prim1 "primNegateFloat" a -> text "-" <+> parens (gen a)
630
631 -- vectors
632 AN n xs | n `elem` ["V2", "V3", "V4"], Just s <- vecConName $ tyOf e -> functionCall s xs
633 -- bool
634 A0 "True" -> text "true"
635 A0 "False" -> text "false"
636 -- matrices
637 AN "M22F" xs -> functionCall "mat2" xs
638 AN "M23F" xs -> error "WebGL 1 does not support matrices with this dimension"
639 AN "M24F" xs -> error "WebGL 1 does not support matrices with this dimension"
640 AN "M32F" xs -> error "WebGL 1 does not support matrices with this dimension"
641 AN "M33F" xs -> functionCall "mat3" xs
642 AN "M34F" xs -> error "WebGL 1 does not support matrices with this dimension"
643 AN "M42F" xs -> error "WebGL 1 does not support matrices with this dimension"
644 AN "M43F" xs -> error "WebGL 1 does not support matrices with this dimension"
645 AN "M44F" xs -> functionCall "mat4" xs -- where gen = gen
646
647 Prim3 "primIfThenElse" a b c -> gen a <+> "?" <+> gen b <+> ":" <+> gen c
648 -- TODO: Texture Lookup Functions
649 SwizzProj a x -> "(" <+> gen a <+> (")." <> text x)
650 ELam _ _ -> error "GLSL codegen for lambda function is not supported yet"
651 ELet (PVar _ _) (A3 "Sampler" _ _ (A1 "Texture2DSlot" (EString n))) _ -> text n
652 ELet (PVar _ n) (A3 "Sampler" _ _ (A2 "Texture2D" _ _)) _ -> text n
653 ELet _ _ _ -> error "GLSL codegen for let is not supported yet"
654 ETuple _ -> error "GLSL codegen for tuple is not supported yet"
655
656 -- Primitive Functions
657 PrimN ('P':'r':'i':'m':n) xs | n'@(_:_) <- trName (dropS n) -> case n' of
658 (c:_) | isAlpha c -> functionCall n' xs
659 [op, '_'] -> prefixOp [op] xs
660 n' -> binOp n' xs
661 where
662 ifType p a b = if all (p . tyOf) xs then a else b
663
664 dropS n
665 | last n == 'S' && init n `elem` ["Add", "Sub", "Div", "Mod", "BAnd", "BOr", "BXor", "BShiftL", "BShiftR", "Min", "Max", "Clamp", "Mix", "Step", "SmoothStep"] = init n
666 | otherwise = n
667
668 trName = \case
669
670 -- Arithmetic Functions
671 "Add" -> "+"
672 "Sub" -> "-"
673 "Neg" -> "-_"
674 "Mul" -> ifType isMatrix "matrixCompMult" "*"
675 "MulS" -> "*"
676 "Div" -> "/"
677 "Mod" -> ifType isIntegral "%" "mod"
678
679 -- Bit-wise Functions
680 "BAnd" -> "&"
681 "BOr" -> "|"
682 "BXor" -> "^"
683 "BNot" -> "~_"
684 "BShiftL" -> "<<"
685 "BShiftR" -> ">>"
686
687 -- Logic Functions
688 "And" -> "&&"
689 "Or" -> "||"
690 "Xor" -> "^"
691 "Not" -> ifType isScalar "!_" "not"
692
693 -- Integer/Float Conversion Functions
694 "FloatBitsToInt" -> "floatBitsToInt"
695 "FloatBitsToUInt" -> "floatBitsToUint"
696 "IntBitsToFloat" -> "intBitsToFloat"
697 "UIntBitsToFloat" -> "uintBitsToFloat"
698
699 -- Matrix Functions
700 "OuterProduct" -> "outerProduct"
701 "MulMatVec" -> "*"
702 "MulVecMat" -> "*"
703 "MulMatMat" -> "*"
704
705 -- Fragment Processing Functions
706 "DFdx" -> "dFdx"
707 "DFdy" -> "dFdy"
708
709 -- Vector and Scalar Relational Functions
710 "LessThan" -> ifType isScalarNum "<" "lessThan"
711 "LessThanEqual" -> ifType isScalarNum "<=" "lessThanEqual"
712 "GreaterThan" -> ifType isScalarNum ">" "greaterThan"
713 "GreaterThanEqual" -> ifType isScalarNum ">=" "greaterThanEqual"
714 "Equal" -> "=="
715 "EqualV" -> ifType isScalar "==" "equal"
716 "NotEqual" -> "!="
717 "NotEqualV" -> ifType isScalar "!=" "notEqual"
718
719 -- Angle and Trigonometry Functions
720 "ATan2" -> "atan"
721 -- Exponential Functions
722 "InvSqrt" -> "inversesqrt"
723 -- Common Functions
724 "RoundEven" -> "roundEven"
725 "ModF" -> error "PrimModF is not implemented yet!" -- TODO
726 "MixB" -> "mix"
727
728 n | n `elem`
729 -- Logic Functions
730 [ "Any", "All"
731 -- Angle and Trigonometry Functions
732 , "ACos", "ACosH", "ASin", "ASinH", "ATan", "ATanH", "Cos", "CosH", "Degrees", "Radians", "Sin", "SinH", "Tan", "TanH"
733 -- Exponential Functions
734 , "Pow", "Exp", "Exp2", "Log2", "Sqrt"
735 -- Common Functions
736 , "IsNan", "IsInf", "Abs", "Sign", "Floor", "Trunc", "Round", "Ceil", "Fract", "Min", "Max", "Mix", "Step", "SmoothStep"
737 -- Geometric Functions
738 , "Length", "Distance", "Dot", "Cross", "Normalize", "FaceForward", "Reflect", "Refract"
739 -- Matrix Functions
740 , "Transpose", "Determinant", "Inverse"
741 -- Fragment Processing Functions
742 , "FWidth"
743 -- Noise Functions
744 , "Noise1", "Noise2", "Noise3", "Noise4"
745 ] -> map toLower n
746
747 _ -> ""
748
749 x -> error $ "GLSL codegen - unsupported expression: " ++ ppShow x
750 where
751 prefixOp o [a] = text o <+> parens (gen a)
752 binOp o [a, b] = parens (gen a) <+> text o <+> parens (gen b)
753 functionCall f a = text f <+> parens (hcat $ intersperse "," $ map gen a)
754
755 gen = genGLSLSubst s
756
757isMatrix :: Ty -> Bool
758isMatrix (TMat{}) = True
759isMatrix _ = False
760
761isIntegral :: Ty -> Bool
762isIntegral TWord = True
763isIntegral TInt = True
764isIntegral (TVec _ TWord) = True
765isIntegral (TVec _ TInt) = True
766isIntegral _ = False
767
768isScalarNum :: Ty -> Bool
769isScalarNum = \case
770 TInt -> True
771 TWord -> True
772 TFloat -> True
773 _ -> False
774
775isScalar :: Ty -> Bool
776isScalar = isJust . scalarType
777
778scalarType = \case
779 TBool -> Just "b"
780 TWord -> Just "u"
781 TInt -> Just "i"
782 TFloat -> Just ""
783 _ -> Nothing
784
785vecConName = \case
786 TVec n t | is234 n, Just s <- scalarType t -> Just $ s ++ "vec" ++ show n
787 t -> Nothing
788
789toGLSLType msg = \case
790 TBool -> "bool"
791 TWord -> "uint"
792 TInt -> "int"
793 TFloat -> "float"
794 x@(TVec n t) | Just s <- vecConName x -> s
795 TMat i j TFloat | is234 i && is234 j -> "mat" ++ if i == j then show i else show i ++ "x" ++ show j
796 TTuple [] -> "void"
797 t -> error $ "toGLSLType: " ++ msg ++ " " ++ ppShow t
798
799is234 = (`elem` [2,3,4])
800
801
802--------------------------------------------------------------------------------
803
804data Exp_ a
805 = Pi_ Visibility SName a a
806 | Lam_ Visibility Pat a a
807 | Con_ (SName, a) [a]
808 | ELit_ Lit
809 | Fun_ (SName, a) [a]
810 | App_ a a
811 | Var_ SName a
812 | TType_
813 | Let_ Pat a a
814 deriving (Show, Eq, Functor, Foldable, Traversable)
815
816instance PShow Exp where pShowPrec p = text . show
817
818pattern Pi h n a b = Exp (Pi_ h n a b)
819pattern Lam h n a b = Exp (Lam_ h n a b)
820pattern Con a b = Exp (Con_ a b)
821pattern ELit a = Exp (ELit_ a)
822pattern Fun a b = Exp (Fun_ a b)
823pattern EApp a b = Exp (App_ a b)
824pattern Var a b = Exp (Var_ a b)
825pattern TType = Exp TType_
826pattern ELet a b c = Exp (Let_ a b c)
827
828pattern EString s = ELit (LString s)
829pattern EFloat s = ELit (LFloat s)
830pattern EInt s = ELit (LInt s)
831
832newtype Exp = Exp (Exp_ Exp)
833 deriving (Show, Eq)
834
835toExp :: I.Exp -> Exp
836toExp = flip runReader [] . flip evalStateT freshTypeVars . f
837 where
838 freshTypeVars = (flip (:) <$> map show [0..] <*> ['a'..'z'])
839 newName = gets head <* modify tail
840 f = \case
841 I.Var i -> asks (!!! i)
842 I.Pi b x (I.downE 0 -> Just y) -> Pi b "" <$> f x <*> f y
843 I.Pi b x y -> newName >>= \n -> do
844 t <- f x
845 Pi b n t <$> local (Var n t:) (f y)
846 I.Lam b x y -> newName >>= \n -> do
847 t <- f x
848 Lam b (PVar t n) t <$> local (Var n t:) (f y)
849 I.Con (I.ConName s _ _ t) xs -> con s <$> f t <*> mapM f xs
850 I.TyCon (I.TyConName s _ _ t _ _) xs -> con s <$> f t <*> mapM f xs
851 I.ELit l -> pure $ ELit l
852 I.Fun (I.FunName s _ t) xs -> fun s <$> f t <*> mapM f xs
853 I.CaseFun x@(I.CaseFunName _ t _) xs -> fun (show x) <$> f t <*> mapM f xs
854 I.App a b -> app' <$> f a <*> f b
855 I.PMLabel x _ -> f x
856 I.FixLabel _ x -> f x
857 I.TType -> pure TType
858 I.LabelEnd x -> f x
859 z -> error $ "toExp: " ++ show z
860
861 xs !!! i | i < 0 || i >= length xs = error $ show xs ++ " !! " ++ show i
862 xs !!! i = xs !! i
863
864 untick ('\'': s) = s
865 untick s = s
866
867 fun s t xs = Fun (untick s, t) xs
868 con s t xs = Con (untick s, t) xs
869
870freeVars :: Exp -> Set.Set SName
871freeVars = \case
872 Var n _ -> Set.singleton n
873 Con _ xs -> Set.unions $ map freeVars xs
874 ELit _ -> mempty
875 Fun _ xs -> Set.unions $ map freeVars xs
876 EApp a b -> freeVars a `Set.union` freeVars b
877 Pi _ n a b -> freeVars a `Set.union` (Set.delete n $ freeVars b)
878 Lam _ n a b -> freeVars a `Set.union` (foldr Set.delete (freeVars b) (patVars n))
879 TType -> mempty
880 ELet n a b -> freeVars a `Set.union` (foldr Set.delete (freeVars b) (patVars n))
881
882type Ty = Exp
883
884tyOf :: Exp -> Ty
885tyOf = \case
886 Lam h (PVar _ n) t x -> Pi h n t $ tyOf x
887 EApp f x -> app (tyOf f) x
888 Var _ t -> t
889 Pi{} -> TType
890 Con (_, t) xs -> foldl app t xs
891 Fun (_, t) xs -> foldl app t xs
892 ELit l -> toExp $ I.litType l
893 TType -> TType
894 ELet a b c -> tyOf $ EApp (ELam a c) b
895 x -> error $ "tyOf: " ++ show x
896 where
897 app (Pi _ n a b) x = substE n x b
898
899substE n x = \case
900 z@(Var n' _) | n' == n -> x
901 | otherwise -> z
902 Pi h n' a b | n == n' -> Pi h n' (substE n x a) b
903 Pi h n' a b -> Pi h n' (substE n x a) (substE n x b)
904 Lam h n' a b -> Lam h n' (substE n x a) $ if n `elem` patVars n' then b else substE n x b
905 Con cn xs -> Con cn (map (substE n x) xs)
906 Fun cn xs -> Fun cn (map (substE n x) xs)
907 TType -> TType
908 EApp a b -> app' (substE n x a) (substE n x b)
909 z -> error $ "substE: " ++ show z
910
911app' (Lam _ (PVar _ n) _ x) b = substE n b x
912app' a b = EApp a b
913
914-------------------------------------------------------------------------------- Exp conversion -- TODO: remove
915
916data Pat
917 = PVar Exp SName
918 | PTuple [Pat]
919 deriving (Eq, Show)
920
921instance PShow Pat where pShowPrec p = text . show
922
923patVars (PVar _ n) = [n]
924patVars (PTuple ps) = concatMap patVars ps
925
926patTy (PVar t _) = t
927patTy (PTuple ps) = Con ("Tuple" ++ show (length ps), tupTy $ length ps) $ map patTy ps
928
929tupTy n = foldr (:~>) TType $ replicate n TType
930
931-- workaround for backward compatibility
932etaRed (ELam (PVar _ n) (EApp f (EVar n'))) | n == n' && n `Set.notMember` freeVars f = f
933etaRed (ELam (PVar _ n) (Prim3 (tupCaseName -> Just k) _ x (EVar n'))) | n == n' && n `Set.notMember` freeVars x = uncurry (\ps e -> ELam (PTuple ps) e) $ getPats k x
934etaRed x = x
935
936tupCaseName "Tuple2Case" = Just 2
937tupCaseName "Tuple3Case" = Just 3
938tupCaseName "Tuple4Case" = Just 4
939tupCaseName "Tuple5Case" = Just 5
940tupCaseName "Tuple6Case" = Just 6
941tupCaseName "Tuple7Case" = Just 7
942tupCaseName _ = Nothing
943
944getPats 0 e = ([], e)
945getPats i (ELam p e) = (p:) *** id $ getPats (i-1) e
946
947-------------
948
949pattern EVar n <- Var n _
950pattern TVar t n = Var n t
951
952pattern ELam n b <- Lam Visible n _ b where ELam n b = Lam Visible n (patTy n) b
953
954pattern a :~> b = Pi Visible "" a b
955infixr 1 :~>
956
957pattern PrimN n xs <- Fun (n, t) (filterRelevant (n, 0) t -> xs) where PrimN n xs = Fun (n, builtinType n) xs
958pattern Prim1 n a = PrimN n [a]
959pattern Prim2 n a b = PrimN n [a, b]
960pattern Prim3 n a b c <- PrimN n [a, b, c]
961pattern Prim4 n a b c d <- PrimN n [a, b, c, d]
962pattern Prim5 n a b c d e <- PrimN n [a, b, c, d, e]
963
964builtinType = \case
965 "Output" -> TType
966 "Bool" -> TType
967 "Float" -> TType
968 "Nat" -> TType
969 "Zero" -> TNat
970 "Succ" -> TNat :~> TNat
971 "String" -> TType
972 "Sampler" -> TType
973 "VecS" -> TType :~> TNat :~> TType
974 n -> error $ "type of " ++ show n
975
976filterRelevant _ _ [] = []
977filterRelevant i (Pi h n t t') (x: xs) = (if h == Visible then (x:) else id) $ filterRelevant (id *** (+1) $ i) (substE n x t') xs
978
979pattern AN n xs <- Con (n, t) (filterRelevant (n, 0) t -> xs) where AN n xs = Con (n, builtinType n) xs
980pattern A0 n = AN n []
981pattern A1 n a = AN n [a]
982pattern A2 n a b = AN n [a, b]
983pattern A3 n a b c <- AN n [a, b, c]
984pattern A4 n a b c d <- AN n [a, b, c, d]
985pattern A5 n a b c d e <- AN n [a, b, c, d, e]
986
987pattern TCon0 n = A0 n
988pattern TCon t n = Con (n, t) []
989
990pattern TUnit <- A0 "Tuple0"
991pattern TBool = A0 "Bool"
992pattern TWord <- A0 "Word"
993pattern TInt <- A0 "Int"
994pattern TNat = A0 "Nat"
995pattern TFloat = A0 "Float"
996pattern TString = A0 "String"
997
998pattern Uniform n <- Prim1 "Uniform" n
999
1000pattern Zero = A0 "Zero"
1001pattern Succ n = A1 "Succ" n
1002
1003pattern TVec n a = A2 "VecS" a (Nat n)
1004pattern TMat i j a <- A3 "Mat" (Nat i) (Nat j) a
1005
1006pattern Nat n <- (fromNat -> Just n) where Nat = toNat
1007
1008toNat :: Int -> Exp
1009toNat 0 = Zero
1010toNat n = Succ (toNat $ n-1)
1011
1012fromNat :: Exp -> Maybe Int
1013fromNat Zero = Just 0
1014fromNat (Succ n) = (1 +) <$> fromNat n
1015fromNat _ = Nothing
1016
1017pattern TTuple xs <- (getTuple -> Just xs)
1018pattern ETuple xs <- (getTuple -> Just xs)
1019
1020getTuple (AN (tupName -> Just n) xs) | length xs == n = Just xs
1021getTuple _ = Nothing
1022
1023tupName = \case
1024 "Tuple0" -> Just 0
1025 "Tuple2" -> Just 2
1026 "Tuple3" -> Just 3
1027 "Tuple4" -> Just 4
1028 "Tuple5" -> Just 5
1029 "Tuple6" -> Just 6
1030 "Tuple7" -> Just 7
1031 _ -> Nothing
1032
1033pattern SwizzProj a b <- (getSwizzProj -> Just (a, b))
1034
1035getSwizzProj = \case
1036 Prim2 "swizzscalar" e (getSwizzChar -> Just s) -> Just (e, [s])
1037 Prim2 "swizzvector" e (AN ((`elem` ["V2","V3","V4"]) -> True) (traverse getSwizzChar -> Just s)) -> Just (e, s)
1038 _ -> Nothing
1039
1040getSwizzChar = \case
1041 A0 "Sx" -> Just 'x'
1042 A0 "Sy" -> Just 'y'
1043 A0 "Sz" -> Just 'z'
1044 A0 "Sw" -> Just 'w'
1045 _ -> Nothing
1046
1047outputType = TCon0 "Output"
1048boolType = TBool
1049trueExp = TCon TBool "True"
1050
diff --git a/src/LambdaCube/Compiler/Driver.hs b/src/LambdaCube/Compiler/Driver.hs
index 68ec34dd..6beca81a 100644
--- a/src/LambdaCube/Compiler/Driver.hs
+++ b/src/LambdaCube/Compiler/Driver.hs
@@ -11,7 +11,7 @@ module LambdaCube.Compiler.Driver
11 , Infos 11 , Infos
12 , showRange 12 , showRange
13 , ErrorMsg(..) 13 , ErrorMsg(..)
14 , Exp 14 , Exp, toExp, tyOf, outputType, boolType, trueExp
15 ) where 15 ) where
16 16
17import Data.List 17import Data.List
@@ -31,11 +31,10 @@ import System.Directory
31import System.FilePath 31import System.FilePath
32import Debug.Trace 32import Debug.Trace
33 33
34import IR
34import LambdaCube.Compiler.Pretty hiding ((</>)) 35import LambdaCube.Compiler.Pretty hiding ((</>))
35import LambdaCube.Compiler.Infer (Info, Infos, ErrorMsg(..), showRange, PolyEnv(..), Export(..), ModuleR(..), ErrorT, throwErrorTCM, parseLC, joinPolyEnvs, inference_) 36import LambdaCube.Compiler.Infer (Info, Infos, ErrorMsg(..), showRange, PolyEnv(..), Export(..), ModuleR(..), ErrorT, throwErrorTCM, parseLC, joinPolyEnvs, inference_)
36import LambdaCube.Compiler.CGExp (Exp, toExp, outputType) 37import LambdaCube.Compiler.CoreToIR
37import IR
38import qualified LambdaCube.Compiler.CoreToIR as IR
39 38
40type EName = String 39type EName = String
41type MName = String 40type MName = String
@@ -153,11 +152,11 @@ parseAndToCoreMain m = either (throwErrorTCM . text) return . (\(e, i) -> flip (
153compileMain_ :: MonadMask m => PolyEnv -> ModuleFetcher (MMT m) -> IR.Backend -> FilePath -> MName -> m (Err (IR.Pipeline, Infos)) 152compileMain_ :: MonadMask m => PolyEnv -> ModuleFetcher (MMT m) -> IR.Backend -> FilePath -> MName -> m (Err (IR.Pipeline, Infos))
154compileMain_ prelude fetch backend path fname = runMM fetch $ do 153compileMain_ prelude fetch backend path fname = runMM fetch $ do
155 modify $ Map.insert (path </> "Prelude.lc") $ Right prelude 154 modify $ Map.insert (path </> "Prelude.lc") $ Right prelude
156 (IR.compilePipeline True backend *** id) <$> parseAndToCoreMain fname 155 (compilePipeline True backend *** id) <$> parseAndToCoreMain fname
157 156
158-- | most commonly used interface for end users 157-- | most commonly used interface for end users
159compileMain :: [FilePath] -> IR.Backend -> MName -> IO (Either String IR.Pipeline) 158compileMain :: [FilePath] -> IR.Backend -> MName -> IO (Either String IR.Pipeline)
160compileMain path backend fname = fmap ((show +++ fst) . fst) $ runMM (ioFetch path) $ (IR.compilePipeline True backend *** id) <$> parseAndToCoreMain fname 159compileMain path backend fname = fmap ((show +++ fst) . fst) $ runMM (ioFetch path) $ (compilePipeline True backend *** id) <$> parseAndToCoreMain fname
161 160
162compileMain' :: MonadMask m => PolyEnv -> IR.Backend -> String -> m (Err (IR.Pipeline, Infos)) 161compileMain' :: MonadMask m => PolyEnv -> IR.Backend -> String -> m (Err (IR.Pipeline, Infos))
163compileMain' prelude backend src = compileMain_ prelude fetch backend "." "Main" 162compileMain' prelude backend src = compileMain_ prelude fetch backend "." "Main"
diff --git a/test/runTests.hs b/test/runTests.hs
index b84181bd..5e1939e5 100644
--- a/test/runTests.hs
+++ b/test/runTests.hs
@@ -22,7 +22,6 @@ import Control.DeepSeq
22import qualified Data.Set as Set 22import qualified Data.Set as Set
23 23
24import LambdaCube.Compiler.Pretty hiding ((</>)) 24import LambdaCube.Compiler.Pretty hiding ((</>))
25import LambdaCube.Compiler.CGExp (tyOf, outputType, boolType, trueExp)
26import LambdaCube.Compiler.Driver 25import LambdaCube.Compiler.Driver
27import LambdaCube.Compiler.CoreToIR 26import LambdaCube.Compiler.CoreToIR
28import IR (Backend(..)) 27import IR (Backend(..))
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-29 20:17:32 +0000