diff options
Diffstat (limited to 'compiler/GHC/Core')
| -rw-r--r-- | compiler/GHC/Core/Opt/CprAnal.hs | 27 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/DmdAnal.hs | 57 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/WorkWrap/Utils.hs | 41 |
3 files changed, 83 insertions, 42 deletions
diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs index 64551f9498..97cd36d15a 100644 --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -20,6 +20,7 @@ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Demand import GHC.Types.Cpr +import GHC.Types.Unique.MemoFun import GHC.Core.FamInstEnv import GHC.Core.DataCon @@ -343,7 +344,7 @@ cprTransform env id args = fst $ cprAnalApp env rhs args -- DataCon worker | Just con <- isDataConWorkId_maybe id - = cprTransformDataConWork (ae_fam_envs env) con args + = cprTransformDataConWork env con args -- Imported function | otherwise = applyCprTy (getCprSig (idCprSig id)) (length args) @@ -361,20 +362,17 @@ cprTransformBespoke id args -- | Get a (possibly nested) 'CprType' for an application of a 'DataCon' worker, -- given a saturated number of 'CprType's for its field expressions. -- Implements the Nested part of Note [Nested CPR]. -cprTransformDataConWork :: FamInstEnvs -> DataCon -> [(CprType, CoreArg)] -> CprType -cprTransformDataConWork fam_envs con args +cprTransformDataConWork :: AnalEnv -> DataCon -> [(CprType, CoreArg)] -> CprType +cprTransformDataConWork env con args | null (dataConExTyCoVars con) -- No existentials , wkr_arity <= mAX_CPR_SIZE -- See Note [Trimming to mAX_CPR_SIZE] , args `lengthIs` wkr_arity - , isRecDataCon fam_envs fuel con /= DefinitelyRecursive -- See Note [CPR for recursive data constructors] + , ae_rec_dc env con /= DefinitelyRecursive -- See Note [CPR for recursive data constructors] -- , pprTrace "cprTransformDataConWork" (ppr con <+> ppr wkr_arity <+> ppr args) True = CprType 0 (ConCpr (dataConTag con) (strictZipWith extract_nested_cpr args wkr_str_marks)) | otherwise = topCprType where - fuel = 3 -- If we can unbox more than 3 constructors to find a - -- recursive occurrence, then we can just as well unbox it - -- See Note [CPR for recursive data constructors], point (4) wkr_arity = dataConRepArity con wkr_str_marks = dataConRepStrictness con -- See Note [Nested CPR] @@ -563,6 +561,8 @@ data AnalEnv -- iteration. See Note [Initialising strictness] in "GHC.Core.Opt.DmdAnal" , ae_fam_envs :: FamInstEnvs -- ^ Needed when expanding type families and synonyms of product types. + , ae_rec_dc :: DataCon -> IsRecDataConResult + -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataCon' } instance Outputable AnalEnv where @@ -594,7 +594,11 @@ emptyAnalEnv fam_envs { ae_sigs = SE emptyUnVarSet emptyVarEnv , ae_virgin = True , ae_fam_envs = fam_envs - } + , ae_rec_dc = memoiseUniqueFun (isRecDataCon fam_envs fuel) + } where + fuel = 3 -- If we can unbox more than 3 constructors to find a + -- recursive occurrence, then we can just as well unbox it + -- See Note [CPR for recursive data constructors], point (4) modifySigEnv :: (SigEnv -> SigEnv) -> AnalEnv -> AnalEnv modifySigEnv f env = env { ae_sigs = f (ae_sigs env) } @@ -1022,6 +1026,7 @@ constructor's type constructor. A few perhaps surprising points: as when we run out of fuel. If there is ever a recursion through an abstract TyCon, then it's not part of the same function we are looking at, so we can treat it as if it wasn't recursive. + We handle stuck type and data families much the same. Here are a few examples of data constructors or data types with a single data con and the answers of our function: @@ -1046,10 +1051,10 @@ con and the answers of our function: E Char = Blub data Blah = Blah (E (Int, (Int, Int))) NonRec (see point (5)) data Blub = Blub (E (Char, Int)) Rec - data Blub2 = Blub2 (E (Bool, Int)) } Rec, because stuck + data Blub2 = Blub2 (E (Bool, Int)) } Unsure, because stuck (see point (7)) { data T1 = T1 T2; data T2 = T2 T3; - ... data T5 = T5 T1 } Nothing (out of fuel) (see point (4)) + ... data T5 = T5 T1 } Unsure (out of fuel) (see point (4)) { module A where -- A.hs-boot data T @@ -1057,7 +1062,7 @@ con and the answers of our function: import {-# SOURCE #-} A data U = MkU T f :: T -> U - f t = MkU t Nothing (T is abstract) (see point (7)) + f t = MkU t Unsure (T is abstract) (see point (7)) module A where -- A.hs import B data T = MkT U } diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index 2dafaf8e0b..95d1954dfe 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -40,10 +40,11 @@ import GHC.Core.Opt.Arity ( typeArity ) import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Data.Maybe ( isJust, orElse ) +import GHC.Data.Maybe import GHC.Builtin.PrimOps import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) import GHC.Types.Unique.Set +import GHC.Types.Unique.MemoFun import GHC.Utils.Trace _ = pprTrace -- Tired of commenting out the import all the time @@ -428,8 +429,9 @@ dmdAnal' env dmd (Lam var body) dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs]) -- Only one alternative. - -- If it's a DataAlt, it should be the only constructor of the type. - | is_single_data_alt alt + -- If it's a DataAlt, it should be the only constructor of the type and we + -- can consider its field demands when analysing the scrutinee. + | want_precise_field_dmds alt = let WithDmdType rhs_ty rhs' = dmdAnal env dmd rhs WithDmdType alt_ty1 fld_dmds = findBndrsDmds env rhs_ty bndrs @@ -454,10 +456,9 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs]) -- __DEFAULT and literal alts. Simply add demands and discard the -- evaluation cardinality, as we evaluate the scrutinee exactly once. = assert (null bndrs) (bndrs, case_bndr_sd) - fam_envs = ae_fam_envs env alt_ty3 -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" - | exprMayThrowPreciseException fam_envs scrut + | exprMayThrowPreciseException (ae_fam_envs env) scrut = deferAfterPreciseException alt_ty2 | otherwise = alt_ty2 @@ -474,8 +475,12 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs]) -- , text "res_ty" <+> ppr res_ty ]) $ WithDmdType res_ty (Case scrut' case_bndr' ty [Alt alt bndrs' rhs']) where - is_single_data_alt (DataAlt dc) = isJust $ tyConSingleAlgDataCon_maybe $ dataConTyCon dc - is_single_data_alt _ = True + want_precise_field_dmds alt = case alt of + (DataAlt dc) + | Nothing <- tyConSingleAlgDataCon_maybe $ dataConTyCon dc -> False + | DefinitelyRecursive <- ae_rec_dc env dc -> False + -- See Note [Demand analysis for recursive data constructors] + _ -> True @@ -689,12 +694,29 @@ to the Divergence lattice, but in practice it turned out to be hard to untaint from 'topDiv' to 'conDiv', leading to bugs, performance regressions and complexity that didn't justify the single fixed testcase T13380c. +Note [Demand analysis for recursive data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +T11545 features a single-product, recursive data type + data A = A A A ... A + deriving Eq +Naturally, `(==)` is deeply strict in `A` and in fact will never terminate. That +leads to very large (exponential in the depth) demand signatures and fruitless +churn in boxity analysis, demand analysis and worker/wrapper. +So we detect `A` as a recursive data constructor +(see Note [Detecting recursive data constructors]) analysing `case x of A ...` +and simply assume L for the demand on field binders, which is the same code +path as we take for sum types. +Combined with the B demand on the case binder, we get the very small demand +signature <1S><1S>b on `(==)`. This improves ghc/alloc performance on T11545 +tenfold! See also Note [CPR for recursive data constructors] which describes the +sibling mechanism in CPR analysis. + Note [Demand on the scrutinee of a product case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When figuring out the demand on the scrutinee of a product case, we use the demands of the case alternative, i.e. id_dmds. But note that these include the demand on the case binder; -see Note [Demand on case-alternative binders] in GHC.Types.Demand. +see Note [Demand on case-alternative binders]. This is crucial. Example: f x = case x of y { (a,b) -> k y a } If we just take scrut_demand = 1P(L,A), then we won't pass x to the @@ -1484,6 +1506,9 @@ finaliseArgBoxities env fn arity rhs -- isStrict: see Note [No lazy, Unboxed demands in demand signature] -- isMarkedStrict: see Note [Unboxing evaluated arguments] , positiveTopBudget bg_inner' + , NonRecursiveOrUnsure <- ae_rec_dc env dc + -- See Note [Which types are unboxed?] + -- and Note [Demand analysis for recursive data constructors] = (bg_inner', dmd') | otherwise = (bg_inner, trimBoxity dmd) @@ -1817,12 +1842,15 @@ demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix". data AnalEnv = AE - { ae_opts :: !DmdAnalOpts -- ^ Analysis options - , ae_sigs :: !SigEnv - , ae_virgin :: !Bool -- ^ True on first iteration only - -- See Note [Initialising strictness] - , ae_fam_envs :: !FamInstEnvs - } + { ae_opts :: !DmdAnalOpts + -- ^ Analysis options + , ae_sigs :: !SigEnv + , ae_virgin :: !Bool + -- ^ True on first iteration only. See Note [Initialising strictness] + , ae_fam_envs :: !FamInstEnvs + , ae_rec_dc :: DataCon -> IsRecDataConResult + -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataCon' + } -- We use the se_env to tell us whether to -- record info about a variable in the DmdEnv @@ -1845,6 +1873,7 @@ emptyAnalEnv opts fam_envs , ae_sigs = emptySigEnv , ae_virgin = True , ae_fam_envs = fam_envs + , ae_rec_dc = memoiseUniqueFun (isRecDataCon fam_envs 3) } emptySigEnv :: SigEnv diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index c62ba572de..75e8c9e3c2 100644 --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -676,6 +676,7 @@ Worker/wrapper will unbox 1. A strict data type argument, that * is an algebraic data type (not a newtype) + * is not recursive (as per 'isRecDataCon') * has a single constructor (thus is a "product") * that may bind existentials We can transform @@ -687,6 +688,7 @@ Worker/wrapper will unbox 2. The constructed result of a function, if * its type is an algebraic data type (not a newtype) + * is not recursive (as per 'isRecDataCon') * (might have multiple constructors, in contrast to (1)) * the applied data constructor *does not* bind existentials We can transform @@ -1244,15 +1246,17 @@ combineIRDCRs = foldl' combineIRDCR NonRecursiveOrUnsure -- | @isRecDataCon _ fuel dc@, where @tc = dataConTyCon dc@ returns -- --- * @Just Recursive@ if the analysis found that @tc@ is reachable through one --- of @dc@'s fields --- * @Just NonRecursive@ if the analysis found that @tc@ is not reachable --- through one of @dc@'s fields --- * @Nothing@ is returned in two cases. The first is when @fuel /= Infinity@ --- and @f@ expansions of nested data TyCons were not enough to prove +-- * @DefinitelyRecursive@ if the analysis found that @tc@ is reachable +-- through one of @dc@'s @arg_tys@. +-- * @NonRecursiveOrUnsure@ if the analysis found that @tc@ is not reachable +-- through one of @dc@'s fields (so surely non-recursive). +-- * @NonRecursiveOrUnsure@ when @fuel /= Infinity@ +-- and @fuel@ expansions of nested data TyCons were not enough to prove -- non-recursivenss, nor arrive at an occurrence of @tc@ thus proving --- recursiveness. The other is when we hit an abstract TyCon (one without +-- recursiveness. (So not sure if non-recursive.) +-- * @NonRecursiveOrUnsure@ when we hit an abstract TyCon (one without -- visible DataCons), such as those imported from .hs-boot files. +-- Similarly for stuck type and data families. -- -- If @fuel = 'Infinity'@ and there are no boot files involved, then the result -- is never @Nothing@ and the analysis is a depth-first search. If @fuel = 'Int' @@ -1266,16 +1270,16 @@ isRecDataCon fam_envs fuel dc | isTupleDataCon dc || isUnboxedSumDataCon dc = NonRecursiveOrUnsure | otherwise - = -- pprTrace "isRecDataCon" (ppr dc <+> dcolon <+> ppr (dataConRepType dc) $$ ppr fuel $$ ppr answer) - answer + = -- pprTraceWith "isRecDataCon" (\answer -> ppr dc <+> dcolon <+> ppr (dataConRepType dc) $$ ppr fuel $$ ppr answer) $ + go_dc fuel (setRecTcMaxBound 1 initRecTc) dc where - answer = go_dc fuel (setRecTcMaxBound 1 initRecTc) dc + _pp_dc_ty = ppr dc (<||>) = combineIRDCR go_dc :: IntWithInf -> RecTcChecker -> DataCon -> IsRecDataConResult go_dc fuel rec_tc dc = - combineIRDCRs [ go_arg_ty fuel rec_tc (scaledThing arg_ty) - | arg_ty <- dataConRepArgTys dc ] + combineIRDCRs [ go_arg_ty fuel rec_tc arg_ty + | arg_ty <- map scaledThing (dataConRepArgTys dc) ] go_arg_ty :: IntWithInf -> RecTcChecker -> Type -> IsRecDataConResult go_arg_ty fuel rec_tc ty @@ -1304,9 +1308,6 @@ isRecDataCon fam_envs fuel dc go_tc_app fuel rec_tc tc tc_args --- | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False = undefined - | tc == dataConTyCon dc - = DefinitelyRecursive -- loop found! - | isPrimTyCon tc = NonRecursiveOrUnsure @@ -1320,8 +1321,14 @@ isRecDataCon fam_envs fuel dc -- This is the only place where we look at tc_args -- See Note [Detecting recursive data constructors], point (5) = case topReduceTyFamApp_maybe fam_envs tc tc_args of - Just (HetReduction (Reduction _ rhs) _) -> go_arg_ty fuel rec_tc rhs - Nothing -> DefinitelyRecursive -- we hit this case for 'Any' + Just (HetReduction (Reduction _ rhs) _) -> + go_arg_ty fuel rec_tc rhs + Nothing -> + NonRecursiveOrUnsure -- NB: We simply give up here. Better return + -- Unsure, as for abstract TyCons, point (7) + + | tc == dataConTyCon dc + = DefinitelyRecursive -- loop found! | otherwise = assertPpr (isAlgTyCon tc) (ppr tc <+> ppr dc) $ |