44a05d7 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

Avoid multiple requestAnimationFrame callbacks for the same frame.

commit44a05d76a0b4d325d480f03f12617ede441c64b9 authorHamish Mackenzie <Hamish.K.Mackenzie@googlemail.com> dateThu 22 Jun 2017, 10:58 (9 years ago) parent580f997

2 files changed+27−27

compare with develop

unifiedsplit

reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+20−13 reflex-dom-core/test/gc.hs+7−14

reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+20−13

@@ -208,20 +208,27 @@ runImmediateDomBuilderT

208208 -> ImmediateDomBuilderEnv t

209209 -> Chan [DSum (EventTriggerRef t) TriggerInvocation]

210210 -> m a

211−runImmediateDomBuilderT (ImmediateDomBuilderT a) env eventChan = flip runTriggerEventT eventChan $ do

212− win <- DOM.currentWindowUnchecked

213− rec (x, req) <- runRequesterT (runReaderT a env) rsp

214− rsp <- performEventAsync $ ffor req $ \rm f -> liftJSM $ runInAnimationFrame win f $

215− DMap.traverseWithKey (\_ r -> Identity <$> r) rm

216− return x

211+runImmediateDomBuilderT (ImmediateDomBuilderT a) env eventChan = do

212+ handlersMVar <- liftIO $ newMVar []

213+ flip runTriggerEventT eventChan $ do

214+ win <- DOM.currentWindowUnchecked

215+ rec (x, req) <- runRequesterT (runReaderT a env) rsp

216+ rsp <- performEventAsync $ ffor req $ \rm f -> liftJSM $ runInAnimationFrame handlersMVar win f $

217+ DMap.traverseWithKey (\_ r -> Identity <$> r) rm

218+ return x

217219 where

218− runInAnimationFrame win f x = do

219− rec cb <- newRequestAnimationFrameCallbackSync $ \_ -> do

220− freeRequestAnimationFrameCallback cb

221− v <- synchronously x

222− void . liftIO $ f v

223− _ <- Window.requestAnimationFrame win cb

224− return ()

220+ runInAnimationFrame handlersMVar win f x = do

221+ handlers <- liftIO $ takeMVar handlersMVar

222+ when (null handlers) $ do

223+ rec cb <- newRequestAnimationFrameCallbackSync $ \_ -> do

224+ freeRequestAnimationFrameCallback cb

225+ handlersToRun <- liftIO $ takeMVar handlersMVar

226+ liftIO $ putMVar handlersMVar []

227+ sequence_ handlersToRun

228+ void $ Window.requestAnimationFrame win cb

229+ liftIO $ putMVar handlersMVar $ handlers ++ [do

230+ v <- synchronously x

231+ void . liftIO $ f v]

225232

226233class Monad m => HasDocument m where

227234 askDocument :: m Document

reflex-dom-core/test/gc.hs+7−14

@@ -6,8 +6,6 @@ import Control.Monad

66import Control.Monad.IO.Class

77import Data.Int

88import GHC.Stats

9−import Language.Javascript.JSaddle.Types (liftJSM)

10−import Language.Javascript.JSaddle.Run

119import Language.Javascript.JSaddle.Warp

1210import Reflex.Dom.Core

1311import System.Exit

@@ -20,7 +18,7 @@ import System.Process

2018-- probably have a memory leak; going under the minimum doesn't indicate a

2119-- memory leak, but may mean the test needs to be updated.

2220minBytesAllowed, resetThreshold, maxBytesAllowed :: Int64

23−(minBytesAllowed, resetThreshold, maxBytesAllowed) = (200000, 400000, 440000)

21+(minBytesAllowed, resetThreshold, maxBytesAllowed) = (200000, 400000, 490000)

2422

2523main :: IO ()

2624main = do

@@ -40,13 +38,9 @@ main = do

4038 d <- holdDyn mempty $ mempty <$ domEvent Click e

4139 return ()

4240 postBuild <- getPostBuild

43− let f (!failures, !n) = if n < 3000

44− then do

45− liftIO $ performMajorGC

46− liftJSM $ do

47− _ <- waitForAnimationFrame

48− syncPoint

49− liftIO $ do

41+ let f (!failures, !n) = liftIO $ if n < 3000

42+ then do performMajorGC

43+ threadDelay 5000 -- Wait a bit to allow requestAnimationFrame to call its callback sometimes; this value was experimentally determined

5044 gcStats <- getGCStats

5145 print $ currentBytesUsed gcStats

5246 when (currentBytesUsed gcStats < minBytesAllowed) $ do

@@ -58,10 +52,9 @@ main = do

5852 putStrLn "FAILED: currentBytesUsed > maxBytesAllowed"

5953 finishTest $ ExitFailure 1

6054 return $ Just (if overMax then succ failures else (if underReset then 0 else failures), succ n)

61− else liftIO $ do

62− putStrLn "SUCCEEDED"

63− finishTest ExitSuccess

64− return Nothing

55+ else do putStrLn "SUCCEEDED"

56+ finishTest ExitSuccess

57+ return Nothing

6558 rec redraw <- performEvent <=< delay 0 $ f <$> leftmost

6659 [ ((0 :: Int), (0 :: Int)) <$ postBuild

6760 , fmapMaybe id redraw