[GHC] #13993: Certain inter-module specializations run out of simplifier ticks

[GHC]

#13993: Certain inter-module specializations run out of simplifier ticks
-------------------------------------+-------------------------------------
           Reporter:  dfeuer         |             Owner:  (none)
               Type:  bug            |            Status:  new
           Priority:  high           |         Milestone:  8.4.1
          Component:  Compiler       |           Version:  8.0.1
           Keywords:                 |  Operating System:  Unknown/Multiple
       Architecture:                 |   Type of failure:  Compile-time
  Unknown/Multiple                   |  performance bug
          Test Case:                 |        Blocked By:
           Blocking:                 |   Related Tickets:  #9630
Differential Rev(s):                 |         Wiki Page:
-------------------------------------+-------------------------------------
 A modification of ezyang's test case in #9630 yields the below. Triggering
 specialization in a separate module can run the simplifier out of ticks.
 Notably, moving the definition of `T` into `GenSpec` resolves the problem.
 Unlike #9630 proper, this seems to cause trouble going back as far as GHC
 7.4.

 {{{#!hs
 module GenSpec where

 import Gen
 import GHC.Generics

 -- Trigger specialization
 tput :: T -> Put
 tput = gput . from
 }}}

 {{{#!hs
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE TypeOperators #-}
 {-# OPTIONS_GHC -fno-warn-missing-methods #-}
 module Gen where

 import GHC.Generics
 import Control.Monad
 import Control.Applicative
 import Data.Monoid

 data PairS a = PairS a !(() -> ())

 newtype PutM a = Put { unPut :: PairS a }

 -- Use of this writer monad seems to be important; IO speeds it up
 type Put = PutM ()
 --type Put = IO ()

 -- binary has INLINE pragmas on most of the instances but you can still
 -- trigger bad behavior without them.
 instance Functor PutM where
         fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w

 -- Just to appease AMP
 instance Applicative PutM where
         pure  = return
         (<*>) = ap

 instance Monad PutM where
     return a = Put $ PairS a id

     m >>= k  = Put $
         let PairS a w  = unPut m
             PairS b w' = unPut (k a)
         in PairS b (w . w')

 class GBinary f where
     gput :: f t -> Put
     -- Forcing the dictionary to have two elements hurts
     -- the optimizer a lot.
     not_used :: f t

 instance GBinary a => GBinary (M1 i c a) where
     gput = gput . unM1

 instance Binary a => GBinary (K1 i a) where
     gput = put . unK1

 instance (GBinary a, GBinary b) => GBinary (a :*: b) where
     gput (x :*: y) = gput x >> gput y

 class Binary t where
     put :: t -> Put

 instance Binary () where
     put () = return ()

 data T = T () () () () () () () () () () () ()
            () () () () () () () () () ()
            () () () () () () () () () ()
            () () () () () () () () () ()
            () () () () () () () () () ()
            () () () () () () () () () ()
            () () () () () () () () () ()
            () () () () () () () () () ()
            () () () () () () () () () ()
            () () () () () () () () () ()
            () () () () () () () () () ()
            () () () () () () () () () ()
            () () () () () () () () () ()
            () () () () () () () () () ()
            () () () () () () () () () ()
            () () () () () () () () () ()
            () () () () () () () () () ()
            () () () () () () () () () ()
            () () () () () () () () () ()
     deriving Generic
 }}}

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