GPipe-GLFW 1.0 → 1.1
raw patch · 3 files changed
+72/−43 lines, 3 filesdep ~GPipePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: GPipe
API changes (from Hackage documentation)
Files
- GPipe-GLFW.cabal +3/−3
- src/Graphics/GPipe/Context/GLFW.hs +67/−38
- src/Graphics/GPipe/Context/GLFW/Util.hs +2/−2
GPipe-GLFW.cabal view
@@ -1,5 +1,5 @@ name: GPipe-GLFW-version: 1.0+version: 1.1 cabal-version: >=1.10 build-type: Simple author: Patrick Redmond@@ -22,7 +22,7 @@ base >=4.7 && <4.9, transformers >= 0.3 && < 0.5, GLFW-b >=1.4 && <1.5,- GPipe >=2.0 && <2.1+ GPipe >=2.1 && <2.2 ghc-options: -Wall default-language: Haskell2010 exposed-modules: Graphics.GPipe.Context.GLFW@@ -40,4 +40,4 @@ type: git location: git@github.com:plredmond/GPipe-GLFW.git subdir: GPipe-GLFW- tag: v1.0+ tag: v1.1
src/Graphics/GPipe/Context/GLFW.hs view
@@ -7,22 +7,21 @@ ) where import qualified Control.Concurrent as C-import qualified Control.Monad as M import qualified Graphics.GPipe.Context.GLFW.Format as Format import qualified Graphics.GPipe.Context.GLFW.Resource as Resource import qualified Graphics.GPipe.Context.GLFW.Util as Util-import qualified Graphics.UI.GLFW as GLFW (getCursorPos, getMouseButton, getKey, windowShouldClose, makeContextCurrent, destroyWindow)+import qualified Graphics.UI.GLFW as GLFW (getCursorPos, getMouseButton, getKey, windowShouldClose, makeContextCurrent, destroyWindow, pollEvents) import Control.Monad.IO.Class (MonadIO)-import Data.Maybe (isNothing) import Graphics.GPipe.Context (ContextFactory, ContextHandle(..),ContextT,withContextWindow)-import Graphics.GPipe.Format (ContextFormat) import Graphics.UI.GLFW (MouseButtonState(..), MouseButton(..), KeyState(..), Key(..))--type Message = Maybe Request+import Data.IORef+import Control.Monad (when) -data Request where- ReqExecute :: forall a. IO a -> Maybe (C.MVar a) -> Request+data Message where+ ReqShutDown :: C.MVar () -> Message+ ReqExecuteSync :: forall a. IO a -> C.MVar a -> Message+ ReqExecuteAsync :: IO () -> Message ------------------------------------------------------------------------------ -- Top-level@@ -31,25 +30,31 @@ newtype GLFWWindow = GLFWWindow { unGLFWWindow :: Resource.Window } -- | The context factory which facilitates use of GLFW with GPipe.+-- This has to be run from the main thread. newContext :: ContextFactory c ds GLFWWindow newContext fmt = do chReply <- C.newEmptyMVar- _ <- C.forkOS $ begin chReply fmt- C.takeMVar chReply+ _ <- C.forkOS $ begin chReply+ msgC <- C.takeMVar chReply+ h <- createContext msgC Nothing fmt + contextDoAsync h True (return ()) -- First action on render thread: Just make window current+ return h createContext :: C.Chan Message -> Maybe Resource.Window -> ContextFactory c ds GLFWWindow createContext msgC share fmt = do w <- makeContext share+ GLFW.makeContextCurrent Nothing+ alive <- newIORef True -- This will always be used from render thread so no need to synchronize return ContextHandle- { newSharedContext = contextDoSyncImpl w msgC . createContext msgC (Just w)+ { newSharedContext = mainthreadDoWhileContextUncurrent msgC w . createContext msgC (Just w) -- Create context on this thread while parent is uncurrent, then make parent current , contextDoSync = contextDoSyncImpl w msgC- , contextDoAsync = contextDoAsyncImpl w msgC- , contextSwap = Util.swapBuffers w -- this thread only- , contextFrameBufferSize = Util.getFramebufferSize w -- this thread only- , contextDelete = do- contextDoSyncImpl w msgC (GLFW.destroyWindow w)- -- Shut down thread when outermost shared context is destroyed- M.when (isNothing share) $ contextDeleteImpl msgC+ , contextDoAsync = contextDoAsyncImpl alive w msgC+ , contextSwap = contextDoSyncImpl w msgC False $ Util.swapBuffers w -- explicitly do it on the render thread to sync properly, GLFW allows this+ , contextFrameBufferSize = Util.getFramebufferSize w -- Runs on mainthread+ , contextDelete = case share of+ Nothing -> do contextDeleteImpl msgC -- This return when render thread is uncurrent and is shutting down (cannot serve any finalizers)+ GLFW.destroyWindow w+ Just parentW -> mainthreadDoWhileContextUncurrent msgC parentW (writeIORef alive False >> GLFW.destroyWindow w) -- Shared contexts still alive, delete while uncurrent, then make parent win current , contextWindow = GLFWWindow w } where@@ -58,15 +63,15 @@ makeContext Nothing = Resource.newContext Nothing hints Nothing makeContext (Just s) = Resource.newSharedContext s hints Nothing + ------------------------------------------------------------------------------ -- OpenGL Context thread --- Create and pass back a ContextHandle. Enter loop.-begin :: C.MVar (ContextHandle GLFWWindow) -> ContextFormat c ds -> IO ()-begin chReply fmt = do+-- Create and pass back a channel. Enter loop.+begin :: C.MVar (C.Chan Message) -> IO ()+begin chReply = do msgC <- C.newChan- handle <- createContext msgC Nothing fmt- C.putMVar chReply handle+ C.putMVar chReply msgC loop msgC -- Handle messages until a stop message is received.@@ -74,33 +79,57 @@ loop msgC = do msg <- C.readChan msgC case msg of- Nothing -> return ()- Just req -> doRequest req >> loop msgC---- Do what the a request asks.-doRequest :: Request -> IO ()-doRequest (ReqExecute action Nothing) = M.void action-doRequest (ReqExecute action (Just reply)) = action >>= C.putMVar reply+ ReqShutDown reply -> GLFW.makeContextCurrent Nothing >> C.putMVar reply ()+ ReqExecuteSync action reply -> action >>= C.putMVar reply >> loop msgC+ ReqExecuteAsync action -> action >> loop msgC ------------------------------------------------------------------------------ -- Application rpc calls -- Await sychronous concurrent IO from the OpenGL context thread-contextDoSyncImpl :: Resource.Window -> C.Chan Message -> IO a -> IO a-contextDoSyncImpl w msgC action = do+contextDoSyncImpl :: Resource.Window -> C.Chan Message -> Bool -> IO a -> IO a+contextDoSyncImpl w msgC inwin action = do reply <- C.newEmptyMVar- C.writeChan msgC . Just $ ReqExecute (GLFW.makeContextCurrent (Just w) >> action) (Just reply)+ C.writeChan msgC $ ReqExecuteSync (do when inwin (GLFW.makeContextCurrent (Just w))+ action)+ reply+ GLFW.pollEvents -- Ugly hack, but at least every swapContextBuffers will run this C.takeMVar reply -- Dispatch asychronous concurrent IO to the OpenGL context thread-contextDoAsyncImpl :: Resource.Window -> C.Chan Message -> IO () -> IO ()-contextDoAsyncImpl w msgC action =- C.writeChan msgC . Just $ ReqExecute (GLFW.makeContextCurrent (Just w) >> action) Nothing+contextDoAsyncImpl :: IORef Bool -> Resource.Window -> C.Chan Message -> Bool -> IO () -> IO ()+contextDoAsyncImpl alive w msgC inwin action =+ C.writeChan msgC $ ReqExecuteAsync $ if inwin + then do -- If needed to be run in this window, then only do it if window still exists+ alive' <- readIORef alive + when alive' $ do + GLFW.makeContextCurrent (Just w)+ action+ else+ action +-- Do action while renderhtread is uncurrent +mainthreadDoWhileContextUncurrent :: C.Chan Message -> Resource.Window -> IO a -> IO a+mainthreadDoWhileContextUncurrent msgC w mainAction = do+ syncMainWait <- C.newEmptyMVar+ syncRendWait <- C.newEmptyMVar+ let m = do GLFW.makeContextCurrent Nothing+ C.putMVar syncMainWait () + C.takeMVar syncRendWait -- Stop other async code from making window current (e.g. finalizers)+ GLFW.makeContextCurrent (Just w)+ + C.writeChan msgC $ ReqExecuteAsync m + C.takeMVar syncMainWait -- Wait for render thread to make window uncurrent+ ret <- mainAction+ C.putMVar syncRendWait () -- Release render thread+ return ret+ -- Request that the OpenGL context thread shut down contextDeleteImpl :: C.Chan Message -> IO ()-contextDeleteImpl msgC =- C.writeChan msgC Nothing+contextDeleteImpl msgC = do+ syncMainWait <- C.newEmptyMVar+ C.writeChan msgC $ ReqShutDown syncMainWait+ C.takeMVar syncMainWait ------------------------------------------------------------------------------ -- Exposed window actions
src/Graphics/GPipe/Context/GLFW/Util.hs view
@@ -11,9 +11,9 @@ -- Util swapBuffers :: GLFW.Window -> IO ()-swapBuffers w = GLFW.makeContextCurrent (Just w) >> GLFW.swapBuffers w >> GLFW.pollEvents+swapBuffers = GLFW.swapBuffers getFramebufferSize :: GLFW.Window -> IO (Int, Int)-getFramebufferSize w = GLFW.makeContextCurrent (Just w) >> GLFW.getFramebufferSize w+getFramebufferSize = GLFW.getFramebufferSize -- eof