[GHC] #15519: Minor code refactoring leads to drastic performance degradation

[GHC]

#15519: Minor code refactoring leads to drastic performance degradation
-------------------------------------+-------------------------------------
           Reporter:  danilo2        |             Owner:  (none)
               Type:  bug            |            Status:  new
           Priority:  high           |         Milestone:  8.6.1
          Component:  Compiler       |           Version:  8.4.3
           Keywords:                 |  Operating System:  Unknown/Multiple
       Architecture:                 |   Type of failure:  None/Unknown
  Unknown/Multiple                   |
          Test Case:                 |        Blocked By:
           Blocking:                 |   Related Tickets:
Differential Rev(s):                 |         Wiki Page:
-------------------------------------+-------------------------------------
 Hi!
 I've just observed an important performance problem. This code:

 {{{
 test0 :: Text -> Result
 test0 src = let
     s1 = token 't'
     s2 = token 'e'
     s3 = token 's'
     s4 = token 't'
     p  = many $! s1 <> s2 <> s3 <> s4
     in runTokenParser p src
 {-# NOINLINE test0 #-}
 }}}

 runs over 10 times faster than this one:

 {{{
 testGrammar1 :: Grammar Char
 testGrammar1 = let
     s1 = token 't'
     s2 = token 'e'
     s3 = token 's'
     s4 = token 't'
     in many $! s1 <> s2 <> s3 <> s4
 {-# INLINE testGrammar1 #-}

 test1 :: Text -> Result
 test1 = runTokenParser testGrammar1
 {-# NOINLINE test1 #-}
 }}}

 I've also observed another thing here, namely the former code runs also
 over 10 times faster than this code:

 {{{
 test2 :: Text -> Result
 test2 src = let
     s1 = token 't'
     s2 = token 'e'
     s3 = token 's'
     s4 = token 't'
     p  = X $! many $! s1 <> s2 <> s3 <> s4
     in runTokenParser p src
 {-# NOINLINE test2 #-}
 }}}

 The only difference here is the `X` wrapper, while the `runTokenParser` is
 defined as `runTokenParser (X !a) = runTokenParser a`.

 I've created sample project for it here: https://github.com/wdanilo/ghc-
 bug-peg-optimization/blob/master/src/Main.hs

 In order to run it execute `stack build --exec test`.

 The results are:

 {{{
 benchmarking test0
 time                 420.0 μs   (417.6 μs .. 422.9 μs)
                      1.000 R²   (0.999 R² .. 1.000 R²)
 mean                 421.0 μs   (419.2 μs .. 425.3 μs)
 std dev              9.286 μs   (4.239 μs .. 15.30 μs)
 variance introduced by outliers: 14% (moderately inflated)

 benchmarking test1
 time                 6.069 ms   (6.022 ms .. 6.123 ms)
                      0.999 R²   (0.998 R² .. 1.000 R²)
 mean                 6.065 ms   (6.037 ms .. 6.117 ms)
 std dev              114.5 μs   (74.30 μs .. 183.4 μs)

 benchmarking test2
 time                 6.070 ms   (6.007 ms .. 6.137 ms)
                      0.999 R²   (0.998 R² .. 1.000 R²)
 mean                 6.067 ms   (6.039 ms .. 6.129 ms)
 std dev              123.0 μs   (63.88 μs .. 220.1 μs)

 benchmarking native
 time                 428.0 μs   (421.5 μs .. 437.4 μs)
                      0.998 R²   (0.995 R² .. 1.000 R²)
 mean                 427.1 μs   (424.1 μs .. 434.7 μs)
 std dev              15.18 μs   (5.678 μs .. 26.26 μs)
 variance introduced by outliers: 29% (moderately inflated)
 }}}

 Where "native" is just standard `Text.takeWhile ...`.

-- 
Ticket URL: <http://ghc.haskell.org/trac/ghc/ticket/15519>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler