diff options
| -rw-r--r-- | compiler/GHC/Core/Opt/DmdAnal.hs | 3 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/WorkWrap/Utils.hs | 49 | ||||
| -rw-r--r-- | compiler/GHC/Types/Demand.hs | 3 |
3 files changed, 39 insertions, 16 deletions
diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index 29fa61a5fc..cd7b628ba5 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -48,6 +48,7 @@ import GHC.Types.Unique.Set ************************************************************************ -} +{-# NOINLINE dmdAnalProgram #-} dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram dmdAnalProgram dflags fam_envs binds = do let env = emptyAnalEnv dflags fam_envs @@ -1252,7 +1253,7 @@ findBndrDmd env arg_of_dfun dmd_ty id = (dmd_ty', dmd') where dmd' = strictify $ - trimToType starting_dmd (findTypeShape fam_envs id_ty) + trimToType starting_dmd (findTypeShape fam_envs id_ty) (dmd_ty', starting_dmd) = peelFV dmd_ty id diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index 4c4a5ced8a..83a29e04d0 100644 --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -40,12 +40,14 @@ import GHC.Core.Coercion import GHC.Core.FamInstEnv import GHC.Types.Basic ( Boxity(..) ) import GHC.Core.TyCon +import GHC.Core.Map (TypeMap, lookupTypeMap, extendTypeMap) import GHC.Types.Unique.Supply import GHC.Types.Unique import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Driver.Session +import GHC.Data.TrieMap import GHC.Data.FastString import GHC.Data.List.SetOps @@ -1001,30 +1003,47 @@ findTypeShape :: FamInstEnvs -> Type -> TypeShape -- The data type TypeShape is defined in GHC.Types.Demand -- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal findTypeShape fam_envs ty - = go (setRecTcMaxBound 2 initRecTc) ty - -- You might think this bound of 2 is low, but actually - -- I think even 1 would be fine. This only bites for recursive - -- product types, which are rare, and we really don't want - -- to look deep into such products -- see #18034 + = go emptyTM ty + -- We keep track of types we have seen to avoid looking deep + -- into recursive types -- see #18304. + + -- The solution is simple. If a type is recursive one of it's + -- fields will eventually mention it's outermost type. + -- So we check for this using TypeMap. + + -- TypeMap isn't ideal for this. It covers types we will never + -- see here, and it wastes space as it's a map used as set. + + -- This makes this somewhat more expensive (~0.1 allocations) + -- than using checkRecTc. But it's more precise as things like + -- deeply nested tuples won't bail out early so still desireable. + + -- Implementing a typeset suitable for this use could increase + -- performance further if this ever becomes a bottleneck. + where - go rec_tc ty + prodFieldShape :: TypeMap () -> Type -> Type -> TypeShape + prodFieldShape tyMap origTy fldTy + | Just _ <- lookupTypeMap tyMap' fldTy + = TsRecField + | otherwise + = go tyMap' fldTy + where + tyMap' = extendTypeMap tyMap origTy () + go tyMap ty | Just (_, res) <- splitFunTy_maybe ty - = TsFun (go rec_tc res) + = TsFun (go tyMap res) + -- Product types | Just (tc, tc_args) <- splitTyConApp_maybe ty , Just con <- isDataProductTyCon_maybe tc - , Just rec_tc <- if isTupleTyCon tc - then Just rec_tc - else checkRecTc rec_tc tc - -- We treat tuples specially because they can't cause loops. - -- Maybe we should do so in checkRecTc. - = TsProd (map (go rec_tc) (dataConInstArgTys con tc_args)) + = TsProd (map (prodFieldShape tyMap ty) (dataConInstArgTys con tc_args)) | Just (_, ty') <- splitForAllTy_maybe ty - = go rec_tc ty' + = go tyMap ty' | Just (_, ty') <- topNormaliseType_maybe fam_envs ty - = go rec_tc ty' + = go tyMap ty' | otherwise = TsUnk diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs index 077d6d913e..06dc43ceea 100644 --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -833,6 +833,8 @@ data TypeShape -- See Note [Trimming a demand to a type] -- in GHC.Core.Opt.DmdAnal = TsFun TypeShape | TsProd [TypeShape] + | TsRecField -- ^ A field which refers to a type it's a part of. + -- e.g. the second field in data T = MkT Int T | TsUnk trimToType :: Demand -> TypeShape -> Demand @@ -864,6 +866,7 @@ trimToType (JD { sd = ms, ud = mu }) ts instance Outputable TypeShape where ppr TsUnk = text "TsUnk" + ppr TsRecField = text "TsRecField" ppr (TsFun ts) = text "TsFun" <> parens (ppr ts) ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss) |