From e4a0905679ebb6796e09a7c45cfddb4291781cd9 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sun, 21 Apr 2019 15:35:01 -0400 Subject: Some type signatures (and build fix?). --- src/LambdaCube/Compiler/CoreToIR.hs | 105 +++++++++++++++++++++++++++++++++++- 1 file changed, 104 insertions(+), 1 deletion(-) diff --git a/src/LambdaCube/Compiler/CoreToIR.hs b/src/LambdaCube/Compiler/CoreToIR.hs index 357702f5..45bfa1ad 100644 --- a/src/LambdaCube/Compiler/CoreToIR.hs +++ b/src/LambdaCube/Compiler/CoreToIR.hs @@ -21,6 +21,7 @@ import Data.List import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Vector as Vector +import Data.String import GHC.Stack import GHC.Word import Control.Arrow hiding ((<+>)) @@ -73,16 +74,39 @@ type CG = State (List IR.StreamData, Map IR.Program Int, List IR.RenderTarget, M type List a = (Int, [a]) +streamLens :: ((t1 -> (t1, t2, t3, t4, t5)) -> t6 -> t7) + -> (t6, t2, t3, t4, t5) -> t7 streamLens f (a,b,c,d,e) = f (,b,c,d,e) a +programLens :: ((t1 -> (t2, t1, t3, t4, t5)) -> t6 -> t7) + -> (t2, t6, t3, t4, t5) -> t7 programLens f (a,b,c,d,e) = f (a,,c,d,e) b +targetLens :: ((t1 -> (t2, t3, t1, t4, t5)) -> t6 -> t7) + -> (t2, t3, t6, t4, t5) -> t7 targetLens f (a,b,c,d,e) = f (a,b,,d,e) c +slotLens :: ((t1 -> (t2, t3, t4, t1, t5)) -> t6 -> t7) + -> (t2, t3, t4, t6, t5) -> t7 slotLens f (a,b,c,d,e) = f (a,b,c,,e) d +textureLens :: ((t1 -> (t2, t3, t4, t5, t1)) -> t6 -> t7) + -> (t2, t3, t4, t5, t6) -> t7 textureLens f (a,b,c,d,e) = f (a,b,c,d,) e +modL :: MonadState s m => + (((b -> c) -> a1 -> (d, c)) -> s -> (a2, s)) + -> (a1 -> (d, b)) -> m a2 modL gs f = state $ gs $ \fx -> second fx . f +addL' :: (MonadState s m, Ord k) => + (((Map k (Int, t) -> c) -> Map k (Int, t) -> (Int, c)) + -> s -> (a, s)) + -> k -> (t -> t -> t) -> t -> m a addL' l p f x = modL l $ \sv -> maybe (length sv, Map.insert p (length sv, x) sv) (\(i, x') -> (i, Map.insert p (i, f x x') sv)) $ Map.lookup p sv +addL :: (MonadState s m, Num a1) => + ((((a1, [a2]) -> c) -> (a1, [a2]) -> (a1, c)) -> s -> (a3, s)) + -> a2 -> m a3 addL l x = modL l $ \(i, sv) -> (i, (i+1, x: sv)) +addLEq :: (MonadState s m, Ord k) => + (((Map k Int -> c) -> Map k Int -> (Int, c)) -> s -> (a, s)) + -> k -> m a addLEq l x = modL l $ \sv -> maybe (let i = length sv in i `seq` (i, Map.insert x i sv)) (\i -> (i, sv)) $ Map.lookup x sv --------------------------------------------------------- @@ -251,6 +275,7 @@ type SamplerBinding = (IR.UniformName,IR.ImageRef) ---------------------------------------------------------------- +frameBufferType :: ExpTV -> ExpTV frameBufferType (A2 "FrameBuffer" _ ty) = ty frameBufferType x = error $ "illegal target type: " ++ ppShow x @@ -266,44 +291,55 @@ getImageTextureTypes = map (imageInputTypeTextureType . compImageInputType) . ge getImageInputTypes :: ExpTV -> [IR.InputType] getImageInputTypes = map compImageInputType . getFramebufferType +getFragFilter :: ExpTV -> (Maybe ExpTV, ExpTV) getFragFilter (A2 "map" (EtaPrim2 "filterFragment" p) x) = (Just p, x) getFragFilter x = (Nothing, x) +getVertexShader :: ExpTV -> ((Maybe ExpTV, Ty), ExpTV) getVertexShader (A2 "map" (EtaPrim2 "mapPrimitive" f@(etaReds -> Just (_, o))) x) = ((Just f, tyOf o), x) --getVertexShader (A2 "map" (EtaPrim2 "mapPrimitive" f) x) = error $ "gff: " ++ show (case f of ExpTV x _ _ -> x) --ppShow (mapVal unFunc' f) --getVertexShader x = error $ "gf: " ++ ppShow x getVertexShader x = ((Nothing, getPrim' $ tyOf x), x) +getFragmentShader :: ExpTV -> ((Maybe ExpTV, Ty), ExpTV) getFragmentShader (A2 "map" (EtaPrim2 "mapFragment" f@(etaReds -> Just (_, o))) x) = ((Just f, tyOf o), x) --getFragmentShader (A2 "map" (EtaPrim2 "mapFragment" f) x) = error $ "gff: " ++ ppShow f --getFragmentShader x = error $ "gf: " ++ ppShow x getFragmentShader x = ((Nothing, getPrim'' $ tyOf x), x) +getPrim :: ExpTV -> ExpTV getPrim (A1 "List" (A2 "Primitive" _ p)) = p +getPrim' :: ExpTV -> ExpTV getPrim' (A1 "List" (A2 "Primitive" a _)) = a +getPrim'' :: ExpTV -> ExpTV getPrim'' (A1 "List" (A2 "Vector" _ (A1 "Maybe" (A1 "SimpleFragment" (TTuple [a]))))) = a getPrim'' x = error $ "getPrim'':" ++ ppShow x +compFrameBuffer :: ExpTV -> IR.ClearImage compFrameBuffer = \case A1 "DepthImage" a -> IR.ClearImage IR.Depth $ compValue a A1 "ColorImage" a -> IR.ClearImage IR.Color $ compValue a x -> error $ "compFrameBuffer " ++ ppShow x +compList :: ExpTV -> [ExpTV] compList (A2 ":" a x) = a : compList x compList (A0 "Nil") = [] compList x = error $ "compList: " ++ ppShow x +compFilter :: ExpTV -> IR.Filter compFilter = \case A0 "PointFilter" -> IR.Nearest A0 "LinearFilter" -> IR.Linear x -> error $ "compFilter: " ++ ppShow x +compEdgeMode :: ExpTV -> IR.EdgeMode compEdgeMode = \case A0 "Repeat" -> IR.Repeat A0 "MirroredRepeat" -> IR.MirroredRepeat A0 "ClampToEdge" -> IR.ClampToEdge x -> error $ "compEdgeMode: " ++ ppShow x +compSemantic :: ExpTV -> IR.ImageSemantic compSemantic = \case A0 "Depth" -> IR.Depth A0 "Stencil" -> IR.Stencil @@ -338,14 +374,17 @@ compImageInputType = \case _ -> error $ "Unexpected color image element type: " <> ppShow c x -> error $ "compImageType: " ++ ppShow x +compAC :: ExpTV -> IR.AccumulationContext compAC (ETuple x) = IR.AccumulationContext Nothing $ map compFrag x +compBlending :: ExpTV -> IR.Blending compBlending x = case x of A0 "NoBlending" -> IR.NoBlending A1 "BlendLogicOp" a -> IR.BlendLogicOp (compLO a) A3 "Blend" (ETuple [a,b]) (ETuple [ETuple [c,d],ETuple [e,f]]) (compValue -> IR.VV4F g) -> IR.Blend (compBE a) (compBE b) (compBF c) (compBF d) (compBF e) (compBF f) g x -> error $ "compBlending " ++ ppShow x +compBF :: ExpTV -> IR.BlendingFactor compBF x = case x of A0 "ZeroBF" -> IR.Zero A0 "OneBF" -> IR.One @@ -364,6 +403,7 @@ compBF x = case x of A0 "SrcAlphaSaturate" -> IR.SrcAlphaSaturate x -> error $ "compBF " ++ ppShow x +compBE :: ExpTV -> IR.BlendEquation compBE x = case x of A0 "FuncAdd" -> IR.FuncAdd A0 "FuncSubtract" -> IR.FuncSubtract @@ -372,6 +412,7 @@ compBE x = case x of A0 "Max" -> IR.Max x -> error $ "compBE " ++ ppShow x +compLO :: ExpTV -> IR.LogicOperation compLO x = case x of A0 "Clear" -> IR.Clear A0 "And" -> IR.And @@ -391,6 +432,7 @@ compLO x = case x of A0 "Set" -> IR.Set x -> error $ "compLO " ++ ppShow x +compComparisonFunction :: ExpTV -> IR.ComparisonFunction compComparisonFunction x = case x of A0 "Never" -> IR.Never A0 "Less" -> IR.Less @@ -404,19 +446,24 @@ compComparisonFunction x = case x of pattern EBool a <- (compBool -> Just a) +compBool :: ExpTV -> Maybe Bool compBool x = case x of A0 "True" -> Just True A0 "False" -> Just False x -> Nothing +compFrag :: ExpTV -> IR.FragmentOperation compFrag x = case x of A2 "DepthOp" (compComparisonFunction -> a) (EBool b) -> IR.DepthOp a b A2 "ColorOp" (compBlending -> b) (compValue -> v) -> IR.ColorOp b v x -> error $ "compFrag " ++ ppShow x +toGLSLType :: IsString p => [Char] -> ExpTV -> p toGLSLType msg x = showGLSLType msg $ compInputType msg x -- move to lambdacube-ir? +showGLSLType :: IsString p => + [Char] -> IR.InputType -> p showGLSLType msg = \case IR.Bool -> "bool" IR.Word -> "uint" @@ -446,6 +493,7 @@ showGLSLType msg = \case IR.FTexture2D -> "sampler2D" t -> error $ "toGLSLType: " ++ msg ++ " " ++ show t +supType :: ExpTV -> Bool supType = isJust . compInputType_ compInputType_ :: ExpTV -> Maybe IR.InputType @@ -477,12 +525,16 @@ compInputType_ x = case x of TMat 4 4 TFloat -> Just IR.M44F _ -> Nothing +compInputType :: [Char] -> ExpTV -> IR.InputType compInputType msg x = fromMaybe (error $ "compInputType " ++ msg ++ " " ++ ppShow x) $ compInputType_ x +is234 :: Integer -> Bool is234 = (`elem` [2,3,4]) -compInputType'' (ETuple attrs) = map compAttribute attrs +compInputType'' :: ExpTV -> [(String, IR.InputType)] +compInputType'' (ETuple attrs) = map compAttribute attrs -- pattern fail. +compAttribute :: ExpTV -> (String, IR.InputType) compAttribute = \case x@(A1 "Attribute" (EString s)) -> (s, compInputType "compAttr" $ tyOf x) x -> error $ "compAttribute " ++ ppShow x @@ -510,6 +562,7 @@ compAttributeValue (ETuple x) = checkLength $ map go x where (A1 "List" (compInputType "compAV" -> t)) = tyOf a values = map compValue $ compList a +compFetchPrimitive :: ExpTV -> IR.FetchPrimitive compFetchPrimitive x = case x of A0 "Point" -> IR.Points A0 "Line" -> IR.Lines @@ -533,52 +586,62 @@ compValue x = case x of A4 "V4" (EBool a) (EBool b) (EBool c) (EBool d) -> IR.VV4B $ IR.V4 a b c d x -> error $ "compValue " ++ ppShow x +compRC :: ExpTV -> IR.RasterContext compRC x = case x of A3 "PointCtx" a (EFloat b) c -> IR.PointCtx (compPS a) (realToFrac b) (compPSCO c) A2 "LineCtx" (EFloat a) b -> IR.LineCtx (realToFrac a) (compPV b) A4 "TriangleCtx" a b c d -> IR.TriangleCtx (compCM a) (compPM b) (compPO c) (compPV d) x -> error $ "compRC " ++ ppShow x +compRC' :: ExpTV -> Maybe ExpTV compRC' x = case x of A3 "PointCtx" a _ _ -> compPS' a A4 "TriangleCtx" _ b _ _ -> compPM' b x -> Nothing +compPSCO :: ExpTV -> IR.PointSpriteCoordOrigin compPSCO x = case x of A0 "LowerLeft" -> IR.LowerLeft A0 "UpperLeft" -> IR.UpperLeft x -> error $ "compPSCO " ++ ppShow x +compCM :: ExpTV -> IR.CullMode compCM x = case x of A0 "CullNone" -> IR.CullNone A0 "CullFront" -> IR.CullFront IR.CCW A0 "CullBack" -> IR.CullBack IR.CCW x -> error $ "compCM " ++ ppShow x +compPM :: ExpTV -> IR.PolygonMode compPM x = case x of A0 "PolygonFill" -> IR.PolygonFill A1 "PolygonLine" (EFloat a) -> IR.PolygonLine $ realToFrac a A1 "PolygonPoint" a -> IR.PolygonPoint $ compPS a x -> error $ "compPM " ++ ppShow x +compPM' :: ExpTV -> Maybe ExpTV compPM' x = case x of A1 "PolygonPoint" a -> compPS' a x -> Nothing +compPS :: ExpTV -> IR.PointSize compPS x = case x of A1 "PointSize" (EFloat a) -> IR.PointSize $ realToFrac a A1 "ProgramPointSize" _ -> IR.ProgramPointSize x -> error $ "compPS " ++ ppShow x +compPS' :: ExpTV -> Maybe ExpTV compPS' x = case x of A1 "ProgramPointSize" x -> Just x x -> Nothing +compPO :: ExpTV -> IR.PolygonOffset compPO x = case x of A2 "Offset" (EFloat a) (EFloat b) -> IR.Offset (realToFrac a) (realToFrac b) A0 "NoOffset" -> IR.NoOffset x -> error $ "compPO " ++ ppShow x +compPV :: ExpTV -> IR.ProvokingVertex compPV x = case x of A0 "FirstVertex" -> IR.FirstVertex A0 "LastVertex" -> IR.LastVertex @@ -741,8 +804,10 @@ data Uniform type Uniforms = Map String (Uniform, IR.InputType) +tellUniform :: (MonadWriter (a, b) m, Monoid b) => a -> m () tellUniform x = tell (x, mempty) +simpleExpr :: ExpTV -> Bool simpleExpr = \case Con cn xs -> case cn of "Uniform" -> True @@ -944,8 +1009,10 @@ type Ty = ExpTV tyOf :: ExpTV -> Ty tyOf (ExpTV _ t vs) = t .@ vs +expOf :: ExpTV -> I.Exp expOf (ExpTV x _ _) = x +mapVal :: (I.Exp -> I.Exp) -> ExpTV -> ExpTV mapVal f (ExpTV a b c) = ExpTV (f a) b c toExp :: I.ExpType -> ExpTV @@ -964,18 +1031,23 @@ pattern EString s <- ELit (LString s) pattern EFloat s <- ELit (LFloat s) pattern EInt s <- ELit (LInt s) +(.@) :: I.Exp -> [I.Exp] -> ExpTV t .@ vs = ExpTV t I.TType vs infix 1 .@ +mkVar :: ExpTV -> Maybe (Int, ExpTV) mkVar (ExpTV (I.Var i) t vs) = Just (i, t .@ vs) mkVar _ = Nothing +mkPi :: ExpTV -> Maybe (Visibility, ExpTV, ExpTV) mkPi (ExpTV (I.Pi b x y) _ vs) = Just (b, x .@ vs, y .@ addToEnv x vs) mkPi _ = Nothing +mkLam :: ExpTV -> Maybe (Visibility, ExpTV, ExpTV) mkLam (ExpTV (I.Lam y) (I.Pi b x yt) vs) = Just (b, x .@ vs, ExpTV y yt $ addToEnv x vs) mkLam _ = Nothing +mkCon :: ExpTV -> Maybe (SName, [ExpTV]) mkCon (ExpTV (I.Con s n (reverse -> xs)) et vs) = Just (untick $ show s, chain vs (I.conType et s) $ I.mkConPars n et ++ xs) mkCon (ExpTV (I.TyCon s (reverse -> xs)) et vs) = Just (untick $ show s, chain vs (nType s) xs) mkCon (ExpTV (I.Neut (I.Fun s@(I.FunName _ loc _{-I.DeltaDef{}-} _) (reverse -> xs) def)) et vs) = Just (untick $ show s, drop loc $ chain vs (nType s) xs) @@ -983,14 +1055,17 @@ mkCon (ExpTV (I.CaseFun s xs n) et vs) = Just (untick $ show s, chain vs (nType mkCon (ExpTV (I.TyCaseFun s [m, t, f] n) et vs) = Just (untick $ show s, chain vs (nType s) [m, t, I.Neut n, f]) mkCon _ = Nothing +mkApp :: ExpTV -> Maybe (ExpTV, ExpTV) mkApp (ExpTV (I.Neut (I.App_ a b)) et vs) = Just (ExpTV (I.Neut a) t vs, head $ chain vs t [b]) where t = neutType' (mkEnv vs) a mkApp _ = Nothing +removeRHS :: (Num t, Ord t) => t -> I.Exp -> Maybe I.Exp removeRHS 0 (I.RHS x) = Just x removeRHS n (I.Lam x) | n > 0 = I.Lam <$> removeRHS (n-1) x removeRHS _ _ = Nothing +mkFunc :: ExpTV -> Maybe ([Char], ExpTV, Ty, [ExpTV]) mkFunc r@(ExpTV (I.Neut (I.Fun (I.FunName (show -> n) loc (I.ExpDef def_) nt) xs I.RHS{})) ty vs) | Just def <- removeRHS (length xs) def_ , all (supType . tyOf) (r: xs') && n `notElem` ["typeAnn"] && all validChar n @@ -1015,19 +1090,24 @@ mkFunc r@(ExpTV (I.Neut (I.Fun (I.FunName (show -> n) loc (I.ExpDef def_) nt) xs -} mkFunc _ = Nothing +chain :: [I.Exp] -> I.Exp -> [I.Exp] -> [ExpTV] chain vs t@(I.Pi Hidden at y) (a: as) = chain vs (I.appTy t a) as chain vs t xs = map snd $ chain' vs t xs +chain' :: [I.Exp] -> I.Exp -> [I.Exp] -> [(Visibility, ExpTV)] chain' vs t [] = [] chain' vs t@(I.Pi b at y) (a: as) = (b, ExpTV a at vs): chain' vs (I.appTy t a) as chain' vs t _ = error $ "chain: " ++ ppShow t +mkTVar :: Int -> ExpTV -> ExpTV mkTVar i (ExpTV t _ vs) = ExpTV (I.Var i) t vs +unLab' :: I.Exp -> I.Exp unLab' (I.Reduced x) = unLab' x unLab' (I.RHS x) = unLab' x -- TODO: remove unLab' x = x +unFunc' :: I.Exp -> I.Exp unFunc' (I.Reduced x) = unFunc' x -- todo: remove? unFunc' (I.Neut (I.Fun (I.FunName _ _ I.ExpDef{} _) _ y)) = unFunc' y unFunc' (I.RHS x) = unFunc' x -- TODO: remove @@ -1036,7 +1116,9 @@ unFunc' x = x instance Subst I.Exp ExpTV where subst_ i0 dx x (ExpTV a at vs) = ExpTV (subst_ i0 dx x a) (subst_ i0 dx x at) (zipWith (\i -> subst_ (i0+i) (I.shiftFreeVars i dx) $ up i x{-todo: review-}) [1..] vs) +addToEnv :: a -> [a] -> [a] addToEnv x xs = x: xs +mkEnv :: Rearrange c => [c] -> [c] mkEnv xs = {-trace_ ("mk " ++ show (length xs)) $ -} zipWith up [1..] xs instance HasFreeVars ExpTV where @@ -1045,15 +1127,18 @@ instance HasFreeVars ExpTV where instance PShow ExpTV where pShow (ExpTV x t _) = pShow (x, t) +isSampler :: I.Exp -> Bool isSampler (I.TyCon n _) = show n == "'Sampler" isSampler _ = False -------------------------------------------------------------------------------- ExpTV conversion -- TODO: remove +removeLams :: (Eq t, Num t) => t -> ExpTV -> ExpTV removeLams 0 x = x removeLams i (ELam _ x) = removeLams (i-1) x removeLams i (Lam Hidden _ x) = removeLams i x +etaReds :: ExpTV -> Maybe ([ExpTV], ExpTV) etaReds (ELam _ (App (down 0 -> Just f) (EVar 0))) = etaReds f etaReds (ELam _ (hlistLam -> x@Just{})) = x etaReds (ELam p i) = Just ([p], i) @@ -1064,6 +1149,8 @@ hlistLam (A3 "hlistNilCase" _ (down 0 -> Just x) (EVar 0)) = Just ([], x) hlistLam (A3 "hlistConsCase" _ (down 0 -> Just (getPats 2 -> Just ([p, px], x))) (EVar 0)) = first (p:) <$> hlistLam x hlistLam _ = Nothing +getPats :: (Eq a, Num a, Show a) => + a -> ExpTV -> Maybe ([ExpTV], ExpTV) getPats 0 e = Just ([], e) getPats i (ELam p e) = first (p:) <$> getPats (i-1) e getPats i (Lam Hidden p (down 0 -> Just e)) = getPats i e @@ -1076,12 +1163,15 @@ pattern EtaPrim4 s x1 x2 x3 <- (getEtaPrim -> Just (s, [x1, x2, x3])) pattern EtaPrim5 s x1 x2 x3 x4 <- (getEtaPrim -> Just (s, [x1, x2, x3, x4])) pattern EtaPrim2_2 s <- (getEtaPrim2 -> Just (s, [])) +getEtaPrim :: ExpTV -> Maybe (SName, [ExpTV]) getEtaPrim (ELam _ (Con s (initLast -> Just (traverse (down 0) -> Just xs, EVar 0)))) = Just (s, xs) getEtaPrim _ = Nothing +getEtaPrim2 :: ExpTV -> Maybe (SName, [ExpTV]) getEtaPrim2 (ELam _ (ELam _ (Con s (initLast -> Just (initLast -> Just (traverse (down 0) -> Just (traverse (down 0) -> Just xs), EVar 0), EVar 0))))) = Just (s, xs) getEtaPrim2 _ = Nothing +initLast :: [b] -> Maybe ([b], b) initLast [] = Nothing initLast xs = Just (init xs, last xs) @@ -1117,9 +1207,11 @@ fromNat _ = Nothing pattern TTuple xs <- (getTTuple -> Just xs) pattern ETuple xs <- (getTuple -> Just xs) +getTTuple :: ExpTV -> Maybe [ExpTV] getTTuple (A1 "HList" l) = Just $ compList l getTTuple _ = Nothing +getTuple :: ExpTV -> Maybe [ExpTV] getTuple (A0 "HNil") = Just [] getTuple (A2 "HCons" x (getTuple -> Just xs)) = Just (x: xs) getTuple _ = Nothing @@ -1308,6 +1400,14 @@ genHLSL dns e = case e of showSwizzProj x a = parens a <> "." <> text x +genHLSLs :: Traversable t => + Backend + -> t ExpTV + -> ExpTV + -> (Maybe ExpTV, ExpTV) + -> (Maybe ExpTV, ExpTV) + -> Maybe ExpTV + -> ([[Char]], Uniforms, Doc, Doc) genHLSLs backend rp -- program point size (ETuple ints) -- interpolations @@ -1453,9 +1553,12 @@ genHLSLs backend shaderDecl a b c = shaderDecl' (a <+> b) c shaderDecl' b c = shaderStmt $ b <+> c +toHLSLType :: IsString p => [Char] -> ExpTV -> p toHLSLType msg x = showHLSLType msg $ compInputType msg x -- move to lambdacube-ir? +showHLSLType :: IsString p => + [Char] -> IR.InputType -> p showHLSLType msg = \case IR.Bool -> "bool" IR.Word -> "uint" -- cgit v1.2.3