Make specialisation a bit more aggressive

The patch

    commit c43c981705ec33da92a9ce91eb90f2ecf00be9fe
    Author: Simon Peyton Jones <simonpj@microsoft.com>
    Date:   Fri Oct 23 16:15:51 2009 +0000
    Fix Trac #3591: very tricky specialiser bug

fixed a nasty specialisation bug /for DFuns/.  Eight years
later, this patch

    commit 2b74bd9d8b4c6b20f3e8d9ada12e7db645cc3c19
    Author: Simon Peyton Jones <simonpj@microsoft.com>
    Date:   Wed Jun 7 12:03:51 2017 +0100
    Stop the specialiser generating loopy code

extended it to work for /imported/ DFuns.  But in the process
we lost the fact that it was needed only for DFuns! As a result
we started silently losing useful specialisation for non-DFuns.
But there was no regression test to spot the lossage.

Then, nearly four years later, Andreas filed #19599, which showed
the lossage in high relief.  This patch restores the DFun test,
and adds Note [Avoiding loops (non-DFuns)] to explain why.

This is undoubtedly a very tricky corner of the specialiser,
and one where I would love to have a more solid argument, even a
paper!  But meanwhile I think this fixes the lost specialisations
without introducing any new loops.

I have two regression tests, T19599 and T19599a, so I hope we'll
know if we lose them again in the future.

Vanishingly small effect on nofib.

A couple of compile-time benchmarks improve
  T9872a(normal) ghc/alloc  1660559328.0  1643827784.0  -1.0% GOOD
  T9872c(normal) ghc/alloc  1691359152.0  1672879384.0  -1.1% GOOD
Many others wiggled around a bit.

Metric Decrease:
    T9872a
    T9872c

6 files changed, 88 insertions, 17 deletions

diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
index 8efebd0cd5..6c1718913c 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ b/compiler/GHC/Core/Opt/Specialise.hs
@@ -859,14 +859,14 @@ allows DFuns to specialise as well.
 Note [Avoiding loops in specImports]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We must take great care when specialising instance declarations
-(functions like $fOrdList) lest we accidentally build a recursive
-dictionary. See Note [Avoiding loops].
+(DFuns like $fOrdList) lest we accidentally build a recursive
+dictionary. See Note [Avoiding loops (DFuns)].
 
-The basic strategy of Note [Avoiding loops] is to use filterCalls
+The basic strategy of Note [Avoiding loops (DFuns)] is to use filterCalls
 to discard loopy specialisations.  But to do that we must ensure
 that the in-scope dict-binds (passed to filterCalls) contains
 all the needed dictionary bindings.  In particular, in the recursive
-call to spec_imorpts in spec_import, we must include the dict-binds
+call to spec_imports in spec_import, we must include the dict-binds
 from the parent.  Lacking this caused #17151, a really nasty bug.
 
 Here is what happened.
@@ -1820,8 +1820,8 @@ In general, we need only make this Rec if
   - there are some specialisations (spec_binds non-empty)
   - there are some dict_binds that depend on f (dump_dbs non-empty)
 
-Note [Avoiding loops]
-~~~~~~~~~~~~~~~~~~~~~
+Note [Avoiding loops (DFuns)]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When specialising /dictionary functions/ we must be very careful to
 avoid building loops. Here is an example that bit us badly, on
 several distinct occasions.
@@ -1862,8 +1862,10 @@ Solution:
   (directly or indirectly) on the dfun we are specialising.
   This is done by 'filterCalls'
 
---------------
-Here's yet another example
+Note [Avoiding loops (non-DFuns)]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The whole Note [Avoiding loops (DFuns)] things applies only to DFuns.
+It's important /not/ to apply filterCalls to non-DFuns. For example:
 
   class C a where { foo,bar :: [a] -> [a] }
 
@@ -1884,8 +1886,8 @@ That translates to:
 The call (r_bar $fCInt) mentions $fCInt,
                         which mentions foo_help,
                         which mentions r_bar
-But we DO want to specialise r_bar at Int:
 
+But we DO want to specialise r_bar at Int:
     Rec { $fCInt :: C Int = MkC foo_help reverse
           foo_help (xs::[Int]) = r_bar Int $fCInt xs
 
@@ -1897,6 +1899,22 @@ But we DO want to specialise r_bar at Int:
 
 Note that, because of its RULE, r_bar joins the recursive
 group.  (In this case it'll unravel a short moment later.)
+See test simplCore/should_compile/T19599a.
+
+Another example is #19599, which looked like this:
+
+   class (Show a, Enum a) => MyShow a where
+      myShow :: a -> String
+
+   myShow_impl :: MyShow a => a -> String
+
+   foo :: Int -> String
+   foo = myShow_impl @Int $fMyShowInt
+
+   Rec { $fMyShowInt = MkMyShowD $fEnumInt $fShowInt $cmyShow
+       ; $cmyShow = myShow_impl @Int $fMyShowInt }
+
+Here, we really do want to specialise `myShow_impl @Int $fMyShowInt`.
 
 
 Note [Specialising a recursive group]
@@ -2677,11 +2695,10 @@ pair_fvs (bndr, rhs) = exprSomeFreeVars interesting rhs
     interesting :: InterestingVarFun
     interesting v = isLocalVar v || (isId v && isDFunId v)
         -- Very important: include DFunIds /even/ if it is imported
-        -- Reason: See Note [Avoiding loops], the second example
-        --         involving an imported dfun.  We must know whether
-        --         a dictionary binding depends on an imported dfun,
-        --         in case we try to specialise that imported dfun
-        --         #13429 illustrates
+        -- Reason: See Note [Avoiding loops in specImports], the #13429
+        --         example involving an imported dfun.  We must know
+        --         whether a dictionary binding depends on an imported
+        --         DFun in case we try to specialise that imported DFun
 
 -- | Flatten a set of "dumped" 'DictBind's, and some other binding
 -- pairs, into a single recursive binding.
@@ -2771,14 +2788,19 @@ callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
                         Nothing -> []
                         Just cis -> filterCalls cis orig_dbs
          -- filterCalls: drop calls that (directly or indirectly)
-         -- refer to fn.  See Note [Avoiding loops]
+         -- refer to fn.  See Note [Avoiding loops (DFuns)]
 
 ----------------------
 filterCalls :: CallInfoSet -> Bag DictBind -> [CallInfo]
--- See Note [Avoiding loops]
+-- See Note [Avoiding loops (DFuns)]
 filterCalls (CIS fn call_bag) dbs
-  = filter ok_call (bagToList call_bag)
+  | isDFunId fn  -- Note [Avoiding loops (DFuns)] applies only to DFuns
+  = filter ok_call unfiltered_calls
+  | otherwise         -- Do not apply it to non-DFuns
+  = unfiltered_calls  -- See Note [Avoiding loops (non-DFuns)]
   where
+    unfiltered_calls = bagToList call_bag
+
     dump_set = foldl' go (unitVarSet fn) dbs
       -- This dump-set could also be computed by splitDictBinds
       --   (_,_,dump_set) = splitDictBinds dbs {fn}
diff --git a/testsuite/tests/simplCore/should_compile/T19599.hs b/testsuite/tests/simplCore/should_compile/T19599.hs
new file mode 100644
index 0000000000..18619b4f86
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T19599.hs
@@ -0,0 +1,20 @@
+module SPEC where
+
+class (Show a, Enum a) => MyShow a where
+    myShow :: a -> String
+
+instance MyShow Int where
+    myShow = myShow_impl . succ
+
+foo :: Int -> String
+foo = myShow_impl
+
+-- This pragma should not be necessary
+-- {-# specialize myShow_impl :: Int -> String #-}
+
+{-# INLINEABLE myShow_impl #-}
+myShow_impl :: MyShow a => a -> String
+-- Make it large enough not to inline
+myShow_impl x = show . succ . succ . succ . succ . succ . succ .
+                succ . succ . succ . succ . succ . succ . succ .
+                succ . succ . succ $ x
diff --git a/testsuite/tests/simplCore/should_compile/T19599.stderr b/testsuite/tests/simplCore/should_compile/T19599.stderr
new file mode 100644
index 0000000000..0629c719fd
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T19599.stderr
@@ -0,0 +1,6 @@
+
+==================== Tidy Core rules ====================
+"SPEC myShow_impl @Int"
+    forall ($dMyShow :: MyShow Int). myShow_impl @Int $dMyShow = foo
+
+
diff --git a/testsuite/tests/simplCore/should_compile/T19599a.hs b/testsuite/tests/simplCore/should_compile/T19599a.hs
new file mode 100644
index 0000000000..a2e9ceb6a4
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T19599a.hs
@@ -0,0 +1,14 @@
+module Spec where
+
+class C a where { foo,bar :: [a] -> [a] }
+
+instance C Int where
+     foo x = r_bar x
+     bar xs = reverse xs
+
+r_bar :: C a => [a] -> [a]
+r_bar (x:xs) = bar (xs ++ r_bar xs)
+r_bar [] = []
+
+-- We should specialise `r_bar` at Int
+-- C.f. Note Note [Avoiding loops (non-DFuns)] in GHC.Core.Opt.Specialise
diff --git a/testsuite/tests/simplCore/should_compile/T19599a.stderr b/testsuite/tests/simplCore/should_compile/T19599a.stderr
new file mode 100644
index 0000000000..17a0fd8330
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T19599a.stderr
@@ -0,0 +1,6 @@
+
+==================== Tidy Core rules ====================
+"SPEC r_bar @Int"
+    forall ($dC :: C Int). r_bar @Int $dC = $fCInt_$sr_bar
+
+
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 3a16d55508..04cab4234f 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -351,3 +351,6 @@ test('T19360', only_ways(['optasm']), compile, [''])
 
 # If the test goes wrong we'll get more case expressions in the output
 test('T19581', [ grep_errmsg(r'case') ], compile, ['-O -ddump-simpl -dsuppress-uniques'])
+
+test('T19599', normal, compile, ['-O -ddump-rules'])
+test('T19599a', normal, compile, ['-O -ddump-rules'])