Fall back to main thread rendering when secondary setup fails (#131)

* Attempt to recover from SDL_GL_MakeCurrent error, and fallback to rendering on the main thread * Check if -threaded flag was used before setting up rendering thread. Add notes to appRenderingOnMainThread * Remove reference to the error from Setup page * Update Changelog * Fix typo * Fix issues with RunInRenderThread when running on single threaded mode. Improve handling of initialization, simplify Core's state variables * Update Changelog * Add note about threaded rendering in 'Running the examples' section. Fix typo.
2024-09-11 12:05:35 +03:00 · 2022-04-30 16:00:17 +02:00 · 2022-04-30 16:00:17 +02:00 · dbb603a4a7
commit dbb603a4a7
parent d2b56c430a
6 changed files with 148 additions and 54 deletions
--- a/ChangeLog.md
+++ b/ChangeLog.md
@ -22,6 +22,8 @@
 - Differences in glyphs positions used by `FontManager` and nanovg; temporary workaround ([PR #105](https://github.com/fjvallarino/monomer/pull/105)).
 - `nodeInfoFromKey` relies on `nodeInfoFromPath` to retrieve information instead of fetching it directly from `WidgetEnv`'s `widgetKeyMap`, which can be stale ([PR #110](https://github.com/fjvallarino/monomer/pull/110)).
 - Glyph positioning issues in `FontManager`; removed workaround added in #105 ([PR #125](https://github.com/fjvallarino/monomer/pull/125)).
+- Will attempt to fall back to rendering on the main thread if threaded rendering setup fails ([PR #131](https://github.com/fjvallarino/monomer/pull/131)).
+- Space leak in StyleUtil's mergeNodeStyleState ([PR #132](https://github.com/fjvallarino/monomer/pull/132)).

 ### Added

--- a/docs/tutorials/00-setup.md
+++ b/docs/tutorials/00-setup.md
@ -114,16 +114,6 @@ Inside your project's directory:
 stack build
 ```

-#### Linux notes
-
-One case has been reported where an _"Unable to make GL context current"_ error
-ocurred on application startup. This seems to be a driver issue, and it's not
-something that can be fixed from the library.
-
-As a workaround, an application configuration option called
-`appRenderOnMainThread` is available. It can be added to the `config` list of
-the starter application or to the corresponding section of any of the examples.
-
 ## Build the examples included with the library

 In case you want to test the examples the library provides, you need to clone
@ -153,6 +143,24 @@ stack run ticker
 stack run generative
 ```

+#### Notes
+
+Monomer uses a secondary thread for rendering to be able to redraw the content
+while the user resizes the window. In some configurations, mainly with NVIDIA
+drivers on Linux, setting up an OpenGL context in a secondary thread fails.
+
+If this happens, Monomer will try to fall back to rendering in the main thread
+and warn about the situation with a message similar to:
+
+```
+Setup of the rendering thread failed: Unable to make GL context current
+Falling back to rendering in the main thread.
+```
+
+Besides having the content stretched while resizing the window (i.e. not
+dinamically resized), there are no other differences between the threaded and
+non-threaded modes.
+
 ## Development mode

 Since compilation times can be annoying, I personally prefer to rely on
--- a/src/Monomer/Main/Core.hs
+++ b/src/Monomer/Main/Core.hs
@ -19,11 +19,11 @@ module Monomer.Main.Core (
  startApp
 ) where

-import Control.Concurrent (MVar, forkIO, forkOS, newMVar, threadDelay)
+import Control.Concurrent
 import Control.Concurrent.STM.TChan (TChan, newTChanIO, readTChan, writeTChan)
+import Control.Exception
 import Control.Lens ((&), (^.), (.=), (.~), use)
 import Control.Monad (unless, void, when)
-import Control.Monad.Catch
 import Control.Monad.Extra
 import Control.Monad.State
 import Control.Monad.STM (atomically)
@ -37,6 +37,7 @@ import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
 import Graphics.GL

 import qualified Data.Map as Map
+import qualified Data.Text as T
 import qualified SDL
 import qualified Data.Sequence as Seq

@ -73,7 +74,6 @@ type AppUIBuilder s e = UIBuilder s e

 data MainLoopArgs sp e ep = MainLoopArgs {
  _mlOS :: Text,
-  _mlRenderer :: Maybe Renderer,
  _mlTheme :: Theme,
  _mlAppStartTs :: Millisecond,
  _mlMaxFps :: Int,
@ -83,8 +83,7 @@ data MainLoopArgs sp e ep = MainLoopArgs {
  _mlFrameCount :: Int,
  _mlExitEvents :: [e],
  _mlWidgetRoot :: WidgetNode sp ep,
-  _mlWidgetShared :: MVar (Map Text WidgetShared),
-  _mlChannel :: TChan (RenderMsg sp ep)
+  _mlWidgetShared :: MVar (Map Text WidgetShared)
 }

 data RenderState s e = RenderState {
@ -136,7 +135,8 @@ runAppLoop window glCtx channel widgetRoot config = do
  dpr <- use L.dpr
  winSize <- use L.windowSize

-  let useRenderThread = fromMaybe True (_apcUseRenderThread config)
+  let useRenderThreadFlag = fromMaybe True (_apcUseRenderThread config)
+  let useRenderThread = useRenderThreadFlag && rtsSupportsBoundThreads
  let maxFps = fromMaybe 60 (_apcMaxFps config)
  let fonts = _apcFonts config
  let theme = fromMaybe def (_apcTheme config)
@ -148,9 +148,6 @@ runAppLoop window glCtx channel widgetRoot config = do
  model <- use L.mainModel
  os <- liftIO getPlatform
  widgetSharedMVar <- liftIO $ newMVar Map.empty
-  renderer <- if useRenderThread
-    then return Nothing
-    else liftIO $ Just <$> makeRenderer fonts dpr
  fontManager <- liftIO $ makeFontManager fonts dpr

  let wenv = WidgetEnv {
@ -183,13 +180,52 @@ runAppLoop window glCtx channel widgetRoot config = do
  let pathReadyRoot = widgetRoot
        & L.info . L.path .~ rootPath
        & L.info . L.widgetId .~ WidgetId (wenv ^. L.timestamp) rootPath
+  let makeMainThreadRenderer = do
+        renderer <- liftIO $ makeRenderer fonts dpr
+        L.renderMethod .= Left renderer
+        return RenderSetupSingle
+
+  setupRes <- if useRenderThread
+    then do
+      stpChan <- liftIO newTChanIO
+
+      liftIO . void . forkOS $
+        {-
+        The wenv and widgetRoot values are not used, since they are replaced
+        during MsgInit. Kept to avoid issues with the Strict pragma.
+        -}
+        startRenderThread stpChan channel window glCtx fonts dpr wenv widgetRoot
+
+      setupRes <- liftIO . atomically $ readTChan stpChan
+
+      case setupRes of
+        RenderSetupMakeCurrentFailed msg -> do
+          liftIO . putStrLn $ "Setup of the rendering thread failed: " ++ msg
+          liftIO . putStrLn $ "Falling back to rendering in the main thread. "
+            ++ "The content may not be updated while resizing the window."
+
+          makeMainThreadRenderer
+        _ -> do
+          return RenderSetupMulti
+    else do
+      makeMainThreadRenderer

  handleResourcesInit
  (newWenv, newRoot, _) <- handleWidgetInit wenv pathReadyRoot

+  {-
+  Deferred initialization step to account for Widgets that rely on OpenGL. They
+  need the Renderer to be setup before handleWidgetInit is called, and it is
+  safer to initialize the watcher after this happens.
+  -}
+  case setupRes of
+    RenderSetupMulti -> do
+      liftIO . atomically $ writeTChan channel (MsgInit newWenv newRoot)
+      liftIO $ watchWindowResize channel
+    _ -> return ()
+
  let loopArgs = MainLoopArgs {
    _mlOS = os,
-    _mlRenderer = renderer,
    _mlTheme = theme,
    _mlMaxFps = maxFps,
    _mlAppStartTs = appStartTs,
@ -199,17 +235,11 @@ runAppLoop window glCtx channel widgetRoot config = do
    _mlFrameCount = 0,
    _mlExitEvents = exitEvents,
    _mlWidgetRoot = newRoot,
-    _mlWidgetShared = widgetSharedMVar,
-    _mlChannel = channel
+    _mlWidgetShared = widgetSharedMVar
  }

  L.mainModel .= _weModel newWenv

-  when useRenderThread $ do
-    liftIO $ watchWindowResize channel
-    liftIO . void . forkOS $
-      startRenderThread channel window glCtx fonts dpr newWenv newRoot
-
  mainLoop window fontManager config loopArgs

 mainLoop
@ -314,20 +344,22 @@ mainLoop window fontManager config loopArgs = do
  -- Rendering
  renderCurrentReq <- checkRenderCurrent startTs _mlLatestRenderTs

-  let useRenderThread = fromMaybe True (_apcUseRenderThread config)
  let renderEvent = any isActionEvent eventsPayload
  let winRedrawEvt = windowResized || windowExposed
  let renderNeeded = winRedrawEvt || renderEvent || renderCurrentReq

-  when (renderNeeded && useRenderThread) $
-    liftIO . atomically $ writeTChan _mlChannel (MsgRender newWenv newRoot)
+  when renderNeeded $ do
+    renderMethod <- use L.renderMethod

-  when (renderNeeded && not useRenderThread) $ do
-    let renderer = fromJust _mlRenderer
-    let bgColor = newWenv ^. L.theme . L.clearColor
+    case renderMethod of
+      Right renderChan -> do
+        liftIO . atomically $ writeTChan renderChan (MsgRender newWenv newRoot)
+      Left renderer -> do
+        let bgColor = newWenv ^. L.theme . L.clearColor

-    liftIO $ renderWidgets window dpr renderer bgColor newWenv newRoot
+        liftIO $ renderWidgets window dpr renderer bgColor newWenv newRoot

+  -- Used in the next rendering cycle
  L.renderRequested .= windowResized

  let fps = realToFrac _mlMaxFps
@ -353,9 +385,18 @@ mainLoop window fontManager config loopArgs = do

  unless shouldQuit (mainLoop window fontManager config newLoopArgs)

+{-
+Attempts to initialize a GL context in a separate OS thread to handle rendering
+actions. This allows for continuous content updates when the user resizes the
+window.
+
+In case the setup fails, it notifies the parent process so it can fall back to
+rendering in the main thread.
+-}
 startRenderThread
  :: (Eq s, WidgetEvent e)
-  => TChan (RenderMsg s e)
+  => TChan RenderSetupResult
+  -> TChan (RenderMsg s e)
  -> SDL.Window
  -> SDL.GLContext
  -> [FontDef]
@ -363,12 +404,23 @@ startRenderThread
  -> WidgetEnv s e
  -> WidgetNode s e
  -> IO ()
-startRenderThread channel window glCtx fonts dpr wenv root = do
-  SDL.glMakeCurrent window glCtx
-  renderer <- liftIO $ makeRenderer fonts dpr
-  fontMgr <- liftIO $ makeFontManager fonts dpr
+startRenderThread setupChan msgChan window glCtx fonts dpr wenv root = do
+  resp <- try $ SDL.glMakeCurrent window glCtx

-  waitRenderMsg channel window renderer fontMgr state
+  case resp of
+    Right{} -> do
+      renderer <- liftIO $ makeRenderer fonts dpr
+      fontMgr <- liftIO $ makeFontManager fonts dpr
+
+      atomically $ writeTChan setupChan RenderSetupMulti
+
+      waitRenderMsg msgChan window renderer fontMgr state
+    Left (SDL.SDLCallFailed _ _ err) -> do
+      let msg = T.unpack err
+      atomically $ writeTChan setupChan (RenderSetupMakeCurrentFailed msg)
+    Left e -> do
+      let msg = displayException e
+      atomically $ writeTChan setupChan (RenderSetupMakeCurrentFailed msg)
  where
    state = RenderState dpr wenv root

@ -380,10 +432,10 @@ waitRenderMsg
  -> FontManager
  -> RenderState s e
  -> IO ()
-waitRenderMsg channel window renderer fontMgr state = do
-  msg <- liftIO . atomically $ readTChan channel
+waitRenderMsg msgChan window renderer fontMgr state = do
+  msg <- atomically $ readTChan msgChan
  newState <- handleRenderMsg window renderer fontMgr state msg
-  waitRenderMsg channel window renderer fontMgr newState
+  waitRenderMsg msgChan window renderer fontMgr newState

 handleRenderMsg
  :: (Eq s, WidgetEvent e)
@ -393,6 +445,9 @@ handleRenderMsg
  -> RenderState s e
  -> RenderMsg s e
  -> IO (RenderState s e)
+handleRenderMsg window renderer fontMgr state (MsgInit newWenv newRoot) = do
+  let RenderState dpr _ _ = state
+  return (RenderState dpr newWenv newRoot)
 handleRenderMsg window renderer fontMgr state (MsgRender tmpWenv newRoot) = do
  let RenderState dpr _ _ = state
  let newWenv = tmpWenv
--- a/src/Monomer/Main/Handlers.hs
+++ b/src/Monomer/Main/Handlers.hs
@ -51,6 +51,7 @@ import qualified SDL.Raw.Types as SDLT

 import Monomer.Core
 import Monomer.Event
+import Monomer.Graphics
 import Monomer.Helper (headMay, seqStartsWith)
 import Monomer.Main.Types
 import Monomer.Main.Util
@ -547,9 +548,12 @@ handleRenderStop widgetId previousStep = do
 handleRemoveRendererImage
  :: MonomerM s e m => Text -> HandlerStep s e -> m (HandlerStep s e)
 handleRemoveRendererImage name previousStep = do
-  renderChannel <- use L.renderChannel
+  renderMethod <- use L.renderMethod
+
+  case renderMethod of
+    Left renderer -> liftIO $ deleteImage renderer name
+    Right chan -> liftIO . atomically $ writeTChan chan (MsgRemoveImage name)

-  liftIO . atomically $ writeTChan renderChannel (MsgRemoveImage name)
  return previousStep

 handleExitApplication
@ -661,9 +665,17 @@ handleRunInRenderThread
  -> HandlerStep s e
  -> m (HandlerStep s e)
 handleRunInRenderThread widgetId path handler previousStep = do
-  renderChannel <- use L.renderChannel
+  renderMethod <- use L.renderMethod

-  handleRunTask widgetId path (taskWrapper renderChannel) previousStep
+  task <- case renderMethod of
+    Left renderer -> do
+      -- Force running in main thread to avoid issues with OpenGL
+      result <- liftIO handler
+      return (return result)
+    Right chan -> do
+      return $ liftIO (taskWrapper chan)
+
+  handleRunTask widgetId path task previousStep
  where
    taskWrapper renderChannel = do
      msgChan <- newTChanIO
--- a/src/Monomer/Main/Types.hs
+++ b/src/Monomer/Main/Types.hs
@ -47,11 +47,18 @@ type MonomerM s e m = (Eq s, MonadState (MonomerCtx s e) m, MonadCatch m, MonadI

 -- | Messages received by the rendering thread.
 data RenderMsg s e
-  = MsgRender (WidgetEnv s e) (WidgetNode s e)
+  = MsgInit (WidgetEnv s e) (WidgetNode s e)
+  | MsgRender (WidgetEnv s e) (WidgetNode s e)
  | MsgResize Size
  | MsgRemoveImage Text
  | forall i . MsgRunInRender (TChan i) (IO i)

+data RenderSetupResult
+  = RenderSetupSingle
+  | RenderSetupMulti
+  | RenderSetupMakeCurrentFailed String
+  deriving (Eq, Show)
+
 {-|
 Requirements for periodic rendering by a widget. Start time is stored to
 calculate next frame based on the step ms. A maximum number of repetitions may
@ -93,8 +100,8 @@ data MonomerCtx s e = MonomerCtx {
  _mcDpr :: Double,
  -- | Event pixel rate.
  _mcEpr :: Double,
-  -- | Event pixel rate.
-  _mcRenderChannel :: TChan (RenderMsg s e),
+  -- | Renderer instance or communication channel with the render thread.
+  _mcRenderMethod :: Either Renderer (TChan (RenderMsg s e)),
  -- | Input status (mouse and keyboard).
  _mcInputStatus :: InputStatus,
  -- | Cursor icons (a stack is used because of parent -> child relationship).
@ -286,11 +293,21 @@ Performs rendering on the main thread. On macOS and Windows this also disables
 continuous rendering on window resize, but in some Linux configurations it still
 works.

-This option is useful when OpenGL driver issues prevent normal startup showing
-the "Unable to make GL context current" error.
+This configuration option was originally available to handle:

-It can also be used for single threaded applications (without -threaded).
+  - OpenGL driver issues which prevented normal startup showing the "Unable to
+    make GL context current" error.
+  - Single threaded applications (without -threaded) which cannot use forkOS.
+
+This flag is no longer necessary for those cases, since the library will:
+
+  - Attempt to fall back to rendering on the main thread if setting up a
+    secondary rendering thread fails.
+  - Will not attempt to set up a secondary rendering thread if the runtime does
+    not support bound threads (i.e. compiled without the -threaded flag).
 -}
+{-# DEPRECATED appRenderOnMainThread
+  "Should no longer be needed. Check appRenderOnMainThread's Haddock page." #-}
 appRenderOnMainThread :: AppConfig e
 appRenderOnMainThread = def {
  _apcUseRenderThread = Just False
--- a/src/Monomer/Main/Util.hs
+++ b/src/Monomer/Main/Util.hs
@ -51,7 +51,7 @@ initMonomerCtx ~win channel winSize dpr epr model = MonomerCtx {
  _mcWindowSize = winSize,
  _mcDpr = dpr,
  _mcEpr = epr,
-  _mcRenderChannel = channel,
+  _mcRenderMethod = Right channel,
  _mcInputStatus = def,
  _mcCursorStack = [],
  _mcFocusedWidgetId = def,