diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,14 @@ +### 2.2.1 + +- Render monad would crash if using deleted windows, when that should be a no-op. (#41). +- Manually deleting last visible window causes objects to be deleted (#42). + +### 2.2 + +- Windows are now explicit objects dynamically created and deleted with newWindow and deleteWindow, and are sent as parameter to drawWindowColor et al. (#18) +- Each window created can now take their own window manager specific parameters (#19) +- Update to GHC 8.0.2 and gl-0.8.0 (#38) + ### 2.1.8 - Update dependencies to make it build with stack resolver nightly-2016-09-24 @@ -27,19 +38,19 @@ ### 2.1.2 -- Fixed bug when nesting while, ifThen, ifThenElse or ifThenElse'. +- Fixed bug when nesting while, ifThen, ifThenElse or ifThenElse'. ### 2.1.1 -- Made ifB use ifThenElse' instead to avoid unwanted strictness +- Made ifB use ifThenElse' instead to avoid unwanted strictness - Fixed bug where ShaderBaseType for () wasn't lazy enough, causing error in ifThenElse' - Added missing () instances ### 2.1 -- Making dangling finalizers work with shared and unshared contexts (#10) +- Making dangling finalizers work with shared and unshared contexts (#10) - Moved orphan instances to separate module (#11) -- Fixing a bug introduced in 2.0.2 when using multiple uniforms +- Fixing a bug introduced in 2.0.2 when using multiple uniforms - Fixing exception when using conditionals in the shader (#12) ### 2.0.2 @@ -55,4 +66,4 @@ ### 2.0 -- Initial release of GPipe 2 +- Initial release of GPipe 2 diff --git a/GPipe.cabal b/GPipe.cabal --- a/GPipe.cabal +++ b/GPipe.cabal @@ -1,5 +1,5 @@ name: GPipe -version: 2.2 +version: 2.2.1 cabal-version: >= 1.8 build-type: Simple author: Tobias Bexelius diff --git a/src/Graphics/GPipe/Internal/Compiler.hs b/src/Graphics/GPipe/Internal/Compiler.hs --- a/src/Graphics/GPipe/Internal/Compiler.hs +++ b/src/Graphics/GPipe/Internal/Compiler.hs @@ -174,25 +174,27 @@ renv <- lift ask let (mfbokeyio, blendio) = fboSetup x let inwin wid m = do - let (ws, doAsync) = perWindowRenderState rs ! wid - let (bindUni, uniState') = makeBind (boundUniforms ws :: Map.IntMap Int) uNameToRenderIOmap' (zip unis ubinds) - let (bindSamp, sampState') = makeBind (boundSamplers ws :: Map.IntMap Int) (samplerNameToRenderIO s) $ zip samps sbinds - let bindRast = if rastN == boundRasterizerN ws then const $ return () else rasterizationNameToRenderIO s ! rastN - wmap' = Map.insert wid (ws { boundUniforms = uniState', boundSamplers = sampState', boundRasterizerN = rastN }, doAsync) (perWindowRenderState rs) - lift $ lift $ put (rs {perWindowRenderState = wmap', renderLastUsedWin = wid }) - mErr <- liftIO $ asSync doAsync $ do - pName' <- readIORef pNameRef -- Cant use pName, need to touch pNameRef - glUseProgram pName' - _ <- bindUni x (const $ return True :: () -> IO Bool) - isOk <- bindSamp x (return . not . (`Set.member` renderWriteTextures rs) :: Int -> IO Bool) - bindRast x - blendio - mErr2 <- m - let mErr = if isOk then Nothing else Just "Running shader that samples from texture that currently has an image borrowed from it. Try run this shader from a separate render call where no images from the same texture are drawn to or cleared.\n" - return $ mErr <> mErr2 - case mErr of - Just e -> throwE e - Nothing -> return () + case Map.lookup wid (perWindowRenderState rs) of + Nothing -> return () -- Window deleted + Just (ws, doAsync) -> do + let (bindUni, uniState') = makeBind (boundUniforms ws :: Map.IntMap Int) uNameToRenderIOmap' (zip unis ubinds) + let (bindSamp, sampState') = makeBind (boundSamplers ws :: Map.IntMap Int) (samplerNameToRenderIO s) $ zip samps sbinds + let bindRast = if rastN == boundRasterizerN ws then const $ return () else rasterizationNameToRenderIO s ! rastN + wmap' = Map.insert wid (ws { boundUniforms = uniState', boundSamplers = sampState', boundRasterizerN = rastN }, doAsync) (perWindowRenderState rs) + lift $ lift $ put (rs {perWindowRenderState = wmap', renderLastUsedWin = wid }) + mErr <- liftIO $ asSync doAsync $ do + pName' <- readIORef pNameRef -- Cant use pName, need to touch pNameRef + glUseProgram pName' + _ <- bindUni x (const $ return True :: () -> IO Bool) + isOk <- bindSamp x (return . not . (`Set.member` renderWriteTextures rs) :: Int -> IO Bool) + bindRast x + blendio + mErr2 <- m + let mErr = if isOk then Nothing else Just "Running shader that samples from texture that currently has an image borrowed from it. Try run this shader from a separate render call where no images from the same texture are drawn to or cleared.\n" + return $ mErr <> mErr2 + case mErr of + Just e -> throwE e + Nothing -> return () wid <- case mfbokeyio of Left wid -> do -- Bind correct context inwin wid $ do @@ -222,21 +224,23 @@ return cwid -- Draw each Vertex Array -- forM_ (map ($ (inps, pstrUBuf, pstrUSize)) ((inputArrayToRenderIOs s ! primN) x)) $ \ ((keyio, vaoio), drawio) -> do - let (ws, doAsync) = perWindowRenderState rs ! wid - cd = windowContextData ws - liftIO $ do - key <- keyio - mvao <- getVAO cd key - case mvao of - Just vao -> do vao' <- readIORef vao - glBindVertexArray vao' - Nothing -> do vao' <- alloca (\ptr -> glGenVertexArrays 1 ptr >> peek ptr) - vao <- newIORef vao' - void $ mkWeakIORef vao (doAsync $ with vao' $ glDeleteVertexArrays 1) - setVAO cd key vao - glBindVertexArray vao' - vaoio - drawio) + case Map.lookup wid (perWindowRenderState rs) of + Nothing -> return () -- Window deleted + Just (ws, doAsync) -> + liftIO $ do + let cd = windowContextData ws + key <- keyio + mvao <- getVAO cd key + case mvao of + Just vao -> do vao' <- readIORef vao + glBindVertexArray vao' + Nothing -> do vao' <- alloca (\ptr -> glGenVertexArrays 1 ptr >> peek ptr) + vao <- newIORef vao' + void $ mkWeakIORef vao (doAsync $ with vao' $ glDeleteVertexArrays 1) + setVAO cd key vao + glBindVertexArray vao' + vaoio + drawio) compileShader name source = do withCStringLen source $ \ (ptr, len) -> diff --git a/src/Graphics/GPipe/Internal/Context.hs b/src/Graphics/GPipe/Internal/Context.hs --- a/src/Graphics/GPipe/Internal/Context.hs +++ b/src/Graphics/GPipe/Internal/Context.hs @@ -69,19 +69,22 @@ contextHandlerDelete :: ctx -> IO () -- | Create a new context sharing all other contexts created by this ContextHandler. If the parameter is Nothing, -- a hidden off-screen context is created, otherwise creates a window with the provided window bits and implementation specific parameters. - -- Only ever called from the mainthread (i.e. the thread that called contextHandlerCreate) + -- Only ever called from the mainthread (i.e. the thread that called contextHandlerCreate). createContext :: ctx -> Maybe (WindowBits, WindowParameters ctx) -> IO (ContextWindow ctx) -- | Run an OpenGL IO action in this context, that doesn't return any value to the caller. This may be run after contextDelete or contextHandlerDelete has been called. -- The thread calling this may not be the same creating the context (for finalizers it is most definetly not). + -- May also be called on previously deleted windows in the case of finalizers. contextDoAsync :: ctx -> Maybe (ContextWindow ctx) -> IO () -> IO () -- | Swap the front and back buffers in the context's default frame buffer. - -- Only ever called from the mainthread (i.e. the thread that called contextHandlerCreate) + -- Only ever called from the mainthread (i.e. the thread that called 'contextHandlerCreate'). + -- Never called on deleted windows. contextSwap :: ctx -> ContextWindow ctx -> IO () -- | Get the current size of the context's default framebuffer (which may change if the window is resized). - -- Only ever called from the mainthread (i.e. the thread that called contextHandlerCreate) + -- Only ever called from the mainthread (i.e. the thread that called 'contextHandlerCreate') contextFrameBufferSize :: ctx -> ContextWindow ctx -> IO (Int, Int) -- | Delete a context and close any associated window. - -- Only ever called from the mainthread (i.e. the thread that called contextHandlerCreate) + -- Only ever called from the mainthread (i.e. the thread that called 'contextHandlerCreate'). Only ever called once per window, + -- and will always be called for each window before the context is deleted with 'contextHandlerDelete'. contextDelete :: ctx -> ContextWindow ctx -> IO () @@ -110,7 +113,7 @@ data ContextState ctx = ContextState { nextName :: Name, perWindowState :: PerWindowState ctx, - lastUsedWin :: Name + lastUsedWin :: Name -- -1 is no window. 0 is the hidden window. 1.. are visible windows } -- | A monad in which shaders are run. @@ -131,7 +134,7 @@ type ContextDoAsync = IO () -> IO () -type PerWindowState ctx = IMap.IntMap (WindowState, ContextWindow ctx) +type PerWindowState ctx = IMap.IntMap (WindowState, ContextWindow ctx) -- -1 is no window. 0 is the hidden window. 1.. are visible windows type PerWindowRenderState = IMap.IntMap (WindowState, ContextDoAsync) data WindowState = WindowState { windowContextData :: !ContextData, @@ -180,12 +183,22 @@ ) (\ctx -> evalStateT (runReaderT m (ContextEnv ctx cds)) (ContextState 1 IMap.empty 0)) - data Window os c ds = Window { getWinName :: Name } instance Eq (Window os c ds) where (Window a) == (Window b) = a == b +createHiddenWin :: (ContextHandler ctx, MonadIO m) => ContextT ctx os m (ContextWindow ctx) +createHiddenWin = ContextT $ do + ContextEnv ctx cds <- ask + ContextState wid _ _ <- lift get -- We need to keep next window id and not start over at 1 + w <- liftIO $ createContext ctx Nothing + cd <- liftIO $ addContextData (contextDelete ctx w) cds + let ws = WindowState cd IMap.empty IMap.empty (-1) + lift $ put $ ContextState wid (IMap.singleton wid (ws,w)) 0 + liftIO $ contextDoAsync ctx (Just w) initGlState + return w + -- | Creates a window newWindow :: (ContextHandler ctx, MonadIO m) => WindowFormat c ds -> WindowParameters ctx -> ContextT ctx os m (Window os c ds) newWindow wf wp = ContextT $ do @@ -208,9 +221,12 @@ Just (ws, w) -> do ContextEnv ctx cds <- ask let wmap' = IMap.delete wid wmap - let n' = if n /= wid then n else case IMap.toList wmap' of - [] -> -1 --No windows left - x:_ -> fst x + n' <- if (IMap.null wmap') + then do + void $ let ContextT m = createHiddenWin in m -- Create a hidden window before we delete last window + return 0 -- The hidden window is now Concurrent + else if n /= wid then return n + else return (fst (head (IMap.toList wmap'))) -- always at least one elem liftIO $ do removeContextData cds (windowContextData ws) contextDelete ctx w lift $ put $ ContextState nid wmap' n' @@ -231,16 +247,9 @@ getLastContextWin = ContextT $ do cs <- lift get let wid = lastUsedWin cs - if wid > 0 - then return (snd $ perWindowState cs ! wid) - else do --Create hidden window - ContextEnv ctx cds <- ask - w <- liftIO $ createContext ctx Nothing - cd <- liftIO $ addContextData (contextDelete ctx w) cds - let ws = WindowState cd IMap.empty IMap.empty (-1) - lift $ put $ ContextState 1 (IMap.singleton wid (ws,w)) 0 - liftIO $ contextDoAsync ctx (Just w) initGlState - return w + if wid >= 0 + then return (snd $ perWindowState cs ! wid) -- always exists, since delete context will change lastUsedWin for us + else let ContextT m = createHiddenWin in m liftNonWinContextIO :: (ContextHandler ctx, MonadIO m) => IO a -> ContextT ctx os m a liftNonWinContextIO m = do diff --git a/src/Graphics/GPipe/Internal/FrameBuffer.hs b/src/Graphics/GPipe/Internal/FrameBuffer.hs --- a/src/Graphics/GPipe/Internal/FrameBuffer.hs +++ b/src/Graphics/GPipe/Internal/FrameBuffer.hs @@ -31,7 +31,7 @@ import Linear.V4 import Control.Monad.IO.Class import Control.Monad.Trans.Except -import Data.IntMap ((!)) +import qualified Data.IntMap as IMap -- | A monad in which individual color images can be drawn. newtype DrawColors os s a = DrawColors (StateT Int (Writer [Int -> (ExprM (), GlobDeclM (), s -> (IO FBOKey, IO (), IO ()))]) a) deriving (Functor, Applicative, Monad) @@ -445,8 +445,9 @@ inWin w m = Render $ do rs <- lift $ lift StrictState.get - let (_, doAsync) = perWindowRenderState rs ! getWinName w - liftIO $ doAsync m + case IMap.lookup (getWinName w) (perWindowRenderState rs) of + Nothing -> return () -- Window deleted, do nothing + Just (_, doAsync) -> liftIO $ doAsync m -- | Fill the window's back buffer with a constant color value clearWindowColor :: forall os c ds. ContextColorFormat c => Window os c ds -> Color c Float -> Render os ()