@@ -0,0 +1,110 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE TupleSections #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE TypeFamilies #-}
5+module Main where
6+
7+import Data.Functor.Misc
8+import Control.Monad.Primitive
9+import Control.Monad.IO.Class
10+import Data.Dependent.Sum
11+import Control.Concurrent.STM
12+import Control.Applicative
13+import System.IO.Unsafe
14+import Data.IORef
15+import Control.DeepSeq
16+import Control.Exception (evaluate)
17+import Control.Monad
18+import Reflex
19+import Reflex.Host.Class
20+import System.Mem
21+import System.IO
22+import Criterion.Main
23+
24+import qualified Data.Traversable as T
25+
26+import qualified Data.Dependent.Map as DM
27+
28+
29+main :: IO ()
30+main = defaultMain
31+ [ bgroup "micro" micros ]
32+
33+instance NFData (IORef a) where
34+ rnf x = seq x ()
35+
36+instance NFData (TVar a) where
37+ rnf x = seq x ()
38+
39+newtype WHNF a = WHNF a
40+instance NFData (WHNF a) where
41+ rnf (WHNF a) = seq a ()
42+
43+withSetup :: NFData b => String -> SpiderHost a -> (a -> SpiderHost b) -> Benchmark
44+withSetup name setup action = env (WHNF <$> runSpiderHost setup) $ \ ~(WHNF a) ->
45+ bench name . nfIO $ runSpiderHost (action a)
46+
47+withSetupWHNF :: String -> SpiderHost a -> (a -> SpiderHost b) -> Benchmark
48+withSetupWHNF name setup action = env (WHNF <$> runSpiderHost setup) $ \ ~(WHNF a) ->
49+ bench name . whnfIO $ runSpiderHost (action a)
50+
51+
52+micros :: [Benchmark]
53+micros =
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+ ]
94+
95+setupMerge :: Int
96+ -> SpiderHost (Event Spider (DM.DMap (Const2 Int a)),
97+ [IORef (Maybe (EventTrigger Spider a))])
98+setupMerge 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)
102+
103+subscribePair :: (Event Spider a, b) -> SpiderHost (EventHandle Spider a, b)
104+subscribePair (ev, b) = (,b) <$> subscribeEvent ev
105+
106+fireAndRead :: IORef (Maybe (EventTrigger Spider a)) -> a -> EventHandle Spider b
107+ -> SpiderHost (Maybe b)
108+fireAndRead trigger val subd = do
109+ Just key <- liftIO $ readIORef trigger
110+ fireEventsAndRead [key :=> val] $ readEvent subd >>= T.sequence