Opened 2 years ago

Last modified 2 years ago

#13993 new bug

Certain inter-module specializations run out of simplifier ticks

Reported by: dfeuer Owned by:
Priority: high Milestone: 8.4.1
Component: Compiler Version: 8.0.1
Keywords: Cc: michalt
Operating System: Unknown/Multiple Architecture: Unknown/Multiple
Type of failure: Compile-time performance bug Test Case:
Blocked By: Blocking:
Related Tickets: #9630 Differential Rev(s):
Wiki Page:

Description

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.

module GenSpec where

import Gen
import GHC.Generics

-- Trigger specialization
tput :: T -> Put
tput = gput . from
{-# 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

Change History (1)

comment:1 Changed 2 years ago by michalt

Cc: michalt added
Note: See TracTickets for help on using tickets.