diff options
| -rw-r--r-- | compiler/GHC/Core/Opt/DmdAnal.hs | 103 | ||||
| -rw-r--r-- | compiler/GHC/Core/TyCon.hs | 3 | ||||
| -rw-r--r-- | compiler/GHC/Types/Demand.hs | 50 |
3 files changed, 141 insertions, 15 deletions
diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index 97c7e29622..db442f2a7c 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -8,6 +8,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} module GHC.Core.Opt.DmdAnal ( dmdAnalProgram ) where @@ -51,7 +52,7 @@ import GHC.Types.Unique.Set dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram dmdAnalProgram dflags fam_envs binds = do let env = emptyAnalEnv dflags fam_envs - let binds_plus_dmds = snd $ mapAccumL dmdAnalTopBind env binds + let !binds_plus_dmds = snd $ mapAccumL dmdAnalTopBind env binds dumpIfSet_dyn dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $ dumpIdInfoOfProgram (pprIfaceStrictSig . strictnessInfo) binds_plus_dmds -- See Note [Stamp out space leaks in demand analysis] @@ -149,7 +150,9 @@ dmdAnal, dmdAnal' :: AnalEnv -- See Note [Ensure demand is strict] dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $ - dmdAnal' env d e + -- See Note [Demand analysis on self recursive functions] + -- for why we widen the incoming demand here. + dmdAnal' env (widenDmd 5 d) e dmdAnal' _ _ (Lit lit) = (nopDmdType, Lit lit) dmdAnal' _ _ (Type ty) = (nopDmdType, Type ty) -- Doesn't happen, in fact @@ -517,6 +520,83 @@ dmdTransform env var dmd ************************************************************************ -} +{- Note [Demand analysis on self recursive functions] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Given a data type like this: + + T = C { ... , next :: T } + +and a function + + f x = .. + .. -> f (next x) + +usage information would be unbounded in it's size. + +The reason is that we figure out f will use the next field of x. +Giving us useage information of U<U>. +Armed with this information we analyse `f (next x)` in the body again +on the next iteration giving usage of U<U<U>>. We can repeat this +for infinity and will never reach a fixpoint. + +We used to deal with this simply by limiting the number of iterations +to 10 and giving up if we could not find a fix point in this time. + +While this works well for small recursive groups it doesn't work for +large ones. This happened in #18304. + +The reason is simple. We analyse a recursive group of functions +like below: + +f1 x = ... + -> f1 (next x) + -> f2 (next x) + +f2 x = ... + -> f1 (next x) + -> f2 (next x) + -> fn ... + +We analyse f1 under the default demand resulting in U<U>. +We analyse f2 and see the call `f1 (next x)` in the body. +Since `f1 x` has U<U> "f1 (next x)" in the body of f2 will +result in U<U<U>> as usage demand of f2. + +For each additional function fn in the group of this pattern +usage information will become nested deeper by one level. + +This means depth of usage information will grow linear in the +number of functions in the recursive group. Being capped at +iterations * n. + +This is still tractable, the issue in #18304 addone one more +dimension to the problem by not having one, but two "next" fields. + +data T = C { ... , next1 :: T, next2 :: T} + +f1 x = ... + .. -> f1 (next1 x) + .. -> f1 (next2 x) + .. -> f2 (next1 x) + .. -> f2 (next2 x) + +Suddenly the size of usage information was growing exponentially +in 2 ^ (n * iterations). + +This very quickly becomes untractable! + +This is a well known problem which is usually solved by adding a +widening operator. + +For simplicity however we apply this operator to the incoming demand +instead of the result. This has the same result of allowing us to reach +a fixpoint but has two benefits: + +* There is only a single place where we need to care (in the argument of dmdAnal). +* We can fully analyze functions taking apart deeply nested non-recursive types + +-} -- Recursive bindings dmdFix :: TopLevelFlag -> AnalEnv -- Does not include bindings for this binding @@ -623,15 +703,16 @@ dmdAnalRhsLetDown rec_flag env let_dmd id rhs where rhs_arity = idArity id rhs_dmd - -- See Note [Demand analysis for join points] - -- See Note [Invariants on join points] invariant 2b, in GHC.Core - -- rhs_arity matches the join arity of the join point - | isJoinId id - = mkCallDmds rhs_arity let_dmd - | otherwise - -- NB: rhs_arity - -- See Note [Demand signatures are computed for a threshold demand based on idArity] - = mkRhsDmd env rhs_arity rhs + -- See Note [Demand analysis for join points] + -- See Note [Invariants on join points] invariant 2b, in GHC.Core + -- rhs_arity matches the join arity of the join point + | isJoinId id + = mkCallDmds rhs_arity let_dmd + | otherwise + -- NB: rhs_arity + -- See Note [Demand signatures are computed for a threshold demand based on idArity] + = mkRhsDmd env rhs_arity rhs + (DmdType rhs_fv rhs_dmds rhs_div, rhs') = dmdAnal env rhs_dmd rhs sig = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div) diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs index 80b4500685..124eab6ebc 100644 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -2750,6 +2750,9 @@ data RecTcChecker = RC !Int (NameEnv Int) -- The upper bound, and the number of times -- we have encountered each TyCon +instance Outputable RecTcChecker where + ppr (RC n env) = braces (text "RC" <+> ppr n <+> ppr env) + -- | Initialise a 'RecTcChecker' with 'defaultRecTcMaxBound'. initRecTc :: RecTcChecker initRecTc = RC defaultRecTcMaxBound emptyNameEnv diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs index cbbbe6688d..5820e69a47 100644 --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -5,6 +5,7 @@ \section[Demand]{@Demand@: A decoupled implementation of a demand domain} -} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances, RecordWildCards #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -51,7 +52,9 @@ module GHC.Types.Demand ( useCount, isUsedOnce, reuseEnv, zapUsageDemand, zapUsageEnvSig, zapUsedOnceDemand, zapUsedOnceSig, - strictifyDictDmd, strictifyDmd + strictifyDictDmd, strictifyDmd, + + widenDmd ) where @@ -83,6 +86,12 @@ import GHC.Core.DataCon ( splitDataProductType_maybe ) data JointDmd s u = JD { sd :: s, ud :: u } deriving ( Eq, Show ) +-- | Limit the depth of demands to the given nesting. +-- Any sub-demand exceeding this depth will be given the top +-- demand for the respective domain. +widenDmd :: Int -> JointDmd StrDmd UseDmd -> JointDmd StrDmd UseDmd +widenDmd n (JD s u) = JD (widenStrDmd n s) (widenUseDmd n u) + getStrDmd :: JointDmd s u -> s getStrDmd = sd @@ -206,6 +215,21 @@ data StrDmd deriving ( Eq, Show ) +widenStrDmd :: Int -> StrDmd -> StrDmd +widenStrDmd !n d = + case d of + HyperStr -> HyperStr + HeadStr -> HeadStr + SCall d -> SCall $! widenStrDmd n d + SProd args -> SProd $ map (widenStrArgDmd n) args + +widenStrArgDmd :: Int -> ArgStr -> ArgStr +widenStrArgDmd 0 _ = Lazy +widenStrArgDmd n d = + case d of + Lazy -> Lazy + Str d -> Str $! widenStrDmd (n-1) d + -- | Strictness of a function argument. type ArgStr = Str StrDmd @@ -330,14 +354,20 @@ splitStrProdDmd _ (SCall {}) = Nothing UHead | Count x - - | - Abs + | + Abs -} -- | Domain for genuine usage data UseDmd - = UCall Count UseDmd -- ^ Call demand for absence. + = UCall Count UseDmd -- ^ Call demand for absence analysis. -- Used only for values of function type + -- + -- The Count argument describes how often the + -- value itself is used. + -- The UseDmd describes how often we use the result + -- of applying one argument to the value. This can + -- and often is nested for multiple arguments. | UProd [ArgUse] -- ^ Product. -- Used only for values of product type @@ -363,6 +393,18 @@ data UseDmd -- (top of the lattice) deriving ( Eq, Show ) +widenUseDmd :: Int -> UseDmd -> UseDmd +widenUseDmd 0 _ = Used +widenUseDmd _ UHead = UHead +widenUseDmd _ Used = Used +widenUseDmd n (UCall c d) = UCall c $! widenUseDmd n d +widenUseDmd n (UProd args) = UProd $ map (widenUseArg n) args + +widenUseArg :: Int -> ArgUse -> ArgUse +widenUseArg _ Abs = Abs +widenUseArg n (Use c d) = Use c $! widenUseDmd (n-1) d + + -- Extended usage demand for absence and counting type ArgUse = Use UseDmd |