Re: [GHC] #13536: Program which terminates instantly in GHC 8.0.2 runs for minutes with 8.2.1

6 Apr 2017

      #13536: Program which terminates instantly in GHC 8.0.2 runs for minutes with 8.2.1
-------------------------------------+-------------------------------------
        Reporter:  RyanGlScott       |                Owner:  (none)
            Type:  bug               |               Status:  new
        Priority:  highest           |            Milestone:  8.2.1
       Component:  Compiler          |              Version:  8.1
      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 RyanGlScott):

 Here's a version with no dependencies:

 {{{#!hs
 {-# LANGUAGE TypeFamilies #-}
 module Main where

 import Control.Monad (ap, liftM, liftM2, liftM3, replicateM)
 import Data.Int (Int32)

 main :: IO ()
 main = do
   let stdGen = StdGen 1523085842 1207612140
       qcGen = QCGen stdGen
       (f, (i, b), v) = case arbitrary of
                          MkGen g -> g qcGen 30
   print $ foldlTest f (i, b) v

 type FoldlTest a = (a -> a -> a) -> a -> [a] -> Bool

 foldlTest :: FoldlTest (Bool, Bool)
 foldlTest f (i, b) v =
   foldl f (i, b) v == foldl (\x -> f (unmodel x)) (i, b) v

 class TestData a where
   type Model a
   unmodel :: Model a -> a

 instance TestData Bool where
   type Model Bool = Bool
   unmodel = id

 instance (Eq a, Eq b, TestData a, TestData b) => TestData (a,b) where
   type Model (a,b) = (Model a, Model b)
   unmodel (a,b) = (unmodel a, unmodel b)

 -------------------------------------------------------------------------------
 -- random stuff

 data StdGen
  = StdGen !Int32 !Int32

 stdNext :: StdGen -> (Int, StdGen)
 stdNext (StdGen s1 s2) = (fromIntegral z', StdGen s1'' s2'')
     where
         z'   = if z < 1 then z + 2147483562 else z
         z    = s1'' - s2''

         k    = s1 `quot` 53668
         s1'  = 40014 * (s1 - k * 53668) - k * 12211
         s1'' = if s1' < 0 then s1' + 2147483563 else s1'

         k'   = s2 `quot` 52774
         s2'  = 40692 * (s2 - k' * 52774) - k' * 3791
         s2'' = if s2' < 0 then s2' + 2147483399 else s2'

 stdRange :: StdGen -> (Int,Int)
 stdRange _ = (1, 2147483562)

 stdSplit :: StdGen -> (StdGen, StdGen)
 stdSplit std@(StdGen s1 s2)
                      = (left, right)
                        where
                         left    = StdGen new_s1 t2
                         right   = StdGen t1 new_s2

                         new_s1 | s1 == 2147483562 = 1
                                | otherwise        = s1 + 1

                         new_s2 | s2 == 1          = 2147483398
                                | otherwise        = s2 - 1

                         StdGen t1 t2 = snd (stdNext std)

 -------------------------------------------------------------------------------
 -- QuickCheck

 newtype QCGen = QCGen StdGen

 newtype Gen a = MkGen{
   unGen :: QCGen -> Int -> a
   }

 variant :: Integral n => n -> Gen a -> Gen a
 variant k (MkGen g) = MkGen (\r n -> g (variantQCGen k r) n)

 bigNatVariant :: Integer -> StdGen -> StdGen
 bigNatVariant n g
   | g `seq` stop n = chip True (fromInteger n) g
   | otherwise      = (bigNatVariant $! chop n) $! chip False (fromInteger
 n) g

 {-# INLINE natVariant #-}
 natVariant :: Integral a => a -> StdGen -> StdGen
 natVariant n g
   | g `seq` stop n = chip True (fromIntegral n) g
   | otherwise      = bigNatVariant (toInteger n) g

 {-# INLINE variantTheGen #-}
 variantTheGen :: Integral a => a -> StdGen -> StdGen
 variantTheGen n g
   | n >= 1    = natVariant (n-1) (boolVariant False g)
   | n == 0   = natVariant (0 `asTypeOf` n) (boolVariant True g)
   | otherwise = bigNatVariant (negate (toInteger n)) (boolVariant True g)

 boolVariant :: Bool -> StdGen -> StdGen
 boolVariant False = fst . stdSplit
 boolVariant True = snd . stdSplit

 variantQCGen :: Integral a => a -> QCGen -> QCGen
 variantQCGen n (QCGen g) = QCGen (variantTheGen n g)

 chip :: Bool -> Int -> StdGen -> StdGen
 chip finished n = boolVariant finished . boolVariant (even n)

 chop :: Integer -> Integer
 chop n = n `div` 2

 stop :: Integral a => a -> Bool
 stop n = n <= 1

 instance Functor Gen where
   fmap f (MkGen h) =
     MkGen (\r n -> f (h r n))

 instance Applicative Gen where
   pure  = return
   (<*>) = ap

 instance Monad Gen where
   return x =
     MkGen (\_ _ -> x)

   MkGen m >>= k =
     MkGen (\(QCGen r) n ->
       let (r1,r2)  = case stdSplit r of (g1, g2) -> (QCGen g1, QCGen g2)
           MkGen m' = k (m r1 n)
        in m' r2 n
     )

 promote :: Monad m => m (Gen a) -> Gen (m a)
 promote m = do
   eval <- delay
   return (liftM eval m)

 delay :: Gen (Gen a -> a)
 delay = MkGen (\r n g -> unGen g r n)

 listOf :: Gen a -> Gen [a]
 listOf gen = sized $ \n ->
   do k <- chooseInt (0,n)
      vectorOf k gen

 vectorOf :: Int -> Gen a -> Gen [a]
 vectorOf = replicateM

 sized :: (Int -> Gen a) -> Gen a
 sized f = MkGen (\r n -> let MkGen m = f n in m r n)

 chooseInt :: (Int, Int) -> Gen Int
 chooseInt rng = MkGen (\r _ -> let (x,_) = randomIvalIntegral rng r in x)

 qcGenRange :: QCGen -> (Int, Int)
 qcGenRange (QCGen g) = stdRange g

 qcGenNext :: QCGen -> (Int, QCGen)
 qcGenNext (QCGen g) = case stdNext g of
                         (x, g') -> (x, QCGen g')

 randomIvalIntegral :: (Integral a) => (a, a) -> QCGen -> (a, QCGen)
 randomIvalIntegral (l,h) = randomIvalInteger (toInteger l, toInteger h)

 randomIvalInteger :: (Num a) => (Integer, Integer) -> QCGen -> (a, QCGen)
 randomIvalInteger (l,h) rng
  | l > h     = randomIvalInteger (h,l) rng
  | otherwise = case (f 1 0 rng) of (v, rng') -> (fromInteger (l + v `mod`
 k), rng')
      where
        (genlo, genhi) = qcGenRange rng
        b = fromIntegral genhi - fromIntegral genlo + 1

        q = 1000
        k = h - l + 1
        magtgt = k * q

        f mag v g | mag >= magtgt = (v, g)
                  | otherwise = v' `seq`f (mag*b) v' g' where
                         (x,g') = qcGenNext g
                         v' = (v * b + (fromIntegral x - fromIntegral
 genlo))

 chooseBool :: (Bool, Bool) -> Gen Bool
 chooseBool rng = MkGen (\r _ -> let (x,_) = randomRBool rng r in x)

 randomRBool :: (Bool, Bool) -> QCGen -> (Bool, QCGen)
 randomRBool (a,b) g =
       case (randomIvalInteger (bool2Int a, bool2Int b) g) of
         (x, g') -> (int2Bool x, g')
        where
          bool2Int :: Bool -> Integer
          bool2Int False = 0
          bool2Int True  = 1

          int2Bool :: Int -> Bool
          int2Bool 0 = False
          int2Bool _ = True

 class Arbitrary a where
   arbitrary :: Gen a

 instance Arbitrary Bool where
   arbitrary = chooseBool (False, True)

 instance Arbitrary a => Arbitrary [a] where
   arbitrary = listOf arbitrary

 instance (Arbitrary a, Arbitrary b)
       => Arbitrary (a, b)
  where
   arbitrary = liftM2 (,) arbitrary arbitrary

 instance (Arbitrary a, Arbitrary b, Arbitrary c)
       => Arbitrary (a,b,c)
  where
   arbitrary = liftM3 (,,) arbitrary arbitrary arbitrary

 instance (CoArbitrary a, Arbitrary b) => Arbitrary (a -> b) where
   arbitrary = promote (`coarbitrary` arbitrary)

 class CoArbitrary a where
   coarbitrary :: a -> Gen b -> Gen b

 instance (CoArbitrary a, CoArbitrary b)
       => CoArbitrary (a,b)
  where
   coarbitrary (x,y) = coarbitrary x
                     . coarbitrary y

 instance CoArbitrary Bool where
   coarbitrary False = variant (0 :: Int)
   coarbitrary True  = variant (1 :: Int)
 }}}

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