git.iko.soy/reflex-dom
on develop help sign in
Avoid multiple requestAnimationFrame callbacks for the same frame.
44a05d7Hamish Mackenzie
reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+20−13
compare with develop
unifiedsplit
@@ -208,20 +208,27 @@ runImmediateDomBuilderT
208 -> ImmediateDomBuilderEnv t
208 -> ImmediateDomBuilderEnv t
209 -> Chan [DSum (EventTriggerRef t) TriggerInvocation]
209 -> Chan [DSum (EventTriggerRef t) TriggerInvocation]
210 -> m a
210 -> m a
211−runImmediateDomBuilderT (ImmediateDomBuilderT a) env eventChan = flip runTriggerEventT eventChan $ do
211+runImmediateDomBuilderT (ImmediateDomBuilderT a) env eventChan = do
212+ handlersMVar <- liftIO $ newMVar []
213+ flip runTriggerEventT eventChan $ do
212− win <- DOM.currentWindowUnchecked
214+ win <- DOM.currentWindowUnchecked
213− rec (x, req) <- runRequesterT (runReaderT a env) rsp
215+ rec (x, req) <- runRequesterT (runReaderT a env) rsp
214− rsp <- performEventAsync $ ffor req $ \rm f -> liftJSM $ runInAnimationFrame win f $
216+ rsp <- performEventAsync $ ffor req $ \rm f -> liftJSM $ runInAnimationFrame handlersMVar win f $
215− DMap.traverseWithKey (\_ r -> Identity <$> r) rm
217+ DMap.traverseWithKey (\_ r -> Identity <$> r) rm
216− return x
218+ return x
217 where
219 where
218− runInAnimationFrame win f x = do
220+ runInAnimationFrame handlersMVar win f x = do
221+ handlers <- liftIO $ takeMVar handlersMVar
222+ when (null handlers) $ do
219− rec cb <- newRequestAnimationFrameCallbackSync $ \_ -> do
223+ rec cb <- newRequestAnimationFrameCallbackSync $ \_ -> do
220− freeRequestAnimationFrameCallback cb
224+ freeRequestAnimationFrameCallback cb
221− v <- synchronously x
225+ handlersToRun <- liftIO $ takeMVar handlersMVar
222− void . liftIO $ f v
226+ liftIO $ putMVar handlersMVar []
227+ sequence_ handlersToRun
223− _ <- Window.requestAnimationFrame win cb
228+ void $ Window.requestAnimationFrame win cb
224− return ()
229+ liftIO $ putMVar handlersMVar $ handlers ++ [do
230+ v <- synchronously x
231+ void . liftIO $ f v]
225
232
226class Monad m => HasDocument m where
233class Monad m => HasDocument m where
227 askDocument :: m Document
234 askDocument :: m Document
reflex-dom-core/test/gc.hs+7−14
@@ -6,8 +6,6 @@ import Control.Monad
6import Control.Monad.IO.Class
6import Control.Monad.IO.Class
7import Data.Int
7import Data.Int
8import GHC.Stats
8import GHC.Stats
9−import Language.Javascript.JSaddle.Types (liftJSM)
10−import Language.Javascript.JSaddle.Run
11import Language.Javascript.JSaddle.Warp
9import Language.Javascript.JSaddle.Warp
12import Reflex.Dom.Core
10import Reflex.Dom.Core
13import System.Exit
11import System.Exit
@@ -20,7 +18,7 @@ import System.Process
20-- probably have a memory leak; going under the minimum doesn't indicate a
18-- probably have a memory leak; going under the minimum doesn't indicate a
21-- memory leak, but may mean the test needs to be updated.
19-- memory leak, but may mean the test needs to be updated.
22minBytesAllowed, resetThreshold, maxBytesAllowed :: Int64
20minBytesAllowed, resetThreshold, maxBytesAllowed :: Int64
23−(minBytesAllowed, resetThreshold, maxBytesAllowed) = (200000, 400000, 440000)
21+(minBytesAllowed, resetThreshold, maxBytesAllowed) = (200000, 400000, 490000)
24
22
25main :: IO ()
23main :: IO ()
26main = do
24main = do
@@ -40,13 +38,9 @@ main = do
40 d <- holdDyn mempty $ mempty <$ domEvent Click e
38 d <- holdDyn mempty $ mempty <$ domEvent Click e
41 return ()
39 return ()
42 postBuild <- getPostBuild
40 postBuild <- getPostBuild
43− let f (!failures, !n) = if n < 3000
41+ let f (!failures, !n) = liftIO $ if n < 3000
44− then do
45− liftIO $ performMajorGC
42+ then do performMajorGC
46− liftJSM $ do
43+ threadDelay 5000 -- Wait a bit to allow requestAnimationFrame to call its callback sometimes; this value was experimentally determined
47− _ <- waitForAnimationFrame
48− syncPoint
49− liftIO $ do
50 gcStats <- getGCStats
44 gcStats <- getGCStats
51 print $ currentBytesUsed gcStats
45 print $ currentBytesUsed gcStats
52 when (currentBytesUsed gcStats < minBytesAllowed) $ do
46 when (currentBytesUsed gcStats < minBytesAllowed) $ do
@@ -58,10 +52,9 @@ main = do
58 putStrLn "FAILED: currentBytesUsed > maxBytesAllowed"
52 putStrLn "FAILED: currentBytesUsed > maxBytesAllowed"
59 finishTest $ ExitFailure 1
53 finishTest $ ExitFailure 1
60 return $ Just (if overMax then succ failures else (if underReset then 0 else failures), succ n)
54 return $ Just (if overMax then succ failures else (if underReset then 0 else failures), succ n)
61− else liftIO $ do
62− putStrLn "SUCCEEDED"
55+ else do putStrLn "SUCCEEDED"
63− finishTest ExitSuccess
56+ finishTest ExitSuccess
64− return Nothing
57+ return Nothing
65 rec redraw <- performEvent <=< delay 0 $ f <$> leftmost
58 rec redraw <- performEvent <=< delay 0 $ f <$> leftmost
66 [ ((0 :: Int), (0 :: Int)) <$ postBuild
59 [ ((0 :: Int), (0 :: Int)) <$ postBuild
67 , fmapMaybe id redraw
60 , fmapMaybe id redraw