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