Fix benchmarks to work on modern GHC.

Author: davean

bench-cbits/checkCapability.c

@@ -42,7 +42,7 @@ typedef struct Task_ {
     // or just continue immediately.  It's a workaround for the fact
     // that signalling a condition variable doesn't do anything if the
     // thread is already running, but we want it to be sticky.
-    rtsBool wakeup;
+    bool wakeup;
 #endif
 
     // This points to the Capability that the Task "belongs" to.  If
@@ -62,14 +62,14 @@ typedef struct Task_ {
     // The current top-of-stack InCall
     struct InCall_ *incall;
 
-    nat n_spare_incalls;
+    uint32_t n_spare_incalls;
     struct InCall_ *spare_incalls;
 
-    rtsBool    worker;          // == rtsTrue if this is a worker Task
-    rtsBool    stopped;         // this task has stopped or exited Haskell
+    bool    worker;          // == rtsTrue if this is a worker Task
+    bool    stopped;         // this task has stopped or exited Haskell
 
     // So that we can detect when a finalizer illegally calls back into Haskell
-    rtsBool running_finalizers;
+    bool running_finalizers;
 
     // Links tasks on the returning_tasks queue of a Capability, and
     // on spare_workers.
@@ -88,7 +88,7 @@ struct Capability_ {
     StgFunTable f;
     StgRegTable r;
 
-    nat no;  // capability number.
+    uint32_t no;  // capability number.
 
     // The Task currently holding this Capability.  This task has
     // exclusive access to the contents of this Capability (apart from
@@ -98,12 +98,12 @@ struct Capability_ {
 
     // true if this Capability is running Haskell code, used for
     // catching unsafe call-ins.
-    rtsBool in_haskell;
+    bool in_haskell;
 
     // Has there been any activity on this Capability since the last GC?
-    nat idle;
+    uint32_t idle;
 
-    rtsBool disabled;
+    bool disabled;
 
     // The run queue.  The Task owning this Capability has exclusive
     // access to its run queue, so can wake up threads without
@@ -159,7 +159,7 @@ struct Capability_ {
 #if defined(THREADED_RTS)
     // Worker Tasks waiting in the wings.  Singly-linked.
     Task *spare_workers;
-    nat n_spare_workers; // count of above
+    uint32_t n_spare_workers; // count of above
 
     // This lock protects:
     //    running_task
@@ -192,10 +192,9 @@ struct Capability_ {
 
     // Per-capability STM-related data
     StgTVarWatchQueue *free_tvar_watch_queues;
-    StgInvariantCheckQueue *free_invariant_check_queues;
     StgTRecChunk *free_trec_chunks;
     StgTRecHeader *free_trec_headers;
-    nat transaction_tokens;
+    uint32_t transaction_tokens;
 } // typedef Capability is defined in RtsAPI.h
   // We never want a Capability to overlap a cache line with anything
   // else, so round it up to a cache line size:

bench/Main.hs

@@ -20,6 +20,7 @@ import qualified Data.Dependent.Map as DMap
 import Data.Dependent.Sum
 import Data.Functor.Misc
 import Data.IORef
+import Data.Maybe (fromJust)
 import Reflex
 import Reflex.Host.Class
 
@@ -70,7 +71,7 @@ micros =
   , withSetupWHNF "fireEventsOnly"
     (newEventWithTriggerRef >>= subscribePair)
     (\(_, trigger) -> do
-        Just key <- liftIO $ readIORef trigger
+        key <- fromJust <$> liftIO (readIORef trigger)
         fireEvents [key :=> Identity (42 :: Int)])
   , withSetupWHNF "fireEventsAndRead(head/merge1)"
     (setupMerge 1 >>= subscribePair)
@@ -84,26 +85,26 @@ micros =
   , withSetupWHNF "fireEventsOnly(head/merge100)"
     (setupMerge 100 >>= subscribePair)
     (\(_, t:_) -> do
-        Just key <- liftIO $ readIORef t
+        key <- fromJust <$> liftIO (readIORef t)
         fireEvents [key :=> Identity (42 :: Int)])
   , withSetupWHNF "hold" newEventWithTriggerRef $ \(ev, _) -> hold (42 :: Int) ev
   , withSetupWHNF "sample" (newEventWithTriggerRef >>= hold (42 :: Int) . fst) sample
   ]
 
 setupMerge :: Int
-           -> SpiderHost Global ( Event (SpiderEnv Global) (DMap (Const2 Int a) Identity)
+           -> SpiderHost Global ( Event (SpiderTimeline Global) (DMap (Const2 Int a) Identity)
                                 , [IORef (Maybe (EventTrigger Spider a))]
                                 )
 setupMerge num = do
   (evs, triggers) <- unzip <$> replicateM num newEventWithTriggerRef
   let !m = DMap.fromList [Const2 i :=> v | (i,v) <- zip [0..] evs]
   pure (merge m, triggers)
 
-subscribePair :: (Event (SpiderEnv Global) a, b) -> SpiderHost Global (EventHandle (SpiderEnv Global) a, b)
+subscribePair :: (Event (SpiderTimeline Global) a, b) -> SpiderHost Global (EventHandle (SpiderTimeline Global) a, b)
 subscribePair (ev, b) = (,b) <$> subscribeEvent ev
 
-fireAndRead :: IORef (Maybe (EventTrigger (SpiderEnv Global) a)) -> a -> EventHandle (SpiderEnv Global) b
+fireAndRead :: IORef (Maybe (EventTrigger (SpiderTimeline Global) a)) -> a -> EventHandle (SpiderTimeline Global) b
             -> SpiderHost Global (Maybe b)
 fireAndRead trigger val subd = do
-  Just key <- liftIO $ readIORef trigger
+  key <- fromJust <$> liftIO (readIORef trigger)
   fireEventsAndRead [key :=> Identity val] $ readEvent subd >>= sequence

bench/RunAll.hs

@@ -136,7 +136,7 @@ benchmarks = implGroup "spider" runSpiderHost cases
 pattern RunTestCaseFlag = "--run-test-case"
 
 spawnBenchmark :: String -> Benchmark
-spawnBenchmark name = Benchmark name $ Benchmarkable $ \n -> do
+spawnBenchmark name = bench name . toBenchmarkable $ \n -> do
   self <- getExecutablePath
   callProcess self [RunTestCaseFlag, name, show n, "+RTS", "-N1"]
 

reflex.cabal

@@ -303,20 +303,27 @@ test-suite rootCleanup
 
 benchmark spider-bench
   type: exitcode-stdio-1.0
-  hs-source-dirs: bench
+  hs-source-dirs: bench test
   main-is: Main.hs
   ghc-options: -Wall -O2 -rtsopts
   build-depends:
     base,
-    criterion == 1.1.*,
+    containers,
+    criterion >= 1.1 && < 1.6,
     deepseq >= 1.3 && < 1.5,
     dependent-map,
     dependent-sum,
+    ref-tf,
     mtl,
     primitive,
     reflex,
+    split,
     stm,
     transformers >= 0.3
+  other-modules:
+    Reflex.TestPlan
+    Reflex.Plan.Reflex
+    Reflex.Bench.Focused
 
 benchmark saulzar-bench
   type: exitcode-stdio-1.0
@@ -327,7 +334,7 @@ benchmark saulzar-bench
   build-depends:
     base,
     containers >= 0.5 && < 0.7,
-    criterion == 1.1.*,
+    criterion >= 1.1 && < 1.6,
     deepseq >= 1.3 && < 1.5,
     dependent-map,
     dependent-sum,
@@ -341,6 +348,10 @@ benchmark saulzar-bench
     stm,
     time,
     transformers >= 0.3
+  other-modules:
+    Reflex.TestPlan
+    Reflex.Plan.Reflex
+    Reflex.Bench.Focused
 
 source-repository head
   type: git