[Git][ghc/ghc][ghc-9.4] Fix a nasty loop in Tidy
Andreas Klebinger (@AndreasK)
gitlab at gitlab.haskell.org
Thu Sep 15 21:58:01 UTC 2022
Andreas Klebinger pushed to branch ghc-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
- - - - -
6 changed files:
- compiler/GHC/Core/Tidy.hs
- compiler/GHC/Iface/Tidy.hs
- compiler/GHC/Types/Id/Info.hs
- + testsuite/tests/simplCore/should_compile/T22112.hs
- + testsuite/tests/simplCore/should_compile/T22112.stderr
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
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/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/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'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2cf828e829011f103ea946756a0c53322fa238dd
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2cf828e829011f103ea946756a0c53322fa238dd
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/20220915/0e9ef277/attachment-0001.html>
More information about the ghc-commits
mailing list