git.iko.soy/patch
on e596bab help sign in
patch/bench/Main.hs
109 lines 4.5 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE BangPatterns #-}
3{-# LANGUAGE TupleSections #-}
4{-# LANGUAGE ScopedTypeVariables #-}
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 Data.Functor.Misc
13import Control.Monad.IO.Class
14import Control.Monad.Identity
15import Data.Dependent.Sum
16import Control.Concurrent.STM
17import Data.IORef
18import Control.DeepSeq
19import Control.Exception (evaluate)
20import Reflex
21import Reflex.Host.Class
22import Criterion.Main
23import Data.Dependent.Map (DMap)
24import qualified Data.Dependent.Map as DMap
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