diff options
| -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']) |