git.iko.soy/patch
on develop help sign in
Fix benchmarks to work on modern GHC.
03387bddavean
bench-cbits/checkCapability.c+11−12
compare with develop
unifiedsplit
@@ -42,7 +42,7 @@ typedef struct Task_ {
42 // or just continue immediately. It's a workaround for the fact
42 // or just continue immediately. It's a workaround for the fact
43 // that signalling a condition variable doesn't do anything if the
43 // that signalling a condition variable doesn't do anything if the
44 // thread is already running, but we want it to be sticky.
44 // thread is already running, but we want it to be sticky.
45− rtsBool wakeup;
45+ bool wakeup;
46#endif
46#endif
47
47
48 // This points to the Capability that the Task "belongs" to. If
48 // This points to the Capability that the Task "belongs" to. If
@@ -62,14 +62,14 @@ typedef struct Task_ {
62 // The current top-of-stack InCall
62 // The current top-of-stack InCall
63 struct InCall_ *incall;
63 struct InCall_ *incall;
64
64
65− nat n_spare_incalls;
65+ uint32_t n_spare_incalls;
66 struct InCall_ *spare_incalls;
66 struct InCall_ *spare_incalls;
67
67
68− rtsBool worker; // == rtsTrue if this is a worker Task
68+ bool worker; // == rtsTrue if this is a worker Task
69− rtsBool stopped; // this task has stopped or exited Haskell
69+ bool stopped; // this task has stopped or exited Haskell
70
70
71 // So that we can detect when a finalizer illegally calls back into Haskell
71 // So that we can detect when a finalizer illegally calls back into Haskell
72− rtsBool running_finalizers;
72+ bool running_finalizers;
73
73
74 // Links tasks on the returning_tasks queue of a Capability, and
74 // Links tasks on the returning_tasks queue of a Capability, and
75 // on spare_workers.
75 // on spare_workers.
@@ -88,7 +88,7 @@ struct Capability_ {
88 StgFunTable f;
88 StgFunTable f;
89 StgRegTable r;
89 StgRegTable r;
90
90
91− nat no; // capability number.
91+ uint32_t no; // capability number.
92
92
93 // The Task currently holding this Capability. This task has
93 // The Task currently holding this Capability. This task has
94 // exclusive access to the contents of this Capability (apart from
94 // exclusive access to the contents of this Capability (apart from
@@ -98,12 +98,12 @@ struct Capability_ {
98
98
99 // true if this Capability is running Haskell code, used for
99 // true if this Capability is running Haskell code, used for
100 // catching unsafe call-ins.
100 // catching unsafe call-ins.
101− rtsBool in_haskell;
101+ bool in_haskell;
102
102
103 // Has there been any activity on this Capability since the last GC?
103 // Has there been any activity on this Capability since the last GC?
104− nat idle;
104+ uint32_t idle;
105
105
106− rtsBool disabled;
106+ bool disabled;
107
107
108 // The run queue. The Task owning this Capability has exclusive
108 // The run queue. The Task owning this Capability has exclusive
109 // access to its run queue, so can wake up threads without
109 // access to its run queue, so can wake up threads without
@@ -159,7 +159,7 @@ struct Capability_ {
159#if defined(THREADED_RTS)
159#if defined(THREADED_RTS)
160 // Worker Tasks waiting in the wings. Singly-linked.
160 // Worker Tasks waiting in the wings. Singly-linked.
161 Task *spare_workers;
161 Task *spare_workers;
162− nat n_spare_workers; // count of above
162+ uint32_t n_spare_workers; // count of above
163
163
164 // This lock protects:
164 // This lock protects:
165 // running_task
165 // running_task
@@ -192,10 +192,9 @@ struct Capability_ {
192
192
193 // Per-capability STM-related data
193 // Per-capability STM-related data
194 StgTVarWatchQueue *free_tvar_watch_queues;
194 StgTVarWatchQueue *free_tvar_watch_queues;
195− StgInvariantCheckQueue *free_invariant_check_queues;
196 StgTRecChunk *free_trec_chunks;
195 StgTRecChunk *free_trec_chunks;
197 StgTRecHeader *free_trec_headers;
196 StgTRecHeader *free_trec_headers;
198− nat transaction_tokens;
197+ uint32_t transaction_tokens;
199} // typedef Capability is defined in RtsAPI.h
198} // typedef Capability is defined in RtsAPI.h
200 // We never want a Capability to overlap a cache line with anything
199 // We never want a Capability to overlap a cache line with anything
201 // else, so round it up to a cache line size:
200 // else, so round it up to a cache line size:
bench/Main.hs+7−6
@@ -20,6 +20,7 @@ import qualified Data.Dependent.Map as DMap
20import Data.Dependent.Sum
20import Data.Dependent.Sum
21import Data.Functor.Misc
21import Data.Functor.Misc
22import Data.IORef
22import Data.IORef
23+import Data.Maybe (fromJust)
23import Reflex
24import Reflex
24import Reflex.Host.Class
25import Reflex.Host.Class
25
26
@@ -70,7 +71,7 @@ micros =
70 , withSetupWHNF "fireEventsOnly"
71 , withSetupWHNF "fireEventsOnly"
71 (newEventWithTriggerRef >>= subscribePair)
72 (newEventWithTriggerRef >>= subscribePair)
72 (\(_, trigger) -> do
73 (\(_, trigger) -> do
73− Just key <- liftIO $ readIORef trigger
74+ key <- fromJust <$> liftIO (readIORef trigger)
74 fireEvents [key :=> Identity (42 :: Int)])
75 fireEvents [key :=> Identity (42 :: Int)])
75 , withSetupWHNF "fireEventsAndRead(head/merge1)"
76 , withSetupWHNF "fireEventsAndRead(head/merge1)"
76 (setupMerge 1 >>= subscribePair)
77 (setupMerge 1 >>= subscribePair)
@@ -84,14 +85,14 @@ micros =
84 , withSetupWHNF "fireEventsOnly(head/merge100)"
85 , withSetupWHNF "fireEventsOnly(head/merge100)"
85 (setupMerge 100 >>= subscribePair)
86 (setupMerge 100 >>= subscribePair)
86 (\(_, t:_) -> do
87 (\(_, t:_) -> do
87− Just key <- liftIO $ readIORef t
88+ key <- fromJust <$> liftIO (readIORef t)
88 fireEvents [key :=> Identity (42 :: Int)])
89 fireEvents [key :=> Identity (42 :: Int)])
89 , withSetupWHNF "hold" newEventWithTriggerRef $ \(ev, _) -> hold (42 :: Int) ev
90 , withSetupWHNF "hold" newEventWithTriggerRef $ \(ev, _) -> hold (42 :: Int) ev
90 , withSetupWHNF "sample" (newEventWithTriggerRef >>= hold (42 :: Int) . fst) sample
91 , withSetupWHNF "sample" (newEventWithTriggerRef >>= hold (42 :: Int) . fst) sample
91 ]
92 ]
92
93
93setupMerge :: Int
94setupMerge :: Int
94− -> SpiderHost Global ( Event (SpiderEnv Global) (DMap (Const2 Int a) Identity)
95+ -> SpiderHost Global ( Event (SpiderTimeline Global) (DMap (Const2 Int a) Identity)
95 , [IORef (Maybe (EventTrigger Spider a))]
96 , [IORef (Maybe (EventTrigger Spider a))]
96 )
97 )
97setupMerge num = do
98setupMerge num = do
@@ -99,11 +100,11 @@ setupMerge num = do
99 let !m = DMap.fromList [Const2 i :=> v | (i,v) <- zip [0..] evs]
100 let !m = DMap.fromList [Const2 i :=> v | (i,v) <- zip [0..] evs]
100 pure (merge m, triggers)
101 pure (merge m, triggers)
101
102
102−subscribePair :: (Event (SpiderEnv Global) a, b) -> SpiderHost Global (EventHandle (SpiderEnv Global) a, b)
103+subscribePair :: (Event (SpiderTimeline Global) a, b) -> SpiderHost Global (EventHandle (SpiderTimeline Global) a, b)
103subscribePair (ev, b) = (,b) <$> subscribeEvent ev
104subscribePair (ev, b) = (,b) <$> subscribeEvent ev
104
105
105−fireAndRead :: IORef (Maybe (EventTrigger (SpiderEnv Global) a)) -> a -> EventHandle (SpiderEnv Global) b
106+fireAndRead :: IORef (Maybe (EventTrigger (SpiderTimeline Global) a)) -> a -> EventHandle (SpiderTimeline Global) b
106 -> SpiderHost Global (Maybe b)
107 -> SpiderHost Global (Maybe b)
107fireAndRead trigger val subd = do
108fireAndRead trigger val subd = do
108− Just key <- liftIO $ readIORef trigger
109+ key <- fromJust <$> liftIO (readIORef trigger)
109 fireEventsAndRead [key :=> Identity val] $ readEvent subd >>= sequence
110 fireEventsAndRead [key :=> Identity val] $ readEvent subd >>= sequence
bench/RunAll.hs+1−1
@@ -136,7 +136,7 @@ benchmarks = implGroup "spider" runSpiderHost cases
136pattern RunTestCaseFlag = "--run-test-case"
136pattern RunTestCaseFlag = "--run-test-case"
137
137
138spawnBenchmark :: String -> Benchmark
138spawnBenchmark :: String -> Benchmark
139−spawnBenchmark name = Benchmark name $ Benchmarkable $ \n -> do
139+spawnBenchmark name = bench name . toBenchmarkable $ \n -> do
140 self <- getExecutablePath
140 self <- getExecutablePath
141 callProcess self [RunTestCaseFlag, name, show n, "+RTS", "-N1"]
141 callProcess self [RunTestCaseFlag, name, show n, "+RTS", "-N1"]
142
142
reflex.cabal+14−3
@@ -303,20 +303,27 @@ test-suite rootCleanup
303
303
304benchmark spider-bench
304benchmark spider-bench
305 type: exitcode-stdio-1.0
305 type: exitcode-stdio-1.0
306− hs-source-dirs: bench
306+ hs-source-dirs: bench test
307 main-is: Main.hs
307 main-is: Main.hs
308 ghc-options: -Wall -O2 -rtsopts
308 ghc-options: -Wall -O2 -rtsopts
309 build-depends:
309 build-depends:
310 base,
310 base,
311+ containers,
311− criterion == 1.1.*,
312+ criterion >= 1.1 && < 1.6,
312 deepseq >= 1.3 && < 1.5,
313 deepseq >= 1.3 && < 1.5,
313 dependent-map,
314 dependent-map,
314 dependent-sum,
315 dependent-sum,
316+ ref-tf,
315 mtl,
317 mtl,
316 primitive,
318 primitive,
317 reflex,
319 reflex,
320+ split,
318 stm,
321 stm,
319 transformers >= 0.3
322 transformers >= 0.3
323+ other-modules:
324+ Reflex.TestPlan
325+ Reflex.Plan.Reflex
326+ Reflex.Bench.Focused
320
327
321benchmark saulzar-bench
328benchmark saulzar-bench
322 type: exitcode-stdio-1.0
329 type: exitcode-stdio-1.0
@@ -327,7 +334,7 @@ benchmark saulzar-bench
327 build-depends:
334 build-depends:
328 base,
335 base,
329 containers >= 0.5 && < 0.7,
336 containers >= 0.5 && < 0.7,
330− criterion == 1.1.*,
337+ criterion >= 1.1 && < 1.6,
331 deepseq >= 1.3 && < 1.5,
338 deepseq >= 1.3 && < 1.5,
332 dependent-map,
339 dependent-map,
333 dependent-sum,
340 dependent-sum,
@@ -341,6 +348,10 @@ benchmark saulzar-bench
341 stm,
348 stm,
342 time,
349 time,
343 transformers >= 0.3
350 transformers >= 0.3
351+ other-modules:
352+ Reflex.TestPlan
353+ Reflex.Plan.Reflex
354+ Reflex.Bench.Focused
344
355
345source-repository head
356source-repository head
346 type: git
357 type: git