io-sim-1.4.0.0: bench/Main.hs

{-# LANGUAGE ScopedTypeVariables #-}

module Main (main) where

import Control.Concurrent.Class.MonadSTM
import Control.Monad (forever, replicateM)
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadFork
import Control.Monad.Class.MonadSay
import Control.Monad.Class.MonadTimer
import Control.Monad.IOSim

import Criterion
import Criterion.Main

import Control.Exception (AsyncException (..))
import Data.Foldable (traverse_)


--
-- timers, delays, timeouts
--

prop_threadDelay :: forall m. MonadDelay m => m ()
prop_threadDelay = threadDelay 1

prop_registerDelay :: forall m. MonadTimer m => m ()
prop_registerDelay = registerDelay 1 >>= \v -> atomically (readTVar v >>= check)

prop_timeout_fail :: forall m. MonadTimer m => m (Maybe ())
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
--

prop_threads :: forall m. (MonadFork m, MonadDelay m, MonadSay m) => Int -> m ()
prop_threads n = do
    threads <- replicateM n (forkIO $ threadDelay 2
                                   >> say ""
                            )
    threadDelay 1
    traverse_ (\tid -> throwTo tid ThreadKilled) threads


prop_async :: forall m. (MonadAsync m, MonadDelay m, MonadSay m) => Int -> m ()
prop_async n = do
    threads <- replicateM n (async $ threadDelay 1
                                  >> say ""
                            )
    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
    [ env (pure ()) $ \_ ->
      bgroup "delays"
      [ bench "threadDelay" $
        whnf id (runSimOrThrow prop_threadDelay)
      , bench "registerDelay" $
        whnf id (runSimOrThrow prop_registerDelay)
      , bgroup "timeout"
        [ bench "fail" $
          whnf id (runSimOrThrow prop_timeout_fail)
        , bench "succeed" $
          whnf id (runSimOrThrow prop_timeout_succeed)
        , bench "race" $
          whnf id (runSimOrThrow prop_timeout_race)
        ]
      ]
    ,
      bgroup "threads"
      [ env (pure 50) $ \n ->
        bgroup "50"
        [ bench "async silent" $
          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
                $ prop_async n)
        , bench "forkIO say" $
          nf id ( selectTraceEventsSay
                $ runSimTrace
                $ prop_threads n)
        , bench "threadDelay bottleneck say" $
          nf id ( selectTraceEventsSay
                $ runSimTrace
                $ prop_threadDelay_bottleneck)
        ]
      , env (pure 250) $ \n ->
        bgroup "250"
        [ bench "async" $
          whnf id (runSimOrThrow (prop_async n))
        , bench "forkIO" $
          whnf id (runSimOrThrow (prop_threads n))
        ]
      ]
    ]