@@ -0,0 +1,79 @@
1+{-# LANGUAGE ConstraintKinds, TypeSynonymInstances, BangPatterns, ScopedTypeVariables, TupleSections, GADTs, RankNTypes, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
2+{-# OPTIONS_GHC -fno-warn-orphans #-}
3+
4+module Main where
5+
6+import Criterion.Main
7+import Criterion.Types
8+
9+import Reflex
10+import Reflex.Host.Class
11+
12+import Reflex.TestPlan
13+import Reflex.Plan.Reflex
14+
15+import Reflex.Spider.Internal (SpiderEventHandle)
16+import qualified Reflex.Bench.Focused as Focused
17+
18+import Control.Applicative
19+import Control.DeepSeq (NFData (..))
20+
21+import System.IO
22+import System.Mem
23+import Prelude
24+
25+type MonadReflexHost' t m = (MonadReflexHost t m, MonadIORef m, MonadIORef (HostFrame t))
26+
27+
28+setupFiring :: (MonadReflexHost t m, MonadIORef m) => Plan t (Event t a) -> m (Ignore (EventHandle t a), Schedule t)
29+setupFiring p = do
30+ (e, s) <- runPlan p
31+ h <- subscribeEvent e
32+ return (Ignore h, s)
33+
34+-- Hack to avoid the NFData constraint for EventHandle which is a synonym
35+newtype Ignore a = Ignore a
36+instance NFData (Ignore a) where
37+ rnf !_ = ()
38+
39+instance NFData (SpiderEventHandle a) where
40+ rnf !_ = ()
41+
42+instance NFData (Behavior t a) where
43+ rnf !_ = ()
44+
45+instance NFData (Firing t) where
46+ rnf !(Firing _ _) = ()
47+
48+-- Measure the running time
49+benchFiring :: (MonadReflexHost' t m, MonadSample t m) => (forall a. m a -> IO a) -> (String, TestCase) -> Benchmark
50+benchFiring runHost (name, TestE p) = env setup (\e -> bench name $ whnfIO $ run e) where
51+ run (Ignore h, s) = runHost (readSchedule s (readEvent' h)) >> performGC
52+ setup = runHost $ setupFiring p
53+
54+benchFiring runHost (name, TestB p) = env setup (\e -> bench name $ whnfIO $ run e) where
55+ run (b, s) = runHost (readSchedule s (sample b)) >> performGC
56+ setup = runHost $ do
57+ (b, s) <- runPlan p
58+ return (b, makeDense s)
59+
60+main :: IO ()
61+main = do
62+ hSetBuffering stdout LineBuffering
63+ defaultMainWith (defaultConfig { timeLimit = 10, csvFile = Just "dmap-cale-densemergetree.csv" })
64+ [ benchImpl "spider" runSpiderHost
65+ ]
66+
67+benchImpl :: (MonadReflexHost' t m, MonadSample t m) => String -> (forall a. m a -> IO a) -> Benchmark
68+benchImpl name runHost = bgroup name [ firing 10000
69+ ]
70+ where
71+ firing n = runGroup ("firing " ++ show n) $ [ testE "dense mergeTree" $ Focused.mergeTree 8 <$> dense ]
72+ where
73+ dense :: TestPlan t m => m [Event t Word]
74+ dense = Focused.continuous n 2
75+
76+ runGroup name' benchmarks = bgroup name' (benchFiring runHost <$> benchmarks)
77+
78+
79+