diff options
author | Matthew Pickering <matthewtpickering@gmail.com> | 2021-07-21 14:03:23 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-08-03 10:16:20 -0400 |
commit | 694ec53bce201c0a7585a59a728459a92e35f586 (patch) | |
tree | 1e749ab2e6f0cdbeb78421534dc9264cba57e19e | |
parent | d22ec8a92953b93149ad3010938ec57556a154ff (diff) | |
download | haskell-694ec53bce201c0a7585a59a728459a92e35f586.tar.gz |
Remove eager forcing of RuleInfo in substRuleInfo
substRuleInfo updates the IdInfo for an Id, therefore it is important to not
force said IdInfo whilst updating it, otherwise we end up in an infinite
loop. This is what happened in #20112 where `mkTick` forced the IdInfo being
updated by checking the arity in isSaturatedConApp. The fix is to stop
the expression being forced so early by removing the call to
seqRuleInfo.
The call sequence looked something like:
* `substRecBndrs`
* `substIdBndr`
* `substIdInfo`
* `substRuleInfo`
* `substRule`
* `substExpr`
* `mkTick`
* `isSaturatedConApp`
* Look at `IdInfo` for thing we are currently substituting because the rule is attached to `transpose` and mentions it in the `RHS` of the rule.
Which arose because the `transpose` Id had a rule attached where the RHS
of the rule also mentioned `transpose`.
This call to seqRuleInfo was introduced in 4e7d56fde0f44d38bbb9a6fc72cf9c603264899d
where it was explained
> I think there are now *too many* seqs, and they waste work, but I don't have
> time to find which ones.
We also observe that there is the ominous note on `substRule` about
making sure substExpr is called lazily.
> {- Note [Substitute lazily]
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~
> The functions that substitute over IdInfo must be pretty lazy, because
> they are knot-tied by substRecBndrs.
>
> One case in point was #10627 in which a rule for a function 'f'
> referred to 'f' (at a different type) on the RHS. But instead of just
> substituting in the rhs of the rule, we were calling simpleOptExpr, which
> looked at the idInfo for 'f'; result <<loop>>.
>
> In any case we don't need to optimise the RHS of rules, or unfoldings,
> because the simplifier will do that.
Before `seqRuleInfo` was removed, this note was pretty much ignored in
the `substSpec` case because the expression was immediately forced after
`substRule` was called.
Unfortunately it's a bit tricky to add a test for this as the failure
only manifested (for an unknown reason) with a dwarf enabled compiler
*AND* compiling with -g3. Fortunatley there is currently a CI
configuration which builds a dwarf compiler to test this.
Also, for good measure, finish off the work started in
840df33685e8c746ade4b9d4d0eb7c764a773e48 which renamed SpecInfo to
RuleInfo but then didn't rename 'substSpec' to 'substRuleInfo'.
Fixes #20112
-rw-r--r-- | compiler/GHC/Core/SimpleOpt.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Core/Subst.hs | 40 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T20112.hs | 26 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T20112A.hs | 21 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/all.T | 1 |
5 files changed, 81 insertions, 9 deletions
diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index 47d2c3f454..40e9f138b7 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -665,7 +665,7 @@ add_info env old_bndr top_level new_rhs new_bndr `setUnfoldingInfo` new_unfolding old_rules = ruleInfo old_info - new_rules = substSpec subst new_bndr old_rules + new_rules = substRuleInfo subst new_bndr old_rules old_unfolding = realUnfoldingInfo old_info new_unfolding | isStableUnfolding old_unfolding diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs index 36f3bad0d4..be05e1c44c 100644 --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -14,7 +14,7 @@ module GHC.Core.Subst ( TvSubstEnv, IdSubstEnv, InScopeSet, -- ** Substituting into expressions and related types - deShadowBinds, substSpec, substRulesForImportedIds, + deShadowBinds, substRuleInfo, substRulesForImportedIds, substTy, substCo, substExpr, substExprSC, substBind, substBindSC, substUnfolding, substUnfoldingSC, lookupIdSubst, lookupTCvSubst, substIdType, substIdOcc, @@ -622,7 +622,7 @@ substIdType subst@(Subst _ _ tv_env cv_env) id substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo substIdInfo subst new_id info | nothing_to_do = Nothing - | otherwise = Just (info `setRuleInfo` substSpec subst new_id old_rules + | otherwise = Just (info `setRuleInfo` substRuleInfo subst new_id old_rules `setUnfoldingInfo` substUnfolding subst old_unf) where old_rules = ruleInfo info @@ -668,14 +668,13 @@ substIdOcc subst v = case lookupIdSubst subst v of other -> pprPanic "substIdOcc" (vcat [ppr v <+> ppr other, ppr subst]) ------------------ --- | Substitutes for the 'Id's within the 'WorkerInfo' given the new function 'Id' -substSpec :: Subst -> Id -> RuleInfo -> RuleInfo -substSpec subst new_id (RuleInfo rules rhs_fvs) - = seqRuleInfo new_spec `seq` new_spec +-- | Substitutes for the 'Id's within the 'RuleInfo' given the new function 'Id' +substRuleInfo :: Subst -> Id -> RuleInfo -> RuleInfo +substRuleInfo subst new_id (RuleInfo rules rhs_fvs) + = RuleInfo (map (substRule subst subst_ru_fn) rules) + (substDVarSet subst rhs_fvs) where subst_ru_fn = const (idName new_id) - new_spec = RuleInfo (map (substRule subst subst_ru_fn) rules) - (substDVarSet subst rhs_fvs) ------------------ substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule] @@ -738,6 +737,31 @@ looked at the idInfo for 'f'; result <<loop>>. In any case we don't need to optimise the RHS of rules, or unfoldings, because the simplifier will do that. +Another place this went wrong was in `substRuleInfo`, which would immediately force +the lazy call to substExpr, which led to an infinite loop (as reported by #20112). + +This time the call stack looked something like: + +* `substRecBndrs` +* `substIdBndr` +* `substIdInfo` +* `substRuleInfo` +* `substRule` +* `substExpr` +* `mkTick` +* `isSaturatedConApp` +* Look at `IdInfo` for thing we are currently substituting because the rule is attached to `transpose` and mentions it in the `RHS` of the rule. + +and the rule was + +{-# RULES +"transpose/overlays1" forall xs. transpose (overlays1 xs) = overlays1 (fmap transpose xs) +#-} + +This rule was attached to `transpose`, but also mentions itself in the RHS so we have +to be careful to not force the `IdInfo` for transpose when dealing with the RHS of the rule. + + Note [substTickish] ~~~~~~~~~~~~~~~~~~~~~~ diff --git a/testsuite/tests/simplCore/should_compile/T20112.hs b/testsuite/tests/simplCore/should_compile/T20112.hs new file mode 100644 index 0000000000..72a4198246 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T20112.hs @@ -0,0 +1,26 @@ +module T20112 ( + -- * Data structure + AdjacencyMap, transpose, overlays1 + + ) where + +import Prelude hiding (reverse) +import Data.List.NonEmpty(NonEmpty, toList) +import Data.Coerce + +import qualified T20112A as AM + +newtype AdjacencyMap a = NAM ( AM.AdjacencyMap a ) + +overlays1 :: Ord a => NonEmpty (AdjacencyMap a) -> AdjacencyMap a +overlays1 = coerce AM.overlays . toList +{-# NOINLINE overlays1 #-} + +transpose :: Ord a => AdjacencyMap a -> AdjacencyMap a +transpose = coerce AM.transpose +{-# NOINLINE [1] transpose #-} + +{-# RULES +"transpose/overlays1" forall xs. transpose (overlays1 xs) = overlays1 (fmap transpose xs) + #-} + diff --git a/testsuite/tests/simplCore/should_compile/T20112A.hs b/testsuite/tests/simplCore/should_compile/T20112A.hs new file mode 100644 index 0000000000..a8f30efbc8 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T20112A.hs @@ -0,0 +1,21 @@ +module T20112A ( + -- * Data structure + AdjacencyMap, adjacencyMap, transpose, overlays + + ) where + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +newtype AdjacencyMap a = AM { + adjacencyMap :: Map a (Set.Set a) } + +overlays :: Ord a => [AdjacencyMap a] -> AdjacencyMap a +overlays = AM . Map.unionsWith Set.union . map adjacencyMap + +transpose :: Ord a => AdjacencyMap a -> AdjacencyMap a +transpose (AM m) = AM $ Map.foldrWithKey combine vs m + where + combine v es = Map.unionWith Set.union (Map.fromSet (const $ Set.singleton v) es) + vs = Map.fromSet (const Set.empty) (Map.keysSet m) diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index 25296eda0f..c8fc59f78d 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -371,3 +371,4 @@ test('T20125', [ grep_errmsg(r'= T20125.MkT') ], compile, ['-O -ddump-simpl -ds test('T20143', [ grep_errmsg(r'unsafeEqualityProof') ], compile, ['-O -ddump-simpl -dsuppress-uniques']) test('T20174', normal, compile, ['']) test('T16373', normal, compile, ['']) +test('T20112', normal, multimod_compile, ['T20112', '-O -v0 -g1']) |