Revert "Make the specialiser handle polymorphic specialisation"

This reverts commit ef0135934fe32da5b5bb730dbce74262e23e72e8.

See ticket #21229

-------------------------
Metric Decrease:
    T15164
Metric Increase:
    T13056
-------------------------

4 files changed, 52 insertions, 238 deletions

diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
index 5fb3b077ea..b59adbd511 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ b/compiler/GHC/Core/Opt/Specialise.hs
@@ -28,8 +28,6 @@ import GHC.Core.Opt.Monad
 import qualified GHC.Core.Subst as Core
 import GHC.Core.Unfold.Make
 import GHC.Core
-import GHC.Core.Make      ( mkLitRubbish )
-import GHC.Core.Unify     ( tcMatchTy )
 import GHC.Core.Rules
 import GHC.Core.Utils     ( exprIsTrivial, getIdFromTrivialExpr_maybe
                           , mkCast, exprType )
@@ -778,10 +776,6 @@ spec_import top_env callers rb dict_binds cis@(CIS fn _)
 canSpecImport :: DynFlags -> Id -> Maybe CoreExpr
 -- See Note [Specialise imported INLINABLE things]
 canSpecImport dflags fn
-  | isDataConWrapId fn
-  = Nothing   -- Don't specialise data-con wrappers, even if they
-              -- have dict args; there is no benefit.
-
   | CoreUnfolding { uf_src = src, uf_tmpl = rhs } <- unf
   , isStableSource src
   = Just rhs   -- By default, specialise only imported things that have a stable
@@ -1533,16 +1527,8 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
              else
         do { -- Run the specialiser on the specialised RHS
              -- The "1" suffix is before we maybe add the void arg
-           ; (rhs_body', rhs_uds) <- specExpr rhs_env2 rhs_body
-                -- Add the { d1' = dx1; d2' = dx2 } usage stuff
-                -- to the rhs_uds; see Note [Specialising Calls]
-           ; let rhs_uds_w_dx = foldr consDictBind rhs_uds dx_binds
-                 spec_rhs_bndrs  = spec_bndrs1 ++ leftover_bndrs
-                 (spec_uds, dumped_dbs) = dumpUDs spec_rhs_bndrs rhs_uds_w_dx
-                 spec_rhs1 = mkLams spec_rhs_bndrs $
-                             wrapDictBindsE dumped_dbs rhs_body'
-
-                 spec_fn_ty1 = exprType spec_rhs1
+           ; (spec_rhs1, rhs_uds) <- specLam rhs_env2 (spec_bndrs1 ++ leftover_bndrs) rhs_body
+           ; let spec_fn_ty1 = exprType spec_rhs1
 
                  -- Maybe add a void arg to the specialised function,
                  -- to avoid unlifted bindings
@@ -1595,6 +1581,10 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
                       Just join_arity -> etaExpandToJoinPointRule join_arity rule_wout_eta
                       Nothing -> rule_wout_eta
 
+                -- Add the { d1' = dx1; d2' = dx2 } usage stuff
+                -- See Note [Specialising Calls]
+                spec_uds = foldr consDictBind rhs_uds dx_binds
+
                 simpl_opts = initSimpleOpts dflags
 
                 --------------------------------------
@@ -1609,12 +1599,9 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
                   = (inl_prag { inl_inline = NoUserInlinePrag }, noUnfolding)
 
                   | otherwise
-                  = (inl_prag, specUnfolding simpl_opts spec_bndrs spec_unf_body
+                  = (inl_prag, specUnfolding simpl_opts spec_bndrs (`mkApps` spec_args)
                                              rule_lhs_args fn_unf)
 
-                spec_unf_body body = wrapDictBindsE dumped_dbs $
-                                     body `mkApps` spec_args
-
                 --------------------------------------
                 -- Adding arity information just propagates it a bit faster
                 --      See Note [Arity decrease] in GHC.Core.Opt.Simplify
@@ -1783,23 +1770,11 @@ in the specialisation:
     {-# RULE "SPEC f @Int" forall x. f @Int x $dShow = $sf #-}
 
 This doesn’t save us much, since the arg would be removed later by
-worker/wrapper, anyway, but it’s easy to do.
+worker/wrapper, anyway, but it’s easy to do. Note, however, that we
+only drop dead arguments if:
 
-Wrinkles
-
-* Note that we only drop dead arguments if:
-    1. We don’t specialise on them.
-    2. They come before an argument we do specialise on.
-  Doing the latter would require eta-expanding the RULE, which could
-  make it match less often, so it’s not worth it. Doing the former could
-  be more useful --- it would stop us from generating pointless
-  specialisations --- but it’s more involved to implement and unclear if
-  it actually provides much benefit in practice.
-
-* If the function has a stable unfolding, specHeader has to come up with
-  arguments to pass to that stable unfolding, when building the stable
-  unfolding of the specialised function: this is the last field in specHeader's
-  big result tuple.
+  1. We don’t specialise on them.
+  2. They come before an argument we do specialise on.
 
   The right thing to do is to produce a LitRubbish; it should rapidly
   disappear.  Rather like GHC.Core.Opt.WorkWrap.Utils.mk_absent_let.
@@ -2277,11 +2252,11 @@ instance Outputable SpecArg where
   ppr (SpecDict d) = text "SpecDict" <+> ppr d
   ppr UnspecArg    = text "UnspecArg"
 
-specArgFreeIds :: SpecArg -> IdSet
-specArgFreeIds (SpecType {}) = emptyVarSet
-specArgFreeIds (SpecDict dx) = exprFreeIds dx
-specArgFreeIds UnspecType    = emptyVarSet
-specArgFreeIds UnspecArg     = emptyVarSet
+specArgFreeVars :: SpecArg -> VarSet
+specArgFreeVars (SpecType ty) = tyCoVarsOfType ty
+specArgFreeVars (SpecDict dx) = exprFreeVars dx
+specArgFreeVars UnspecType    = emptyVarSet
+specArgFreeVars UnspecArg     = emptyVarSet
 
 isSpecDict :: SpecArg -> Bool
 isSpecDict (SpecDict {}) = True
@@ -2351,33 +2326,24 @@ specHeader
               , [OutBndr]    -- Binders for $sf
               , [DictBind]   -- Auxiliary dictionary bindings
               , [OutExpr]    -- Specialised arguments for unfolding
-                             -- Same length as "Args for LHS of rule"
+                             -- Same length as "args for LHS of rule"
               )
 
 -- We want to specialise on type 'T1', and so we must construct a substitution
 -- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding
 -- details.
-specHeader env (bndr : bndrs) (SpecType ty : args)
-  = do { let in_scope = Core.substInScope (se_subst env)
-             qvars    = scopedSort $
-                        filterOut (`elemInScopeSet` in_scope) $
-                        tyCoVarsOfTypeList ty
-             -- qvars are the type variables free in the call that
-             -- are not already in scope.  Quantify over these.
-             -- See Note [Specialising polymorphic dictionaries]
-             (env1, qvars') = substBndrs env qvars
-             ty'            = substTy env1 ty
-             env2           = extendTvSubstList env1 [(bndr, ty')]
-       ; (useful, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
-            <- specHeader env2 bndrs args
+specHeader env (bndr : bndrs) (SpecType t : args)
+  = do { let env' = extendTvSubstList env [(bndr, t)]
+       ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
+            <- specHeader env' bndrs args
        ; pure ( useful
-              , env3
+              , env''
               , leftover_bndrs
-              , qvars' ++ rule_bs
-              , Type ty' : rule_es
-              , qvars' ++ bs'
+              , rule_bs
+              , Type t : rule_es
+              , bs'
               , dx
-              , Type ty' : spec_args
+              , Type t : spec_args
               )
        }
 
@@ -2433,28 +2399,16 @@ specHeader env (bndr : bndrs) (UnspecArg : args)
          let (env', bndr') = substBndr env (zapIdOccInfo bndr)
        ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
              <- specHeader env' bndrs args
-
-       ; let bndr_ty = idType bndr'
-
-             -- See Note [Drop dead args from specialisations]
-             -- C.f. GHC.Core.Opt.WorkWrap.Utils.mk_absent_let
-             (mb_spec_bndr, spec_arg)
-                | isDeadBinder bndr
-                , Just lit_expr <- mkLitRubbish bndr_ty
-                = (Nothing, lit_expr)
-                | otherwise
-                = (Just bndr', varToCoreExpr bndr')
-
        ; pure ( useful
               , env''
               , leftover_bndrs
               , bndr' : rule_bs
               , varToCoreExpr bndr' : rule_es
-              , case mb_spec_bndr of
-                  Just b' -> b' : bs'
-                  Nothing -> bs'
+              , if isDeadBinder bndr
+                  then bs' -- see Note [Drop dead args from specialisations]
+                  else bndr' : bs'
               , dx
-              , spec_arg : spec_args
+              , varToCoreExpr bndr' : spec_args
               )
        }
 
@@ -2616,64 +2570,6 @@ successfully specialise 'f'.
 
 So the DictBinds in (ud_binds :: Bag DictBind) may contain
 non-dictionary bindings too.
-
-It's important to add the dictionary binders that are currently in-float to the
-InScopeSet of the SpecEnv before calling 'specBind'. That's what we do when we
-call 'bringFloatedDictsIntoScope'.
-
-Note [Specialising polymorphic dictionaries]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-    class M a where { foo :: a -> Int }
-
-    instance M (ST s) where ...
-    -- dMST :: forall s. M (ST s)
-
-    wimwam :: forall a. M a => a -> Int
-    wimwam = /\a \(d::M a). body
-
-    f :: ST s -> Int
-    f = /\s \(x::ST s). wimwam @(ST s) (dMST @s) dx + 1
-
-We'd like to specialise wimwam at (ST s), thus
-    $swimwam :: forall s. ST s -> Int
-    $swimwam = /\s. body[ST s/a, (dMST @s)/d]
-
-    RULE forall s (d :: M (ST s)).
-         wimwam @(ST s) d = $swimwam @s
-
-Here are the moving parts:
-
-* We must /not/ dump the CallInfo
-    CIS wimwam (CI { ci_key = [@(ST s), dMST @s]
-                   , ci_fvs = {dMST} })
-  when we come to the /\s.  Instead, we simply let it continue to float
-  upwards. Hence ci_fvs is an IdSet, listing the /Ids/ that
-  are free in the call, but not the /TyVars/.  Hence using specArgFreeIds
-  in singleCall.
-
-  NB to be fully kosher we should explicitly quantifying the CallInfo
-  over 's', but we don't bother.  This would matter if there was an
-  enclosing binding of the same 's', which I don't expect to happen.
-
-* Whe we come to specialise the call, we must remember to quantify
-  over 's'.  That is done in the SpecType case of specHeader, where
-  we add 's' (called qvars) to the binders of the RULE and the specialised
-  function.
-
-* If we have f :: forall m. Monoid m => blah, and two calls
-     (f @(Endo b)      (d :: Monoid (Endo b))
-     (f @(Endo (c->c)) (d :: Monoid (Endo (c->c)))
-  we want to generate a specialisation only for the first.  The second
-  is just a substitution instance of the first, with no greater specialisation.
-  Hence the call to `remove_dups` in `filterCalls`.
-
-All this arose in #13873, in the unexpected form that a SPECIALISE
-pragma made the program slower!  The reason was that the specialised
-function $sinsertWith arising from the pragma looked rather like `f`
-above, and failed to specialise a call in its body like wimwam.
-Without the pragma, the original call to `insertWith` was completely
-monomorphic, and specialised in one go.
 -}
 
 instance Outputable DictBind where
@@ -2714,7 +2610,6 @@ data CallInfo
        , ci_fvs  :: IdSet       -- Free Ids of the ci_key call
                                 -- _not_ including the main id itself, of course
                                 -- NB: excluding tyvars:
-                                --     See Note [Specialising polymorphic dictionaries]
     }
 
 type DictExpr = CoreExpr
@@ -2769,7 +2664,7 @@ singleCall id args
                      unitBag (CI { ci_key  = args -- used to be tys
                                  , ci_fvs  = call_fvs }) }
   where
-    call_fvs = foldr (unionVarSet . specArgFreeIds) emptyVarSet args
+    call_fvs = foldr (unionVarSet . specArgFreeVars) emptyVarSet args
         -- The type args (tys) are guaranteed to be part of the dictionary
         -- types, because they are just the constrained types,
         -- and the dictionary is therefore sure to be bound
@@ -3059,15 +2954,15 @@ callsForMe fn uds@MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }
 
 ----------------------
 filterCalls :: CallInfoSet -> FloatedDictBinds -> [CallInfo]
--- Remove dominated calls (Note [Specialising polymorphic dictionaries])
+-- Remove dominated calls
 -- and loopy DFuns (Note [Avoiding loops (DFuns)])
 filterCalls (CIS fn call_bag) (FDB { fdb_binds = dbs })
   | isDFunId fn  -- Note [Avoiding loops (DFuns)] applies only to DFuns
-  = filter ok_call de_dupd_calls
+  = filter ok_call unfiltered_calls
   | otherwise         -- Do not apply it to non-DFuns
-  = de_dupd_calls  -- See Note [Avoiding loops (non-DFuns)]
+  = unfiltered_calls  -- See Note [Avoiding loops (non-DFuns)]
   where
-    de_dupd_calls = remove_dups call_bag
+    unfiltered_calls = bagToList call_bag
 
     dump_set = foldl' go (unitVarSet fn) dbs
       -- This dump-set could also be computed by splitDictBinds
@@ -3081,29 +2976,6 @@ filterCalls (CIS fn call_bag) (FDB { fdb_binds = dbs })
 
     ok_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` dump_set
 
-remove_dups :: Bag CallInfo -> [CallInfo]
-remove_dups calls = foldr add [] calls
-  where
-    add :: CallInfo -> [CallInfo] -> [CallInfo]
-    add ci [] = [ci]
-    add ci1 (ci2:cis) | ci2 `beats_or_same` ci1 = ci2:cis
-                      | ci1 `beats_or_same` ci2 = ci1:cis
-                      | otherwise               = ci2 : add ci1 cis
-
-beats_or_same :: CallInfo -> CallInfo -> Bool
-beats_or_same (CI { ci_key = args1 }) (CI { ci_key = args2 })
-  = go args1 args2
-  where
-    go [] _ = True
-    go (arg1:args1) (arg2:args2) = go_arg arg1 arg2 && go args1 args2
-    go (_:_)        []           = False
-
-    go_arg (SpecType ty1) (SpecType ty2) = isJust (tcMatchTy ty1 ty2)
-    go_arg UnspecType     UnspecType     = True
-    go_arg (SpecDict {})  (SpecDict {})  = True
-    go_arg UnspecArg      UnspecArg      = True
-    go_arg _              _              = False
-
 ----------------------
 splitDictBinds :: FloatedDictBinds -> IdSet -> (FloatedDictBinds, Bag DictBind, IdSet)
 -- splitDictBinds dbs bndrs returns
@@ -3134,18 +3006,15 @@ splitDictBinds (FDB { fdb_binds = dbs, fdb_bndrs = bs }) bndr_set
 
 ----------------------
 deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails
--- Remove calls mentioning any Id in bndrs
--- NB: The call is allowed to mention TyVars in bndrs
---     Note [Specialising polymorphic dictionaries]
---     ci_fvs are just the free /Ids/
-deleteCallsMentioning bndrs calls
+-- Remove calls *mentioning* bs in any way
+deleteCallsMentioning bs calls
   = mapDVarEnv (ciSetFilter keep_call) calls
   where
-    keep_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` bndrs
+    keep_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` bs
 
 deleteCallsFor :: [Id] -> CallDetails -> CallDetails
--- Remove calls *for* bndrs
-deleteCallsFor bndrs calls = delDVarEnvList calls bndrs
+-- Remove calls *for* bs
+deleteCallsFor bs calls = delDVarEnvList calls bs
 
 {-
 ************************************************************************
diff --git a/testsuite/tests/numeric/should_compile/T19641.stderr b/testsuite/tests/numeric/should_compile/T19641.stderr
index b79d0217ee..8f6e3696be 100644
--- a/testsuite/tests/numeric/should_compile/T19641.stderr
+++ b/testsuite/tests/numeric/should_compile/T19641.stderr
@@ -3,13 +3,6 @@
 Result size of Tidy Core
   = {terms: 22, types: 20, coercions: 0, joins: 0/0}
 
-natural_to_word
-  = \ x ->
-      case x of {
-        NS x1 -> Just (W# x1);
-        NB ds -> Nothing
-      }
-
 integer_to_int
   = \ x ->
       case x of {
@@ -18,15 +11,22 @@ integer_to_int
         IN ds -> Nothing
       }
 
+natural_to_word
+  = \ x ->
+      case x of {
+        NS x1 -> Just (W# x1);
+        NB ds -> Nothing
+      }
+
 
 ------ Local rules for imported ids --------
-"SPEC/Test toIntegralSized @Integer @Int"
-    forall $dIntegral $dIntegral1 $dBits $dBits1.
-      toIntegralSized $dIntegral $dIntegral1 $dBits $dBits1
-      = integer_to_int
 "SPEC/Test toIntegralSized @Natural @Word"
     forall $dIntegral $dIntegral1 $dBits $dBits1.
       toIntegralSized $dIntegral $dIntegral1 $dBits $dBits1
       = natural_to_word
+"SPEC/Test toIntegralSized @Integer @Int"
+    forall $dIntegral $dIntegral1 $dBits $dBits1.
+      toIntegralSized $dIntegral $dIntegral1 $dBits $dBits1
+      = integer_to_int
 
 
diff --git a/testsuite/tests/simplCore/should_compile/T8331.stderr b/testsuite/tests/simplCore/should_compile/T8331.stderr
index 7219016651..0fbd7a577c 100644
--- a/testsuite/tests/simplCore/should_compile/T8331.stderr
+++ b/testsuite/tests/simplCore/should_compile/T8331.stderr
@@ -1,60 +1,5 @@
 
 ==================== Tidy Core rules ====================
-"SPEC $c*> @(ST s) _"
-    forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
-      $fApplicativeReaderT_$c*> @(ST s) @r $dApplicative
-      = ($fApplicativeReaderT3 @s @r)
-        `cast` (forall (a :: <*>_N) (b :: <*>_N).
-                <ReaderT r (ST s) a>_R
-                %<'Many>_N ->_R <ReaderT r (ST s) b>_R
-                %<'Many>_N ->_R <r>_R %<'Many>_N ->_R Sym (N:ST[0] <s>_N <b>_R)
-                                ; Sym (N:ReaderT[0] <*>_N <r>_R <ST s>_R <b>_N)
-                :: Coercible
-                     (forall {a} {b}.
-                      ReaderT r (ST s) a -> ReaderT r (ST s) b -> r -> STRep s b)
-                     (forall {a} {b}.
-                      ReaderT r (ST s) a -> ReaderT r (ST s) b -> ReaderT r (ST s) b))
-"SPEC $c>> @(ST s) _"
-    forall (@s) (@r) ($dMonad :: Monad (ST s)).
-      $fMonadReaderT1 @(ST s) @r $dMonad
-      = $fMonadAbstractIOSTReaderT_$s$c>> @s @r
-"SPEC $cliftA2 @(ST s) _"
-    forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
-      $fApplicativeReaderT_$cliftA2 @(ST s) @r $dApplicative
-      = ($fApplicativeReaderT1 @s @r)
-        `cast` (forall (a :: <*>_N) (b :: <*>_N) (c :: <*>_N).
-                <a -> b -> c>_R
-                %<'Many>_N ->_R <ReaderT r (ST s) a>_R
-                %<'Many>_N ->_R <ReaderT r (ST s) b>_R
-                %<'Many>_N ->_R <r>_R %<'Many>_N ->_R Sym (N:ST[0] <s>_N <c>_R)
-                                ; Sym (N:ReaderT[0] <*>_N <r>_R <ST s>_R <c>_N)
-                :: Coercible
-                     (forall {a} {b} {c}.
-                      (a -> b -> c)
-                      -> ReaderT r (ST s) a -> ReaderT r (ST s) b -> r -> STRep s c)
-                     (forall {a} {b} {c}.
-                      (a -> b -> c)
-                      -> ReaderT r (ST s) a -> ReaderT r (ST s) b -> ReaderT r (ST s) c))
-"SPEC $cp1Applicative @(ST s) _"
-    forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
-      $fApplicativeReaderT_$cp1Applicative @(ST s) @r $dApplicative
-      = $fApplicativeReaderT_$s$fFunctorReaderT @s @r
-"SPEC $cp1Monad @(ST s) _"
-    forall (@s) (@r) ($dMonad :: Monad (ST s)).
-      $fMonadReaderT_$cp1Monad @(ST s) @r $dMonad
-      = $fApplicativeReaderT_$s$fApplicativeReaderT @s @r
-"SPEC $fApplicativeReaderT @(ST s) _"
-    forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
-      $fApplicativeReaderT @(ST s) @r $dApplicative
-      = $fApplicativeReaderT_$s$fApplicativeReaderT @s @r
-"SPEC $fFunctorReaderT @(ST s) _"
-    forall (@s) (@r) ($dFunctor :: Functor (ST s)).
-      $fFunctorReaderT @(ST s) @r $dFunctor
-      = $fApplicativeReaderT_$s$fFunctorReaderT @s @r
-"SPEC $fMonadReaderT @(ST s) _"
-    forall (@s) (@r) ($dMonad :: Monad (ST s)).
-      $fMonadReaderT @(ST s) @r $dMonad
-      = $fMonadAbstractIOSTReaderT_$s$fMonadReaderT @s @r
 "SPEC useAbstractMonad"
     forall (@s)
            ($dMonadAbstractIOST :: MonadAbstractIOST (ReaderT Int (ST s))).
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 7f1af1be06..3b78531e5e 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -352,7 +352,7 @@ test('T19586', normal, compile, [''])
 
 test('T19599', normal, compile, ['-O -ddump-rules'])
 test('T19599a', normal, compile, ['-O -ddump-rules'])
-test('T13873',  [ grep_errmsg(r'SPEC') ], compile, ['-O -ddump-rules'])
+test('T13873',  [expect_broken(21229), grep_errmsg(r'SPEC') ], compile, ['-O -ddump-rules'])
 
 # Look for a specialisation rule for wimwam
 test('T19672', normal, compile, ['-O2 -ddump-rules'])