From 2cf828e829011f103ea946756a0c53322fa238dd Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Fri, 26 Aug 2022 12:16:01 +0100 Subject: 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 --- compiler/GHC/Core/Tidy.hs | 37 ++++--- compiler/GHC/Iface/Tidy.hs | 123 ++++++++++++++------- compiler/GHC/Types/Id/Info.hs | 2 +- testsuite/tests/simplCore/should_compile/T22112.hs | 7 ++ .../tests/simplCore/should_compile/T22112.stderr | 14 +++ testsuite/tests/simplCore/should_compile/all.T | 1 + 6 files changed, 126 insertions(+), 58 deletions(-) create mode 100644 testsuite/tests/simplCore/should_compile/T22112.hs create mode 100644 testsuite/tests/simplCore/should_compile/T22112.stderr diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs index 3f6c212f49..2201c9c3c1 100644 --- a/compiler/GHC/Core/Tidy.hs +++ b/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] diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index 1417f26f49..4032bfbc4d 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/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 diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs index c0027eab18..126223226c 100644 --- a/compiler/GHC/Types/Id/Info.hs +++ b/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 diff --git a/testsuite/tests/simplCore/should_compile/T22112.hs b/testsuite/tests/simplCore/should_compile/T22112.hs new file mode 100644 index 0000000000..19291c39dc --- /dev/null +++ b/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 diff --git a/testsuite/tests/simplCore/should_compile/T22112.stderr b/testsuite/tests/simplCore/should_compile/T22112.stderr new file mode 100644 index 0000000000..1a97dd9b41 --- /dev/null +++ b/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 } + + + diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index bbed3c805f..acaba48686 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/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']) -- cgit v1.2.1