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
, glBindFramebuffer
, glDeleteFramebuffers
, glGenFramebuffers
, 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
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]
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]]
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
(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
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 texUnitState1]) $ \(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
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)
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)
return (setup,return ())
False -> do
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]
(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))
let fboMappingMap = IntMap.fromList fboMapping
fboMappingList = [IntMap.findWithDefault gl_NONE i fboMappingMap | i <- [0..outCnt1]]
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
unless (all (== head texSizes) texSizes) $ error ("Framebuffer attachment size mismatch! \n" ++ " - sizes: " ++ show texSizes)
let VV2U (V2 depthW depthH) = head texSizes
when hasDepthOp $ do
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
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
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)
disposeAct = do
with glFBO $ \pbo -> glDeleteFramebuffers 1 pbo
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
}
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
(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))
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
slotDescriptors <- T.fromList <$> mapM (\(n,a) -> (n,) <$> mkSlotDescriptor a) (T.toList slotGP)
(texSlotName,renderTexName,renderTexGLObj,renderTexDispose,dependentSamplers) <- mkRenderTextures dag allGPs
renderDescriptors <- Map.fromList <$> mapM (\a -> (a,) <$> mkRenderDescriptor dag rendState texSlotName renderTexName renderTexGLObj a) (nubS $ concatMap (renderChain dag) ordFBs)
screenSizeIORef <- newIORef (0,0)
putStrLn ("number of passes: " ++ show (length ordFBs))
(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)
putStrLn $ "number of passes: " ++ show (length ordFBs) ++ " is output the last? " ++ show (findFrameBuffer dag gp == last ordFBs)
objIDSeed <- newIORef 1
return $! Renderer
{ slotUniform = slotUniformTrie
, slotStream = slotStreamTrie
, uniformSetter = uniformSetterTrie
, render = do
sequence_ passRender
, dispose = renderTexDispose >> sequence_ passDispose
, setScreenSize = \w h -> writeIORef screenSizeIORef (w,h)
, mkUniformSetup = mkUniformSetupTrie
, slotDescriptor = slotDescriptors
, renderDescriptor = renderDescriptors
, renderState = rendState
, objectIDSeed = objIDSeed
}