IOSim Timeouts API refactor and optimisation

io-classes/src/Control/Monad/Class/MonadAsync.hs

@@ -7,8 +7,6 @@
 {-# LANGUAGE QuantifiedConstraints  #-}
 {-# LANGUAGE RankNTypes             #-}
 {-# LANGUAGE ScopedTypeVariables    #-}
-{-# LANGUAGE TypeApplications       #-}
-{-# LANGUAGE TypeFamilies           #-}
 {-# LANGUAGE TypeFamilyDependencies #-}
 -- MonadAsync's ReaderT instance is undecidable.
 {-# LANGUAGE UndecidableInstances   #-}

io-classes/src/Control/Monad/Class/MonadSTM.hs

@@ -1,5 +1,15 @@
 -- | This module corresponds to `Control.Monad.STM` in "stm" package
 --
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+-- undecidable instances needed for 'WrappedSTM' instances of 'MonadThrow' and
+-- 'MonadCatch' type classes.
+{-# LANGUAGE UndecidableInstances       #-}
 module Control.Monad.Class.MonadSTM
   ( MonadSTM (STM, atomically, retry, orElse, check)
   , throwSTM

io-classes/src/Control/Monad/Class/MonadTimer.hs

@@ -54,6 +54,9 @@ class Monad m => MonadDelay m where
   threadDelay d   = void . atomically . awaitTimeout =<< newTimeout d
 
 class (MonadSTM m, MonadDelay m) => MonadTimer m where
+  -- | The type of the timeout handle, used with 'newTimeout', 'readTimeout',
+  -- 'updateTimeout' and 'cancelTimeout'.
+  --
   data Timeout m :: Type
 
   -- | Create a new timeout which will fire at the given time duration in

io-sim/bench/Main.hs

@@ -4,7 +4,7 @@
 module Main (main) where
 
 import           Control.Concurrent.Class.MonadSTM
-import           Control.Monad (replicateM)
+import           Control.Monad (replicateM, forever)
 import           Control.Monad.Class.MonadAsync
 import           Control.Monad.Class.MonadFork
 import           Control.Monad.Class.MonadSay
@@ -67,6 +67,9 @@ prop_timeout_fail = timeout 1 (threadDelay 2)
 prop_timeout_succeed :: forall m. MonadTimer m => m (Maybe ())
 prop_timeout_succeed = timeout 2 (threadDelay 1)
 
+prop_timeout_race :: forall m. MonadTimer m => m (Maybe ())
+prop_timeout_race = timeout 1 (threadDelay 1)
+
 
 --
 -- threads, async
@@ -88,6 +91,13 @@ prop_async n = do
                             )
     traverse_ wait threads
 
+prop_threadDelay_bottleneck :: forall m. (MonadTimer m, MonadSay m)
+                            => m (Maybe ())
+prop_threadDelay_bottleneck =
+  timeout 1000000 $ do
+    forever $ do
+      threadDelay 1
+      say ""
 
 main :: IO ()
 main = defaultMain
@@ -117,6 +127,8 @@ main = defaultMain
           whnf id (runSimOrThrow prop_timeout_fail)
         , bench "succeed" $
           whnf id (runSimOrThrow prop_timeout_succeed)
+        , bench "race" $
+          whnf id (runSimOrThrow prop_timeout_race)
         ]
       ]
     ,
@@ -127,6 +139,8 @@ main = defaultMain
           whnf id (runSimOrThrow (prop_async n))
         , bench "forkIO silent" $
           whnf id (runSimOrThrow (prop_threads n))
+        , bench "threadDelay bottleneck silent" $
+          whnf id (runSimOrThrow prop_threadDelay_bottleneck)
         , bench "async say" $
           nf id ( selectTraceEventsSay
                 $ runSimTrace
@@ -135,6 +149,10 @@ main = defaultMain
           nf id ( selectTraceEventsSay
                 $ runSimTrace
                 $ prop_threads n)
+        , bench "threadDelay bottleneck say" $
+          nf id ( selectTraceEventsSay
+                $ runSimTrace
+                $ prop_threadDelay_bottleneck)
         ]
       , env (pure 250) $ \n ->
         bgroup "250"

io-sim/src/Control/Monad/IOSim/CommonTypes.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
-{-# LANGUAGE StandaloneDeriving         #-}
 
 -- | Common types shared between `IOSim` and `IOSimPOR`.
 --