diff --git a/BiMap.hs b/BiMap.hs new file mode 100644 --- /dev/null +++ b/BiMap.hs @@ -0,0 +1,54 @@ +-- Establishing a bijection between the values of the type a and integers, with +-- the operations to retrieve the value given its key, +-- to find the key for the existing value, and to extend the +-- bijection with a new association. + +-- The type 'a' of values should at least permit equality comparison; +-- In the present implementation, we require 'a' to be a member +-- of Ord. + +-- There are many ways to implement bi-maps, for example, using hash tables, +-- or maps. +-- Our implementation uses Data.Map and Data.IntMap to record +-- both parts of the association. + +module BiMap ( + BiMap(..), empty, + lookup_key, + lookup_val, + insert, + size, + ) + where + +import qualified Data.Map as M +import qualified Data.IntMap as IM + +data BiMap a = BiMap (M.Map a Int) (IM.IntMap a) + +-- Find a key for a value +lookup_key :: Ord a => a -> BiMap a -> Maybe Int +lookup_key v (BiMap m _) = M.lookup v m + +-- Find a value for a key +lookup_val :: Int -> BiMap a -> a +lookup_val k (BiMap _ m) = m IM.! k + +-- Insert the value and return the corresponding key +-- and the new map +-- Alas, Map interface does not have an operation to insert and find the index +-- at the same time (although such an operation is easily possible) +insert :: Ord a => a -> BiMap a -> (Int, BiMap a) +insert v (BiMap m im) = (k, BiMap m' im') + where m' = M.insert v k m + im' = IM.insert k v im + k = IM.size im + +empty :: BiMap a +empty = BiMap (M.empty) (IM.empty) + +instance Show a => Show (BiMap a) where + show (BiMap _ m) = "BiMap" ++ show (IM.toList m) + +size :: BiMap a -> Int +size (BiMap _ m) = IM.size m diff --git a/LC_API.hs b/LC_API.hs new file mode 100644 --- /dev/null +++ b/LC_API.hs @@ -0,0 +1,240 @@ +module LC_API ( + -- language + module LC_G_Type, + module LC_G_APIType, + module LC_T_APIType, + module LC_T_DSLType, + module LC_T_HOAS, + module LC_T_Language, + Int32, + Word32, + uniformBool, + uniformV2B, + uniformV3B, + uniformV4B, + + uniformWord, + uniformV2U, + uniformV3U, + uniformV4U, + + uniformInt, + uniformV2I, + uniformV3I, + uniformV4I, + + uniformFloat, + uniformV2F, + uniformV3F, + uniformV4F, + + uniformM22F, + uniformM23F, + uniformM24F, + uniformM32F, + uniformM33F, + uniformM34F, + uniformM42F, + uniformM43F, + uniformM44F, + + uniformFTexture2D, + + -- backend + Buffer, + compileBuffer, + updateBuffer, + bufferSize, + arraySize, + arrayType, + + Renderer, + compileRenderer, + slotUniform, + slotStream, + uniformSetter, + render, + dispose, + setScreenSize, + + Object, + addObject, + removeObject, + objectUniformSetter, + enableObject, + + -- texture (temporary) + compileTexture2DRGBAF +) where + +import Data.Int +import Data.Word + +import LC_G_APIType hiding (InputType(..)) +import LC_G_Type + +import LC_T_APIType +import LC_T_DSLType hiding (Buffer,Shadow) +import LC_T_HOAS +import LC_T_Language +import qualified LC_T_APIType as H +import qualified LC_T_HOAS as H + +import qualified LC_U_DeBruijn as U +import LC_C_Convert + +import LC_B_GL hiding (compileRenderer) +import LC_B_GLCompile +import LC_B_GLData +import LC_B_GLType +import LC_B_GLUtil (Buffer) +import qualified LC_B_GL as GL + +import Control.Monad.State +import Data.ByteString.Char8 (ByteString) +import Data.ByteString.Char8 as SB +import Data.Trie as T + +compileRenderer :: H.GPOutput H.SingleOutput -> IO Renderer +compileRenderer l = GL.compileRenderer dag $ U.toExp dag l' + where + (l', dag) = runState (U.unN $ convertGPOutput l) U.emptyDAG + +nullSetter :: ByteString -> String -> a -> IO () +nullSetter n t _ = Prelude.putStrLn $ "WARNING: unknown uniform: " ++ SB.unpack n ++ " :: " ++ t + +uniformBool :: ByteString -> Trie InputSetter -> SetterFun Bool +uniformV2B :: ByteString -> Trie InputSetter -> SetterFun V2B +uniformV3B :: ByteString -> Trie InputSetter -> SetterFun V3B +uniformV4B :: ByteString -> Trie InputSetter -> SetterFun V4B + +uniformWord :: ByteString -> Trie InputSetter -> SetterFun Word32 +uniformV2U :: ByteString -> Trie InputSetter -> SetterFun V2U +uniformV3U :: ByteString -> Trie InputSetter -> SetterFun V3U +uniformV4U :: ByteString -> Trie InputSetter -> SetterFun V4U + +uniformInt :: ByteString -> Trie InputSetter -> SetterFun Int32 +uniformV2I :: ByteString -> Trie InputSetter -> SetterFun V2I +uniformV3I :: ByteString -> Trie InputSetter -> SetterFun V3I +uniformV4I :: ByteString -> Trie InputSetter -> SetterFun V4I + +uniformFloat :: ByteString -> Trie InputSetter -> SetterFun Float +uniformV2F :: ByteString -> Trie InputSetter -> SetterFun V2F +uniformV3F :: ByteString -> Trie InputSetter -> SetterFun V3F +uniformV4F :: ByteString -> Trie InputSetter -> SetterFun V4F + +uniformM22F :: ByteString -> Trie InputSetter -> SetterFun M22F +uniformM23F :: ByteString -> Trie InputSetter -> SetterFun M23F +uniformM24F :: ByteString -> Trie InputSetter -> SetterFun M24F +uniformM32F :: ByteString -> Trie InputSetter -> SetterFun M32F +uniformM33F :: ByteString -> Trie InputSetter -> SetterFun M33F +uniformM34F :: ByteString -> Trie InputSetter -> SetterFun M34F +uniformM42F :: ByteString -> Trie InputSetter -> SetterFun M42F +uniformM43F :: ByteString -> Trie InputSetter -> SetterFun M43F +uniformM44F :: ByteString -> Trie InputSetter -> SetterFun M44F + +uniformFTexture2D :: ByteString -> Trie InputSetter -> SetterFun TextureData + +uniformBool n is = case T.lookup n is of + Just (SBool fun) -> fun + _ -> nullSetter n "Bool" + +uniformV2B n is = case T.lookup n is of + Just (SV2B fun) -> fun + _ -> nullSetter n "V2B" + +uniformV3B n is = case T.lookup n is of + Just (SV3B fun) -> fun + _ -> nullSetter n "V3B" + +uniformV4B n is = case T.lookup n is of + Just (SV4B fun) -> fun + _ -> nullSetter n "V4B" + +uniformWord n is = case T.lookup n is of + Just (SWord fun) -> fun + _ -> nullSetter n "Word" + +uniformV2U n is = case T.lookup n is of + Just (SV2U fun) -> fun + _ -> nullSetter n "V2U" + +uniformV3U n is = case T.lookup n is of + Just (SV3U fun) -> fun + _ -> nullSetter n "V3U" + +uniformV4U n is = case T.lookup n is of + Just (SV4U fun) -> fun + _ -> nullSetter n "V4U" + +uniformInt n is = case T.lookup n is of + Just (SInt fun) -> fun + _ -> nullSetter n "Int" + +uniformV2I n is = case T.lookup n is of + Just (SV2I fun) -> fun + _ -> nullSetter n "V2I" + +uniformV3I n is = case T.lookup n is of + Just (SV3I fun) -> fun + _ -> nullSetter n "V3I" + +uniformV4I n is = case T.lookup n is of + Just (SV4I fun) -> fun + _ -> nullSetter n "V4I" + +uniformFloat n is = case T.lookup n is of + Just (SFloat fun) -> fun + _ -> nullSetter n "Float" + +uniformV2F n is = case T.lookup n is of + Just (SV2F fun) -> fun + _ -> nullSetter n "V2F" + +uniformV3F n is = case T.lookup n is of + Just (SV3F fun) -> fun + _ -> nullSetter n "V3F" + +uniformV4F n is = case T.lookup n is of + Just (SV4F fun) -> fun + _ -> nullSetter n "V4F" + +uniformM22F n is = case T.lookup n is of + Just (SM22F fun) -> fun + _ -> nullSetter n "M22F" + +uniformM23F n is = case T.lookup n is of + Just (SM23F fun) -> fun + _ -> nullSetter n "M23F" + +uniformM24F n is = case T.lookup n is of + Just (SM24F fun) -> fun + _ -> nullSetter n "M24F" + +uniformM32F n is = case T.lookup n is of + Just (SM32F fun) -> fun + _ -> nullSetter n "M32F" + +uniformM33F n is = case T.lookup n is of + Just (SM33F fun) -> fun + _ -> nullSetter n "M33F" + +uniformM34F n is = case T.lookup n is of + Just (SM34F fun) -> fun + _ -> nullSetter n "M34F" + +uniformM42F n is = case T.lookup n is of + Just (SM42F fun) -> fun + _ -> nullSetter n "M42F" + +uniformM43F n is = case T.lookup n is of + Just (SM43F fun) -> fun + _ -> nullSetter n "M43F" + +uniformM44F n is = case T.lookup n is of + Just (SM44F fun) -> fun + _ -> nullSetter n "M44F" + +uniformFTexture2D n is = case T.lookup n is of + Just (SFTexture2D fun) -> fun + _ -> nullSetter n "FTexture2D" diff --git a/LC_B_GL.hs b/LC_B_GL.hs new file mode 100644 --- /dev/null +++ b/LC_B_GL.hs @@ -0,0 +1,385 @@ +module LC_B_GL where + +import Debug.Trace + +import Control.Applicative +import Control.Monad +import Data.ByteString.Char8 (ByteString) +import Data.IORef +import Data.List as L +import Data.Maybe +import Data.Set (Set) +import Data.Map (Map) +import Data.Trie as T +import Foreign +import qualified Data.ByteString.Char8 as SB +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Traversable as T +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed.Mutable as MV + +import Graphics.Rendering.OpenGL.Raw.Core32 + ( GLuint + -- FRAMEBUFFER related * + -- create + , glBindFramebuffer + , glDeleteFramebuffers + , glGenFramebuffers + -- content manipulation + , glActiveTexture + , glBindRenderbuffer + , glBindTexture + , glDeleteTextures + , glDrawBuffer + , glDrawBuffers + , glFramebufferRenderbuffer + , glFramebufferTexture + , glFramebufferTexture2D + , glGenRenderbuffers + , glRenderbufferStorage + , glViewport + , gl_BACK_LEFT + , gl_COLOR_ATTACHMENT0 + , gl_DEPTH_ATTACHMENT + , gl_DEPTH_COMPONENT32 + , gl_DRAW_FRAMEBUFFER + , gl_MAX_COMBINED_TEXTURE_IMAGE_UNITS + , gl_NONE + , gl_RENDERBUFFER + , gl_TEXTURE0 + , gl_TEXTURE_2D + , gl_UNSIGNED_BYTE + , glTexImage2D + , gl_TEXTURE_2D_ARRAY + , glTexImage3D + , gl_TEXTURE_MAX_LEVEL + , glTexParameteri + , gl_TEXTURE_BASE_LEVEL + , gl_NEAREST + , gl_TEXTURE_MIN_FILTER + , gl_TEXTURE_MAG_FILTER + , gl_CLAMP_TO_EDGE + , gl_TEXTURE_WRAP_S + , gl_TEXTURE_WRAP_T + , gl_DEPTH_COMPONENT32 + , gl_DEPTH_COMPONENT + , glGenTextures + ) + +import LC_G_Type +import LC_G_APIType +import LC_U_APIType +import LC_U_DeBruijn + +import LC_B_GLType +import LC_B_GLUtil +import LC_B_GLSLCodeGen +import LC_B_Traversals +import LC_B_GLCompile + +-- Renderer + +nubS :: Ord a => [a] -> [a] +nubS = Set.toList . Set.fromList + +findFetch :: DAG -> Exp -> Maybe Exp +findFetch dag f = listToMaybe [a | a@Fetch {} <- drawOperations dag f] + +-- odered according pass dependency (topology order) +orderedFrameBuffersFromGP :: DAG -> Exp -> [Exp] +orderedFrameBuffersFromGP dag orig = order deps + where + deps :: Map Exp (Set Exp) + deps = add Map.empty $ findFrameBuffer dag orig + + add :: Map Exp (Set Exp) -> Exp -> Map Exp (Set Exp) + add m fb = Map.unionsWith Set.union $ m' : map (add m') fbl + where + m' = Map.alter fun fb m + fbl = concat [map (findFrameBuffer dag . toExp dag) l | Sampler _ _ tx <- concatMap (expUniverse' dag) (gpUniverse' dag fb), Texture _ _ _ l <- [toExp dag tx]] + fbs = Set.fromList fbl + fun Nothing = Just fbs + fun (Just a) = Just (a `Set.union` fbs) + + order :: Map Exp (Set Exp) -> [Exp] + order d + | Map.null d = [] + | otherwise = leaves ++ order (Map.map (Set.\\ (Set.fromList leaves)) hasDeps) + where + leaves = Map.keys noDeps + (noDeps,hasDeps) = Map.partition Set.null d + +printGLStatus = checkGL >>= print +printFBOStatus = checkFBO >>= print + +mkSlotDescriptor :: Set Exp -> IO SlotDescriptor +mkSlotDescriptor gps = SlotDescriptor gps <$> newIORef Set.empty + +mkRenderTextures :: DAG -> [Exp] -> IO (Map Exp String, Map Exp String, Map Exp GLuint, IO (), Exp -> [Exp]) +mkRenderTextures dag allGPs = do + let samplers = nubS [s | s@Sampler {} <- expUniverse' dag allGPs] + samplersWithTexture = nubS [s | s@(Sampler _ _ tx) <- samplers, Texture {} <- [toExp dag tx]] + -- collect all render textures refers to a FrameBuffer + isReferred :: Exp -> Exp -> Bool + isReferred f (Sampler _ _ tx) = findFrameBuffer dag (toExp dag f') == f + where + Texture _ _ _ [f'] = toExp dag tx + isReferred _ _ = False + dependentSamplers f = filter (isReferred f) samplersWithTexture + -- texture attributes: GL texture target (1D,2D,etc), arity, float/word/int, size, mipmap + -- sampler attributes: filter, edge mode + -- TODO: also build sampler name map: Map (Exp :: Sampler) (ByteString, GLTexObj) + + -- question: how should we handle the Stencil and Depth textures at multipass rendering + (renderTexNameList,renderTexGLObjList,disposeTex) <- fmap unzip3 $ forM (zip [0..] samplersWithTexture) $ \(sIdx,smp) -> do + to <- createGLTextureObject dag smp + putStr (" -- Render Texture " ++ show sIdx ++ ": ") >> printGLStatus + return ((smp,"renderTex_" ++ show sIdx),(smp,to),with to $ \pto -> glDeleteTextures 1 pto) + let renderTexName = Map.fromList renderTexNameList + renderTexGLObj = Map.fromList renderTexGLObjList + texSlotName = Map.fromList $ nubS [(s,SB.unpack n) | s@(Sampler _ _ txExp) <- samplers, TextureSlot n _ <- [toExp dag txExp]] + return (texSlotName, renderTexName, renderTexGLObj, sequence_ disposeTex, dependentSamplers) + +mkRenderDescriptor :: DAG -> RenderState -> Map Exp String -> Map Exp String -> Map Exp GLuint -> Exp -> IO RenderDescriptor +mkRenderDescriptor dag rendState texSlotName renderTexName renderTexGLObj f = case f of + FrameBuffer imgs -> RenderDescriptor T.empty T.empty (compileClearFrameBuffer f) (return ()) <$> newIORef (ObjectSet (return ()) Map.empty) <*> pure (length [() | ColorImage {} <- imgs]) + Accumulate {} -> do + {- + setup texture input, before each slot's render operation we should setup texture unit mapping + - we have to create the TextureUnit layout + - create TextureUnit setter action + - the shader should be setup at the creation + - we have to setup texture binding before each render action call + -} + let usedRenderSamplers = nubS [s | s@(Sampler _ _ te) <- expUniverse' dag f, Texture {} <- [toExp dag te]] + usedSlotSamplers = nubS [s | s@(Sampler _ _ te) <- expUniverse' dag f, TextureSlot {} <- [toExp dag te]] + usedRenderTexName = [(s,n) | s <- usedRenderSamplers, let Just n = Map.lookup s renderTexName] + usedTexSlotName = [(s,n) | s <- usedSlotSamplers, let Just n = Map.lookup s texSlotName] + renderTexObjs = [txObj | s <- usedRenderSamplers, let Just txObj = Map.lookup s renderTexGLObj] + texUnitState = textureUnitState rendState + textureSetup = forM_ (zip renderTexObjs [0.. MV.length texUnitState-1]) $ \(texObj,texUnitIdx) -> do + let texObj' = fromIntegral texObj + curTexObj <- MV.read texUnitState texUnitIdx + when (curTexObj /= texObj') $ do + MV.write texUnitState texUnitIdx texObj' + glActiveTexture $ gl_TEXTURE0 + fromIntegral texUnitIdx + glBindTexture gl_TEXTURE_2D texObj + --putStr (" -- Texture bind (TexUnit " ++ show (texUnitIdx,texObj) ++ " TexObj): ") >> printGLStatus + + drawRef <- newIORef $ ObjectSet (return ()) Map.empty + (rA,dA,uT,sT,outColorCnt) <- compileRenderFrameBuffer dag usedRenderTexName usedTexSlotName drawRef f + return $ RenderDescriptor + { uniformLocation = uT + , streamLocation = sT + , renderAction = textureSetup >> rA + , disposeAction = dA + , drawObjectsIORef = drawRef + , fragmentOutCount = outColorCnt + } + _ -> error $ "GP node type error: should be FrameBuffer but got: " ++ (head $ words $ show f) + +-- FIXME: currently we expect ScreenOut to be the last operation +mkPassSetup :: IORef (Word,Word) -> DAG -> Map Exp GLuint -> (Exp -> [Exp]) -> (Bool,Int,Int) -> Exp -> IO (IO (), IO ()) +mkPassSetup screenSizeIORef dag renderTexGLObj dependentSamplers (isLast,outIdx,outCnt) fb = case isLast of + True -> do + putStrLn $ " -- last pass output count: " ++ show outCnt ++ " outIdx: " ++ show outIdx + let setup = do + (screenW,screenH) <- readIORef screenSizeIORef + glViewport 0 0 (fromIntegral screenW) (fromIntegral screenH) + glBindFramebuffer gl_DRAW_FRAMEBUFFER 0 + let fboMapping = [if i == outIdx then gl_BACK_LEFT else gl_NONE | i <- [1..outCnt]] + withArray fboMapping $ glDrawBuffers (fromIntegral $ length fboMapping) + --putStr " -- default FB bind: " >> printGLStatus + return (setup,return ()) + False -> do + -- setup each pass's FBO output, attach RenderTarget textures to source FBO + putStrLn " -- FBO init: " + + glFBO <- alloca $! \pbo -> glGenFramebuffers 1 pbo >> peek pbo + putStr " - alloc: " >> printGLStatus + glBindFramebuffer gl_DRAW_FRAMEBUFFER glFBO + putStr " - bind: " >> printGLStatus + let depSamplers = dependentSamplers fb + hasDepthOp = case fb of + Accumulate (AccumulationContext _ ops) _ _ _ _ -> not $ L.null [() | DepthOp {} <- ops] + FrameBuffer imgs -> not $ L.null [() | DepthImage {} <- imgs] + ---------- + -- FIXME: samplers must contain the fragment value's output index! + ---------- + (layerCnts,texSizes,fboMapping) <- fmap unzip3 $ forM (zip [0..] depSamplers) $ \(i,smp) -> do + let Sampler _ _ txExp = smp + Texture txType ts NoMip [prjFBExp] = toExp dag txExp + PrjFrameBuffer _ prjIdx _ = toExp dag prjFBExp + Just txObj = Map.lookup smp renderTexGLObj + colorNumber = outCnt - prjIdx - 1 + attachSingleLayer = glFramebufferTexture2D gl_DRAW_FRAMEBUFFER (gl_COLOR_ATTACHMENT0 + fromIntegral i) gl_TEXTURE_2D txObj 0 + attachMultiLayer = glFramebufferTexture gl_DRAW_FRAMEBUFFER (gl_COLOR_ATTACHMENT0 + fromIntegral i) txObj 0 + lc <- case txType of + Texture2D _ ln + | ln <= 1 -> attachSingleLayer >> return ln + | otherwise -> attachMultiLayer >> return ln + TextureCube _ -> attachMultiLayer >> return 6 + putStr (" - attach to color slot #" ++ show i ++ " texture object #" ++ show txObj ++ " with color number #" ++ show colorNumber ++ ": ") >> printGLStatus + return (lc, ts, (colorNumber,gl_COLOR_ATTACHMENT0 + fromIntegral i)) -- FIXME: calculate FBO attachment index properly, index reffered from right + let fboMappingMap = IntMap.fromList fboMapping + fboMappingList = [IntMap.findWithDefault gl_NONE i fboMappingMap | i <- [0..outCnt-1]] + withArray fboMappingList $ glDrawBuffers $ fromIntegral outCnt + putStrLn $ " - FBO mapping: " ++ show [if i == gl_NONE then "gl_NONE" else ("gl_COLOR_ATTACHMENT" ++ (show $ i - gl_COLOR_ATTACHMENT0)) | i <- fboMappingList] + putStr " - mappig setup: " >> printGLStatus + + -- check all texture size maches + unless (all (== head texSizes) texSizes) $ error ("Framebuffer attachment size mismatch! \n" ++ " - sizes: " ++ show texSizes) + -- create and attach depth buffer + let VV2U (V2 depthW depthH) = head texSizes + when hasDepthOp $ do + {- + depthTex <- alloca $! \pto -> glGenRenderbuffers 1 pto >> peek pto + putStr " - alloc depth texture: " >> printGLStatus + glBindRenderbuffer gl_RENDERBUFFER depthTex + putStr " - bind depth texture: " >> printGLStatus + glRenderbufferStorage gl_RENDERBUFFER gl_DEPTH_COMPONENT32 (fromIntegral depthW) (fromIntegral depthH) + putStr " - define depth texture: " >> printGLStatus + glFramebufferRenderbuffer gl_DRAW_FRAMEBUFFER gl_DEPTH_ATTACHMENT gl_RENDERBUFFER depthTex + putStr " - attach depth texture: " >> printGLStatus + -} + depthTex <- alloca $! \pto -> glGenTextures 1 pto >> peek pto + putStr " - alloc depth texture: " >> printGLStatus + let layerCnt = head layerCnts + txTarget = if layerCnt > 1 then gl_TEXTURE_2D_ARRAY else gl_TEXTURE_2D + internalFormat = fromIntegral gl_DEPTH_COMPONENT32 + dataFormat = fromIntegral gl_DEPTH_COMPONENT + glBindTexture txTarget depthTex + putStr " - bind depth texture: " >> printGLStatus + -- temp + glTexParameteri txTarget gl_TEXTURE_WRAP_S $ fromIntegral gl_CLAMP_TO_EDGE + glTexParameteri txTarget gl_TEXTURE_WRAP_T $ fromIntegral gl_CLAMP_TO_EDGE + glTexParameteri txTarget gl_TEXTURE_MAG_FILTER $ fromIntegral gl_NEAREST + glTexParameteri txTarget gl_TEXTURE_MIN_FILTER $ fromIntegral gl_NEAREST + glTexParameteri txTarget gl_TEXTURE_BASE_LEVEL 0 + glTexParameteri txTarget gl_TEXTURE_MAX_LEVEL 0 + -- temp end + case layerCnt > 1 of + True -> glTexImage3D gl_TEXTURE_2D_ARRAY 0 internalFormat (fromIntegral depthW) (fromIntegral depthH) (fromIntegral layerCnt) 0 dataFormat gl_UNSIGNED_BYTE nullPtr + False -> glTexImage2D gl_TEXTURE_2D 0 internalFormat (fromIntegral depthW) (fromIntegral depthH) 0 dataFormat gl_UNSIGNED_BYTE nullPtr + putStr " - define depth texture: " >> printGLStatus + case layerCnt > 1 of + True -> glFramebufferTexture gl_DRAW_FRAMEBUFFER gl_DEPTH_ATTACHMENT depthTex 0 + False -> glFramebufferTexture2D gl_DRAW_FRAMEBUFFER gl_DEPTH_ATTACHMENT gl_TEXTURE_2D depthTex 0 + putStr " - attach depth texture: " >> printGLStatus + + + putStr " - check FBO completeness: " >> printFBOStatus + + let renderAct = do + glBindFramebuffer gl_DRAW_FRAMEBUFFER glFBO + glViewport 0 0 (fromIntegral depthW) (fromIntegral depthH) + --putStr " -- FBO bind: " >> printGLStatus + --putStr " -- FBO status: " >> printFBOStatus + disposeAct = do + with glFBO $ \pbo -> glDeleteFramebuffers 1 pbo + --with depthTex $ \pto -> glDeleteTextures 1 pto + return (renderAct,disposeAct) + +mkRenderState :: IO RenderState +mkRenderState = do + maxTextureUnits <- glGetIntegerv1 gl_MAX_COMBINED_TEXTURE_IMAGE_UNITS + texUnitState <- MV.new $ fromIntegral maxTextureUnits + MV.set texUnitState (-1) + return $ RenderState + { textureUnitState = texUnitState + } +{- + Note: Input mapping problem + more programs use the same slot -> minimize vertex attribute mapping collisions (best case: use the same mapping) + more programs use the same uniform -> minimize uniform mapping collisions (best case: use the same mapping) +-} +-- FIXME: implement properly +compileRenderer :: DAG -> Exp -> IO Renderer +compileRenderer dag (ScreenOut img) = do + let PrjFrameBuffer n idx gpId = toExp dag img + gp = toExp dag gpId + unis :: Exp -> [(ByteString,InputType)] + unis fb = nubS [(name,t) | u@(Uni name) <- expUniverse' dag fb, let [t] = codeGenType $ expType dag u] ++ + nubS [(name,t) | s@(Sampler _ _ ts) <- expUniverse' dag fb + , TextureSlot name _ <- [toExp dag ts] + , let [t] = codeGenType $ expType dag s] + + ordFBs = orderedFrameBuffersFromGP dag gp + allGPs = nubS $ concatMap (gpUniverse' dag) ordFBs + + -- collect slot info: name, primitive type, stream input, uniform input + (slotStreamList, slotUniformList, slotGPList) = unzip3 + [ (T.singleton name (primType,T.fromList inputs) + ,T.singleton name (T.fromList $ unis fb) + ,T.singleton name (Set.singleton fb)) + | fb <- concatMap (renderChain dag) ordFBs + , Fetch name primType inputs <- maybeToList $ findFetch dag fb + ] + slotStreamTrie = foldl' (T.mergeBy (\(a1,a2) (b1,b2) -> Just (a1, T.unionL a2 b2))) T.empty slotStreamList + slotUniformTrie = foldl' (T.mergeBy (\a b -> Just (T.unionL a b))) T.empty slotUniformList + (uniformNames,uniformTypes) = unzip $ nubS $ concatMap (T.toList . snd) $ T.toList slotUniformTrie + + putStrLn $ "GP universe size: " ++ show (length allGPs) + putStrLn $ "Exp universe size: " ++ show (length (nubS $ expUniverse' dag gp)) + + -- create RenderState + rendState <- mkRenderState + + (uSetup,uSetter) <- unzip <$> mapM (mkUniformSetter rendState) uniformTypes + let uniformSetterTrie = T.fromList $! zip uniformNames uSetter + mkUniformSetupTrie = T.fromList $! zip uniformNames uSetup + + slotGP :: Trie (Set Exp) + slotGP = foldl' (T.mergeBy (\a b -> Just $ Set.union a b)) T.empty slotGPList + + -- create SlotDescriptors (input setup) + slotDescriptors <- T.fromList <$> mapM (\(n,a) -> (n,) <$> mkSlotDescriptor a) (T.toList slotGP) + + -- allocate render textures (output resource initialization) + (texSlotName,renderTexName,renderTexGLObj,renderTexDispose,dependentSamplers) <- mkRenderTextures dag allGPs + + -- create RenderDescriptors + renderDescriptors <- Map.fromList <$> mapM (\a -> (a,) <$> mkRenderDescriptor dag rendState texSlotName renderTexName renderTexGLObj a) (nubS $ concatMap (renderChain dag) ordFBs) + + -- create IORef for ScreenOut Size + screenSizeIORef <- newIORef (0,0) + + putStrLn ("number of passes: " ++ show (length ordFBs)) + -- join compiled graphics network components + (passRender,passDispose) <- fmap unzip $ forM (zip ordFBs [1..]) $ \(fb,passNo) -> do + let (drawList, disposeList) = unzip [(renderAction rd, disposeAction rd) | f <- renderChain dag fb, let Just rd = Map.lookup f renderDescriptors] + let Just rd = Map.lookup fb renderDescriptors + putStrLn ("pass #" ++ show passNo) + putStrLn (" - draw count: " ++ show (length drawList)) + (passSetup,passDispose) <- mkPassSetup screenSizeIORef dag renderTexGLObj dependentSamplers (fb == gp,fragmentOutCount rd - idx, fragmentOutCount rd) fb + return (passSetup >> sequence_ drawList, passDispose >> sequence_ disposeList) + + -- debug + putStrLn $ "number of passes: " ++ show (length ordFBs) ++ " is output the last? " ++ show (findFrameBuffer dag gp == last ordFBs) + + -- TODO: validate + -- all slot name should be unique + -- all uniform with same name have the same type + -- all stream input with same name have the same type + objIDSeed <- newIORef 1 + return $! Renderer + -- public + { slotUniform = slotUniformTrie + , slotStream = slotStreamTrie + , uniformSetter = uniformSetterTrie + , render = do + --print " * Frame Started" + sequence_ passRender + --print " * Frame Ended" + , dispose = renderTexDispose >> sequence_ passDispose + , setScreenSize = \w h -> writeIORef screenSizeIORef (w,h) + + -- internal + , mkUniformSetup = mkUniformSetupTrie + , slotDescriptor = slotDescriptors + , renderDescriptor = renderDescriptors + , renderState = rendState + , objectIDSeed = objIDSeed + } diff --git a/LC_B_GLCompile.hs b/LC_B_GLCompile.hs new file mode 100644 --- /dev/null +++ b/LC_B_GLCompile.hs @@ -0,0 +1,540 @@ +module LC_B_GLCompile where + +import Control.Applicative +import Control.Monad +import Data.ByteString.Char8 (ByteString) +import Data.IORef +import Data.List as L +import Data.Maybe +import Data.Set (Set) +import Data.Map (Map) +import Data.Trie as T +import Foreign +import qualified Data.ByteString.Char8 as SB +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Data.Traversable as T +import qualified Data.Vector as V + +import Graphics.Rendering.OpenGL.Raw.Core32 + ( GLboolean + , GLenum + , GLint + , GLuint + , glDisable + , glEnable + , gl_TRUE + + -- SHADER PROGRAM related * + , glAttachShader + , glBindFragDataLocation + , glCreateProgram + , glCreateShader + , glDeleteProgram + , glDeleteShader + , glLinkProgram + , glUseProgram + , gl_FRAGMENT_SHADER + , gl_GEOMETRY_SHADER + , gl_LINK_STATUS + , gl_VERTEX_SHADER + + -- ACCUMULATION CONTEXT related * + -- blending + , glBlendColor + , glBlendEquationSeparate + , glBlendFuncSeparate + , gl_BLEND + -- logic operation + , glLogicOp + , gl_COLOR_LOGIC_OP + -- framebuffer related + , glClear + , glClearColor + , glClearDepth + , glColorMask + , gl_COLOR_BUFFER_BIT + , gl_DEPTH_BUFFER_BIT + -- depth and stencil filter functions + , glDepthFunc + , glDepthMask + , gl_DEPTH_TEST + , gl_STENCIL_TEST + + -- RASTER CONTEXT related * + , glProvokingVertex + , gl_FIRST_VERTEX_CONVENTION + , gl_LAST_VERTEX_CONVENTION + -- point + , glPointParameterf + , glPointSize + , gl_LOWER_LEFT + , gl_POINT_FADE_THRESHOLD_SIZE + , gl_POINT_SPRITE_COORD_ORIGIN + , gl_PROGRAM_POINT_SIZE + , gl_UPPER_LEFT + -- line + , glLineWidth + -- triangle + , glCullFace + , glFrontFace + , glPolygonMode + , glPolygonOffset + , gl_BACK + , gl_CCW + , gl_CULL_FACE + , gl_CW + , gl_FILL + , gl_FRONT + , gl_FRONT_AND_BACK + , gl_LINE + , gl_POINT + , gl_POLYGON_OFFSET_FILL + , gl_POLYGON_OFFSET_LINE + , gl_POLYGON_OFFSET_POINT + ) + +import LC_G_Type +import LC_G_APIType +import LC_U_APIType +import LC_U_DeBruijn + +import LC_B_GLType +import LC_B_GLUtil +import LC_B_GLSLCodeGen +import LC_B_Traversals + +data ShaderSource + = VertexShaderSrc !ByteString + | GeometryShaderSrc !ByteString + | FragmentShaderSrc !ByteString + +setupRasterContext :: RasterContext -> IO () +setupRasterContext = cvt + where + cff :: FrontFace -> GLenum + cff CCW = gl_CCW + cff CW = gl_CW + + setProvokingVertex :: ProvokingVertex -> IO () + setProvokingVertex pv = glProvokingVertex $ case pv of + FirstVertex -> gl_FIRST_VERTEX_CONVENTION + LastVertex -> gl_LAST_VERTEX_CONVENTION + + setPointSize :: PointSize -> IO () + setPointSize ps = case ps of + ProgramPointSize -> glEnable gl_PROGRAM_POINT_SIZE + PointSize s -> do + glDisable gl_PROGRAM_POINT_SIZE + glPointSize $ realToFrac s + + cvt :: RasterContext -> IO () + cvt (PointCtx ps fts sc) = do + setPointSize ps + glPointParameterf gl_POINT_FADE_THRESHOLD_SIZE (realToFrac fts) + glPointParameterf gl_POINT_SPRITE_COORD_ORIGIN $ realToFrac $ case sc of + LowerLeft -> gl_LOWER_LEFT + UpperLeft -> gl_UPPER_LEFT + + cvt (LineCtx lw pv) = do + glLineWidth (realToFrac lw) + setProvokingVertex pv + + cvt (TriangleCtx cm pm po pv) = do + -- cull mode + case cm of + CullNone -> glDisable gl_CULL_FACE + CullFront f -> do + glEnable gl_CULL_FACE + glCullFace gl_FRONT + glFrontFace $ cff f + CullBack f -> do + glEnable gl_CULL_FACE + glCullFace gl_BACK + glFrontFace $ cff f + + -- polygon mode + case pm of + PolygonPoint ps -> do + setPointSize ps + glPolygonMode gl_FRONT_AND_BACK gl_POINT + PolygonLine lw -> do + glLineWidth (realToFrac lw) + glPolygonMode gl_FRONT_AND_BACK gl_LINE + PolygonFill -> glPolygonMode gl_FRONT_AND_BACK gl_FILL + + -- polygon offset + glDisable gl_POLYGON_OFFSET_POINT + glDisable gl_POLYGON_OFFSET_LINE + glDisable gl_POLYGON_OFFSET_FILL + case po of + NoOffset -> return () + Offset f u -> do + glPolygonOffset (realToFrac f) (realToFrac u) + glEnable $ case pm of + PolygonPoint _ -> gl_POLYGON_OFFSET_POINT + PolygonLine _ -> gl_POLYGON_OFFSET_LINE + PolygonFill -> gl_POLYGON_OFFSET_FILL + + -- provoking vertex + setProvokingVertex pv + +setupAccumulationContext :: AccumulationContext -> IO () +setupAccumulationContext (AccumulationContext n ops) = cvt ops + where + cvt :: [FragmentOperation] -> IO () + cvt (StencilOp a b c : DepthOp f m : xs) = do + -- TODO + cvtC 0 xs + cvt (StencilOp a b c : xs) = do + -- TODO + cvtC 0 xs + cvt (DepthOp df dm : xs) = do + -- TODO + glDisable gl_STENCIL_TEST + case df == Always && dm == False of + True -> glDisable gl_DEPTH_TEST + False -> do + glEnable gl_DEPTH_TEST + glDepthFunc $! comparisonFunctionToGLType df + glDepthMask (cvtBool dm) + cvtC 0 xs + cvt xs = do + glDisable gl_DEPTH_TEST + glDisable gl_STENCIL_TEST + cvtC 0 xs + + cvtC :: Int -> [FragmentOperation] -> IO () + cvtC i (ColorOp b m : xs) = do + -- TODO + case b of + NoBlending -> do + -- FIXME: requires GL 3.1 + --glDisablei gl_BLEND $ fromIntegral gl_DRAW_BUFFER0 + fromIntegral i + glDisable gl_BLEND -- workaround + glDisable gl_COLOR_LOGIC_OP + BlendLogicOp op -> do + glDisable gl_BLEND + glEnable gl_COLOR_LOGIC_OP + glLogicOp $ logicOperationToGLType op + Blend (cEq,aEq) ((scF,dcF),(saF,daF)) (V4 r g b a) -> do + glDisable gl_COLOR_LOGIC_OP + -- FIXME: requires GL 3.1 + --glEnablei gl_BLEND $ fromIntegral gl_DRAW_BUFFER0 + fromIntegral i + glEnable gl_BLEND -- workaround + glBlendEquationSeparate (blendEquationToGLType cEq) (blendEquationToGLType aEq) + glBlendFuncSeparate (blendingFactorToGLType scF) (blendingFactorToGLType dcF) + (blendingFactorToGLType saF) (blendingFactorToGLType daF) + glBlendColor (realToFrac r) (realToFrac g) (realToFrac b) (realToFrac a) + let cvt True = 1 + cvt False = 0 + (mr,mg,mb,ma) = case m of + VBool r -> (cvt r, 1, 1, 1) + VV2B (V2 r g) -> (cvt r, cvt g, 1, 1) + VV3B (V3 r g b) -> (cvt r, cvt g, cvt b, 1) + VV4B (V4 r g b a) -> (cvt r, cvt g, cvt b, cvt a) + _ -> (1,1,1,1) + glColorMask mr mg mb ma + cvtC (i + 1) xs + cvtC _ [] = return () + + cvtBool :: Bool -> GLboolean + cvtBool True = 1 + cvtBool False = 0 + +{- + compile steps: + - collect all render buffers and render textures and allocate the GL resources + - create setup actions all FBO-s (including clear targets action) + - compile Image setup function for each + - compile FragmentOperation function for each + - compile shader programs + + render stages: + - draw pass: + - bind FBO + - clear FBO targets + - bind program + - execute draw actions + - execute next draw pass + - blit ScreenOut to Back buffer if necessary + + hints: + - we will have one GLProgram and one FBO per Accumulate +-} +-- TODO: +-- according context create FBO attachments +-- we always use Textures (without mipmap, as a single image) as FBO attachments +-- RenderBuffer can be use if it not fed to a sampler and it has olny one layer +-- question: +-- what is needed to create a Texture: +-- size - will be stored in FrameBuffer :: GP (FrameBuffer sh t) +-- internal format - for each component (float,int or word) +{- + glGenTextures(1, &color_tex); + glBindTexture(GL_TEXTURE_2D, color_tex); + glTexImage2D(GL_TEXTURE_2D, 0, GL_RGBA8, 256, 256, 0, GL_BGRA, GL_UNSIGNED_BYTE, NULL); + + void glFramebufferTexture(GLenum target, GLenum attachment, GLuint texture, GLint level); + void glDrawBuffers( GLsizei n, const GLenum *bufs ); +-} +{- + scissor: + enable/disable: SCISSOR_TEST + void Scissor( int left, int bottom, sizei width, sizei height ); + + multisample: + enable/disable: SAMPLE_ALPHA_TO_COVERAGE, SAMPLE_ALPHA_TO_ONE, SAMPLE_COVERAGE, SAMPLE_MASK + void SampleCoverage( clampf value, boolean invert ); + void SampleMaski( uint maskNumber, bitfield mask ); + + stencil: + enable/disable: STENCIL_TEST + void StencilFunc( enum func, int ref, uint mask ); + void StencilFuncSeparate( enum face, enum func, int ref, uint mask ); + void StencilOp( enum sfail, enum dpfail, enum dppass ); + void StencilOpSeparate( enum face, enum sfail, enum dpfail, enum dppass ); + + depth: + enable/disable: DEPTH_TEST + void DepthFunc( enum func ); + + blending: + enable/disable: + target: BLEND + index: DRAW_BUFFERi + void Enablei( enum target, uint index ); + void Disablei( enum target, uint index ); + FRAMEBUFFER_SRGB + Blend Equation: + void BlendEquation( enum mode ); + void BlendEquationSeparate( enum modeRGB, enum modeAlpha ); + void BlendFuncSeparate( enum srcRGB, enum dstRGB, enum srcAlpha, enum dstAlpha ); + void BlendFunc( enum src, enum dst ); + void BlendColor( clampf red, clampf green, clampf blue, clampf alpha ); + + dither: + enable/disable: DITHER + + logic operation: + enable/disable: COLOR_LOGIC_OP + void LogicOp( enum op ); + + Selecting a Buffer for Writing: + void DrawBuffer( enum buf ); + void DrawBuffers( sizei n, const enum *bufs ); + + Fine Control of Buffer Updates: + void ColorMask( boolean r, boolean g, boolean b, boolean a ); + void ColorMaski( uint buf, boolean r, boolean g, boolean b, boolean a ); + void DepthMask( boolean mask ); + void StencilMask( uint mask ); + void StencilMaskSeparate( enum face, uint mask ); + + Clearing the Buffers: + void Clear( bitfield buf ); + void ClearColor( clampf r, clampf g, clampf b, clampf a ); + void ClearDepth( clampd d ); + void ClearStencil( int s ); + void ClearBuffer{if ui}v( enum buffer, int drawbuffer, const T*value); + void ClearBufferfi( enum buffer, int drawbuffer, float depth, int stencil ); + + Reading and Copying Pixels: + void ReadPixels( int x, int y, sizei width, sizei height, enum format, enum type, void *data ); + void ReadBuffer( enum src ); + void ClampColor( enum target, enum clamp ); + + void BlitFramebuffer( int srcX0, int srcY0, int srcX1, int srcY1, int dstX0, int dstY0, int dstX1, int dstY1, bitfield mask, enum filter ); +-} +{- + NOTE: + We have to validate context, because we can support only the same Blend and LogicOperation for all render targets, + however blending or LogicOp can be disabled separatly to each render target. +-} + +compileClearFrameBuffer :: Exp -> IO () +compileClearFrameBuffer (FrameBuffer fb) = cvt fb + where + -- we have to handle depth and stencil specially, available configurations: + -- depth + -- stencil + -- depth-stencil + cvt :: [Image] -> IO () + cvt (StencilImage sh1 s : DepthImage sh2 d : xs) = do + -- TODO + cvtC 0 xs + cvt (StencilImage sh s : xs) = do + -- TODO + cvtC 0 xs + cvt (DepthImage sh d : xs) = do + let --renderGL3 = with d $ \pd -> glClearBufferfv gl_DEPTH 0 $ castPtr pd + glClearDepth $ realToFrac d + glClear $ fromIntegral gl_DEPTH_BUFFER_BIT + --print " * glClear gl_DEPTH_BUFFER_BIT" + cvtC 0 xs + cvt xs = cvtC 0 xs + + cvtC :: Int -> [Image] -> IO () + cvtC i (ColorImage sh c : xs) = do + -- for GL3: + --with c' $ \pc -> glClearBufferfv gl_COLOR (fromIntegral $ gl_DRAW_BUFFER0 + fromIntegral i) $ castPtr pc + let (r,g,b,a) = case c of + VFloat r -> (realToFrac r, 0, 0, 1) + VV2F (V2 r g) -> (realToFrac r, realToFrac g, 0, 1) + VV3F (V3 r g b) -> (realToFrac r, realToFrac g, realToFrac b, 1) + VV4F (V4 r g b a) -> (realToFrac r, realToFrac g, realToFrac b, realToFrac a) + _ -> (0,0,0,1) + glClearColor r g b a + glClear $ fromIntegral gl_COLOR_BUFFER_BIT + cvtC i [] = return () + +-- TODO +{- + hint: + sampler names are generated, only texture slots are named by user + one texture can be attached to more samplers + user feed textures not samplers to gfx network + + texturing support: + collect all sampler and texture definitions + create sampler <-> texture name map + sort previous passes + create sampler setup action + add texture slots to uniform input trie + + resources to create + samplers + sampler setup action + textures + hint: only if it is an output of a previous pass +-} +{- + void GenSamplers( sizei count, uint *samplers ); + void BindSampler( uint unit, uint sampler ); + void DeleteSamplers( sizei count, const uint *samplers ); + void SamplerParameter{if}v( uint sampler, enum pname, T param ); + void SamplerParameterI{u ui}v( uint sampler, enum pname, T *params ); + pname: + TEXTURE_WRAP_S + TEXTURE_WRAP_T + TEXTURE_WRAP_R + TEXTURE_MIN_FILTER + TEXTURE_MAG_FILTER + TEXTURE_BORDER_COLOR + TEXTURE_MIN_LOD + TEXTURE_MAX_LOD + TEXTURE_LOD_BIAS + TEXTURE_COMPARE_MODE + TEXTURE_COMPARE_FUNC + void DeleteSamplers( sizei count, const uint *samplers ); + + void ActiveTexture( enum texture ); + TEXTUREi = TEXTURE0 + i + void BindTexture( enum target, uint texture ); + target: + TEXTURE_1D + TEXTURE_2D + TEXTURE_3D + TEXTURE_1D_ARRAY + TEXTURE_2D_ARRAY + TEXTURE_RECTANGLE + TEXTURE_BUFFER + TEXTURE_CUBE_MAP + TEXTURE_2D_MULTISAMPLE + TEXTURE_2D_MULTISAMPLE_ARRAY +-} + + +-- FIXME: simple solution, does not support sharing +-- result: (RenderAction, DisposeAction, UniformLocation, StreamLocation) +compileRenderFrameBuffer :: DAG -> [(Exp,String)] -> [(Exp,String)] -> IORef ObjectSet -> Exp -> IO (IO (), IO (), Trie GLint, Trie GLuint, Int) +compileRenderFrameBuffer dag samplerNames slotSamplerNames objsIORef (Accumulate aCtx ffilter fsh rastExp fb) = do + --rndr <- compileFrameBuffer fb rndr' + po <- glCreateProgram + let Rasterize rCtx primsExp = toExp dag rastExp + (vsh,gsh,fetchExp) = case toExp dag primsExp of + Transform vsh fetchExp -> (vsh,Nothing,fetchExp) + Reassemble gsh transExp -> case toExp dag transExp of + Transform vsh fetchExp -> (vsh,Just gsh,fetchExp) + _ -> error "internal error: compileRenderFrameBuffer" + _ -> error "internal error: compileRenderFrameBuffer" + Fetch slotName slotPrim slotInput = toExp dag fetchExp + (shl,fragOuts,outColorCnt) = case gsh of + Nothing -> ([VertexShaderSrc srcV, FragmentShaderSrc srcF], (map fst outF), outColorCnt) + where + (srcF,outF,outColorCnt) = codeGenFragmentShader dag samplerNameMap outV (toExp dag ffilter) $ toExp dag fsh + Just gs -> ([VertexShaderSrc srcV, GeometryShaderSrc srcG, FragmentShaderSrc srcF], (map fst outF), outColorCnt) + where + (srcG,outG) = codeGenGeometryShader dag samplerNameMap slotPrim outV $ toExp dag gs + (srcF,outF,outColorCnt) = codeGenFragmentShader dag samplerNameMap outG (toExp dag ffilter) $ toExp dag fsh + (srcV,outV) = codeGenVertexShader dag samplerNameMap slotInput $ toExp dag vsh + allSamplerNames = samplerNames ++ slotSamplerNames + samplerNameMap = Map.fromList allSamplerNames + printGLStatus = checkGL >>= print + createAndAttach [] _ = return $! Nothing + createAndAttach sl t = do + mapM_ SB.putStrLn sl + o <- glCreateShader t + compileShader o sl + glAttachShader po o + putStr " + compile shader source: " >> printGLStatus + return $! Just o + putStrLn $ "compileRenderFrameBuffer: compiling program for slot: " ++ show slotName + putStrLn " + compile vertex shader" + vsh <- createAndAttach [s | VertexShaderSrc s <- shl] gl_VERTEX_SHADER + putStrLn " + compile geometry shader" + gsh <- createAndAttach [s | GeometryShaderSrc s <- shl] gl_GEOMETRY_SHADER + putStrLn " + compile fragment shader" + fsh <- createAndAttach [s | FragmentShaderSrc s <- shl] gl_FRAGMENT_SHADER + + -- connect Fragment output to FBO + forM_ (zip fragOuts [0..]) $ \(n,i) -> SB.useAsCString n $ \pn -> do + putStrLn ("variable " ++ show n ++ " attached to color number #" ++ show i) + glBindFragDataLocation po i $ castPtr pn + putStr " + setup shader output mapping: " >> printGLStatus + glLinkProgram po + printProgramLog po + + -- check link status + status <- glGetProgramiv1 gl_LINK_STATUS po + when (status /= fromIntegral gl_TRUE) $ fail "link program failed!" + + -- query active uniforms, attributes and samplers + (uLoc,uType) <- queryUniforms po + (sLoc,sType) <- queryStreams po + + putStrLn $ "shader program stream input: " ++ show sLoc + putStrLn $ "shader program uniform input: " ++ show uLoc + putStrLn $ "expected sampler input: " ++ show allSamplerNames + + -- set sampler mapping + glUseProgram po + forM_ (zip [0..] (map (SB.pack . snd) allSamplerNames)) $ \(tuIdx,n) -> case T.lookup n uLoc of + Nothing -> putStrLn $ "WARNING - unxepected inactive sampler: " ++ show n + Just i -> (setSampler i tuIdx) >> putStr (" + setup texture unit mapping (smp " ++ show i ++ " <-> TexUnit " ++ show tuIdx ++": ") >> printGLStatus + + -- HINT: we get the uniform location now, so we have to provide this info to the renderer + let uLoc' = foldl' (\t (_,n) -> setSamplerLoc t (SB.pack n)) uLoc allSamplerNames + renderSmpNamesS = Set.fromList $ map (SB.pack . snd) samplerNames + renderSmpCount = Set.size renderSmpNamesS + slotSmpName = map (SB.pack . snd) slotSamplerNames + + setSamplerLoc :: Trie GLint -> ByteString -> Trie GLint + setSamplerLoc t n + | Set.member n renderSmpNamesS = T.delete n t + | otherwise = T.adjust (\_ -> fromIntegral $ renderSmpCount + idx) n t + where + Just idx = elemIndex n slotSmpName + + disposeFun = glDeleteProgram po >> mapM_ glDeleteShader (catMaybes [vsh,gsh,fsh]) + renderFun = do + ObjectSet drawObjs objsMap <- readIORef objsIORef + unless (Map.null objsMap) $ do + --putStrLn $ "Slot: " ++ show slotName ++ " object count: " ++ show (Map.size objsMap) + setupRasterContext rCtx + setupAccumulationContext aCtx + glUseProgram po + drawObjs + print slotName + print uLoc' + return $! (renderFun, disposeFun, uLoc', sLoc, outColorCnt) diff --git a/LC_B_GLData.hs b/LC_B_GLData.hs new file mode 100644 --- /dev/null +++ b/LC_B_GLData.hs @@ -0,0 +1,312 @@ +module LC_B_GLData where + +import Control.Applicative +import Control.Monad +import Data.ByteString.Char8 (ByteString) +import Data.IORef +import Data.List as L +import Data.Maybe +import Data.Trie as T +import Foreign +--import qualified Data.IntMap as IM +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Vector as V + +--import Control.DeepSeq + +import Graphics.Rendering.OpenGL.Raw.Core32 + ( GLuint + + -- FUNCTION APPLICATION related * + -- render call + , glDrawArrays + , glDrawElements + , gl_LINES + , gl_LINES_ADJACENCY + , gl_LINE_STRIP + , gl_LINE_STRIP_ADJACENCY + , gl_POINTS + , gl_TRIANGLES + , gl_TRIANGLES_ADJACENCY + , gl_TRIANGLE_FAN + , gl_TRIANGLE_STRIP + , gl_TRIANGLE_STRIP_ADJACENCY + + -- BUFFER related * + -- buffer data + , glBindBuffer + , glBindVertexArray + , glBufferData + , glBufferSubData + , glGenBuffers + , glGenVertexArrays + , gl_ARRAY_BUFFER + , gl_ELEMENT_ARRAY_BUFFER + , gl_STATIC_DRAW + + -- TEXTURE related * + -- texture data + , glBindTexture + , glGenTextures + , glGenerateMipmap + , glPixelStorei + , glTexImage2D + , glTexParameteri + , gl_CLAMP_TO_EDGE + , gl_LINEAR + , gl_LINEAR_MIPMAP_LINEAR + , gl_REPEAT + , gl_RGB + , gl_RGBA + , gl_RGBA8 + , gl_TEXTURE_2D + , gl_TEXTURE_BASE_LEVEL + , gl_TEXTURE_MAG_FILTER + , gl_TEXTURE_MAX_LEVEL + , gl_TEXTURE_MIN_FILTER + , gl_TEXTURE_WRAP_S + , gl_TEXTURE_WRAP_T + , gl_UNPACK_ALIGNMENT + , gl_UNSIGNED_BYTE + ) + +import Data.Word +import Data.Bitmap.Pure + +import LC_B_GLType +import LC_B_GLUtil +import LC_G_APIType +import LC_U_APIType +import LC_U_DeBruijn + +-- Buffer +compileBuffer :: [Array] -> IO Buffer +compileBuffer arrs = do + let calcDesc (offset,setters,descs) (Array arrType cnt setter) = + let size = cnt * sizeOfArrayType arrType + in (size + offset, (offset,size,setter):setters, ArrayDesc arrType cnt offset size:descs) + (bufSize,arrSetters,arrDescs) = foldl' calcDesc (0,[],[]) arrs + bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo + glBindBuffer gl_ARRAY_BUFFER bo + glBufferData gl_ARRAY_BUFFER (fromIntegral bufSize) nullPtr gl_STATIC_DRAW + forM_ arrSetters $! \(offset,size,setter) -> setter $! glBufferSubData gl_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size) + glBindBuffer gl_ARRAY_BUFFER 0 + return $! Buffer (V.fromList $! reverse arrDescs) bo + +updateBuffer :: Buffer -> [(Int,Array)] -> IO () +updateBuffer (Buffer arrDescs bo) arrs = do + glBindBuffer gl_ARRAY_BUFFER bo + forM arrs $ \(i,Array arrType cnt setter) -> do + let ArrayDesc ty len offset size = arrDescs V.! i + when (ty == arrType && cnt == len) $ + setter $! glBufferSubData gl_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size) + glBindBuffer gl_ARRAY_BUFFER 0 + +bufferSize :: Buffer -> Int +bufferSize = V.length . bufArrays + +arraySize :: Buffer -> Int -> Int +arraySize buf arrIdx = arrLength $! bufArrays buf V.! arrIdx + +arrayType :: Buffer -> Int -> ArrayType +arrayType buf arrIdx = arrType $! bufArrays buf V.! arrIdx + +-- question: should we render the full stream? +-- answer: YES +-- Object +nullObject :: Object +nullObject = unsafePerformIO $ Object "" T.empty 0 <$> newIORef False + +addObject :: Renderer -> ByteString -> Primitive -> Maybe (IndexStream Buffer) -> Trie (Stream Buffer) -> [ByteString] -> IO Object +addObject renderer slotName prim objIndices objAttributes objUniforms = + if (not $ T.member slotName $! slotUniform renderer) then do + putStrLn $ "WARNING: unknown slot name: " ++ show slotName + return nullObject + else do + -- validate + let Just (slotType,sType) = T.lookup slotName $ slotStream renderer + objSType = fmap streamToInputType objAttributes + primType = case prim of + TriangleStrip -> Triangles + TriangleList -> Triangles + TriangleFan -> Triangles + LineStrip -> Lines + LineList -> Lines + PointList -> Points + TriangleStripAdjacency -> TrianglesAdjacency + TriangleListAdjacency -> TrianglesAdjacency + LineStripAdjacency -> LinesAdjacency + LineListAdjacency -> LinesAdjacency + primGL = case prim of + TriangleStrip -> gl_TRIANGLE_STRIP + TriangleList -> gl_TRIANGLES + TriangleFan -> gl_TRIANGLE_FAN + LineStrip -> gl_LINE_STRIP + LineList -> gl_LINES + PointList -> gl_POINTS + TriangleStripAdjacency -> gl_TRIANGLE_STRIP_ADJACENCY + TriangleListAdjacency -> gl_TRIANGLES_ADJACENCY + LineStripAdjacency -> gl_LINE_STRIP_ADJACENCY + LineListAdjacency -> gl_LINES_ADJACENCY + streamCounts = [c | Stream _ _ _ _ c <- T.elems objAttributes] + count = head streamCounts + + when (slotType /= primType) $ fail $ "addObject: primitive type mismatch: " ++ show (slotType,primType) + when (objSType /= sType) $ fail $ unlines + [ "addObject: attribute mismatch" + , "expected:" + , " " ++ show sType + , "actual:" + , " " ++ show objSType + ] + when (L.null streamCounts) $ fail "addObject: missing stream attribute, a least one stream attribute is required!" + when (L.or [c /= count | c <- streamCounts]) $ fail "addObject: streams should have the same length!" + + -- validate index type if presented and create draw action + (iSetup,draw) <- case objIndices of + Nothing -> return (glBindBuffer gl_ELEMENT_ARRAY_BUFFER 0, glDrawArrays primGL 0 (fromIntegral count)) + Just (IndexStream (Buffer arrs bo) arrIdx start idxCount) -> do + -- setup index buffer + let ArrayDesc arrType arrLen arrOffs arrSize = arrs V.! arrIdx + glType = arrayTypeToGLType arrType + ptr = intPtrToPtr $! fromIntegral (arrOffs + start * sizeOfArrayType arrType) + -- validate index type + when (notElem arrType [ArrWord8, ArrWord16, ArrWord32]) $ fail "addObject: index type should be unsigned integer type" + return (glBindBuffer gl_ELEMENT_ARRAY_BUFFER bo, glDrawElements primGL (fromIntegral idxCount) glType ptr) + + -- implementation + let renderDescriptorMap = renderDescriptor renderer + uniformType = T.fromList $ concat [T.toList t | (_,t) <- T.toList $ slotUniform renderer] + mkUSetup = mkUniformSetup renderer + globalUNames = Set.toList $! (Set.fromList $! T.keys uniformType) Set.\\ (Set.fromList objUniforms) + rendState = renderState renderer + + stateIORef <- newIORef True + (mkObjUSetup,objUSetters) <- unzip <$> (sequence [mkUniformSetter rendState t | n <- objUniforms, t <- maybeToList $ T.lookup n uniformType]) + let objUSetterTrie = T.fromList $! zip objUniforms objUSetters + + mkDrawAction :: Exp -> IO (GLuint,IO ()) + mkDrawAction gp = do + let Just rd = Map.lookup gp renderDescriptorMap + sLocs = streamLocation rd + uLocs = uniformLocation rd + -- stream setup action + sSetup = sequence_ [ mkSSetter t loc s + | (n,s) <- T.toList objAttributes + , t <- maybeToList $ T.lookup n sType + , loc <- maybeToList $ T.lookup n sLocs + ] + -- global uniform setup + {- + globalUSetup = sequence_ [ mkUS loc + | n <- globalUNames + , let Just mkUS = T.lookup n mkUSetup + , loc <- maybeToList $ T.lookup n uLocs + ] + -} + globalUSetup = V.sequence_ $ V.fromList + [ mkUS loc + | n <- globalUNames + , let Just mkUS = T.lookup n mkUSetup + , loc <- maybeToList $ T.lookup n uLocs + ] + -- object uniform setup + objUSetup = sequence_ [ mkOUS loc + | (n,mkOUS) <- zip objUniforms mkObjUSetup + , loc <- maybeToList $ T.lookup n uLocs + ] + --print sLocs + -- create Vertex Array Object + vao <- alloca $! \pvao -> glGenVertexArrays 1 pvao >> peek pvao + glBindVertexArray vao + sSetup -- setup vertex attributes + iSetup -- setup index buffer + let renderFun = readIORef stateIORef >>= \enabled -> when enabled $ do + --print "draw object" + --putStrLn $ " setup global uniforms: " ++ show [n | n <- globalUNames, T.member n uLocs] + globalUSetup -- setup uniforms + --putStrLn $ " setup object uniforms: " ++ show [n | n <- objUniforms, T.member n uLocs] + objUSetup + glBindVertexArray vao -- setup stream input (aka object attributes) + draw -- execute draw function + return (vao,renderFun) + + Just (SlotDescriptor gps objSetRef) = T.lookup slotName (slotDescriptor renderer) + gpList = Set.toList gps + {- + - create the object draw action for every Accumulate node + - update ObjectSet's draw action lists + -} + --print sType + (vaoList,drawList) <- unzip <$> mapM mkDrawAction gpList + objID <- readIORef (objectIDSeed renderer) + modifyIORef (objectIDSeed renderer) (+1) + let obj = Object + { objectSlotName = slotName + , objectUniformSetter = objUSetterTrie + , objectID = objID + , objectEnabledIORef = stateIORef + } + + -- add object to slot's object set + modifyIORef objSetRef $ \s -> Set.insert obj s + + -- add draw object action to list + forM_ (zip gpList drawList) $ \(gp,draw) -> do + --print ("add", vaoList) + let Just rd = Map.lookup gp renderDescriptorMap + modifyIORef (drawObjectsIORef rd) $ \(ObjectSet _ drawMap) -> + let drawMap' = Map.insert obj draw drawMap + in ObjectSet (sequence_ $ Map.elems drawMap') drawMap' + + return obj + +removeObject :: Renderer -> Object -> IO () +removeObject rend obj = do + let Just (SlotDescriptor gps objSetRef) = T.lookup (objectSlotName obj) (slotDescriptor rend) + renderDescriptorMap = renderDescriptor rend + + -- remove object from slot's object set + modifyIORef objSetRef $ \s -> Set.delete obj s + + -- remove draw object action from list + forM_ (Set.toList gps) $ \gp -> do + let Just rd = Map.lookup gp renderDescriptorMap + modifyIORef (drawObjectsIORef rd) $ \(ObjectSet _ drawMap) -> + let drawMap' = Map.delete obj drawMap + in ObjectSet (sequence_ $ Map.elems drawMap') drawMap' + +enableObject :: Object -> Bool -> IO () +enableObject obj b = writeIORef (objectEnabledIORef obj) b + +-- Texture + +-- FIXME: Temporary implemenation +compileTexture2DRGBAF :: Bool -> Bool -> Bitmap Word8 -> IO TextureData +compileTexture2DRGBAF isMip isClamped bitmap = do + glPixelStorei gl_UNPACK_ALIGNMENT 1 + to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto + glBindTexture gl_TEXTURE_2D to + let (width,height) = bitmapSize bitmap + wrapMode = case isClamped of + True -> gl_CLAMP_TO_EDGE + False -> gl_REPEAT + (minFilter,maxLevel) = case isMip of + False -> (gl_LINEAR,0) + True -> (gl_LINEAR_MIPMAP_LINEAR, floor $ log (fromIntegral $ max width height) / log 2) + glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_S $ fromIntegral wrapMode + glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_T $ fromIntegral wrapMode + glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MIN_FILTER $ fromIntegral minFilter + glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAG_FILTER $ fromIntegral gl_LINEAR + glTexParameteri gl_TEXTURE_2D gl_TEXTURE_BASE_LEVEL 0 + glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAX_LEVEL $ fromIntegral maxLevel + withBitmap bitmap $ \(w,h) nchn 0 ptr -> do + let internalFormat = fromIntegral gl_RGBA8 + dataFormat = fromIntegral $ case nchn of + 3 -> gl_RGB + 4 -> gl_RGBA + _ -> error "unsupported texture format!" + glTexImage2D gl_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE $ castPtr ptr + when isMip $ glGenerateMipmap gl_TEXTURE_2D + return $ TextureData to diff --git a/LC_B_GLSLCodeGen.hs b/LC_B_GLSLCodeGen.hs new file mode 100644 --- /dev/null +++ b/LC_B_GLSLCodeGen.hs @@ -0,0 +1,869 @@ +module LC_B_GLSLCodeGen ( + codeGenVertexShader, + codeGenGeometryShader, + codeGenFragmentShader, + codeGenType +) where + +import Debug.Trace + +import Control.Applicative hiding (Const) +import Control.Exception +import Control.Monad.State +import Data.ByteString.Char8 (ByteString,pack,unpack) +import Data.Int +import Data.IntMap (IntMap) +import Data.Map (Map) +import Data.Maybe +import Data.Set (Set) +import Data.Word +import Text.PrettyPrint.HughesPJClass +import qualified Data.ByteString.Char8 as SB +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Vector as V + +import LC_G_Type +import LC_G_APIType hiding (LogicOperation(..), ComparisonFunction(..)) +import LC_U_APIType +import LC_U_PrimFun +import LC_U_DeBruijn hiding (ExpC(..)) + +import Language.GLSL.Syntax hiding (Const,InterpolationQualifier(..),TypeSpecifierNonArray(..)) +import Language.GLSL.Syntax (TypeSpecifierNonArray) +import qualified Language.GLSL.Syntax as GLSL +import Language.GLSL.Pretty +import LC_B_Traversals + +codeGenPrim :: PrimFun -> [InputType] -> [InputType] -> [Expr] -> [Expr] + +-- Vec/Mat (de)construction +codeGenPrim PrimTupToV2 ty argTy [a,b] + | all (==Bool) argTy = [functionCall "bvec2" [a,b]] + | all (==Float) argTy = [functionCall "vec2" [a,b]] + | all (==Int) argTy = [functionCall "ivec2" [a,b]] + | all (==Word) argTy = [functionCall "uvec2" [a,b]] + | all (==V2F) argTy = [functionCall "mat2" [a,b]] + | all (==V3F) argTy = [functionCall "mat3x2" [a,b]] + | all (==V4F) argTy = [functionCall "mat4x2" [a,b]] +codeGenPrim PrimTupToV3 ty argTy [a,b,c] + | all (==Bool) argTy = [functionCall "bvec3" [a,b,c]] + | all (==Float) argTy = [functionCall "vec3" [a,b,c]] + | all (==Int) argTy = [functionCall "ivec3" [a,b,c]] + | all (==Word) argTy = [functionCall "uvec3" [a,b,c]] + | all (==V2F) argTy = [functionCall "mat2x3" [a,b,c]] + | all (==V3F) argTy = [functionCall "mat3" [a,b,c]] + | all (==V4F) argTy = [functionCall "mat4x3" [a,b,c]] +codeGenPrim PrimTupToV4 ty argTy [a,b,c,d] + | all (==Bool) argTy = [functionCall "bvec4" [a,b,c,d]] + | all (==Float) argTy = [functionCall "vec4" [a,b,c,d]] + | all (==Int) argTy = [functionCall "ivec4" [a,b,c,d]] + | all (==Word) argTy = [functionCall "uvec4" [a,b,c,d]] + | all (==V2F) argTy = [functionCall "mat2x4" [a,b,c,d]] + | all (==V3F) argTy = [functionCall "mat3x4" [a,b,c,d]] + | all (==V4F) argTy = [functionCall "mat4" [a,b,c,d]] + +codeGenPrim PrimV2ToTup ty argTy [a] + | all isMatrix argTy = [ Bracket a (IntConstant Decimal 0) + , Bracket a (IntConstant Decimal 1) + ] + | otherwise = [ FieldSelection a "x" + , FieldSelection a "y" + ] +codeGenPrim PrimV3ToTup ty argTy [a] + | all isMatrix argTy = [ Bracket a (IntConstant Decimal 0) + , Bracket a (IntConstant Decimal 1) + , Bracket a (IntConstant Decimal 2) + ] + | otherwise = [ FieldSelection a "x" + , FieldSelection a "y" + , FieldSelection a "z" + ] +codeGenPrim PrimV4ToTup ty argTy [a] + | all isMatrix argTy = [ Bracket a (IntConstant Decimal 0) + , Bracket a (IntConstant Decimal 1) + , Bracket a (IntConstant Decimal 2) + , Bracket a (IntConstant Decimal 3) + ] + | otherwise = [ FieldSelection a "x" + , FieldSelection a "y" + , FieldSelection a "z" + , FieldSelection a "w" + ] + +-- Arithmetic Functions +-- OK +codeGenPrim PrimAdd ty argTy [a,b] = [Add a b] +codeGenPrim PrimAddS ty argTy [a,b] = [Add a b] +codeGenPrim PrimSub ty argTy [a,b] = [Sub a b] +codeGenPrim PrimSubS ty argTy [a,b] = [Sub a b] +codeGenPrim PrimMul ty argTy [a,b] + | all isMatrix argTy = [functionCall "matrixCompMult" [a,b]] + | otherwise = [Mul a b] +codeGenPrim PrimMulS ty argTy [a,b] = [Mul a b] +codeGenPrim PrimDiv ty argTy [a,b] = [Div a b] +codeGenPrim PrimDivS ty argTy [a,b] = [Div a b] +codeGenPrim PrimNeg ty argTy [a] = [UnaryNegate a] +codeGenPrim PrimMod ty argTy [a,b] + | all isIntegral argTy = [Mod a b] + | otherwise = [functionCall "mod" [a,b]] +codeGenPrim PrimModS ty argTy [a,b] + | all isIntegral argTy = [Mod a b] + | otherwise = [functionCall "mod" [a,b]] + +-- Bit-wise Functions +-- OK +codeGenPrim PrimBAnd ty argTy [a,b] = [BitAnd a b] +codeGenPrim PrimBAndS ty argTy [a,b] = [BitAnd a b] +codeGenPrim PrimBOr ty argTy [a,b] = [BitOr a b] +codeGenPrim PrimBOrS ty argTy [a,b] = [BitOr a b] +codeGenPrim PrimBXor ty argTy [a,b] = [BitXor a b] +codeGenPrim PrimBXorS ty argTy [a,b] = [BitXor a b] +codeGenPrim PrimBNot ty argTy [a] = [UnaryOneComplement a] +codeGenPrim PrimBShiftL ty argTy [a,b] = [LeftShift a b] +codeGenPrim PrimBShiftLS ty argTy [a,b] = [LeftShift a b] +codeGenPrim PrimBShiftR ty argTy [a,b] = [RightShift a b] +codeGenPrim PrimBShiftRS ty argTy [a,b] = [RightShift a b] + +-- Logic Functions +-- OK +codeGenPrim PrimAnd ty argTy [a,b] = [And a b] +codeGenPrim PrimOr ty argTy [a,b] = [Or a b] +codeGenPrim PrimXor ty argTy [a,b] = error "codeGenPrim PrimXor is not implemented yet!" -- TODO: implement in GLSLSyntax +codeGenPrim PrimNot ty argTy [a] + | all isScalar argTy = [UnaryNot a] + | otherwise = [functionCall "not" [a]] +codeGenPrim PrimAny ty argTy [a] = [functionCall "any" [a]] +codeGenPrim PrimAll ty argTy [a] = [functionCall "all" [a]] + +-- Angle and Trigonometry Functions +-- OK +codeGenPrim PrimACos ty argTy [a] = [functionCall "acos" [a]] +codeGenPrim PrimACosH ty argTy [a] = [functionCall "acosh" [a]] +codeGenPrim PrimASin ty argTy [a] = [functionCall "asin" [a]] +codeGenPrim PrimASinH ty argTy [a] = [functionCall "asinh" [a]] +codeGenPrim PrimATan ty argTy [a] = [functionCall "atan" [a]] +codeGenPrim PrimATan2 ty argTy [a,b] = [functionCall "atan" [a,b]] +codeGenPrim PrimATanH ty argTy [a] = [functionCall "atanh" [a]] +codeGenPrim PrimCos ty argTy [a] = [functionCall "cos" [a]] +codeGenPrim PrimCosH ty argTy [a] = [functionCall "cosh" [a]] +codeGenPrim PrimDegrees ty argTy [a] = [functionCall "degrees" [a]] +codeGenPrim PrimRadians ty argTy [a] = [functionCall "radians" [a]] +codeGenPrim PrimSin ty argTy [a] = [functionCall "sin" [a]] +codeGenPrim PrimSinH ty argTy [a] = [functionCall "sinh" [a]] +codeGenPrim PrimTan ty argTy [a] = [functionCall "tan" [a]] +codeGenPrim PrimTanH ty argTy [a] = [functionCall "tanh" [a]] + +-- Exponential Functions +-- OK +codeGenPrim PrimPow ty argTy [a,b] = [functionCall "pow" [a,b]] +codeGenPrim PrimExp ty argTy [a] = [functionCall "exp" [a]] +codeGenPrim PrimLog ty argTy [a] = [functionCall "log" [a]] +codeGenPrim PrimExp2 ty argTy [a] = [functionCall "exp2" [a]] +codeGenPrim PrimLog2 ty argTy [a] = [functionCall "log2" [a]] +codeGenPrim PrimSqrt ty argTy [a] = [functionCall "sqrt" [a]] +codeGenPrim PrimInvSqrt ty argTy [a] = [functionCall "inversesqrt" [a]] + +-- Common Functions +-- OK +codeGenPrim PrimIsNan ty argTy [a] = [functionCall "isnan" [a]] +codeGenPrim PrimIsInf ty argTy [a] = [functionCall "isinf" [a]] +codeGenPrim PrimAbs ty argTy [a] = [functionCall "abs" [a]] +codeGenPrim PrimSign ty argTy [a] = [functionCall "sign" [a]] +codeGenPrim PrimFloor ty argTy [a] = [functionCall "floor" [a]] +codeGenPrim PrimTrunc ty argTy [a] = [functionCall "trunc" [a]] +codeGenPrim PrimRound ty argTy [a] = [functionCall "round" [a]] +codeGenPrim PrimRoundEven ty argTy [a] = [functionCall "roundEven" [a]] +codeGenPrim PrimCeil ty argTy [a] = [functionCall "ceil" [a]] +codeGenPrim PrimFract ty argTy [a] = [functionCall "fract" [a]] +codeGenPrim PrimModF ty argTy [a] = error "codeGenPrim PrimModF is not implemented yet!" -- TODO +codeGenPrim PrimMin ty argTy [a,b] = [functionCall "min" [a,b]] +codeGenPrim PrimMinS ty argTy [a,b] = [functionCall "min" [a,b]] +codeGenPrim PrimMax ty argTy [a,b] = [functionCall "max" [a,b]] +codeGenPrim PrimMaxS ty argTy [a,b] = [functionCall "max" [a,b]] +codeGenPrim PrimClamp ty argTy [a,b,c] = [functionCall "clamp" [a,b,c]] +codeGenPrim PrimClampS ty argTy [a,b,c] = [functionCall "clamp" [a,b,c]] +codeGenPrim PrimMix ty argTy [a,b,c] = [functionCall "mix" [a,b,c]] +codeGenPrim PrimMixS ty argTy [a,b,c] = [functionCall "mix" [a,b,c]] +codeGenPrim PrimMixB ty argTy [a,b,c] = [functionCall "mix" [a,b,c]] +codeGenPrim PrimStep ty argTy [a,b] = [functionCall "step" [a,b]] +codeGenPrim PrimStepS ty argTy [a,b] = [functionCall "step" [a,b]] +codeGenPrim PrimSmoothStep ty argTy [a,b,c] = [functionCall "smoothstep" [a,b,c]] +codeGenPrim PrimSmoothStepS ty argTy [a,b,c] = [functionCall "smoothstep" [a,b,c]] + +-- Integer/Float Conversion Functions +-- OK +codeGenPrim PrimFloatBitsToInt ty argTy [a] = [functionCall "floatBitsToInt" [a]] +codeGenPrim PrimFloatBitsToUInt ty argTy [a] = [functionCall "floatBitsToUint" [a]] +codeGenPrim PrimIntBitsToFloat ty argTy [a] = [functionCall "intBitsToFloat" [a]] +codeGenPrim PrimUIntBitsToFloat ty argTy [a] = [functionCall "uintBitsToFloat" [a]] + +-- Geometric Functions +-- OK +codeGenPrim PrimLength ty argTy [a] = [functionCall "length" [a]] +codeGenPrim PrimDistance ty argTy [a,b] = [functionCall "distance" [a,b]] +codeGenPrim PrimDot ty argTy [a,b] = [functionCall "dot" [a,b]] +codeGenPrim PrimCross ty argTy [a,b] = [functionCall "cross" [a,b]] +codeGenPrim PrimNormalize ty argTy [a] = [functionCall "normalize" [a]] +codeGenPrim PrimFaceForward ty argTy [a,b,c] = [functionCall "faceforward" [a,b,c]] +codeGenPrim PrimReflect ty argTy [a,b] = [functionCall "reflect" [a,b]] +codeGenPrim PrimRefract ty argTy [a,b,c] = [functionCall "refract" [a,b,c]] + +-- Matrix Functions +-- OK +codeGenPrim PrimTranspose ty argTy [a] = [functionCall "transpose" [a]] +codeGenPrim PrimDeterminant ty argTy [a] = [functionCall "determinant" [a]] +codeGenPrim PrimInverse ty argTy [a] = [functionCall "inverse" [a]] +codeGenPrim PrimOuterProduct ty argTy [a,b] = [functionCall "outerProduct" [a,b]] +codeGenPrim PrimMulMatVec ty argTy [a,b] = [Mul a b] +codeGenPrim PrimMulVecMat ty argTy [a,b] = [Mul a b] +codeGenPrim PrimMulMatMat ty argTy [a,b] = [Mul a b] + +-- Vector and Scalar Relational Functions +-- OK +codeGenPrim PrimLessThan ty argTy [a,b] + | all isScalarNum argTy = [Lt a b] + | otherwise = [functionCall "lessThan" [a,b]] +codeGenPrim PrimLessThanEqual ty argTy [a,b] + | all isScalarNum argTy = [Lte a b] + | otherwise = [functionCall "lessThanEqual" [a,b]] +codeGenPrim PrimGreaterThan ty argTy [a,b] + | all isScalarNum argTy = [Gt a b] + | otherwise = [functionCall "greaterThan" [a,b]] +codeGenPrim PrimGreaterThanEqual ty argTy [a,b] + | all isScalarNum argTy = [Gte a b] + | otherwise = [functionCall "greaterThanEqual" [a,b]] +codeGenPrim PrimEqualV ty argTy [a,b] + | all isScalar argTy = [Equ a b] + | otherwise = [functionCall "equal" [a,b]] +codeGenPrim PrimEqual ty argTy [a,b] = [Equ a b] +codeGenPrim PrimNotEqualV ty argTy [a,b] + | all isScalar argTy = [Neq a b] + | otherwise = [functionCall "notEqual" [a,b]] +codeGenPrim PrimNotEqual ty argTy [a,b] = [Neq a b] + +-- Fragment Processing Functions +-- OK +codeGenPrim PrimDFdx ty argTy [a] = [functionCall "dFdx" [a]] +codeGenPrim PrimDFdy ty argTy [a] = [functionCall "dFdy" [a]] +codeGenPrim PrimFWidth ty argTy [a] = [functionCall "fwidth" [a]] + +-- Noise Functions +-- OK +codeGenPrim PrimNoise1 ty argTy [a] = [functionCall "noise1" [a]] +codeGenPrim PrimNoise2 ty argTy [a] = [functionCall "noise2" [a]] +codeGenPrim PrimNoise3 ty argTy [a] = [functionCall "noise3" [a]] +codeGenPrim PrimNoise4 ty argTy [a] = [functionCall "noise4" [a]] + +-- Texture Lookup Functions +codeGenPrim PrimTextureSize ty argTy [a] = [functionCall "textureSize" [a]] +codeGenPrim PrimTextureSize ty argTy [a,b] = [functionCall "textureSize" [a,b]] +codeGenPrim PrimTexture ty argTy [a,b] = [swizzleV4 ty $ functionCall "texture" [a,b]] +codeGenPrim PrimTexture ty argTy [a,b,c] = [swizzleV4 ty $ functionCall "texture" [a,b,c]] +codeGenPrim PrimTextureProj ty argTy [a,b] = [swizzleV4 ty $ functionCall "textureProj" [a,b]] +codeGenPrim PrimTextureProj ty argTy [a,b,c] = [swizzleV4 ty $ functionCall "textureProj" [a,b,c]] +codeGenPrim PrimTextureLod ty argTy [a,b,c] = [swizzleV4 ty $ functionCall "textureLod" [a,b,c]] +codeGenPrim PrimTextureOffset ty argTy [a,b,c] = [swizzleV4 ty $ functionCall "textureOffset" [a,b,c]] +codeGenPrim PrimTextureOffset ty argTy [a,b,c,d] = [swizzleV4 ty $ functionCall "textureOffset" [a,b,c,d]] +codeGenPrim PrimTexelFetch ty argTy [a,b] = [swizzleV4 ty $ functionCall "texelFetch" [a,b]] +codeGenPrim PrimTexelFetch ty argTy [a,b,c] = [swizzleV4 ty $ functionCall "texelFetch" [a,b,c]] +codeGenPrim PrimTexelFetchOffset ty argTy [a,b,c] = [swizzleV4 ty $ functionCall "texelFetchOffset" [a,b,c]] +codeGenPrim PrimTexelFetchOffset ty argTy [a,b,c,d] = [swizzleV4 ty $ functionCall "texelFetchOffset" [a,b,c,d]] +codeGenPrim PrimTextureProjOffset ty argTy [a,b,c] = [swizzleV4 ty $ functionCall "textureProjOffset" [a,b,c]] +codeGenPrim PrimTextureProjOffset ty argTy [a,b,c,d] = [swizzleV4 ty $ functionCall "textureProjOffset" [a,b,c,d]] +codeGenPrim PrimTextureLodOffset ty argTy [a,b,c,d] = [swizzleV4 ty $ functionCall "textureLodOffset" [a,b,c,d]] +codeGenPrim PrimTextureProjLod ty argTy [a,b,c] = [swizzleV4 ty $ functionCall "textureProjLod" [a,b,c]] +codeGenPrim PrimTextureProjLodOffset ty argTy [a,b,c,d] = [swizzleV4 ty $ functionCall "textureProjLodOffset" [a,b,c,d]] +codeGenPrim PrimTextureGrad ty argTy [a,b,c,d] = [swizzleV4 ty $ functionCall "textureGrad" [a,b,c,d]] +codeGenPrim PrimTextureGradOffset ty argTy [a,b,c,d,e] = [swizzleV4 ty $ functionCall "textureGradOffset" [a,b,c,d,e]] +codeGenPrim PrimTextureProjGrad ty argTy [a,b,c,d] = [swizzleV4 ty $ functionCall "textureProjGrad" [a,b,c,d]] +codeGenPrim PrimTextureProjGradOffset ty argTy [a,b,c,d,e] = [swizzleV4 ty $ functionCall "textureProjGradOffset" [a,b,c,d,e]] + +-- unmatched primitive function +codeGenPrim prim ty argTy params = throw $ userError $ unlines $ + [ "codeGenPrim failed: " + , " name: " ++ show prim + , " parameter types: " ++ show ty + , " parameter values: " ++ show params + ] + +swizzleV4 :: [InputType] -> Expr -> Expr +swizzleV4 [ty] a + | elem ty [V4F, V4I, V4U] = a + | elem ty [V3F, V3I, V3U] = FieldSelection a "rgb" + | elem ty [V2F, V2I, V2U] = FieldSelection a "rg" + | elem ty [Float, Int, Word] = FieldSelection a "r" + | otherwise = error $ "swizzleV4 - illegal type: " ++ show ty + +-- glsl ast utility +functionCall :: String -> [Expr] -> Expr +functionCall name params = FunctionCall (FuncId name) (Params params) + +isMatrix :: InputType -> Bool +isMatrix ty = elem ty $ + [ M22F, M23F, M24F + , M32F, M33F, M34F + , M42F, M43F, M44F + ] + +isIntegral :: InputType -> Bool +isIntegral ty = elem ty $ + [ Word, V2U, V3U, V4U + , Int, V2I, V3I, V4I + ] + +isScalarNum :: InputType -> Bool +isScalarNum ty = elem ty [Int, Word, Float] + +isScalar :: InputType -> Bool +isScalar ty = elem ty [Bool, Int, Word, Float] + +wordC :: Word32 -> Expr +wordC v = IntConstant Decimal (fromIntegral v) + +intC :: Int32 -> Expr +intC v = IntConstant Decimal (fromIntegral v) + +boolC :: Bool -> Expr +boolC v = BoolConstant v + +floatC :: Float -> Expr +floatC v = FloatConstant v + +v2C :: String -> (a -> Expr) -> V2 a -> Expr +v2C name f (V2 x y) = functionCall name [f x, f y] + +v3C :: String -> (a -> Expr) -> V3 a -> Expr +v3C name f (V3 x y z) = functionCall name [f x, f y, f z] + +v4C :: String -> (a -> Expr) -> V4 a -> Expr +v4C name f (V4 x y z w) = functionCall name [f x, f y, f z, f w] + +matX2C :: String -> (v Float -> Expr) -> V2 (v Float) -> Expr +matX2C name f (V2 x y) = functionCall name [f x, f y] + +matX3C :: String -> (v Float -> Expr) -> V3 (v Float) -> Expr +matX3C name f (V3 x y z) = functionCall name [f x, f y, f z] + +matX4C :: String -> (v Float -> Expr) -> V4 (v Float) -> Expr +matX4C name f (V4 x y z w) = functionCall name [f x, f y, f z, f w] + +codeGenConst :: Value -> Expr +codeGenConst (VBool v) = boolC v +codeGenConst (VV2B v) = v2C "bvec2" boolC v +codeGenConst (VV3B v) = v3C "bvec3" boolC v +codeGenConst (VV4B v) = v4C "bvec4" boolC v +codeGenConst (VWord v) = wordC v +codeGenConst (VV2U v) = v2C "uvec2" wordC v +codeGenConst (VV3U v) = v3C "uvec3" wordC v +codeGenConst (VV4U v) = v4C "uvec4" wordC v +codeGenConst (VInt v) = intC v +codeGenConst (VV2I v) = v2C "ivec2" intC v +codeGenConst (VV3I v) = v3C "ivec3" intC v +codeGenConst (VV4I v) = v4C "ivec4" intC v +codeGenConst (VFloat v) = floatC v +codeGenConst (VV2F v) = v2C "vec2" floatC v +codeGenConst (VV3F v) = v3C "vec3" floatC v +codeGenConst (VV4F v) = v4C "vec4" floatC v +codeGenConst (VM22F v) = matX2C "mat2" (v2C "vec2" floatC) v +codeGenConst (VM23F v) = matX3C "mat2x3" (v2C "vec2" floatC) v +codeGenConst (VM24F v) = matX4C "mat2x4" (v2C "vec2" floatC) v +codeGenConst (VM32F v) = matX2C "mat3x2" (v3C "vec3" floatC) v +codeGenConst (VM33F v) = matX3C "mat3" (v3C "vec3" floatC) v +codeGenConst (VM34F v) = matX4C "mat3x4" (v3C "vec3" floatC) v +codeGenConst (VM42F v) = matX2C "mat4x2" (v4C "vec4" floatC) v +codeGenConst (VM43F v) = matX3C "mat4x3" (v4C "vec4" floatC) v +codeGenConst (VM44F v) = matX4C "mat4" (v4C "vec4" floatC) v + +type CGen a = State ([Statement],IntMap [Expr]) a + +store :: DAG -> Int -> Expr -> CGen [Expr] +store dag expId exp = do + let name = "val" ++ show expId + newVar = Variable name + t = codeGenType $ expIdType dag expId + [ty] = {-trace (show expId ++ " [ty] = " ++ show t)-} t + newStmt = varStmt name (toGLSLType ty) exp + cnt = expIdCount dag expId + case cnt > 0 of + True -> do + (stmt,varMap) <- get + put (newStmt:stmt,IntMap.insert expId [newVar] varMap) + return [newVar] + False -> return [exp] + +addStmt :: Statement -> CGen () +addStmt s = do + (stmt,varMap) <- get + put (s:stmt,varMap) + return () + +addExpr :: ExpId -> [Expr] -> CGen () +addExpr expId exprs = do + (stmt,varMap) <- get + put (stmt,IntMap.insert expId exprs varMap) + return () + +type Env = V.Vector [Expr] + +codeGenExp' :: DAG -> Map Exp String -> Env -> ExpId -> CGen [Expr] +codeGenExp' dag smpName env expId = do + (stmt,varMap) <- get + case IntMap.lookup expId varMap of + Just v -> return v + Nothing -> case toExp dag expId of + + Loop st lc sr is -> do + -- state transform, loop condition, state to result, initial state + isE <- codeGenExp' dag smpName env is + let getBody a = case toExp dag a of + Lam b -> case toExp dag b of + Body c -> c + _ -> error "internal error: illegal lambda function!" + _ -> error "internal error: illegal lambda function!" + name = "state" ++ show expId ++ "_" + t = codeGenType $ expIdType dag is + (stS,stE) = unzip $ [(varStmt n (toGLSLType ty) e, Variable n) | (e,ty,i) <- zip3 isE t [0..], let n = name ++ show i] + mapM addStmt stS + {- + done - create state variable + done - create while loop: + done - loop condition expression + done - state transformation expression + done - create result from final state + -} + (_,loopCGenState) <- get + let loop = While (Condition $ BoolConstant True) (CompoundStatement $ Compound $ reverse body) + env' = (V.snoc env stE) + (_,(body,_)) = (flip runState) ([],loopCGenState) $ do + [lcE] <- codeGenExp' dag smpName env' (getBody lc) + addStmt (SelectionStatement (UnaryNot lcE) Break Nothing) + stE' <- codeGenExp' dag smpName env' (getBody st) + mapM_ addStmt $ zipWith assign stE stE' + return () + addStmt loop + rE <- codeGenExp' dag smpName env' (getBody sr) + addExpr expId rE + return rE + Const c -> store dag expId $ codeGenConst c + Uni n -> return [Variable $! unpack n] + PrimVar n -> return [Variable $! unpack n] + PrimApp f arg -> do + arg' <- codeGenExp' dag smpName env arg + let argTy = codeGenType $ expIdType dag arg + ty = codeGenType $ expIdType dag expId + e = codeGenPrim f ty argTy arg' + if length e > 1 then return e else + store dag expId $ head e + s@(Sampler f e t) -> case Map.lookup s smpName of + Just name -> return [Variable name] + Nothing -> error "Internal error: Unknown sampler value!" + Cond p t e -> do + [p'] <- codeGenExp' dag smpName env p + t' <- codeGenExp' dag smpName env t + e' <- codeGenExp' dag smpName env e + let branch a b = Selection p' a b + return $ zipWith branch t' e' + e@(Var i li) -> do + let ty = expType dag e + arity = length $! codeGenType ty + errEx = throw $ userError $ unlines $ + [ "codeGenExp failed: " + , " Var " ++ show i ++ " (" ++ show li ++ ") :: " ++ show ty + , " input names: " ++ show env + , " arity: " ++ show arity + ] + case env V.!? i of + Nothing -> errEx + Just v -> if length v == arity then return v else errEx + + Tup t -> concat <$> mapM (codeGenExp' dag smpName env) t + p@(Prj idx e) -> do + let ty = expType dag p + e' <- codeGenExp' dag smpName env e + return $ reverse . take (length $ codeGenType ty) . drop idx . reverse $ e' +{- + required info: output variable names + if we disable inline functions, it simplifies variable name gen +-} + +codeGenVertexShader :: DAG + -> Map Exp String + -> [(ByteString,InputType)] + -> Exp + -> (ByteString, [(ByteString,GLSL.InterpolationQualifier,InputType)]) +codeGenVertexShader dag smpName inVars = cvt + where + genExp :: ExpId -> CGen [Expr] + genExp = codeGenExp' dag smpName $ V.singleton [Variable (unpack n) | n <- map fst inVars] + + genIExp :: Exp -> CGen (GLSL.InterpolationQualifier,[Expr],[InputType]) + genIExp (Flat e) = (GLSL.Flat,,codeGenType $ expIdType dag e) <$> genExp e + genIExp (Smooth e) = (GLSL.Smooth,,codeGenType $ expIdType dag e) <$> genExp e + genIExp (NoPerspective e) = (GLSL.NoPerspective,,codeGenType $ expIdType dag e) <$> genExp e + + cvt :: Exp -> (ByteString, [(ByteString,GLSL.InterpolationQualifier,InputType)]) + cvt (Lam lam) = cvt $ toExp dag lam + cvt (Body bodyExp) = (SB.unlines $! + [ "#version 150 core" + , "#extension GL_EXT_gpu_shader4 : enable" + -- , "#pragma optimize(off)" + , pp [uniform (unpack n) (toGLSLType t) | (n,t) <- uniVars] + , pp [uniform n (toGLSLType t) | (n,t) <- smpVars] + , pp [inVar (unpack n) (toGLSLType t) | (n,t) <- inVars] + , pp [outVarIQ (unpack n) iq (toGLSLType t) | n <- oNames | iq <- oQ | [t] <- oT] + , "void main ()" + , ppE (posE:sizeE:concat oE ++ clipE) ("gl_Position":"gl_PointSize":oNames ++ take clipCount clipNames) + ], [(n,q,t) | n <- oNames | q <- oQ | [t] <- oT]) + where + clipCount = length clipE + clipNames = [pack $ "gl_ClipDistance[" ++ show i ++ "]" | i <- [0..]] + VertexOut pos size clips outs = toExp dag bodyExp + ppE e a = pack $! show $! pPrint $! Compound $ reverse stmt ++ [assign (Variable (unpack n)) ex | ex <- e | n <- a] + pp a = pack $! show $! pPrint $! TranslationUnit a + uniVars = Set.toList $ Set.fromList [(n,t) | u@(Uni n) <- expUniverse' dag (toExp dag bodyExp), let Single t = expType dag u] + smpVars = Set.toList $ Set.fromList [(n,t) | s@Sampler {} <- expUniverse' dag (toExp dag bodyExp), let Single t = expType dag s, let Just n = Map.lookup s smpName] + ((clipE,posE,sizeE,oQ,oE,oT),(stmt,_)) = runState genSrc ([],IntMap.empty) + genSrc = do + --[posE'] <- genExp pos + a <- genExp pos + let [posE'] = {-trace ("let [posE'] = " ++ show a)-} a + [sizeE'] <- genExp size + clipE' <- concat <$> mapM genExp clips + (oQ',oE',oT') <- unzip3 <$> mapM genIExp (map (toExp dag) outs) + return (clipE',posE',sizeE',oQ',oE',oT') + oNames = [pack $ "v" ++ show i | i <- [0..]] + +codeGenGeometryShader :: DAG + -> Map Exp String + -> FetchPrimitive + -> [(ByteString,GLSL.InterpolationQualifier,InputType)] + -> Exp + -> (ByteString, [(ByteString,GLSL.InterpolationQualifier,InputType)]) +codeGenGeometryShader dag samplerNameMap inPrim inVars geomSh@(GeometryShader layerCount outPrim maxGenVertices funPrimCnt funPrim funVert) = (SB.concat [srcPre, src], outVars) + where +{- + done - uniforms + done - samplers + done - input variables + - output variables + + - primitive count expression + - primitive loop + - vertex loop +-} + srcPre = pack $ unlines $ + [ "#version 150 core" + , "#extension GL_EXT_gpu_shader4 : enable" + , "layout(" ++ cvtInputPrim inPrim ++ ") in;" + , "layout (" ++ cvtOutputPrim outPrim ++ ", max_vertices=" ++ show maxGenVertices ++ ") out;" + ] + src = SB.unlines $ + [ pp [uniform (unpack n) (toGLSLType t) | (n,t) <- uniVars] + , pp [uniform n (toGLSLType t) | (n,t) <- smpVars] + , pp [inVarArr (unpack n) iq (toGLSLType t) | (n,iq,t) <- inVars] + , pp [outVarIQ n iq (toGLSLType t) | n <- oNames | iq <- oQ | [t] <- oT] + , pack "void main ()" + -- , pack "{ for(int i = 0; i < gl_in.length(); i++) { gl_Position = gl_in[i].gl_Position; gl_PointSize = gl_in[i].gl_PointSize; EmitVertex(); } }" + , pack $! show $! pPrint $! Compound $ reverse stmt + ] + + pp a = pack $! show $! pPrint $! TranslationUnit a + uniVars = Set.toList $ Set.fromList [(n,t) | u@(Uni n) <- expUniverse' dag geomSh, let Single t = expType dag u] + smpVars = Set.toList $ Set.fromList [(n,t) | s@Sampler {} <- expUniverse' dag geomSh, let Single t = expType dag s, let Just n = Map.lookup s samplerNameMap] + + cvtInputPrim a = case a of + Points -> "points" + Lines -> "lines" + Triangles -> "triangles" + LinesAdjacency -> "lines_adjacency" + TrianglesAdjacency -> "triangles_adjacency" + + cvtOutputPrim a = case a of + TrianglesOutput -> "triangle_strip" + LinesOutput -> "line_strip" + PointsOutput -> "points" + + genExp :: Env -> ExpId -> CGen [Expr] + genExp = codeGenExp' dag samplerNameMap + + genIExp :: Env -> Exp -> CGen (GLSL.InterpolationQualifier,[Expr],[InputType]) + genIExp env (Flat e) = (GLSL.Flat,,codeGenType $ expIdType dag e) <$> genExp env e + genIExp env (Smooth e) = (GLSL.Smooth,,codeGenType $ expIdType dag e) <$> genExp env e + genIExp env (NoPerspective e) = (GLSL.NoPerspective,,codeGenType $ expIdType dag e) <$> genExp env e + + oNames = ["g" ++ show i | i <- [0..]] + ((oQ,oT),(stmt,_)) = runState genSrc ([],IntMap.empty) + outVars = zip3 (map pack oNames) oQ (concat oT) + genSrc = do + -- calculate how many primitives should we generate + -- create primitive loop (ends with EndPrimitive()) + -- create vertex loop (EmitVertex()) + let primCntBody = getBody funPrimCnt + primCntLam = funPrimCnt + primBody = getBody funPrim + vertBody = getBody funVert + vertLam = funVert + GeometryOut stE pE sE cE oE = toExp dag vertBody + --Tuple [iTy,Single Int] = expIdType dag primCntBody + Tuple iTyInt = expIdType dag primCntBody + iTy = Tuple $ take (length iTyInt-1) iTyInt + (inputTy,clipsTy) = case expIdType dag primCntLam of + Tuple it@((Tuple [Single V4F,Single Float,ct,_]):_) -> (it,ct) + it@(Tuple [Single V4F,Single Float,ct,_]) -> ([it],ct) + t -> error $ "clipsTy error: " ++ show t + vertStTy = expIdType dag vertLam + -- create expressions for input primitive vertices + primVert i = [pre ++ "gl_Position", pre ++ "gl_PointSize"] ++ + [pre ++ "gl_ClipDistance[" ++ show n ++ "]" | n <- [0..tySize clipsTy-1]] ++ + [unpack n ++ post | (n,_,_) <- inVars] + where + pre = "gl_in[" ++ i ++ "]." + post = "[" ++ i ++ "]" + inputVerts = map Variable $ concat [primVert (show i) | i <- [0..length inputTy-1]] + eCnt <- codeGenExp' dag samplerNameMap (V.singleton inputVerts) primCntBody + (_,varMapP) <- get + let (primStateE,[primCntE]) = splitAt (length eCnt - 1) eCnt + (stPS,stPE) = unzip $ [(varStmt n (toGLSLType ty) e, Variable n) | (e,ty,i) <- zip3 primStateE (codeGenType iTy) [0..], let n = "statePrim_" ++ show i] + primCntVar = Variable "primCnt" + primIdVar = Variable "gl_PrimitiveID" + layerVar = Variable "gl_Layer" + clipVars = [Variable $ "gl_ClipDistance[" ++ show i ++ "]" | i <- [0..]] + (resP,(sP,_)) = runState primLoop ([],varMapP) + primLoop = do + (primIdE:layerE:stPrimStVertCntVert) <- genExp (V.singleton stPE) primBody + let (stPrimE',xsE) = splitAt (length primStateE) stPrimStVertCntVert + (stVertE,[vertCntE]) = splitAt (length xsE - 1) xsE + (stVS,stVE) = unzip $ [(varStmt n (toGLSLType ty) e, Variable n) | (e,ty,i) <- zip3 stVertE (codeGenType vertStTy) [0..], let n = "stateVert_" ++ show i] + vertCntVar = GLSL.Variable "vertCnt" + mapM addStmt stVS + (_,varMapV) <- get + let (resV,(sV,_)) = runState genVertFun ([],varMapV) + genVertFun = do + let env = V.singleton stVE + genVert = genExp env + stVE' <- genVert stE + [posE] <- genVert pE + [sizeE] <- genVert sE + clipsE <- concat <$> mapM genVert cE + (oQ',oE',oT') <- unzip3 <$> mapM (genIExp env) (map (toExp dag) oE) + -- set vertex variables - position, size, clip distances, outputs + addStmt $ assign (Variable "gl_Position") posE + addStmt $ assign (Variable "gl_PointSize") sizeE + mapM_ addStmt $ zipWith assign clipVars clipsE + mapM_ addStmt $ zipWith assign (map Variable oNames) (concat oE') + addStmt $ ExpressionStatement $ Just $ functionCall "EmitVertex" [] + mapM_ addStmt $ zipWith assign stVE stVE' + return (oQ',oT') + addStmt $ varStmt "vertCnt" GLSL.Int vertCntE + addStmt $ assign primIdVar primIdE + addStmt $ assign layerVar layerE + addStmt $ GLSL.For (Left Nothing) + (Just $ GLSL.Condition $ GLSL.Gt vertCntVar (GLSL.IntConstant GLSL.Decimal 0)) + (Just $ GLSL.PostDec vertCntVar) + (CompoundStatement $ Compound $ reverse sV) + addStmt $ ExpressionStatement $ Just $ functionCall "EndPrimitive" [] + mapM_ addStmt $ zipWith assign stPE stPrimE' + return resV + mapM addStmt stPS + addStmt $ varStmt "primCnt" GLSL.Int primCntE + addStmt $ GLSL.For (Left Nothing) + (Just $ GLSL.Condition $ GLSL.Gt primCntVar (GLSL.IntConstant GLSL.Decimal 0)) + (Just $ GLSL.PostDec primCntVar) + (CompoundStatement $ Compound $ reverse sP) + return resP + + getBody a = b + where + Lam l = toExp dag a + Body b = toExp dag l + +codeGenFragmentShader :: DAG + -> Map Exp String + -> [(ByteString,GLSL.InterpolationQualifier,InputType)] + -> Exp + -> Exp + -> (ByteString, [(ByteString,InputType)],Int) +codeGenFragmentShader dag smpName inVars ffilter = cvt + where + cvtF :: Exp -> CGen Expr + cvtF (Lam lam) = cvtF $ toExp dag lam + cvtF (Body bodyExp) = do + [e] <- genExp bodyExp + return e + + cvt :: Exp -> (ByteString, [(ByteString,InputType)],Int) + cvt (Lam lam) = cvt $ toExp dag lam + cvt (Body bodyExp) = case toExp dag bodyExp of + FragmentOut e -> src e [] + FragmentOutDepth de e -> src e [("gl_FragDepth",de)] + FragmentOutRastDepth e -> src e [] + + genExp :: ExpId -> CGen [Expr] + genExp = codeGenExp' dag smpName $ V.singleton [Variable (unpack n) | (n,_,_) <- inVars] + + genFExp :: ExpId -> CGen ([Expr],[InputType]) + genFExp e = (,codeGenType $ expIdType dag e) <$> genExp e + + oNames :: [ByteString] + oNames = [pack $ "f" ++ show i | i <- [0..]] + + src :: [ExpId] -> [(ByteString,ExpId)] -> (ByteString, [(ByteString,InputType)],Int) + src outs outs' = (SB.unlines $! + [ "#version 150 core" + , "#extension GL_EXT_gpu_shader4 : enable" + -- , "#pragma optimize(off)" + , pp [uniform (unpack n) (toGLSLType t) | (n,t) <- uniVars] + , pp [uniform n (toGLSLType t) | (n,t) <- smpVars] + , pp [inVarIQ (unpack n) iq (toGLSLType t) | (n,iq,t) <- inVars] + , pp [outVar (unpack n) (toGLSLType t) | n <- oNames | [t] <- oT] + , "void main ()" + , ppBody $ case ffilter of + PassAll -> reverse stmt ++ body + Filter f -> reverse fstmt ++ [SelectionStatement (UnaryNot fexpr) Discard $ Just (CompoundStatement $ Compound $ reverse stmt ++ body)] + ], [(n,t) | n <- oNames | [t] <- oT], length outs) + where + assigns a e = [assign (Variable (unpack n)) ex | ex <- e | n <- a] + ppBody l = pack $! show $! pPrint $! Compound l + pp a = pack $! show $! pPrint $! TranslationUnit a + allExps = concat [expUniverse' dag outs, expUniverse' dag (map snd outs'), filterExps] + filterExps = case ffilter of + PassAll -> [] + Filter f -> expUniverse' dag f + uniVars = Set.toList $ Set.fromList [(n,t) | u@(Uni n) <- allExps, let Single t = expType dag u] + smpVars = Set.toList $ Set.fromList [(n,t) | s@Sampler {} <- allExps, let Single t = expType dag s, let Just n = Map.lookup s smpName] + body = assigns (oN' ++ oNames) (concat oE' ++ concat oE) + ((oE',oN',oE,oT,fstmt,fexpr),(stmt,_)) = runState genSrc ([],IntMap.empty) + genSrc = do + fexpr' <- case ffilter of + PassAll -> return $ boolC True + Filter f -> cvtF $ toExp dag f + (fstmt',s) <- get + put ([],s) + (oE'',oN'') <- unzip <$> sequence [(,n) <$> genExp e | (n,e) <- outs'] + (oE',oT') <- unzip <$> mapM genFExp outs + return (oE'',oN'',oE',oT',fstmt',fexpr') + + +codeGenType :: Ty -> [InputType] +codeGenType (Single ty) = [ty] +codeGenType (Tuple l) = concatMap codeGenType l +codeGenType t = error $ "codeGenType error: " ++ show t + +-- Utility functions +toGLSLType :: InputType -> TypeSpecifierNonArray +toGLSLType t = case t of + Bool -> GLSL.Bool + V2B -> GLSL.BVec2 + V3B -> GLSL.BVec3 + V4B -> GLSL.BVec4 + Word -> GLSL.UInt + V2U -> GLSL.UVec2 + V3U -> GLSL.UVec3 + V4U -> GLSL.UVec4 + Int -> GLSL.Int + V2I -> GLSL.IVec2 + V3I -> GLSL.IVec3 + V4I -> GLSL.IVec4 + Float -> GLSL.Float + V2F -> GLSL.Vec2 + V3F -> GLSL.Vec3 + V4F -> GLSL.Vec4 + M22F -> GLSL.Mat2 + M23F -> GLSL.Mat2x3 + M24F -> GLSL.Mat2x4 + M32F -> GLSL.Mat3x2 + M33F -> GLSL.Mat3 + M34F -> GLSL.Mat3x4 + M42F -> GLSL.Mat4x2 + M43F -> GLSL.Mat4x3 + M44F -> GLSL.Mat4 + -- shadow textures + STexture1D -> GLSL.Sampler1DShadow + STexture2D -> GLSL.Sampler2DShadow + STextureCube -> GLSL.SamplerCubeShadow + STexture1DArray -> GLSL.Sampler1DArrayShadow + STexture2DArray -> GLSL.Sampler2DArrayShadow + STexture2DRect -> GLSL.Sampler2DRectShadow + -- float textures + FTexture1D -> GLSL.Sampler1D + FTexture2D -> GLSL.Sampler2D + FTexture3D -> GLSL.Sampler3D + FTextureCube -> GLSL.SamplerCube + FTexture1DArray -> GLSL.Sampler1DArray + FTexture2DArray -> GLSL.Sampler2DArray + FTexture2DMS -> GLSL.Sampler2DMS + FTexture2DMSArray -> GLSL.Sampler2DMSArray + FTextureBuffer -> GLSL.SamplerBuffer + FTexture2DRect -> GLSL.Sampler2DRect + -- int textures + ITexture1D -> GLSL.ISampler1D + ITexture2D -> GLSL.ISampler2D + ITexture3D -> GLSL.ISampler3D + ITextureCube -> GLSL.ISamplerCube + ITexture1DArray -> GLSL.ISampler1DArray + ITexture2DArray -> GLSL.ISampler2DArray + ITexture2DMS -> GLSL.ISampler2DMS + ITexture2DMSArray -> GLSL.ISampler2DMSArray + ITextureBuffer -> GLSL.ISamplerBuffer + ITexture2DRect -> GLSL.ISampler2DRect + -- uint textures + UTexture1D -> GLSL.USampler1D + UTexture2D -> GLSL.USampler2D + UTexture3D -> GLSL.USampler3D + UTextureCube -> GLSL.USamplerCube + UTexture1DArray -> GLSL.USampler1DArray + UTexture2DArray -> GLSL.USampler2DArray + UTexture2DMS -> GLSL.USampler2DMS + UTexture2DMSArray -> GLSL.USampler2DMSArray + UTextureBuffer -> GLSL.USamplerBuffer + UTexture2DRect -> GLSL.USampler2DRect + +varInit :: String -> TypeSpecifierNonArray -> Maybe TypeQualifier -> Maybe Expr -> Declaration +varInit name ty tq val = InitDeclaration (TypeDeclarator varType) [InitDecl name Nothing val] + where + varTySpecNoPrec = TypeSpecNoPrecision ty Nothing + varTySpec = TypeSpec Nothing varTySpecNoPrec + varType = FullType tq varTySpec + +var :: String -> TypeSpecifierNonArray -> Maybe TypeQualifier -> Declaration +var name ty tq = varInit name ty tq Nothing + +uniform :: String -> TypeSpecifierNonArray -> ExternalDeclaration +uniform name ty = Declaration $ var name ty (Just $ TypeQualSto Uniform) + +inVar :: String -> TypeSpecifierNonArray -> ExternalDeclaration +inVar name ty = Declaration $ var name ty (Just $ TypeQualSto In) + +inVarArr :: String -> GLSL.InterpolationQualifier -> TypeSpecifierNonArray -> ExternalDeclaration +inVarArr name iq ty = Declaration $ InitDeclaration (TypeDeclarator varType) [InitDecl name Nothing Nothing] + where + tq = Just $ TypeQualInt iq $ Just In + varTySpecNoPrec = TypeSpecNoPrecision ty (Just Nothing) + varTySpec = TypeSpec Nothing varTySpecNoPrec + varType = FullType tq varTySpec + +inVarIQ :: String -> GLSL.InterpolationQualifier -> TypeSpecifierNonArray -> ExternalDeclaration +inVarIQ name iq ty = Declaration $ var name ty (Just $ TypeQualInt iq $ Just In) + +outVar :: String -> TypeSpecifierNonArray -> ExternalDeclaration +outVar name ty = Declaration $ var name ty (Just $ TypeQualSto Out) + +outVarIQ :: String -> GLSL.InterpolationQualifier -> TypeSpecifierNonArray -> ExternalDeclaration +outVarIQ name iq ty = Declaration $ var name ty (Just $ TypeQualInt iq $ Just Out) +{- +attribute :: String -> TypeSpecifierNonArray -> ExternalDeclaration +attribute name ty = Declaration $ var name ty (Just $ TypeQualSto Attribute) + +varying :: String -> TypeSpecifierNonArray -> ExternalDeclaration +varying name ty = Declaration $ var name ty (Just $ TypeQualSto Varying) + +varyingIQ :: String -> GLSL.InterpolationQualifier -> TypeSpecifierNonArray -> ExternalDeclaration +varyingIQ name iq ty = Declaration $ var name ty (Just $ TypeQualInt iq $ Just Varying) +-} +assign :: Expr -> Expr -> Statement +assign l r = ExpressionStatement $ Just $ Equal l r + +varStmt :: String -> TypeSpecifierNonArray -> Expr -> Statement +varStmt name ty val = DeclarationStatement $ varInit name ty Nothing $ Just val diff --git a/LC_B_GLType.hs b/LC_B_GLType.hs new file mode 100644 --- /dev/null +++ b/LC_B_GLType.hs @@ -0,0 +1,168 @@ +module LC_B_GLType where + +import Data.ByteString.Char8 (ByteString) +import Data.IORef +import Data.Word +import Data.Map (Map) +--import Data.IntMap (IntMap) +import Data.Set (Set) +import Data.Trie (Trie) +import Data.Vector.Unboxed.Mutable (IOVector) +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed.Mutable as MV + +import Graphics.Rendering.OpenGL.Raw.Core32 (GLint, GLuint) + +import LC_G_APIType +import LC_U_APIType +import LC_U_DeBruijn + +{- + we should store: + generic attributer setters (default values in that case when an attribute is missing from a mesh) + question: + should we provide default attributes or should we require a full attribute description from the user? + answer: the latter seems better idea! + question: + is a mesh object constant in vertex attributes? e.g. if we'd like to change the value of an attribute buffer or generic attribute + then we have to swap the old mesh object with a new one. + answer: seems a good and reasonable idea, because we can customize object rendering using per object uniforms! + PUBLIC: + - slotUniforms :: Trie (Trie InputType) + - slotStreams :: Trie (PrimitiveType, Trie InputType) + - uniformSetter :: Trie InputSetter + - render :: IO () + - dispose :: IO () + INTERNAL: + - object sets :: Trie (TVar ObjectSet) + - globalUniformSetup :: Trie (GLint -> IO ()) + - uniform setup actions :: Trie (STM (GLint -> IO (), InputSetter)) + - attribute setup actions :: Trie (GLuint -> StreamSetter) + + note: if we'd like to support slot sharing between different sub gfx networks, + then we have to check that they have the same primitve type and + there is no type collision if we build the union of they stream input + otherwise we can not support slot sharing. + should we use namespaces in stream input names? + e.g "slot name/atribute name" in this case we can store stream attribute descriptions in a single trie. + or should we use trie of tries? + discussion: + how to handle sub network uniform/attribute naming + - global all + - namespace prefix in name + - trie of tries + temporary decision: + i'll use global names + + minimal restricition for (global name) uniforms and attributes: + a name sould bound to only one type! + + TODO: + proper handling of attribute and uniform sharing between shader programs + two alternatives: + - use same mapping for every program (more efficient, but requires more gl features) + - use custom mapping per program with custom attribute/uniform setter (less efficient, but more compatible/less restricitive) +-} + +--------- +-- API -- +--------- +{- +-- Buffer + compileBuffer :: [Array] -> IO Buffer + bufferSize :: Buffer -> Int + arraySize :: Buffer -> Int -> Int + arrayType :: Buffer -> Int -> ArrayType + +-- Renderer + compileRenderer :: GPOutput -> IO Renderer + slotUniforms :: Renderer -> Trie (Trie InputType) + slotStreams :: Renderer -> Trie (PrimitiveType, Trie InputType) + uniformSetter :: Renderer -> Trie InputSetter + render :: Renderer -> IO () + dispose :: Renderer -> IO () + +-- Object + addObject :: Renderer -> ByteString -> Primitive -> Maybe (IndexStream Buffer) -> Trie (Stream Buffer) -> [ByteString] -> IO Object + removeObject :: Renderer -> Object -> IO () + objectUniformSetter :: Object -> Trie InputSetter +-} + +data Renderer -- internal type + = Renderer + -- public + { slotUniform :: Trie (Trie InputType) + , slotStream :: Trie (FetchPrimitive, Trie InputType) + , uniformSetter :: Trie InputSetter -- global uniform + , render :: IO () + , dispose :: IO () + , setScreenSize :: Word -> Word -> IO () + + -- internal + , mkUniformSetup :: Trie (GLint -> IO ()) -- global unifiorm + , slotDescriptor :: Trie SlotDescriptor + , renderDescriptor :: Map Exp RenderDescriptor --Map GP RenderDescriptor + , renderState :: RenderState + , objectIDSeed :: IORef Int + } + +data RenderDescriptor + = RenderDescriptor + { uniformLocation :: Trie GLint -- Uniform name -> GLint + , streamLocation :: Trie GLuint -- Attribute name -> GLuint + , renderAction :: IO () + , disposeAction :: IO () + , drawObjectsIORef :: IORef ObjectSet -- updated internally, according objectSet + -- hint: Map is required to support slot sharing across different Accumulation nodes, + -- because each node requires it's own render action list: [IO ()] + , fragmentOutCount :: Int + } + +data SlotDescriptor + = SlotDescriptor + { attachedGP :: Set Exp + , objectSet :: IORef (Set Object) -- objects, added to this slot (set by user) + } + +data ObjectSet + = ObjectSet + { drawObject :: IO () -- synthetized/sorted render action + , drawObjectMap :: Map Object (IO ()) -- original render actions + } + +data Object -- internal type + = Object + { objectSlotName :: ByteString + , objectUniformSetter :: Trie InputSetter + , objectID :: Int + , objectEnabledIORef :: IORef Bool + } + +instance Eq Object where + a == b = objectID a == objectID b + +instance Ord Object where + a `compare` b = objectID a `compare` objectID b + +data RenderState + = RenderState + { textureUnitState :: IOVector Int + } + +type StreamSetter = Stream Buffer -> IO () + +data Buffer -- internal type + = Buffer + { bufArrays :: V.Vector ArrayDesc + , bufGLObj :: GLuint + } + deriving (Show,Eq) + +data ArrayDesc + = ArrayDesc + { arrType :: ArrayType + , arrLength :: Int -- item count + , arrOffset :: Int -- byte position in buffer + , arrSize :: Int -- size in bytes + } + deriving (Show,Eq) diff --git a/LC_B_GLUtil.hs b/LC_B_GLUtil.hs new file mode 100644 --- /dev/null +++ b/LC_B_GLUtil.hs @@ -0,0 +1,972 @@ +module LC_B_GLUtil ( + queryUniforms, + queryStreams, + mkUniformSetter, + mkSSetter, + compileShader, + printProgramLog, + glGetShaderiv1, + glGetProgramiv1, + Buffer(..), + ArrayDesc(..), + StreamSetter, + streamToInputType, + arrayTypeToGLType, + comparisonFunctionToGLType, + logicOperationToGLType, + blendEquationToGLType, + blendingFactorToGLType, + checkGL, + textureDataTypeToGLType, + textureDataTypeToGLArityType, + glGetIntegerv1, + setSampler, + checkFBO, + createGLTextureObject +) where + +import Control.Applicative +import Control.Exception +import Control.Monad +import Data.ByteString.Char8 (ByteString) +import Data.IORef +import Data.List as L +import Data.Trie as T +import Foreign +import qualified Data.ByteString.Char8 as SB +import qualified Data.Vector as V +import Data.Vector.Unboxed.Mutable (IOVector) +import qualified Data.Vector.Unboxed.Mutable as MV + +import Graphics.Rendering.OpenGL.Raw.Core32 + ( GLchar + , GLenum + , GLint + , GLsizei + , GLuint + , gl_FALSE + , gl_TRUE + , glGetIntegerv + + -- ERROR CHECKING related + -- error handling + , glGetError + , glCheckFramebufferStatus + -- error checking + , gl_COMPILE_STATUS + , gl_DRAW_FRAMEBUFFER + , gl_FRAMEBUFFER_COMPLETE + , gl_FRAMEBUFFER_INCOMPLETE_ATTACHMENT + , gl_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER + , gl_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS + , gl_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE + , gl_FRAMEBUFFER_INCOMPLETE_READ_BUFFER + , gl_FRAMEBUFFER_UNDEFINED + , gl_FRAMEBUFFER_UNSUPPORTED + , gl_INFO_LOG_LENGTH + , gl_INVALID_ENUM + , gl_INVALID_FRAMEBUFFER_OPERATION + , gl_INVALID_OPERATION + , gl_INVALID_VALUE + , gl_NO_ERROR + , gl_OUT_OF_MEMORY + + -- TEXTURE related + -- texture data + , glActiveTexture + , glBindTexture + , glGenTextures + , glTexImage2D + , glTexImage3D + , glTexParameteri + , gl_TEXTURE0 + + -- texture parameters + , gl_CLAMP_TO_BORDER + , gl_CLAMP_TO_EDGE + , gl_MIRRORED_REPEAT + , gl_REPEAT + , gl_LINEAR + , gl_NEAREST + + , gl_TEXTURE_CUBE_MAP + , gl_TEXTURE_CUBE_MAP_POSITIVE_X + , gl_TEXTURE_CUBE_MAP_NEGATIVE_X + , gl_TEXTURE_CUBE_MAP_POSITIVE_Y + , gl_TEXTURE_CUBE_MAP_NEGATIVE_Y + , gl_TEXTURE_CUBE_MAP_POSITIVE_Z + , gl_TEXTURE_CUBE_MAP_NEGATIVE_Z + , gl_TEXTURE_2D + , gl_TEXTURE_2D_ARRAY + , gl_TEXTURE_MAG_FILTER + , gl_TEXTURE_MIN_FILTER + , gl_TEXTURE_WRAP_S + , gl_TEXTURE_WRAP_T + , gl_TEXTURE_BASE_LEVEL + , gl_TEXTURE_MAX_LEVEL + + -- texture format + , gl_R32F + , gl_R32I + , gl_R32UI + , gl_RED + , gl_RG + , gl_RG32F + , gl_RG32I + , gl_RG32UI + , gl_RGBA + , gl_RGBA32F + , gl_RGBA32I + , gl_RGBA32UI + + -- SHADER related + -- shader program + , glCompileShader + , glGetActiveAttrib + , glGetActiveUniform + , glGetAttribLocation + , glGetProgramInfoLog + , glGetProgramiv + , glGetShaderInfoLog + , glGetShaderiv + , glGetUniformLocation + , glShaderSource + + -- stream data (stream parameter) + , glBindBuffer + , glDisableVertexAttribArray + , glEnableVertexAttribArray + , glVertexAttrib1fv + , glVertexAttrib2fv + , glVertexAttrib3fv + , glVertexAttrib4fv + , glVertexAttribI1iv + , glVertexAttribI1uiv + , glVertexAttribI2iv + , glVertexAttribI2uiv + , glVertexAttribI3iv + , glVertexAttribI3uiv + , glVertexAttribI4iv + , glVertexAttribI4uiv + , glVertexAttribIPointer + , glVertexAttribPointer + , gl_ACTIVE_ATTRIBUTES + , gl_ACTIVE_ATTRIBUTE_MAX_LENGTH + , gl_ARRAY_BUFFER + + -- stream value representation + , gl_BYTE + , gl_HALF_FLOAT + , gl_SHORT + , gl_UNSIGNED_BYTE + , gl_UNSIGNED_SHORT + + -- uniform data (constant parameter) + , glUniform1fv + , glUniform1i + , glUniform1iv + , glUniform1uiv + , glUniform2fv + , glUniform2iv + , glUniform2uiv + , glUniform3fv + , glUniform3iv + , glUniform3uiv + , glUniform4fv + , glUniform4iv + , glUniform4uiv + , glUniformMatrix2fv + , glUniformMatrix2x3fv + , glUniformMatrix2x4fv + , glUniformMatrix3fv + , glUniformMatrix3x2fv + , glUniformMatrix3x4fv + , glUniformMatrix4fv + , glUniformMatrix4x2fv + , glUniformMatrix4x3fv + , gl_ACTIVE_UNIFORMS + , gl_ACTIVE_UNIFORM_MAX_LENGTH + + -- uniform types (constant value types) + , gl_BOOL + , gl_BOOL_VEC2 + , gl_BOOL_VEC3 + , gl_BOOL_VEC4 + , gl_FLOAT + , gl_FLOAT_MAT2 + , gl_FLOAT_MAT2x3 + , gl_FLOAT_MAT2x4 + , gl_FLOAT_MAT3 + , gl_FLOAT_MAT3x2 + , gl_FLOAT_MAT3x4 + , gl_FLOAT_MAT4 + , gl_FLOAT_MAT4x2 + , gl_FLOAT_MAT4x3 + , gl_FLOAT_VEC2 + , gl_FLOAT_VEC3 + , gl_FLOAT_VEC4 + , gl_INT + , gl_INT_SAMPLER_1D + , gl_INT_SAMPLER_1D_ARRAY + , gl_INT_SAMPLER_2D + , gl_INT_SAMPLER_2D_ARRAY + , gl_INT_SAMPLER_2D_MULTISAMPLE + , gl_INT_SAMPLER_2D_MULTISAMPLE_ARRAY + , gl_INT_SAMPLER_2D_RECT + , gl_INT_SAMPLER_3D + , gl_INT_SAMPLER_BUFFER + , gl_INT_SAMPLER_CUBE + , gl_INT_VEC2 + , gl_INT_VEC3 + , gl_INT_VEC4 + , gl_SAMPLER_1D + , gl_SAMPLER_1D_ARRAY + , gl_SAMPLER_1D_ARRAY_SHADOW + , gl_SAMPLER_1D_SHADOW + , gl_SAMPLER_2D + , gl_SAMPLER_2D_ARRAY + , gl_SAMPLER_2D_ARRAY_SHADOW + , gl_SAMPLER_2D_MULTISAMPLE + , gl_SAMPLER_2D_MULTISAMPLE_ARRAY + , gl_SAMPLER_2D_RECT + , gl_SAMPLER_2D_RECT_SHADOW + , gl_SAMPLER_2D_SHADOW + , gl_SAMPLER_3D + , gl_SAMPLER_BUFFER + , gl_SAMPLER_CUBE + , gl_SAMPLER_CUBE_SHADOW + , gl_UNSIGNED_INT + , gl_UNSIGNED_INT_SAMPLER_1D + , gl_UNSIGNED_INT_SAMPLER_1D_ARRAY + , gl_UNSIGNED_INT_SAMPLER_2D + , gl_UNSIGNED_INT_SAMPLER_2D_ARRAY + , gl_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE + , gl_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE_ARRAY + , gl_UNSIGNED_INT_SAMPLER_2D_RECT + , gl_UNSIGNED_INT_SAMPLER_3D + , gl_UNSIGNED_INT_SAMPLER_BUFFER + , gl_UNSIGNED_INT_SAMPLER_CUBE + , gl_UNSIGNED_INT_VEC2 + , gl_UNSIGNED_INT_VEC3 + , gl_UNSIGNED_INT_VEC4 + + -- CONTEXT PARAMETER realted + -- depth and stencil operation + , gl_ALWAYS + , gl_EQUAL + , gl_GEQUAL + , gl_GREATER + , gl_LEQUAL + , gl_LESS + , gl_NEVER + , gl_NOTEQUAL + + -- blending function + , gl_FUNC_ADD + , gl_FUNC_REVERSE_SUBTRACT + , gl_FUNC_SUBTRACT + , gl_MAX + , gl_MIN + + -- blending + , gl_CONSTANT_ALPHA + , gl_CONSTANT_COLOR + , gl_DST_ALPHA + , gl_DST_COLOR + , gl_ONE + , gl_ONE_MINUS_CONSTANT_ALPHA + , gl_ONE_MINUS_CONSTANT_COLOR + , gl_ONE_MINUS_DST_ALPHA + , gl_ONE_MINUS_DST_COLOR + , gl_ONE_MINUS_SRC_ALPHA + , gl_ONE_MINUS_SRC_COLOR + , gl_SRC_ALPHA + , gl_SRC_ALPHA_SATURATE + , gl_SRC_COLOR + , gl_ZERO + + -- logic operation + , gl_AND + , gl_AND_INVERTED + , gl_AND_REVERSE + , gl_CLEAR + , gl_COPY + , gl_COPY_INVERTED + , gl_EQUIV + , gl_INVERT + , gl_NAND + , gl_NOOP + , gl_NOR + , gl_OR + , gl_OR_INVERTED + , gl_OR_REVERSE + , gl_SET + , gl_XOR + ) + +import LC_G_Type +import LC_G_APIType +import LC_U_APIType +import LC_U_DeBruijn +import LC_B_GLType + +setSampler :: GLint -> Int32 -> IO () +setSampler i v = glUniform1i i $ fromIntegral v + +z2 = V2 0 0 :: V2F +z3 = V3 0 0 0 :: V3F +z4 = V4 0 0 0 0 :: V4F + +-- uniform functions +queryUniforms :: GLuint -> IO (Trie GLint, Trie InputType) +queryUniforms po = do + ul <- getNameTypeSize po glGetActiveUniform glGetUniformLocation gl_ACTIVE_UNIFORMS gl_ACTIVE_UNIFORM_MAX_LENGTH + let uNames = [n | (n,_,_,_) <- ul] + uTypes = [fromGLType (e,s) | (_,_,e,s) <- ul] + uLocation = [i | (_,i,_,_) <- ul] + return $! (T.fromList $! zip uNames uLocation, T.fromList $! zip uNames uTypes) + +mkUniformSetter :: RenderState -> InputType -> IO (GLint -> IO (), InputSetter) +mkUniformSetter _ Bool = do {t <- newIORef False; return $! (\i -> readIORef t >>= setUBool i, SBool $! writeIORef t)} +mkUniformSetter _ V2B = do {t <- newIORef (V2 False False); return $! (\i -> readIORef t >>= setUV2B i, SV2B $! writeIORef t)} +mkUniformSetter _ V3B = do {t <- newIORef (V3 False False False); return $! (\i -> readIORef t >>= setUV3B i, SV3B $! writeIORef t)} +mkUniformSetter _ V4B = do {t <- newIORef (V4 False False False False); return $! (\i -> readIORef t >>= setUV4B i, SV4B $! writeIORef t)} +mkUniformSetter _ Word = do {t <- newIORef 0; return $! (\i -> readIORef t >>= setUWord i, SWord $! writeIORef t)} +mkUniformSetter _ V2U = do {t <- newIORef (V2 0 0); return $! (\i -> readIORef t >>= setUV2U i, SV2U $! writeIORef t)} +mkUniformSetter _ V3U = do {t <- newIORef (V3 0 0 0); return $! (\i -> readIORef t >>= setUV3U i, SV3U $! writeIORef t)} +mkUniformSetter _ V4U = do {t <- newIORef (V4 0 0 0 0); return $! (\i -> readIORef t >>= setUV4U i, SV4U $! writeIORef t)} +mkUniformSetter _ Int = do {t <- newIORef 0; return $! (\i -> readIORef t >>= setUInt i, SInt $! writeIORef t)} +mkUniformSetter _ V2I = do {t <- newIORef (V2 0 0); return $! (\i -> readIORef t >>= setUV2I i, SV2I $! writeIORef t)} +mkUniformSetter _ V3I = do {t <- newIORef (V3 0 0 0); return $! (\i -> readIORef t >>= setUV3I i, SV3I $! writeIORef t)} +mkUniformSetter _ V4I = do {t <- newIORef (V4 0 0 0 0); return $! (\i -> readIORef t >>= setUV4I i, SV4I $! writeIORef t)} +mkUniformSetter _ Float = do {t <- newIORef 0; return $! (\i -> readIORef t >>= setUFloat i, SFloat $! writeIORef t)} +mkUniformSetter _ V2F = do {t <- newIORef (V2 0 0); return $! (\i -> readIORef t >>= setUV2F i, SV2F $! writeIORef t)} +mkUniformSetter _ V3F = do {t <- newIORef (V3 0 0 0); return $! (\i -> readIORef t >>= setUV3F i, SV3F $! writeIORef t)} +mkUniformSetter _ V4F = do {t <- newIORef (V4 0 0 0 0); return $! (\i -> readIORef t >>= setUV4F i, SV4F $! writeIORef t)} +mkUniformSetter _ M22F = do {t <- newIORef (V2 z2 z2); return $! (\i -> readIORef t >>= setUM22F i, SM22F $! writeIORef t)} +mkUniformSetter _ M23F = do {t <- newIORef (V3 z2 z2 z2); return $! (\i -> readIORef t >>= setUM23F i, SM23F $! writeIORef t)} +mkUniformSetter _ M24F = do {t <- newIORef (V4 z2 z2 z2 z2); return $! (\i -> readIORef t >>= setUM24F i, SM24F $! writeIORef t)} +mkUniformSetter _ M32F = do {t <- newIORef (V2 z3 z3); return $! (\i -> readIORef t >>= setUM32F i, SM32F $! writeIORef t)} +mkUniformSetter _ M33F = do {t <- newIORef (V3 z3 z3 z3); return $! (\i -> readIORef t >>= setUM33F i, SM33F $! writeIORef t)} +mkUniformSetter _ M34F = do {t <- newIORef (V4 z3 z3 z3 z3); return $! (\i -> readIORef t >>= setUM34F i, SM34F $! writeIORef t)} +mkUniformSetter _ M42F = do {t <- newIORef (V2 z4 z4); return $! (\i -> readIORef t >>= setUM42F i, SM42F $! writeIORef t)} +mkUniformSetter _ M43F = do {t <- newIORef (V3 z4 z4 z4); return $! (\i -> readIORef t >>= setUM43F i, SM43F $! writeIORef t)} +mkUniformSetter _ M44F = do {t <- newIORef (V4 z4 z4 z4 z4); return $! (\i -> readIORef t >>= setUM44F i, SM44F $! writeIORef t)} +mkUniformSetter rendState FTexture2D = do + let texUnitState = textureUnitState rendState + t <- newIORef (TextureData 0) + return $! (\i -> readIORef t >>= setTextureData texUnitState i, SFTexture2D $! writeIORef t) + +-- FIXME: implement properly +setTextureData :: IOVector Int -> GLint -> TextureData -> IO () +setTextureData texUnitState texUnitIdx (TextureData texObj) = do + let texUnitIdx' = fromIntegral texUnitIdx + texObj' = fromIntegral texObj + curTexObj <- MV.read texUnitState texUnitIdx' + when (curTexObj /= texObj') $ do + MV.write texUnitState texUnitIdx' texObj' + glActiveTexture $ gl_TEXTURE0 + fromIntegral texUnitIdx + glBindTexture gl_TEXTURE_2D texObj + --putStrLn (" -- uniform setup - Texture bind (TexUnit " ++ show (texUnitIdx,texObj) ++ " TexObj)") + +b2w :: Bool -> GLuint +b2w True = 1 +b2w False = 0 + +setUBool :: GLint -> Bool -> IO () +setUV2B :: GLint -> V2B -> IO () +setUV3B :: GLint -> V3B -> IO () +setUV4B :: GLint -> V4B -> IO () +setUBool i v = with (b2w v) $! \p -> glUniform1uiv i 1 p +setUV2B i (V2 x y) = with (V2 (b2w x) (b2w y)) $! \p -> glUniform2uiv i 1 $! castPtr p +setUV3B i (V3 x y z) = with (V3 (b2w x) (b2w y) (b2w z)) $! \p -> glUniform3uiv i 1 $! castPtr p +setUV4B i (V4 x y z w) = with (V4 (b2w x) (b2w y) (b2w z) (b2w w)) $! \p -> glUniform4uiv i 1 $! castPtr p + +setUWord :: GLint -> Word32 -> IO () +setUV2U :: GLint -> V2U -> IO () +setUV3U :: GLint -> V3U -> IO () +setUV4U :: GLint -> V4U -> IO () +setUWord i v = with v $! \p -> glUniform1uiv i 1 $! castPtr p +setUV2U i v = with v $! \p -> glUniform2uiv i 1 $! castPtr p +setUV3U i v = with v $! \p -> glUniform3uiv i 1 $! castPtr p +setUV4U i v = with v $! \p -> glUniform4uiv i 1 $! castPtr p + +setUInt :: GLint -> Int32 -> IO () +setUV2I :: GLint -> V2I -> IO () +setUV3I :: GLint -> V3I -> IO () +setUV4I :: GLint -> V4I -> IO () +setUInt i v = with v $! \p -> glUniform1iv i 1 $! castPtr p +setUV2I i v = with v $! \p -> glUniform2iv i 1 $! castPtr p +setUV3I i v = with v $! \p -> glUniform3iv i 1 $! castPtr p +setUV4I i v = with v $! \p -> glUniform4iv i 1 $! castPtr p + +setUFloat :: GLint -> Float -> IO () +setUV2F :: GLint -> V2F -> IO () +setUV3F :: GLint -> V3F -> IO () +setUV4F :: GLint -> V4F -> IO () +setUFloat i v = with v $! \p -> glUniform1fv i 1 $! castPtr p +setUV2F i v = with v $! \p -> glUniform2fv i 1 $! castPtr p +setUV3F i v = with v $! \p -> glUniform3fv i 1 $! castPtr p +setUV4F i v = with v $! \p -> glUniform4fv i 1 $! castPtr p + +setUM22F :: GLint -> M22F -> IO () +setUM23F :: GLint -> M23F -> IO () +setUM24F :: GLint -> M24F -> IO () +setUM22F i v = with v $! \p -> glUniformMatrix2fv i 1 (fromIntegral gl_FALSE) $! castPtr p +setUM23F i v = with v $! \p -> glUniformMatrix2x3fv i 1 (fromIntegral gl_FALSE) $! castPtr p +setUM24F i v = with v $! \p -> glUniformMatrix2x4fv i 1 (fromIntegral gl_FALSE) $! castPtr p + +setUM32F :: GLint -> M32F -> IO () +setUM33F :: GLint -> M33F -> IO () +setUM34F :: GLint -> M34F -> IO () +setUM32F i v = with v $! \p -> glUniformMatrix3x2fv i 1 (fromIntegral gl_FALSE) $! castPtr p +setUM33F i v = with v $! \p -> glUniformMatrix3fv i 1 (fromIntegral gl_FALSE) $! castPtr p +setUM34F i v = with v $! \p -> glUniformMatrix3x4fv i 1 (fromIntegral gl_FALSE) $! castPtr p + +setUM42F :: GLint -> M42F -> IO () +setUM43F :: GLint -> M43F -> IO () +setUM44F :: GLint -> M44F -> IO () +setUM42F i v = with v $! \p -> glUniformMatrix4x2fv i 1 (fromIntegral gl_FALSE) $! castPtr p +setUM43F i v = with v $! \p -> glUniformMatrix4x3fv i 1 (fromIntegral gl_FALSE) $! castPtr p +setUM44F i v = with v $! \p -> glUniformMatrix4fv i 1 (fromIntegral gl_FALSE) $! castPtr p + +-- attribute functions +queryStreams :: GLuint -> IO (Trie GLuint, Trie InputType) +queryStreams po = do + al <- getNameTypeSize po glGetActiveAttrib glGetAttribLocation gl_ACTIVE_ATTRIBUTES gl_ACTIVE_ATTRIBUTE_MAX_LENGTH + let aNames = [n | (n,_,_,_) <- al] + aTypes = [fromGLType (e,s) | (_,_,e,s) <- al] + aLocation = [fromIntegral i | (_,i,_,_) <- al] + return $! (T.fromList $! zip aNames aLocation, T.fromList $! zip aNames aTypes) + +-- should handle constant value and buffer value as well +mkSSetter :: InputType -> GLuint -> StreamSetter +mkSSetter Word i (ConstWord v) = setAWord i v +mkSSetter V2U i (ConstV2U v) = setAV2U i v +mkSSetter V3U i (ConstV3U v) = setAV3U i v +mkSSetter V4U i (ConstV4U v) = setAV4U i v +mkSSetter Word i (Stream TWord b a s l) = setBufInteger 1 i b a s +mkSSetter V2U i (Stream TV2U b a s l) = setBufInteger 2 i b a s +mkSSetter V3U i (Stream TV3U b a s l) = setBufInteger 3 i b a s +mkSSetter V4U i (Stream TV4U b a s l) = setBufInteger 4 i b a s + +mkSSetter Int i (ConstInt v) = setAInt i v +mkSSetter V2I i (ConstV2I v) = setAV2I i v +mkSSetter V3I i (ConstV3I v) = setAV3I i v +mkSSetter V4I i (ConstV4I v) = setAV4I i v +mkSSetter Int i (Stream TInt b a s l) = setBufInteger 1 i b a s +mkSSetter V2I i (Stream TV2I b a s l) = setBufInteger 2 i b a s +mkSSetter V3I i (Stream TV3I b a s l) = setBufInteger 3 i b a s +mkSSetter V4I i (Stream TV4I b a s l) = setBufInteger 4 i b a s + +mkSSetter Float i (ConstFloat v) = setAFloat i v +mkSSetter V2F i (ConstV2F v) = setAV2F i v +mkSSetter V3F i (ConstV3F v) = setAV3F i v +mkSSetter V4F i (ConstV4F v) = setAV4F i v +mkSSetter Float i (Stream TFloat b a s l) = setBufFloat 1 i b a s +mkSSetter V2F i (Stream TV2F b a s l) = setBufFloat 2 i b a s +mkSSetter V3F i (Stream TV3F b a s l) = setBufFloat 3 i b a s +mkSSetter V4F i (Stream TV4F b a s l) = setBufFloat 4 i b a s + +mkSSetter M22F i (ConstM22F v) = setAM22F i v +mkSSetter M23F i (ConstM23F v) = setAM23F i v +mkSSetter M24F i (ConstM24F v) = setAM24F i v +mkSSetter M22F i (Stream TM22F b a s l) = setBufFloat 4 i b a s +mkSSetter M23F i (Stream TM23F b a s l) = setBufFloat 6 i b a s +mkSSetter M24F i (Stream TM24F b a s l) = setBufFloat 8 i b a s + +mkSSetter M32F i (ConstM32F v) = setAM32F i v +mkSSetter M33F i (ConstM33F v) = setAM33F i v +mkSSetter M34F i (ConstM34F v) = setAM34F i v +mkSSetter M32F i (Stream TM32F b a s l) = setBufFloat 6 i b a s +mkSSetter M33F i (Stream TM33F b a s l) = setBufFloat 9 i b a s +mkSSetter M34F i (Stream TM34F b a s l) = setBufFloat 12 i b a s + +mkSSetter M42F i (ConstM42F v) = setAM42F i v +mkSSetter M43F i (ConstM43F v) = setAM43F i v +mkSSetter M44F i (ConstM44F v) = setAM44F i v +mkSSetter M42F i (Stream TM42F b a s l) = setBufFloat 8 i b a s +mkSSetter M43F i (Stream TM43F b a s l) = setBufFloat 12 i b a s +mkSSetter M44F i (Stream TM44F b a s l) = setBufFloat 16 i b a s +mkSSetter _ _ _ = fail "mkSSetter type mismatch!" + +arrayTypeToGLType :: ArrayType -> GLenum +arrayTypeToGLType ArrWord8 = gl_UNSIGNED_BYTE +arrayTypeToGLType ArrWord16 = gl_UNSIGNED_SHORT +arrayTypeToGLType ArrWord32 = gl_UNSIGNED_INT +arrayTypeToGLType ArrInt8 = gl_BYTE +arrayTypeToGLType ArrInt16 = gl_SHORT +arrayTypeToGLType ArrInt32 = gl_INT +arrayTypeToGLType ArrFloat = gl_FLOAT +arrayTypeToGLType ArrHalf = gl_HALF_FLOAT + +setBufFloat :: GLint -> GLuint -> Buffer -> Int -> Int -> IO () +setBufFloat compCnt i (Buffer arrs bo) arrIdx start = do + let ArrayDesc arrType arrLen arrOffs arrSize = arrs V.! arrIdx + glType = arrayTypeToGLType arrType + ptr = intPtrToPtr $! fromIntegral (arrOffs + start * fromIntegral compCnt * sizeOfArrayType arrType) + glBindBuffer gl_ARRAY_BUFFER bo + glEnableVertexAttribArray i + glVertexAttribPointer i compCnt glType (fromIntegral gl_FALSE) 0 ptr + +setBufInteger :: GLint -> GLuint -> Buffer -> Int -> Int -> IO () +--setBufInteger = setBufFloat -- FIXME: GL 2.1 does not have glVertexAttribIPointer +setBufInteger compCnt i (Buffer arrs bo) arrIdx start = do + let ArrayDesc arrType arrLen arrOffs arrSize = arrs V.! arrIdx + glType = arrayTypeToGLType arrType + ptr = intPtrToPtr $! fromIntegral (arrOffs + start * fromIntegral compCnt * sizeOfArrayType arrType) + glBindBuffer gl_ARRAY_BUFFER bo + glEnableVertexAttribArray i + -- GL 3.X version + glVertexAttribIPointer i compCnt glType 0 ptr + +setAWord :: GLuint -> Word32 -> IO () +setAV2U :: GLuint -> V2U -> IO () +setAV3U :: GLuint -> V3U -> IO () +setAV4U :: GLuint -> V4U -> IO () +setAWord i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI1uiv i $! castPtr p) +setAV2U i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI2uiv i $! castPtr p) +setAV3U i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI3uiv i $! castPtr p) +setAV4U i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI4uiv i $! castPtr p) + +setAInt :: GLuint -> Int32 -> IO () +setAV2I :: GLuint -> V2I -> IO () +setAV3I :: GLuint -> V3I -> IO () +setAV4I :: GLuint -> V4I -> IO () +setAInt i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI1iv i $! castPtr p) +setAV2I i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI2iv i $! castPtr p) +setAV3I i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI3iv i $! castPtr p) +setAV4I i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI4iv i $! castPtr p) + +setAFloat :: GLuint -> Float -> IO () +setAV2F :: GLuint -> V2F -> IO () +setAV3F :: GLuint -> V3F -> IO () +setAV4F :: GLuint -> V4F -> IO () +setAFloat i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttrib1fv i $! castPtr p) +setAV2F i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttrib2fv i $! castPtr p) +setAV3F i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttrib3fv i $! castPtr p) +setAV4F i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttrib4fv i $! castPtr p) + +setAM22F :: GLuint -> M22F -> IO () +setAM23F :: GLuint -> M23F -> IO () +setAM24F :: GLuint -> M24F -> IO () +setAM22F i (V2 x y) = setAV2F i x >> setAV2F (i+1) y +setAM23F i (V3 x y z) = setAV2F i x >> setAV2F (i+1) y >> setAV2F (i+2) z +setAM24F i (V4 x y z w) = setAV2F i x >> setAV2F (i+1) y >> setAV2F (i+2) z >> setAV2F (i+3) w + +setAM32F :: GLuint -> M32F -> IO () +setAM33F :: GLuint -> M33F -> IO () +setAM34F :: GLuint -> M34F -> IO () +setAM32F i (V2 x y) = setAV3F i x >> setAV3F (i+1) y +setAM33F i (V3 x y z) = setAV3F i x >> setAV3F (i+1) y >> setAV3F (i+2) z +setAM34F i (V4 x y z w) = setAV3F i x >> setAV3F (i+1) y >> setAV3F (i+2) z >> setAV3F (i+3) w + +setAM42F :: GLuint -> M42F -> IO () +setAM43F :: GLuint -> M43F -> IO () +setAM44F :: GLuint -> M44F -> IO () +setAM42F i (V2 x y) = setAV4F i x >> setAV4F (i+1) y +setAM43F i (V3 x y z) = setAV4F i x >> setAV4F (i+1) y >> setAV4F (i+2) z +setAM44F i (V4 x y z w) = setAV4F i x >> setAV4F (i+1) y >> setAV4F (i+2) z >> setAV4F (i+3) w + +-- result list: [(name string,location,gl type,component count)] +getNameTypeSize :: GLuint -> (GLuint -> GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLint -> Ptr GLenum -> Ptr GLchar -> IO ()) + -> (GLuint -> Ptr GLchar -> IO GLint) -> GLenum -> GLenum -> IO [(ByteString,GLint,GLenum,GLint)] +getNameTypeSize o f g enum enumLen = do + nameLen <- glGetProgramiv1 enumLen o + allocaArray (fromIntegral nameLen) $! \namep -> alloca $! \sizep -> alloca $! \typep -> do + n <- glGetProgramiv1 enum o + forM [0..n-1] $! \i -> f o (fromIntegral i) (fromIntegral nameLen) nullPtr sizep typep namep >> + (,,,) <$> SB.packCString (castPtr namep) <*> g o namep <*> peek typep <*> peek sizep +{- +filterSamplers :: [(ByteString,GLint,GLenum,GLint)] -> ([(ByteString,GLint,GLenum,GLint)],[(ByteString,GLint,GLenum,GLint)]) +filterSamplers l = partition (\(_,_,e,_) -> elem e samplerTypes) l + where + samplerTypes = [gl_SAMPLER_2D] +-} +fromGLType :: (GLenum,GLint) -> InputType +fromGLType (t,1) + | t == gl_BOOL = Bool + | t == gl_BOOL_VEC2 = V2B + | t == gl_BOOL_VEC3 = V3B + | t == gl_BOOL_VEC4 = V4B + | t == gl_UNSIGNED_INT = Word + | t == gl_UNSIGNED_INT_VEC2 = V2U + | t == gl_UNSIGNED_INT_VEC3 = V3U + | t == gl_UNSIGNED_INT_VEC4 = V4U + | t == gl_INT = Int + | t == gl_INT_VEC2 = V2I + | t == gl_INT_VEC3 = V3I + | t == gl_INT_VEC4 = V4I + | t == gl_FLOAT = Float + | t == gl_FLOAT_VEC2 = V2F + | t == gl_FLOAT_VEC3 = V3F + | t == gl_FLOAT_VEC4 = V4F + | t == gl_FLOAT_MAT2 = M22F + | t == gl_FLOAT_MAT2x3 = M23F + | t == gl_FLOAT_MAT2x4 = M24F + | t == gl_FLOAT_MAT3x2 = M32F + | t == gl_FLOAT_MAT3 = M33F + | t == gl_FLOAT_MAT3x4 = M34F + | t == gl_FLOAT_MAT4x2 = M42F + | t == gl_FLOAT_MAT4x3 = M43F + | t == gl_FLOAT_MAT4 = M44F + | t == gl_SAMPLER_1D_ARRAY_SHADOW = STexture1DArray + | t == gl_SAMPLER_1D_SHADOW = STexture1D + | t == gl_SAMPLER_2D_ARRAY_SHADOW = STexture2DArray + | t == gl_SAMPLER_2D_RECT_SHADOW = STexture2DRect + | t == gl_SAMPLER_2D_SHADOW = STexture2D + | t == gl_SAMPLER_CUBE_SHADOW = STextureCube + | t == gl_INT_SAMPLER_1D = ITexture1D + | t == gl_INT_SAMPLER_1D_ARRAY = ITexture1DArray + | t == gl_INT_SAMPLER_2D = ITexture2D + | t == gl_INT_SAMPLER_2D_ARRAY = ITexture2DArray + | t == gl_INT_SAMPLER_2D_MULTISAMPLE = ITexture2DMS + | t == gl_INT_SAMPLER_2D_MULTISAMPLE_ARRAY = ITexture2DMSArray + | t == gl_INT_SAMPLER_2D_RECT = ITexture2DRect + | t == gl_INT_SAMPLER_3D = ITexture3D + | t == gl_INT_SAMPLER_BUFFER = ITextureBuffer + | t == gl_INT_SAMPLER_CUBE = ITextureCube + | t == gl_SAMPLER_1D = FTexture1D + | t == gl_SAMPLER_1D_ARRAY = FTexture1DArray + | t == gl_SAMPLER_2D = FTexture2D + | t == gl_SAMPLER_2D_ARRAY = FTexture2DArray + | t == gl_SAMPLER_2D_MULTISAMPLE = FTexture2DMS + | t == gl_SAMPLER_2D_MULTISAMPLE_ARRAY = FTexture2DMSArray + | t == gl_SAMPLER_2D_RECT = FTexture2DRect + | t == gl_SAMPLER_3D = FTexture3D + | t == gl_SAMPLER_BUFFER = FTextureBuffer + | t == gl_SAMPLER_CUBE = FTextureCube + | t == gl_UNSIGNED_INT_SAMPLER_1D = UTexture1D + | t == gl_UNSIGNED_INT_SAMPLER_1D_ARRAY = UTexture1DArray + | t == gl_UNSIGNED_INT_SAMPLER_2D = UTexture2D + | t == gl_UNSIGNED_INT_SAMPLER_2D_ARRAY = UTexture2DArray + | t == gl_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE = UTexture2DMS + | t == gl_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE_ARRAY = UTexture2DMSArray + | t == gl_UNSIGNED_INT_SAMPLER_2D_RECT = UTexture2DRect + | t == gl_UNSIGNED_INT_SAMPLER_3D = UTexture3D + | t == gl_UNSIGNED_INT_SAMPLER_BUFFER = UTextureBuffer + | t == gl_UNSIGNED_INT_SAMPLER_CUBE = UTextureCube + | otherwise = error "Failed fromGLType" +fromGLUniformType _ = error "Failed fromGLType" + +printShaderLog :: GLuint -> IO () +printShaderLog o = do + i <- glGetShaderiv1 gl_INFO_LOG_LENGTH o + allocaArray (fromIntegral i) $! \ps -> glGetShaderInfoLog o (fromIntegral i) nullPtr ps >> SB.packCString (castPtr ps) >>= SB.putStr + +glGetShaderiv1 :: GLenum -> GLuint -> IO GLint +glGetShaderiv1 pname o = alloca $! \pi -> glGetShaderiv o pname pi >> peek pi + +glGetProgramiv1 :: GLenum -> GLuint -> IO GLint +glGetProgramiv1 pname o = alloca $! \pi -> glGetProgramiv o pname pi >> peek pi + +printProgramLog :: GLuint -> IO () +printProgramLog o = do + i <- glGetProgramiv1 gl_INFO_LOG_LENGTH o + allocaArray (fromIntegral i) $! \ps -> glGetProgramInfoLog o (fromIntegral i) nullPtr ps >> SB.packCString (castPtr ps) >>= SB.putStr + +compileShader :: GLuint -> [ByteString] -> IO () +compileShader o srcl = withMany SB.useAsCString srcl $! \l -> withArray l $! \p -> do + glShaderSource o (fromIntegral $! length srcl) (castPtr p) nullPtr + glCompileShader o + printShaderLog o + status <- glGetShaderiv1 gl_COMPILE_STATUS o + when (status /= fromIntegral gl_TRUE) $ fail "compileShader failed!" + +checkGL :: IO ByteString +checkGL = do + let f e | e == gl_INVALID_ENUM = "INVALID_ENUM" + | e == gl_INVALID_VALUE = "INVALID_VALUE" + | e == gl_INVALID_OPERATION = "INVALID_OPERATION" + | e == gl_INVALID_FRAMEBUFFER_OPERATION = "INVALID_FRAMEBUFFER_OPERATION" + | e == gl_OUT_OF_MEMORY = "OUT_OF_MEMORY" + | e == gl_NO_ERROR = "OK" + | otherwise = "Unknown error" + e <- glGetError + return $ f e + +streamToInputType :: Stream Buffer -> InputType +streamToInputType (ConstWord _) = Word +streamToInputType (ConstV2U _) = V2U +streamToInputType (ConstV3U _) = V3U +streamToInputType (ConstV4U _) = V4U +streamToInputType (ConstInt _) = Int +streamToInputType (ConstV2I _) = V2I +streamToInputType (ConstV3I _) = V3I +streamToInputType (ConstV4I _) = V4I +streamToInputType (ConstFloat _) = Float +streamToInputType (ConstV2F _) = V2F +streamToInputType (ConstV3F _) = V3F +streamToInputType (ConstV4F _) = V4F +streamToInputType (ConstM22F _) = M22F +streamToInputType (ConstM23F _) = M23F +streamToInputType (ConstM24F _) = M24F +streamToInputType (ConstM32F _) = M32F +streamToInputType (ConstM33F _) = M33F +streamToInputType (ConstM34F _) = M34F +streamToInputType (ConstM42F _) = M42F +streamToInputType (ConstM43F _) = M43F +streamToInputType (ConstM44F _) = M44F +streamToInputType (Stream t (Buffer a _) i _ _) + | 0 <= i && i < V.length a && + if elem t integralTypes then elem at integralArrTypes else True + = fromStreamType t + | otherwise = throw $ userError "streamToInputType failed" + where + at = arrType $! (a V.! i) + integralTypes = [TWord, TV2U, TV3U, TV4U, TInt, TV2I, TV3I, TV4I] + integralArrTypes = [ArrWord8, ArrWord16, ArrWord32, ArrInt8, ArrInt16, ArrInt32] + +comparisonFunctionToGLType :: ComparisonFunction -> GLenum +comparisonFunctionToGLType Always = gl_ALWAYS +comparisonFunctionToGLType Equal = gl_EQUAL +comparisonFunctionToGLType Gequal = gl_GEQUAL +comparisonFunctionToGLType Greater = gl_GREATER +comparisonFunctionToGLType Lequal = gl_LEQUAL +comparisonFunctionToGLType Less = gl_LESS +comparisonFunctionToGLType Never = gl_NEVER +comparisonFunctionToGLType Notequal = gl_NOTEQUAL + +logicOperationToGLType :: LogicOperation -> GLenum +logicOperationToGLType And = gl_AND +logicOperationToGLType AndInverted = gl_AND_INVERTED +logicOperationToGLType AndReverse = gl_AND_REVERSE +logicOperationToGLType Clear = gl_CLEAR +logicOperationToGLType Copy = gl_COPY +logicOperationToGLType CopyInverted = gl_COPY_INVERTED +logicOperationToGLType Equiv = gl_EQUIV +logicOperationToGLType Invert = gl_INVERT +logicOperationToGLType Nand = gl_NAND +logicOperationToGLType Noop = gl_NOOP +logicOperationToGLType Nor = gl_NOR +logicOperationToGLType Or = gl_OR +logicOperationToGLType OrInverted = gl_OR_INVERTED +logicOperationToGLType OrReverse = gl_OR_REVERSE +logicOperationToGLType Set = gl_SET +logicOperationToGLType Xor = gl_XOR + +blendEquationToGLType :: BlendEquation -> GLenum +blendEquationToGLType FuncAdd = gl_FUNC_ADD +blendEquationToGLType FuncReverseSubtract = gl_FUNC_REVERSE_SUBTRACT +blendEquationToGLType FuncSubtract = gl_FUNC_SUBTRACT +blendEquationToGLType Max = gl_MAX +blendEquationToGLType Min = gl_MIN + +blendingFactorToGLType :: BlendingFactor -> GLenum +blendingFactorToGLType ConstantAlpha = gl_CONSTANT_ALPHA +blendingFactorToGLType ConstantColor = gl_CONSTANT_COLOR +blendingFactorToGLType DstAlpha = gl_DST_ALPHA +blendingFactorToGLType DstColor = gl_DST_COLOR +blendingFactorToGLType One = gl_ONE +blendingFactorToGLType OneMinusConstantAlpha = gl_ONE_MINUS_CONSTANT_ALPHA +blendingFactorToGLType OneMinusConstantColor = gl_ONE_MINUS_CONSTANT_COLOR +blendingFactorToGLType OneMinusDstAlpha = gl_ONE_MINUS_DST_ALPHA +blendingFactorToGLType OneMinusDstColor = gl_ONE_MINUS_DST_COLOR +blendingFactorToGLType OneMinusSrcAlpha = gl_ONE_MINUS_SRC_ALPHA +blendingFactorToGLType OneMinusSrcColor = gl_ONE_MINUS_SRC_COLOR +blendingFactorToGLType SrcAlpha = gl_SRC_ALPHA +blendingFactorToGLType SrcAlphaSaturate = gl_SRC_ALPHA_SATURATE +blendingFactorToGLType SrcColor = gl_SRC_COLOR +blendingFactorToGLType Zero = gl_ZERO + +{- +data ColorArity = Red | RG | RGB | RGBA deriving (Show,Eq,Ord) +data TextureDataType + = FloatT ColorArity + | IntT ColorArity + | WordT ColorArity + | ShadowT + deriving (Show, Eq, Ord) +-} +textureDataTypeToGLType :: TextureDataType -> GLenum +textureDataTypeToGLType (FloatT Red) = gl_R32F +textureDataTypeToGLType (IntT Red) = gl_R32I +textureDataTypeToGLType (WordT Red) = gl_R32UI +textureDataTypeToGLType (FloatT RG) = gl_RG32F +textureDataTypeToGLType (IntT RG) = gl_RG32I +textureDataTypeToGLType (WordT RG) = gl_RG32UI +textureDataTypeToGLType (FloatT RGBA) = gl_RGBA32F +textureDataTypeToGLType (IntT RGBA) = gl_RGBA32I +textureDataTypeToGLType (WordT RGBA) = gl_RGBA32UI +textureDataTypeToGLType a = error $ "FIXME: This texture format is not yet supported" ++ show a + +textureDataTypeToGLArityType :: TextureDataType -> GLenum +textureDataTypeToGLArityType (FloatT Red) = gl_RED +textureDataTypeToGLArityType (IntT Red) = gl_RED +textureDataTypeToGLArityType (WordT Red) = gl_RED +textureDataTypeToGLArityType (FloatT RG) = gl_RG +textureDataTypeToGLArityType (IntT RG) = gl_RG +textureDataTypeToGLArityType (WordT RG) = gl_RG +textureDataTypeToGLArityType (FloatT RGBA) = gl_RGBA +textureDataTypeToGLArityType (IntT RGBA) = gl_RGBA +textureDataTypeToGLArityType (WordT RGBA) = gl_RGBA +textureDataTypeToGLArityType a = error $ "FIXME: This texture format is not yet supported" ++ show a +{- +Texture and renderbuffer color formats (R): + R11F_G11F_B10F + R16 + R16F + R16I + R16UI + R32F + R32I + R32UI + R8 + R8I + R8UI + RG16 + RG16F + RG16I + RG16UI + RG32F + RG32I + RG32UI + RG8 + RG8I + RG8UI + RGB10_A2 + RGB10_A2UI + RGBA16 + RGBA16F + RGBA16I + RGBA16UI + RGBA32F + RGBA32I + RGBA32UI + RGBA8 + RGBA8I + RGBA8UI + SRGB8_ALPHA8 +-} + +glGetIntegerv1 :: GLenum -> IO GLint +glGetIntegerv1 e = alloca $ \pi -> glGetIntegerv e pi >> peek pi + +checkFBO :: IO ByteString +checkFBO = do + let f e | e == gl_FRAMEBUFFER_UNDEFINED = "FRAMEBUFFER_UNDEFINED" + | e == gl_FRAMEBUFFER_INCOMPLETE_ATTACHMENT = "FRAMEBUFFER_INCOMPLETE_ATTACHMENT" + | e == gl_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER = "FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER" + | e == gl_FRAMEBUFFER_INCOMPLETE_READ_BUFFER = "FRAMEBUFFER_INCOMPLETE_READ_BUFFER" + | e == gl_FRAMEBUFFER_UNSUPPORTED = "FRAMEBUFFER_UNSUPPORTED" + | e == gl_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE = "FRAMEBUFFER_INCOMPLETE_MULTISAMPLE" + | e == gl_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS = "FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS" + | e == gl_FRAMEBUFFER_COMPLETE = "FRAMEBUFFER_COMPLETE" + | otherwise = "Unknown error" + e <- glCheckFramebufferStatus gl_DRAW_FRAMEBUFFER + return $ f e + +{- +data TextureDataType - gl internal representation + = FloatT ColorArity + | IntT ColorArity + | WordT ColorArity + | ShadowT + deriving (Show, Eq, Ord) + +data TextureType - gl texture target + = Texture1D TextureDataType Int + | Texture2D TextureDataType Int + | Texture3D TextureDataType + | TextureCube TextureDataType + | TextureRect TextureDataType + | Texture2DMS TextureDataType Int + | TextureBuffer TextureDataType + deriving (Show, Eq, Ord) +-} +createGLTextureObject :: DAG -> Exp -> IO GLuint +createGLTextureObject dag (Sampler txFilter txEdgeMode tx) = do + let Texture txType txSize txMipMap txGPList = toExp dag tx + wrapMode = case txEdgeMode of + Repeat -> gl_REPEAT + MirroredRepeat -> gl_MIRRORED_REPEAT + ClampToEdge -> gl_CLAMP_TO_EDGE + ClampToBorder -> gl_CLAMP_TO_BORDER + filterMode = case txFilter of + PointFilter -> gl_NEAREST + LinearFilter -> gl_LINEAR + to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto + {- + void glTexImage1D( GLenum target, GLint level, GLint internalformat, GLsizei width, GLint border, GLenum format, GLenum type, void *data ); + void glTexImage2D( GLenum target, GLint level, GLint internalformat, GLsizei width, GLsizei height, GLint border, GLenum format, GLenum type, void *data ); + void glTexImage3D( GLenum target, GLint level, GLint internalformat, GLsizei width, GLsizei height, GLsizei depth, GLint border, GLenum format, GLenum type, void *data ); + void glTexImage2DMultisample( GLenum target, GLsizei samples, GLint internalformat, GLsizei width, GLsizei height, GLboolean fixedsamplelocations ); + void glTexImage3DMultisample( GLenum target, GLsizei samples, GLint internalformat, GLsizei width, GLsizei height, GLsizei depth, GLboolean fixedsamplelocations ); + -} + -- FIXME: for now we support only single 2D texture + case txType of + {- + Texture1D dTy n -> return () + Texture2D dTy n -> return () + Texture3D dTy -> return () + TextureCube dTy -> return () + TextureRect dTy -> return () + Texture2DMS dTy n -> return () + TextureBuffer dTy -> return () + -} +{- + let (width,height) = bitmapSize bitmap + wrapMode = case isClamped of + True -> gl_CLAMP_TO_EDGE + False -> gl_REPEAT + (minFilter,maxLevel) = case isMip of + False -> (gl_LINEAR,0) + True -> (gl_LINEAR_MIPMAP_LINEAR, floor $ log (fromIntegral $ max width height) / log 2) + glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_S $ fromIntegral wrapMode + glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_T $ fromIntegral wrapMode + glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MIN_FILTER $ fromIntegral minFilter + glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAG_FILTER $ fromIntegral gl_LINEAR + glTexParameteri gl_TEXTURE_2D gl_TEXTURE_BASE_LEVEL 0 + glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAX_LEVEL $ fromIntegral maxLevel + withBitmap bitmap $ \(w,h) nchn 0 ptr -> do + let internalFormat = fromIntegral gl_RGBA8 + dataFormat = fromIntegral $ case nchn of + 3 -> gl_RGB + 4 -> gl_RGBA + _ -> error "unsupported texture format!" + glTexImage2D gl_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE $ castPtr ptr + when isMip $ glGenerateMipmap gl_TEXTURE_2D +-} + TextureCube dTy -> if txMipMap /= NoMip then error "FIXME: Only NoMip textures are supported yet!" else + if length txGPList /= 1 then error "Invalid texture source specification!" else do + let internalFormat = fromIntegral $ textureDataTypeToGLType dTy + dataFormat = fromIntegral $ textureDataTypeToGLArityType dTy + VV2U (V2 w h) = txSize + glBindTexture gl_TEXTURE_CUBE_MAP to + glTexParameteri gl_TEXTURE_CUBE_MAP gl_TEXTURE_WRAP_S $ fromIntegral wrapMode + glTexParameteri gl_TEXTURE_CUBE_MAP gl_TEXTURE_WRAP_T $ fromIntegral wrapMode + glTexParameteri gl_TEXTURE_CUBE_MAP gl_TEXTURE_MAG_FILTER $ fromIntegral filterMode + glTexParameteri gl_TEXTURE_CUBE_MAP gl_TEXTURE_MIN_FILTER $ fromIntegral filterMode + glTexParameteri gl_TEXTURE_CUBE_MAP gl_TEXTURE_BASE_LEVEL 0 + glTexParameteri gl_TEXTURE_CUBE_MAP gl_TEXTURE_MAX_LEVEL 0 + let l = [ gl_TEXTURE_CUBE_MAP_POSITIVE_X + , gl_TEXTURE_CUBE_MAP_NEGATIVE_X + , gl_TEXTURE_CUBE_MAP_POSITIVE_Y + , gl_TEXTURE_CUBE_MAP_NEGATIVE_Y + , gl_TEXTURE_CUBE_MAP_POSITIVE_Z + , gl_TEXTURE_CUBE_MAP_NEGATIVE_Z + ] + forM_ l $ \t -> glTexImage2D t 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE nullPtr + + -- temporary texture support: 2D NoMip Float/Int/Word Red/RG/RGBA + Texture2D dTy layerCnt -> if txMipMap /= NoMip then error "FIXME: Only NoMip textures are supported yet!" else + if length txGPList /= 1 then error "Invalid texture source specification!" else do + let internalFormat = fromIntegral $ textureDataTypeToGLType dTy + dataFormat = fromIntegral $ textureDataTypeToGLArityType dTy + VV2U (V2 w h) = txSize + txTarget = if layerCnt > 1 then gl_TEXTURE_2D_ARRAY else gl_TEXTURE_2D + glBindTexture txTarget to + -- temp + glTexParameteri txTarget gl_TEXTURE_WRAP_S $ fromIntegral wrapMode + glTexParameteri txTarget gl_TEXTURE_WRAP_T $ fromIntegral wrapMode + glTexParameteri txTarget gl_TEXTURE_MAG_FILTER $ fromIntegral filterMode + glTexParameteri txTarget gl_TEXTURE_MIN_FILTER $ fromIntegral filterMode + glTexParameteri txTarget gl_TEXTURE_BASE_LEVEL 0 + glTexParameteri txTarget gl_TEXTURE_MAX_LEVEL 0 + -- temp end + case layerCnt > 1 of + True -> glTexImage3D gl_TEXTURE_2D_ARRAY 0 internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral layerCnt) 0 dataFormat gl_UNSIGNED_BYTE nullPtr + False -> glTexImage2D gl_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE nullPtr + return () + _ -> error $ "FIXME: This texture format is not yet supported: " ++ show txType + return to diff --git a/LC_B_Traversals.hs b/LC_B_Traversals.hs new file mode 100644 --- /dev/null +++ b/LC_B_Traversals.hs @@ -0,0 +1,94 @@ +module LC_B_Traversals where + +import Data.List +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet + +import LC_U_APIType +import LC_U_DeBruijn + +class HasExp a where + expUniverse :: DAG -> a -> [Exp] + expUniverse' :: DAG -> a -> [Exp] -- includes the origin + +instance HasExp a => HasExp [a] where + expUniverse dag a = concatMap (expUniverse dag) a + expUniverse' dag a = concatMap (expUniverse' dag) a + +instance HasExp ExpId where + expUniverse dag e = expUniverse dag $ toExp dag e + expUniverse' dag e = expUniverse' dag $ toExp dag e + +instance HasExp Exp where + expUniverse dag exp = case exp of + Lam f -> expUniverse dag f + Body f -> let a = toExp dag f + in a : expUniverse dag f + Apply ia ib -> let [a,b] = map (toExp dag) [ia,ib] + in a : b : expUniverse dag a ++ expUniverse dag b + Tup l -> let e = map (toExp dag) l + in e ++ expUniverse dag e + Prj _ i -> let e = toExp dag i + in e : expUniverse dag e + Cond ia ib ic -> let [a,b,c] = map (toExp dag) [ia,ib,ic] + in a : b : c : expUniverse dag a ++ expUniverse dag b ++ expUniverse dag c + PrimApp _ ia -> let a = toExp dag ia + in a : expUniverse dag a + Loop ia ib ic id -> let [a,b,c,d] = map (toExp dag) [ia,ib,ic,id] + in a : b : c : d : expUniverse dag a ++ expUniverse dag b ++ expUniverse dag c ++ expUniverse dag d + VertexOut ia ib ic id -> let [a,b] = map (toExp dag) [ia,ib] + in a : b : expUniverse dag a ++ expUniverse dag b ++ expUniverse dag ic ++ expUniverse dag id + GeometryOut i j k l m -> let [a,b,c] = map (toExp dag) [i,j,k] + in a : b : c : expUniverse dag a ++ expUniverse dag b ++ expUniverse dag c ++ expUniverse dag l ++ expUniverse dag m + FragmentOut i -> let a = map (toExp dag) i + in a ++ expUniverse dag a + FragmentOutDepth i j -> let a:b = map (toExp dag) (i:j) + in a : b ++ expUniverse dag a ++ expUniverse dag b + FragmentOutRastDepth i -> let a = map (toExp dag) i + in a ++ expUniverse dag a + Transform a b -> expUniverse dag a ++ expUniverse dag b + Reassemble a b -> expUniverse dag a ++ expUniverse dag b + Rasterize _ a -> expUniverse dag a + Accumulate _ a b c _ -> expUniverse dag a ++ expUniverse dag b ++ expUniverse dag c + PrjFrameBuffer _ _ a -> expUniverse dag a + PrjImage _ _ a -> expUniverse dag a + Filter f -> expUniverse dag f + Flat a -> toExp dag a : expUniverse dag a + Smooth a -> toExp dag a : expUniverse dag a + NoPerspective a -> toExp dag a : expUniverse dag a + GeometryShader _ _ _ a b c -> expUniverse dag a ++ expUniverse dag b ++ expUniverse dag c + _ -> [] + + expUniverse' dag exp = exp : expUniverse dag exp + +gpUniverse :: DAG -> Exp -> [Exp] +gpUniverse dag gp = gp : case gp of + Transform _ a -> gpUniverse dag $ toExp dag a + Reassemble _ a -> gpUniverse dag $ toExp dag a + Rasterize _ a -> gpUniverse dag $ toExp dag a + Accumulate _ _ _ a b -> gpUniverse dag (toExp dag a) ++ gpUniverse dag (toExp dag b) + PrjFrameBuffer _ _ a -> gpUniverse dag $ toExp dag a + PrjImage _ _ a -> gpUniverse dag $ toExp dag a + _ -> [] + +-- includes the origin +gpUniverse' :: DAG -> Exp -> [Exp] +gpUniverse' dag gp = gp : gpUniverse dag gp + +findFrameBuffer :: DAG -> Exp -> Exp +findFrameBuffer dag a = head $ dropWhile notFrameBuffer $ gpUniverse' dag a + where + notFrameBuffer (Accumulate {}) = False + notFrameBuffer (FrameBuffer {}) = False + notFrameBuffer _ = True + +-- starts from a FrameBuffer GP and track the draw action chain until the FrameBuffer definition +renderChain :: DAG -> Exp -> [Exp] +renderChain _ fb@(FrameBuffer {}) = [fb] +renderChain dag fb@(Accumulate _ _ _ _ a) = renderChain dag (toExp dag a) ++ [fb] +renderChain _ _ = [] + +drawOperations :: DAG -> Exp -> [Exp] +drawOperations dag fb@(FrameBuffer {}) = [fb] +drawOperations dag fb@(Accumulate _ _ _ a _) = fb : gpUniverse' dag (toExp dag a) +drawOperations _ _ = [] diff --git a/LC_C_Convert.hs b/LC_C_Convert.hs new file mode 100644 --- /dev/null +++ b/LC_C_Convert.hs @@ -0,0 +1,279 @@ +module LC_C_Convert (convertGPOutput) where + +import GHC.TypeLits + +import Debug.Trace + +import LC_T_APIType (FlatTuple(..),Frequency(..)) +import LC_T_DSLType (GPU,Tuple(..),TupleIdx(..)) +import qualified LC_T_APIType as T +import qualified LC_T_DSLType as T hiding (Shadow) +import qualified LC_T_PrimFun as T +import qualified LC_T_HOAS as H +import LC_U_DeBruijn +import LC_U_APIType +import LC_G_APIType +import LC_C_PrimFun +import LC_G_Type as G + +toInt :: SingI n => T.NatNum n -> Int +toInt (a :: T.NatNum n) = fromInteger $ fromSing (sing :: Sing (n :: Nat)) + +prjIdx i lyt = i--length lyt - i - 1 + + +prjToInt :: TupleIdx t e -> Int +prjToInt ZeroTupIdx = 0 +prjToInt (SuccTupIdx i) = 1 + prjToInt i + +genTupLen :: GPU a => Int -> a -> Int +genTupLen i a = sum $ map tySize $ take i rt + where + rt = reverse t + Tuple t = genTy a + +type Layout = [[Ty]] + +genTy :: GPU a => a -> Ty +genTy = T.tupleType + +convertGPOutput :: ExpC exp => H.GPOutput o -> exp +convertGPOutput (H.ImageOut a b c) = imageOut a b $ convertGP c +convertGPOutput (H.ScreenOut a) = screenOut $ convertGP a +convertGPOutput (H.MultiOut a) = multiOut $ map convertGPOutput a + +-- GP +convertGP :: ExpC exp => H.Exp T.Obj t -> exp +convertGP = convertOpenGP [] + +convertOpenGP :: ExpC exp => Layout -> H.Exp T.Obj t -> exp +convertOpenGP = cvt + where + cvt :: ExpC exp => Layout -> H.Exp T.Obj t -> exp + cvt lyt (H.Fetch n p i) = fetch n (convertFetchPrimitive p) (T.toInputList i) + cvt lyt (H.Transform vs ps) = transform (convertFun1Vert lyt vs) (cvt lyt ps) + cvt lyt (H.Reassemble sh ps) = reassemble (convertGeometryShader lyt sh) (cvt lyt ps) + cvt lyt (H.Rasterize ctx ps) = rasterize (convertRasterContext ctx) $ cvt lyt ps + cvt lyt (H.FrameBuffer fb) = frameBuffer (convertFrameBuffer fb) + cvt lyt (H.Accumulate ctx f sh fs fb) = accumulate (convertAccumulationContext ctx) (convertFragmentFilter lyt f) + (convertFun1Frag lyt sh) + (cvt lyt fs) + (cvt lyt fb) + cvt lyt (H.PrjFrameBuffer n idx fb) = prjFrameBuffer n (prjToInt idx) $ convertGP fb + cvt lyt (H.PrjImage n idx img) = prjImage n (toInt idx) $ convertGP img + +-- Vertex +convertOpenVertexOut :: ExpC exp => forall t. + Layout -- environment + -> H.VertexOut clipDistances t -- expression to be converted + -> exp +convertOpenVertexOut lyt = cvt + where + cvt :: ExpC exp => H.VertexOut clipDistances t' -> exp + cvt (H.VertexOut e1 e2 e3 ie :: H.VertexOut clipDistances t') = vertexOut (convertOpenExp lyt e1) (convertOpenExp lyt e2) (convertOpenFlatExp lyt e3) (convertOpenInterpolatedFlatExp lyt ie) + +-- Fragment +convertOpenFragmentOut :: ExpC exp => forall t. + Layout -- environment + -> H.FragmentOut t -- expression to be converted + -> exp +convertOpenFragmentOut lyt = cvt + where + cvt :: ExpC exp => H.FragmentOut t' -> exp + cvt (H.FragmentOut fe :: H.FragmentOut t') = fragmentOut $ convertOpenFlatExp lyt fe + cvt (H.FragmentOutDepth e fe :: H.FragmentOut t') = fragmentOutDepth (convertOpenExp lyt e) (convertOpenFlatExp lyt fe) + cvt (H.FragmentOutRastDepth fe :: H.FragmentOut t') = fragmentOutRastDepth $ convertOpenFlatExp lyt fe + +convertFragmentFilter :: (ExpC exp, GPU a) + => Layout + -> H.FragmentFilter a + -> exp +convertFragmentFilter = cvt + where + cvt :: (ExpC exp, GPU a) => Layout -> H.FragmentFilter a -> exp + cvt lyt H.PassAll = passAll + cvt lyt (H.Filter f) = filter_ $ convertFun1Exp lyt f + +-- Geometry +convertOpenGeometryOut :: ExpC exp => forall i clipDistances t. + Layout -- environment + -> H.GeometryOut i clipDistances t -- expression to be converted + -> exp +convertOpenGeometryOut lyt = cvt + where + cvt :: ExpC exp => H.GeometryOut i clipDistances t' -> exp + cvt (H.GeometryOut e1 e2 e3 e4 ie :: H.GeometryOut i clipDistances t') = geometryOut (convertOpenExp lyt e1) + (convertOpenExp lyt e2) + (convertOpenExp lyt e3) + (convertOpenFlatExp lyt e4) + (convertOpenInterpolatedFlatExp lyt ie) + +convertGeometryShader :: ExpC exp + => Layout + -> H.GeometryShader inputPrimitive outputPrimitive inputClipDistances outputClipDistances layerCount a b + -> exp +convertGeometryShader = cvt + where + cvt :: ExpC exp => Layout -> H.GeometryShader inputPrimitive outputPrimitive inputClipDistances outputClipDistances layerCount a b -> exp + cvt lyt (H.GeometryShader a b c e1 e2 e3) = geometryShader (toInt a) (convertOutputPrimitive b) c (convertFun1Exp lyt e1) + (convertFun1Exp lyt e2) + (convertFun1Geom lyt e3) + +-- Common +convertOpenInterpolatedFlatExp :: ExpC exp => forall stage t. + Layout -- environment + -> H.InterpolatedFlatExp stage t -- expression to be converted + -> [exp] +convertOpenInterpolatedFlatExp lyt = cvt + where + cvt :: ExpC exp => H.InterpolatedFlatExp stage t' -> [exp] + cvt (ZT) = [] + cvt (e:.xs) = cvt' e : cvt xs + + cvt' :: ExpC exp => T.Interpolated (H.Exp stage) t' -> exp + cvt' (T.Flat e) = flat $ convertOpenExp lyt e + cvt' (T.Smooth e) = smooth $ convertOpenExp lyt e + cvt' (T.NoPerspective e) = noPerspective $ convertOpenExp lyt e + +convertOpenFlatExp :: ExpC exp => forall stage t. + Layout -- environment + -> H.FlatExp stage t -- expression to be converted + -> [exp] +convertOpenFlatExp lyt = cvt + where + cvt :: ExpC exp => H.FlatExp stage t' -> [exp] + cvt (ZT) = [] + cvt (e:.xs) = convertOpenExp lyt e : cvt xs + +convertOpenExp :: ExpC exp => forall stage t. + Layout -- environment + -> H.Exp stage t -- expression to be converted + -> exp +convertOpenExp lyt = cvt + where + cvt :: ExpC exp => H.Exp stage t' -> exp + cvt (H.Tag i li :: H.Exp stage t') = var (genTy (undefined :: t')) (prjIdx i lyt) li + cvt (H.Const v :: H.Exp stage t') = const_ (genTy (undefined :: t')) (T.toValue v) + cvt (H.PrimVar v :: H.Exp stage t') = primVar (genTy (undefined :: t')) (fst $ T.toInput v) + cvt (H.Uni v :: H.Exp stage t') = uni (genTy (undefined :: t')) (fst $ T.toInput v) + cvt (H.Tup tupl :: H.Exp stage t') = tup (genTy (undefined :: t')) $ convertTuple lyt tupl + cvt (H.Prj idx (e :: H.Exp stage e') :: H.Exp stage' t') = prj (genTy (undefined :: t')) (genTupLen (prjToInt idx) (undefined :: e')) $ cvt e + cvt (H.Cond e1 e2 e3 :: H.Exp stage t') = cond (genTy (undefined :: t')) (cvt e1) (cvt e2) (cvt e3) + cvt (H.PrimApp p e :: H.Exp stage t') = primApp (genTy (undefined :: t')) (convertPrimFun p) $ cvt e + cvt (H.Sampler f em t :: H.Exp stage t') = sampler (genTy (undefined :: t')) f em $ convertTexture t + cvt (H.Loop e1 e2 e3 s :: H.Exp stage t') = loop (genTy (undefined :: t')) (convertFun1Exp lyt e1) (convertFun1Exp lyt e2) (convertFun1Exp lyt e3) (cvt s) + +convertFun1Vert :: ExpC exp => forall a b clipDistances. GPU a + => Layout + -> (H.Exp V a -> H.VertexOut clipDistances b) + -> exp +convertFun1Vert = convertFun1 convertOpenVertexOut + +convertFun1Geom :: ExpC exp => (GPU a, GPU i, GPU b, GPU clipDistances) + => Layout + -> (H.Exp G a -> H.GeometryOut i clipDistances b) + -> exp +convertFun1Geom = convertFun1 convertOpenGeometryOut + +convertFun1Frag :: ExpC exp => forall a b. GPU a + => Layout + -> (H.Exp F a -> H.FragmentOut b) + -> exp +convertFun1Frag = convertFun1 convertOpenFragmentOut + +convertFun1Exp :: ExpC exp => forall stage a b. GPU a + => Layout + -> (H.Exp stage a -> H.Exp stage b) + -> exp +convertFun1Exp = convertFun1 convertOpenExp + +convertFun1 :: (GPU a, ExpC exp) + => (Layout -> b -> exp) -> Layout -> (H.Exp stage a -> b) -> exp +convertFun1 cvt lyt (f :: H.Exp stage t' -> b) = lam (genTy (undefined :: t')) $ body $ cvt lyt' (f a) + where + lyt' = []:lyt + a = case f of + (fv :: H.Exp stage t -> t2) -> H.Tag (length lyt) (show $ genTy (undefined :: t)) + +convertExp :: ExpC exp + => Layout -- array environment + -> H.Exp stage t -- expression to be converted + -> exp +convertExp lyt = convertOpenExp lyt + +convertTuple :: ExpC exp + => Layout + -> Tuple (H.Exp stage) t + -> [exp] +convertTuple _lyt NilTup = [] +convertTuple lyt (es `SnocTup` e) = convertTuple lyt es ++ [convertOpenExp lyt e] + +-- data type conversion + +convertTexture :: ExpC exp + => T.Texture (H.Exp T.Obj) dim arr t ar + -> exp +convertTexture (T.TextureSlot n t) = textureSlot n (convertTextureType t) +convertTexture (T.Texture t s m d) = texture (convertTextureType t) (T.toValue s) (convertMipMap m) (map convertGP d) + +convertTextureDataType :: T.TextureDataType t ar -> TextureDataType +convertTextureDataType (T.Float a) = FloatT (T.toColorArity a) +convertTextureDataType (T.Int a) = IntT (T.toColorArity a) +convertTextureDataType (T.Word a) = WordT (T.toColorArity a) +convertTextureDataType T.Shadow = ShadowT + +convertTextureType :: T.TextureType dim mip arr layerCount t ar -> TextureType +convertTextureType (T.Texture1D a b) = Texture1D (convertTextureDataType a) (toInt b) +convertTextureType (T.Texture2D a b) = Texture2D (convertTextureDataType a) (toInt b) +convertTextureType (T.Texture3D a) = Texture3D (convertTextureDataType a) +convertTextureType (T.TextureCube a) = TextureCube (convertTextureDataType a) +convertTextureType (T.TextureRect a) = TextureRect (convertTextureDataType a) +convertTextureType (T.Texture2DMS a b) = Texture2DMS (convertTextureDataType a) (toInt b) +convertTextureType (T.TextureBuffer a) = TextureBuffer (convertTextureDataType a) + +convertMipMap :: T.MipMap t -> MipMap +convertMipMap (T.NoMip) = NoMip +convertMipMap (T.Mip a b) = Mip a b +convertMipMap (T.AutoMip a b) = AutoMip a b + +convertRasterContext :: T.RasterContext p -> RasterContext +convertRasterContext (T.PointCtx a b c) = PointCtx a b c +convertRasterContext (T.LineCtx a b) = LineCtx a b +convertRasterContext (T.TriangleCtx a b c d) = TriangleCtx a b c d + +convertBlending :: T.Blending c -> Blending +convertBlending T.NoBlending = NoBlending +convertBlending (T.BlendLogicOp a) = BlendLogicOp a +convertBlending (T.Blend a b c) = Blend a b c + +convertFetchPrimitive :: T.FetchPrimitive a -> FetchPrimitive +convertFetchPrimitive v = case v of + T.Points -> Points + T.Lines -> Lines + T.Triangles -> Triangles + T.LinesAdjacency -> LinesAdjacency + T.TrianglesAdjacency -> TrianglesAdjacency + +convertOutputPrimitive :: T.OutputPrimitive a -> OutputPrimitive +convertOutputPrimitive v = case v of + T.TrianglesOutput -> TrianglesOutput + T.LinesOutput -> LinesOutput + T.PointsOutput -> PointsOutput + +convertAccumulationContext :: T.AccumulationContext b -> AccumulationContext +convertAccumulationContext (T.AccumulationContext n ops) = AccumulationContext n $ cvt ops + where + cvt :: FlatTuple T.NoConstraint T.FragmentOperation b -> [FragmentOperation] + cvt ZT = [] + cvt (T.DepthOp a b:.xs) = DepthOp a b : cvt xs + cvt (T.StencilOp a b c :. xs) = StencilOp a b c : cvt xs + cvt (T.ColorOp a b :. xs) = ColorOp (convertBlending a) (T.toValue b) : cvt xs + +convertFrameBuffer :: T.FrameBuffer layerCount t -> [Image] +convertFrameBuffer = cvt + where + cvt :: T.FrameBuffer layerCount t -> [Image] + cvt ZT = [] + cvt (T.DepthImage a b:.xs) = DepthImage (toInt a) b : cvt xs + cvt (T.StencilImage a b:.xs) = StencilImage (toInt a) b : cvt xs + cvt (T.ColorImage a b:.xs) = ColorImage (toInt a) (T.toValue b) : cvt xs diff --git a/LC_C_PrimFun.hs b/LC_C_PrimFun.hs new file mode 100644 --- /dev/null +++ b/LC_C_PrimFun.hs @@ -0,0 +1,167 @@ +module LC_C_PrimFun where + +import qualified LC_T_PrimFun as T +import LC_U_PrimFun + +convertPrimFun :: T.PrimFun a b -> PrimFun +convertPrimFun a = case a of + -- Vec/Mat (de)construction + T.PrimTupToV2 -> PrimTupToV2 + T.PrimTupToV3 -> PrimTupToV3 + T.PrimTupToV4 -> PrimTupToV4 + T.PrimV2ToTup -> PrimV2ToTup + T.PrimV3ToTup -> PrimV3ToTup + T.PrimV4ToTup -> PrimV4ToTup + + -- Arithmetic Functions (componentwise) + T.PrimAdd -> PrimAdd + T.PrimAddS -> PrimAddS + T.PrimSub -> PrimSub + T.PrimSubS -> PrimSubS + T.PrimMul -> PrimMul + T.PrimMulS -> PrimMulS + T.PrimDiv -> PrimDiv + T.PrimDivS -> PrimDivS + T.PrimNeg -> PrimNeg + T.PrimMod -> PrimMod + T.PrimModS -> PrimModS + + -- Bit-wise Functions + T.PrimBAnd -> PrimBAnd + T.PrimBAndS -> PrimBAndS + T.PrimBOr -> PrimBOr + T.PrimBOrS -> PrimBOrS + T.PrimBXor -> PrimBXor + T.PrimBXorS -> PrimBXorS + T.PrimBNot -> PrimBNot + T.PrimBShiftL -> PrimBShiftL + T.PrimBShiftLS -> PrimBShiftLS + T.PrimBShiftR -> PrimBShiftR + T.PrimBShiftRS -> PrimBShiftRS + + -- Logic Functions + T.PrimAnd -> PrimAnd + T.PrimOr -> PrimOr + T.PrimXor -> PrimXor + T.PrimNot -> PrimNot + T.PrimAny -> PrimAny + T.PrimAll -> PrimAll + + -- Angle and Trigonometry Functions + T.PrimACos -> PrimACos + T.PrimACosH -> PrimACosH + T.PrimASin -> PrimASin + T.PrimASinH -> PrimASinH + T.PrimATan -> PrimATan + T.PrimATan2 -> PrimATan2 + T.PrimATanH -> PrimATanH + T.PrimCos -> PrimCos + T.PrimCosH -> PrimCosH + T.PrimDegrees -> PrimDegrees + T.PrimRadians -> PrimRadians + T.PrimSin -> PrimSin + T.PrimSinH -> PrimSinH + T.PrimTan -> PrimTan + T.PrimTanH -> PrimTanH + + -- Exponential Functions + T.PrimPow -> PrimPow + T.PrimExp -> PrimExp + T.PrimLog -> PrimLog + T.PrimExp2 -> PrimExp2 + T.PrimLog2 -> PrimLog2 + T.PrimSqrt -> PrimSqrt + T.PrimInvSqrt -> PrimInvSqrt + + -- Common Functions + T.PrimIsNan -> PrimIsNan + T.PrimIsInf -> PrimIsInf + T.PrimAbs -> PrimAbs + T.PrimSign -> PrimSign + T.PrimFloor -> PrimFloor + T.PrimTrunc -> PrimTrunc + T.PrimRound -> PrimRound + T.PrimRoundEven -> PrimRoundEven + T.PrimCeil -> PrimCeil + T.PrimFract -> PrimFract + T.PrimModF -> PrimModF + T.PrimMin -> PrimMin + T.PrimMinS -> PrimMinS + T.PrimMax -> PrimMax + T.PrimMaxS -> PrimMaxS + T.PrimClamp -> PrimClamp + T.PrimClampS -> PrimClampS + T.PrimMix -> PrimMix + T.PrimMixS -> PrimMixS + T.PrimMixB -> PrimMixB + T.PrimStep -> PrimStep + T.PrimStepS -> PrimStepS + T.PrimSmoothStep -> PrimSmoothStep + T.PrimSmoothStepS -> PrimSmoothStepS + + -- Integer/Float Conversion Functions + T.PrimFloatBitsToInt -> PrimFloatBitsToInt + T.PrimFloatBitsToUInt -> PrimFloatBitsToUInt + T.PrimIntBitsToFloat -> PrimIntBitsToFloat + T.PrimUIntBitsToFloat -> PrimUIntBitsToFloat + + -- Geometric Functions + T.PrimLength -> PrimLength + T.PrimDistance -> PrimDistance + T.PrimDot -> PrimDot + T.PrimCross -> PrimCross + T.PrimNormalize -> PrimNormalize + T.PrimFaceForward -> PrimFaceForward + T.PrimReflect -> PrimReflect + T.PrimRefract -> PrimRefract + + -- Matrix Functions + T.PrimTranspose -> PrimTranspose + T.PrimDeterminant -> PrimDeterminant + T.PrimInverse -> PrimInverse + T.PrimOuterProduct -> PrimOuterProduct + T.PrimMulMatVec -> PrimMulMatVec + T.PrimMulVecMat -> PrimMulVecMat + T.PrimMulMatMat -> PrimMulMatMat + + -- Vector and Scalar Relational Functions + T.PrimLessThan -> PrimLessThan + T.PrimLessThanEqual -> PrimLessThanEqual + T.PrimGreaterThan -> PrimGreaterThan + T.PrimGreaterThanEqual -> PrimGreaterThanEqual + T.PrimEqualV -> PrimEqualV + T.PrimEqual -> PrimEqual + T.PrimNotEqualV -> PrimNotEqualV + T.PrimNotEqual -> PrimNotEqual + + -- Fragment Processing Functions + T.PrimDFdx -> PrimDFdx + T.PrimDFdy -> PrimDFdy + T.PrimFWidth -> PrimFWidth + + -- Noise Functions + T.PrimNoise1 -> PrimNoise1 + T.PrimNoise2 -> PrimNoise2 + T.PrimNoise3 -> PrimNoise3 + T.PrimNoise4 -> PrimNoise4 + + -- Texture Lookup Functions + T.PrimTextureSize -> PrimTextureSize + T.PrimTexture -> PrimTexture + T.PrimTextureB -> PrimTexture + T.PrimTextureProj -> PrimTextureProj + T.PrimTextureProjB -> PrimTextureProj + T.PrimTextureLod -> PrimTextureLod + T.PrimTextureOffset -> PrimTextureOffset + T.PrimTextureOffsetB -> PrimTextureOffset + T.PrimTexelFetch -> PrimTexelFetch + T.PrimTexelFetchOffset -> PrimTexelFetchOffset + T.PrimTextureProjOffset -> PrimTextureProjOffset + T.PrimTextureProjOffsetB -> PrimTextureProjOffset + T.PrimTextureLodOffset -> PrimTextureLodOffset + T.PrimTextureProjLod -> PrimTextureProjLod + T.PrimTextureProjLodOffset -> PrimTextureProjLodOffset + T.PrimTextureGrad -> PrimTextureGrad + T.PrimTextureGradOffset -> PrimTextureGradOffset + T.PrimTextureProjGrad -> PrimTextureProjGrad + T.PrimTextureProjGradOffset -> PrimTextureProjGradOffset diff --git a/LC_G_APIType.hs b/LC_G_APIType.hs new file mode 100644 --- /dev/null +++ b/LC_G_APIType.hs @@ -0,0 +1,394 @@ +module LC_G_APIType where + +import Data.Int +import Data.Word +import Foreign.Ptr + +import LC_G_Type + +import Graphics.Rendering.OpenGL.Raw.Core32 (GLuint) + +data TextureData + = TextureData + { textureObject :: GLuint + } + +data Primitive + = TriangleStrip + | TriangleList + | TriangleFan + | LineStrip + | LineList + | PointList + | TriangleStripAdjacency + | TriangleListAdjacency + | LineStripAdjacency + | LineListAdjacency + deriving (Eq,Ord,Bounded,Enum,Show) + +-- GPU type value reification, needed for shader codegen +data Value + = VBool !Bool + | VV2B !V2B + | VV3B !V3B + | VV4B !V4B + | VWord !Word32 + | VV2U !V2U + | VV3U !V3U + | VV4U !V4U + | VInt !Int32 + | VV2I !V2I + | VV3I !V3I + | VV4I !V4I + | VFloat !Float + | VV2F !V2F + | VV3F !V3F + | VV4F !V4F + | VM22F !M22F + | VM23F !M23F + | VM24F !M24F + | VM32F !M32F + | VM33F !M33F + | VM34F !M34F + | VM42F !M42F + | VM43F !M43F + | VM44F !M44F + deriving (Show,Eq,Ord) + +type SetterFun a = a -> IO () + +-- user will provide scalar input data via this type +data InputSetter + = SBool (SetterFun Bool) + | SV2B (SetterFun V2B) + | SV3B (SetterFun V3B) + | SV4B (SetterFun V4B) + | SWord (SetterFun Word32) + | SV2U (SetterFun V2U) + | SV3U (SetterFun V3U) + | SV4U (SetterFun V4U) + | SInt (SetterFun Int32) + | SV2I (SetterFun V2I) + | SV3I (SetterFun V3I) + | SV4I (SetterFun V4I) + | SFloat (SetterFun Float) + | SV2F (SetterFun V2F) + | SV3F (SetterFun V3F) + | SV4F (SetterFun V4F) + | SM22F (SetterFun M22F) + | SM23F (SetterFun M23F) + | SM24F (SetterFun M24F) + | SM32F (SetterFun M32F) + | SM33F (SetterFun M33F) + | SM34F (SetterFun M34F) + | SM42F (SetterFun M42F) + | SM43F (SetterFun M43F) + | SM44F (SetterFun M44F) + -- shadow textures + | SSTexture1D + | SSTexture2D + | SSTextureCube + | SSTexture1DArray + | SSTexture2DArray + | SSTexture2DRect + -- float textures + | SFTexture1D + | SFTexture2D (SetterFun TextureData) + | SFTexture3D + | SFTextureCube + | SFTexture1DArray + | SFTexture2DArray + | SFTexture2DMS + | SFTexture2DMSArray + | SFTextureBuffer + | SFTexture2DRect + -- int textures + | SITexture1D + | SITexture2D + | SITexture3D + | SITextureCube + | SITexture1DArray + | SITexture2DArray + | SITexture2DMS + | SITexture2DMSArray + | SITextureBuffer + | SITexture2DRect + -- uint textures + | SUTexture1D + | SUTexture2D + | SUTexture3D + | SUTextureCube + | SUTexture1DArray + | SUTexture2DArray + | SUTexture2DMS + | SUTexture2DMSArray + | SUTextureBuffer + | SUTexture2DRect + +-- buffer handling +{- + user can fills a buffer (continuous memory region) + each buffer have a data descriptor, what describes the + buffer content. e.g. a buffer can contain more arrays of stream types +-} + +-- user will provide stream data using this setup function +type BufferSetter = (Ptr () -> IO ()) -> IO () + +-- specifies array component type (stream type in storage side) +-- this type can be overridden in GPU side, e.g ArrWord8 can be seen as TFloat or TWord also +data ArrayType + = ArrWord8 + | ArrWord16 + | ArrWord32 + | ArrInt8 + | ArrInt16 + | ArrInt32 + | ArrFloat + | ArrHalf -- Hint: half float is not supported in haskell + deriving (Show,Eq,Ord) + +sizeOfArrayType :: ArrayType -> Int +sizeOfArrayType ArrWord8 = 1 +sizeOfArrayType ArrWord16 = 2 +sizeOfArrayType ArrWord32 = 4 +sizeOfArrayType ArrInt8 = 1 +sizeOfArrayType ArrInt16 = 2 +sizeOfArrayType ArrInt32 = 4 +sizeOfArrayType ArrFloat = 4 +sizeOfArrayType ArrHalf = 2 + +-- describes an array in a buffer +data Array -- array type, element count (NOT byte size!), setter + = Array ArrayType Int BufferSetter + +-- dev hint: this should be InputType +-- we restrict StreamType using type class +-- subset of InputType, describes a stream type (in GPU side) +data StreamType + = TWord + | TV2U + | TV3U + | TV4U + | TInt + | TV2I + | TV3I + | TV4I + | TFloat + | TV2F + | TV3F + | TV4F + | TM22F + | TM23F + | TM24F + | TM32F + | TM33F + | TM34F + | TM42F + | TM43F + | TM44F + deriving (Show,Eq,Ord) + +data Ty + = Single !InputType + | Tuple [Ty] + | FrameBuffer' + | Image' + | PrimitiveStream' + | VertexStream' + | FragmentStream' + | Unknown String + deriving (Show,Eq,Ord) + +tySize :: Ty -> Int +tySize (Tuple a) = sum $ map tySize a +tySize _ = 1 + +-- describes a stream type (in GPU side) +data InputType + = Bool + | V2B + | V3B + | V4B + | Word + | V2U + | V3U + | V4U + | Int + | V2I + | V3I + | V4I + | Float + | V2F + | V3F + | V4F + | M22F + | M23F + | M24F + | M32F + | M33F + | M34F + | M42F + | M43F + | M44F + -- shadow textures + | STexture1D + | STexture2D + | STextureCube + | STexture1DArray + | STexture2DArray + | STexture2DRect + -- float textures + | FTexture1D + | FTexture2D + | FTexture3D + | FTextureCube + | FTexture1DArray + | FTexture2DArray + | FTexture2DMS + | FTexture2DMSArray + | FTextureBuffer + | FTexture2DRect + -- int textures + | ITexture1D + | ITexture2D + | ITexture3D + | ITextureCube + | ITexture1DArray + | ITexture2DArray + | ITexture2DMS + | ITexture2DMSArray + | ITextureBuffer + | ITexture2DRect + -- uint textures + | UTexture1D + | UTexture2D + | UTexture3D + | UTextureCube + | UTexture1DArray + | UTexture2DArray + | UTexture2DMS + | UTexture2DMSArray + | UTextureBuffer + | UTexture2DRect + deriving (Show,Eq,Ord) + +toStreamType :: InputType -> Maybe StreamType +toStreamType Word = Just TWord +toStreamType V2U = Just TV2U +toStreamType V3U = Just TV3U +toStreamType V4U = Just TV4U +toStreamType Int = Just TInt +toStreamType V2I = Just TV2I +toStreamType V3I = Just TV3I +toStreamType V4I = Just TV4I +toStreamType Float = Just TFloat +toStreamType V2F = Just TV2F +toStreamType V3F = Just TV3F +toStreamType V4F = Just TV4F +toStreamType M22F = Just TM22F +toStreamType M23F = Just TM23F +toStreamType M24F = Just TM24F +toStreamType M32F = Just TM32F +toStreamType M33F = Just TM33F +toStreamType M34F = Just TM34F +toStreamType M42F = Just TM42F +toStreamType M43F = Just TM43F +toStreamType M44F = Just TM44F +toStreamType _ = Nothing + +fromStreamType :: StreamType -> InputType +fromStreamType TWord = Word +fromStreamType TV2U = V2U +fromStreamType TV3U = V3U +fromStreamType TV4U = V4U +fromStreamType TInt = Int +fromStreamType TV2I = V2I +fromStreamType TV3I = V3I +fromStreamType TV4I = V4I +fromStreamType TFloat = Float +fromStreamType TV2F = V2F +fromStreamType TV3F = V3F +fromStreamType TV4F = V4F +fromStreamType TM22F = M22F +fromStreamType TM23F = M23F +fromStreamType TM24F = M24F +fromStreamType TM32F = M32F +fromStreamType TM33F = M33F +fromStreamType TM34F = M34F +fromStreamType TM42F = M42F +fromStreamType TM43F = M43F +fromStreamType TM44F = M44F + +-- user can specify streams using Stream type +-- a stream can be constant (ConstXXX) or can came from a buffer +data Stream b + = ConstWord Word32 + | ConstV2U V2U + | ConstV3U V3U + | ConstV4U V4U + | ConstInt Int32 + | ConstV2I V2I + | ConstV3I V3I + | ConstV4I V4I + | ConstFloat Float + | ConstV2F V2F + | ConstV3F V3F + | ConstV4F V4F + | ConstM22F M22F + | ConstM23F M23F + | ConstM24F M24F + | ConstM32F M32F + | ConstM33F M33F + | ConstM34F M34F + | ConstM42F M42F + | ConstM43F M43F + | ConstM44F M44F + | Stream + { streamType :: StreamType + , streamBuffer :: b + , streamArrIdx :: Int + , streamStart :: Int + , streamLength :: Int + } + +-- stream of index values (for index buffer) +data IndexStream b + = IndexStream + { indexBuffer :: b + , indexArrIdx :: Int + , indexStart :: Int + , indexLength :: Int + } + +data PointSpriteCoordOrigin = LowerLeft | UpperLeft deriving (Show, Eq, Ord) +data PointSize = PointSize Float | ProgramPointSize deriving (Eq,Ord,Show) +data PolygonOffset = NoOffset | Offset Float Float deriving (Eq,Ord,Show) +data FrontFace = CCW | CW deriving (Eq,Ord,Show) +data PolygonMode = PolygonPoint PointSize | PolygonLine Float | PolygonFill deriving (Eq,Ord,Show) +data ProvokingVertex = FirstVertex | LastVertex deriving (Eq,Ord,Bounded,Enum,Show) +data CullMode = CullNone | CullFront FrontFace | CullBack FrontFace deriving (Eq,Ord,Show) +type DepthFunction = ComparisonFunction +data ComparisonFunction = Never | Less | Equal | Lequal | Greater | Notequal | Gequal | Always deriving ( Eq, Ord, Show ) +data StencilOperation = OpZero | OpKeep | OpReplace | OpIncr | OpIncrWrap | OpDecr | OpDecrWrap | OpInvert deriving ( Eq, Ord, Show ) +data BlendEquation = FuncAdd | FuncSubtract | FuncReverseSubtract | Min | Max deriving ( Eq, Ord, Show ) +data BlendingFactor = Zero | One | SrcColor | OneMinusSrcColor | DstColor | OneMinusDstColor | SrcAlpha | OneMinusSrcAlpha | DstAlpha | OneMinusDstAlpha | ConstantColor | OneMinusConstantColor | ConstantAlpha | OneMinusConstantAlpha | SrcAlphaSaturate deriving ( Eq, Ord, Show ) +data LogicOperation = Clear | And | AndReverse | Copy | AndInverted | Noop | Xor | Or | Nor | Equiv | Invert | OrReverse | CopyInverted | OrInverted | Nand | Set deriving ( Eq, Ord, Show ) + +data StencilOps + = StencilOps + { frontStencilOp :: StencilOperation -- ^ Used for front faced triangles and other primitives. + , backStencilOp :: StencilOperation -- ^ Used for back faced triangles. + } deriving (Eq,Ord,Show) + +data StencilTests = StencilTests StencilTest StencilTest deriving (Eq,Ord,Show) +data StencilTest + = StencilTest + { stencilComparision :: ComparisonFunction -- ^ The function used to compare the @stencilReference@ and the stencil buffers value with. + , stencilReference :: Int32 -- ^ The value to compare with the stencil buffer's value. + , stencilMask :: Word32 -- ^ A bit mask with ones in each position that should be compared and written to the stencil buffer. + } deriving (Eq,Ord,Show) + +-- sampler and texture specification +data Filter = PointFilter | LinearFilter deriving (Show,Eq,Ord) +data EdgeMode = Repeat | MirroredRepeat | ClampToEdge | ClampToBorder deriving (Show,Eq,Ord) diff --git a/LC_G_Type.hs b/LC_G_Type.hs new file mode 100644 --- /dev/null +++ b/LC_G_Type.hs @@ -0,0 +1,240 @@ +module LC_G_Type where + +import GHC.TypeLits + +import Data.Int +import Data.Word +import Foreign.Storable +import Foreign.Ptr + +data V2 a = V2 !a !a deriving (Eq,Ord,Show) +data V3 a = V3 !a !a !a deriving (Eq,Ord,Show) +data V4 a = V4 !a !a !a !a deriving (Eq,Ord,Show) + +-- matrices are stored in column major order +type M22F = V2 V2F +type M23F = V3 V2F +type M24F = V4 V2F +type M32F = V2 V3F +type M33F = V3 V3F +type M34F = V4 V3F +type M42F = V2 V4F +type M43F = V3 V4F +type M44F = V4 V4F + +type V2F = V2 Float +type V3F = V3 Float +type V4F = V4 Float +type V2I = V2 Int32 +type V3I = V3 Int32 +type V4I = V4 Int32 +type V2U = V2 Word32 +type V3U = V3 Word32 +type V4U = V4 Word32 +type V2B = V2 Bool +type V3B = V3 Bool +type V4B = V4 Bool + +-- vector types: V2, V3, V4 +class IsVec (dim :: Nat) vec component | vec -> dim component, dim component -> vec +instance IsVec 2 (V2 Float) Float +instance IsVec 3 (V3 Float) Float +instance IsVec 4 (V4 Float) Float +instance IsVec 2 (V2 Int32) Int32 +instance IsVec 3 (V3 Int32) Int32 +instance IsVec 4 (V4 Int32) Int32 +instance IsVec 2 (V2 Word32) Word32 +instance IsVec 3 (V3 Word32) Word32 +instance IsVec 4 (V4 Word32) Word32 +instance IsVec 2 (V2 Bool) Bool +instance IsVec 3 (V3 Bool) Bool +instance IsVec 4 (V4 Bool) Bool + +-- scalar and vector types: scalar, V2, V3, V4 +class IsVecScalar (dim :: Nat) vec component | vec -> dim component, dim component -> vec +instance IsVecScalar 1 Float Float +instance IsVecScalar 2 (V2 Float) Float +instance IsVecScalar 3 (V3 Float) Float +instance IsVecScalar 4 (V4 Float) Float +instance IsVecScalar 1 Int32 Int32 +instance IsVecScalar 2 (V2 Int32) Int32 +instance IsVecScalar 3 (V3 Int32) Int32 +instance IsVecScalar 4 (V4 Int32) Int32 +instance IsVecScalar 1 Word32 Word32 +instance IsVecScalar 2 (V2 Word32) Word32 +instance IsVecScalar 3 (V3 Word32) Word32 +instance IsVecScalar 4 (V4 Word32) Word32 +instance IsVecScalar 1 Bool Bool +instance IsVecScalar 2 (V2 Bool) Bool +instance IsVecScalar 3 (V3 Bool) Bool +instance IsVecScalar 4 (V4 Bool) Bool + +-- matrix types of dimension [2..4] x [2..4] +class IsMat mat h w | mat -> h w +instance IsMat M22F V2F V2F +instance IsMat M23F V2F V3F +instance IsMat M24F V2F V4F +instance IsMat M32F V3F V2F +instance IsMat M33F V3F V3F +instance IsMat M34F V3F V4F +instance IsMat M42F V4F V2F +instance IsMat M43F V4F V3F +instance IsMat M44F V4F V4F + +-- matrix, vector and scalar types +class IsMatVecScalar a t | a -> t +instance IsMatVecScalar Float Float +instance IsMatVecScalar (V2 Float) Float +instance IsMatVecScalar (V3 Float) Float +instance IsMatVecScalar (V4 Float) Float +instance IsMatVecScalar Int32 Int32 +instance IsMatVecScalar (V2 Int32) Int32 +instance IsMatVecScalar (V3 Int32) Int32 +instance IsMatVecScalar (V4 Int32) Int32 +instance IsMatVecScalar Word32 Word32 +instance IsMatVecScalar (V2 Word32) Word32 +instance IsMatVecScalar (V3 Word32) Word32 +instance IsMatVecScalar (V4 Word32) Word32 +instance IsMatVecScalar Bool Bool +instance IsMatVecScalar (V2 Bool) Bool +instance IsMatVecScalar (V3 Bool) Bool +instance IsMatVecScalar (V4 Bool) Bool +instance IsMatVecScalar M22F Float +instance IsMatVecScalar M23F Float +instance IsMatVecScalar M24F Float +instance IsMatVecScalar M32F Float +instance IsMatVecScalar M33F Float +instance IsMatVecScalar M34F Float +instance IsMatVecScalar M42F Float +instance IsMatVecScalar M43F Float +instance IsMatVecScalar M44F Float + +-- matrix and vector types +class IsMatVec a t | a -> t +instance IsMatVec (V2 Float) Float +instance IsMatVec (V3 Float) Float +instance IsMatVec (V4 Float) Float +instance IsMatVec (V2 Int32) Int32 +instance IsMatVec (V3 Int32) Int32 +instance IsMatVec (V4 Int32) Int32 +instance IsMatVec (V2 Word32) Word32 +instance IsMatVec (V3 Word32) Word32 +instance IsMatVec (V4 Word32) Word32 +instance IsMatVec (V2 Bool) Bool +instance IsMatVec (V3 Bool) Bool +instance IsMatVec (V4 Bool) Bool +instance IsMatVec M22F Float +instance IsMatVec M23F Float +instance IsMatVec M24F Float +instance IsMatVec M32F Float +instance IsMatVec M33F Float +instance IsMatVec M34F Float +instance IsMatVec M42F Float +instance IsMatVec M43F Float +instance IsMatVec M44F Float + +-- matrix or vector component type +class IsComponent a +instance IsComponent Float +instance IsComponent Int32 +instance IsComponent Word32 +instance IsComponent Bool +instance IsComponent V2F +instance IsComponent V3F +instance IsComponent V4F + +-- matrix or vector number component type +class IsNumComponent a +instance IsNumComponent Float +instance IsNumComponent Int32 +instance IsNumComponent Word32 +instance IsNumComponent V2F +instance IsNumComponent V3F +instance IsNumComponent V4F + +class IsSigned a +instance IsSigned Float +instance IsSigned Int + +class Real a => IsNum a +instance IsNum Float +instance IsNum Int32 +instance IsNum Word32 + +class IsIntegral a +instance IsIntegral Int32 +instance IsIntegral Word32 + +class IsFloating a +instance IsFloating Float +instance IsFloating V2F +instance IsFloating V3F +instance IsFloating V4F +instance IsFloating M22F +instance IsFloating M23F +instance IsFloating M24F +instance IsFloating M32F +instance IsFloating M33F +instance IsFloating M34F +instance IsFloating M42F +instance IsFloating M43F +instance IsFloating M44F + + +-- storable instances +instance Storable a => Storable (V2 a) where + sizeOf _ = 2 * sizeOf (undefined :: a) + alignment _ = sizeOf (undefined :: a) + + peek q = do + let p = castPtr q :: Ptr a + k = sizeOf (undefined :: a) + x <- peek p + y <- peekByteOff p k + return $! (V2 x y) + + poke q (V2 x y) = do + let p = castPtr q :: Ptr a + k = sizeOf (undefined :: a) + poke p x + pokeByteOff p k y + +instance Storable a => Storable (V3 a) where + sizeOf _ = 3 * sizeOf (undefined :: a) + alignment _ = sizeOf (undefined :: a) + + peek q = do + let p = castPtr q :: Ptr a + k = sizeOf (undefined :: a) + x <- peek p + y <- peekByteOff p k + z <- peekByteOff p (k*2) + return $! (V3 x y z) + + poke q (V3 x y z) = do + let p = castPtr q :: Ptr a + k = sizeOf (undefined :: a) + poke p x + pokeByteOff p k y + pokeByteOff p (k*2) z + +instance Storable a => Storable (V4 a) where + sizeOf _ = 4 * sizeOf (undefined :: a) + alignment _ = sizeOf (undefined :: a) + + peek q = do + let p = castPtr q :: Ptr a + k = sizeOf (undefined :: a) + x <- peek p + y <- peekByteOff p k + z <- peekByteOff p (k*2) + w <- peekByteOff p (k*3) + return $! (V4 x y z w) + + poke q (V4 x y z w) = do + let p = castPtr q :: Ptr a + k = sizeOf (undefined :: a) + poke p x + pokeByteOff p k y + pokeByteOff p (k*2) z + pokeByteOff p (k*3) w diff --git a/LC_Mesh.hs b/LC_Mesh.hs new file mode 100644 --- /dev/null +++ b/LC_Mesh.hs @@ -0,0 +1,187 @@ +module LC_Mesh ( + loadMesh, + saveMesh, + addMesh, + compileMesh, + Mesh(..), + MeshPrimitive(..), + MeshAttribute(..) +) where + +import Control.Applicative +import Control.Monad +import Data.Binary +import Data.ByteString.Char8 (ByteString) +import Foreign.Ptr +import Data.Int +import Foreign.Storable +import Foreign.Marshal.Utils +import System.IO.Unsafe +import qualified Data.ByteString.Char8 as SB +import qualified Data.ByteString.Lazy as LB +import qualified Data.Trie as T +import qualified Data.Vector.Storable as V +import qualified Data.Vector.Storable.Mutable as MV + +import LC_API + +fileVersion :: Int32 +fileVersion = 1 + +data MeshAttribute + = A_Float (V.Vector Float) + | A_V2F (V.Vector V2F) + | A_V3F (V.Vector V3F) + | A_V4F (V.Vector V4F) + | A_M22F (V.Vector M22F) + | A_M33F (V.Vector M33F) + | A_M44F (V.Vector M44F) + | A_Int (V.Vector Int32) + | A_Word (V.Vector Word32) + +data MeshPrimitive + = P_Points + | P_TriangleStrip + | P_Triangles + | P_TriangleStripI (V.Vector Int32) + | P_TrianglesI (V.Vector Int32) + +data Mesh + = Mesh + { mAttributes :: T.Trie MeshAttribute + , mPrimitive :: MeshPrimitive + , mGPUData :: Maybe GPUData + } + +data GPUData + = GPUData + { dPrimitive :: Primitive + , dStreams :: T.Trie (Stream Buffer) + , dIndices :: Maybe (IndexStream Buffer) + } + +loadMesh :: ByteString -> IO Mesh +loadMesh n = compileMesh =<< decode <$> LB.readFile (SB.unpack n) + +saveMesh :: ByteString -> Mesh -> IO () +saveMesh n m = LB.writeFile (SB.unpack n) (encode m) + +addMesh :: Renderer -> ByteString -> Mesh -> [ByteString] -> IO Object +addMesh renderer slotName (Mesh _ _ (Just (GPUData prim streams indices))) objUniNames = do + -- select proper attributes + let Just (slotPrim,slotStreams) = T.lookup slotName $! slotStream renderer + filterStream n s + | T.member n slotStreams = Just s + | otherwise = Nothing + addObject renderer slotName prim indices (T.mapBy filterStream streams) objUniNames +addMesh _ _ _ _ = fail "addMesh: only compiled mesh with GPUData is supported" + +withV w a f = w a (\p -> f $ castPtr p) + +meshAttrToArray :: MeshAttribute -> Array +meshAttrToArray (A_Float v) = Array ArrFloat (1 * V.length v) $ withV V.unsafeWith v +meshAttrToArray (A_V2F v) = Array ArrFloat (2 * V.length v) $ withV V.unsafeWith v +meshAttrToArray (A_V3F v) = Array ArrFloat (3 * V.length v) $ withV V.unsafeWith v +meshAttrToArray (A_V4F v) = Array ArrFloat (4 * V.length v) $ withV V.unsafeWith v +meshAttrToArray (A_M22F v) = Array ArrFloat (4 * V.length v) $ withV V.unsafeWith v +meshAttrToArray (A_M33F v) = Array ArrFloat (9 * V.length v) $ withV V.unsafeWith v +meshAttrToArray (A_M44F v) = Array ArrFloat (16 * V.length v) $ withV V.unsafeWith v +meshAttrToArray (A_Int v) = Array ArrInt32 (1 * V.length v) $ withV V.unsafeWith v +meshAttrToArray (A_Word v) = Array ArrWord32 (1 * V.length v) $ withV V.unsafeWith v + +meshAttrToStream :: Buffer -> Int -> MeshAttribute -> Stream Buffer +meshAttrToStream b i (A_Float v) = Stream TFloat b i 0 (V.length v) +meshAttrToStream b i (A_V2F v) = Stream TV2F b i 0 (V.length v) +meshAttrToStream b i (A_V3F v) = Stream TV3F b i 0 (V.length v) +meshAttrToStream b i (A_V4F v) = Stream TV4F b i 0 (V.length v) +meshAttrToStream b i (A_M22F v) = Stream TM22F b i 0 (V.length v) +meshAttrToStream b i (A_M33F v) = Stream TM33F b i 0 (V.length v) +meshAttrToStream b i (A_M44F v) = Stream TM44F b i 0 (V.length v) +meshAttrToStream b i (A_Int v) = Stream TInt b i 0 (V.length v) +meshAttrToStream b i (A_Word v) = Stream TWord b i 0 (V.length v) + +compileMesh :: Mesh -> IO Mesh +compileMesh (Mesh attrs mPrim Nothing) = do + let mkIndexBuf v = do + iBuf <- compileBuffer [Array ArrWord32 (V.length v) $ withV V.unsafeWith v] + return $! Just $! IndexStream iBuf 0 0 (V.length v) + vBuf <- compileBuffer [meshAttrToArray a | a <- T.elems attrs] + (indices,prim) <- case mPrim of + P_Points -> return (Nothing,PointList) + P_TriangleStrip -> return (Nothing,TriangleStrip) + P_Triangles -> return (Nothing,TriangleList) + P_TriangleStripI v -> (,TriangleStrip) <$> mkIndexBuf v + P_TrianglesI v -> (,TriangleList) <$> mkIndexBuf v + let streams = T.fromList $! zipWith (\i (n,a) -> (n,meshAttrToStream vBuf i a)) [0..] (T.toList attrs) + gpuData = GPUData prim streams indices + return $! Mesh attrs mPrim (Just gpuData) + +compileMesh mesh = return mesh + +sblToV :: Storable a => [SB.ByteString] -> V.Vector a +sblToV ls = v + where + offs o (s:xs) = (o,s):offs (o + SB.length s) xs + offs _ [] = [] + cnt = sum (map SB.length ls) `div` (sizeOf $ V.head v) + v = unsafePerformIO $ do + mv <- MV.new cnt + MV.unsafeWith mv $ \dst -> forM_ (offs 0 ls) $ \(o,s) -> + SB.useAsCStringLen s $ \(src,len) -> moveBytes (plusPtr dst o) src len + V.unsafeFreeze mv + +vToSB :: Storable a => V.Vector a -> SB.ByteString +vToSB v = unsafePerformIO $ do + let len = V.length v * sizeOf (V.head v) + V.unsafeWith v $ \p -> SB.packCStringLen (castPtr p,len) + +instance Storable a => Binary (V.Vector a) where + put v = put $ vToSB v + get = do s <- get ; return $ sblToV [s] + +instance Binary MeshAttribute where + put (A_Float a) = putWord8 0 >> put a + put (A_V2F a) = putWord8 1 >> put a + put (A_V3F a) = putWord8 2 >> put a + put (A_V4F a) = putWord8 3 >> put a + put (A_M22F a) = putWord8 4 >> put a + put (A_M33F a) = putWord8 5 >> put a + put (A_M44F a) = putWord8 6 >> put a + put (A_Int a) = putWord8 7 >> put a + put (A_Word a) = putWord8 8 >> put a + get = do + tag_ <- getWord8 + case tag_ of + 0 -> A_Float <$> get + 1 -> A_V2F <$> get + 2 -> A_V3F <$> get + 3 -> A_V4F <$> get + 4 -> A_M22F <$> get + 5 -> A_M33F <$> get + 6 -> A_M44F <$> get + 7 -> A_Int <$> get + 8 -> A_Word <$> get + _ -> fail "no parse" + +instance Binary MeshPrimitive where + put P_Points = putWord8 0 + put P_TriangleStrip = putWord8 1 + put P_Triangles = putWord8 2 + put (P_TriangleStripI a) = putWord8 3 >> put a + put (P_TrianglesI a) = putWord8 4 >> put a + get = do + tag_ <- getWord8 + case tag_ of + 0 -> return P_Points + 1 -> return P_TriangleStrip + 2 -> return P_Triangles + 3 -> P_TriangleStripI <$> get + 4 -> P_TrianglesI <$> get + _ -> fail "no parse" + +instance Binary Mesh where + put (Mesh a b _) = put (T.toList a) >> put b + get = do + a <- get + b <- get + return $! Mesh (T.fromList a) b Nothing diff --git a/LC_T_APIType.hs b/LC_T_APIType.hs new file mode 100644 --- /dev/null +++ b/LC_T_APIType.hs @@ -0,0 +1,518 @@ +{-# LANGUAGE UndecidableInstances #-} +module LC_T_APIType where + +import GHC.TypeLits + +import Data.ByteString.Char8 +import Data.Int +import Data.Word + +import LC_G_Type +import LC_G_APIType hiding (InputType(..)) +import LC_G_APIType (InputType) +import qualified LC_G_APIType as U +import qualified LC_U_APIType as U +import LC_T_DSLType hiding (Shadow) +import qualified LC_T_DSLType as T + +data NatNum :: Nat -> * where + N0 :: NatNum 0 + N1 :: NatNum 1 + N2 :: NatNum 2 + N3 :: NatNum 3 + N4 :: NatNum 4 + N5 :: NatNum 5 + N6 :: NatNum 6 + N7 :: NatNum 7 + N8 :: NatNum 8 + N9 :: NatNum 9 + +n0 = N0 +n1 = N1 +n2 = N2 +n3 = N3 +n4 = N4 +n5 = N5 +n6 = N6 +n7 = N7 +n8 = N8 +n9 = N9 + +-- user can define stream input using InputTuple type class +class InputTuple tup where + type InputTupleRepr tup + toInputList :: tup -> [(ByteString,InputType)] + +instance InputTuple (Input a) where + type InputTupleRepr (Input a) = a + toInputList a = [toInput a] + +instance InputTuple (Input a, Input b) where + type InputTupleRepr (Input a, Input b) = (a, b) + toInputList (a, b) = [toInput a, toInput b] + +instance InputTuple (Input a, Input b, Input c) where + type InputTupleRepr (Input a, Input b, Input c) = (a, b, c) + toInputList (a, b, c) = [toInput a, toInput b, toInput c] + +instance InputTuple (Input a, Input b, Input c, Input d) where + type InputTupleRepr (Input a, Input b, Input c, Input d) = (a, b, c, d) + toInputList (a, b, c, d) = [toInput a, toInput b, toInput c, toInput d] + +instance InputTuple (Input a, Input b, Input c, Input d, Input e) where + type InputTupleRepr (Input a, Input b, Input c, Input d, Input e) = (a, b, c, d, e) + toInputList (a, b, c, d, e) = [toInput a, toInput b, toInput c, toInput d, toInput e] + +instance InputTuple (Input a, Input b, Input c, Input d, Input e, Input f) where + type InputTupleRepr (Input a, Input b, Input c, Input d, Input e, Input f) = (a, b, c, d, e, f) + toInputList (a, b, c, d, e, f) = [toInput a, toInput b, toInput c, toInput d, toInput e, toInput f] + +instance InputTuple (Input a, Input b, Input c, Input d, Input e, Input f, Input g) where + type InputTupleRepr (Input a, Input b, Input c, Input d, Input e, Input f, Input g) = (a, b, c, d, e, f, g) + toInputList (a, b, c, d, e, f, g) = [toInput a, toInput b, toInput c, toInput d, toInput e, toInput f, toInput g] + +instance InputTuple (Input a, Input b, Input c, Input d, Input e, Input f, Input g, Input h) where + type InputTupleRepr (Input a, Input b, Input c, Input d, Input e, Input f, Input g, Input h) = (a, b, c, d, e, f, g, h) + toInputList (a, b, c, d, e, f, g, h) = [toInput a, toInput b, toInput c, toInput d, toInput e, toInput f, toInput g, toInput h] + +instance InputTuple (Input a, Input b, Input c, Input d, Input e, Input f, Input g, Input h, Input i) where + type InputTupleRepr (Input a, Input b, Input c, Input d, Input e, Input f, Input g, Input h, Input i) = (a, b, c, d, e, f, g, h, i) + toInputList (a, b, c, d, e, f, g, h, i) = [toInput a, toInput b, toInput c, toInput d, toInput e, toInput f, toInput g, toInput h, toInput i] + +-- we should define all of input types +-- supported stream input types (the ByteString argument is the input slot name) +data Input a where + IBool :: ByteString -> Input Bool + IV2B :: ByteString -> Input V2B + IV3B :: ByteString -> Input V3B + IV4B :: ByteString -> Input V4B + IWord :: ByteString -> Input Word32 + IV2U :: ByteString -> Input V2U + IV3U :: ByteString -> Input V3U + IV4U :: ByteString -> Input V4U + IInt :: ByteString -> Input Int32 + IV2I :: ByteString -> Input V2I + IV3I :: ByteString -> Input V3I + IV4I :: ByteString -> Input V4I + IFloat :: ByteString -> Input Float + IV2F :: ByteString -> Input V2F + IV3F :: ByteString -> Input V3F + IV4F :: ByteString -> Input V4F + IM22F :: ByteString -> Input M22F + IM23F :: ByteString -> Input M23F + IM24F :: ByteString -> Input M24F + IM32F :: ByteString -> Input M32F + IM33F :: ByteString -> Input M33F + IM34F :: ByteString -> Input M34F + IM42F :: ByteString -> Input M42F + IM43F :: ByteString -> Input M43F + IM44F :: ByteString -> Input M44F + +toInput :: Input a -> (ByteString,InputType) +toInput (IBool n) = (n, U.Bool) +toInput (IV2B n) = (n, U.V2B) +toInput (IV3B n) = (n, U.V3B) +toInput (IV4B n) = (n, U.V4B) +toInput (IWord n) = (n, U.Word) +toInput (IV2U n) = (n, U.V2U) +toInput (IV3U n) = (n, U.V3U) +toInput (IV4U n) = (n, U.V4U) +toInput (IInt n) = (n, U.Int) +toInput (IV2I n) = (n, U.V2I) +toInput (IV3I n) = (n, U.V3I) +toInput (IV4I n) = (n, U.V4I) +toInput (IFloat n) = (n, U.Float) +toInput (IV2F n) = (n, U.V2F) +toInput (IV3F n) = (n, U.V3F) +toInput (IV4F n) = (n, U.V4F) +toInput (IM22F n) = (n, U.M22F) +toInput (IM23F n) = (n, U.M23F) +toInput (IM24F n) = (n, U.M24F) +toInput (IM32F n) = (n, U.M32F) +toInput (IM33F n) = (n, U.M33F) +toInput (IM34F n) = (n, U.M34F) +toInput (IM42F n) = (n, U.M42F) +toInput (IM43F n) = (n, U.M43F) +toInput (IM44F n) = (n, U.M44F) + +-- primitive types +data PrimitiveType + = Triangle + | Line + | Point + | TriangleAdjacency + | LineAdjacency + +data FetchPrimitive :: PrimitiveType -> * where + Points :: FetchPrimitive Point + Lines :: FetchPrimitive Line + Triangles :: FetchPrimitive Triangle + LinesAdjacency :: FetchPrimitive LineAdjacency + TrianglesAdjacency :: FetchPrimitive TriangleAdjacency + +data OutputPrimitive :: PrimitiveType -> * where + TrianglesOutput :: OutputPrimitive Triangle + LinesOutput :: OutputPrimitive Line + PointsOutput :: OutputPrimitive Point + +data Blending c where + NoBlending :: Blending c + + BlendLogicOp :: IsIntegral c + => LogicOperation + -> Blending c + + -- FIXME: restrict BlendingFactor at some BlendEquation + Blend :: (BlendEquation, BlendEquation) + -> ((BlendingFactor, BlendingFactor), (BlendingFactor, BlendingFactor)) + -> V4F + -> Blending Float + +blend = Blend (FuncAdd,FuncAdd) ((SrcAlpha,OneMinusSrcAlpha),(SrcAlpha,OneMinusSrcAlpha)) (V4 1 1 1 1) + +-- abstract types, used in language AST +data VertexStream (primitive :: PrimitiveType) t +data PrimitiveStream (primitive :: PrimitiveType) clipDistances (layerCount :: Nat) (freq :: Frequency) t +data FragmentStream (layerCount :: Nat) t + + +-- flat tuple, another internal tuple representation + +-- means unit +data ZZ = ZZ deriving (Show) + +-- used for tuple type description +infixr 1 :+: +data tail :+: head = !tail :+: !head deriving (Show) + +-- used for tuple value description +infixr 1 :. +data FlatTuple c a t where + ZT :: FlatTuple c a ZZ + + (:.) :: c t + => a t + -> FlatTuple c a t' + -> FlatTuple c a (t :+: t') + +class IsFloatTuple a +instance IsFloatTuple ZZ +instance IsFloatTuple l => IsFloatTuple (Float :+: l) + +-- vertex attribute interpolation +data Interpolated e a where + Flat :: e a -> Interpolated e a + + Smooth :: IsFloating a + => e a -> Interpolated e a + + NoPerspective :: IsFloating a + => e a -> Interpolated e a + +-- framebuffer data / fragment output semantic +data Color a +data Depth a +data Stencil a + +-- describe geometry shader input +type family PrimitiveVertices (primitive :: PrimitiveType) a +type instance PrimitiveVertices Point a = a +type instance PrimitiveVertices Line a = (a,a) +type instance PrimitiveVertices LineAdjacency a = (a,a,a,a) +type instance PrimitiveVertices Triangle a = (a,a,a) +type instance PrimitiveVertices TriangleAdjacency a = (a,a,a,a,a,a) + +-- raster context description +data RasterContext t where + PointCtx :: + { ctxPointSize :: PointSize + , ctxFadeThresholdSize :: Float + , ctxSpriteCoordOrigin :: PointSpriteCoordOrigin + } -> RasterContext Point + + LineCtx :: + { ctxLineWidth :: Float + , ctxProvokingVertex' :: ProvokingVertex + } -> RasterContext Line + + TriangleCtx :: + { ctxCullMode :: CullMode + , ctxPolygonMode :: PolygonMode + , ctxPolygonOffset :: PolygonOffset + , ctxProvokingVertex :: ProvokingVertex + } -> RasterContext Triangle + +-- default triangle raster context +triangleCtx :: RasterContext Triangle +triangleCtx = TriangleCtx CullNone PolygonFill NoOffset LastVertex + +class NoConstraint a +instance NoConstraint a + +type FrameBuffer layerCount t = FlatTuple NoConstraint (Image layerCount) t +data AccumulationContext t + = AccumulationContext + { accViewportName :: Maybe ByteString + , accOperations :: FlatTuple NoConstraint FragmentOperation t + } + +-- Fragment Operation +data FragmentOperation ty where + DepthOp :: DepthFunction + -> Bool -- depth write + -> FragmentOperation (Depth Float) + + StencilOp :: StencilTests + -> StencilOps + -> StencilOps + -> FragmentOperation (Stencil Int32) + + ColorOp :: (IsVecScalar d mask Bool, IsVecScalar d color c, IsNum c, IsScalar mask) + => Blending c -- blending type + -> mask -- write mask + -> FragmentOperation (Color color) + +-- specifies an empty image (pixel rectangle) +-- hint: framebuffer is composed from images +data Image (layerCount :: Nat) t where + DepthImage :: SingI layerCount + => NatNum layerCount + -> Float -- initial value + -> Image layerCount (Depth Float) + + StencilImage :: SingI layerCount + => NatNum layerCount + -> Int32 -- initial value + -> Image layerCount (Stencil Int32) + + ColorImage :: (IsNum t, IsVecScalar d color t, IsScalar color, SingI layerCount) + => NatNum layerCount + -> color -- initial value + -> Image layerCount (Color color) + +-- restriction for framebuffer structure according content semantic +-- supported configurations: optional stencil + optional depth + [zero or more color] +class IsColorOutput a +instance IsColorOutput ZZ +instance (IsColorOutput b) => IsColorOutput (Color c :+: b) + +class IsValidOutput a +instance (IsColorOutput a) => IsValidOutput (Color c :+: a) +instance (IsColorOutput a) => IsValidOutput (Depth d :+: a) +instance (IsColorOutput a) => IsValidOutput (Stencil s :+: a) +instance (IsColorOutput a) => IsValidOutput (Stencil s :+: Depth d :+: a) + +-- helper class (type level function), used in language AST +-- converts FlatTuple type to ordinary tuple type +type family FTRepr a :: * +type instance FTRepr ZZ = () +type instance FTRepr (a :+: ZZ) = a +type instance FTRepr (a :+: b :+: ZZ) = (a, b) +type instance FTRepr (a :+: b :+: c :+: ZZ) = (a, b, c) +type instance FTRepr (a :+: b :+: c :+: d :+: ZZ) = (a, b, c, d) +type instance FTRepr (a :+: b :+: c :+: d :+: e :+: ZZ) = (a, b, c, d, e) +type instance FTRepr (a :+: b :+: c :+: d :+: e :+: f :+: ZZ) = (a, b, c, d, e, f) +type instance FTRepr (a :+: b :+: c :+: d :+: e :+: f :+: g :+: ZZ) = (a, b, c, d, e, f, g) +type instance FTRepr (a :+: b :+: c :+: d :+: e :+: f :+: g :+: h :+: ZZ) = (a, b, c, d, e, f, g, h) +type instance FTRepr (a :+: b :+: c :+: d :+: e :+: f :+: g :+: h :+: i :+: ZZ) = (a, b, c, d, e, f, g, h, i) + +-- helper type level function, used in language AST +type family FTRepr' a :: * +type instance FTRepr' (i1 a :+: ZZ) = a +type instance FTRepr' (i1 a :+: i2 b :+: ZZ) = (a, b) +type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: ZZ) = (a, b, c) +type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: i4 d :+: ZZ) = (a, b, c, d) +type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: i4 d :+: i5 e :+: ZZ) = (a, b, c, d, e) +type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: i4 d :+: i5 e :+: i6 f :+: ZZ) = (a, b, c, d, e, f) +type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: i4 d :+: i5 e :+: i6 f :+: i7 g :+: ZZ) = (a, b, c, d, e, f, g) +type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: i4 d :+: i5 e :+: i6 f :+: i7 g :+: i8 h :+: ZZ) = (a, b, c, d, e, f, g, h) +type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: i4 d :+: i5 e :+: i6 f :+: i7 g :+: i8 h :+: i9 i :+: ZZ) = (a, b, c, d, e, f, g, h ,i) + +-- helper type level function, used in language AST +type family ColorRepr a :: * +type instance ColorRepr ZZ = ZZ +type instance ColorRepr (a :+: b) = Color a :+: (ColorRepr b) + +-- helper type level function, used in language AST +type family NoStencilRepr a :: * +type instance NoStencilRepr ZZ = ZZ +type instance NoStencilRepr (Stencil a :+: b) = NoStencilRepr b +type instance NoStencilRepr (Color a :+: b) = Color a :+: (NoStencilRepr b) +type instance NoStencilRepr (Depth a :+: b) = Depth a :+: (NoStencilRepr b) + +-- sampler and texture specification +data TextureMipMap + = TexMip + | TexNoMip + +data MipMap (t :: TextureMipMap) where + NoMip :: MipMap TexNoMip + + Mip :: Int -- base level + -> Int -- max level + -> MipMap TexMip + + AutoMip :: Int -- base level + -> Int -- max level + -> MipMap TexMip + +-- helper type level function, used in language AST +type family TexDataRepr arity (t :: TextureSemantics *) +type instance TexDataRepr Red (v a) = a +type instance TexDataRepr RG (v a) = V2 a +type instance TexDataRepr RGB (v a) = V3 a +type instance TexDataRepr RGBA (v a) = V4 a + +-- describes texel (texture component) type +data TextureDataType (kind :: TextureSemantics *) arity where + Float :: IsColorArity a + => a + -> TextureDataType (Regular Float) a + + Int :: IsColorArity a + => a + -> TextureDataType (Regular Int) a + + Word :: IsColorArity a + => a + -> TextureDataType (Regular Word) a + + Shadow :: TextureDataType (T.Shadow Float) Red -- TODO: add params required by shadow textures + + +-- helper type level function for texture specification +-- tells whether a texture is a single or an array texture +type family TexArrRepr (a :: Nat) :: TextureArray +{- +type instance TexArrRepr 1 = SingleTex +type instance TexArrRepr ((2 <= t) => t) = ArrayTex +-} +-- FIXME: implement properly +type instance TexArrRepr 1 = SingleTex +type instance TexArrRepr 2 = ArrayTex +type instance TexArrRepr 3 = ArrayTex +type instance TexArrRepr 4 = ArrayTex +type instance TexArrRepr 5 = ArrayTex +type instance TexArrRepr 6 = ArrayTex +type instance TexArrRepr 7 = ArrayTex +type instance TexArrRepr 8 = ArrayTex +type instance TexArrRepr 9 = ArrayTex + +-- supported texture component arities +class IsColorArity a where + toColorArity :: a -> U.ColorArity + +instance IsColorArity Red where + toColorArity _ = U.Red +instance IsColorArity RG where + toColorArity _ = U.RG +instance IsColorArity RGB where + toColorArity _ = U.RGB +instance IsColorArity RGBA where + toColorArity _ = U.RGBA + +-- component arity specification (Red,RG,RGB,RGBA) +-- hint: there is an interference with Shadow component format +-- alternatives: +-- A: move Shadow from TextureDataType to TextureType, this will introduce some new TextureType constructors (1D,2D,Cube,Rect) +-- B: restrict ColorArity for Shadow +-- C: add color arity definition to TextureDataType, this will solve the problem (best solution) + +-- fully describes a texture type +data TextureType :: TextureShape -> TextureMipMap -> TextureArray -> Nat -> TextureSemantics * -> * -> * where -- hint: arr - single or array texture, ar - arity (Red,RG,RGB,..) + Texture1D :: SingI layerCount + => TextureDataType t ar + -> NatNum layerCount + -> TextureType Tex1D TexMip (TexArrRepr layerCount) layerCount t ar + + Texture2D :: SingI layerCount + => TextureDataType t ar + -> NatNum layerCount + -> TextureType Tex2D TexMip (TexArrRepr layerCount) layerCount t ar + + Texture3D :: TextureDataType (Regular t) ar + -> TextureType Tex3D TexMip SingleTex 1 (Regular t) ar + + TextureCube :: TextureDataType t ar + -> TextureType Tex2D TexMip CubeTex 6 t ar + + TextureRect :: TextureDataType t ar + -> TextureType TexRect TexNoMip SingleTex 1 t ar + + Texture2DMS :: SingI layerCount + => TextureDataType (Regular t) ar + -> NatNum layerCount + -> TextureType Tex2D TexNoMip (TexArrRepr layerCount) layerCount (MultiSample t) ar + + TextureBuffer :: TextureDataType (Regular t) ar + -> TextureType Tex1D TexNoMip SingleTex 1 (Buffer t) ar + + +-- defines a texture +data Texture (gp :: * -> *) (dim :: TextureShape) (arr :: TextureArray) (t :: TextureSemantics *) ar where + TextureSlot :: (IsValidTextureSlot t) + => ByteString -- texture slot name + -> TextureType dim mip arr layerCount t ar + -> Texture gp dim arr t ar + -- TODO: + -- add texture internal format specification + Texture :: (IsScalar (TexSizeRepr dim), IsMipValid canMip mip) + => TextureType dim canMip arr layerCount t ar + -> TexSizeRepr dim + -> MipMap mip +-- -> TexRepr dim mip gp layerCount (TexDataRepr ar t) -- FIXME: for cube it will give wrong type + -> [gp (Image layerCount (TexDataRepr ar t))] + -> Texture gp dim arr t ar +{- + -- TODO: + -- swizzling (arity conversion) + -- integral -> floating casting (floating -> integral casting if possible) + ConvertTexture :: Texture gp dim arr t ar + -> Texture gp dim arr t' ar' +-} + +-- MipMap validation +class IsMipValid (canMip :: TextureMipMap) (mip :: TextureMipMap) +instance IsMipValid TexMip TexMip +instance IsMipValid TexMip TexNoMip +instance IsMipValid TexNoMip TexNoMip + +-- restriction for texture types what can be specified as texture slots, e.g. multisample textures cannot be created im this way +class IsValidTextureSlot (a :: TextureSemantics *) +instance IsValidTextureSlot (Regular a) +instance IsValidTextureSlot (T.Shadow a) +instance IsValidTextureSlot (Buffer a) + +-- type level hepler function, used for texture specification +type family TexSizeRepr (a :: TextureShape) +type instance TexSizeRepr (Tex1D) = Word32 +type instance TexSizeRepr (Tex2D) = V2U +type instance TexSizeRepr (TexRect) = V2U +type instance TexSizeRepr (Tex3D) = V3U +{- +-- type level hepler function, used for texture specification +type family TexRepr dim mip (gp :: * -> *) layerCount t :: * +type instance TexRepr DIM1 NoMip gp layerCount t = gp (Image layerCount t) +type instance TexRepr DIM1 AutoMip gp layerCount t = gp (Image layerCount t) +type instance TexRepr DIM1 Mip gp layerCount t = [gp (Image layerCount t)] + +type instance TexRepr DIM2 NoMip gp layerCount t = gp (Image layerCount t) +type instance TexRepr DIM2 AutoMip gp layerCount t = gp (Image layerCount t) +type instance TexRepr DIM2 Mip gp layerCount t = [gp (Image layerCount t)] + +type instance TexRepr DIM3 NoMip gp layerCount t = [gp (Image layerCount t)] +type instance TexRepr DIM3 AutoMip gp layerCount t = [gp (Image layerCount t)] +type instance TexRepr DIM3 Mip gp layerCount t = [[gp (Image layerCount t)]] -- 3D layers contain mipmap +-} + +-- shader stage tags: vertex, geometry, fragment +-- used in language AST, for primfun restriction and in shader codegen +data Frequency + = Obj + | V + | G + | F + +data OutputType + = SingleOutput + | MultiOutput diff --git a/LC_T_DSLType.hs b/LC_T_DSLType.hs new file mode 100644 --- /dev/null +++ b/LC_T_DSLType.hs @@ -0,0 +1,622 @@ +module LC_T_DSLType where + +import Data.Int +import Data.Word + +import LC_G_Type +import LC_G_APIType (InputType) +import LC_G_APIType hiding (InputType(..)) +import qualified LC_G_APIType as U + +data TextureShape + = Tex1D + | Tex2D + | Tex3D + | TexRect + +data Red = Red deriving (Eq,Ord) +data RG = RG deriving (Eq,Ord) +data RGB = RGB deriving (Eq,Ord) +data RGBA = RGBA deriving (Eq,Ord) + +data TextureSemantics a + = Regular a + | Shadow a + | MultiSample a + | Buffer a + +data TextureArray + = SingleTex -- singleton texture + | ArrayTex -- array texture + | CubeTex -- cube texture = array with size 6 + +--data Sampler dim layerCount t ar +data Sampler :: TextureShape -> TextureArray -> TextureSemantics * -> * -> * + +-- IsScalar means here that the related type is not a tuple, but a GPU primitive type +class GPU a => IsScalar a where + toValue :: a -> Value + toType :: a -> InputType +{- +instance Nat sh => IsScalar (Sampler dim sh t ar) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = error "toType Sampler is not implemented yet" -- TODO +-} +-- Float +instance IsScalar (Sampler Tex1D SingleTex (Regular Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.FTexture1D +instance IsScalar (Sampler Tex2D SingleTex (Regular Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.FTexture2D +instance IsScalar (Sampler Tex3D SingleTex (Regular Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.FTexture3D +instance IsScalar (Sampler Tex2D CubeTex (Regular Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.FTextureCube +instance IsScalar (Sampler Tex1D ArrayTex (Regular Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.FTexture1DArray +instance IsScalar (Sampler Tex2D ArrayTex (Regular Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.FTexture2DArray +instance IsScalar (Sampler Tex2D SingleTex (MultiSample Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.FTexture2DMS +instance IsScalar (Sampler Tex2D ArrayTex (MultiSample Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.FTexture2DMSArray +instance IsScalar (Sampler Tex1D SingleTex (Buffer Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.FTextureBuffer +instance IsScalar (Sampler TexRect SingleTex (Regular Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.FTexture2DRect + +-- Int +instance IsScalar (Sampler Tex1D SingleTex (Regular Int) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.ITexture1D +instance IsScalar (Sampler Tex2D SingleTex (Regular Int) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.ITexture2D +instance IsScalar (Sampler Tex3D SingleTex (Regular Int) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.ITexture3D +instance IsScalar (Sampler Tex2D CubeTex (Regular Int) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.ITextureCube +instance IsScalar (Sampler Tex1D ArrayTex (Regular Int) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.ITexture1DArray +instance IsScalar (Sampler Tex2D ArrayTex (Regular Int) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.ITexture2DArray +instance IsScalar (Sampler Tex2D SingleTex (MultiSample Int) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.ITexture2DMS +instance IsScalar (Sampler Tex2D ArrayTex (MultiSample Int) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.ITexture2DMSArray +instance IsScalar (Sampler Tex1D SingleTex (Buffer Int) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.ITextureBuffer +instance IsScalar (Sampler TexRect SingleTex (Regular Int) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.ITexture2DRect + +-- Word +instance IsScalar (Sampler Tex1D SingleTex (Regular Word) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.UTexture1D +instance IsScalar (Sampler Tex2D SingleTex (Regular Word) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.UTexture2D +instance IsScalar (Sampler Tex3D SingleTex (Regular Word) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.UTexture3D +instance IsScalar (Sampler Tex2D CubeTex (Regular Word) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.UTextureCube +instance IsScalar (Sampler Tex1D ArrayTex (Regular Word) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.UTexture1DArray +instance IsScalar (Sampler Tex2D ArrayTex (Regular Word) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.UTexture2DArray +instance IsScalar (Sampler Tex2D SingleTex (MultiSample Word) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.UTexture2DMS +instance IsScalar (Sampler Tex2D ArrayTex (MultiSample Word) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.UTexture2DMSArray +instance IsScalar (Sampler Tex1D SingleTex (Buffer Word) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.UTextureBuffer +instance IsScalar (Sampler TexRect SingleTex (Regular Word) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.UTexture2DRect + +-- Shadow +instance IsScalar (Sampler Tex1D SingleTex (Shadow Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.STexture1D +instance IsScalar (Sampler Tex2D SingleTex (Shadow Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.STexture2D +instance IsScalar (Sampler Tex2D CubeTex (Shadow Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.STextureCube +instance IsScalar (Sampler Tex1D ArrayTex (Shadow Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.STexture1DArray +instance IsScalar (Sampler Tex2D ArrayTex (Shadow Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.STexture2DArray +instance IsScalar (Sampler TexRect SingleTex (Shadow Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.STexture2DRect + +instance IsScalar Int32 where + toValue v = VInt v + toType _ = U.Int +instance IsScalar Word32 where + toValue v = VWord v + toType _ = U.Word +instance IsScalar Float where + toValue v = VFloat v + toType _ = U.Float +instance IsScalar Bool where + toValue v = VBool v + toType _ = U.Bool +instance IsScalar M22F where + toValue v = VM22F v + toType _ = U.M22F +instance IsScalar M23F where + toValue v = VM23F v + toType _ = U.M23F +instance IsScalar M24F where + toValue v = VM24F v + toType _ = U.M24F +instance IsScalar M32F where + toValue v = VM32F v + toType _ = U.M32F +instance IsScalar M33F where + toValue v = VM33F v + toType _ = U.M33F +instance IsScalar M34F where + toValue v = VM34F v + toType _ = U.M34F +instance IsScalar M42F where + toValue v = VM42F v + toType _ = U.M42F +instance IsScalar M43F where + toValue v = VM43F v + toType _ = U.M43F +instance IsScalar M44F where + toValue v = VM44F v + toType _ = U.M44F +instance IsScalar V2F where + toValue v = VV2F v + toType _ = U.V2F +instance IsScalar V3F where + toValue v = VV3F v + toType _ = U.V3F +instance IsScalar V4F where + toValue v = VV4F v + toType _ = U.V4F +instance IsScalar V2I where + toValue v = VV2I v + toType _ = U.V2I +instance IsScalar V3I where + toValue v = VV3I v + toType _ = U.V3I +instance IsScalar V4I where + toValue v = VV4I v + toType _ = U.V4I +instance IsScalar V2U where + toValue v = VV2U v + toType _ = U.V2U +instance IsScalar V3U where + toValue v = VV3U v + toType _ = U.V3U +instance IsScalar V4U where + toValue v = VV4U v + toType _ = U.V4U +instance IsScalar V2B where + toValue v = VV2B v + toType _ = U.V2B +instance IsScalar V3B where + toValue v = VV3B v + toType _ = U.V3B +instance IsScalar V4B where + toValue v = VV4B v + toType _ = U.V4B + +instance Show (Sampler dim layerCount t ar) where + show _ = "Sampler dim layerCount t ar" + +-- GPU type restriction, the functions are used in shader codegen +class (Show a) => GPU a where + tupleType :: a -> Ty + +-- Float +instance GPU (Sampler Tex1D SingleTex (Regular Float) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex2D SingleTex (Regular Float) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex3D SingleTex (Regular Float) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex2D CubeTex (Regular Float) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex1D ArrayTex (Regular Float) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex2D ArrayTex (Regular Float) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex2D SingleTex (MultiSample Float) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex2D ArrayTex (MultiSample Float) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex1D SingleTex (Buffer Float) a) where + tupleType v = Single $ toType v +instance GPU (Sampler TexRect SingleTex (Regular Float) a) where + tupleType v = Single $ toType v + +-- Int +instance GPU (Sampler Tex1D SingleTex (Regular Int) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex2D SingleTex (Regular Int) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex3D SingleTex (Regular Int) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex2D CubeTex (Regular Int) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex1D ArrayTex (Regular Int) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex2D ArrayTex (Regular Int) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex2D SingleTex (MultiSample Int) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex2D ArrayTex (MultiSample Int) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex1D SingleTex (Buffer Int) a) where + tupleType v = Single $ toType v +instance GPU (Sampler TexRect SingleTex (Regular Int) a) where + tupleType v = Single $ toType v + +-- Word +instance GPU (Sampler Tex1D SingleTex (Regular Word) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex2D SingleTex (Regular Word) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex3D SingleTex (Regular Word) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex2D CubeTex (Regular Word) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex1D ArrayTex (Regular Word) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex2D ArrayTex (Regular Word) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex2D SingleTex (MultiSample Word) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex2D ArrayTex (MultiSample Word) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex1D SingleTex (Buffer Word) a) where + tupleType v = Single $ toType v +instance GPU (Sampler TexRect SingleTex (Regular Word) a) where + tupleType v = Single $ toType v + +-- Shadow +instance GPU (Sampler Tex1D SingleTex (Shadow Float) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex2D SingleTex (Shadow Float) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex2D CubeTex (Shadow Float) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex1D ArrayTex (Shadow Float) a) where + tupleType v = Single $ toType v +instance GPU (Sampler Tex2D ArrayTex (Shadow Float) a) where + tupleType v = Single $ toType v +instance GPU (Sampler TexRect SingleTex (Shadow Float) a) where + tupleType v = Single $ toType v + +instance GPU () where + tupleType v = Tuple [] +instance GPU Bool where + tupleType v = Single $ toType v +instance GPU Float where + tupleType v = Single $ toType v +instance GPU Int32 where + tupleType v = Single $ toType v +instance GPU Word32 where + tupleType v = Single $ toType v +instance GPU V2B where + tupleType v = Single $ toType v +instance GPU V2F where + tupleType v = Single $ toType v +instance GPU V2I where + tupleType v = Single $ toType v +instance GPU V2U where + tupleType v = Single $ toType v +instance GPU V3B where + tupleType v = Single $ toType v +instance GPU V3F where + tupleType v = Single $ toType v +instance GPU V3I where + tupleType v = Single $ toType v +instance GPU V3U where + tupleType v = Single $ toType v +instance GPU V4B where + tupleType v = Single $ toType v +instance GPU V4F where + tupleType v = Single $ toType v +instance GPU V4I where + tupleType v = Single $ toType v +instance GPU V4U where + tupleType v = Single $ toType v +instance GPU M22F where + tupleType v = Single $ toType v +instance GPU M23F where + tupleType v = Single $ toType v +instance GPU M24F where + tupleType v = Single $ toType v +instance GPU M32F where + tupleType v = Single $ toType v +instance GPU M33F where + tupleType v = Single $ toType v +instance GPU M34F where + tupleType v = Single $ toType v +instance GPU M42F where + tupleType v = Single $ toType v +instance GPU M43F where + tupleType v = Single $ toType v +instance GPU M44F where + tupleType v = Single $ toType v +instance (GPU a, GPU b) => GPU (a, b) where + tupleType (v :: (a,b)) = Tuple + [ tupleType (undefined :: a) + , tupleType (undefined :: b) + ] +instance (GPU a, GPU b, GPU c) => GPU (a, b, c) where + tupleType (v :: (a,b,c)) = Tuple + [ tupleType (undefined :: a) + , tupleType (undefined :: b) + , tupleType (undefined :: c) + ] +instance (GPU a, GPU b, GPU c, GPU d) => GPU (a, b, c, d) where + tupleType (v :: (a,b,c,d)) = Tuple + [ tupleType (undefined :: a) + , tupleType (undefined :: b) + , tupleType (undefined :: c) + , tupleType (undefined :: d) + ] +instance (GPU a, GPU b, GPU c, GPU d, GPU e) => GPU (a, b, c, d, e) where + tupleType (v :: (a,b,c,d,e)) = Tuple + [ tupleType (undefined :: a) + , tupleType (undefined :: b) + , tupleType (undefined :: c) + , tupleType (undefined :: d) + , tupleType (undefined :: e) + ] +instance (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f) => GPU (a, b, c, d, e, f) where + tupleType (v :: (a,b,c,d,e,f)) = Tuple + [ tupleType (undefined :: a) + , tupleType (undefined :: b) + , tupleType (undefined :: c) + , tupleType (undefined :: d) + , tupleType (undefined :: e) + , tupleType (undefined :: f) + ] +instance (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g) => GPU (a, b, c, d, e, f, g) where + tupleType (v :: (a,b,c,d,e,f,g)) = Tuple + [ tupleType (undefined :: a) + , tupleType (undefined :: b) + , tupleType (undefined :: c) + , tupleType (undefined :: d) + , tupleType (undefined :: e) + , tupleType (undefined :: f) + , tupleType (undefined :: g) + ] +instance (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g, GPU h) => GPU (a, b, c, d, e, f, g, h) where + tupleType (v :: (a,b,c,d,e,f,g,h)) = Tuple + [ tupleType (undefined :: a) + , tupleType (undefined :: b) + , tupleType (undefined :: c) + , tupleType (undefined :: d) + , tupleType (undefined :: e) + , tupleType (undefined :: f) + , tupleType (undefined :: g) + , tupleType (undefined :: h) + ] +instance (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g, GPU h, GPU i) => GPU (a, b, c, d, e, f, g, h, i) where + tupleType (v :: (a,b,c,d,e,f,g,h,i)) = Tuple + [ tupleType (undefined :: a) + , tupleType (undefined :: b) + , tupleType (undefined :: c) + , tupleType (undefined :: d) + , tupleType (undefined :: e) + , tupleType (undefined :: f) + , tupleType (undefined :: g) + , tupleType (undefined :: h) + , tupleType (undefined :: i) + ] + +-- stream type restriction, these types can be used in vertex shader input +class GPU a => SGPU a +instance SGPU Int32 +instance SGPU Word32 +instance SGPU Float +instance SGPU M22F +instance SGPU M23F +instance SGPU M24F +instance SGPU M32F +instance SGPU M33F +instance SGPU M34F +instance SGPU M42F +instance SGPU M43F +instance SGPU M44F +instance SGPU V2F +instance SGPU V3F +instance SGPU V4F +instance SGPU V2I +instance SGPU V3I +instance SGPU V4I +instance SGPU V2U +instance SGPU V3U +instance SGPU V4U +instance (SGPU a, SGPU b) => SGPU (a, b) +instance (SGPU a, SGPU b, SGPU c) => SGPU (a, b, c) +instance (SGPU a, SGPU b, SGPU c, SGPU d) => SGPU (a, b, c, d) +instance (SGPU a, SGPU b, SGPU c, SGPU d, SGPU e) => SGPU (a, b, c, d, e) +instance (SGPU a, SGPU b, SGPU c, SGPU d, SGPU e, SGPU f) => SGPU (a, b, c, d, e, f) +instance (SGPU a, SGPU b, SGPU c, SGPU d, SGPU e, SGPU f, SGPU g) => SGPU (a, b, c, d, e, f, g) +instance (SGPU a, SGPU b, SGPU c, SGPU d, SGPU e, SGPU f, SGPU g, SGPU h) => SGPU (a, b, c, d, e, f, g, h) +instance (SGPU a, SGPU b, SGPU c, SGPU d, SGPU e, SGPU f, SGPU g, SGPU h, SGPU i) => SGPU (a, b, c, d, e, f, g, h, i) + +-- uniform type restriction +-- hint: EltRepr stands for Elementary Type Representation +type family EltRepr a :: * +type instance EltRepr (Sampler dim sh t ar) = ((), Sampler dim sh t ar) +type instance EltRepr () = () +type instance EltRepr Int32 = ((), Int32) +type instance EltRepr Word32 = ((), Word32) +type instance EltRepr Float = ((), Float) +type instance EltRepr Bool = ((), Bool) +type instance EltRepr V2F = ((), V2F) +type instance EltRepr V2I = ((), V2I) +type instance EltRepr V2U = ((), V2U) +type instance EltRepr V2B = ((), V2B) +type instance EltRepr M22F = ((), M22F) +type instance EltRepr M23F = ((), M23F) +type instance EltRepr M24F = ((), M24F) +type instance EltRepr V3F = ((), V3F) +type instance EltRepr V3I = ((), V3I) +type instance EltRepr V3U = ((), V3U) +type instance EltRepr V3B = ((), V3B) +type instance EltRepr M32F = ((), M32F) +type instance EltRepr M33F = ((), M33F) +type instance EltRepr M34F = ((), M34F) +type instance EltRepr V4F = ((), V4F) +type instance EltRepr V4I = ((), V4I) +type instance EltRepr V4U = ((), V4U) +type instance EltRepr V4B = ((), V4B) +type instance EltRepr M42F = ((), M42F) +type instance EltRepr M43F = ((), M43F) +type instance EltRepr M44F = ((), M44F) +type instance EltRepr (a, b) = (EltRepr a, EltRepr' b) +type instance EltRepr (a, b, c) = (EltRepr (a, b), EltRepr' c) +type instance EltRepr (a, b, c, d) = (EltRepr (a, b, c), EltRepr' d) +type instance EltRepr (a, b, c, d, e) = (EltRepr (a, b, c, d), EltRepr' e) +type instance EltRepr (a, b, c, d, e, f) = (EltRepr (a, b, c, d, e), EltRepr' f) +type instance EltRepr (a, b, c, d, e, f, g) = (EltRepr (a, b, c, d, e, f), EltRepr' g) +type instance EltRepr (a, b, c, d, e, f, g, h) = (EltRepr (a, b, c, d, e, f, g), EltRepr' h) +type instance EltRepr (a, b, c, d, e, f, g, h, i) = (EltRepr (a, b, c, d, e, f, g, h), EltRepr' i) + +type family EltRepr' a :: * +type instance EltRepr' (Sampler dim sh t ar) = Sampler dim sh t ar +type instance EltRepr' () = () +type instance EltRepr' Int32 = Int32 +type instance EltRepr' Word32 = Word32 +type instance EltRepr' Float = Float +type instance EltRepr' Bool = Bool +type instance EltRepr' V2F = V2F +type instance EltRepr' V2I = V2I +type instance EltRepr' V2U = V2U +type instance EltRepr' V2B = V2B +type instance EltRepr' M22F = M22F +type instance EltRepr' M23F = M23F +type instance EltRepr' M24F = M24F +type instance EltRepr' V3F = V3F +type instance EltRepr' V3I = V3I +type instance EltRepr' V3U = V3U +type instance EltRepr' V3B = V3B +type instance EltRepr' M32F = M32F +type instance EltRepr' M33F = M33F +type instance EltRepr' M34F = M34F +type instance EltRepr' V4F = V4F +type instance EltRepr' V4I = V4I +type instance EltRepr' V4U = V4U +type instance EltRepr' V4B = V4B +type instance EltRepr' M42F = M42F +type instance EltRepr' M43F = M43F +type instance EltRepr' M44F = M44F +type instance EltRepr' (a, b) = (EltRepr a, EltRepr' b) +type instance EltRepr' (a, b, c) = (EltRepr (a, b), EltRepr' c) +type instance EltRepr' (a, b, c, d) = (EltRepr (a, b, c), EltRepr' d) +type instance EltRepr' (a, b, c, d, e) = (EltRepr (a, b, c, d), EltRepr' e) +type instance EltRepr' (a, b, c, d, e, f) = (EltRepr (a, b, c, d, e), EltRepr' f) +type instance EltRepr' (a, b, c, d, e, f, g) = (EltRepr (a, b, c, d, e, f), EltRepr' g) +type instance EltRepr' (a, b, c, d, e, f, g, h) = (EltRepr (a, b, c, d, e, f, g), EltRepr' h) +type instance EltRepr' (a, b, c, d, e, f, g, h, i) = (EltRepr (a, b, c, d, e, f, g, h), EltRepr' i) + +-- |Conversion between surface n-tuples and our tuple representation. +-- +-- our language uses nested tuple representation +class IsTuple tup where + type TupleRepr tup + +instance IsTuple () where + type TupleRepr () = () + +instance IsTuple (a, b) where + type TupleRepr (a, b) = (((), a), b) + +instance IsTuple (a, b, c) where + type TupleRepr (a, b, c) = (TupleRepr (a, b), c) + +instance IsTuple (a, b, c, d) where + type TupleRepr (a, b, c, d) = (TupleRepr (a, b, c), d) + +instance IsTuple (a, b, c, d, e) where + type TupleRepr (a, b, c, d, e) = (TupleRepr (a, b, c, d), e) + +instance IsTuple (a, b, c, d, e, f) where + type TupleRepr (a, b, c, d, e, f) = (TupleRepr (a, b, c, d, e), f) + +instance IsTuple (a, b, c, d, e, f, g) where + type TupleRepr (a, b, c, d, e, f, g) = (TupleRepr (a, b, c, d, e, f), g) + +instance IsTuple (a, b, c, d, e, f, g, h) where + type TupleRepr (a, b, c, d, e, f, g, h) = (TupleRepr (a, b, c, d, e, f, g), h) + +instance IsTuple (a, b, c, d, e, f, g, h, i) where + type TupleRepr (a, b, c, d, e, f, g, h, i) = (TupleRepr (a, b, c, d, e, f, g, h), i) + +-- Tuple representation +-- -------------------- + +-- |We represent tuples as heterogenous lists, typed by a type list. +-- +data Tuple c t where + NilTup :: Tuple c () + SnocTup :: GPU t => Tuple c s -> c t -> Tuple c (s, t) + +-- |Type-safe projection indicies for tuples. +-- +-- NB: We index tuples by starting to count from the *right*! +-- +data TupleIdx t e where + ZeroTupIdx :: GPU s => TupleIdx (t, s) s + SuccTupIdx :: TupleIdx t e -> TupleIdx (t, s) e + +-- Auxiliary tuple index constants +-- +tix0 :: GPU s => TupleIdx (t, s) s +tix0 = ZeroTupIdx +tix1 :: GPU s => TupleIdx ((t, s), s1) s +tix1 = SuccTupIdx tix0 +tix2 :: GPU s => TupleIdx (((t, s), s1), s2) s +tix2 = SuccTupIdx tix1 +tix3 :: GPU s => TupleIdx ((((t, s), s1), s2), s3) s +tix3 = SuccTupIdx tix2 +tix4 :: GPU s => TupleIdx (((((t, s), s1), s2), s3), s4) s +tix4 = SuccTupIdx tix3 +tix5 :: GPU s => TupleIdx ((((((t, s), s1), s2), s3), s4), s5) s +tix5 = SuccTupIdx tix4 +tix6 :: GPU s => TupleIdx (((((((t, s), s1), s2), s3), s4), s5), s6) s +tix6 = SuccTupIdx tix5 +tix7 :: GPU s => TupleIdx ((((((((t, s), s1), s2), s3), s4), s5), s6), s7) s +tix7 = SuccTupIdx tix6 +tix8 :: GPU s => TupleIdx (((((((((t, s), s1), s2), s3), s4), s5), s6), s7), s8) s +tix8 = SuccTupIdx tix7 diff --git a/LC_T_HOAS.hs b/LC_T_HOAS.hs new file mode 100644 --- /dev/null +++ b/LC_T_HOAS.hs @@ -0,0 +1,236 @@ +module LC_T_HOAS where + +import GHC.TypeLits + +import Data.ByteString.Char8 +import Data.Int + +import LC_G_Type +import LC_G_APIType (Filter(..),EdgeMode(..)) +import LC_T_APIType +import LC_T_DSLType +import LC_T_PrimFun + +-- Common Exp, describes shader functions +data Exp :: Frequency -> * -> * where + -- Needed for conversion to de Bruijn form + Tag :: GPU t + => Int + -> String + -> Exp stage t + -- environment size at defining occurrence +{- + -- function support + Lam :: (GPU a, GPU b) + => (Exp stage a -> Exp stage b) + -> Exp stage (a -> b) + + App :: (GPU a, GPU b) + => Exp stage a + -> Exp stage (a -> b) + -> Exp stage b +-} + -- constant value + Const :: (GPU t,IsScalar t) + => t + -> Exp stage t + + -- builtin variable + PrimVar :: GPU t + => Input t + -> Exp stage t + + -- uniform value + Uni :: GPU t + => Input t + -> Exp stage t + + -- conditional expression + Cond :: GPU t + => Exp stage Bool + -> Exp stage t + -> Exp stage t + -> Exp stage t + + PrimApp :: (GPU a, GPU r) + => PrimFun stage (a -> r) + -> Exp stage a + -> Exp stage r + + -- tuple support + Tup :: (GPU t, IsTuple t) + => Tuple (Exp stage) (TupleRepr t) + -> Exp stage t + + Prj :: (GPU e, GPU t, IsTuple t) + => TupleIdx (TupleRepr t) e + -> Exp stage t + -> Exp stage e + + -- sampler support + Sampler :: GPU (Sampler dim arr t ar) + => Filter + -> EdgeMode + -> Texture (Exp Obj) dim arr t ar + -> Exp stage (Sampler dim arr t ar) + + -- loop support + Loop :: (GPU s, GPU a) + => (Exp stage s -> Exp stage s) -- state transform function + -> (Exp stage s -> Exp stage Bool) -- loop condition function + -> (Exp stage s -> Exp stage a) -- state to result transform function + -> Exp stage s -- initial state + -> Exp stage a -- result + -- GP + -- hint: GP stands for Graphics Pipeline + Fetch :: (InputTuple a, SGPU (InputTupleRepr a)) + => ByteString + -> FetchPrimitive primitive + -> a + -> Exp Obj (VertexStream primitive (InputTupleRepr a)) + + Transform :: (GPU a, GPU b) + => (Exp V a -> VertexOut clipDistances b) -- vertex shader + -> Exp Obj (VertexStream primitive a) + -> Exp Obj (PrimitiveStream primitive clipDistances 1 V b) + + Reassemble :: GeometryShader inputPrimitive outputPrimitive inputClipDistances outputClipDistances layerCount a b + -> Exp Obj (PrimitiveStream inputPrimitive inputClipDistances 1 V a) + -> Exp Obj (PrimitiveStream outputPrimitive outputClipDistances layerCount G b) + + Rasterize :: RasterContext primitive + -> Exp Obj (PrimitiveStream primitive clipDistances layerCount freq a) + -> Exp Obj (FragmentStream layerCount a) + + FrameBuffer :: FrameBuffer layerCount t + -> Exp Obj (FrameBuffer layerCount (FTRepr' t)) + + Accumulate :: (GPU a, GPU (FTRepr' b), IsValidOutput b) -- restriction: depth and stencil optional, arbitrary color component + => AccumulationContext b + -> FragmentFilter a + -> (Exp F a -> FragmentOut (NoStencilRepr b)) -- fragment shader + -> Exp Obj (FragmentStream layerCount a) + -> Exp Obj (FrameBuffer layerCount (FTRepr' b)) + -> Exp Obj (FrameBuffer layerCount (FTRepr' b)) + + PrjFrameBuffer :: ByteString -- internal image output (can be allocated on request) + -> TupleIdx (EltRepr b) t + -> Exp Obj (FrameBuffer layerCount b) + -> Exp Obj (Image layerCount t) + + PrjImage :: ((idx + 1) <= layerCount, 2 <= layerCount, SingI idx) + => ByteString -- internal image output (can be allocated on request) + -> NatNum idx + -> Exp Obj (Image layerCount t) + -> Exp Obj (Image 1 t) +{- + -- dynamic extension support + AccumulateSet :: GPU a + => ByteString + -> Exp Obj (FrameBuffer layerCount a) + -> Exp Obj (FrameBuffer layerCount a) +-} + +type InterpolatedFlatExp stage a = FlatTuple GPU (Interpolated (Exp stage)) a +type FlatExp stage a = FlatTuple GPU (Exp stage) a + +-- Vertex +{- + Vertex shader builtin output: + gl_PerVertex { + vec4 gl_Position + float gl_PointSize + float gl_ClipDistance[] + } +-} +-- result of a vertex or geometry shader function +data VertexOut clipDistances t where + VertexOut :: IsFloatTuple clipDistances + => Exp V V4F -- position + -> Exp V Float -- point size + -> FlatExp V clipDistances -- clip distance [] + -> InterpolatedFlatExp V a + -> VertexOut (FTRepr clipDistances) (FTRepr a) + +-- Geometry +-- describes a geometry shader +data GeometryShader (inPrimitive :: PrimitiveType) (outPrimitive :: PrimitiveType) inClipDistances outClipDistances (layerCount :: Nat) a b where + GeometryShader :: (GPU j, GPU i, GPU b, GPU outputClipDistances, GPU input, SingI layerCount + , inputVertex ~ (V4F,Float,inputClipDistances,a) + , input ~ PrimitiveVertices inputPrimitive inputVertex + ) + => NatNum layerCount -- geometry shader: + -> OutputPrimitive outputPrimitive -- output primitive + -> Int -- max amount of generated vertices + -> (Exp G input -> Exp G (i,Int32)) -- how many primitives? + -> (Exp G i -> Exp G (Int32,Int32,i,j,Int32)) -- how many vertices? primtive loop, out: + -- gl_PrimitiveID; gl_Layer; loop var; vertex loop seed; vertex loop iteration count) + -> (Exp G j -> GeometryOut j outputClipDistances b) -- generate vertices + -> GeometryShader inputPrimitive outputPrimitive inputClipDistances outputClipDistances layerCount a b +{- + GeometryShader :: (GPU (PrimitiveVertices primIn a), GPU i, GPU j, GPU b, IsPrimitive primIn, IsPrimitive primOut, SingI layerNum) + => NatNum layerNum -- geometry shader: + -> primOut -- output primitive + -> Int -- max amount of generated vertices + -> (Exp G (PrimitiveVertices primIn a) -> Exp G (i,Int32)) -- how many primitives? + -> (Exp G i -> Exp G (i,j,Int32)) -- how many vertices? + -> (Exp G j -> GeometryOut (j,b)) -- generate vertices + -> GeometryShader primIn primOut layerNum a b +-} + +{- + Geometry shader builtin output: + gl_PerVertex { + vec4 gl_Position + float gl_PointSize + float gl_ClipDistance[] + } + int gl_PrimitiveID + int gl_Layer +-} +-- result of a geometry shader function +data GeometryOut i clipDistances t where + GeometryOut :: IsFloatTuple clipDistances + => Exp G i + -> Exp G V4F -- position + -> Exp G Float -- point size + -> FlatExp G clipDistances -- clip distance [] + -> InterpolatedFlatExp G a + -> GeometryOut i (FTRepr clipDistances) (FTRepr a) + +-- Fragment +{- + Fragment shader builtin output: + float gl_FragDepth -- Optional +-} +-- result of a fragment shader function +data FragmentOut t where + FragmentOut :: FlatExp F a + -> FragmentOut (ColorRepr a) + + FragmentOutDepth :: Exp F Float + -> FlatExp F a + -> FragmentOut (Depth Float :+: ColorRepr a) + + FragmentOutRastDepth :: FlatExp F a + -> FragmentOut (Depth Float :+: ColorRepr a) + +-- fragment filter function, we express discard using a filter function +data FragmentFilter a where + PassAll :: FragmentFilter a + + Filter :: (Exp F a -> Exp F Bool) + -> FragmentFilter a + + +data GPOutput (o :: OutputType) where + ImageOut :: ByteString + -> V2U + -> Exp Obj (Image 1 t) + -> GPOutput SingleOutput + + ScreenOut :: Exp Obj (Image 1 t) + -> GPOutput SingleOutput + + MultiOut :: [GPOutput SingleOutput] + -> GPOutput MultiOutput diff --git a/LC_T_Language.hs b/LC_T_Language.hs new file mode 100644 --- /dev/null +++ b/LC_T_Language.hs @@ -0,0 +1,508 @@ +{-# LANGUAGE UndecidableInstances, OverlappingInstances #-} +module LC_T_Language where + +import Data.Int +import Data.Word + +import LC_G_Type +import LC_T_APIType +import LC_T_DSLType +import LC_T_PrimFun +import LC_T_HOAS +{- + all operatiors with @<>?,./\';""|:}{+_)0-=§±!@#$%^&*()_+ + <+> <+.> <.+> -- good, conflict: <*> + [+] [+.] [.+] -- good, conflict with lists + |+| |+.| |.+| -- medium + @+ @+. @.+ -- bad + :+: :+.: :.+: -- bad + [*] +-} +{- +infixl 7 .*., ./., .%. +infixl 6 .+., .-. +infix 4 .==., ./=., .<., .<=., .>=., .>. + +infixr 3 .&&. +infixr 2 .||. + +infixl 8 .>>., .<<. +infixl 7 .&. +infixl 6 .^. +infixl 5 .|. +-} + +infixl 7 @*, @/, @% +infixl 6 @+, @- +infix 4 @==, @/=, @<, @<=, @>=, @> + +infixr 3 @&& +infixr 2 @|| + +infixl 8 @>>, @<< +infixl 7 @& +infixl 6 @^ +infixl 5 @| + +infix 7 @. -- dot +infix 7 @# -- cross +infixr 7 @*. -- mulmv +infixl 7 @.* -- mulvm +infixl 7 @.*. -- mulmm + +-- TODO: we should use template haskell or a preprocessor to generate the instances +class OperatorArithmetic a b where + (@+) :: a -> b -> a + (@-) :: a -> b -> a + (@*) :: a -> b -> a + +instance (GPU (V2 t), IsNumComponent t, IsMatVec (V2 t) c, IsNum c) => OperatorArithmetic (Exp stage (V2 t)) (Exp stage (V2 t)) where + a @+ b = PrimApp PrimAdd $! tup2 (a,b) + a @- b = PrimApp PrimSub $! tup2 (a,b) + a @* b = PrimApp PrimMul $! tup2 (a,b) + +instance (GPU (V3 t), IsNumComponent t, IsMatVec (V3 t) c, IsNum c) => OperatorArithmetic (Exp stage (V3 t)) (Exp stage (V3 t)) where + a @+ b = PrimApp PrimAdd $! tup2 (a,b) + a @- b = PrimApp PrimSub $! tup2 (a,b) + a @* b = PrimApp PrimMul $! tup2 (a,b) + +instance (GPU (V4 t), IsNumComponent t, IsMatVec (V4 t) c, IsNum c) => OperatorArithmetic (Exp stage (V4 t)) (Exp stage (V4 t)) where + a @+ b = PrimApp PrimAdd $! tup2 (a,b) + a @- b = PrimApp PrimSub $! tup2 (a,b) + a @* b = PrimApp PrimMul $! tup2 (a,b) + +instance (GPU c, GPU (V2 t), IsNumComponent t, IsMatVecScalar (V2 t) c, IsNum c) => OperatorArithmetic (Exp stage (V2 t)) (Exp stage c) where + a @+ b = PrimApp PrimAddS $! tup2 (a,b) + a @- b = PrimApp PrimSubS $! tup2 (a,b) + a @* b = PrimApp PrimMulS $! tup2 (a,b) + +instance (GPU c, GPU (V3 t), IsNumComponent t, IsMatVecScalar (V3 t) c, IsNum c) => OperatorArithmetic (Exp stage (V3 t)) (Exp stage c) where + a @+ b = PrimApp PrimAddS $! tup2 (a,b) + a @- b = PrimApp PrimSubS $! tup2 (a,b) + a @* b = PrimApp PrimMulS $! tup2 (a,b) + +instance (GPU c, GPU (V4 t), IsNumComponent t, IsMatVecScalar (V4 t) c, IsNum c) => OperatorArithmetic (Exp stage (V4 t)) (Exp stage c) where + a @+ b = PrimApp PrimAddS $! tup2 (a,b) + a @- b = PrimApp PrimSubS $! tup2 (a,b) + a @* b = PrimApp PrimMulS $! tup2 (a,b) + +instance (GPU a, GPU t, IsNum t, IsMatVecScalar a t) => OperatorArithmetic (Exp stage a) (Exp stage t) where + a @+ b = PrimApp PrimAddS $! tup2 (a,b) + a @- b = PrimApp PrimSubS $! tup2 (a,b) + a @* b = PrimApp PrimMulS $! tup2 (a,b) + +{- +instance (GPU a, IsNum t, IsMatVec a t) => OperatorArithmetic (Exp stage a) (Exp stage a) (Exp stage a) where + a @+ b = PrimApp PrimAdd $! tup2 (a,b) + a @- b = PrimApp PrimSub $! tup2 (a,b) + a @* b = PrimApp PrimMul $! tup2 (a,b) + +instance (GPU a, GPU t, IsNum t, IsMatVecScalar a t) => OperatorArithmetic (Exp stage a) (Exp stage t) (Exp stage a) where + a @+ b = PrimApp PrimAddS $! tup2 (a,b) + a @- b = PrimApp PrimSubS $! tup2 (a,b) + a @* b = PrimApp PrimMulS $! tup2 (a,b) +-} +{- +instance OperatorArithmetic (Exp stage V4F) (Exp stage V4F) (Exp stage V4F) where + a @+ b = PrimApp PrimAdd $! tup2 (a,b) + a @- b = PrimApp PrimSub $! tup2 (a,b) + a @* b = PrimApp PrimMul $! tup2 (a,b) + +instance OperatorArithmetic (Exp stage V4F) (Exp stage Float) (Exp stage V4F) where + a @+ b = PrimApp PrimAddS $! tup2 (a,b) + a @- b = PrimApp PrimSubS $! tup2 (a,b) + a @* b = PrimApp PrimMulS $! tup2 (a,b) +-} + +-- FIXME: modulus % is defined only for integral types +class OperatorDivide a b where + (@/) :: a -> b -> a + (@%) :: a -> b -> a + +instance (GPU a, IsNum t, IsVecScalar d a t) => OperatorDivide (Exp stage a) (Exp stage a) where + a @/ b = PrimApp PrimDiv $! tup2 (a,b) + a @% b = PrimApp PrimMod $! tup2 (a,b) + +instance (GPU a, GPU t, IsNum t, IsVecScalar d a t) => OperatorDivide (Exp stage a) (Exp stage t) where + a @/ b = PrimApp PrimDivS $! tup2 (a,b) + a @% b = PrimApp PrimModS $! tup2 (a,b) + +class OperatorBit a b where + (@&) :: a -> b -> a + (@|) :: a -> b -> a + (@^) :: a -> b -> a + +instance (GPU a, IsIntegral t, IsVecScalar d a t) => OperatorBit (Exp stage a) (Exp stage a) where + a @& b = PrimApp PrimBAnd $! tup2 (a,b) + a @| b = PrimApp PrimBOr $! tup2 (a,b) + a @^ b = PrimApp PrimBXor $! tup2 (a,b) + +instance (GPU a, GPU t, IsIntegral t, IsVecScalar d a t) => OperatorBit (Exp stage a) (Exp stage t) where + a @& b = PrimApp PrimBAndS $! tup2 (a,b) + a @| b = PrimApp PrimBOrS $! tup2 (a,b) + a @^ b = PrimApp PrimBXorS $! tup2 (a,b) + +class OperatorShift a b where + (@>>) :: a -> b -> a + (@<<) :: a -> b -> a + +instance (GPU a, GPU b, IsIntegral t, IsVecScalar d a t, IsVecScalar d b Word32) => OperatorShift (Exp stage a) (Exp stage b) where + a @>> b = PrimApp PrimBShiftR $! tup2 (a,b) + a @<< b = PrimApp PrimBShiftL $! tup2 (a,b) + +instance (GPU a, IsIntegral t, IsVecScalar d a t) => OperatorShift (Exp stage a) (Exp stage Word32) where + a @>> b = PrimApp PrimBShiftRS $! tup2 (a,b) + a @<< b = PrimApp PrimBShiftLS $! tup2 (a,b) + +class OperatorEq a b where + (@==) :: a -> a -> b + (@/=) :: a -> a -> b + +instance (GPU a, GPU b, IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => OperatorEq (Exp stage a) (Exp stage b) where + a @== b = PrimApp PrimEqualV $! tup2 (a,b) + a @/= b = PrimApp PrimNotEqualV $! tup2 (a,b) + +instance (GPU a, IsMatVecScalar a t) => OperatorEq (Exp stage a) (Exp stage Bool) where + a @== b = PrimApp PrimEqual $! tup2 (a,b) + a @/= b = PrimApp PrimNotEqual $! tup2 (a,b) + +class OperatorRelational a b where + (@<=) :: a -> a -> b + (@>=) :: a -> a -> b + (@<) :: a -> a -> b + (@>) :: a -> a -> b + +instance (GPU a, GPU b, IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => OperatorRelational (Exp stage a) (Exp stage b) where + a @<= b = PrimApp PrimLessThanEqual $! tup2 (a,b) + a @>= b = PrimApp PrimGreaterThanEqual $! tup2 (a,b) + a @< b = PrimApp PrimLessThan $! tup2 (a,b) + a @> b = PrimApp PrimGreaterThan $! tup2 (a,b) + +a @&& b = PrimApp PrimAnd $! tup2 (a,b) +a @|| b = PrimApp PrimOr $! tup2 (a,b) + +xor' a b = PrimApp PrimXor $! tup2 (a,b) +not' a = PrimApp PrimNot a +any' a = PrimApp PrimAny a +all' a = PrimApp PrimAll a + +acos' a = PrimApp PrimACos a +acosh' a = PrimApp PrimACosH a +asin' a = PrimApp PrimASin a +asinh' a = PrimApp PrimASinH a +atan' a = PrimApp PrimATan a +atan2' a b = PrimApp PrimATan2 $! tup2 (a,b) +atanh' a = PrimApp PrimATanH a +cos' a = PrimApp PrimCos a +cosh' a = PrimApp PrimCosH a +degrees' a = PrimApp PrimDegrees a +radians' a = PrimApp PrimRadians a +sin' a = PrimApp PrimSin a +sinh' a = PrimApp PrimSinH a +tan' a = PrimApp PrimTan a +tanh' a = PrimApp PrimTanH a + +pow' a b = PrimApp PrimPow $! tup2 (a,b) +exp' a = PrimApp PrimExp a +log' a = PrimApp PrimLog a +exp2' a = PrimApp PrimExp2 a +log2' a = PrimApp PrimLog2 a +sqrt' a = PrimApp PrimSqrt a +invsqrt' a = PrimApp PrimInvSqrt a + +isnan' a = PrimApp PrimIsNan a +isinf' a = PrimApp PrimIsInf a +abs' a = PrimApp PrimAbs a +sign' a = PrimApp PrimSign a +floor' a = PrimApp PrimFloor a +trunc' a = PrimApp PrimTrunc a +round' a = PrimApp PrimRound a +roundEven' a = PrimApp PrimRoundEven a +ceil' a = PrimApp PrimCeil a +fract' a = PrimApp PrimFract a + +floatBitsToInt' a = PrimApp PrimFloatBitsToInt a +floatBitsToUint' a = PrimApp PrimFloatBitsToUInt a +intBitsToFloat' a = PrimApp PrimIntBitsToFloat a +uintBitsToFloat' a = PrimApp PrimUIntBitsToFloat a + +length' a = PrimApp PrimLength a +distance' a b = PrimApp PrimDistance $! tup2 (a,b) +dot' a b = PrimApp PrimDot $! tup2 (a,b) +cross' a b = PrimApp PrimCross $! tup2 (a,b) +normalize' a = PrimApp PrimNormalize a +faceforward' a b c = PrimApp PrimFaceForward $! tup3 (a,b,c) +reflect' a b = PrimApp PrimReflect $! tup2 (a,b) +refract' a b c = PrimApp PrimRefract $! tup3 (a,b,c) + +transpose' a = PrimApp PrimTranspose a +determinant' a = PrimApp PrimDeterminant a +inverse' a = PrimApp PrimInverse a +outerProduct' a b = PrimApp PrimOuterProduct $! tup2 (a,b) + +dFdx' a = PrimApp PrimDFdx a +dFdy' a = PrimApp PrimDFdy a +fwidth' a = PrimApp PrimFWidth a + +noise1' a = PrimApp PrimNoise1 a +noise2' a = PrimApp PrimNoise2 a +noise3' a = PrimApp PrimNoise3 a +noise4' a = PrimApp PrimNoise4 a + +textureSize' a b = PrimApp PrimTextureSize $! tup2 (a,b) +texture' a b = PrimApp PrimTexture $! tup2 (a,b) +textureB' a b c = PrimApp PrimTextureB $! tup3 (a,b,c) +textureProj' a b = PrimApp PrimTextureProj $! tup2 (a,b) +textureProjB' a b c = PrimApp PrimTextureProjB $! tup3 (a,b,c) +textureLod' a b c = PrimApp PrimTextureLod $! tup3 (a,b,c) +textureOffset' a b c = PrimApp PrimTextureOffset $! tup3 (a,b,c) +textureOffsetB' a b c d = PrimApp PrimTextureOffsetB $! tup4 (a,b,c,d) +texelFetch' a b c = PrimApp PrimTexelFetch $! tup3 (a,b,c) +texelFetchOffset' a b c d = PrimApp PrimTexelFetchOffset $! tup4 (a,b,c,d) +textureProjOffset' a b c = PrimApp PrimTextureProjOffset $! tup3 (a,b,c) +textureProjOffsetB' a b c d = PrimApp PrimTextureProjOffsetB $! tup4 (a,b,c,d) +textureLodOffset' a b c d = PrimApp PrimTextureLodOffset $! tup4 (a,b,c,d) +textureProjLod' a b c = PrimApp PrimTextureProjLod $! tup3 (a,b,c) +textureProjLodOffset' a b c d = PrimApp PrimTextureProjLodOffset $! tup4 (a,b,c,d) +textureGrad' a b c d = PrimApp PrimTextureGrad $! tup4 (a,b,c,d) +textureGradOffset' a b c d e = PrimApp PrimTextureGradOffset $! tup5 (a,b,c,d,e) +textureProjGrad' a b c d = PrimApp PrimTextureProjGrad $! tup4 (a,b,c,d) +textureProjGradOffset' a b c d e = PrimApp PrimTextureProjGradOffset $! tup5 (a,b,c,d,e) + +class BuiltinCommon a b where + min' :: a -> b -> a + max' :: a -> b -> a + clamp' :: a -> b -> b -> a + +instance (GPU a, IsNum t, IsVecScalar d a t) => BuiltinCommon (Exp stage a) (Exp stage a) where + min' a b = PrimApp PrimMin $! tup2 (a,b) + max' a b = PrimApp PrimMax $! tup2 (a,b) + clamp' a b c = PrimApp PrimClamp $! tup3 (a,b,c) + +instance (GPU a, GPU t, IsNum t, IsVecScalar d a t) => BuiltinCommon (Exp stage a) (Exp stage t) where + min' a b = PrimApp PrimMinS $! tup2 (a,b) + max' a b = PrimApp PrimMaxS $! tup2 (a,b) + clamp' a b c = PrimApp PrimClampS $! tup3 (a,b,c) + +class BuiltinMix a b where + mix' :: a -> a -> b -> a + +instance (GPU a, IsVecScalar d a Float) => BuiltinMix (Exp stage a) (Exp stage a) where + mix' a b c = PrimApp PrimMix $! tup3 (a,b,c) + +instance (GPU a, IsVecScalar d a Float) => BuiltinMix (Exp stage a) (Exp stage Float) where + mix' a b c = PrimApp PrimMixS $! tup3 (a,b,c) + +instance (GPU a, GPU b, IsVecScalar d a Float, IsVecScalar d b Bool) => BuiltinMix (Exp stage a) (Exp stage b) where + mix' a b c = PrimApp PrimMixB $! tup3 (a,b,c) + +class BuiltinStep a b where + step' :: b -> a -> a + smoothstep' :: b -> b -> a -> a + +instance BuiltinStep (Exp stage V2F) (Exp stage V2F) where + step' a b = PrimApp PrimStep $! tup2 (a,b) + smoothstep' a b c = PrimApp PrimSmoothStep $! tup3 (a,b,c) + +instance BuiltinStep (Exp stage V3F) (Exp stage V3F) where + step' a b = PrimApp PrimStep $! tup2 (a,b) + smoothstep' a b c = PrimApp PrimSmoothStep $! tup3 (a,b,c) + +instance BuiltinStep (Exp stage V4F) (Exp stage V4F) where + step' a b = PrimApp PrimStep $! tup2 (a,b) + smoothstep' a b c = PrimApp PrimSmoothStep $! tup3 (a,b,c) + +instance (GPU a, IsVecScalar d a Float) => BuiltinStep (Exp stage a) (Exp stage Float) where + step' a b = PrimApp PrimStepS $! tup2 (a,b) + smoothstep' a b c = PrimApp PrimSmoothStepS $! tup3 (a,b,c) + +a @. b = dot' a b +a @# b = cross' a b +a @*. b = PrimApp PrimMulMatVec $! tup2 (a,b) +a @.* b = PrimApp PrimMulVecMat $! tup2 (a,b) +a @.*. b = PrimApp PrimMulMatMat $! tup2 (a,b) + +complement' a = PrimApp PrimBNot a +neg' a = PrimApp PrimNeg a +modf' a = PrimApp PrimModF a + +{- +data PrimFun sig where + + -- Vec/Mat (de)construction + PrimTupToV2 :: IsComponent a => PrimFun ((a,a) -> V2 a) + PrimTupToV3 :: IsComponent a => PrimFun ((a,a,a) -> V3 a) + PrimTupToV4 :: IsComponent a => PrimFun ((a,a,a,a) -> V4 a) + PrimV2ToTup :: IsComponent a => PrimFun (V2 a -> (a,a)) + PrimV3ToTup :: IsComponent a => PrimFun (V3 a -> (a,a,a)) + PrimV4ToTup :: IsComponent a => PrimFun (V4 a -> (a,a,a,a)) +-} +--mkV2 a b = +--mkV3 +--mkV4 + +class SpecialConstant a where + zero' :: a + one' :: a + +instance SpecialConstant Bool where + zero' = False + one' = True + +instance SpecialConstant Int32 where + zero' = 0 + one' = 1 + +instance SpecialConstant Word32 where + zero' = 0 + one' = 1 + +instance SpecialConstant Float where + zero' = 0 + one' = 1 + +instance (SpecialConstant a) => SpecialConstant (V2 a) where + zero' = V2 zero' zero' + one' = V2 one' one' + +instance (SpecialConstant a) => SpecialConstant (V3 a) where + zero' = V3 zero' zero' zero' + one' = V3 one' one' one' + +instance (SpecialConstant a) => SpecialConstant (V4 a) where + zero' = V4 zero' zero' zero' zero' + one' = V4 one' one' one' one' + +class IdentityMatrix a where + idmtx' :: a + +instance IdentityMatrix M22F where + idmtx' = V2 (V2 1 0) (V2 0 1) + +instance IdentityMatrix M33F where + idmtx' = V3 (V3 1 0 0) (V3 0 1 0) (V3 0 0 1) + +instance IdentityMatrix M44F where + idmtx' = V4 (V4 1 0 0 0) (V4 0 1 0 0) (V4 0 0 1 0) (V4 0 0 0 1) +{- + TODO: + extendZero + extendWith + trim +-} + +class PkgVec v where + unpack' :: (GPU a, GPU (v a), IsComponent a) + => Exp stage (v a) -> v (Exp stage a) + + pack' :: (GPU a, GPU (v a), IsComponent a) + => v (Exp stage a) -> Exp stage (v a) + +instance PkgVec V2 where + unpack' v = let (x,y) = untup2 $! PrimApp PrimV2ToTup v in V2 x y + pack' (V2 x y) = PrimApp PrimTupToV2 $! tup2 (x,y) + +instance PkgVec V3 where + unpack' v = let (x,y,z) = untup3 $! PrimApp PrimV3ToTup v in V3 x y z + pack' (V3 x y z) = PrimApp PrimTupToV3 $! tup3 (x,y,z) + +instance PkgVec V4 where + unpack' v = let (x,y,z,w) = untup4 $! PrimApp PrimV4ToTup v in V4 x y z w + pack' (V4 x y z w) = PrimApp PrimTupToV4 $! tup4 (x,y,z,w) + +-- Smart constructor and destructors for tuples +-- +tup0 :: Exp freq () +tup0 = Tup NilTup + +tup2 :: (GPU a, GPU b) + => (Exp stage a, Exp stage b) -> Exp stage (a, b) +tup2 (x1, x2) = Tup (NilTup `SnocTup` x1 `SnocTup` x2) + +tup3 :: (GPU a, GPU b, GPU c) + => (Exp stage a, Exp stage b, Exp stage c) -> Exp stage (a, b, c) +tup3 (x1, x2, x3) = Tup (NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3) + +tup4 :: (GPU a, GPU b, GPU c, GPU d) + => (Exp stage a, Exp stage b, Exp stage c, Exp stage d) -> Exp stage (a, b, c, d) +tup4 (x1, x2, x3, x4) = Tup (NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4) + +tup5 :: (GPU a, GPU b, GPU c, GPU d, GPU e) + => (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e) -> Exp stage (a, b, c, d, e) +tup5 (x1, x2, x3, x4, x5) = Tup $! NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5 + +tup6 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f) + => (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f) -> Exp stage (a, b, c, d, e, f) +tup6 (x1, x2, x3, x4, x5, x6) = Tup $! NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5 `SnocTup` x6 + +tup7 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g) + => (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f, Exp stage g) -> Exp stage (a, b, c, d, e, f, g) +tup7 (x1, x2, x3, x4, x5, x6, x7) + = Tup $! NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5 `SnocTup` x6 `SnocTup` x7 + +tup8 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g, GPU h) + => (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f, Exp stage g, Exp stage h) -> Exp stage (a, b, c, d, e, f, g, h) +tup8 (x1, x2, x3, x4, x5, x6, x7, x8) + = Tup $! NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5 `SnocTup` x6 `SnocTup` x7 `SnocTup` x8 + +tup9 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g, GPU h, GPU i) + => (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f, Exp stage g, Exp stage h, Exp stage i) -> Exp stage (a, b, c, d, e, f, g, h, i) +tup9 (x1, x2, x3, x4, x5, x6, x7, x8, x9) + = Tup $! NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5 `SnocTup` x6 `SnocTup` x7 `SnocTup` x8 `SnocTup` x9 + +untup2 :: (GPU a, GPU b) + => Exp stage (a, b) -> (Exp stage a, Exp stage b) +untup2 e = (tix1 `Prj` e, tix0 `Prj` e) + +untup3 :: (GPU a, GPU b, GPU c) + => Exp stage (a, b, c) -> (Exp stage a, Exp stage b, Exp stage c) +untup3 e = (tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e) + +untup4 :: (GPU a, GPU b, GPU c, GPU d) + => Exp stage (a, b, c, d) -> (Exp stage a, Exp stage b, Exp stage c, Exp stage d) +untup4 e = (tix3 `Prj` e, tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e) + +untup5 :: (GPU a, GPU b, GPU c, GPU d, GPU e) + => Exp stage (a, b, c, d, e) -> (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e) +untup5 e = (tix4 `Prj` e, tix3 `Prj` e, tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e) + +untup6 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f) + => Exp stage (a, b, c, d, e, f) -> (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f) +untup6 e = (tix5 `Prj` e, tix4 `Prj` e, tix3 `Prj` e, tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e) + +untup7 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g) + => Exp stage (a, b, c, d, e, f, g) -> (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f, Exp stage g) +untup7 e = (tix6 `Prj` e, tix5 `Prj` e, tix4 `Prj` e, tix3 `Prj` e, tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e) + +untup8 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g, GPU h) + => Exp stage (a, b, c, d, e, f, g, h) -> (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f, Exp stage g, Exp stage h) +untup8 e = (tix7 `Prj` e, tix6 `Prj` e, tix5 `Prj` e, tix4 `Prj` e, tix3 `Prj` e, tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e) + +untup9 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g, GPU h, GPU i) + => Exp stage (a, b, c, d, e, f, g, h, i) -> (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f, Exp stage g, Exp stage h, Exp stage i) +untup9 e = (tix8 `Prj` e, tix7 `Prj` e, tix6 `Prj` e, tix5 `Prj` e, tix4 `Prj` e, tix3 `Prj` e, tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e) + +-- builtin variables +-- vertex shader +vertexID' :: Exp V Int32 +vertexID' = PrimVar $ IInt "gl_VertexID" + +instanceID' :: Exp V Int32 +instanceID' = PrimVar $ IInt "gl_InstanceID" + +-- geometry shader +primitiveIDIn' :: Exp G Int32 +primitiveIDIn' = PrimVar $ IInt "gl_PrimitiveIDIn" + +-- fragment shader +fragCoord' :: Exp F V4F +fragCoord' = PrimVar $ IV4F "gl_FragCoord" + +frontFacing' :: Exp F Bool +frontFacing' = PrimVar $ IBool "gl_FrontFacing" + +pointCoord' :: Exp F V2F +pointCoord' = PrimVar $ IV2F "gl_PointCoord" + +primitiveID' :: Exp F Int32 +primitiveID' = PrimVar $ IInt "gl_PrimitiveID" diff --git a/LC_T_PrimFun.hs b/LC_T_PrimFun.hs new file mode 100644 --- /dev/null +++ b/LC_T_PrimFun.hs @@ -0,0 +1,172 @@ +module LC_T_PrimFun where + +import Data.Int +import Data.Word + +import LC_G_Type +import LC_T_Sampler +import LC_T_APIType + +data PrimFun stage sig where + + -- Vec/Mat (de)construction + PrimTupToV2 :: IsComponent a => PrimFun stage ((a,a) -> V2 a) + PrimTupToV3 :: IsComponent a => PrimFun stage ((a,a,a) -> V3 a) + PrimTupToV4 :: IsComponent a => PrimFun stage ((a,a,a,a) -> V4 a) + PrimV2ToTup :: IsComponent a => PrimFun stage (V2 a -> (a,a)) + PrimV3ToTup :: IsComponent a => PrimFun stage (V3 a -> (a,a,a)) + PrimV4ToTup :: IsComponent a => PrimFun stage (V4 a -> (a,a,a,a)) + + -- Arithmetic Functions (componentwise) + PrimAdd :: (IsNum t, IsMatVec a t) => PrimFun stage ((a,a) -> a) + PrimAddS :: (IsNum t, IsMatVecScalar a t) => PrimFun stage ((a,t) -> a) + PrimSub :: (IsNum t, IsMatVec a t) => PrimFun stage ((a,a) -> a) + PrimSubS :: (IsNum t, IsMatVecScalar a t) => PrimFun stage ((a,t) -> a) + PrimMul :: (IsNum t, IsMatVec a t) => PrimFun stage ((a,a) -> a) + PrimMulS :: (IsNum t, IsMatVecScalar a t) => PrimFun stage ((a,t) -> a) + PrimDiv :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a) + PrimDivS :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a) + PrimNeg :: (IsSigned t, IsMatVecScalar a t) => PrimFun stage (a -> a) + PrimMod :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a) + PrimModS :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a) + + -- Bit-wise Functions + PrimBAnd :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a) + PrimBAndS :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a) + PrimBOr :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a) + PrimBOrS :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a) + PrimBXor :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a) + PrimBXorS :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a) + PrimBNot :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage (a -> a) + PrimBShiftL :: (IsIntegral t, IsVecScalar d a t, IsVecScalar d b Word32) => PrimFun stage ((a, b) -> a) + PrimBShiftLS :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a, Word32) -> a) + PrimBShiftR :: (IsIntegral t, IsVecScalar d a t, IsVecScalar d b Word32) => PrimFun stage ((a, b) -> a) + PrimBShiftRS :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a, Word32) -> a) + + -- Logic Functions + PrimAnd :: PrimFun stage ((Bool,Bool) -> Bool) + PrimOr :: PrimFun stage ((Bool,Bool) -> Bool) + PrimXor :: PrimFun stage ((Bool,Bool) -> Bool) + PrimNot :: IsVecScalar d a Bool => PrimFun stage (a -> a) + PrimAny :: IsVecScalar d a Bool => PrimFun stage (a -> Bool) + PrimAll :: IsVecScalar d a Bool => PrimFun stage (a -> Bool) + + -- Angle and Trigonometry Functions + PrimACos :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimACosH :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimASin :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimASinH :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimATan :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimATan2 :: IsVecScalar d a Float => PrimFun stage ((a,a) -> a) + PrimATanH :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimCos :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimCosH :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimDegrees :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimRadians :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimSin :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimSinH :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimTan :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimTanH :: IsVecScalar d a Float => PrimFun stage (a -> a) + + -- Exponential Functions + PrimPow :: IsVecScalar d a Float => PrimFun stage ((a,a) -> a) + PrimExp :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimLog :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimExp2 :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimLog2 :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimSqrt :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimInvSqrt :: IsVecScalar d a Float => PrimFun stage (a -> a) + + -- Common Functions + PrimIsNan :: (IsVecScalar d a Float, IsVecScalar d b Bool) => PrimFun stage (a -> b) + PrimIsInf :: (IsVecScalar d a Float, IsVecScalar d b Bool) => PrimFun stage (a -> b) + PrimAbs :: (IsSigned t, IsVecScalar d a t) => PrimFun stage (a -> a) + PrimSign :: (IsSigned t, IsVecScalar d a t) => PrimFun stage (a -> a) + PrimFloor :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimTrunc :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimRound :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimRoundEven :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimCeil :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimFract :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimModF :: IsVecScalar d a Float => PrimFun stage (a -> (a,a)) + PrimMin :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a) + PrimMinS :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a) + PrimMax :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a) + PrimMaxS :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a) + PrimClamp :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,a,a) -> a) + PrimClampS :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,t,t) -> a) + PrimMix :: IsVecScalar d a Float => PrimFun stage ((a,a,a) -> a) + PrimMixS :: IsVecScalar d a Float => PrimFun stage ((a,a,Float) -> a) + PrimMixB :: (IsVecScalar d a Float, IsVecScalar d b Bool) => PrimFun stage ((a,a,b) -> a) + PrimStep :: IsVec d a Float => PrimFun stage ((a,a) -> a) + PrimStepS :: IsVecScalar d a Float => PrimFun stage ((Float,a) -> a) + PrimSmoothStep :: IsVec d a Float => PrimFun stage ((a,a,a) -> a) + PrimSmoothStepS :: IsVecScalar d a Float => PrimFun stage ((Float,Float,a) -> a) + + -- Integer/Float Conversion Functions + PrimFloatBitsToInt :: (IsVecScalar d fv Float, IsVecScalar d iv Int32) => PrimFun stage (fv -> iv) + PrimFloatBitsToUInt :: (IsVecScalar d fv Float, IsVecScalar d uv Word32) => PrimFun stage (fv -> uv) + PrimIntBitsToFloat :: (IsVecScalar d fv Float, IsVecScalar d iv Int32) => PrimFun stage (iv -> fv) + PrimUIntBitsToFloat :: (IsVecScalar d fv Float, IsVecScalar d uv Word32) => PrimFun stage (uv -> fv) + + -- Geometric Functions + PrimLength :: IsVecScalar d a Float => PrimFun stage (a -> Float) + PrimDistance :: IsVecScalar d a Float => PrimFun stage ((a,a) -> Float) + PrimDot :: IsVecScalar d a Float => PrimFun stage ((a,a) -> Float) + PrimCross :: IsVecScalar 3 a Float => PrimFun stage ((a,a) -> a) + PrimNormalize :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimFaceForward :: IsVecScalar d a Float => PrimFun stage ((a,a,a) -> a) + PrimReflect :: IsVecScalar d a Float => PrimFun stage ((a,a) -> a) + PrimRefract :: IsVecScalar d a Float => PrimFun stage ((a,a,a) -> a) + + -- Matrix Functions + PrimTranspose :: (IsMat a h w, IsMat b w h) => PrimFun stage (a -> b) + PrimDeterminant :: IsMat m s s => PrimFun stage (m -> Float) + PrimInverse :: IsMat m h w => PrimFun stage (m -> m) + PrimOuterProduct :: IsMat m h w => PrimFun stage ((w,h) -> m) + PrimMulMatVec :: IsMat m h w => PrimFun stage ((m,w) -> h) + PrimMulVecMat :: IsMat m h w => PrimFun stage ((h,m) -> w) + PrimMulMatMat :: (IsMat a i j, IsMat b j k, IsMat c i k) => PrimFun stage ((a,b) -> c) + + -- Vector and Scalar Relational Functions + PrimLessThan :: (IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => PrimFun stage ((a,a) -> b) + PrimLessThanEqual :: (IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => PrimFun stage ((a,a) -> b) + PrimGreaterThan :: (IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => PrimFun stage ((a,a) -> b) + PrimGreaterThanEqual :: (IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => PrimFun stage ((a,a) -> b) + PrimEqualV :: (IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => PrimFun stage ((a,a) -> b) + PrimEqual :: IsMatVecScalar a t => PrimFun stage ((a,a) -> Bool) + PrimNotEqualV :: (IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => PrimFun stage ((a,a) -> b) + PrimNotEqual :: IsMatVecScalar a t => PrimFun stage ((a,a) -> Bool) + + -- Fragment Processing Functions + PrimDFdx :: IsVecScalar d a Float => PrimFun F (a -> a) + PrimDFdy :: IsVecScalar d a Float => PrimFun F (a -> a) + PrimFWidth :: IsVecScalar d a Float => PrimFun F (a -> a) + + -- Noise Functions + PrimNoise1 :: IsVecScalar d a Float => PrimFun stage (a -> Float) + PrimNoise2 :: (IsVecScalar d a Float, IsVecScalar 2 b Float) => PrimFun stage (a -> b) + PrimNoise3 :: (IsVecScalar d a Float, IsVecScalar 3 b Float) => PrimFun stage (a -> b) + PrimNoise4 :: (IsVecScalar d a Float, IsVecScalar 4 b Float) => PrimFun stage (a -> b) + + -- Texture Lookup Functions + PrimTextureSize :: IsTextureSize sampler lod size => PrimFun stage ((sampler,lod) -> size) + PrimTexture :: IsTexture sampler coord bias => PrimFun stage ((sampler,coord) -> TexelRepr sampler) + PrimTextureB :: IsTexture sampler coord bias => PrimFun F ((sampler,coord,bias) -> TexelRepr sampler) + PrimTextureProj :: IsTextureProj sampler coord bias => PrimFun stage ((sampler,coord) -> TexelRepr sampler) + PrimTextureProjB :: IsTextureProj sampler coord bias => PrimFun F ((sampler,coord,bias) -> TexelRepr sampler) + PrimTextureLod :: IsTextureLod sampler coord lod => PrimFun stage ((sampler,coord,lod) -> TexelRepr sampler) + PrimTextureOffset :: IsTextureOffset sampler coord offset bias => PrimFun stage ((sampler,coord,offset) -> TexelRepr sampler) + PrimTextureOffsetB :: IsTextureOffset sampler coord offset bias => PrimFun F ((sampler,coord,offset,bias) -> TexelRepr sampler) + PrimTexelFetch :: IsTexelFetch sampler coord lod => PrimFun stage ((sampler,coord,lod) -> TexelRepr sampler) + PrimTexelFetchOffset :: IsTexelFetchOffset sampler coord lod offset => PrimFun stage ((sampler,coord,lod,offset) -> TexelRepr sampler) + PrimTextureProjOffset :: IsTextureProjOffset sampler coord offset bias => PrimFun stage ((sampler,coord,offset) -> TexelRepr sampler) + PrimTextureProjOffsetB :: IsTextureProjOffset sampler coord offset bias => PrimFun F ((sampler,coord,offset,bias) -> TexelRepr sampler) + PrimTextureLodOffset :: IsTextureLodOffset sampler coord lod offset => PrimFun stage ((sampler,coord,lod,offset) -> TexelRepr sampler) + PrimTextureProjLod :: IsTextureProjLod sampler coord lod => PrimFun stage ((sampler,coord,lod) -> TexelRepr sampler) + PrimTextureProjLodOffset :: IsTextureProjLodOffset sampler coord lod offset => PrimFun stage ((sampler,coord,lod,offset) -> TexelRepr sampler) + PrimTextureGrad :: IsTextureGrad sampler coord dx dy => PrimFun stage ((sampler,coord,dx,dy) -> TexelRepr sampler) + PrimTextureGradOffset :: IsTextureGradOffset sampler coord dx dy offset => PrimFun stage ((sampler,coord,dx,dy,offset) -> TexelRepr sampler) + PrimTextureProjGrad :: IsTextureProjGrad sampler coord dx dy => PrimFun stage ((sampler,coord,dx,dy) -> TexelRepr sampler) + PrimTextureProjGradOffset :: IsTextureProjGradOffset sampler coord dx dy offset => PrimFun stage ((sampler,coord,dx,dy,offset) -> TexelRepr sampler) + diff --git a/LC_T_Sampler.hs b/LC_T_Sampler.hs new file mode 100644 --- /dev/null +++ b/LC_T_Sampler.hs @@ -0,0 +1,263 @@ +module LC_T_Sampler where + +import Data.Int + +import LC_G_Type +import LC_T_DSLType + +{- +-- shadow samplers +type Sampler1DShadow = Sampler DIM1 Z Depth Mip Shadow +type Sampler2DShadow = Sampler DIM2 Z Depth Mip Shadow +type SamplerCubeShadow = Sampler DIM2 C Depth Mip Array Shadow +type Sampler1DArrayShadow = Sampler DIM1 A Depth Mip Array Shadow +type Sampler2DArrayShadow = Sampler DIM2 A Depth Mip Array Shadow +type Sampler2DRectShadow = Sampler Rect Z Depth NoMip Shadow + +-- float,int,word samplers +type Sampler1D = Sampler DIM1 Z Float Mip Regular +type Sampler2D = Sampler DIM2 Z Float Mip Regular +type Sampler3D = Sampler DIM3 Z Float Mip Regular +type SamplerCube = Sampler DIM2 C Float Mip Regular Array +type Sampler1DArray = Sampler DIM1 A Float Mip Regular Array +type Sampler2DArray = Sampler DIM2 A Float Mip Regular Array +type Sampler2DRect = Sampler Rect Z Float NoMip Regular + +type Sampler2DMS = Sampler DIM2 Z FloatMS NoMip -- from previous render pass only +type Sampler2DMSArray = Sampler DIM2 A FloatMS NoMip Array -- from previous render pass only +type SamplerBuffer = Sampler DIM1 Z BufferFloat NoMip +-} + +type GSampler1D t ar = Sampler Tex1D SingleTex t ar +type GSampler2D t ar = Sampler Tex2D SingleTex t ar +type GSampler3D t ar = Sampler Tex3D SingleTex t ar +type GSamplerCube t ar = Sampler Tex2D CubeTex t ar +type GSampler1DArray t ar = Sampler Tex1D ArrayTex t ar +type GSampler2DArray t ar = Sampler Tex2D ArrayTex t ar +type GSampler2DRect t ar = Sampler TexRect SingleTex t ar + +type family TexelRepr sampler +type instance TexelRepr (Sampler dim arr (v t) Red) = t +type instance TexelRepr (Sampler dim arr (v t) RG) = V2 t +type instance TexelRepr (Sampler dim arr (v t) RGB) = V3 t +type instance TexelRepr (Sampler dim arr (v t) RGBA) = V4 t + +-- shadow samplers +type Sampler1DShadow = GSampler1D (Shadow Float) Red +type Sampler2DShadow = GSampler2D (Shadow Float) Red +type SamplerCubeShadow = GSamplerCube (Shadow Float) Red +type Sampler1DArrayShadow = GSampler1DArray (Shadow Float) Red +type Sampler2DArrayShadow = GSampler2DArray (Shadow Float) Red +type Sampler2DRectShadow = GSampler2DRect (Shadow Float) Red + +-- float samplers +type Sampler1D t ar = GSampler1D (Regular t) ar +type Sampler2D t ar = GSampler2D (Regular t) ar +type Sampler3D t ar = GSampler3D (Regular t) ar +type SamplerCube t ar = GSamplerCube (Regular t) ar +type Sampler1DArray t ar = GSampler1DArray (Regular t) ar +type Sampler2DArray t ar = GSampler2DArray (Regular t) ar +type Sampler2DRect t ar = GSampler2DRect (Regular t) ar +type Sampler2DMS t ar = GSampler2D (MultiSample t) ar +type Sampler2DMSArray t ar = GSampler2DArray (MultiSample t) ar +type SamplerBuffer t ar = GSampler1D (Buffer t) ar + +-- brute force +-- arity problem: lod +-- restriction: NONE +class IsTextureSize sampler lod size | sampler -> lod size +instance IsTextureSize (Sampler1D t ar) Int32 Int32 +instance IsTextureSize (Sampler1DArray t ar) Int32 V2I +instance IsTextureSize (Sampler2D t ar) Int32 V2I +instance IsTextureSize (Sampler2DArray t ar) Int32 V3I +instance IsTextureSize (Sampler2DMS t ar) () V2I +instance IsTextureSize (Sampler2DMSArray t ar) () V3I +instance IsTextureSize (Sampler2DRect t ar) () V2I +instance IsTextureSize (Sampler3D t ar) Int32 V3I +instance IsTextureSize (SamplerCube t ar) Int32 V2I +instance IsTextureSize (SamplerBuffer t ar) () Int32 +instance IsTextureSize Sampler1DArrayShadow Int32 V2I +instance IsTextureSize Sampler1DShadow Int32 Int32 +instance IsTextureSize Sampler2DArrayShadow Int32 V3I +instance IsTextureSize Sampler2DRectShadow () V2I +instance IsTextureSize Sampler2DShadow Int32 V2I +instance IsTextureSize SamplerCubeShadow Int32 V2I + +-- arity problem: bias +-- restriction: Regular union Shadow +class IsTexture sampler coord bias | sampler -> coord bias +instance IsTexture (Sampler1D t ar) Float Float +instance IsTexture (Sampler1DArray t ar) V2F Float +instance IsTexture (Sampler2D t ar) V2F Float +instance IsTexture (Sampler2DArray t ar) V3F Float +instance IsTexture (Sampler2DRect t ar) V2F () +instance IsTexture (Sampler3D t ar) V3F Float +instance IsTexture (SamplerCube t ar) V3F Float +instance IsTexture Sampler1DShadow V3F Float +instance IsTexture Sampler1DArrayShadow V3F Float +instance IsTexture Sampler2DShadow V3F Float +instance IsTexture Sampler2DArrayShadow V4F () +instance IsTexture Sampler2DRectShadow V3F () +instance IsTexture SamplerCubeShadow V4F Float + +-- arity problem: bias +-- restriction: (Regular union Shadow) exclude Array +class IsTextureProj sampler coord bias | sampler coord -> bias +instance IsTextureProj (Sampler1D t ar) V2F Float +instance IsTextureProj (Sampler1D t ar) V4F Float +instance IsTextureProj (Sampler2D t ar) V3F Float +instance IsTextureProj (Sampler2D t ar) V4F Float +instance IsTextureProj (Sampler2DRect t ar) V3F () +instance IsTextureProj (Sampler2DRect t ar) V4F () +instance IsTextureProj (Sampler3D t ar) V4F Float +instance IsTextureProj Sampler1DShadow V4F Float +instance IsTextureProj Sampler2DRectShadow V4F () +instance IsTextureProj Sampler2DShadow V4F Float + +-- arity ok +-- restriction: ((Regular union Shadow) intersection Mip) exclude (2D Shadow Array) +class IsTextureLod sampler coord lod | sampler -> coord lod +instance IsTextureLod (Sampler1D t ar) Float Float +instance IsTextureLod (Sampler1DArray t ar) V2F Float +instance IsTextureLod (Sampler2D t ar) V2F Float +instance IsTextureLod (Sampler2DArray t ar) V3F Float +instance IsTextureLod (Sampler3D t ar) V3F Float +instance IsTextureLod (SamplerCube t ar) V3F Float +instance IsTextureLod Sampler1DShadow V3F Float +instance IsTextureLod Sampler1DArrayShadow V3F Float +instance IsTextureLod Sampler2DShadow V3F Float + +-- arity problem: bias +-- restriction: (Regular union Shadow) excluding (Cube, 2D Shadow Array) +class IsTextureOffset sampler coord offset bias | sampler -> coord offset bias +instance IsTextureOffset (Sampler1D t ar) Float Int32 Float +instance IsTextureOffset (Sampler1DArray t ar) V2F Int32 Float +instance IsTextureOffset (Sampler2D t ar) V2F V2I Float +instance IsTextureOffset (Sampler2DArray t ar) V3F V2I Float +instance IsTextureOffset (Sampler2DRect t ar) V2F V2I () +instance IsTextureOffset (Sampler3D t ar) V3F V3I Float +instance IsTextureOffset Sampler1DShadow V3F Int32 Float +instance IsTextureOffset Sampler1DArrayShadow V3F Int32 Float +instance IsTextureOffset Sampler2DShadow V3F V2I Float +instance IsTextureOffset Sampler2DRectShadow V3F V2I () + +-- arity problem: lod, sample +class IsTexelFetch sampler coord lod | sampler -> coord lod +instance IsTexelFetch (Sampler1D t ar) Int32 Int32 +instance IsTexelFetch (Sampler1DArray t ar) V2I Int32 +instance IsTexelFetch (Sampler2D t ar) V2I Int32 +instance IsTexelFetch (Sampler2DArray t ar) V3I Int32 +instance IsTexelFetch (Sampler2DMS t ar) V2I Int32 +instance IsTexelFetch (Sampler2DMSArray t ar) V3I Int32 +instance IsTexelFetch (Sampler2DRect t ar) V2I () +instance IsTexelFetch (Sampler3D t ar) V3I Int32 +instance IsTexelFetch (SamplerBuffer t ar) Int32 () + +-- arity problem: lod +class IsTexelFetchOffset sampler coord lod offset | sampler -> coord lod offset +instance IsTexelFetchOffset (Sampler1D t ar) Int32 Int32 Int32 +instance IsTexelFetchOffset (Sampler1DArray t ar) V2I Int32 Int32 +instance IsTexelFetchOffset (Sampler2D t ar) V2I Int32 V2I +instance IsTexelFetchOffset (Sampler2DArray t ar) V3I Int32 V2I +instance IsTexelFetchOffset (Sampler2DRect t ar) V2I () V2I +instance IsTexelFetchOffset (Sampler3D t ar) V3I Int32 V3I + +-- arity problem: bias +class IsTextureProjOffset sampler coord offset bias | sampler coord -> offset bias +instance IsTextureProjOffset (Sampler1D t ar) V2F Int32 Float +instance IsTextureProjOffset (Sampler1D t ar) V4F Int32 Float +instance IsTextureProjOffset (Sampler2D t ar) V3F V2I Float +instance IsTextureProjOffset (Sampler2D t ar) V4F V2I Float +instance IsTextureProjOffset (Sampler3D t ar) V4F V3I Float +instance IsTextureProjOffset (Sampler2DRect t ar) V3F V2I () +instance IsTextureProjOffset (Sampler2DRect t ar) V4F V2I () +instance IsTextureProjOffset Sampler1DShadow V4F Int32 Float +instance IsTextureProjOffset Sampler2DShadow V4F V2I Float +instance IsTextureProjOffset Sampler2DRectShadow V4F V2I Float + +-- arity ok +class IsTextureLodOffset sampler coord lod offset | sampler -> coord lod offset +instance IsTextureLodOffset (Sampler1D t ar) Float Float Int32 +instance IsTextureLodOffset (Sampler1DArray t ar) V2F Float Int32 +instance IsTextureLodOffset (Sampler2D t ar) V2F Float V2I +instance IsTextureLodOffset (Sampler2DArray t ar) V3F Float V2I +instance IsTextureLodOffset (Sampler3D t ar) V3F Float V3I +instance IsTextureLodOffset Sampler1DShadow V3F Float Int32 +instance IsTextureLodOffset Sampler1DArrayShadow V3F Float Int32 +instance IsTextureLodOffset Sampler2DShadow V3F Float V2I + +-- arity ok +class IsTextureProjLod sampler coord lod | sampler coord -> lod +instance IsTextureProjLod (Sampler1D t ar) V2F Float +instance IsTextureProjLod (Sampler1D t ar) V4F Float +instance IsTextureProjLod (Sampler2D t ar) V3F Float +instance IsTextureProjLod (Sampler2D t ar) V4F Float +instance IsTextureProjLod (Sampler3D t ar) V4F Float +instance IsTextureProjLod Sampler1DShadow V4F Float +instance IsTextureProjLod Sampler2DShadow V4F Float + +-- arity ok +class IsTextureProjLodOffset sampler coord lod offset | sampler coord -> lod offset +instance IsTextureProjLodOffset (Sampler1D t ar) V2F Float Int32 +instance IsTextureProjLodOffset (Sampler1D t ar) V4F Float Int32 +instance IsTextureProjLodOffset (Sampler2D t ar) V3F Float V2I +instance IsTextureProjLodOffset (Sampler2D t ar) V4F Float V2I +instance IsTextureProjLodOffset (Sampler3D t ar) V4F Float V3I +instance IsTextureProjLodOffset Sampler1DShadow V4F Float Int32 +instance IsTextureProjLodOffset Sampler2DShadow V4F Float V2F + +-- arity ok +class IsTextureGrad sampler coord dx dy | sampler -> coord dx dy +instance IsTextureGrad (Sampler1D t ar) Float Float Float +instance IsTextureGrad (Sampler1DArray t ar) V2F Float Float +instance IsTextureGrad (Sampler2D t ar) V2F V2F V2F +instance IsTextureGrad (Sampler2DArray t ar) V3F V2F V2F +instance IsTextureGrad (Sampler2DRect t ar) V2F V2F V2F +instance IsTextureGrad (Sampler3D t ar) V3F V3F V3F +instance IsTextureGrad (SamplerCube t ar) V3F V3F V3F +instance IsTextureGrad Sampler1DArrayShadow V3F Float Float +instance IsTextureGrad Sampler1DShadow V3F Float Float +instance IsTextureGrad Sampler2DArrayShadow V4F V2F V2F +instance IsTextureGrad Sampler2DRectShadow V3F V2F V2F +instance IsTextureGrad Sampler2DShadow V3F V2F V2F +instance IsTextureGrad SamplerCubeShadow V4F V3F V3F + +-- arity ok +class IsTextureGradOffset sampler coord dx dy offset | sampler -> coord dx dy offset +instance IsTextureGradOffset (Sampler1D t ar) Float Float Float Int32 +instance IsTextureGradOffset (Sampler1DArray t ar) V2F Float Float Int32 +instance IsTextureGradOffset (Sampler2D t ar) V2F V2F V2F V2I +instance IsTextureGradOffset (Sampler2DArray t ar) V3F V2F V2F V2I +instance IsTextureGradOffset (Sampler2DRect t ar) V2F V2F V2F V2I +instance IsTextureGradOffset (Sampler3D t ar) V3F V3F V3F V3I +instance IsTextureGradOffset Sampler1DArrayShadow V3F Float Float Int32 +instance IsTextureGradOffset Sampler1DShadow V3F Float Float Int32 +instance IsTextureGradOffset Sampler2DArrayShadow V4F V2F V2F V2I +instance IsTextureGradOffset Sampler2DRectShadow V3F V2F V2F V2I +instance IsTextureGradOffset Sampler2DShadow V3F V2F V2F V2I + +-- arity ok +class IsTextureProjGrad sampler coord dx dy | sampler coord -> dx dy +instance IsTextureProjGrad (Sampler1D t ar) V2F Float Float +instance IsTextureProjGrad (Sampler1D t ar) V4F Float Float +instance IsTextureProjGrad (Sampler2D t ar) V3F V2F V2F +instance IsTextureProjGrad (Sampler2D t ar) V4F V2F V2F +instance IsTextureProjGrad (Sampler2DRect t ar) V3F V2F V2F +instance IsTextureProjGrad (Sampler2DRect t ar) V4F V2F V2F +instance IsTextureProjGrad (Sampler3D t ar) V4F V3F V3F +instance IsTextureProjGrad Sampler1DShadow V4F Float Float +instance IsTextureProjGrad Sampler2DRectShadow V4F V2F V2F +instance IsTextureProjGrad Sampler2DShadow V4F V2F V2F + +-- arity ok +class IsTextureProjGradOffset sampler coord dx dy offset | sampler coord -> dx dy offset +instance IsTextureProjGradOffset (Sampler1D t ar) V2F Float Float Int32 +instance IsTextureProjGradOffset (Sampler1D t ar) V4F Float Float Int32 +instance IsTextureProjGradOffset (Sampler2D t ar) V3F V2F V2F V2I +instance IsTextureProjGradOffset (Sampler2D t ar) V4F V2F V2F V2I +instance IsTextureProjGradOffset (Sampler2DRect t ar) V3F V2F V2F V2I +instance IsTextureProjGradOffset (Sampler2DRect t ar) V4F V2F V2F V2I +instance IsTextureProjGradOffset (Sampler3D t ar) V4F V3F V3F V3I +instance IsTextureProjGradOffset Sampler1DShadow V4F Float Float Int32 +instance IsTextureProjGradOffset Sampler2DRectShadow V4F V2F V2F V2I +instance IsTextureProjGradOffset Sampler2DShadow V4F V2F V2F V2I diff --git a/LC_U_APIType.hs b/LC_U_APIType.hs new file mode 100644 --- /dev/null +++ b/LC_U_APIType.hs @@ -0,0 +1,81 @@ +module LC_U_APIType where + +import Data.ByteString.Char8 +import Data.Int + +import LC_G_Type + +import LC_G_APIType + +-- primitive types +data FetchPrimitive + = Points + | Lines + | Triangles + | LinesAdjacency + | TrianglesAdjacency + deriving (Show,Eq,Ord) + +data OutputPrimitive + = TrianglesOutput + | LinesOutput + | PointsOutput + deriving (Show,Eq,Ord) + +data ColorArity = Red | RG | RGB | RGBA deriving (Show,Eq,Ord) + +data Blending + = NoBlending + | BlendLogicOp LogicOperation + | Blend (BlendEquation, BlendEquation) + ((BlendingFactor, BlendingFactor), (BlendingFactor, BlendingFactor)) + V4F + deriving (Show,Eq,Ord) + +data RasterContext + = PointCtx PointSize Float PointSpriteCoordOrigin + | LineCtx Float ProvokingVertex + | TriangleCtx CullMode PolygonMode PolygonOffset ProvokingVertex + deriving (Show, Eq, Ord) + +data FragmentOperation + = DepthOp DepthFunction Bool + | StencilOp StencilTests StencilOps StencilOps + | ColorOp Blending Value + deriving (Show, Eq, Ord) + +data AccumulationContext + = AccumulationContext + { accViewportName :: Maybe ByteString + , accOperations :: [FragmentOperation] + } + deriving (Show, Eq, Ord) + +data Image + = DepthImage Int Float + | StencilImage Int Int32 + | ColorImage Int Value + deriving (Show, Eq, Ord) + +data TextureDataType + = FloatT ColorArity + | IntT ColorArity + | WordT ColorArity + | ShadowT + deriving (Show, Eq, Ord) + +data TextureType + = Texture1D TextureDataType Int + | Texture2D TextureDataType Int + | Texture3D TextureDataType + | TextureCube TextureDataType + | TextureRect TextureDataType + | Texture2DMS TextureDataType Int + | TextureBuffer TextureDataType + deriving (Show, Eq, Ord) + +data MipMap + = Mip Int Int -- Base level, Max level + | NoMip + | AutoMip Int Int -- Base level, Max level + deriving (Show,Eq,Ord) diff --git a/LC_U_DeBruijn.hs b/LC_U_DeBruijn.hs new file mode 100644 --- /dev/null +++ b/LC_U_DeBruijn.hs @@ -0,0 +1,308 @@ +module LC_U_DeBruijn where + +import Debug.Trace +import Control.Monad.State +import Data.ByteString.Char8 (ByteString) + +import LC_G_Type +import LC_G_APIType +import LC_U_APIType +import LC_U_PrimFun + +import BiMap +import qualified Data.IntMap as IM + +type ExpId = Int + +--newtype DAG = DAG (BiMap Exp) deriving Show +data DAG + = DAG + { dagExp :: BiMap Exp + , dagTy :: IM.IntMap Ty + , dagCount :: IM.IntMap Int + } deriving Show + +emptyDAG :: DAG +emptyDAG = DAG empty IM.empty IM.empty + +hashcons :: Ty -> Exp -> State DAG ExpId +hashcons !t !e = do + DAG !m !tm !cm <- get + case lookup_key e m of + Nothing -> let (!k,!m') = insert e m + !tm' = IM.insert k t tm + !cm' = IM.insert k 1 cm + in put (DAG m' tm' cm') >> return k + Just !k -> do + {-trace ("sharing : " ++ show k ++ " :: " ++ show (tm IM.! k)) $ -} + let !cm' = IM.adjust (1+) k cm + put (DAG m tm cm') + return k +{- +--hashcons = dontShare +dontShare :: Ty -> Exp -> State DAG ExpId +dontShare t e = do + DAG m tm <- get + let (k,m') = insert e m + tm' = IM.insert k t tm + put (DAG m' tm') >> return k +-} + +-- Utility functions for CodeGen +toExp :: DAG -> ExpId -> Exp +toExp (DAG !m _ _) !k = lookup_val k m + +toExpId :: DAG -> Exp -> ExpId +toExpId (DAG !m _ _) !v = let Just k = lookup_key v m in k + +expIdType :: DAG -> ExpId -> Ty +expIdType (DAG _ !tm _) !k = tm IM.! k + +expType :: DAG -> Exp -> Ty +expType dag@(DAG !m !tm _) !e = case lookup_key e m of + Nothing -> error $ "unknown Exp node: " ++ show e + Just !k -> expIdType dag k + +expIdCount :: DAG -> ExpId -> Int +expIdCount (DAG _ _ !cm) !k = cm IM.! k + +expCount :: DAG -> Exp -> Int +expCount dag@(DAG !m !tm !cm) !e = case lookup_key e m of + Nothing -> error $ "unknown Exp node: " ++ show e + Just !k -> expIdCount dag k + +{- + TODO: + represent these as tuples from specific types: VertexOut, GeometryOut, FragmentOut, FragmentOutDepth, FragmentOutRastDepth +-} +data Exp + -- Fun + = Lam !ExpId + | Body !ExpId + | Var Int String -- index, layout counter + | Apply !ExpId !ExpId + + -- Exp + | Const !Value + | PrimVar !ByteString + | Uni !ByteString + | Tup [ExpId] + | Prj Int !ExpId + | Cond !ExpId !ExpId !ExpId + | PrimApp !PrimFun !ExpId + | Sampler !Filter !EdgeMode !ExpId + | Loop !ExpId !ExpId !ExpId !ExpId + -- special tuple expressions + | VertexOut !ExpId !ExpId [ExpId] [ExpId] + | GeometryOut !ExpId !ExpId !ExpId [ExpId] [ExpId] + | FragmentOut [ExpId] + | FragmentOutDepth !ExpId [ExpId] + | FragmentOutRastDepth [ExpId] + + -- GP + | Fetch ByteString FetchPrimitive [(ByteString,InputType)] + | Transform !ExpId !ExpId + | Reassemble !ExpId !ExpId + | Rasterize RasterContext !ExpId + | FrameBuffer [Image] + | Accumulate AccumulationContext !ExpId !ExpId !ExpId !ExpId + | PrjFrameBuffer ByteString Int !ExpId + | PrjImage ByteString Int !ExpId + + -- Texture + | TextureSlot ByteString TextureType + | Texture TextureType Value MipMap [ExpId] -- hint: type, size, mip, data + + -- Interpolated + | Flat !ExpId + | Smooth !ExpId + | NoPerspective !ExpId + + | GeometryShader Int OutputPrimitive Int !ExpId !ExpId !ExpId + + -- FragmentFilter + | PassAll + | Filter !ExpId + + -- GPOutput + | ImageOut ByteString V2U !ExpId + | ScreenOut !ExpId + | MultiOut [ExpId] + deriving (Eq, Ord, Show) + +class ExpC exp where + -- exp constructors + lam :: Ty -> exp -> exp + body :: exp -> exp + var :: Ty -> Int -> String -> exp -- type, index, layout counter (this needed for proper sharing) + apply :: Ty -> exp -> exp -> exp + const_ :: Ty -> Value -> exp + primVar :: Ty -> ByteString -> exp + uni :: Ty -> ByteString -> exp + tup :: Ty -> [exp] -> exp + prj :: Ty -> Int -> exp -> exp + cond :: Ty -> exp -> exp -> exp -> exp + primApp :: Ty -> PrimFun -> exp -> exp + sampler :: Ty -> Filter -> EdgeMode -> exp -> exp + loop :: Ty -> exp -> exp -> exp -> exp -> exp + -- special tuple expressions + vertexOut :: exp -> exp -> [exp] -> [exp] -> exp + geometryOut :: exp -> exp -> exp -> [exp] -> [exp] -> exp + fragmentOut :: [exp] -> exp + fragmentOutDepth :: exp -> [exp] -> exp + fragmentOutRastDepth :: [exp] -> exp + -- gp constructors + fetch :: ByteString -> FetchPrimitive -> [(ByteString,InputType)] -> exp + transform :: exp -> exp -> exp + reassemble :: exp -> exp -> exp + rasterize :: RasterContext -> exp -> exp + frameBuffer :: [Image] -> exp + accumulate :: AccumulationContext -> exp -> exp -> exp -> exp -> exp + prjFrameBuffer :: ByteString -> Int -> exp -> exp + prjImage :: ByteString -> Int -> exp -> exp + -- texture constructors + textureSlot :: ByteString -> TextureType -> exp + texture :: TextureType -> Value -> MipMap -> [exp] -> exp -- hint: type, size, mip, data + -- Interpolated constructors + flat :: exp -> exp + smooth :: exp -> exp + noPerspective :: exp -> exp + -- GeometryShader constructors + geometryShader :: Int -> OutputPrimitive -> Int -> exp -> exp -> exp -> exp + -- FragmentFilter constructors + passAll :: exp + filter_ :: exp -> exp + -- GPOutput constructors + imageOut :: ByteString -> V2U -> exp -> exp + screenOut :: exp -> exp + multiOut :: [exp] -> exp + +newtype N = N {unN :: State DAG ExpId} + +instance ExpC N where + lam !t !a = N $ do + !h1 <- unN a + hashcons t $ Lam h1 + body !a = N $ do + !h1 <- unN a + hashcons (Unknown "Body") $ Body h1 + var !t !a !b = N $ hashcons t $ Var a b + apply !t !a !b = N $ do + !h1 <- unN a + !h2 <- unN b + hashcons t $ Apply h1 h2 + const_ !t !a = N $ hashcons t $ Const a + primVar !t !a = N $ hashcons t $ PrimVar a + uni !t !a = N $ hashcons t $ Uni a + tup !t !a = N $ do + !h <- mapM unN a + hashcons t $ Tup h + prj !t !a !b = N $ do + !h1 <- unN b + hashcons t $ Prj a h1 + cond !t !a !b !c = N $ do + !h1 <- unN a + !h2 <- unN b + !h3 <- unN c + hashcons t $ Cond h1 h2 h3 + primApp !t !a !b = N $ do + !h1 <- unN b + hashcons t $ PrimApp a h1 + sampler !t !a !b !c = N $ do + !h1 <- unN c + hashcons t $ Sampler a b h1 + loop !t !a !b !c !d = N $ do + !h1 <- unN a + !h2 <- unN b + !h3 <- unN c + !h4 <- unN d + hashcons t $ Loop h1 h2 h3 h4 + + -- special tuple expressions + vertexOut !a !b !c !d = N $ do + !h1 <- unN a + !h2 <- unN b + !h3 <- mapM unN c + !h4 <- mapM unN d + hashcons (Unknown "VertexOut") $ VertexOut h1 h2 h3 h4 + geometryOut !a !b !c !d !e = N $ do + !h1 <- unN a + !h2 <- unN b + !h3 <- unN c + !h4 <- mapM unN d + !h5 <- mapM unN e + hashcons (Unknown "GeometryOut") $ GeometryOut h1 h2 h3 h4 h5 + fragmentOut !a = N $ do + !h <- mapM unN a + hashcons (Unknown "FragmentOut") $ FragmentOut h + fragmentOutDepth !a !b = N $ do + !h1 <- unN a + !h2 <- mapM unN b + hashcons (Unknown "FragmentOutDepth") $ FragmentOutDepth h1 h2 + fragmentOutRastDepth !a = N $ do + !h <- mapM unN a + hashcons (Unknown "FragmentOutRastDepth") $ FragmentOutRastDepth h + -- gp constructors + fetch !a !b !c = N $ do + hashcons VertexStream' $ Fetch a b c + transform !a !b = N $ do + !h1 <- unN a + !h2 <- unN b + hashcons PrimitiveStream' $ Transform h1 h2 + reassemble !a !b = N $ do + !h1 <- unN a + !h2 <- unN b + hashcons PrimitiveStream' $ Reassemble h1 h2 + rasterize !a !b = N $ do + !h1 <- unN b + hashcons FragmentStream' $ Rasterize a h1 + frameBuffer !a = N $ do + hashcons FrameBuffer' $ FrameBuffer a + accumulate !a !b !c !d !e = N $ do + !h1 <- unN b + !h2 <- unN c + !h3 <- unN d + !h4 <- unN e + hashcons FrameBuffer' $ Accumulate a h1 h2 h3 h4 + prjFrameBuffer !a !b !c = N $ do + !h1 <- unN c + hashcons Image' $ PrjFrameBuffer a b h1 + prjImage !a !b !c = N $ do + !h1 <- unN c + hashcons Image' $ PrjImage a b h1 + -- texture constructors + textureSlot !a !b = N $ hashcons (Unknown "TextureSlot") $ TextureSlot a b + texture !a !b !c !d = N $ do + !h1 <- mapM unN d + hashcons (Unknown "Texture") $ Texture a b c h1 + -- Interpolated constructors + flat !a = N $ do + !h1 <- unN a + hashcons (Unknown "Flat") $ Flat h1 + smooth !a = N $ do + !h1 <- unN a + hashcons (Unknown "Smooth") $ Smooth h1 + noPerspective !a = N $ do + !h1 <- unN a + hashcons (Unknown "NoPerspective") $ NoPerspective h1 + -- GeometryShader constructors + geometryShader !a !b !c !d !e !f = N $ do + !h1 <- unN d + !h2 <- unN e + !h3 <- unN f + hashcons (Unknown "GeometryShader") $ GeometryShader a b c h1 h2 h3 + -- FragmentFilter constructors + passAll = N $ hashcons (Unknown "PassAll") PassAll + filter_ !a = N $ do + !h1 <- unN a + hashcons (Unknown "Filter") $ Filter h1 + -- GPOutput constructors + imageOut !a !b !c = N $ do + !h1 <- unN c + hashcons (Unknown "ImageOut") $ ImageOut a b h1 + screenOut !a = N $ do + !h1 <- unN a + hashcons (Unknown "ScreenOut") $ ScreenOut h1 + multiOut !a = N $ do + !h1 <- mapM unN a + hashcons (Unknown "MultiOut") $ MultiOut h1 diff --git a/LC_U_PrimFun.hs b/LC_U_PrimFun.hs new file mode 100644 --- /dev/null +++ b/LC_U_PrimFun.hs @@ -0,0 +1,160 @@ +module LC_U_PrimFun where + +data PrimFun + -- Vec/Mat (de)construction + = PrimTupToV2 + | PrimTupToV3 + | PrimTupToV4 + | PrimV2ToTup + | PrimV3ToTup + | PrimV4ToTup + + -- Arithmetic Functions (componentwise) + | PrimAdd + | PrimAddS + | PrimSub + | PrimSubS + | PrimMul + | PrimMulS + | PrimDiv + | PrimDivS + | PrimNeg + | PrimMod + | PrimModS + + -- Bit-wise Functions + | PrimBAnd + | PrimBAndS + | PrimBOr + | PrimBOrS + | PrimBXor + | PrimBXorS + | PrimBNot + | PrimBShiftL + | PrimBShiftLS + | PrimBShiftR + | PrimBShiftRS + + -- Logic Functions + | PrimAnd + | PrimOr + | PrimXor + | PrimNot + | PrimAny + | PrimAll + + -- Angle and Trigonometry Functions + | PrimACos + | PrimACosH + | PrimASin + | PrimASinH + | PrimATan + | PrimATan2 + | PrimATanH + | PrimCos + | PrimCosH + | PrimDegrees + | PrimRadians + | PrimSin + | PrimSinH + | PrimTan + | PrimTanH + + -- Exponential Functions + | PrimPow + | PrimExp + | PrimLog + | PrimExp2 + | PrimLog2 + | PrimSqrt + | PrimInvSqrt + + -- Common Functions + | PrimIsNan + | PrimIsInf + | PrimAbs + | PrimSign + | PrimFloor + | PrimTrunc + | PrimRound + | PrimRoundEven + | PrimCeil + | PrimFract + | PrimModF + | PrimMin + | PrimMinS + | PrimMax + | PrimMaxS + | PrimClamp + | PrimClampS + | PrimMix + | PrimMixS + | PrimMixB + | PrimStep + | PrimStepS + | PrimSmoothStep + | PrimSmoothStepS + + -- Integer/Float Conversion Functions + | PrimFloatBitsToInt + | PrimFloatBitsToUInt + | PrimIntBitsToFloat + | PrimUIntBitsToFloat + + -- Geometric Functions + | PrimLength + | PrimDistance + | PrimDot + | PrimCross + | PrimNormalize + | PrimFaceForward + | PrimReflect + | PrimRefract + + -- Matrix Functions + | PrimTranspose + | PrimDeterminant + | PrimInverse + | PrimOuterProduct + | PrimMulMatVec + | PrimMulVecMat + | PrimMulMatMat + + -- Vector and Scalar Relational Functions + | PrimLessThan + | PrimLessThanEqual + | PrimGreaterThan + | PrimGreaterThanEqual + | PrimEqualV + | PrimEqual + | PrimNotEqualV + | PrimNotEqual + + -- Fragment Processing Functions + | PrimDFdx + | PrimDFdy + | PrimFWidth + + -- Noise Functions + | PrimNoise1 + | PrimNoise2 + | PrimNoise3 + | PrimNoise4 + + -- Texture Lookup Functions + | PrimTextureSize + | PrimTexture + | PrimTextureProj + | PrimTextureLod + | PrimTextureOffset + | PrimTexelFetch + | PrimTexelFetchOffset + | PrimTextureProjOffset + | PrimTextureLodOffset + | PrimTextureProjLod + | PrimTextureProjLodOffset + | PrimTextureGrad + | PrimTextureGradOffset + | PrimTextureProjGrad + | PrimTextureProjGradOffset + deriving (Eq, Ord, Show) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2009-2012, Csaba Hruska +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lambdacube-core.cabal b/lambdacube-core.cabal new file mode 100644 --- /dev/null +++ b/lambdacube-core.cabal @@ -0,0 +1,93 @@ +Name: lambdacube-core +Version: 0.1.0 +Cabal-Version: >= 1.6 && < 2 +Build-Type: Simple +License: BSD3 +License-File: LICENSE +Author: Csaba Hruska, Gergely Patai +Maintainer: csaba (dot) hruska (at) gmail (dot) com +Stability: experimental +Homepage: http://lambdacube3d.wordpress.com/ +Bug-Reports: https://github.com/csabahruska/lc-dsl/issues +Category: Graphics +Tested-With: GHC == 7.6.3 +Synopsis: LambdaCube 3D is a domain specific language and library that makes it possible to program GPUs in a purely functional style. +Description: + LambdaCube 3D is a domain specific language and library that makes + it possible to program GPUs in a purely functional style. + Programming with LambdaCube constitutes of composing a data-flow + description, which is compiled into a specialised library. The + language provides a uniform way to define shaders and compositor + chains by treating both streams and framebuffers as first-class + values. + . + As a user of the library you only need to import the "LC_API" and + "LC_Mesh" modules. You should check out the pointers at + to understand the principle behind the library, and also have a good look + at the @lambdacube-samples@ package. + +Library + Build-Depends: + base >=4.6 && <4.7, containers >=0.5 && <0.6, mtl >=2.1 && <2.2, bytestring >=0.10 && <0.11, bytestring-trie >=0.2 && <0.3, vector >=0.10 && <0.11, OpenGLRaw >=1.4 && <1.5, bitmap >=0.0 && <0.1, prettyclass >=1.0 && <1.1, language-glsl >=0.0 && <0.1, binary >=0.7 && <0.8 + Exposed-modules: + BiMap + LC_API + LC_B_GL + LC_B_GLCompile + LC_B_GLData + LC_B_GLSLCodeGen + LC_B_GLType + LC_B_GLUtil + LC_B_Traversals + LC_C_Convert + LC_C_PrimFun + LC_G_APIType + LC_G_Type + LC_Mesh + LC_T_APIType + LC_T_DSLType + LC_T_HOAS + LC_T_Language + LC_T_PrimFun + LC_T_Sampler + LC_U_APIType + LC_U_DeBruijn + LC_U_PrimFun + + GHC-options: +-- -Werror + -Wall + -fno-warn-missing-signatures + -fno-warn-name-shadowing + -fno-warn-orphans + -fno-warn-unused-binds + -fno-warn-unused-do-bind + -fspec-constr-count=10 + -funbox-strict-fields + -O2 +-- for profiling +-- -auto-all +-- -caf-all + + Extensions: + BangPatterns + ConstraintKinds + DataKinds + DeriveDataTypeable + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + ImpredicativeTypes + KindSignatures + MultiParamTypeClasses + OverloadedStrings + ParallelListComp + Rank2Types + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeFamilies + TypeOperators + TypeSynonymInstances