@@ -1,10 +1,13 @@
11{-# LANGUAGE OverloadedStrings #-}
22{-# LANGUAGE RecursiveDo #-}
3+{-# LANGUAGE BangPatterns #-}
34import Control.Concurrent
45import Control.Monad
56import Control.Monad.IO.Class
67import Data.Int
78import GHC.Stats
9+import Language.Javascript.JSaddle.Types (liftJSM)
10+import Language.Javascript.JSaddle.Run
811import Language.Javascript.JSaddle.Warp
912import Reflex.Dom.Core
1013import System.Exit
@@ -16,8 +19,8 @@ import System.Process
1619-- 363712. Going over the maximum means the test has actually failed - we
1720-- probably have a memory leak; going under the minimum doesn't indicate a
1821-- memory leak, but may mean the test needs to be updated.
19−minBytesAllowed, maxBytesAllowed :: Int64
20−(minBytesAllowed, maxBytesAllowed) = (200000, 450000)
22+minBytesAllowed, resetThreshold, maxBytesAllowed :: Int64
23+(minBytesAllowed, resetThreshold, maxBytesAllowed) = (200000, 400000, 440000)
2124
2225main :: IO ()
2326main = do
@@ -28,6 +31,7 @@ main = do
2831 interruptProcessGroupOf browserProcess
2932 throwTo mainThread result
3033 run 3911 $ do
34+ -- enableLogging True
3135 liftIO $ putStrLn "Running..."
3236 mainWidget $ do
3337 let w = do
@@ -36,23 +40,30 @@ main = do
3640 d <- holdDyn mempty $ mempty <$ domEvent Click e
3741 return ()
3842 postBuild <- getPostBuild
39− let f n = liftIO $ if n < 3000
40− then do performMajorGC
41− threadDelay 1000 -- Wait a bit to allow requestAnimationFrame to call its callback sometimes; this value was experimentally determined
43+ let f (!failures, !n) = if n < 3000
44+ then do
45+ liftIO $ performMajorGC
46+ liftJSM $ do
47+ _ <- waitForAnimationFrame
48+ syncPoint
49+ liftIO $ do
4250 gcStats <- getGCStats
4351 print $ currentBytesUsed gcStats
4452 when (currentBytesUsed gcStats < minBytesAllowed) $ do
4553 putStrLn "FAILED: currentBytesUsed < minBytesAllowed"
4654 finishTest $ ExitFailure 2
47− when (currentBytesUsed gcStats > maxBytesAllowed) $ do
55+ let overMax = currentBytesUsed gcStats > maxBytesAllowed
56+ underReset = currentBytesUsed gcStats < resetThreshold
57+ when (overMax && failures > 4) $ do
4858 putStrLn "FAILED: currentBytesUsed > maxBytesAllowed"
4959 finishTest $ ExitFailure 1
50− return $ Just $ succ n
51− else do putStrLn "SUCCEEDED"
52− finishTest ExitSuccess
53− return Nothing
60+ 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
5465 rec redraw <- performEvent <=< delay 0 $ f <$> leftmost
55− [ (0 :: Int) <$ postBuild
66+ [ ((0 :: Int), (0 :: Int)) <$ postBuild
5667 , fmapMaybe id redraw
5768 ]
5869 _ <- widgetHold w $ w <$ redraw