Major improvements to the specialiser

This patch is joint work of Alexis King and Simon PJ.  It does some
significant refactoring of the type-class specialiser.  Main highlights:

* We can specialise functions with types like
     f :: Eq a => a -> Ord b => b => blah
  where the classes aren't all at the front (#16473).  Here we can
  correctly specialise 'f' based on a call like
     f @Int @Bool dEqInt x dOrdBool
  This change really happened in an earlier patch
     commit 2d0cf6252957b8980d89481ecd0b79891da4b14b
     Author: Sandy Maguire <sandy@sandymaguire.me>
     Date:   Thu May 16 12:12:10 2019 -0400
  work that this new patch builds directly on that work, and refactors
  it a bit.

* We can specialise functions with implicit parameters (#17930)
     g :: (?foo :: Bool, Show a) => a -> String
  Previously we could not, but now they behave just like a non-class
  argument as in 'f' above.

* We can specialise under-saturated calls, where some (but not all of
  the dictionary arguments are provided (#17966).  For example, we can
  specialise the above 'f' based on a call
     map (f @Int dEqInt) xs
  even though we don't (and can't) give Ord dictionary.

  This may sound exotic, but #17966 is a program from the wild, and
  showed significant perf loss for functions like f, if you need
  saturation of all dictionaries.

* We fix a buglet in which a floated dictionary had a bogus demand
  (#17810), by using zapIdDemandInfo in the NonRec case of specBind.

* A tiny side benefit: we can drop dead arguments to specialised
  functions; see Note [Drop dead args from specialisations]

* Fixed a bug in deciding what dictionaries are "interesting"; see
  Note [Keep the old dictionaries interesting]

This is all achieved by by building on Sandy Macguire's work in
defining SpecArg, which mkCallUDs uses to describe the arguments of
the call. Main changes:

* Main work is in specHeader, which marched down the [InBndr] from the
  function definition and the [SpecArg] from the call site, together.

* specCalls no longer has an arity check; the entire mechanism now
  handles unders-saturated calls fine.

* mkCallUDs decides on an argument-by-argument basis whether to
  specialise a particular dictionary argument; this is new.
  See mk_spec_arg in mkCallUDs.

It looks as if there are many more lines of code, but I think that
all the extra lines are comments!

11 files changed, 187 insertions, 2 deletions

diff --git a/testsuite/tests/perf/compiler/T16473.stdout b/testsuite/tests/perf/compiler/T16473.stdout
index e70603e56f..2e2c88f82c 100644
--- a/testsuite/tests/perf/compiler/T16473.stdout
+++ b/testsuite/tests/perf/compiler/T16473.stdout
@@ -92,6 +92,12 @@ Rule fired: Class op $p1Monad (BUILTIN)
 Rule fired: Class op $p1Applicative (BUILTIN)
 Rule fired: Class op fmap (BUILTIN)
 Rule fired: Class op fmap (BUILTIN)
+Rule fired: Class op fmap (BUILTIN)
+Rule fired: Class op fmap (BUILTIN)
+Rule fired: SPEC/Main $fFunctorStateT_$cfmap @Identity _ (Main)
+Rule fired: Class op fmap (BUILTIN)
+Rule fired: SPEC/Main $fFunctorStateT_$cfmap @Identity _ (Main)
+Rule fired: Class op fmap (BUILTIN)
 Rule fired: Class op return (BUILTIN)
 Rule fired: Class op return (BUILTIN)
 Rule fired: Class op >>= (BUILTIN)
@@ -117,18 +123,19 @@ Rule fired: SPEC/Main $fApplicativeStateT_$c<*> @Identity _ (Main)
 Rule fired: SPEC/Main $fApplicativeStateT_$c*> @Identity _ (Main)
 Rule fired: SPEC/Main $fMonadStateT @Identity _ (Main)
 Rule fired: Class op $p1Monad (BUILTIN)
+Rule fired: Class op $p1Applicative (BUILTIN)
+Rule fired: Class op fmap (BUILTIN)
+Rule fired: Class op $p1Monad (BUILTIN)
 Rule fired: Class op <*> (BUILTIN)
 Rule fired: Class op $p1Monad (BUILTIN)
 Rule fired: Class op $p1Applicative (BUILTIN)
 Rule fired: Class op fmap (BUILTIN)
-Rule fired: Class op fmap (BUILTIN)
 Rule fired: Class op $p1Monad (BUILTIN)
 Rule fired: Class op <*> (BUILTIN)
 Rule fired: Class op $p1Monad (BUILTIN)
 Rule fired: Class op $p1Applicative (BUILTIN)
 Rule fired: Class op fmap (BUILTIN)
 Rule fired: Class op >>= (BUILTIN)
-Rule fired: Class op fmap (BUILTIN)
 Rule fired: SPEC go @(StateT (Sum Int) Identity) (Main)
 Rule fired: Class op $p1Monad (BUILTIN)
 Rule fired: Class op pure (BUILTIN)
diff --git a/testsuite/tests/simplCore/should_compile/Makefile b/testsuite/tests/simplCore/should_compile/Makefile
index 396c375110..bc96b8f124 100644
--- a/testsuite/tests/simplCore/should_compile/Makefile
+++ b/testsuite/tests/simplCore/should_compile/Makefile
@@ -2,6 +2,11 @@ TOP=../../..
 include $(TOP)/mk/boilerplate.mk
 include $(TOP)/mk/test.mk
 
+T17966:
+	$(RM) -f T17966.o T17966.hi
+	- '$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-spec T17966.hs 2> /dev/null | grep 'SPEC'
+        # Expecting a SPEC rule for $cm
+
 T17409:
 	$(RM) -f T17409.o T17409.hi
 	- '$(TEST_HC)' $(TEST_HC_OPTS) -O -c -dverbose-core2core -dsuppress-uniques T17409.hs 2> /dev/null | grep '\<id\>'
diff --git a/testsuite/tests/simplCore/should_compile/T17810.hs b/testsuite/tests/simplCore/should_compile/T17810.hs
new file mode 100644
index 0000000000..6e13d9211c
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T17810.hs
@@ -0,0 +1,7 @@
+module T17801 where
+
+import Control.Monad.Except
+import T17810a
+
+f :: ExceptT e (TCMT IO) ()
+f = liftReduce
diff --git a/testsuite/tests/simplCore/should_compile/T17810a.hs b/testsuite/tests/simplCore/should_compile/T17810a.hs
new file mode 100644
index 0000000000..6f3cf88246
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T17810a.hs
@@ -0,0 +1,27 @@
+module T17810a where
+
+import Control.Monad.Except
+
+class Monad m => ReadTCState m where
+  locallyTCState :: m ()
+  liftReduce :: m ()
+
+instance ReadTCState m => ReadTCState (ExceptT err m) where
+  locallyTCState = undefined
+  liftReduce = lift liftReduce
+
+instance MonadIO m => ReadTCState (TCMT m) where
+  locallyTCState = (undefined <$> liftReduce) <* TCM (\_ -> return ())
+  liftReduce = undefined
+
+newtype TCMT m a = TCM { unTCM :: () -> m a }
+
+instance MonadIO m => Functor (TCMT m) where
+  fmap f (TCM m) = TCM $ \r -> liftM f (m r )
+
+instance MonadIO m => Applicative (TCMT m) where
+  pure x = TCM (\_ -> return x)
+  (<*>) (TCM mf) (TCM m) = TCM $ \r -> ap (mf r) (m r)
+
+instance MonadIO m => Monad (TCMT m) where
+  (>>=) (TCM m) k = TCM $ \r -> m r >>= \x -> unTCM (k x) r
diff --git a/testsuite/tests/simplCore/should_compile/T17930.hs b/testsuite/tests/simplCore/should_compile/T17930.hs
new file mode 100644
index 0000000000..07a186840a
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T17930.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE ImplicitParams #-}
+module T17930 where
+
+foo :: (?b :: Bool, Show a) => a -> String
+foo x | ?b        = show x ++ "!"
+      | otherwise = show x ++ "."
+{-# INLINABLE[0] foo #-}
+
+str :: String
+str = let ?b = True in foo "Hello"
diff --git a/testsuite/tests/simplCore/should_compile/T17930.stderr b/testsuite/tests/simplCore/should_compile/T17930.stderr
new file mode 100644
index 0000000000..7b24d169f2
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T17930.stderr
@@ -0,0 +1,2 @@
+$sfoo :: (?b::Bool) => [Char] -> [Char]
+$sfoo
diff --git a/testsuite/tests/simplCore/should_compile/T17966.hs b/testsuite/tests/simplCore/should_compile/T17966.hs
new file mode 100644
index 0000000000..ca7803ea0b
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T17966.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+
+-- The issue here is whether $cm gets a specialiation
+-- See #17966
+
+module T17966 where
+
+class C a b where
+  m :: Show c => a -> b -> c -> String
+
+instance Show b => C Bool b where
+  m a b c = show a ++ show b ++ show c
+  {-# INLINABLE [0] m #-}
+
+f :: (C a b, Show c) => a -> b -> c -> String
+f a b c = m a b c ++ "!"
+{-# INLINABLE [0] f #-}
+
+x :: String
+x = f True () (Just 42)
diff --git a/testsuite/tests/simplCore/should_compile/T17966.stdout b/testsuite/tests/simplCore/should_compile/T17966.stdout
new file mode 100644
index 0000000000..b324259b4a
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T17966.stdout
@@ -0,0 +1,4 @@
+ RULES: "SPEC $cm @()" [0]
+ RULES: "SPEC f @Bool @() @(Maybe Integer)" [0]
+"SPEC/T17966 $fShowMaybe_$cshowList @Integer"
+"SPEC/T17966 $fShowMaybe @Integer"
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index ed89a35690..b3262b8d19 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -319,3 +319,10 @@ test('T17787',  [ grep_errmsg(r'foo') ], compile, ['-ddump-simpl -dsuppress-uniq
 test('T17901',
      normal,
      makefile_test, ['T17901'])
+test('T17930', [ grep_errmsg(r'^\$sfoo') ], compile, ['-O -ddump-spec -dsuppress-uniques -dsuppress-idinfo'])
+test('spec004', [ grep_errmsg(r'\$sfoo') ], compile, ['-O -ddump-spec -dsuppress-uniques'])
+test('T17966',
+     normal,
+     makefile_test, ['T17966'])
+# NB: T17810: -fspecialise-aggressively
+test('T17810', normal, multimod_compile, ['T17810', '-fspecialise-aggressively -dcore-lint -O -v0'])
diff --git a/testsuite/tests/simplCore/should_compile/spec004.hs b/testsuite/tests/simplCore/should_compile/spec004.hs
new file mode 100644
index 0000000000..29b85c9f5b
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/spec004.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE RankNTypes #-}
+
+-- Dead arguments should be dropped in specialisations. See !2913.
+
+module ShouldCompile where
+
+foo :: () -> Show a => a -> String
+foo _x y = show y ++ "!"
+{-# NOINLINE[0] foo #-}
+
+bar :: String
+bar = foo () (42 :: Int)
diff --git a/testsuite/tests/simplCore/should_compile/spec004.stderr b/testsuite/tests/simplCore/should_compile/spec004.stderr
new file mode 100644
index 0000000000..8d53785b68
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/spec004.stderr
@@ -0,0 +1,84 @@
+
+==================== Specialise ====================
+Result size of Specialise
+  = {terms: 53, types: 46, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 14, types: 12, coercions: 0, joins: 0/0}
+$sfoo [InlPrag=NOINLINE[0]] :: Int -> [Char]
+[LclId]
+$sfoo
+  = \ (y :: Int) ->
+      GHC.Base.build
+        @Char
+        (\ (@b) (c [OS=OneShot] :: Char -> b -> b) (n [OS=OneShot] :: b) ->
+           GHC.Base.foldr
+             @Char
+             @b
+             c
+             (GHC.CString.unpackFoldrCString# @b "!"# c n)
+             (show @Int GHC.Show.$fShowInt y))
+
+-- RHS size: {terms: 17, types: 17, coercions: 0, joins: 0/0}
+foo [InlPrag=NOINLINE[0]] :: forall a. () -> Show a => a -> String
+[LclIdX,
+ Arity=3,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [0 30 0] 150 40},
+ RULES: "SPEC foo @Int" [0]
+            forall (dk :: ()) ($dShow :: Show Int). foo @Int dk $dShow = $sfoo]
+foo
+  = \ (@a) _ [Occ=Dead] ($dShow :: Show a) (y :: a) ->
+      GHC.Base.build
+        @Char
+        (\ (@b) (c [OS=OneShot] :: Char -> b -> b) (n [OS=OneShot] :: b) ->
+           GHC.Base.foldr
+             @Char
+             @b
+             c
+             (GHC.CString.unpackFoldrCString# @b "!"# c n)
+             (show @a $dShow y))
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Prim.Addr#
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+$trModule = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Types.TrName
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+$trModule = GHC.Types.TrNameS $trModule
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Prim.Addr#
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 50 0}]
+$trModule = "ShouldCompile"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Types.TrName
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+$trModule = GHC.Types.TrNameS $trModule
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+ShouldCompile.$trModule :: GHC.Types.Module
+[LclIdX,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
+ShouldCompile.$trModule = GHC.Types.Module $trModule $trModule
+
+-- RHS size: {terms: 5, types: 1, coercions: 0, joins: 0/0}
+bar :: String
+[LclIdX,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False,
+         WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 50 0}]
+bar = foo @Int GHC.Tuple.() GHC.Show.$fShowInt (GHC.Types.I# 42#)
+
+
+