[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:  JoinPoints
Operating System:  Unknown/Multiple  |         Architecture:
 Type of failure:  Runtime           |  Unknown/Multiple
  performance bug                    |            Test Case:
      Blocked By:                    |             Blocking:
 Related Tickets:  #14620            |  Differential Rev(s):
       Wiki Page:                    |
-------------------------------------+-------------------------------------

Comment (by nomeata):

 Here is a contrived example. This code:
 {{{
 {-# LANGUAGE KindSignatures, DataKinds, GADTs, TypeFamilies #-}
 module RecCast (foo) where

 import Data.Coerce

 data Nat = Z | S Nat

 data Sing (n :: Nat) where
     FZ :: Sing Z
     FS :: Sing n -> Sing (S n)

 -- The NoConst to avoid worker-wrapper
 data Const (y::Nat) = Const Nat | NoConst

 mapConst :: (Nat -> Nat) -> Const n -> Const n
 mapConst f (Const x) = Const (f x)
 mapConst f NoConst = NoConst
 {-# NOINLINE mapConst #-}

 inc :: Const n -> Const (S n)
 inc = coerce

 type family Plus n m :: Nat where
     Plus Z m = m
     Plus (S n) m = S (Plus n m)

 foo :: Sing n -> Const m -> Const (Plus n m)
 foo FZ c = c
 foo (FS n) c = inc (foo n (mapConst S c))
 }}}
 produces this function that would be a join point when we consider casted
 expressions as tail-recursive:
 {{{
 Rec {
 -- RHS size: {terms: 14, types: 25, coercions: 18, joins: 0/0}
 foo [Occ=LoopBreaker]
   :: forall (n :: Nat) (m :: Nat).
      Sing n -> Const m -> Const (Plus n m)
 [GblId, Arity=2, Caf=NoCafRefs, Str=<S,1*U><S,1*U>]
 foo
   = \ (@ (n_asO :: Nat))
       (@ (m_asP :: Nat))
       (ds_dXH :: Sing n_asO)
       (c_aqe :: Const m_asP) ->
       case ds_dXH of {
         FZ cobox_asR [Dmd=<L,A>] ->
           c_aqe
           `cast` ((Const <m, Plus n m>)_R
                   :: (Const m_asP :: *) ~R# (Const (Plus n_asO m_asP) ::
 *));
         FS @ n1_asU cobox_asV [Dmd=<L,A>] n2_aqf ->
           (foo @ n1_asU @ m_asP n2_aqf (mapConst_rnA @ m_asP S c_aqe))
           `cast` ((Const <Plus n1 m, Plus n m>)_R
                   :: (Const (Plus n1_asU m_asP) :: *)
                      ~R#
                      (Const (Plus n_asO m_asP) :: *))
       }
 end Rec }
 }}}

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