git.iko.soy/reflex
on joindyn-intmap help sign in
reflex/bench/Main.hs
110 lines 4.6 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 Data.Maybe (fromJust)
24import Reflex
25import Reflex.Host.Class
27main :: IO ()
28main = defaultMain
29 [ bgroup "micro" micros ]
31#if !(MIN_VERSION_deepseq(1,4,2))
32instance NFData (IORef a) where
33 rnf x = seq x ()
34#endif
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 Global a -> (a -> SpiderHost Global b) -> Benchmark
44withSetup name setup action = env (WHNF <$> runSpiderHost setup) $ \ ~(WHNF a) ->
45 bench name . nfIO $ runSpiderHost (action a)
47withSetupWHNF :: String -> SpiderHost Global a -> (a -> SpiderHost Global b) -> Benchmark
48withSetupWHNF name setup action = env (WHNF <$> runSpiderHost setup) $ \ ~(WHNF a) ->
49 bench name . whnfIO $ runSpiderHost (action a)
51micros :: [Benchmark]
52micros =
53 [ bench "newIORef" $ whnfIO $ void $ newIORef ()
54 , env (newIORef (42 :: Int)) (bench "readIORef" . whnfIO . readIORef)
55 , bench "newTVar" $ whnfIO $ void $ newTVarIO ()
56 , env (newTVarIO (42 :: Int)) (bench "readTVar" . whnfIO . readTVarIO)
57 , bench "newEventWithTrigger" $ whnfIO . void $ runSpiderHost $ newEventWithTrigger $
58 \trigger -> return () <$ evaluate trigger
59 , bench "newEventWithTriggerRef" $ whnfIO . void $ runSpiderHost newEventWithTriggerRef
60 , withSetupWHNF "subscribeEvent" newEventWithTriggerRef $ subscribeEvent . fst
61 , withSetupWHNF "subscribeSwitch"
62 (join $ hold <$> fmap fst newEventWithTriggerRef <*> fmap fst newEventWithTriggerRef)
63 (subscribeEvent . switch)
64 , withSetupWHNF "subscribeMerge(1)" (setupMerge 1) $ \(ev,_) -> subscribeEvent ev
65 , withSetupWHNF "subscribeMerge(100)" (setupMerge 100) (subscribeEvent . fst)
66 , withSetupWHNF "subscribeMerge(10000)" (setupMerge 10000) (subscribeEvent . fst)
67 , bench "runHostFrame" $ whnfIO $ runSpiderHost $ runHostFrame $ return ()
68 , withSetupWHNF "fireEventsAndRead(single/single)"
69 (newEventWithTriggerRef >>= subscribePair)
70 (\(subd, trigger) -> fireAndRead trigger (42 :: Int) subd)
71 , withSetupWHNF "fireEventsOnly"
72 (newEventWithTriggerRef >>= subscribePair)
73 (\(_, trigger) -> do
74 key <- fromJust <$> liftIO (readIORef trigger)
75 fireEvents [key :=> Identity (42 :: Int)])
76 , withSetupWHNF "fireEventsAndRead(head/merge1)"
77 (setupMerge 1 >>= subscribePair)
78 (\(subd, t:_) -> fireAndRead t (42 :: Int) subd)
79 , withSetupWHNF "fireEventsAndRead(head/merge100)"
80 (setupMerge 100 >>= subscribePair)
81 (\(subd, t:_) -> fireAndRead t (42 :: Int) subd)
82 , withSetupWHNF "fireEventsAndRead(head/merge10000)"
83 (setupMerge 10000 >>= subscribePair)
84 (\(subd, t:_) -> fireAndRead t (42 :: Int) subd)
85 , withSetupWHNF "fireEventsOnly(head/merge100)"
86 (setupMerge 100 >>= subscribePair)
87 (\(_, t:_) -> do
88 key <- fromJust <$> liftIO (readIORef t)
89 fireEvents [key :=> Identity (42 :: Int)])
90 , withSetupWHNF "hold" newEventWithTriggerRef $ \(ev, _) -> hold (42 :: Int) ev
91 , withSetupWHNF "sample" (newEventWithTriggerRef >>= hold (42 :: Int) . fst) sample
92 ]
94setupMerge :: Int
95 -> SpiderHost Global ( Event (SpiderTimeline Global) (DMap (Const2 Int a) Identity)
96 , [IORef (Maybe (EventTrigger Spider a))]
97 )
98setupMerge num = do
99 (evs, triggers) <- unzip <$> replicateM num newEventWithTriggerRef
100 let !m = DMap.fromList [Const2 i :=> v | (i,v) <- zip [0..] evs]
101 pure (merge m, triggers)
103subscribePair :: (Event (SpiderTimeline Global) a, b) -> SpiderHost Global (EventHandle (SpiderTimeline Global) a, b)
104subscribePair (ev, b) = (,b) <$> subscribeEvent ev
106fireAndRead :: IORef (Maybe (EventTrigger (SpiderTimeline Global) a)) -> a -> EventHandle (SpiderTimeline Global) b
107 -> SpiderHost Global (Maybe b)
108fireAndRead trigger val subd = do
109 key <- fromJust <$> liftIO (readIORef trigger)
110 fireEventsAndRead [key :=> Identity val] $ readEvent subd >>= sequence