Comparing monad-par and async over two use cases: already calculated futures, and blocking I/O

gistfile1.txt

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TypeSynonymInstances       #-}
import           Control.Concurrent.Async
import           Control.DeepSeq
import           Control.Exception
import           Control.Monad
import           Control.Monad.Free.Reflectable
import           Control.Monad.IO.Class
import qualified Control.Monad.Par.Class        as Par
import           Control.Monad.Par.IO
import           Control.Parallel.Strategies
import           Criterion
import           Criterion
import           Criterion.Main
import           Data.Array as A
import           Data.Bifunctor
import Data.Functor.Identity
import           Data.Text                      (Text)
import           Network.HTTP.Client
import           Text.Printf
-- * Functor

-- Benchmarks

url = "http://192.168.1.16/?hoogle=foobar"

-- Making an http query
bench1async manager request n = do
  futs <- replicateM n $ async $ responseBody <$> (httpNoBody request manager)
  _ <- mapM wait futs
  return ()

bench1par manager request n = runParIO $ do
  futs <- replicateM n $ Par.spawn $ responseBody <$> liftIO(httpNoBody request manager)
  _ <- mapM Par.get futs
  return ()

-- use arrays instead of lists to avoid fusion (it distorts timings)
bench2pure :: NFData ix => Monad m => (forall a b . NFData b => (a->b) -> f a -> m(f b)) -> f(Array ix Int) -> m (f [Int])
bench2pure map = map (A.elems) <=< map(fmap (+100)) <=< map (fmap (*2)) <=< map (fmap (*2)) <=< map (fmap (*2)) <=< map (fmap (*2))

-- fmap an already calculated value
bench2async k = do
  fut <- async(evaluate $ A.listArray (1::Int,1000000) [1 :: Int .. 1000000])
  _ <- wait fut
  fut' <- bench2pure ((return .) . fmap ) fut
  k fut'

-- create a new future over an already calculated one
bench2async' k = do
  fut <- async (return $ A.listArray (1::Int,1000000) [1 :: Int .. 1000000])
  _ <- wait fut
  fut' <- bench2pure mapFut fut
  k fut'
 where
   mapFut f fut = async ( wait fut >>=  return . f )

bench2par :: NFData b => (IVar [Int] -> ParIO b) -> IO b
bench2par k = runParIO $ do
  fut <- Par.spawn (return $ A.listArray (1::Int,1000000) [1 :: Int .. 1000000])
  _ <- Par.get fut
  fut' <- bench2pure mapFut fut
  k fut'
 where
   mapFut :: NFData b => (a -> b) -> IVar a -> ParIO(IVar b)
   mapFut f fut = Par.get fut >>= Par.spawn . return . f

main = do
  manager <- liftIO $ newManager defaultManagerSettings
  request <- parseRequest url
  defaultMain
    [ fmapBenchGroup
    , fmapReuseBenchGroup
    , httpReqBenchGroup manager request 100
    , httpReqBenchGroup manager request 200
    -- httpReqBenchGroup manager request 300,
    -- httpReqBenchGroup manager request 500,
    -- httpReqBenchGroup manager request 800,
    -- httpReqBenchGroup manager request 1000,
    -- httpReqBenchGroup manager request 10000,
    -- httpReqBenchGroup manager request 100000
    ]
  where
    fmapBenchGroup =
      bgroup
        "map over already calc'ed future"
        [ bench "pure/fmap"  $ nf (bench2pure ((Identity.) . fmap)) $ Identity $ A.listArray (1::Int,1000000) [1 :: Int .. 1000000]
        , bench "async/fmap" $ nfIO $ (bench2async wait)
        , bench "async/spawn" $ nfIO $ (bench2async' wait)
        , bench "ivar" $ nfIO $ bench2par Par.get
        ]
    fmapReuseBenchGroup =
      bgroup
        "reuse a mapped over future"
        [ bench "async/fmap" $ nfIO (bench2async $ \fut -> replicateM 10 (wait fut))
        , bench "async/spawn" $ nfIO (bench2async' $ \fut -> replicateM 10 (wait fut))
        , bench "ivar" $ nfIO $ (bench2par $ \fut -> replicateM 10 (Par.get fut))
        ]
    httpReqBenchGroup manager request n =
      bgroup (printf "HTTP req (%d)" n)
        [ bench "async" $ whnfIO (bench1async manager request n)
        , bench "ivar" $ whnfIO (bench1par manager request n)
        ]