[Git][ghc/ghc][wip/backports-9.4] 6 commits: Fix a nasty loop in Tidy
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Fri Oct 14 20:24:20 UTC 2022
Ben Gamari pushed to branch wip/backports-9.4 at Glasgow Haskell Compiler / GHC
Commits:
2cf828e8 by Simon Peyton Jones at 2022-09-15T10:28:17+02:00
Fix a nasty loop in Tidy
As the remarkably-simple #22112 showed, we were making a black hole
in the unfolding of a self-recursive binding. Boo!
It's a bit tricky. Documented in GHC.Iface.Tidy,
Note [tidyTopUnfolding: avoiding black holes]
This is the 9.4 packport based on
commit 4945953823620b223a0b51b2b1275a1de8f4a851
- - - - -
15c496c5 by Sebastian Graf at 2022-10-12T19:20:16-04:00
Ignore .hie-bios
(cherry picked from commit 2563b95cda983cd6be23a5be01fe1f1873f1fa4f)
- - - - -
26af15a0 by Sebastian Graf at 2022-10-12T19:20:16-04:00
CprAnal: Set signatures of DFuns to top
The recursive DFun in the reproducer for #20836 also triggered a bug in CprAnal
that is observable in a debug build. The CPR signature of a recursive DFunId
was never updated and hence the optimistic arity 0 bottom signature triggered a
mismatch with the arity 1 of the binding in WorkWrap. We never miscompiled any
code because WW doesn't exploit bottom CPR signatures.
(cherry picked from commit 94f2e92a2510a3338c5201a4dcc69666fa9575f8)
- - - - -
ecb6accd by Sebastian Graf at 2022-10-14T16:16:07-04:00
CorePrep: Don't speculatively evaluate recursive calls (#20836)
In #20836 we have optimised a terminating program into an endless loop,
because we speculated the self-recursive call of a recursive DFun.
Now we track the set of enclosing recursive binders in CorePrep to prevent
speculation of such self-recursive calls.
See the updates to Note [Speculative evaluation] for details.
Fixes #20836.
(cherry picked from commit b570da84b7aad5ca3f90f2d1c1a690c927e99fe9)
- - - - -
1431ee96 by Sebastian Graf at 2022-10-14T16:19:30-04:00
Simplify: Take care with eta reduction in recursive RHSs (#21652)
Similar to the fix to #20836 in CorePrep, we now track the set of enclosing
recursive binders in the SimplEnv and SimpleOptEnv.
See Note [Eta reduction in recursive RHSs] for details.
I also updated Note [Arity robustness] with the insights Simon and I had in a
call discussing the issue.
Fixes #21652.
Unfortunately, we get a 5% ghc/alloc regression in T16577. That is due to
additional eta reduction in GHC.Read.choose1 and the resulting ANF-isation
of a large list literal at the top-level that didn't happen before (presumably
because it was too interesting to float to the top-level). There's not much we
can do about that.
Metric Increase:
T16577
(cherry picked from commit 49fb2f9b16ca987648d2ac57eecf1892d49852ec)
- - - - -
3e4a38c8 by Ben Gamari at 2022-10-14T16:24:01-04:00
CmmToLlvm: Don't aliasify builtin LLVM variables
Our aliasification logic would previously turn builtin LLVM variables
into aliases, which apparently confuses LLVM. This manifested in
initializers failing to be emitted, resulting in many profiling failures
with the LLVM backend.
Fixes #22019.
(cherry picked from commit cd6f5bfd0cc2bcf74de1d9edb43fe4b338b4c4e3)
- - - - -
27 changed files:
- .gitignore
- compiler/GHC/CmmToLlvm/Base.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/CprAnal.hs
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/Tidy.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Data/Graph/UnVar.hs
- compiler/GHC/Iface/Tidy.hs
- compiler/GHC/Types/Id/Info.hs
- testsuite/tests/arityanal/should_compile/Arity03.stderr
- + testsuite/tests/arityanal/should_run/Makefile
- + testsuite/tests/arityanal/should_run/T21652.hs
- + testsuite/tests/arityanal/should_run/T21652.stdout
- + testsuite/tests/arityanal/should_run/all.T
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- testsuite/tests/deSugar/should_compile/T19969.stderr
- + testsuite/tests/simplCore/should_compile/T22112.hs
- + testsuite/tests/simplCore/should_compile/T22112.stderr
- testsuite/tests/simplCore/should_compile/all.T
- + testsuite/tests/simplCore/should_run/T20836.hs
- testsuite/tests/simplCore/should_run/all.T
Changes:
=====================================
.gitignore
=====================================
@@ -57,6 +57,7 @@ _*
*/ghc-stage1
.shake.*
.hadrian_ghci
+.hie-bios
# -----------------------------------------------------------------------------
# Ignore any overlapped darcs repos and back up files
=====================================
compiler/GHC/CmmToLlvm/Base.hs
=====================================
@@ -67,7 +67,7 @@ import GHC.Utils.Logger
import Data.Maybe (fromJust)
import Control.Monad (ap)
import Data.Char (isDigit)
-import Data.List (sortBy, groupBy, intercalate)
+import Data.List (sortBy, groupBy, intercalate, isPrefixOf)
import Data.Ord (comparing)
import qualified Data.List.NonEmpty as NE
@@ -550,6 +550,12 @@ generateExternDecls = do
modifyEnv $ \env -> env { envAliases = emptyUniqSet }
return (concat defss, [])
+-- | Is a variable one of the special @$llvm@ globals?
+isBuiltinLlvmVar :: LlvmVar -> Bool
+isBuiltinLlvmVar (LMGlobalVar lbl _ _ _ _ _) =
+ "$llvm" `isPrefixOf` unpackFS lbl
+isBuiltinLlvmVar _ = False
+
-- | Here we take a global variable definition, rename it with a
-- @$def@ suffix, and generate the appropriate alias.
aliasify :: LMGlobal -> LlvmM [LMGlobal]
@@ -557,8 +563,9 @@ aliasify :: LMGlobal -> LlvmM [LMGlobal]
-- Here we obtain the indirectee's precise type and introduce
-- fresh aliases to both the precise typed label (lbl$def) and the i8*
-- typed (regular) label of it with the matching new names.
-aliasify (LMGlobal (LMGlobalVar lbl ty at LMAlias{} link sect align Alias)
- (Just orig)) = do
+aliasify (LMGlobal var@(LMGlobalVar lbl ty at LMAlias{} link sect align Alias)
+ (Just orig))
+ | not $ isBuiltinLlvmVar var = do
let defLbl = llvmDefLabel lbl
LMStaticPointer (LMGlobalVar origLbl _ oLnk Nothing Nothing Alias) = orig
defOrigLbl = llvmDefLabel origLbl
@@ -571,7 +578,8 @@ aliasify (LMGlobal (LMGlobalVar lbl ty at LMAlias{} link sect align Alias)
pure [ LMGlobal (LMGlobalVar defLbl ty link sect align Alias) (Just defOrig)
, LMGlobal (LMGlobalVar lbl i8Ptr link sect align Alias) (Just orig')
]
-aliasify (LMGlobal var val) = do
+aliasify (LMGlobal var val)
+ | not $ isBuiltinLlvmVar var = do
let LMGlobalVar lbl ty link sect align const = var
defLbl = llvmDefLabel lbl
@@ -589,6 +597,7 @@ aliasify (LMGlobal var val) = do
return [ LMGlobal defVar val
, LMGlobal aliasVar (Just aliasVal)
]
+aliasify global = pure [global]
-- Note [Llvm Forward References]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -647,3 +656,6 @@ aliasify (LMGlobal var val) = do
-- away with casting the alias to the desired type in @getSymbolPtr@
-- and instead just emit a reference to the definition symbol directly.
-- This is the @Just@ case in @getSymbolPtr at .
+--
+-- Note that we must take care not to turn LLVM's builtin variables into
+-- aliases (e.g. $llvm.global_ctors) since this confuses LLVM.
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -59,6 +59,7 @@ import GHC.Types.Tickish
import GHC.Builtin.Uniques
import GHC.Data.FastString
+import GHC.Data.Graph.UnVar
import GHC.Data.Pair
import GHC.Utils.Constants (debugIsOn)
@@ -505,6 +506,67 @@ Suppose f = \xy. x+y
Then f :: \??.T
f v :: \?.T
f <expensive> :: T
+
+
+
+Note [Eta reduction in recursive RHSs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the following recursive function:
+ f = \x. ....g (\y. f y)....
+The recursive call of f in its own RHS seems like a fine opportunity for
+eta-reduction because f has arity 1. And often it is!
+
+Alas, that is unsound in general if the eta-reduction happens in a tail context.
+Making the arity visible in the RHS allows us to eta-reduce
+ f = \x -> f x
+to
+ f = f
+which means we optimise terminating programs like (f `seq` ()) into
+non-terminating ones. Nor is this problem just for tail calls. Consider
+ f = id (\x -> f x)
+where we have (for some reason) not yet inlined `id`. We must not eta-reduce to
+ f = id f
+because that will then simplify to `f = f` as before.
+
+An immediate idea might be to look at whether the called function is a local
+loopbreaker and refrain from eta-expanding. But that doesn't work for mutually
+recursive function like in #21652:
+ f = g
+ g* x = f x
+Here, g* is the loopbreaker but f isn't.
+
+What can we do?
+
+Fix 1: Zap `idArity` when analysing recursive RHSs and re-attach the info when
+ entering the let body.
+ Has the disadvantage that other transformations which make use of arity
+ (such as dropping of `seq`s when arity > 0) will no longer work in the RHS.
+ Plus it requires non-trivial refactorings to both the simple optimiser (in
+ the way `subst_opt_bndr` is used) as well as the Simplifier (in the way
+ `simplRecBndrs` and `simplRecJoinBndrs` is used), modifying the SimplEnv's
+ substitution twice in the process. A very complicated stop-gap.
+
+Fix 2: Pass the set of enclosing recursive binders to `tryEtaReduce`; these are
+ the ones we should not eta-reduce. All call-site must maintain this set.
+ Example:
+ rec { f1 = ....rec { g = ... (\x. g x)...(\y. f2 y)... }...
+ ; f2 = ...f1... }
+ when eta-reducing those inner lambdas, we need to know that we are in the
+ rec group for {f1, f2, g}.
+ This is very much like the solution in Note [Speculative evaluation] in
+ GHC.CoreToStg.Prep.
+ It is a bit tiresome to maintain this info, because it means another field
+ in SimplEnv and SimpleOptEnv.
+
+We implement Fix (2) because of it isn't as complicated to maintain as (1).
+Plus, it is the correct fix to begin with. After all, the arity is correct,
+but doing the transformation isn't. The moving parts are:
+ * A field `scRecIds` in `SimplEnv` tracks the enclosing recursive binders
+ * We extend the `scRecIds` set in `GHC.Core.Opt.Simplify.simplRecBind`
+ * We consult the set in `is_eta_reduction_sound` in `tryEtaReduce`
+The situation is very similar to Note [Speculative evaluation] which has the
+same fix.
+
-}
=====================================
compiler/GHC/Core/Opt/CprAnal.hs
=====================================
@@ -398,8 +398,10 @@ cprFix orig_env orig_pairs
where
init_sig id
-- See Note [CPR for data structures]
- | isDataStructure id = topCprSig
- | otherwise = mkCprSig 0 botCpr
+ -- Don't set the sig to bottom in this case, because cprAnalBind won't
+ -- update it to something reasonable. Result: Assertion error in WW
+ | isDataStructure id || isDFunId id = topCprSig
+ | otherwise = mkCprSig 0 botCpr
-- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal
orig_virgin = ae_virgin orig_env
init_pairs | orig_virgin = [(setIdCprSig id (init_sig id), rhs) | (id, rhs) <- orig_pairs ]
@@ -464,10 +466,10 @@ cprAnalBind env id rhs
| isDFunId id -- Never give DFuns the CPR property; we'll never save allocs.
= (id, rhs, extendSigEnv env id topCprSig)
-- See Note [CPR for data structures]
- | isDataStructure id
- = (id, rhs, env) -- Data structure => no code => no need to analyse rhs
+ | isDataStructure id -- Data structure => no code => no need to analyse rhs
+ = (id, rhs, env)
| otherwise
- = (id', rhs', env')
+ = (id `setIdCprSig` sig', rhs', env')
where
(rhs_ty, rhs') = cprAnal env rhs
-- possibly trim thunk CPR info
@@ -481,7 +483,6 @@ cprAnalBind env id rhs
-- See Note [The OPAQUE pragma and avoiding the reboxing of results]
sig' | isOpaquePragma (idInlinePragma id) = topCprSig
| otherwise = sig
- id' = setIdCprSig id sig'
env' = extendSigEnv env id sig'
-- See Note [CPR for thunks]
=====================================
compiler/GHC/Core/Opt/Simplify.hs
=====================================
@@ -64,6 +64,7 @@ import GHC.Builtin.Names( runRWKey )
import GHC.Data.Maybe ( isNothing, orElse )
import GHC.Data.FastString
import GHC.Unit.Module ( moduleName, pprModuleName )
+import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
@@ -256,9 +257,11 @@ simplRecBind :: SimplEnv -> BindContext
-> [(InId, InExpr)]
-> SimplM (SimplFloats, SimplEnv)
simplRecBind env0 bind_cxt pairs0
- = do { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0
- ; (rec_floats, env1) <- go env_with_info triples
- ; return (mkRecFloats rec_floats, env1) }
+ = do { (env1, triples) <- mapAccumLM add_rules env0 pairs0
+ ; let new_bndrs = map sndOf3 triples
+ ; (rec_floats, env2) <- enterRecGroupRHSs env1 new_bndrs $ \env ->
+ go env triples
+ ; return (mkRecFloats rec_floats, env2) }
where
add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr))
-- Add the (substituted) rules to the binder
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -17,7 +17,7 @@ module GHC.Core.Opt.Simplify.Env (
zapSubstEnv, setSubstEnv, bumpCaseDepth,
getInScope, setInScopeFromE, setInScopeFromF,
setInScopeSet, modifyInScope, addNewInScopeIds,
- getSimplRules,
+ getSimplRules, enterRecGroupRHSs,
-- * Substitution results
SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope,
@@ -55,6 +55,7 @@ import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Data.OrdList
+import GHC.Data.Graph.UnVar
import GHC.Types.Id as Id
import GHC.Core.Make ( mkWildValBinder )
import GHC.Driver.Session ( DynFlags )
@@ -96,6 +97,10 @@ data SimplEnv
, seCvSubst :: CvSubstEnv -- InCoVar |--> OutCoercion
, seIdSubst :: SimplIdSubst -- InId |--> OutExpr
+ -- | Fast OutVarSet tracking which recursive RHSs we are analysing.
+ -- See Note [Eta reduction in recursive RHSs] in GHC.Core.Opt.Arity.
+ , seRecIds :: !UnVarSet
+
----------- Dynamic part of the environment -----------
-- Dynamic in the sense of describing the setup where
-- the expression finally ends up
@@ -286,6 +291,7 @@ mkSimplEnv mode
, seTvSubst = emptyVarEnv
, seCvSubst = emptyVarEnv
, seIdSubst = emptyVarEnv
+ , seRecIds = emptyUnVarSet
, seCaseDepth = 0 }
-- The top level "enclosing CC" is "SUBSUMED".
@@ -391,6 +397,13 @@ modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv
modifyInScope env@(SimplEnv {seInScope = in_scope}) v
= env {seInScope = extendInScopeSet in_scope v}
+enterRecGroupRHSs :: SimplEnv -> [OutBndr] -> (SimplEnv -> SimplM (r, SimplEnv))
+ -> SimplM (r, SimplEnv)
+enterRecGroupRHSs env bndrs k = do
+ --pprTraceM "enterRecGroupRHSs" (ppr bndrs)
+ (r, env'') <- k env{seRecIds = extendUnVarSetList bndrs (seRecIds env)}
+ return (r, env''{seRecIds = seRecIds env})
+
{- Note [Setting the right in-scope set]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
@@ -886,31 +899,18 @@ seqIds (id:ids) = seqId id `seq` seqIds ids
Note [Arity robustness]
~~~~~~~~~~~~~~~~~~~~~~~
We *do* transfer the arity from the in_id of a let binding to the
-out_id. This is important, so that the arity of an Id is visible in
-its own RHS. For example:
- f = \x. ....g (\y. f y)....
-We can eta-reduce the arg to g, because f is a value. But that
-needs to be visible.
-
-This interacts with the 'state hack' too:
- f :: Bool -> IO Int
- f = \x. case x of
- True -> f y
- False -> \s -> ...
-Can we eta-expand f? Only if we see that f has arity 1, and then we
-take advantage of the 'state hack' on the result of
-(f y) :: State# -> (State#, Int) to expand the arity one more.
-
-There is a disadvantage though. Making the arity visible in the RHS
-allows us to eta-reduce
- f = \x -> f x
-to
- f = f
-which technically is not sound. This is very much a corner case, so
-I'm not worried about it. Another idea is to ensure that f's arity
-never decreases; its arity started as 1, and we should never eta-reduce
-below that.
-
+out_id so that its arity is visible in its RHS. Examples:
+
+ * f = \x y. let g = \p q. f (p+q) in Just (...g..g...)
+ Here we want to give `g` arity 3 and eta-expand. `findRhsArity` will have a
+ hard time figuring that out when `f` only has arity 0 in its own RHS.
+ * f = \x y. ....(f `seq` blah)....
+ We want to drop the seq.
+ * f = \x. g (\y. f y)
+ You'd think we could eta-reduce `\y. f y` to `f` here. And indeed, that is true.
+ Unfortunately, it is not sound in general to eta-reduce in f's RHS.
+ Example: `f = \x. f x`. See Note [Eta reduction in recursive RHSs] for how
+ we prevent that.
Note [Robust OccInfo]
~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1610,6 +1610,7 @@ mkLam env bndrs body cont
; mkLam' dflags bndrs body }
where
mode = getMode env
+ rec_ids = seRecIds env
mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr
mkLam' dflags bndrs body@(Lam {})
@@ -1633,7 +1634,7 @@ mkLam env bndrs body cont
mkLam' dflags bndrs body
| gopt Opt_DoEtaReduction dflags
- , Just etad_lam <- {-# SCC "tryee" #-} tryEtaReduce bndrs body
+ , Just etad_lam <- {-# SCC "tryee" #-} tryEtaReduce rec_ids bndrs body
= do { tick (EtaReduction (head bndrs))
; return etad_lam }
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -52,6 +52,7 @@ import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Data.Maybe ( orElse )
+import GHC.Data.Graph.UnVar
import Data.List (mapAccumL)
import qualified Data.ByteString as BS
@@ -193,6 +194,10 @@ data SimpleOptEnv
, soe_subst :: Subst
-- ^ Deals with cloning; includes the InScopeSet
+
+ , soe_rec_ids :: !UnVarSet
+ -- ^ Fast OutVarSet tracking which recursive RHSs we are analysing.
+ -- See Note [Eta reduction in recursive RHSs]
}
instance Outputable SimpleOptEnv where
@@ -205,6 +210,7 @@ emptyEnv :: SimpleOpts -> SimpleOptEnv
emptyEnv opts = SOE
{ soe_inl = emptyVarEnv
, soe_subst = emptySubst
+ , soe_rec_ids = emptyUnVarSet
, soe_co_opt_opts = so_co_opts opts
, soe_uf_opts = so_uf_opts opts
}
@@ -219,6 +225,13 @@ soeSetInScope (SOE { soe_subst = subst1 })
env2@(SOE { soe_subst = subst2 })
= env2 { soe_subst = setInScope subst2 (substInScope subst1) }
+enterRecGroupRHSs :: SimpleOptEnv -> [OutBndr] -> (SimpleOptEnv -> (SimpleOptEnv, r))
+ -> (SimpleOptEnv, r)
+enterRecGroupRHSs env bndrs k
+ = (env'{soe_rec_ids = soe_rec_ids env}, r)
+ where
+ (env', r) = k env{soe_rec_ids = extendUnVarSetList bndrs (soe_rec_ids env)}
+
---------------
simple_opt_clo :: SimpleOptEnv -> SimpleClo -> OutExpr
simple_opt_clo env (e_env, e)
@@ -228,6 +241,7 @@ simple_opt_expr :: HasCallStack => SimpleOptEnv -> InExpr -> OutExpr
simple_opt_expr env expr
= go expr
where
+ rec_ids = soe_rec_ids env
subst = soe_subst env
in_scope = substInScope subst
in_scope_env = (in_scope, simpleUnfoldingFun)
@@ -290,13 +304,16 @@ simple_opt_expr env expr
----------------------
-- go_lam tries eta reduction
+ -- It is quite important that it does so. I tried removing this code and
+ -- got a lot of regressions, e.g., +11% ghc/alloc in T18223 and many
+ -- run/alloc increases. Presumably RULEs are affected.
go_lam env bs' (Lam b e)
= go_lam env' (b':bs') e
where
(env', b') = subst_opt_bndr env b
go_lam env bs' e
- | Just etad_e <- tryEtaReduce bs e' = etad_e
- | otherwise = mkLams bs e'
+ | Just etad_e <- tryEtaReduce rec_ids bs e' = etad_e
+ | otherwise = mkLams bs e'
where
bs = reverse bs'
e' = simple_opt_expr env e
@@ -390,12 +407,13 @@ simple_opt_bind env (NonRec b r) top_level
(env', mb_pr) = simple_bind_pair env b' Nothing (env,r') top_level
simple_opt_bind env (Rec prs) top_level
- = (env'', res_bind)
+ = (env2, res_bind)
where
res_bind = Just (Rec (reverse rev_prs'))
prs' = joinPointBindings_maybe prs `orElse` prs
- (env', bndrs') = subst_opt_bndrs env (map fst prs')
- (env'', rev_prs') = foldl' do_pr (env', []) (prs' `zip` bndrs')
+ (env1, bndrs') = subst_opt_bndrs env (map fst prs')
+ (env2, rev_prs') = enterRecGroupRHSs env1 bndrs' $ \env ->
+ foldl' do_pr (env, []) (prs' `zip` bndrs')
do_pr (env, prs) ((b,r), b')
= (env', case mb_pr of
Just pr -> pr : prs
=====================================
compiler/GHC/Core/Tidy.hs
=====================================
@@ -10,7 +10,7 @@ The code for *top-level* bindings is in GHC.Iface.Tidy.
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Core.Tidy (
- tidyExpr, tidyRules, tidyUnfolding, tidyCbvInfoTop
+ tidyExpr, tidyRules, tidyCbvInfoTop, tidyBndrs
) where
import GHC.Prelude
@@ -345,33 +345,36 @@ tidyLetBndr rec_tidy_env env@(tidy_env, var_env) id
`setUnfoldingInfo` new_unf
old_unf = realUnfoldingInfo old_info
- new_unf | isStableUnfolding old_unf = tidyUnfolding rec_tidy_env old_unf old_unf
- | otherwise = trimUnfolding old_unf
- -- See Note [Preserve evaluatedness]
+ new_unf = tidyNestedUnfolding rec_tidy_env old_unf
in
((tidy_env', var_env'), id') }
------------ Unfolding --------------
-tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding
-tidyUnfolding tidy_env df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) _
+tidyNestedUnfolding :: TidyEnv -> Unfolding -> Unfolding
+tidyNestedUnfolding _ NoUnfolding = NoUnfolding
+tidyNestedUnfolding _ BootUnfolding = BootUnfolding
+tidyNestedUnfolding _ (OtherCon {}) = evaldUnfolding
+
+tidyNestedUnfolding tidy_env df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
= df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args }
where
(tidy_env', bndrs') = tidyBndrs tidy_env bndrs
-tidyUnfolding tidy_env
- unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })
- unf_from_rhs
+tidyNestedUnfolding tidy_env
+ unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_is_value = is_value })
| isStableSource src
= seqIt $ unf { uf_tmpl = tidyExpr tidy_env unf_rhs } -- Preserves OccInfo
- -- This seqIt avoids a space leak: otherwise the uf_is_value,
- -- uf_is_conlike, ... fields may retain a reference to the
- -- pre-tidied expression forever (GHC.CoreToIface doesn't look at them)
-
- | otherwise
- = unf_from_rhs
- where seqIt unf = seqUnfolding unf `seq` unf
-tidyUnfolding _ unf _ = unf -- NoUnfolding or OtherCon
+ -- This seqIt avoids a space leak: otherwise the uf_is_value,
+ -- uf_is_conlike, ... fields may retain a reference to the
+ -- pre-tidied expression forever (GHC.CoreToIface doesn't look at them)
+
+ -- Discard unstable unfoldings, but see Note [Preserve evaluatedness]
+ | is_value = evaldUnfolding
+ | otherwise = noUnfolding
+
+ where
+ seqIt unf = seqUnfolding unf `seq` unf
{-
Note [Tidy IdInfo]
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -26,8 +26,8 @@ module GHC.Core.Utils (
exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsDeadEnd,
getIdFromTrivialExpr_maybe,
exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun,
- exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree,
- exprIsConLike,
+ exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprOkForSpecEval,
+ exprIsWorkFree, exprIsConLike,
isCheapApp, isExpandableApp, isSaturatedConApp,
exprIsTickedString, exprIsTickedString_maybe,
exprIsTopLevelBindable,
@@ -86,6 +86,7 @@ import GHC.Core.Map.Expr ( eqCoreExpr )
import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofIdKey )
import GHC.Builtin.PrimOps
+import GHC.Data.Graph.UnVar
import GHC.Types.Var
import GHC.Types.SrcLoc
import GHC.Types.Var.Env
@@ -1563,45 +1564,55 @@ it's applied only to dictionaries.
-- side effects, and can't diverge or raise an exception.
exprOkForSpeculation, exprOkForSideEffects :: CoreExpr -> Bool
-exprOkForSpeculation = expr_ok primOpOkForSpeculation
-exprOkForSideEffects = expr_ok primOpOkForSideEffects
-
-expr_ok :: (PrimOp -> Bool) -> CoreExpr -> Bool
-expr_ok _ (Lit _) = True
-expr_ok _ (Type _) = True
-expr_ok _ (Coercion _) = True
-
-expr_ok primop_ok (Var v) = app_ok primop_ok v []
-expr_ok primop_ok (Cast e _) = expr_ok primop_ok e
-expr_ok primop_ok (Lam b e)
- | isTyVar b = expr_ok primop_ok e
+exprOkForSpeculation = expr_ok fun_always_ok primOpOkForSpeculation
+exprOkForSideEffects = expr_ok fun_always_ok primOpOkForSideEffects
+
+fun_always_ok :: Id -> Bool
+fun_always_ok _ = True
+
+-- | A special version of 'exprOkForSpeculation' used during
+-- Note [Speculative evaluation]. When the predicate arg `fun_ok` returns False
+-- for `b`, then `b` is never considered ok-for-spec.
+exprOkForSpecEval :: (Id -> Bool) -> CoreExpr -> Bool
+exprOkForSpecEval fun_ok = expr_ok fun_ok primOpOkForSpeculation
+
+expr_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool
+expr_ok _ _ (Lit _) = True
+expr_ok _ _ (Type _) = True
+expr_ok _ _ (Coercion _) = True
+
+expr_ok fun_ok primop_ok (Var v) = app_ok fun_ok primop_ok v []
+expr_ok fun_ok primop_ok (Cast e _) = expr_ok fun_ok primop_ok e
+expr_ok fun_ok primop_ok (Lam b e)
+ | isTyVar b = expr_ok fun_ok primop_ok e
| otherwise = True
-- Tick annotations that *tick* cannot be speculated, because these
-- are meant to identify whether or not (and how often) the particular
-- source expression was evaluated at runtime.
-expr_ok primop_ok (Tick tickish e)
+expr_ok fun_ok primop_ok (Tick tickish e)
| tickishCounts tickish = False
- | otherwise = expr_ok primop_ok e
+ | otherwise = expr_ok fun_ok primop_ok e
-expr_ok _ (Let {}) = False
+expr_ok _ _ (Let {}) = False
-- Lets can be stacked deeply, so just give up.
-- In any case, the argument of exprOkForSpeculation is
-- usually in a strict context, so any lets will have been
-- floated away.
-expr_ok primop_ok (Case scrut bndr _ alts)
+expr_ok fun_ok primop_ok (Case scrut bndr _ alts)
= -- See Note [exprOkForSpeculation: case expressions]
- expr_ok primop_ok scrut
+ expr_ok fun_ok primop_ok scrut
&& isUnliftedType (idType bndr)
-- OK to call isUnliftedType: binders always have a fixed RuntimeRep
- && all (\(Alt _ _ rhs) -> expr_ok primop_ok rhs) alts
+ && all (\(Alt _ _ rhs) -> expr_ok fun_ok primop_ok rhs) alts
&& altsAreExhaustive alts
-expr_ok primop_ok other_expr
+expr_ok fun_ok primop_ok other_expr
| (expr, args) <- collectArgs other_expr
= case stripTicksTopE (not . tickishCounts) expr of
- Var f -> app_ok primop_ok f args
+ Var f ->
+ app_ok fun_ok primop_ok f args
-- 'LitRubbish' is the only literal that can occur in the head of an
-- application and will not be matched by the above case (Var /= Lit).
@@ -1615,8 +1626,11 @@ expr_ok primop_ok other_expr
_ -> False
-----------------------------
-app_ok :: (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool
-app_ok primop_ok fun args
+app_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool
+app_ok fun_ok primop_ok fun args
+ | not (fun_ok fun)
+ = False -- This code path is only taken for Note [Speculative evaluation]
+ | otherwise
= case idDetails fun of
DFunId new_type -> not new_type
-- DFuns terminate, unless the dict is implemented
@@ -1630,7 +1644,7 @@ app_ok primop_ok fun args
PrimOpId op
| primOpIsDiv op
, [arg1, Lit lit] <- args
- -> not (isZeroLit lit) && expr_ok primop_ok arg1
+ -> not (isZeroLit lit) && expr_ok fun_ok primop_ok arg1
-- Special case for dividing operations that fail
-- In general they are NOT ok-for-speculation
-- (which primop_ok will catch), but they ARE OK
@@ -1679,7 +1693,7 @@ app_ok primop_ok fun args
| Just Lifted <- typeLevity_maybe (scaledThing ty)
= True -- See Note [Primops with lifted arguments]
| otherwise
- = expr_ok primop_ok arg
+ = expr_ok fun_ok primop_ok arg
-----------------------------
altsAreExhaustive :: [Alt b] -> Bool
@@ -2415,8 +2429,8 @@ need to address that here.
-- When updating this function, make sure to update
-- CorePrep.tryEtaReducePrep as well!
-tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr
-tryEtaReduce bndrs body
+tryEtaReduce :: UnVarSet -> [Var] -> CoreExpr -> Maybe CoreExpr
+tryEtaReduce rec_ids bndrs body
= go (reverse bndrs) body (mkRepReflCo (exprType body))
where
incoming_arity = count isId bndrs
@@ -2455,14 +2469,15 @@ tryEtaReduce bndrs body
ok_fun _fun = False
---------------
- ok_fun_id fun = -- There are arguments to reduce...
- fun_arity fun >= incoming_arity &&
- -- ... and the function can be eta reduced to arity 0
- canEtaReduceToArity fun 0 0
+ ok_fun_id fun =
+ -- Don't eta-reduce in fun in its own recursive RHSs
+ not (fun `elemUnVarSet` rec_ids) && -- criterion (R)
+ -- There are arguments to reduce...
+ fun_arity fun >= incoming_arity &&
+ -- ... and the function can be eta reduced to arity 0
+ canEtaReduceToArity fun 0 0
---------------
fun_arity fun -- See Note [Arity care]
- | isLocalId fun
- , isStrongLoopBreaker (idOccInfo fun) = 0
| arity > 0 = arity
| isEvaldUnfolding (idUnfolding fun) = 1
-- See Note [Eta reduction of an eval'd function]
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -49,6 +49,7 @@ import GHC.Data.Maybe
import GHC.Data.OrdList
import GHC.Data.FastString
import GHC.Data.Pair
+import GHC.Data.Graph.UnVar
import GHC.Utils.Error
import GHC.Utils.Misc
@@ -594,7 +595,7 @@ cpeBind top_lvl env (NonRec bndr rhs)
| otherwise
= addFloat floats new_float
- new_float = mkFloat dmd is_unlifted bndr1 rhs1
+ new_float = mkFloat env dmd is_unlifted bndr1 rhs1
; return (env2, floats1, Nothing) }
@@ -608,24 +609,27 @@ cpeBind top_lvl env (NonRec bndr rhs)
cpeBind top_lvl env (Rec pairs)
| not (isJoinId (head bndrs))
- = do { (env', bndrs1) <- cpCloneBndrs env bndrs
+ = do { (env, bndrs1) <- cpCloneBndrs env bndrs
+ ; let env' = enterRecGroupRHSs env bndrs1
; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env')
bndrs1 rhss
; let (floats_s, rhss1) = unzip stuff
all_pairs = foldrOL add_float (bndrs1 `zip` rhss1)
(concatFloats floats_s)
-
+ -- use env below, so that we reset cpe_rec_ids
; return (extendCorePrepEnvList env (bndrs `zip` bndrs1),
unitFloat (FloatLet (Rec all_pairs)),
Nothing) }
| otherwise -- See Note [Join points and floating]
- = do { (env', bndrs1) <- cpCloneBndrs env bndrs
+ = do { (env, bndrs1) <- cpCloneBndrs env bndrs
+ ; let env' = enterRecGroupRHSs env bndrs1
; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss
; let bndrs2 = map fst pairs1
- ; return (extendCorePrepEnvList env' (bndrs `zip` bndrs2),
+ -- use env below, so that we reset cpe_rec_ids
+ ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
emptyFloats,
Just (Rec pairs1)) }
where
@@ -657,7 +661,7 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $
-- Note [Silly extra arguments]
(do { v <- newVar (idType bndr)
- ; let float = mkFloat topDmd False v rhs2
+ ; let float = mkFloat env topDmd False v rhs2
; return ( addFloat floats2 float
, cpeEtaExpand arity (Var v)) })
@@ -1464,7 +1468,7 @@ cpeArg env dmd arg
; if okCpeArg arg2
then do { v <- newVar arg_ty
; let arg3 = cpeEtaExpand (exprArity arg2) arg2
- arg_float = mkFloat dmd is_unlifted v arg3
+ arg_float = mkFloat env dmd is_unlifted v arg3
; return (addFloat floats2 arg_float, varToCoreExpr v) }
else return (floats2, arg2)
}
@@ -1669,6 +1673,66 @@ to allocate a thunk for it, whose closure must be retained as
long as the callee might evaluate it. And if it is evaluated on
most code paths anyway, we get to turn the unknown eval in the
callee into a known call at the call site.
+
+However, we must be very careful not to speculate recursive calls!
+Doing so might well change termination behavior.
+
+That comes up in practice for DFuns, which are considered ok-for-spec,
+because they always immediately return a constructor.
+Not so if you speculate the recursive call, as #20836 shows:
+
+ class Foo m => Foo m where
+ runFoo :: m a -> m a
+ newtype Trans m a = Trans { runTrans :: m a }
+ instance Monad m => Foo (Trans m) where
+ runFoo = id
+
+(NB: class Foo m => Foo m` looks weird and needs -XUndecidableSuperClasses. The
+example in #20836 is more compelling, but boils down to the same thing.)
+This program compiles to the following DFun for the `Trans` instance:
+
+ Rec {
+ $fFooTrans
+ = \ @m $dMonad -> C:Foo ($fFooTrans $dMonad) (\ @a -> id)
+ end Rec }
+
+Note that the DFun immediately terminates and produces a dictionary, just
+like DFuns ought to, but it calls itself recursively to produce the `Foo m`
+dictionary. But alas, if we treat `$fFooTrans` as always-terminating, so
+that we can speculate its calls, and hence use call-by-value, we get:
+
+ $fFooTrans
+ = \ @m $dMonad -> case ($fFooTrans $dMonad) of sc ->
+ C:Foo sc (\ @a -> id)
+
+and that's an infinite loop!
+Note that this bad-ness only happens in `$fFooTrans`'s own RHS. In the
+*body* of the letrec, it's absolutely fine to use call-by-value on
+`foo ($fFooTrans d)`.
+
+Our solution is this: we track in cpe_rec_ids the set of enclosing
+recursively-bound Ids, the RHSs of which we are currently transforming and then
+in 'exprOkForSpecEval' (a special entry point to 'exprOkForSpeculation',
+basically) we'll say that any binder in this set is not ok-for-spec.
+
+Note if we have a letrec group `Rec { f1 = rhs1; ...; fn = rhsn }`, and we
+prep up `rhs1`, we have to include not only `f1`, but all binders of the group
+`f1..fn` in this set, otherwise our fix is not robust wrt. mutual recursive
+DFuns.
+
+NB: If at some point we decide to have a termination analysis for general
+functions (#8655, !1866), we need to take similar precautions for (guarded)
+recursive functions:
+
+ repeat x = x : repeat x
+
+Same problem here: As written, repeat evaluates rapidly to WHNF. So `repeat x`
+is a cheap call that we are willing to speculate, but *not* in repeat's RHS.
+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.
-}
data FloatingBind
@@ -1715,8 +1779,8 @@ data OkToSpec
-- ok-to-speculate unlifted bindings
| NotOkToSpec -- Some not-ok-to-speculate unlifted bindings
-mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind
-mkFloat dmd is_unlifted bndr rhs
+mkFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind
+mkFloat env dmd is_unlifted bndr rhs
| is_strict || ok_for_spec -- See Note [Speculative evaluation]
, not is_hnf = FloatCase rhs bndr DEFAULT [] ok_for_spec
-- Don't make a case for a HNF binding, even if it's strict
@@ -1743,7 +1807,8 @@ mkFloat dmd is_unlifted bndr rhs
where
is_hnf = exprIsHNF rhs
is_strict = isStrUsedDmd dmd
- ok_for_spec = exprOkForSpeculation rhs
+ ok_for_spec = exprOkForSpecEval (not . is_rec_call) rhs
+ is_rec_call = (`elemUnVarSet` cpe_rec_ids env)
emptyFloats :: Floats
emptyFloats = Floats OkToSpec nilOL
@@ -1941,6 +2006,7 @@ data CorePrepEnv
, cpe_convertNumLit :: LitNumType -> Integer -> Maybe CoreExpr
-- ^ Convert some numeric literals (Integer, Natural) into their
-- final Core form
+ , cpe_rec_ids :: UnVarSet -- Faster OutIdSet; See Note [Speculative evaluation]
}
mkInitialCorePrepEnv :: HscEnv -> IO CorePrepEnv
@@ -1951,6 +2017,7 @@ mkInitialCorePrepEnv hsc_env = do
, cpe_env = emptyVarEnv
, cpe_tyco_env = Nothing
, cpe_convertNumLit = convertNumLit
+ , cpe_rec_ids = emptyUnVarSet
}
extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
@@ -1972,6 +2039,10 @@ lookupCorePrepEnv cpe id
Nothing -> Var id
Just exp -> exp
+enterRecGroupRHSs :: CorePrepEnv -> [OutId] -> CorePrepEnv
+enterRecGroupRHSs env grp
+ = env { cpe_rec_ids = extendUnVarSetList grp (cpe_rec_ids env) }
+
------------------------------------------------------------------------------
-- CpeTyCoEnv
-- ---------------------------------------------------------------------------
=====================================
compiler/GHC/Data/Graph/UnVar.hs
=====================================
@@ -17,7 +17,7 @@ equal to g, but twice as expensive and large.
module GHC.Data.Graph.UnVar
( UnVarSet
, emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets
- , extendUnVarSet, delUnVarSet
+ , extendUnVarSet, extendUnVarSetList, delUnVarSet, delUnVarSetList
, elemUnVarSet, isEmptyUnVarSet
, UnVarGraph
, emptyUnVarGraph
@@ -63,6 +63,9 @@ isEmptyUnVarSet (UnVarSet s) = S.null s
delUnVarSet :: UnVarSet -> Var -> UnVarSet
delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s
+delUnVarSetList :: UnVarSet -> [Var] -> UnVarSet
+delUnVarSetList s vs = s `minusUnVarSet` mkUnVarSet vs
+
minusUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet
minusUnVarSet (UnVarSet s) (UnVarSet s') = UnVarSet $ s `S.difference` s'
@@ -78,6 +81,9 @@ varEnvDom ae = UnVarSet $ ufmToSet_Directly ae
extendUnVarSet :: Var -> UnVarSet -> UnVarSet
extendUnVarSet v (UnVarSet s) = UnVarSet $ S.insert (k v) s
+extendUnVarSetList :: [Var] -> UnVarSet -> UnVarSet
+extendUnVarSetList vs s = s `unionUnVarSet` mkUnVarSet vs
+
unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet
unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2)
=====================================
compiler/GHC/Iface/Tidy.hs
=====================================
@@ -24,13 +24,12 @@ import GHC.Tc.Utils.Env
import GHC.Core
import GHC.Core.Unfold
-import GHC.Core.Unfold.Make
import GHC.Core.FVs
import GHC.Core.Tidy
import GHC.Core.Seq (seqBinds)
-import GHC.Core.Opt.Arity ( exprArity, exprBotStrictness_maybe )
+import GHC.Core.Opt.Arity ( exprArity, exprBotStrictness_maybe, typeArity )
import GHC.Core.InstEnv
-import GHC.Core.Type ( tidyTopType )
+import GHC.Core.Type ( tidyTopType, Type )
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.Class
@@ -74,6 +73,7 @@ import Data.Function
import Data.List ( sortBy, mapAccumL )
import qualified Data.Set as S
import GHC.Types.CostCentre
+import GHC.Core.Opt.OccurAnal (occurAnalyseExpr)
{-
Constructing the TypeEnv, Instances, Rules from which the
@@ -384,8 +384,7 @@ tidyProgram opts (ModGuts { mg_module = mod
(unfold_env, tidy_occ_env) <- chooseExternalIds opts mod binds implicit_binds imp_rules
let (trimmed_binds, trimmed_rules) = findExternalRules opts binds imp_rules unfold_env
- let uf_opts = opt_unfolding_opts opts
- (tidy_env, tidy_binds) <- tidyTopBinds uf_opts unfold_env boot_exports tidy_occ_env trimmed_binds
+ (tidy_env, tidy_binds) <- tidyTopBinds unfold_env boot_exports tidy_occ_env trimmed_binds
-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
(spt_entries, mcstub, tidy_binds') <- case opt_static_ptr_opts opts of
@@ -1146,60 +1145,49 @@ tidyTopName mod name_cache maybe_ref occ_env id
--
-- * subst_env: A Var->Var mapping that substitutes the new Var for the old
-tidyTopBinds :: UnfoldingOpts
- -> UnfoldEnv
+tidyTopBinds :: UnfoldEnv
-> NameSet
-> TidyOccEnv
-> CoreProgram
-> IO (TidyEnv, CoreProgram)
-tidyTopBinds uf_opts unfold_env boot_exports init_occ_env binds
+tidyTopBinds unfold_env boot_exports init_occ_env binds
= do let result = tidy init_env binds
seqBinds (snd result) `seq` return result
-- This seqBinds avoids a spike in space usage (see #13564)
where
init_env = (init_occ_env, emptyVarEnv)
- tidy = mapAccumL (tidyTopBind uf_opts unfold_env boot_exports)
+ tidy = mapAccumL (tidyTopBind unfold_env boot_exports)
------------------------
-tidyTopBind :: UnfoldingOpts
- -> UnfoldEnv
+tidyTopBind :: UnfoldEnv
-> NameSet
-> TidyEnv
-> CoreBind
-> (TidyEnv, CoreBind)
-tidyTopBind uf_opts unfold_env boot_exports
+tidyTopBind unfold_env boot_exports
(occ_env,subst1) (NonRec bndr rhs)
= (tidy_env2, NonRec bndr' rhs')
where
- Just (name',show_unfold) = lookupVarEnv unfold_env bndr
- (bndr', rhs') = tidyTopPair uf_opts show_unfold boot_exports tidy_env2 name' (bndr, rhs)
+ (bndr', rhs') = tidyTopPair unfold_env boot_exports tidy_env2 (bndr, rhs)
subst2 = extendVarEnv subst1 bndr bndr'
tidy_env2 = (occ_env, subst2)
-tidyTopBind uf_opts unfold_env boot_exports (occ_env, subst1) (Rec prs)
+tidyTopBind unfold_env boot_exports (occ_env, subst1) (Rec prs)
= (tidy_env2, Rec prs')
where
- prs' = [ tidyTopPair uf_opts show_unfold boot_exports tidy_env2 name' (id,rhs)
- | (id,rhs) <- prs,
- let (name',show_unfold) =
- expectJust "tidyTopBind" $ lookupVarEnv unfold_env id
- ]
-
- subst2 = extendVarEnvList subst1 (bndrs `zip` map fst prs')
+ prs' = map (tidyTopPair unfold_env boot_exports tidy_env2) prs
+ subst2 = extendVarEnvList subst1 (map fst prs `zip` map fst prs')
tidy_env2 = (occ_env, subst2)
-
- bndrs = map fst prs
+ -- This is where we "tie the knot": tidy_env2 is fed into tidyTopPair
-----------------------------------------------------------
-tidyTopPair :: UnfoldingOpts
- -> Bool -- show unfolding
+tidyTopPair :: UnfoldEnv
-> NameSet
-> TidyEnv -- The TidyEnv is used to tidy the IdInfo
-- It is knot-tied: don't look at it!
- -> Name -- New name
-> (Id, CoreExpr) -- Binder and RHS before tidying
-> (Id, CoreExpr)
-- This function is the heart of Step 2
@@ -1208,18 +1196,19 @@ tidyTopPair :: UnfoldingOpts
-- group, a variable late in the group might be mentioned
-- in the IdInfo of one early in the group
-tidyTopPair uf_opts show_unfold boot_exports rhs_tidy_env name' (bndr, rhs)
+tidyTopPair unfold_env boot_exports rhs_tidy_env (bndr, rhs)
= -- pprTrace "tidyTop" (ppr name' <+> ppr details <+> ppr rhs) $
(bndr1, rhs1)
where
+ Just (name',show_unfold) = lookupVarEnv unfold_env bndr
!cbv_bndr = tidyCbvInfoTop boot_exports bndr rhs
bndr1 = mkGlobalId details name' ty' idinfo'
details = idDetails cbv_bndr -- Preserve the IdDetails
ty' = tidyTopType (idType cbv_bndr)
rhs1 = tidyExpr rhs_tidy_env rhs
- idinfo' = tidyTopIdInfo uf_opts rhs_tidy_env name' rhs rhs1 (idInfo cbv_bndr)
- show_unfold
+ idinfo' = tidyTopIdInfo rhs_tidy_env name' ty'
+ rhs rhs1 (idInfo cbv_bndr) show_unfold
-- tidyTopIdInfo creates the final IdInfo for top-level
-- binders. The delicate piece:
@@ -1228,9 +1217,9 @@ tidyTopPair uf_opts show_unfold boot_exports rhs_tidy_env name' (bndr, rhs)
-- Indeed, CorePrep must eta expand where necessary to make
-- the manifest arity equal to the claimed arity.
--
-tidyTopIdInfo :: UnfoldingOpts -> TidyEnv -> Name -> CoreExpr -> CoreExpr
+tidyTopIdInfo :: TidyEnv -> Name -> Type -> CoreExpr -> CoreExpr
-> IdInfo -> Bool -> IdInfo
-tidyTopIdInfo uf_opts rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
+tidyTopIdInfo rhs_tidy_env name rhs_ty orig_rhs tidy_rhs idinfo show_unfold
| not is_external -- For internal Ids (not externally visible)
= vanillaIdInfo -- we only need enough info for code generation
-- Arity and strictness info are enough;
@@ -1281,13 +1270,17 @@ tidyTopIdInfo uf_opts rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
--------- Unfolding ------------
unf_info = realUnfoldingInfo idinfo
- unfold_info
- | isCompulsoryUnfolding unf_info || show_unfold
- = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs
- | otherwise
- = minimal_unfold_info
- minimal_unfold_info = trimUnfolding unf_info
- unf_from_rhs = mkFinalUnfolding uf_opts InlineRhs final_sig tidy_rhs
+ !minimal_unfold_info = trimUnfolding unf_info
+
+ !unfold_info | isCompulsoryUnfolding unf_info || show_unfold
+ = tidyTopUnfolding rhs_tidy_env tidy_rhs unf_info
+ | otherwise
+ = minimal_unfold_info
+
+ -- NB: use `orig_rhs` not `tidy_rhs` in this call to mkFinalUnfolding
+ -- else you get a black hole (#22122). Reason: mkFinalUnfolding
+ -- looks at IdInfo, and that is knot-tied in tidyTopBind (the Rec case)
+
-- NB: do *not* expose the worker if show_unfold is off,
-- because that means this thing is a loop breaker or
-- marked NOINLINE or something like that
@@ -1311,4 +1304,54 @@ tidyTopIdInfo uf_opts rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
-- did was to let-bind a non-atomic argument and then float
-- it to the top level. So it seems more robust just to
-- fix it here.
- arity = exprArity orig_rhs
+ arity = exprArity orig_rhs `min` (length $ typeArity rhs_ty)
+
+
+------------ Unfolding --------------
+tidyTopUnfolding :: TidyEnv -> CoreExpr -> Unfolding -> Unfolding
+tidyTopUnfolding _ _ NoUnfolding = NoUnfolding
+tidyTopUnfolding _ _ BootUnfolding = BootUnfolding
+tidyTopUnfolding _ _ (OtherCon {}) = evaldUnfolding
+
+tidyTopUnfolding tidy_env _ df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
+ = df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args }
+ where
+ (tidy_env', bndrs') = tidyBndrs tidy_env bndrs
+
+tidyTopUnfolding tidy_env tidy_rhs
+ unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })
+ = -- See Note [tidyTopUnfolding: avoiding black holes]
+ unf { uf_tmpl = tidy_unf_rhs }
+ where
+ tidy_unf_rhs | isStableSource src
+ = tidyExpr tidy_env unf_rhs -- Preserves OccInfo in unf_rhs
+ | otherwise
+ = occurAnalyseExpr tidy_rhs -- Do occ-anal
+
+{- Note [tidyTopUnfolding: avoiding black holes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we are exposing all unfoldings we don't want to tidy the unfolding
+twice -- we just want to use the tidied RHS. That tidied RHS itself
+contains fully-tidied Ids -- it is knot-tied. So the uf_tmpl for the
+unfolding contains stuff we can't look at. Now consider (#22112)
+ foo = foo
+If we freshly compute the uf_is_value field for foo's unfolding,
+we'll call `exprIsValue`, which will look at foo's unfolding!
+Whether or not the RHS is a value depends on whether foo is a value...
+black hole.
+
+In the Simplifier we deal with this by not giving `foo` an unfolding
+in its own RHS. And we could do that here. But it's qite nice
+to common everything up to a single Id for foo, used everywhere.
+
+And it's not too hard: simply leave the unfolding undisturbed, except
+tidy the uf_tmpl field. Hence tidyTopUnfolding does
+ unf { uf_tmpl = tidy_unf_rhs }
+
+Don't mess with uf_is_value, or guidance; in particular don't recompute
+them from tidy_unf_rhs.
+
+And (unlike tidyNestedUnfolding) don't deep-seq the new unfolding,
+because that'll cause a black hole (I /think/ because occurAnalyseExpr
+looks in IdInfo).
+-}
\ No newline at end of file
=====================================
compiler/GHC/Types/Id/Info.hs
=====================================
@@ -834,7 +834,7 @@ zapFragileUnfolding unf
trimUnfolding :: Unfolding -> Unfolding
-- Squash all unfolding info, preserving only evaluated-ness
trimUnfolding unf | isEvaldUnfolding unf = evaldUnfolding
- | otherwise = noUnfolding
+ | otherwise = noUnfolding
zapTailCallInfo :: IdInfo -> Maybe IdInfo
zapTailCallInfo info
=====================================
testsuite/tests/arityanal/should_compile/Arity03.stderr
=====================================
@@ -18,20 +18,15 @@ end Rec }
fac [InlPrag=[2]] :: Int -> Int
[GblId,
Arity=1,
- Str=<1P(1L)>,
- Cpr=m1,
+ Str=<1!P(1L)>,
+ Cpr=1,
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
- Tmpl= \ (w [Occ=Once1!] :: Int) -> case w of { GHC.Types.I# ww1 [Occ=Once1] -> case F3.$wfac ww1 of ww2 [Occ=Once1] { __DEFAULT -> GHC.Types.I# ww2 } }}]
-fac = \ (w :: Int) -> case w of { GHC.Types.I# ww1 -> case F3.$wfac ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 } }
+ Tmpl= \ (x [Occ=Once1!] :: Int) -> case x of { GHC.Types.I# ww [Occ=Once1] -> case F3.$wfac ww of ww1 [Occ=Once1] { __DEFAULT -> GHC.Types.I# ww1 } }}]
+fac = \ (x :: Int) -> case x of { GHC.Types.I# ww -> case F3.$wfac ww of ww1 { __DEFAULT -> GHC.Types.I# ww1 } }
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
f3 :: Int -> Int
-[GblId,
- Arity=1,
- Str=<1P(1L)>,
- Cpr=m1,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=True)
- Tmpl= fac}]
+[GblId, Arity=1, Str=<1!P(1L)>, Cpr=1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]
f3 = fac
=====================================
testsuite/tests/arityanal/should_run/Makefile
=====================================
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
=====================================
testsuite/tests/arityanal/should_run/T21652.hs
=====================================
@@ -0,0 +1,10 @@
+import GHC.Exts
+
+f, g :: a -> a
+f = g
+g x = f x
+{-# NOINLINE f #-}
+{-# NOINLINE g #-}
+
+-- should print done, not <<loop>>
+main = lazy g `seq` putStrLn "done"
=====================================
testsuite/tests/arityanal/should_run/T21652.stdout
=====================================
@@ -0,0 +1 @@
+done
=====================================
testsuite/tests/arityanal/should_run/all.T
=====================================
@@ -0,0 +1,2 @@
+# Regression tests
+test('T21652', [ only_ways(['optasm']) ], compile_and_run, [''])
=====================================
testsuite/tests/count-deps/CountDepsAst.stdout
=====================================
@@ -1,4 +1,4 @@
-Found 282 Language.Haskell.Syntax module dependencies
+Found 283 Language.Haskell.Syntax module dependencies
GHC.Builtin.Names
GHC.Builtin.PrimOps
GHC.Builtin.PrimOps.Ids
@@ -74,6 +74,7 @@ GHC.Data.FastString
GHC.Data.FastString.Env
GHC.Data.FiniteMap
GHC.Data.Graph.Directed
+GHC.Data.Graph.UnVar
GHC.Data.IOEnv
GHC.Data.List.SetOps
GHC.Data.Maybe
=====================================
testsuite/tests/count-deps/CountDepsParser.stdout
=====================================
@@ -1,4 +1,4 @@
-Found 289 GHC.Parser module dependencies
+Found 290 GHC.Parser module dependencies
GHC.Builtin.Names
GHC.Builtin.PrimOps
GHC.Builtin.PrimOps.Ids
@@ -74,6 +74,7 @@ GHC.Data.FastString
GHC.Data.FastString.Env
GHC.Data.FiniteMap
GHC.Data.Graph.Directed
+GHC.Data.Graph.UnVar
GHC.Data.IOEnv
GHC.Data.List.SetOps
GHC.Data.Maybe
=====================================
testsuite/tests/deSugar/should_compile/T19969.stderr
=====================================
@@ -1,7 +1,7 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 12, types: 18, coercions: 0, joins: 0/0}
+ = {terms: 8, types: 14, coercions: 0, joins: 0/0}
Rec {
-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
@@ -10,7 +10,7 @@ f [Occ=LoopBreaker] :: [Int] -> [Int]
f = \ (x :: [Int]) -> f x
end Rec }
--- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
g [InlPrag=INLINE (sat-args=1)] :: [Int] -> [Int]
[GblId,
Arity=1,
@@ -19,10 +19,10 @@ g [InlPrag=INLINE (sat-args=1)] :: [Int] -> [Int]
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=True)
- Tmpl= \ (x [Occ=Once1] :: [Int]) -> f x}]
-g = \ (x :: [Int]) -> f x
+ Tmpl= f}]
+g = f
--- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
h [InlPrag=INLINE (sat-args=1)] :: [Int] -> [Int]
[GblId,
Arity=1,
@@ -31,8 +31,8 @@ h [InlPrag=INLINE (sat-args=1)] :: [Int] -> [Int]
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=True)
- Tmpl= \ (x [Occ=Once1] :: [Int]) -> f x}]
-h = \ (x :: [Int]) -> f x
+ Tmpl= f}]
+h = f
=====================================
testsuite/tests/simplCore/should_compile/T22112.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+module Rec where
+
+-- This one created a black hole in Tidy,
+-- when creating the tidied unfolding for foo
+foo :: () -> ()
+foo = foo
=====================================
testsuite/tests/simplCore/should_compile/T22112.stderr
=====================================
@@ -0,0 +1,14 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+ = {terms: 2, types: 2, coercions: 0, joins: 0/0}
+
+Rec {
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+foo [Occ=LoopBreaker] :: () -> ()
+[GblId, Str=b, Cpr=b]
+foo = foo
+end Rec }
+
+
+
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -393,4 +393,5 @@ test('OpaqueNoStrictArgWW', normal, compile, ['-O -fworker-wrapper-cbv -ddump-si
test('OpaqueNoWW', normal, compile, ['-O -ddump-simpl -dsuppress-uniques'])
test('T21144', normal, compile, ['-O'])
+test('T22112', normal, compile, ['-O -dsuppress-uniques -dno-typeable-binds -ddump-simpl'])
=====================================
testsuite/tests/simplCore/should_run/T20836.hs
=====================================
@@ -0,0 +1,23 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
+
+import Data.Kind (Type)
+
+class (Monad m, MonadFoo (FooM m)) => MonadFoo m where
+ type FooM m :: Type -> Type
+ runFoo :: FooM m a -> m a
+
+newtype MyMonad m a = MyMonad { runMyMonad :: m a }
+ deriving (Functor, Applicative, Monad)
+
+instance Monad m => MonadFoo (MyMonad m) where
+ type FooM (MyMonad m) = MyMonad m
+ runFoo = id
+
+main :: IO ()
+main = runMyMonad foo
+
+foo :: MonadFoo m => m ()
+foo = runFoo $ return ()
=====================================
testsuite/tests/simplCore/should_run/all.T
=====================================
@@ -102,3 +102,4 @@ test('T20203', normal, compile, ['-O -dsuppress-all -dsuppress-uniques -dno-type
test('T19313', expect_broken(19131), compile_and_run, [''])
test('T21575', normal, compile_and_run, ['-O'])
test('T21575b', [], multimod_compile_and_run, ['T21575b', '-O'])
+test('T20836', normal, compile_and_run, ['-O0']) # Should not time out; See #20836
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e8a889a7fc670532a3bf883a3e25acba92e6e6e1...3e4a38c8b88a93cc740b7432902e46586e10eab1
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e8a889a7fc670532a3bf883a3e25acba92e6e6e1...3e4a38c8b88a93cc740b7432902e46586e10eab1
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/20221014/76a845f7/attachment-0001.html>
More information about the ghc-commits
mailing list