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