[GHC] #14610: newtype wrapping of a monadic stack kills performance

[GHC]

#14610: newtype wrapping of a monadic stack kills performance
-------------------------------------+-------------------------------------
        Reporter:  mrkkrp            |                Owner:  (none)
            Type:  bug               |               Status:  new
        Priority:  normal            |            Milestone:  8.6.1
       Component:  Compiler          |              Version:  8.2.2
      Resolution:                    |             Keywords:
Operating System:  Unknown/Multiple  |         Architecture:
 Type of failure:  Runtime           |  Unknown/Multiple
  performance bug                    |            Test Case:
      Blocked By:                    |             Blocking:
 Related Tickets:                    |  Differential Rev(s):
       Wiki Page:                    |
-------------------------------------+-------------------------------------

Comment (by dfeuer):

 Here's an example that doesn't quite go far enough to demonstrate the
 problem, but seems closer in spirit to the original.

 {{{#!hs
 newtype D a = D {getD :: a}
 d :: a -> D a
 d a = D a

 baz :: D Int -> Int -> D Int
 baz y x0 = foo x0
   where
     foo :: Int -> D Int
     foo 0 = y
     foo x = D (bar (x - 3))

     bar :: Int -> Int
     bar 0 = getD y
     bar x = getD (foo x)
 }}}

 Compiling with `-dverbose-core2core`, we see that after the first
 simplifier run (gentle, before floating), we get

 {{{
 baz :: D Int -> Int -> D Int
 [LclIdX,
  Arity=2,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True, Guidance=IF_ARGS [0 0] 121 0}]
 baz
   = \ (y_aSE :: D Int) (x0_aSF :: Int) ->
       letrec {
         foo_aSG [Occ=LoopBreaker] :: Int -> D Int
         [LclId,
          Arity=1,
          Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True,
                  WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 81
 0}]
         foo_aSG
           = \ (ds_d27R :: Int) ->
               case ds_d27R of { GHC.Types.I# ds_d27T ->
               case ds_d27T of ds_X289 {
                 __DEFAULT ->
                   (case ds_X289 of ds_X284 {
                      __DEFAULT ->
                        (foo_aSG (GHC.Types.I# (GHC.Prim.-# ds_X284 3#)))
                        `cast` (Foo.N:D[0] <Int>_R :: (D Int :: *) ~R# (Int
 :: *));
                      3# ->
                        y_aSE `cast` (Foo.N:D[0] <Int>_R :: (D Int :: *)
 ~R# (Int :: *))
                    })
                   `cast` (Sym (Foo.N:D[0] <Int>_R) :: (Int :: *) ~R# (D
 Int :: *));
                 0# -> y_aSE
               }
               }; } in
       foo_aSG x0_aSF
 }}}

 Note that `foo_aSG` is bound by `letrec`.

 If we switch to a type synonym version,

 {{{#!hs
 type D a = a
 getD :: D a -> a
 getD a = a

 d :: a -> D a
 d a = a

 baz :: Int -> Int -> Int
 baz y x0 = foo x0
   where
     foo :: Int -> Int
     foo 0 = y
     foo x = d (bar (x - 3))

     bar :: Int -> Int
     bar 0 = getD y
     bar x = getD (foo x)
 }}}

 then at the same point in core2core we instead see

 {{{#!hs
 baz :: Int -> Int -> Int
 [LclIdX,
  Arity=2,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True, Guidance=IF_ARGS [0 0] 59 0}]
 baz
   = \ (y_aSQ :: Int) (x0_aSR :: Int) ->
       joinrec {
         foo_aSS [Occ=LoopBreaker] :: Int -> Int
         [LclId[JoinId(1)],
          Arity=1,
          Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True,
                  WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 55
 0}]
         foo_aSS (ds_d27X :: Int)
           = case ds_d27X of { GHC.Types.I# ds_d27Z ->
             case ds_d27Z of ds_X28a {
               __DEFAULT -> jump foo_aSS (GHC.Types.I# (GHC.Prim.-# ds_X28a
 3#));
               0# -> y_aSQ;
               3# -> y_aSQ
             }
             }; } in
       jump foo_aSS x0_aSR
 }}}

 The reason this example doesn't quite go far enough is that later
 transformations work out the kinks and recognize the join point. But based
 on the bug report, that isn't always the case.

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