Fix loss-of-SpecConstr bug

This bug, reported in Trac #13623 has been present since

  commit b8b3e30a6eedf9f213b8a718573c4827cfa230ba
  Author: Edward Z. Yang <ezyang@cs.stanford.edu>
  Date:   Fri Jun 24 11:03:47 2016 -0700

      Axe RecFlag on TyCons.

SpecConstr tries not to specialise indefinitely, and had a
limit (see Note [Limit recursive specialisation]) that made
use of info about whether or not a data constructor was
"recursive".  This info vanished in the above commit, making
the limit fire much more often -- and indeed it fired in this
test case, in a situation where specialisation is /highly/
desirable.

I refactored the test, to look instead at the number of
iterations of the loop of "and now specialise calls that
arise from the specialisation".  Actually less code, and
more robust.

I also added record field names to a couple of constructors,
and renamed RuleInfo to SpecInfo.

3 files changed, 91 insertions, 0 deletions

diff --git a/testsuite/tests/perf/should_run/T13623.hs b/testsuite/tests/perf/should_run/T13623.hs
new file mode 100644
index 0000000000..7a048b2a36
--- /dev/null
+++ b/testsuite/tests/perf/should_run/T13623.hs
@@ -0,0 +1,82 @@
+{-# LANGUAGE BangPatterns, GADTs, ExistentialQuantification #-}
+{-# OPTIONS_GHC -cpp #-}
+
+module Main where
+
+
+import GHC.Types
+
+
+foo :: Int -> Int -> IO Int
+foo = \i j -> sfoldl' (+) 0 $ xs i j +++ ys i j
+  where xs k l = senumFromStepN k l 200000
+        ys k l = senumFromStepN k l 300000
+        {-# Inline xs #-}
+        {-# Inline ys #-}
+{-# Inline foo #-}
+
+
+main = do { n <- foo 1 1; print n }
+
+
+
+-------------------------------------------------------------------------------
+-- vector junk
+-------------------------------------------------------------------------------
+
+#define PHASE_FUSED [1]
+#define PHASE_INNER [0]
+
+#define INLINE_FUSED INLINE PHASE_FUSED
+#define INLINE_INNER INLINE PHASE_INNER
+
+data Stream m a = forall s. Stream (s -> m (Step s a)) s
+
+data Step s a where
+  Yield :: a -> s -> Step s a
+  Skip  :: s -> Step s a
+  Done  :: Step s a
+
+senumFromStepN :: (Num a, Monad m) => a -> a -> Int -> Stream m a
+{-# INLINE_FUSED senumFromStepN #-}
+senumFromStepN x y n = x `seq` y `seq` n `seq` Stream step (x,n)
+  where
+    {-# INLINE_INNER step #-}
+    step (w,m) | m > 0     = return $ Yield w (w+y,m-1)
+               | otherwise = return $ Done
+
+sfoldl' :: Monad m => (a -> b -> a) -> a -> Stream m b -> m a
+{-# INLINE sfoldl' #-}
+sfoldl' f = sfoldlM' (\a b -> return (f a b))
+
+sfoldlM' :: Monad m => (a -> b -> m a) -> a -> Stream m b -> m a
+{-# INLINE_FUSED sfoldlM' #-}
+sfoldlM' m w (Stream step t) = foldlM'_loop SPEC w t
+  where
+    foldlM'_loop !_ z s
+      = z `seq`
+        do
+          r <- step s
+          case r of
+            Yield x s' -> do { z' <- m z x; foldlM'_loop SPEC z' s' }
+            Skip    s' -> foldlM'_loop SPEC z s'
+            Done       -> return z
+
+infixr 5 +++
+(+++) :: Monad m => Stream m a -> Stream m a -> Stream m a
+{-# INLINE_FUSED (+++) #-}
+Stream stepa ta +++ Stream stepb tb = Stream step (Left ta)
+  where
+    {-# INLINE_INNER step #-}
+    step (Left  sa) = do
+                        r <- stepa sa
+                        case r of
+                          Yield x sa' -> return $ Yield x (Left  sa')
+                          Skip    sa' -> return $ Skip    (Left  sa')
+                          Done        -> return $ Skip    (Right tb)
+    step (Right sb) = do
+                        r <- stepb sb
+                        case r of
+                          Yield x sb' -> return $ Yield x (Right sb')
+                          Skip    sb' -> return $ Skip    (Right sb')
+                          Done        -> return $ Done
diff --git a/testsuite/tests/perf/should_run/T13623.stdout b/testsuite/tests/perf/should_run/T13623.stdout
new file mode 100644
index 0000000000..ac3eff3654
--- /dev/null
+++ b/testsuite/tests/perf/should_run/T13623.stdout
@@ -0,0 +1 @@
+65000250000
diff --git a/testsuite/tests/perf/should_run/all.T b/testsuite/tests/perf/should_run/all.T
index 04513487ee..9c92cd6dc8 100644
--- a/testsuite/tests/perf/should_run/all.T
+++ b/testsuite/tests/perf/should_run/all.T
@@ -539,3 +539,11 @@ test('DeriveNull',
     ['-O'])
 
 test('DeriveNullTermination', normal, compile_and_run, [''])
+
+test('T13623',
+    [stats_num_field('bytes allocated',
+                    [ (wordsize(64), 50936, 5) ]),
+                    # 2017-05-02     50936 initial
+     only_ways(['normal'])],
+    compile_and_run,
+    ['-O2'])