git.iko.soy/reflex
on workflow-monad help sign in
reflex/bench/RunAll.hs
157 lines 4.7 kB history raw
1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE ForeignFunctionInterface #-}
6{-# LANGUAGE GADTs #-}
7{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
9{-# LANGUAGE PatternSynonyms #-}
10{-# LANGUAGE RankNTypes #-}
11{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE TemplateHaskell #-}
13{-# LANGUAGE TupleSections #-}
14{-# LANGUAGE TypeSynonymInstances #-}
15{-# LANGUAGE ViewPatterns #-}
16{-# OPTIONS_GHC -fno-warn-orphans #-}
18module Main where
20import Criterion.Main
21import Criterion.Types
23import Reflex
24import Reflex.Host.Class
26import Reflex.Plan.Reflex
27import Reflex.TestPlan
29import qualified Reflex.Bench.Focused as Focused
30import Reflex.Spider.Internal (SpiderEventHandle)
32import Control.Applicative
33import Control.DeepSeq (NFData (..))
35import Prelude
36import System.IO
37import System.Mem
39import Control.Arrow
40import Control.Concurrent
41import Control.Concurrent.STM
42import Control.Exception
43import Control.Monad
44import Control.Monad.Trans
45import Data.Bool
46import Data.Function
47import Data.Int
48import Data.IORef
49import Data.Monoid
50import Data.Time.Clock
51import Debug.Trace.LocationTH
52import GHC.Stats
53import System.Environment
54import System.Mem.Weak
55import System.Process
56import Text.Read
58import Unsafe.Coerce
60import Data.Map (Map)
61import qualified Data.Map as Map
63type MonadReflexHost' t m = (MonadReflexHost t m, MonadIORef m, MonadIORef (HostFrame t))
66setupFiring :: (MonadReflexHost t m, MonadIORef m) => Plan t (Event t a) -> m (EventHandle t a, Schedule t)
67setupFiring p = do
68 (e, s) <- runPlan p
69 h <- subscribeEvent e
70 return (h, s)
72-- Hack to avoid the NFData constraint for EventHandle which is a synonym
73newtype Ignore a = Ignore a
74instance NFData (Ignore a) where
75 rnf !_ = ()
77instance NFData (SpiderEventHandle x a) where
78 rnf !_ = ()
80instance NFData (Behavior t a) where
81 rnf !_ = ()
83instance NFData (Firing t) where
84 rnf !_ = ()
86-- Measure the running time
87benchFiring :: forall t m. (MonadReflexHost' t m, MonadSample t m) => (forall a. m a -> IO a) -> TestCase -> Int -> IO ()
88benchFiring runHost tc n = runHost $ do
89 let runIterations :: m a -> m ()
90 runIterations test = replicateM_ (10*n) $ do
91 result <- test
92 liftIO $ evaluate result
93 case tc of
94 TestE p -> do
95 (h, s) <- setupFiring p
96 runIterations $ readSchedule_ s $ readEvent' h
97 TestB p -> do
98 (b, s) <- runPlan p
99 runIterations $ readSchedule_ (makeDense s) $ sample b
101waitForFinalizers :: IO ()
102waitForFinalizers = do
103 performGC
104 x <- getCurrentTime
105 isFinalized <- newIORef False
106 mkWeakPtr x $ Just $ writeIORef isFinalized True
107 performGC
108 fix $ \loop -> do
109 f <- readIORef isFinalized
110 unless f $ do
111 threadDelay 1
112 loop
114benchmarks :: [(String, Int -> IO ())]
115benchmarks = implGroup "spider" runSpiderHost cases
116 where
117 implGroup :: (MonadReflexHost' t m, MonadSample t m) => String -> (forall a. m a -> IO a) -> [(String, TestCase)] -> [(String, Int -> IO ())]
118 implGroup name runHost = group name . fmap (second (benchFiring runHost))
119 group name = fmap $ first ((name <> "/") <>)
120 sub n frames = group ("subscribing " ++ show (n, frames)) $ Focused.subscribing n frames
121 firing n = group ("firing " <> show n) $ Focused.firing n
122 merging n = group ("merging " <> show n) $ Focused.merging n
123 dynamics n = group ("dynamics " <> show n) $ Focused.dynamics n
124 cases = concat
125 [ sub 100 40
126 , dynamics 100
127 , dynamics 1000
128 , firing 1000
129 , firing 10000
130 , merging 10
131 , merging 50
132 , merging 100
133 , merging 200
134 ]
136pattern RunTestCaseFlag = "--run-test-case"
138spawnBenchmark :: String -> Benchmark
139spawnBenchmark name = Benchmark name $ Benchmarkable $ \n -> do
140 self <- getExecutablePath
141 callProcess self [RunTestCaseFlag, name, show n, "+RTS", "-N1"]
143foreign import ccall unsafe "myCapabilityHasOtherRunnableThreads" myCapabilityHasOtherRunnableThreads :: IO Bool
145main :: IO ()
146main = do
147 args <- getArgs
148 case args of
149 RunTestCaseFlag : t -> case t of
150 [name, readMaybe -> Just count] -> do
151 case lookup name benchmarks of
152 Just testCase -> testCase count
153 performGC
154 fix $ \loop -> bool (return ()) (yield >> loop) =<< myCapabilityHasOtherRunnableThreads
155 return ()
156 _ -> $failure "--run-test-case: expected test name and iteration count to follow"
157 _ -> defaultMainWith (defaultConfig { timeLimit = 20, csvFile = Just "dmap-original.csv", reportFile = Just "report.html" }) $ fmap (spawnBenchmark . fst) benchmarks