[GHC] #13851: Change in specialisation(?) behaviour since 8.0.2 causes 6x slowdown

[GHC]

#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