[GHC] #13536: Program which terminates instantly in GHC 8.0.2 runs for minutes with 8.2.1
GHC
ghc-devs at haskell.org
Thu Apr 6 15:31:55 UTC 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
More information about the ghc-tickets
mailing list