Do not strictify a DFun's parameter dictionaries (#22549)

... thus fixing #22549.

The details are in the refurbished and no longer dead
`Note [Do not strictify a DFun's parameter dictionaries]`.

There's a regression test in T22549.

5 files changed, 106 insertions, 38 deletions

diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs
index 74316e1e1b..3738f8b3ed 100644
--- a/compiler/GHC/Core/Opt/DmdAnal.hs
+++ b/compiler/GHC/Core/Opt/DmdAnal.hs
@@ -290,8 +290,10 @@ dmdAnalBind
 dmdAnalBind top_lvl env dmd bind anal_body = case bind of
   NonRec id rhs
     | useLetUp top_lvl id
-    -> dmdAnalBindLetUp   top_lvl env     id rhs anal_body
-  _ -> dmdAnalBindLetDown top_lvl env dmd bind   anal_body
+    -> dmdAnalBindLetUp   top_lvl env_rhs     id rhs anal_body
+  _ -> dmdAnalBindLetDown top_lvl env_rhs dmd bind   anal_body
+  where
+    env_rhs = enterDFun bind env
 
 -- | Annotates uninteresting top level functions ('isInterestingTopLevelFn')
 -- with 'topDmd', the rest with the given demand.
@@ -1759,6 +1761,10 @@ We never unbox class dictionaries in worker/wrapper.
    occur without INLINABLE, when we use -fexpose-all-unfoldings and
    -fspecialise-aggressively to do vigorous cross-module specialisation.
 
+3. #18421 found that unboxing a dictionary can also make the worker less likely
+   to inline; the inlining heuristics seem to prefer to inline a function
+   applied to a dictionary over a function applied to a bunch of functions.
+
 TL;DR we /never/ unbox class dictionaries. Unboxing the dictionary, and passing
 a raft of higher-order functions isn't a huge win anyway -- you really want to
 specialise the function.
@@ -2242,14 +2248,6 @@ addLazyFVs dmd_ty lazy_fvs
         -- L demand doesn't get both'd with the Bot coming up from the inner
         -- call to f.  So we just get an L demand for x for g.
 
-{-
-Note [Do not strictify the argument dictionaries of a dfun]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The typechecker can tie recursive knots involving dfuns, so we do the
-conservative thing and refrain from strictifying a dfun's argument
-dictionaries.
--}
-
 setBndrsDemandInfo :: HasCallStack => [Var] -> [Demand] -> [Var]
 setBndrsDemandInfo (b:bs) ds
   | isTyVar b = b : setBndrsDemandInfo bs ds
@@ -2388,6 +2386,16 @@ emptyAnalEnv opts fam_envs
          , ae_rec_dc       = memoiseUniqueFun (isRecDataCon fam_envs 3)
          }
 
+-- | Unset the 'dmd_strict_dicts' flag if any of the given bindings is a DFun
+-- binding. Part of the mechanism that detects
+-- Note [Do not strictify a DFun's parameter dictionaries].
+enterDFun :: CoreBind -> AnalEnv -> AnalEnv
+enterDFun bind env
+  | any isDFunId (bindersOf bind)
+  = env { ae_opts = (ae_opts env) { dmd_strict_dicts = False } }
+  | otherwise
+  = env
+
 emptySigEnv :: SigEnv
 emptySigEnv = emptyVarEnv
 
@@ -2439,31 +2447,29 @@ findBndrDmd env dmd_ty id
     id_ty = idType id
 
     strictify dmd
-      -- See Note [Making dictionaries strict]
+      -- See Note [Making dictionary parameters strict]
+      -- and Note [Do not strictify a DFun's parameter dictionaries]
       | dmd_strict_dicts (ae_opts env)
-             -- We never want to strictify a recursive let. At the moment
-             -- findBndrDmd is never called for recursive lets; if that
-             -- changes, we need a RecFlag parameter and another guard here.
       = strictifyDictDmd id_ty dmd
       | otherwise
       = dmd
 
     fam_envs = ae_fam_envs env
 
-{- Note [Making dictionaries strict]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Making dictionary parameters strict]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The Opt_DictsStrict flag makes GHC use call-by-value for dictionaries.  Why?
 
 * Generally CBV is more efficient.
 
-* Dictionaries are always non-bottom; and never take much work to
-  compute.  E.g. a dfun from an instance decl always returns a dictionary
+* A datatype dictionary is always non-bottom and never takes much work to
+  compute.  E.g. a DFun from an instance decl always returns a dictionary
   record immediately.  See DFunUnfolding in CoreSyn.
   See also Note [Recursive superclasses] in TcInstDcls.
 
-* The strictness analyser will then unbox dictionaries and pass the
-  methods individually, rather than in a bundle.  If there are a lot of
-  methods that might be bad; but worker/wrapper already does throttling.
+See #17758 for more background and perf numbers.
+
+Wrinkles:
 
 * A newtype dictionary is *not* always non-bottom.  E.g.
       class C a where op :: a -> a
@@ -2471,26 +2477,44 @@ The Opt_DictsStrict flag makes GHC use call-by-value for dictionaries.  Why?
   Now a value of type (C Int) is just a newtype wrapper (a cast) around
   the error thunk.  Don't strictify these!
 
-See #17758 for more background and perf numbers.
+* Strictifying DFuns risks destroying the invariant that DFuns never take much
+  work to compute, so we don't do it.
+  See Note [Do not strictify a DFun's parameter dictionaries] for details.
+
+* Although worker/wrapper *could* unbox strictly used dictionaries, we do not do
+  so; see Note [Do not unbox class dictionaries].
 
 The implementation is extremely simple: just make the strictness
 analyser strictify the demand on a dictionary binder in
-'findBndrDmd'.
-
-However there is one case where this can make performance worse.
-For the principle consider some function at the core level:
-    myEq :: Eq a => a -> a -> Bool
-    myEq eqDict x y = ((==) eqDict) x y
-If we make the dictionary strict then WW can fire turning this into:
-    $wmyEq :: (a -> a -> Bool) -> a -> a -> Bool
-    $wmyEq eq x y = eq x y
-Which *usually* performs better. However if the dictionary is known we
-are far more likely to inline a function applied to the dictionary than
-to inline one applied to a function. Sometimes this makes just enough
-of a difference to stop a function from inlining. This is documented in #18421.
-
-It's somewhat similar to Note [Do not unbox class dictionaries] although
-here our problem is with the inliner, not the specializer.
+'findBndrDmd' if the binder does not belong to a DFun.
+
+Note [Do not strictify a DFun's parameter dictionaries]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The typechecker can tie recursive knots involving (non-recursive) DFuns, so
+we must not strictify a DFun's parameter dictionaries (#22549).
+T22549 has an example involving undecidable instances that <<loop>>s when we
+strictify the DFun of, e.g., `$fEqSeqT`:
+
+  Main.$fEqSeqT
+    = \@m @a ($dEq :: Eq (m (ViewT m a))) ($dMonad :: Monad m) ->
+        GHC.Classes.C:Eq @(SeqT m a) ($c== @m @a $dEq $dMonad)
+                                     ($c/= @m @a $dEq $dMonad)
+
+  Rec {
+    $dEq_a = Main.$fEqSeqT @Identity @Int $dEq_b Main.$fMonadIdentity
+    $dEq_b = ... $dEq_a ... <another strict context due to DFun>
+  }
+
+If we make `$fEqSeqT` strict in `$dEq`, we'll collapse the Rec group into a
+giant, <<loop>>ing thunk.
+
+To prevent that, we never strictify dictionary params when inside a DFun.
+That is implemented by unsetting 'dmd_strict_dicts' when entering a DFun.
+
+See also Note [Speculative evaluation] in GHC.CoreToStg.Prep which has a rather
+similar example in #20836. We may never speculate *arguments* of (recursive)
+DFun calls, likewise we should not mark *formal parameters* of recursive DFuns
+as strict.
 
 Note [Initialising strictness]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs
index d0a56f9166..0b9259bc0e 100644
--- a/compiler/GHC/CoreToStg/Prep.hs
+++ b/compiler/GHC/CoreToStg/Prep.hs
@@ -1708,6 +1708,10 @@ Fortunately, pce_rec_ids already has all the information we need in that case.
 The problem is very similar to Note [Eta reduction in recursive RHSs].
 Here as well as there it is *unsound* to change the termination properties
 of the very function whose termination properties we are exploiting.
+
+It is also similar to Note [Do not strictify a DFun's parameter dictionaries],
+where marking recursive DFuns (of undecidable *instances*) strict in dictionary
+*parameters* leads to quite the same change in termination as above.
 -}
 
 data FloatingBind
diff --git a/testsuite/tests/stranal/should_run/T22549.hs b/testsuite/tests/stranal/should_run/T22549.hs
new file mode 100644
index 0000000000..841ead007b
--- /dev/null
+++ b/testsuite/tests/stranal/should_run/T22549.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE MonoLocalBinds #-}
+{-# LANGUAGE DeriveFunctor #-}
+
+import Data.Function (on)
+
+newtype Identity a = Identity a deriving (Eq, Functor)
+instance Applicative Identity where
+  pure = Identity
+  Identity f <*> Identity a = Identity $ f a
+instance Monad Identity where
+  Identity a >>= f = f a
+
+data ViewT m a
+  = Empty
+  | a :< SeqT m a
+newtype SeqT m a = SeqT [m (ViewT m a)]
+
+toViewT :: Monad m => SeqT m a -> m (ViewT m a)
+toViewT (SeqT []) = pure Empty
+toViewT (SeqT (h : t)) = h >>= \case
+  Empty -> toViewT (SeqT t)
+  hi :< SeqT ti -> pure (hi :< SeqT (ti ++ t))
+
+instance (Eq (m (ViewT m a)), Monad m) => Eq (SeqT m a) where
+  (==) = (==) `on` toViewT
+
+deriving instance (Eq a, Eq (SeqT m a)) => Eq (ViewT m a)
+
+example :: SeqT Identity Int
+example = SeqT []
+
+main :: IO ()
+main = print (example == example)
diff --git a/testsuite/tests/stranal/should_run/T22549.stdout b/testsuite/tests/stranal/should_run/T22549.stdout
new file mode 100644
index 0000000000..0ca95142bb
--- /dev/null
+++ b/testsuite/tests/stranal/should_run/T22549.stdout
@@ -0,0 +1 @@
+True
diff --git a/testsuite/tests/stranal/should_run/all.T b/testsuite/tests/stranal/should_run/all.T
index a2b8e4cfc5..9da7863314 100644
--- a/testsuite/tests/stranal/should_run/all.T
+++ b/testsuite/tests/stranal/should_run/all.T
@@ -30,3 +30,5 @@ test('T19053', normal, compile_and_run, [''])
 test('T21717b', normal, compile_and_run, [''])
 test('T22475', normal, compile_and_run, [''])
 test('T22475b', normal, compile_and_run, [''])
+# T22549: Do not strictify DFuns, otherwise we will <<loop>>
+test('T22549', normal, compile_and_run, ['-fdicts-strict -fno-specialise'])