git.iko.soy/patch
on 6ed20dc help sign in
patch/bench/Main.hs
110 lines 4.3 kB history raw
1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE TupleSections #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE TypeFamilies #-}
5module Main where
7import Data.Functor.Misc
8import Control.Monad.Primitive
9import Control.Monad.IO.Class
10import Data.Dependent.Sum
11import Control.Concurrent.STM
12import Control.Applicative
13import System.IO.Unsafe
14import Data.IORef
15import Control.DeepSeq
16import Control.Exception (evaluate)
17import Control.Monad
18import Reflex
19import Reflex.Host.Class
20import System.Mem
21import System.IO
22import Criterion.Main
24import qualified Data.Traversable as T
26import qualified Data.Dependent.Map as DM
29main :: IO ()
30main = defaultMain
31 [ bgroup "micro" micros ]
33instance NFData (IORef a) where
34 rnf x = seq x ()
36instance NFData (TVar a) where
37 rnf x = seq x ()
39newtype WHNF a = WHNF a
40instance NFData (WHNF a) where
41 rnf (WHNF a) = seq a ()
43withSetup :: NFData b => String -> SpiderHost a -> (a -> SpiderHost b) -> Benchmark
44withSetup name setup action = env (WHNF <$> runSpiderHost setup) $ \ ~(WHNF a) ->
45 bench name . nfIO $ runSpiderHost (action a)
47withSetupWHNF :: String -> SpiderHost a -> (a -> SpiderHost b) -> Benchmark
48withSetupWHNF name setup action = env (WHNF <$> runSpiderHost setup) $ \ ~(WHNF a) ->
49 bench name . whnfIO $ runSpiderHost (action a)
52micros :: [Benchmark]
53micros =
54 [ bench "newIORef" $ whnfIO $ void $ newIORef ()
55 , env (newIORef (42 :: Int)) (bench "readIORef" . whnfIO . readIORef)
56 , bench "newTVar" $ whnfIO $ void $ newTVarIO ()
57 , env (newTVarIO (42 :: Int)) (bench "readTVar" . whnfIO . readTVarIO)
58 , bench "newEventWithTrigger" $ whnfIO . void $ runSpiderHost $ newEventWithTrigger $
59 \trigger -> return () <$ evaluate trigger
60 , bench "newEventWithTriggerRef" $ whnfIO . void $ runSpiderHost newEventWithTriggerRef
61 , withSetupWHNF "subscribeEvent" newEventWithTriggerRef $ subscribeEvent . fst
62 , withSetupWHNF "subscribeSwitch"
63 (join $ hold <$> fmap fst newEventWithTriggerRef <*> fmap fst newEventWithTriggerRef)
64 (subscribeEvent . switch)
65 , withSetupWHNF "subscribeMerge(1)" (setupMerge 1) $ \(ev,_) -> subscribeEvent ev
66 , withSetupWHNF "subscribeMerge(100)" (setupMerge 100) (subscribeEvent . fst)
67 , withSetupWHNF "subscribeMerge(10000)" (setupMerge 10000) (subscribeEvent . fst)
68 , bench "runHostFrame" $ whnfIO $ runSpiderHost $ runHostFrame $ return ()
69 , withSetupWHNF "fireEventsAndRead(single/single)"
70 (newEventWithTriggerRef >>= subscribePair)
71 (\(subd, trigger) -> fireAndRead trigger (42 :: Int) subd)
72 , withSetupWHNF "fireEventsOnly"
73 (newEventWithTriggerRef >>= subscribePair)
74 (\(subd, trigger) -> do
75 Just key <- liftIO $ readIORef trigger
76 fireEvents [key :=> (42 :: Int)])
77 , withSetupWHNF "fireEventsAndRead(head/merge1)"
78 (setupMerge 1 >>= subscribePair)
79 (\(subd, t:riggers) -> fireAndRead t (42 :: Int) subd)
80 , withSetupWHNF "fireEventsAndRead(head/merge100)"
81 (setupMerge 100 >>= subscribePair)
82 (\(subd, t:riggers) -> fireAndRead t (42 :: Int) subd)
83 , withSetupWHNF "fireEventsAndRead(head/merge10000)"
84 (setupMerge 10000 >>= subscribePair)
85 (\(subd, t:riggers) -> fireAndRead t (42 :: Int) subd)
86 , withSetupWHNF "fireEventsOnly(head/merge100)"
87 (setupMerge 100 >>= subscribePair)
88 (\(subd, t:riggers) -> do
89 Just key <- liftIO $ readIORef t
90 fireEvents [key :=> (42 :: Int)])
91 , withSetupWHNF "hold" newEventWithTriggerRef $ \(ev,trigger) -> hold (42 :: Int) ev
92 , withSetupWHNF "sample" (newEventWithTriggerRef >>= hold (42 :: Int) . fst) sample
93 ]
95setupMerge :: Int
96 -> SpiderHost (Event Spider (DM.DMap (Const2 Int a)),
97 [IORef (Maybe (EventTrigger Spider a))])
98setupMerge num = do
99 (evs, triggers) <- unzip <$> replicateM 100 newEventWithTriggerRef
100 let !m = DM.fromList [WrapArg (Const2 i) :=> v | (i,v) <- zip [0..] evs]
101 pure (merge m, triggers)
103subscribePair :: (Event Spider a, b) -> SpiderHost (EventHandle Spider a, b)
104subscribePair (ev, b) = (,b) <$> subscribeEvent ev
106fireAndRead :: IORef (Maybe (EventTrigger Spider a)) -> a -> EventHandle Spider b
107 -> SpiderHost (Maybe b)
108fireAndRead trigger val subd = do
109 Just key <- liftIO $ readIORef trigger
110 fireEventsAndRead [key :=> val] $ readEvent subd >>= T.sequence