{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- {-# LANGUAGE Strict #-}
module Main where
import Prelude as P
import Criterion.Main
import Control.Monad.State.Layered hiding ((.))
import qualified Control.Monad.State.Strict as S
import Control.Monad.Codensity
import qualified Control.Monad.State.CPS as CPS
import Data.Word
import Control.Monad.Identity
import GHC.IO as X (evaluate)
import Control.DeepSeq
import System.TimeIt
import System.Environment (getArgs)
import System.IO (stdout, hSetBuffering, BufferMode(..))
import Control.Monad.Trans.Either
import Data.IORef
import Foreign.ForeignPtr
import Foreign.Storable (peek, poke)
eval :: NFData a => a -> IO a
eval = evaluate . force ; {-# INLINE eval #-}
mtlIncState :: S.MonadState Int m => m ()
mtlIncState = S.modify (1+) ; {-# INLINE mtlIncState #-}
{-# SPECIALIZE mtlIncState :: S.State Int () #-}
-- | incLoop transformation needed because of bug https://ghc.haskell.org/trac/ghc/ticket/14062
incLoop :: MonadState Int m => Int -> m Int
incLoop2 :: MonadStates '[Int, Word] m => Int -> m (Int, Word)
incLoop n = repeatM incState n >> get @Int ; {-# INLINE incLoop #-}
incLoop2 n = repeatM incState2 n >> ((,) <$> get @Int <*> get @Word) ; {-# INLINE incLoop2 #-}
incState :: MonadState Int m => m ()
incState2 :: MonadStates '[Int, Word] m => m ()
incState = modify_ @Int (1+) ; {-# INLINE incState #-}
incState2 = modify_ @Int (1+) >> modify_ @Word (1+) ; {-# INLINE incState2 #-}
repeatM :: Monad m => m a -> Int -> m ()
repeatM f = go where
go 0 = pure ()
go i = f >> go (i - 1)
{-# INLINE repeatM #-}
pureInc :: Int -> Int -> Int
pureInc !a !i = case i of
0 -> a
_ -> pureInc (a + 1) (i - 1)
pureInc2 :: Int -> Word -> Int -> (Int, Word)
pureInc2 !a !b i = case i of
0 -> (a,b)
_ -> pureInc2 (a + 1) (b + 1) (i - 1)
iorefInc :: Int -> IO Int
iorefInc !i = do
!ref <- newIORef (0 :: Int)
let go = \case
0 -> return ()
j -> modifyIORef' ref (+1) >> go (j-1)
go i
readIORef ref
{-# INLINE iorefInc #-}
fpInc :: Int -> IO ()
fpInc !i = do
!(ptr :: ForeignPtr Int) <- mallocForeignPtr
let go = \case
0 -> return ()
j -> do
withForeignPtr ptr $ \ !p -> do
val <- peek p
poke p (val + 1)
go (j - 1)
go i
{-# INLINE fpInc #-}
sInt :: Functor m => StateT Int m a -> m a
sWrd :: Functor m => StateT Word m a -> m a
sStr :: Functor m => StateT String m a -> m a
sChr :: Functor m => StateT Char m a -> m a
sTup :: Functor m => StateT () m a -> m a
sInt = flip (evalStateT @Int) 0 ; {-# INLINE sInt #-}
sWrd = flip (evalStateT @Word) 0 ; {-# INLINE sWrd #-}
sStr = flip (evalStateT @String) "" ; {-# INLINE sStr #-}
sChr = flip (evalStateT @Char) 'x' ; {-# INLINE sChr #-}
sTup = flip (evalStateT @()) () ; {-# INLINE sTup #-}
t_0 :: Int -> ()
t_0 = runIdentity . sInt . repeatM incState ; {-# INLINE t_0 #-}
t_1R, t_2R, t_3R :: Int -> Int
t_1R = runIdentity . sInt . sStr . incLoop ; {-# INLINE t_1R #-}
t_2R = runIdentity . sInt . sStr . sChr . incLoop ; {-# INLINE t_2R #-}
t_3R = runIdentity . sInt . sStr . sChr . sTup . incLoop ; {-# INLINE t_3R #-}
t_1L, t_2L, t_3L :: Int -> Int
t_1L = runIdentity . sStr . sInt . incLoop ; {-# INLINE t_1L #-}
t_2L = runIdentity . sChr . sStr . sInt . incLoop ; {-# INLINE t_2L #-}
t_3L = runIdentity . sTup . sChr . sStr . sInt . incLoop ; {-# INLINE t_3L #-}
t_1R2, t_2R2, t_3R2 :: Int -> (Int,Word)
t_1R2 = runIdentity . sInt . sWrd . sStr . incLoop2 ; {-# INLINE t_1R2 #-}
t_2R2 = runIdentity . sInt . sWrd . sStr . sChr . incLoop2 ; {-# INLINE t_2R2 #-}
t_3R2 = runIdentity . sInt . sWrd . sStr . sChr . sTup . incLoop2 ; {-# INLINE t_3R2 #-}
t_1L2, t_2L2, t_3L2 :: Int -> (Int, Word)
t_1L2 = runIdentity . sStr . sInt . sWrd . incLoop2 ; {-# INLINE t_1L2 #-}
t_2L2 = runIdentity . sChr . sStr . sInt . sWrd . incLoop2 ; {-# INLINE t_2L2 #-}
t_3L2 = runIdentity . sTup . sChr . sStr . sInt . sWrd . incLoop2 ; {-# INLINE t_3L2 #-}
t_1R2E, t_2R2E, t_3R2E :: Int -> Either () (Int,Word)
t_1R2E = runIdentity . sInt . sWrd . sStr . runEitherT . incLoop2 ; {-# INLINE t_1R2E #-}
t_2R2E = runIdentity . sInt . sWrd . sStr . sChr . runEitherT . incLoop2 ; {-# INLINE t_2R2E #-}
t_3R2E = runIdentity . sInt . sWrd . sStr . sChr . sTup . runEitherT . incLoop2 ; {-# INLINE t_3R2E #-}
t_1L2E, t_2L2E, t_3L2E :: Int -> Either () (Int, Word)
t_1L2E = runIdentity . runEitherT . sStr . sInt . sWrd . incLoop2 ; {-# INLINE t_1L2E #-}
t_2L2E = runIdentity . runEitherT . sChr . sStr . sInt . sWrd . incLoop2 ; {-# INLINE t_2L2E #-}
t_3L2E = runIdentity . runEitherT . sTup . sChr . sStr . sInt . sWrd . incLoop2 ; {-# INLINE t_3L2E #-}
t_1R2Eb, t_2R2Eb, t_3R2Eb :: Int -> Either () (Int,Word)
t_1R2Eb = runIdentity . sInt . runEitherT . sWrd . sStr . incLoop2 ; {-# INLINE t_1R2Eb #-}
t_2R2Eb = runIdentity . sInt . runEitherT . sWrd . sStr . sChr . incLoop2 ; {-# INLINE t_2R2Eb #-}
t_3R2Eb = runIdentity . sInt . runEitherT . sWrd . sStr . sChr . sTup . incLoop2 ; {-# INLINE t_3R2Eb #-}
t_1L2Eb, t_2L2Eb, t_3L2Eb :: Int -> Either () (Int, Word)
t_1L2Eb = runIdentity . sStr . sInt . runEitherT . sWrd . incLoop2 ; {-# INLINE t_1L2Eb #-}
t_2L2Eb = runIdentity . sChr . sStr . sInt . runEitherT . sWrd . incLoop2 ; {-# INLINE t_2L2Eb #-}
t_3L2Eb = runIdentity . sTup . sChr . sStr . sInt . runEitherT . sWrd . incLoop2 ; {-# INLINE t_3L2Eb #-}
main :: IO ()
main = do
hSetBuffering stdout NoBuffering
-- let s = "1000000000" :: String
-- x = read s :: Int
--
-- putStrLn "Single counter loop"
-- putStr "pure " >> timeIt (eval (pureInc 0 x))
-- putStr "t_0 " >> timeIt (eval (t_0 x))
-- putStr "t_1R " >> timeIt (eval (t_1R x))
-- putStr "t_2R " >> timeIt (eval (t_2R x))
-- putStr "t_3R " >> timeIt (eval (t_3R x))
-- putStr "t_1L " >> timeIt (eval (t_1L x))
-- putStr "t_2L " >> timeIt (eval (t_2L x))
-- putStr "t_3L " >> timeIt (eval (t_3L x))
--
-- putStrLn "\nDouble counter loop"
-- putStr "pure " >> timeIt (eval (pureInc2 0 0 x))
-- putStr "t_1R2 " >> timeIt (eval (t_1R2 x))
-- putStr "t_2R2 " >> timeIt (eval (t_2R2 x))
-- putStr "t_3R2 " >> timeIt (eval (t_3R2 x))
-- putStr "t_1L2 " >> timeIt (eval (t_1L2 x))
-- putStr "t_2L2 " >> timeIt (eval (t_2L2 x))
-- putStr "t_3L2 " >> timeIt (eval (t_3L2 x))
--
-- putStrLn "\nDouble counter loop n EitherT"
-- putStr "t_1R2E " >> timeIt (eval (t_1R2E x))
-- putStr "t_2R2E " >> timeIt (eval (t_2R2E x))
-- putStr "t_3R2E " >> timeIt (eval (t_3R2E x))
-- putStr "t_1L2E " >> timeIt (eval (t_1L2E x))
-- putStr "t_2L2E " >> timeIt (eval (t_2L2E x))
-- putStr "t_3L2E " >> timeIt (eval (t_3L2E x))
let iterCount = 100000000
putStrLn "\nTesting time overhead of monad transformers"
putStrLn "IMPORTANT: These times should be THE SAME. If they are not, you've broken then implementation. Go back and fix it."
putStrLn "\n\n=== Single counter loop ===\n"
defaultMain [ bench "IORef (10e6)" $ nfIO (iorefInc iterCount)
, bench "FPtr (10e6)" $ nfIO (fpInc iterCount)
, bench "pure (10e6)" $ nf (pureInc 0) iterCount
, bench "1R trans (10e6)" $ nf t_1R iterCount
, bench "2R trans (10e6)" $ nf t_2R iterCount
, bench "3R trans (10e6)" $ nf t_3R iterCount
, bench "1L trans (10e6)" $ nf t_1L iterCount
, bench "2L trans (10e6)" $ nf t_2L iterCount
, bench "3L trans (10e6)" $ nf t_3L iterCount
]
putStrLn "\n\n=== Double counter loop ===\n"
defaultMain [ bench "pure (10e6)" $ nf (pureInc2 0 0) iterCount
, bench "1R trans (10e6)" $ nf t_1R2 iterCount
, bench "2R trans (10e6)" $ nf t_2R2 iterCount
, bench "3R trans (10e6)" $ nf t_3R2 iterCount
, bench "1L trans (10e6)" $ nf t_1L2 iterCount
, bench "2L trans (10e6)" $ nf t_2L2 iterCount
, bench "3L trans (10e6)" $ nf t_3L2 iterCount
]
putStrLn "\n\n=== Double counter loop in EitherT ===\n"
defaultMain [ bench "1R trans (10e6)" $ nf t_1R2E iterCount
, bench "2R trans (10e6)" $ nf t_2R2E iterCount
, bench "3R trans (10e6)" $ nf t_3R2E iterCount
, bench "1L trans (10e6)" $ nf t_1L2E iterCount
, bench "2L trans (10e6)" $ nf t_2L2E iterCount
, bench "3L trans (10e6)" $ nf t_3L2E iterCount
]
putStrLn "\n\n=== Double counter loop with EitherT in-between ===\n"
defaultMain [ bench "1R trans (10e6)" $ nf t_1R2Eb iterCount
, bench "2R trans (10e6)" $ nf t_2R2Eb iterCount
, bench "3R trans (10e6)" $ nf t_3R2Eb iterCount
, bench "1L trans (10e6)" $ nf t_1L2Eb iterCount
, bench "2L trans (10e6)" $ nf t_2L2Eb iterCount
, bench "3L trans (10e6)" $ nf t_3L2Eb iterCount
]