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