#13851: Change in specialisation(?) behaviour since 8.0.2 causes 6x slowdown -------------------------------------+------------------------------------- Reporter: mpickering | Owner: (none) Type: bug | Status: new Priority: normal | Milestone: Component: Compiler | Version: 8.2.1-rc2 Resolution: | Keywords: Operating System: Unknown/Multiple | Architecture: | Unknown/Multiple Type of failure: None/Unknown | Test Case: Blocked By: | Blocking: Related Tickets: | Differential Rev(s): Wiki Page: | -------------------------------------+------------------------------------- Comment (by RyanGlScott): Here's a version with no dependencies: {{{#!hs {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} module Main (main) where -- | Benchmarks for various effect system implementations -- import Criterion.Main import Data.Bits import Data.Int import Data.IORef import Data.Ratio import Data.Time ( getCurrentTime, utctDayTime ) import Control.Exception import Control.Monad import Control.Monad.Trans.Class import qualified Control.Monad.Trans.State.Strict as S import Control.Monad.Trans.Reader import System.CPUTime ( getCPUTime ) import System.IO.Unsafe -- Use only state, lift variable number of effects over/under -------------------------------------------------------------------------------- test1mtl :: MonadState Int m => Int -> m Int test1mtl n = foldM f 1 [0..n] where f acc x | x `rem` 5 == 0 = do s <- get put $! (s + 1) pure $! max acc x | otherwise = pure $! max acc x main = do -- Used to definitively disable bench argument inlining -- !n <- randomRIO (1000000, 1000000) :: IO Int !m <- randomRIO (0, 0) :: IO Int let runRT = (`runReaderT` (m :: Int)) let runS = (`S.runState` (m :: Int)) replicateM_ 100 $ do !n <- randomRIO (1000000, 1000000) :: IO Int evaluate $ (runS . runRT . test1mtl) n replicateM_ 100 $ do !n <- randomRIO (1000000, 1000000) :: IO Int evaluate $ (runS . runRT . test1mtl) n replicateM_ 100 $ do !n <- randomRIO (1000000, 1000000) :: IO Int evaluate $ (runS . runRT . runRT . test1mtl) n ----- -- Auxiliary ---- class Monad m => MonadState s m | m -> s where get :: m s get = state (\s -> (s, s)) put :: s -> m () put s = state (\_ -> ((), s)) state :: (s -> (a, s)) -> m a state f = do s <- get let ~(a, s') = f s put s' return a {-# MINIMAL state | get, put #-} instance MonadState s m => MonadState s (ReaderT r m) where get = lift get put = lift . put state = lift . state instance Monad m => MonadState s (S.StateT s m) where get = S.get put = S.put state = S.state class Random a where randomR :: RandomGen g => (a,a) -> g -> (a,g) -- random :: RandomGen g => g -> (a, g) randomRIO :: (a,a) -> IO a randomRIO range = getStdRandom (randomR range) instance Random Int where randomR = randomIvalIntegral -- ; random = randomBounded randomIvalIntegral :: (RandomGen g, Integral a) => (a, a) -> g -> (a, g) randomIvalIntegral (l,h) = randomIvalInteger (toInteger l, toInteger h) {-# SPECIALIZE randomIvalInteger :: (Num a) => (Integer, Integer) -> StdGen -> (a, StdGen) #-} randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g) randomIvalInteger (l,h) rng | l > h = randomIvalInteger (h,l) rng | otherwise = case (f 1 0 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng') where (genlo, genhi) = genRange rng b = fromIntegral genhi - fromIntegral genlo + 1 q = 1000 k = h - l + 1 magtgt = k * q f mag v g | mag >= magtgt = (v, g) | otherwise = v' `seq`f (mag*b) v' g' where (x,g') = next g v' = (v * b + (fromIntegral x - fromIntegral genlo)) class RandomGen g where next :: g -> (Int, g) genRange :: g -> (Int,Int) genRange _ = (minBound, maxBound) data StdGen = StdGen !Int32 !Int32 instance RandomGen StdGen where next = stdNext genRange _ = stdRange stdRange :: (Int,Int) stdRange = (1, 2147483562) stdNext :: StdGen -> (Int, StdGen) stdNext (StdGen s1 s2) = (fromIntegral z', StdGen s1'' s2'') where z' = if z < 1 then z + 2147483562 else z z = s1'' - s2'' k = s1 `quot` 53668 s1' = 40014 * (s1 - k * 53668) - k * 12211 s1'' = if s1' < 0 then s1' + 2147483563 else s1' k' = s2 `quot` 52774 s2' = 40692 * (s2 - k' * 52774) - k' * 3791 s2'' = if s2' < 0 then s2' + 2147483399 else s2' getStdRandom :: (StdGen -> (a,StdGen)) -> IO a getStdRandom f = atomicModifyIORef' theStdGen (swap . f) where swap (v,g) = (g,v) theStdGen :: IORef StdGen theStdGen = unsafePerformIO $ do rng <- mkStdRNG 0 newIORef rng mkStdRNG :: Integer -> IO StdGen mkStdRNG o = do ct <- getCPUTime (sec, psec) <- getTime return (createStdGen (sec * 12345 + psec + ct + o)) createStdGen :: Integer -> StdGen createStdGen s = mkStdGen32 $ fromIntegral s mkStdGen32 :: Int32 -> StdGen mkStdGen32 sMaybeNegative = StdGen (s1+1) (s2+1) where s = sMaybeNegative .&. maxBound (q, s1) = s `divMod` 2147483562 s2 = q `mod` 2147483398 getTime :: IO (Integer, Integer) getTime = do utc <- getCurrentTime let daytime = toRational $ utctDayTime utc return $ quotRem (numerator daytime) (denominator daytime) }}} {{{ $ /opt/ghc/8.0.2/bin/ghc MultiBench2.hs -O2 -fforce-recomp [1 of 1] Compiling Main ( MultiBench2.hs, MultiBench2.o ) Linking MultiBench2 ... $ time ./MultiBench2 real 0m2.954s user 0m2.952s sys 0m0.000s $ /opt/ghc/8.2.1/bin/ghc MultiBench2.hs -O2 -fforce-recomp [1 of 1] Compiling Main ( MultiBench2.hs, MultiBench2.o ) Linking MultiBench2 ... $ time ./MultiBench2 real 0m12.335s user 0m12.292s sys 0m0.048s }}} -- Ticket URL: http://ghc.haskell.org/trac/ghc/ticket/13851#comment:2 GHC http://www.haskell.org/ghc/ The Glasgow Haskell Compiler