Do proper depth checking in the flattener to avoid looping.

This implements (roughly) the plan put forward in comment:14:ticket:7788,
fixing #7788, #8550, #9554, #10139, and addressing concerns raised in #10079.
There are some regressions w.r.t. GHC 7.8, but only with pathological type
families (like F a = F a). This also (hopefully -- don't have a test case)
fixes #10158. Unsolved problems include #10184 and #10185, which are both
known deficiencies of the approach used here.

As part of this change, the plumbing around detecting infinite loops has
changed. Instead of -fcontext-stack and -ftype-function-depth, we now have
one combined -freduction-depth parameter. Setting it to 0 disbales the
check, which is now the recommended way to get (terminating) code to
typecheck in releases. (The number of reduction steps may well change between
minor GHC releases!)

This commit also introduces a new IntWithInf type in BasicTypes
that represents an integer+infinity. This type is used in a few
places throughout the code.

Tests in
  indexed-types/should_fail/T7788
  indexed-types/should_fail/T8550
  indexed-types/should_fail/T9554
  indexed-types/should_compile/T10079
  indexed-types/should_compile/T10139
  typecheck/should_compile/T10184  (expected broken)
  typecheck/should_compile/T10185  (expected broken)

This commit also changes performance testsuite numbers, for the better.

1 files changed, 9 insertions, 8 deletions

diff --git a/compiler/simplCore/SimplMonad.hs b/compiler/simplCore/SimplMonad.hs
index fbf23d7436..7eb6a54ced 100644
--- a/compiler/simplCore/SimplMonad.hs
+++ b/compiler/simplCore/SimplMonad.hs
@@ -30,6 +30,7 @@ import Outputable
 import FastString
 import MonadUtils
 import ErrUtils
+import BasicTypes          ( IntWithInf, treatZeroAsInf, mkIntWithInf )
 import Control.Monad       ( when, liftM, ap )
 
 {-
@@ -52,11 +53,10 @@ newtype SimplM result
   -- we only need IO here for dump output
 
 data SimplTopEnv
-  = STE { st_flags :: DynFlags
-        , st_max_ticks :: Int  -- Max #ticks in this simplifier run
-                               -- Zero means infinity!
-        , st_rules :: RuleBase
-        , st_fams  :: (FamInstEnv, FamInstEnv) }
+  = STE { st_flags     :: DynFlags
+        , st_max_ticks :: IntWithInf  -- Max #ticks in this simplifier run
+        , st_rules     :: RuleBase
+        , st_fams      :: (FamInstEnv, FamInstEnv) }
 
 initSmpl :: DynFlags -> RuleBase -> (FamInstEnv, FamInstEnv)
          -> UniqSupply          -- No init count; set to 0
@@ -73,14 +73,15 @@ initSmpl dflags rules fam_envs us size m
               , st_max_ticks = computeMaxTicks dflags size
               , st_fams = fam_envs }
 
-computeMaxTicks :: DynFlags -> Int -> Int
+computeMaxTicks :: DynFlags -> Int -> IntWithInf
 -- Compute the max simplifier ticks as
 --     (base-size + pgm-size) * magic-multiplier * tick-factor/100
 -- where
 --    magic-multiplier is a constant that gives reasonable results
 --    base-size is a constant to deal with size-zero programs
 computeMaxTicks dflags size
-  = fromInteger ((toInteger (size + base_size)
+  = treatZeroAsInf $
+    fromInteger ((toInteger (size + base_size)
                   * toInteger (tick_factor * magic_multiplier))
           `div` 100)
   where
@@ -195,7 +196,7 @@ tick t = SM (\st_env us sc -> let sc' = doSimplTick (st_flags st_env) t sc
 checkedTick :: Tick -> SimplM ()
 -- Try to take a tick, but fail if too many
 checkedTick t
-  = SM (\st_env us sc -> if st_max_ticks st_env <= simplCountN sc
+  = SM (\st_env us sc -> if st_max_ticks st_env <= mkIntWithInf (simplCountN sc)
                          then pprPanic "Simplifier ticks exhausted" (msg sc)
                          else let sc' = doSimplTick (st_flags st_env) t sc
                               in sc' `seq` return ((), us, sc'))