Reduce inlining in deeply-nested cases

This adds a new heuristic, controllable via two new flags to
better tune inlining behaviour.

The new flags are -funfolding-case-threshold and
-funfolding-case-scaling which are document both
in the user guide and in
Note [Avoid inlining into deeply nested cases].

Co-authored-by: Andreas Klebinger <klebinger.andreas@gmx.at>

7 files changed, 88 insertions, 19 deletions

diff --git a/testsuite/tests/dependent/should_compile/all.T b/testsuite/tests/dependent/should_compile/all.T
index cf5c76d380..a368edd128 100644
--- a/testsuite/tests/dependent/should_compile/all.T
+++ b/testsuite/tests/dependent/should_compile/all.T
@@ -10,14 +10,18 @@ test('RaeBlogPost', normal, compile, [''])
 test('mkGADTVars', normal, compile, [''])
 test('TypeLevelVec',normal,compile, [''])
 test('T9632', normal, compile, [''])
-# The dynamic-paper test fails in the profasm way if we don't increase
+
+# dynamic-paper used to run out of simplfier ticks because of
+# infinite inlining, but the new case-depth mechanism cuts that off,
+# so it now compiles fine.
+#
+# Historical notes: The dynamic-paper test fails in the profasm way if we don't increase
 # the simplifier tick limit. If we do, we run out of stack
 # space. If we increase the stack size enough with -K,
 # we run out of simplifier ticks again. This is
 # discussed in #11330.
-test('dynamic-paper',
-     expect_broken_for(11330, ['profasm']),
-     compile_fail, [''])
+test('dynamic-paper', normal, compile, [''])
+
 test('T11311', normal, compile, [''])
 test('T11405', normal, compile, [''])
 test('T11241', normal, compile, [''])
diff --git a/testsuite/tests/dependent/should_compile/dynamic-paper.stderr b/testsuite/tests/dependent/should_compile/dynamic-paper.stderr
deleted file mode 100644
index b05335047f..0000000000
--- a/testsuite/tests/dependent/should_compile/dynamic-paper.stderr
+++ /dev/null
@@ -1,15 +0,0 @@
-Simplifier ticks exhausted
-  When trying UnfoldingDone delta1
-  To increase the limit, use -fsimpl-tick-factor=N (default 100).
-   
-  If you need to increase the limit substantially, please file a
-  bug report and indicate the factor you needed.
-   
-  If GHC was unable to complete compilation even with a very large factor
-  (a thousand or more), please consult the "Known bugs or infelicities"
-  section in the Users Guide before filing a report. There are a
-  few situations unlikely to occur in practical programs for which
-  simplifier non-termination has been judged acceptable.
-   
-  To see detailed counts use -ddump-simpl-stats
-  Total ticks: 140801
diff --git a/testsuite/tests/driver/inline-check.stderr b/testsuite/tests/driver/inline-check.stderr
index 5bf9edaf24..953e101315 100644
--- a/testsuite/tests/driver/inline-check.stderr
+++ b/testsuite/tests/driver/inline-check.stderr
@@ -5,6 +5,8 @@ Considering inlining: foo
   is exp: True
   is work-free: True
   guidance IF_ARGS [0] 30 0
+  case depth = 0
+  depth based penalty = 0
   discounted size = 10
   ANSWER = YES
 Inactive unfolding: foo1
diff --git a/testsuite/tests/simplCore/should_compile/T18730.hs b/testsuite/tests/simplCore/should_compile/T18730.hs
new file mode 100644
index 0000000000..87cd1819d8
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T18730.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE TupleSections #-}
+{-# OPTIONS_GHC -funfolding-case-scaling=5 #-}
+
+module T18730 where
+
+import T18730_A (Gen)
+
+genFields :: Gen [(String, Int)]
+genFields =
+  mapM
+    (\(f, g) -> (f,) <$> g)
+    [ ("field", genIntField)
+    , ("field_10", genIntField)
+    , ("field_10", genIntField)
+    , ("field_10", genIntField)
+    , ("field_10", genIntField)
+    , ("field_10", genIntField)
+    , ("field_10", genIntField)
+    , ("field_10", genIntField)
+    , ("field_10", genIntField)
+    , ("field_10", genIntField)
+    , ("field_10", genIntField)
+    ]
+
+genIntField :: Gen Int
+genIntField = pure 0
diff --git a/testsuite/tests/simplCore/should_compile/T18730.stderr b/testsuite/tests/simplCore/should_compile/T18730.stderr
new file mode 100644
index 0000000000..2b9a11ea07
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T18730.stderr
@@ -0,0 +1 @@
+[1 of 1] Compiling T18730_A         ( T18730_A.hs, T18730_A.o )
diff --git a/testsuite/tests/simplCore/should_compile/T18730_A.hs b/testsuite/tests/simplCore/should_compile/T18730_A.hs
new file mode 100644
index 0000000000..c076956b43
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T18730_A.hs
@@ -0,0 +1,50 @@
+module T18730_A where
+
+import Control.Monad (ap)
+import Data.Word
+import Data.Bits
+
+newtype Gen a = MkGen
+  { -- | Run the generator on a particular seed.
+    -- If you just want to get a random value out, consider using 'generate'.
+    unGen :: QCGen -> Int -> a
+  }
+
+instance Functor Gen where
+  fmap f (MkGen h) =
+    MkGen (\r n -> f (h r n))
+
+instance Applicative Gen where
+  pure x =
+    MkGen (\_ _ -> x)
+  (<*>) = ap
+
+instance Monad Gen where
+  return = pure
+
+  MkGen m >>= k =
+    MkGen
+      ( \r n ->
+          case split r of
+            (r1, r2) ->
+              let MkGen m' = k (m r1 n)
+               in m' r2 n
+      )
+
+  (>>) = (*>)
+
+data QCGen = QCGen !Word64 !Word64
+
+split :: QCGen -> (QCGen, QCGen)
+split (QCGen seed gamma) =
+    (QCGen seed'' gamma, QCGen seed' (mixGamma seed''))
+  where
+    seed'  = seed + gamma
+    seed'' = seed' + gamma
+
+-- This piece appears to be critical
+mixGamma :: Word64 -> Word64
+mixGamma z0 =
+    if z0 >= 24
+        then z0
+        else z0 `xor` 0xaaaaaaaaaaaaaaaa
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index d62a7ce0e6..e892ad7194 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -338,6 +338,7 @@ test('T18603', normal, compile, ['-dcore-lint -O'])
 # T18649 should /not/ generate a specialisation rule
 test('T18649', normal, compile, ['-O -ddump-rules -Wno-simplifiable-class-constraints'])
 
+test('T18730', normal, multimod_compile, ['T18730_A', '-dcore-lint -O'])
 test('T18747A', normal, compile, [''])
 test('T18747B', normal, compile, [''])
 test('T18815', only_ways(['optasm']), makefile_test, ['T18815'])