[Git][ghc/ghc][wip/T22549] Do not strictify a DFun's parameter dictionaries (#22549)
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Wed Dec 7 15:46:46 UTC 2022
Sebastian Graf pushed to branch wip/T22549 at Glasgow Haskell Compiler / GHC
Commits:
934947e9 by Sebastian Graf at 2022-12-07T16:46:39+01:00
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 changed files:
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/CoreToStg/Prep.hs
- + testsuite/tests/stranal/should_run/T22549.hs
- + testsuite/tests/stranal/should_run/T22549.stdout
- testsuite/tests/stranal/should_run/all.T
Changes:
=====================================
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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
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
=====================================
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)
=====================================
testsuite/tests/stranal/should_run/T22549.stdout
=====================================
@@ -0,0 +1 @@
+True
=====================================
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'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/934947e93113a7d6ce7391e4857e1e197864f3a0
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/934947e93113a7d6ce7391e4857e1e197864f3a0
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221207/7f7ad967/attachment-0001.html>
More information about the ghc-commits
mailing list