{- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 ----------------- A demand analysis ----------------- -} module GHC.Core.Opt.DmdAnal ( DmdAnalOpts(..) , dmdAnalProgram ) where import GHC.Prelude import GHC.Core.Opt.WorkWrap.Utils import GHC.Types.Demand -- All of it import GHC.Core import GHC.Core.Multiplicity ( scaledThing ) import GHC.Utils.Outputable import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Basic import Data.List ( mapAccumL ) import GHC.Core.DataCon import GHC.Types.ForeignCall ( isSafeForeignCall ) import GHC.Types.Id import GHC.Core.Utils import GHC.Core.TyCon import GHC.Core.Type import GHC.Core.Predicate( isClassPred ) import GHC.Core.FVs ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds ) import GHC.Core.Coercion ( Coercion ) import GHC.Core.TyCo.FVs ( coVarsOfCos ) import GHC.Core.TyCo.Compare ( eqType ) import GHC.Core.FamInstEnv import GHC.Core.Opt.Arity ( typeArity ) import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Panic.Plain 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.Types.RepType {- ************************************************************************ * * \subsection{Top level stuff} * * ************************************************************************ -} -- | Options for the demand analysis data DmdAnalOpts = DmdAnalOpts { DmdAnalOpts -> Bool dmd_strict_dicts :: !Bool -- ^ Value of `-fdicts-strict` (on by default). -- When set, all functons are implicitly strict in dictionary args. , DmdAnalOpts -> Bool dmd_do_boxity :: !Bool -- ^ Governs whether the analysis should update boxity signatures. -- See Note [Don't change boxity without worker/wrapper]. , DmdAnalOpts -> Arity dmd_unbox_width :: !Int -- ^ Value of `-fdmd-unbox-width`. -- See Note [Unboxed demand on function bodies returning small products] , DmdAnalOpts -> Arity dmd_max_worker_args :: !Int -- ^ Value of `-fmax-worker-args`. -- Don't unbox anything if we end up with more than this many args. } -- This is a strict alternative to (,) -- See Note [Space Leaks in Demand Analysis] data WithDmdType a = WithDmdType !DmdType !a getAnnotated :: WithDmdType a -> a getAnnotated :: forall a. WithDmdType a -> a getAnnotated (WithDmdType DmdType _ a a) = a a data DmdResult a b = R !a !b -- | Outputs a new copy of the Core program in which binders have been annotated -- with demand and strictness information. -- -- Note: use `seqBinds` on the result to avoid leaks due to lazyness (cf Note -- [Stamp out space leaks in demand analysis]) dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram dmdAnalProgram DmdAnalOpts opts FamInstEnvs fam_envs [CoreRule] rules CoreProgram binds = WithDmdType CoreProgram -> CoreProgram forall a. WithDmdType a -> a getAnnotated (WithDmdType CoreProgram -> CoreProgram) -> WithDmdType CoreProgram -> CoreProgram forall a b. (a -> b) -> a -> b $ AnalEnv -> CoreProgram -> WithDmdType CoreProgram go (DmdAnalOpts -> FamInstEnvs -> AnalEnv emptyAnalEnv DmdAnalOpts opts FamInstEnvs fam_envs) CoreProgram binds where -- See Note [Analysing top-level bindings] -- and Note [Why care for top-level demand annotations?] go :: AnalEnv -> CoreProgram -> WithDmdType CoreProgram go AnalEnv _ [] = DmdType -> CoreProgram -> WithDmdType CoreProgram forall a. DmdType -> a -> WithDmdType a WithDmdType DmdType nopDmdType [] go AnalEnv env (Bind Id b:CoreProgram bs) = WithDmdType (DmdResult (Bind Id) CoreProgram) -> WithDmdType CoreProgram forall b. WithDmdType (DmdResult b [b]) -> WithDmdType [b] cons_up (WithDmdType (DmdResult (Bind Id) CoreProgram) -> WithDmdType CoreProgram) -> WithDmdType (DmdResult (Bind Id) CoreProgram) -> WithDmdType CoreProgram forall a b. (a -> b) -> a -> b $ TopLevelFlag -> AnalEnv -> SubDemand -> Bind Id -> (AnalEnv -> WithDmdType CoreProgram) -> WithDmdType (DmdResult (Bind Id) CoreProgram) forall a. TopLevelFlag -> AnalEnv -> SubDemand -> Bind Id -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult (Bind Id) a) dmdAnalBind TopLevelFlag TopLevel AnalEnv env SubDemand topSubDmd Bind Id b AnalEnv -> WithDmdType CoreProgram anal_body where anal_body :: AnalEnv -> WithDmdType CoreProgram anal_body AnalEnv env' | WithDmdType DmdType body_ty CoreProgram bs' <- AnalEnv -> CoreProgram -> WithDmdType CoreProgram go AnalEnv env' CoreProgram bs = DmdType -> CoreProgram -> WithDmdType CoreProgram forall a. DmdType -> a -> WithDmdType a WithDmdType (AnalEnv -> DmdType -> [Id] -> DmdType add_exported_uses AnalEnv env' DmdType body_ty (Bind Id -> [Id] forall b. Bind b -> [b] bindersOf Bind Id b)) CoreProgram bs' cons_up :: WithDmdType (DmdResult b [b]) -> WithDmdType [b] cons_up :: forall b. WithDmdType (DmdResult b [b]) -> WithDmdType [b] cons_up (WithDmdType DmdType dmd_ty (R b b' [b] bs')) = DmdType -> [b] -> WithDmdType [b] forall a. DmdType -> a -> WithDmdType a WithDmdType DmdType dmd_ty (b b' b -> [b] -> [b] forall a. a -> [a] -> [a] : [b] bs') add_exported_uses :: AnalEnv -> DmdType -> [Id] -> DmdType add_exported_uses :: AnalEnv -> DmdType -> [Id] -> DmdType add_exported_uses AnalEnv env = (DmdType -> Id -> DmdType) -> DmdType -> [Id] -> DmdType forall b a. (b -> a -> b) -> b -> [a] -> b forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl' (AnalEnv -> DmdType -> Id -> DmdType add_exported_use AnalEnv env) -- If @e@ is denoted by @dmd_ty@, then @add_exported_use _ dmd_ty id@ -- corresponds to the demand type of @(id, e)@, but is a lot more direct. -- See Note [Analysing top-level bindings]. add_exported_use :: AnalEnv -> DmdType -> Id -> DmdType add_exported_use :: AnalEnv -> DmdType -> Id -> DmdType add_exported_use AnalEnv env DmdType dmd_ty Id id | Id -> Bool isExportedId Id id Bool -> Bool -> Bool || Id -> VarSet -> Bool elemVarSet Id id VarSet rule_fvs -- See Note [Absence analysis for stable unfoldings and RULES] = DmdType dmd_ty DmdType -> PlusDmdArg -> DmdType `plusDmdType` (PlusDmdArg, CoreExpr) -> PlusDmdArg forall a b. (a, b) -> a fst (AnalEnv -> Demand -> CoreExpr -> (PlusDmdArg, CoreExpr) dmdAnalStar AnalEnv env Demand topDmd (Id -> CoreExpr forall b. Id -> Expr b Var Id id)) | Bool otherwise = DmdType dmd_ty rule_fvs :: IdSet rule_fvs :: VarSet rule_fvs = [CoreRule] -> VarSet rulesRhsFreeIds [CoreRule] rules -- | We attach useful (e.g. not 'topDmd') 'idDemandInfo' to top-level bindings -- that satisfy this function. -- -- Basically, we want to know how top-level *functions* are *used* -- (e.g. called). The information will always be lazy. -- Any other top-level bindings are boring. -- -- See also Note [Why care for top-level demand annotations?]. isInterestingTopLevelFn :: Id -> Bool -- SG tried to set this to True and got a +2% ghc/alloc regression in T5642 -- (which is dominated by the Simplifier) at no gain in analysis precision. -- If there was a gain, that regression might be acceptable. -- Plus, we could use LetUp for thunks and share some code with local let -- bindings. isInterestingTopLevelFn :: Id -> Bool isInterestingTopLevelFn Id id = Type -> Arity typeArity (Id -> Type idType Id id) Arity -> Arity -> Bool forall a. Ord a => a -> a -> Bool > Arity 0 {- Note [Stamp out space leaks in demand analysis] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The demand analysis pass outputs a new copy of the Core program in which binders have been annotated with demand and strictness information. It's tiresome to ensure that this information is fully evaluated everywhere that we produce it, so we just run a single seqBinds over the output before returning it, to ensure that there are no references holding on to the input Core program. This makes a ~30% reduction in peak memory usage when compiling DynFlags (cf #9675 and #13426). This is particularly important when we are doing late demand analysis, since we don't do a seqBinds at any point thereafter. Hence code generation would hold on to an extra copy of the Core program, via unforced thunks in demand or strictness information; and it is the most memory-intensive part of the compilation process, so this added seqBinds makes a big difference in peak memory usage. Note [Don't change boxity without worker/wrapper] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider (T21754) f n = n+1 {-# NOINLINE f #-} With `-fno-worker-wrapper`, we should not give `f` a boxity signature that says that it unboxes its argument! Client modules would never be able to cancel away the box for n. Likewise we shouldn't give `f` the CPR property. Similarly, in the last run of DmdAnal before codegen (which does not have a worker/wrapper phase) we should not change boxity in any way. Remember: an earlier result of the demand analyser, complete with worker/wrapper, has aleady given a demand signature (with boxity info) to the function. (The "last run" is mainly there to attach demanded-once info to let-bindings.) In general, we should not run Note [Boxity analysis] unless worker/wrapper follows to exploit the boxity and make sure that calling modules can observe the reported boxity. Hence DmdAnal is configured by a flag `dmd_do_boxity` that is True only if worker/wrapper follows after DmdAnal. If it is not set, and the signature is not subject to Note [Boxity for bottoming functions], DmdAnal tries to transfer over the previous boxity to the new demand signature, in `setIdDmdAndBoxSig`. Why isn't CprAnal configured with a similar flag? Because if we aren't going to do worker/wrapper we don't run CPR analysis at all. (see GHC.Core.Opt.Pipeline) It might be surprising that we only try to preserve *arg* boxity, not boxity on FVs. But FV demands won't make it into interface files anyway, so it's a waste of energy. Besides, W/W zaps the `DmdEnv` portion of a signature, so we don't know the old boxity to begin with; see Note [Zapping DmdEnv after Demand Analyzer]. Note [Analysing top-level bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a CoreProgram like e1 = ... n1 = ... e2 = \a b -> ... fst (n1 a b) ... n2 = \c d -> ... snd (e2 c d) ... ... where e* are exported, but n* are not. Intuitively, we can see that @n1@ is only ever called with two arguments and in every call site, the first component of the result of the call is evaluated. Thus, we'd like it to have idDemandInfo @LC(L,C(M,P(1L,A))@. NB: We may *not* give e2 a similar annotation, because it is exported and external callers might use it in arbitrary ways, expressed by 'topDmd'. This can then be exploited by Nested CPR and eta-expansion, see Note [Why care for top-level demand annotations?]. How do we get this result? Answer: By analysing the program as if it was a let expression of this form: let e1 = ... in let n1 = ... in let e2 = ... in let n2 = ... in (e1,e2, ...) E.g. putting all bindings in nested lets and returning all exported binders in a tuple. Of course, we will not actually build that CoreExpr! Instead we faithfully simulate analysis of said expression by adding the free variable 'DmdEnv' of @e*@'s strictness signatures to the 'DmdType' we get from analysing the nested bindings. And even then the above form blows up analysis performance in T10370: If @e1@ uses many free variables, we'll unnecessarily carry their demands around with us from the moment we analyse the pair to the moment we bubble back up to the binding for @e1@. So instead we analyse as if we had let e1 = ... in (e1, let n1 = ... in ( let e2 = ... in (e2, let n2 = ... in ( ...)))) That is, a series of right-nested pairs, where the @fst@ are the exported binders of the last enclosing let binding and @snd@ continues the nested lets. Variables occurring free in RULE RHSs are to be handled the same as exported Ids. See also Note [Absence analysis for stable unfoldings and RULES]. Note [Why care for top-level demand annotations?] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Reading Note [Analysing top-level bindings], you might think that we go through quite some trouble to get useful demands for top-level bindings. They can never be strict, for example, so why bother? First, we get to eta-expand top-level bindings that we weren't able to eta-expand before without Call Arity. From T18894b: module T18894b (f) where eta :: Int -> Int -> Int eta x = if fst (expensive x) == 13 then \y -> ... else \y -> ... f m = ... eta m 2 ... eta 2 m ... Since only @f@ is exported, we see all call sites of @eta@ and can eta-expand to arity 2. The call demands we get for some top-level bindings will also allow Nested CPR to unbox deeper. From T18894: module T18894 (h) where g m n = (2 * m, 2 `div` n) {-# NOINLINE g #-} h :: Int -> Int h m = ... snd (g m 2) ... uncurry (+) (g 2 m) ... Only @h@ is exported, hence we see that @g@ is always called in contexts were we also force the division in the second component of the pair returned by @g@. This allows Nested CPR to evaluate the division eagerly and return an I# in its position. -} {- ************************************************************************ * * \subsection{The analyser itself} * * ************************************************************************ -} -- | Analyse a binding group and its \"body\", e.g. where it is in scope. -- -- It calls a function that knows how to analyse this \"body\" given -- an 'AnalEnv' with updated demand signatures for the binding group -- (reflecting their 'idDmdSigInfo') and expects to receive a -- 'DmdType' in return, which it uses to annotate the binding group with their -- 'idDemandInfo'. dmdAnalBind :: TopLevelFlag -> AnalEnv -> SubDemand -- ^ Demand put on the "body" -- (important for join points) -> CoreBind -> (AnalEnv -> WithDmdType a) -- ^ How to analyse the "body", e.g. -- where the binding is in scope -> WithDmdType (DmdResult CoreBind a) dmdAnalBind :: forall a. TopLevelFlag -> AnalEnv -> SubDemand -> Bind Id -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult (Bind Id) a) dmdAnalBind TopLevelFlag top_lvl AnalEnv env SubDemand dmd Bind Id bind AnalEnv -> WithDmdType a anal_body = case Bind Id bind of NonRec Id id CoreExpr rhs | TopLevelFlag -> Id -> Bool useLetUp TopLevelFlag top_lvl Id id -> TopLevelFlag -> AnalEnv -> Id -> CoreExpr -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult (Bind Id) a) forall a. TopLevelFlag -> AnalEnv -> Id -> CoreExpr -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult (Bind Id) a) dmdAnalBindLetUp TopLevelFlag top_lvl AnalEnv env_rhs Id id CoreExpr rhs AnalEnv -> WithDmdType a anal_body Bind Id _ -> TopLevelFlag -> AnalEnv -> SubDemand -> Bind Id -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult (Bind Id) a) forall a. TopLevelFlag -> AnalEnv -> SubDemand -> Bind Id -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult (Bind Id) a) dmdAnalBindLetDown TopLevelFlag top_lvl AnalEnv env_rhs SubDemand dmd Bind Id bind AnalEnv -> WithDmdType a anal_body where env_rhs :: AnalEnv env_rhs = Bind Id -> AnalEnv -> AnalEnv enterDFun Bind Id bind AnalEnv env -- | Annotates uninteresting top level functions ('isInterestingTopLevelFn') -- with 'topDmd', the rest with the given demand. setBindIdDemandInfo :: TopLevelFlag -> Id -> Demand -> Id setBindIdDemandInfo :: TopLevelFlag -> Id -> Demand -> Id setBindIdDemandInfo TopLevelFlag top_lvl Id id Demand dmd = Id -> Demand -> Id setIdDemandInfo Id id (Demand -> Id) -> Demand -> Id forall a b. (a -> b) -> a -> b $ case TopLevelFlag top_lvl of TopLevelFlag TopLevel | Bool -> Bool not (Id -> Bool isInterestingTopLevelFn Id id) -> Demand topDmd TopLevelFlag _ -> Demand dmd -- | Update the demand signature, but be careful not to change boxity info if -- `dmd_do_boxity` is True or if the signature is bottom. -- See Note [Don't change boxity without worker/wrapper] -- and Note [Boxity for bottoming functions]. setIdDmdAndBoxSig :: DmdAnalOpts -> Id -> DmdSig -> Id setIdDmdAndBoxSig :: DmdAnalOpts -> Id -> DmdSig -> Id setIdDmdAndBoxSig DmdAnalOpts opts Id id DmdSig sig = Id -> DmdSig -> Id setIdDmdSig Id id (DmdSig -> Id) -> DmdSig -> Id forall a b. (a -> b) -> a -> b $ if DmdAnalOpts -> Bool dmd_do_boxity DmdAnalOpts opts Bool -> Bool -> Bool || DmdSig -> Bool isBottomingSig DmdSig sig then DmdSig sig else DmdSig -> DmdSig -> DmdSig transferArgBoxityDmdSig (Id -> DmdSig idDmdSig Id id) DmdSig sig -- | Let bindings can be processed in two ways: -- Down (RHS before body) or Up (body before RHS). -- This function handles the up variant. -- -- It is very simple. For let x = rhs in body -- * Demand-analyse 'body' in the current environment -- * Find the demand, 'rhs_dmd' placed on 'x' by 'body' -- * Demand-analyse 'rhs' in 'rhs_dmd' -- -- This is used for a non-recursive local let without manifest lambdas (see -- 'useLetUp'). -- -- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”. dmdAnalBindLetUp :: TopLevelFlag -> AnalEnv -> Id -> CoreExpr -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult CoreBind a) dmdAnalBindLetUp :: forall a. TopLevelFlag -> AnalEnv -> Id -> CoreExpr -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult (Bind Id) a) dmdAnalBindLetUp TopLevelFlag top_lvl AnalEnv env Id id CoreExpr rhs AnalEnv -> WithDmdType a anal_body = DmdType -> DmdResult (Bind Id) a -> WithDmdType (DmdResult (Bind Id) a) forall a. DmdType -> a -> WithDmdType a WithDmdType DmdType final_ty (Bind Id -> a -> DmdResult (Bind Id) a forall a b. a -> b -> DmdResult a b R (Id -> CoreExpr -> Bind Id forall b. b -> Expr b -> Bind b NonRec Id id' CoreExpr rhs') (a body')) where WithDmdType DmdType body_ty a body' = AnalEnv -> WithDmdType a anal_body (AnalEnv -> Id -> AnalEnv addInScopeAnalEnv AnalEnv env Id id) -- See Note [Bringing a new variable into scope] WithDmdType DmdType body_ty' Demand id_dmd = AnalEnv -> DmdType -> Id -> WithDmdType Demand findBndrDmd AnalEnv env DmdType body_ty Id id -- See Note [Finalising boxity for demand signatures] id_dmd' :: Demand id_dmd' = AnalEnv -> Type -> Demand -> Demand finaliseLetBoxity AnalEnv env (Id -> Type idType Id id) Demand id_dmd !id' :: Id id' = TopLevelFlag -> Id -> Demand -> Id setBindIdDemandInfo TopLevelFlag top_lvl Id id Demand id_dmd' (PlusDmdArg rhs_ty, CoreExpr rhs') = AnalEnv -> Demand -> CoreExpr -> (PlusDmdArg, CoreExpr) dmdAnalStar AnalEnv env Demand id_dmd' CoreExpr rhs -- See Note [Absence analysis for stable unfoldings and RULES] rule_fvs :: VarSet rule_fvs = Id -> VarSet bndrRuleAndUnfoldingIds Id id final_ty :: DmdType final_ty = DmdType body_ty' DmdType -> PlusDmdArg -> DmdType `plusDmdType` PlusDmdArg rhs_ty DmdType -> VarSet -> DmdType `keepAliveDmdType` VarSet rule_fvs -- | Let bindings can be processed in two ways: -- Down (RHS before body) or Up (body before RHS). -- This function handles the down variant. -- -- It computes a demand signature (by means of 'dmdAnalRhsSig') and uses -- that at call sites in the body. -- -- It is used for toplevel definitions, recursive definitions and local -- non-recursive definitions that have manifest lambdas (cf. 'useLetUp'). -- Local non-recursive definitions without a lambda are handled with LetUp. -- -- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”. dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult CoreBind a) dmdAnalBindLetDown :: forall a. TopLevelFlag -> AnalEnv -> SubDemand -> Bind Id -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult (Bind Id) a) dmdAnalBindLetDown TopLevelFlag top_lvl AnalEnv env SubDemand dmd Bind Id bind AnalEnv -> WithDmdType a anal_body = case Bind Id bind of NonRec Id id CoreExpr rhs | (AnalEnv env', DmdEnv lazy_fv, Id id1, CoreExpr rhs1) <- TopLevelFlag -> RecFlag -> AnalEnv -> SubDemand -> Id -> CoreExpr -> (AnalEnv, DmdEnv, Id, CoreExpr) dmdAnalRhsSig TopLevelFlag top_lvl RecFlag NonRecursive AnalEnv env SubDemand dmd Id id CoreExpr rhs -> AnalEnv -> DmdEnv -> [(Id, CoreExpr)] -> ([(Id, CoreExpr)] -> Bind Id) -> WithDmdType (DmdResult (Bind Id) a) do_rest AnalEnv env' DmdEnv lazy_fv [(Id id1, CoreExpr rhs1)] ((Id -> CoreExpr -> Bind Id) -> (Id, CoreExpr) -> Bind Id forall a b c. (a -> b -> c) -> (a, b) -> c uncurry Id -> CoreExpr -> Bind Id forall b. b -> Expr b -> Bind b NonRec ((Id, CoreExpr) -> Bind Id) -> ([(Id, CoreExpr)] -> (Id, CoreExpr)) -> [(Id, CoreExpr)] -> Bind Id forall b c a. (b -> c) -> (a -> b) -> a -> c . [(Id, CoreExpr)] -> (Id, CoreExpr) forall a. [a] -> a only) Rec [(Id, CoreExpr)] pairs | (AnalEnv env', DmdEnv lazy_fv, [(Id, CoreExpr)] pairs') <- TopLevelFlag -> AnalEnv -> SubDemand -> [(Id, CoreExpr)] -> (AnalEnv, DmdEnv, [(Id, CoreExpr)]) dmdFix TopLevelFlag top_lvl AnalEnv env SubDemand dmd [(Id, CoreExpr)] pairs -> AnalEnv -> DmdEnv -> [(Id, CoreExpr)] -> ([(Id, CoreExpr)] -> Bind Id) -> WithDmdType (DmdResult (Bind Id) a) do_rest AnalEnv env' DmdEnv lazy_fv [(Id, CoreExpr)] pairs' [(Id, CoreExpr)] -> Bind Id forall b. [(b, Expr b)] -> Bind b Rec where do_rest :: AnalEnv -> DmdEnv -> [(Id, CoreExpr)] -> ([(Id, CoreExpr)] -> Bind Id) -> WithDmdType (DmdResult (Bind Id) a) do_rest AnalEnv env' DmdEnv lazy_fv [(Id, CoreExpr)] pairs1 [(Id, CoreExpr)] -> Bind Id build_bind = DmdType -> DmdResult (Bind Id) a -> WithDmdType (DmdResult (Bind Id) a) forall a. DmdType -> a -> WithDmdType a WithDmdType DmdType final_ty (Bind Id -> a -> DmdResult (Bind Id) a forall a b. a -> b -> DmdResult a b R ([(Id, CoreExpr)] -> Bind Id build_bind [(Id, CoreExpr)] pairs2) a body') where WithDmdType DmdType body_ty a body' = AnalEnv -> WithDmdType a anal_body AnalEnv env' -- see Note [Lazy and unleashable free variables] dmd_ty :: DmdType dmd_ty = DmdType -> DmdEnv -> DmdType addLazyFVs DmdType body_ty DmdEnv lazy_fv WithDmdType DmdType final_ty [Demand] id_dmds = AnalEnv -> DmdType -> [Id] -> WithDmdType [Demand] findBndrsDmds AnalEnv env' DmdType dmd_ty (((Id, CoreExpr) -> Id) -> [(Id, CoreExpr)] -> [Id] forall a b. (a -> b) -> [a] -> [b] strictMap (Id, CoreExpr) -> Id forall a b. (a, b) -> a fst [(Id, CoreExpr)] pairs1) -- Important to force this as build_bind might not force it. !pairs2 :: [(Id, CoreExpr)] pairs2 = ((Id, CoreExpr) -> Demand -> (Id, CoreExpr)) -> [(Id, CoreExpr)] -> [Demand] -> [(Id, CoreExpr)] forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] strictZipWith (Id, CoreExpr) -> Demand -> (Id, CoreExpr) do_one [(Id, CoreExpr)] pairs1 [Demand] id_dmds do_one :: (Id, CoreExpr) -> Demand -> (Id, CoreExpr) do_one (Id id', CoreExpr rhs') Demand dmd = ((,) (Id -> CoreExpr -> (Id, CoreExpr)) -> Id -> CoreExpr -> (Id, CoreExpr) forall a b. (a -> b) -> a -> b $! TopLevelFlag -> Id -> Demand -> Id setBindIdDemandInfo TopLevelFlag top_lvl Id id' Demand dmd) (CoreExpr -> (Id, CoreExpr)) -> CoreExpr -> (Id, CoreExpr) forall a b. (a -> b) -> a -> b $! CoreExpr rhs' -- If the actual demand is better than the vanilla call -- demand, you might think that we might do better to re-analyse -- the RHS with the stronger demand. -- But (a) That seldom happens, because it means that *every* path in -- the body of the let has to use that stronger demand -- (b) It often happens temporarily in when fixpointing, because -- the recursive function at first seems to place a massive demand. -- But we don't want to go to extra work when the function will -- probably iterate to something less demanding. -- In practice, all the times the actual demand on id2 is more than -- the vanilla call demand seem to be due to (b). So we don't -- bother to re-analyse the RHS. -- | Mimic the effect of 'GHC.Core.Prep.mkFloat', turning non-trivial argument -- expressions/RHSs into a proper let-bound thunk (lifted) or a case (with -- unlifted scrutinee). anticipateANF :: CoreExpr -> Card -> Card anticipateANF :: CoreExpr -> Card -> Card anticipateANF CoreExpr e Card n | CoreExpr -> Bool exprIsTrivial CoreExpr e = Card n -- trivial expr won't have a binding | Just Levity Unlifted <- (() :: Constraint) => Type -> Maybe Levity Type -> Maybe Levity typeLevity_maybe ((() :: Constraint) => CoreExpr -> Type CoreExpr -> Type exprType CoreExpr e) , Bool -> Bool not (Card -> Bool isAbs Card n Bool -> Bool -> Bool && CoreExpr -> Bool exprOkForSpeculation CoreExpr e) = Card -> Card forall {p}. p -> Card case_bind Card n | Bool otherwise = Card -> Card let_bind Card n where case_bind :: p -> Card case_bind p _ = Card C_11 -- evaluated exactly once let_bind :: Card -> Card let_bind = Card -> Card oneifyCard -- evaluated at most once -- Do not process absent demands -- Otherwise act like in a normal demand analysis -- See ↦* relation in the Cardinality Analysis paper dmdAnalStar :: AnalEnv -> Demand -- This one takes a *Demand* -> CoreExpr -> (PlusDmdArg, CoreExpr) dmdAnalStar :: AnalEnv -> Demand -> CoreExpr -> (PlusDmdArg, CoreExpr) dmdAnalStar AnalEnv env (Card n :* SubDemand sd) CoreExpr e -- NB: (:*) expands AbsDmd and BotDmd as needed | WithDmdType DmdType dmd_ty CoreExpr e' <- AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr dmdAnal AnalEnv env SubDemand sd CoreExpr e , Card n' <- CoreExpr -> Card -> Card anticipateANF CoreExpr e Card n -- See Note [Anticipating ANF in demand analysis] -- and Note [Analysing with absent demand] = (DmdType -> PlusDmdArg toPlusDmdArg (DmdType -> PlusDmdArg) -> DmdType -> PlusDmdArg forall a b. (a -> b) -> a -> b $ Card -> DmdType -> DmdType multDmdType Card n' DmdType dmd_ty, CoreExpr e') -- Main Demand Analysis machinery dmdAnal, dmdAnal' :: AnalEnv -> SubDemand -- The main one takes a *SubDemand* -> CoreExpr -> WithDmdType CoreExpr dmdAnal :: AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr dmdAnal AnalEnv env SubDemand d CoreExpr e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $ AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr dmdAnal' AnalEnv env SubDemand d CoreExpr e dmdAnal' :: AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr dmdAnal' AnalEnv _ SubDemand _ (Lit Literal lit) = DmdType -> CoreExpr -> WithDmdType CoreExpr forall a. DmdType -> a -> WithDmdType a WithDmdType DmdType nopDmdType (Literal -> CoreExpr forall b. Literal -> Expr b Lit Literal lit) dmdAnal' AnalEnv _ SubDemand _ (Type Type ty) = DmdType -> CoreExpr -> WithDmdType CoreExpr forall a. DmdType -> a -> WithDmdType a WithDmdType DmdType nopDmdType (Type -> CoreExpr forall b. Type -> Expr b Type Type ty) -- Doesn't happen, in fact dmdAnal' AnalEnv _ SubDemand _ (Coercion Coercion co) = DmdType -> CoreExpr -> WithDmdType CoreExpr forall a. DmdType -> a -> WithDmdType a WithDmdType (DmdEnv -> DmdType unitDmdType (Coercion -> DmdEnv coercionDmdEnv Coercion co)) (Coercion -> CoreExpr forall b. Coercion -> Expr b Coercion Coercion co) dmdAnal' AnalEnv env SubDemand dmd (Var Id var) = DmdType -> CoreExpr -> WithDmdType CoreExpr forall a. DmdType -> a -> WithDmdType a WithDmdType (AnalEnv -> Id -> SubDemand -> DmdType dmdTransform AnalEnv env Id var SubDemand dmd) (Id -> CoreExpr forall b. Id -> Expr b Var Id var) dmdAnal' AnalEnv env SubDemand dmd (Cast CoreExpr e Coercion co) = DmdType -> CoreExpr -> WithDmdType CoreExpr forall a. DmdType -> a -> WithDmdType a WithDmdType (DmdType dmd_ty DmdType -> PlusDmdArg -> DmdType `plusDmdType` DmdEnv -> PlusDmdArg mkPlusDmdArg (Coercion -> DmdEnv coercionDmdEnv Coercion co)) (CoreExpr -> Coercion -> CoreExpr forall b. Expr b -> Coercion -> Expr b Cast CoreExpr e' Coercion co) where WithDmdType DmdType dmd_ty CoreExpr e' = AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr dmdAnal AnalEnv env SubDemand dmd CoreExpr e dmdAnal' AnalEnv env SubDemand dmd (Tick CoreTickish t CoreExpr e) = DmdType -> CoreExpr -> WithDmdType CoreExpr forall a. DmdType -> a -> WithDmdType a WithDmdType DmdType dmd_ty (CoreTickish -> CoreExpr -> CoreExpr forall b. CoreTickish -> Expr b -> Expr b Tick CoreTickish t CoreExpr e') where WithDmdType DmdType dmd_ty CoreExpr e' = AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr dmdAnal AnalEnv env SubDemand dmd CoreExpr e dmdAnal' AnalEnv env SubDemand dmd (App CoreExpr fun (Type Type ty)) = DmdType -> CoreExpr -> WithDmdType CoreExpr forall a. DmdType -> a -> WithDmdType a WithDmdType DmdType fun_ty (CoreExpr -> CoreExpr -> CoreExpr forall b. Expr b -> Expr b -> Expr b App CoreExpr fun' (Type -> CoreExpr forall b. Type -> Expr b Type Type ty)) where WithDmdType DmdType fun_ty CoreExpr fun' = AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr dmdAnal AnalEnv env SubDemand dmd CoreExpr fun -- Lots of the other code is there to make this -- beautiful, compositional, application rule :-) dmdAnal' AnalEnv env SubDemand dmd (App CoreExpr fun CoreExpr arg) = -- This case handles value arguments (type args handled above) -- Crucially, coercions /are/ handled here, because they are -- value arguments (#10288) let call_dmd :: SubDemand call_dmd = SubDemand -> SubDemand mkCalledOnceDmd SubDemand dmd WithDmdType DmdType fun_ty CoreExpr fun' = AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr dmdAnal AnalEnv env SubDemand call_dmd CoreExpr fun (Demand arg_dmd, DmdType res_ty) = DmdType -> (Demand, DmdType) splitDmdTy DmdType fun_ty (PlusDmdArg arg_ty, CoreExpr arg') = AnalEnv -> Demand -> CoreExpr -> (PlusDmdArg, CoreExpr) dmdAnalStar AnalEnv env Demand arg_dmd CoreExpr arg in -- pprTrace "dmdAnal:app" (vcat -- [ text "dmd =" <+> ppr dmd -- , text "expr =" <+> ppr (App fun arg) -- , text "fun dmd_ty =" <+> ppr fun_ty -- , text "arg dmd =" <+> ppr arg_dmd -- , text "arg dmd_ty =" <+> ppr arg_ty -- , text "res dmd_ty =" <+> ppr res_ty -- , text "overall res dmd_ty =" <+> ppr (res_ty `plusDmdType` arg_ty) ]) DmdType -> CoreExpr -> WithDmdType CoreExpr forall a. DmdType -> a -> WithDmdType a WithDmdType (DmdType res_ty DmdType -> PlusDmdArg -> DmdType `plusDmdType` PlusDmdArg arg_ty) (CoreExpr -> CoreExpr -> CoreExpr forall b. Expr b -> Expr b -> Expr b App CoreExpr fun' CoreExpr arg') dmdAnal' AnalEnv env SubDemand dmd (Lam Id var CoreExpr body) | Id -> Bool isTyVar Id var = let WithDmdType DmdType body_ty CoreExpr body' = AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr dmdAnal (AnalEnv -> Id -> AnalEnv addInScopeAnalEnv AnalEnv env Id var) SubDemand dmd CoreExpr body -- See Note [Bringing a new variable into scope] in DmdType -> CoreExpr -> WithDmdType CoreExpr forall a. DmdType -> a -> WithDmdType a WithDmdType DmdType body_ty (Id -> CoreExpr -> CoreExpr forall b. b -> Expr b -> Expr b Lam Id var CoreExpr body') | Bool otherwise = let (Card n, SubDemand body_dmd) = SubDemand -> (Card, SubDemand) peelCallDmd SubDemand dmd -- body_dmd: a demand to analyze the body WithDmdType DmdType body_ty CoreExpr body' = AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr dmdAnal (AnalEnv -> Id -> AnalEnv addInScopeAnalEnv AnalEnv env Id var) SubDemand body_dmd CoreExpr body -- See Note [Bringing a new variable into scope] WithDmdType DmdType lam_ty Id var' = AnalEnv -> DmdType -> Id -> WithDmdType Id annotateLamIdBndr AnalEnv env DmdType body_ty Id var new_dmd_type :: DmdType new_dmd_type = Card -> DmdType -> DmdType multDmdType Card n DmdType lam_ty in DmdType -> CoreExpr -> WithDmdType CoreExpr forall a. DmdType -> a -> WithDmdType a WithDmdType DmdType new_dmd_type (Id -> CoreExpr -> CoreExpr forall b. b -> Expr b -> Expr b Lam Id var' CoreExpr body') dmdAnal' AnalEnv env SubDemand dmd (Case CoreExpr scrut Id case_bndr Type ty [Alt AltCon alt_con [Id] bndrs CoreExpr rhs]) -- Only one alternative. -- 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. | AltCon -> Bool want_precise_field_dmds AltCon alt_con = let rhs_env :: AnalEnv rhs_env = AnalEnv -> [Id] -> AnalEnv addInScopeAnalEnvs AnalEnv env (Id case_bndrId -> [Id] -> [Id] forall a. a -> [a] -> [a] :[Id] bndrs) -- See Note [Bringing a new variable into scope] WithDmdType DmdType rhs_ty CoreExpr rhs' = AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr dmdAnal AnalEnv rhs_env SubDemand dmd CoreExpr rhs WithDmdType DmdType alt_ty1 [Demand] fld_dmds = AnalEnv -> DmdType -> [Id] -> WithDmdType [Demand] findBndrsDmds AnalEnv env DmdType rhs_ty [Id] bndrs WithDmdType DmdType alt_ty2 Demand case_bndr_dmd = AnalEnv -> DmdType -> Id -> WithDmdType Demand findBndrDmd AnalEnv env DmdType alt_ty1 Id case_bndr !case_bndr' :: Id case_bndr' = Id -> Demand -> Id setIdDemandInfo Id case_bndr Demand case_bndr_dmd -- Evaluation cardinality on the case binder is irrelevant and a no-op. -- What matters is its nested sub-demand! -- NB: If case_bndr_dmd is absDmd, boxity will say Unboxed, which is -- what we want, because then `seq` will put a `seqDmd` on its scrut. (Card _ :* SubDemand case_bndr_sd) = Demand -> Demand strictifyDmd Demand case_bndr_dmd -- Compute demand on the scrutinee -- FORCE the result, otherwise thunks will end up retaining the -- whole DmdEnv !(![Id] bndrs', !SubDemand scrut_sd) | DataAlt DataCon _ <- AltCon alt_con -- See Note [Demand on the scrutinee of a product case] , let !scrut_sd :: SubDemand scrut_sd = SubDemand -> [Demand] -> SubDemand scrutSubDmd SubDemand case_bndr_sd [Demand] fld_dmds -- See Note [Demand on case-alternative binders] , let !fld_dmds' :: [Demand] fld_dmds' = SubDemand -> Arity -> [Demand] fieldBndrDmds SubDemand scrut_sd ([Demand] -> Arity forall a. [a] -> Arity forall (t :: * -> *) a. Foldable t => t a -> Arity length [Demand] fld_dmds) , let !bndrs' :: [Id] bndrs' = HasCallStack => [Id] -> [Demand] -> [Id] [Id] -> [Demand] -> [Id] setBndrsDemandInfo [Id] bndrs [Demand] fld_dmds' = ([Id] bndrs', SubDemand scrut_sd) | Bool otherwise -- DEFAULT alts. Simply add demands and discard the evaluation -- cardinality, as we evaluate the scrutinee exactly once. = Bool -> ([Id], SubDemand) -> ([Id], SubDemand) forall a. HasCallStack => Bool -> a -> a assert ([Id] -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [Id] bndrs) ([Id] bndrs, SubDemand case_bndr_sd) alt_ty3 :: DmdType alt_ty3 -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" | FamInstEnvs -> CoreExpr -> Bool exprMayThrowPreciseException (AnalEnv -> FamInstEnvs ae_fam_envs AnalEnv env) CoreExpr scrut = DmdType -> DmdType deferAfterPreciseException DmdType alt_ty2 | Bool otherwise = DmdType alt_ty2 WithDmdType DmdType scrut_ty CoreExpr scrut' = AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr dmdAnal AnalEnv env SubDemand scrut_sd CoreExpr scrut res_ty :: DmdType res_ty = DmdType alt_ty3 DmdType -> PlusDmdArg -> DmdType `plusDmdType` DmdType -> PlusDmdArg toPlusDmdArg DmdType scrut_ty in -- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut -- , text "dmd" <+> ppr dmd -- , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr') -- , text "scrut_sd" <+> ppr scrut_sd -- , text "scrut_ty" <+> ppr scrut_ty -- , text "alt_ty" <+> ppr alt_ty2 -- , text "res_ty" <+> ppr res_ty ]) $ DmdType -> CoreExpr -> WithDmdType CoreExpr forall a. DmdType -> a -> WithDmdType a WithDmdType DmdType res_ty (CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr forall b. Expr b -> b -> Type -> [Alt b] -> Expr b Case CoreExpr scrut' Id case_bndr' Type ty [AltCon -> [Id] -> CoreExpr -> Alt Id forall b. AltCon -> [b] -> Expr b -> Alt b Alt AltCon alt_con [Id] bndrs' CoreExpr rhs']) where want_precise_field_dmds :: AltCon -> Bool want_precise_field_dmds (DataAlt DataCon dc) | Maybe DataCon Nothing <- TyCon -> Maybe DataCon tyConSingleAlgDataCon_maybe (TyCon -> Maybe DataCon) -> TyCon -> Maybe DataCon forall a b. (a -> b) -> a -> b $ DataCon -> TyCon dataConTyCon DataCon dc = Bool False -- Not a product type, even though this is the -- only remaining possible data constructor | IsRecDataConResult DefinitelyRecursive <- AnalEnv -> DataCon -> IsRecDataConResult ae_rec_dc AnalEnv env DataCon dc = Bool False -- See Note [Demand analysis for recursive data constructors] | Bool otherwise = Bool True want_precise_field_dmds (LitAlt {}) = Bool False -- Like the non-product datacon above want_precise_field_dmds AltCon DEFAULT = Bool True dmdAnal' AnalEnv env SubDemand dmd (Case CoreExpr scrut Id case_bndr Type ty [Alt Id] alts) = let -- Case expression with multiple alternatives WithDmdType DmdType scrut_ty CoreExpr scrut' = AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr dmdAnal AnalEnv env SubDemand topSubDmd CoreExpr scrut WithDmdType DmdType alt_ty1 Demand case_bndr_dmd = AnalEnv -> DmdType -> Id -> WithDmdType Demand findBndrDmd AnalEnv env DmdType alt_ty Id case_bndr !case_bndr' :: Id case_bndr' = Id -> Demand -> Id setIdDemandInfo Id case_bndr Demand case_bndr_dmd WithDmdType DmdType alt_ty [Alt Id] alts' = AnalEnv -> SubDemand -> Id -> [Alt Id] -> WithDmdType [Alt Id] dmdAnalSumAlts AnalEnv env SubDemand dmd Id case_bndr [Alt Id] alts fam_envs :: FamInstEnvs fam_envs = AnalEnv -> FamInstEnvs ae_fam_envs AnalEnv env alt_ty2 :: DmdType alt_ty2 -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" | FamInstEnvs -> CoreExpr -> Bool exprMayThrowPreciseException FamInstEnvs fam_envs CoreExpr scrut = DmdType -> DmdType deferAfterPreciseException DmdType alt_ty1 | Bool otherwise = DmdType alt_ty1 res_ty :: DmdType res_ty = DmdType alt_ty2 DmdType -> PlusDmdArg -> DmdType `plusDmdType` DmdType -> PlusDmdArg toPlusDmdArg DmdType scrut_ty in -- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut -- , text "scrut_ty" <+> ppr scrut_ty -- , text "alt_ty1" <+> ppr alt_ty1 -- , text "alt_ty2" <+> ppr alt_ty2 -- , text "res_ty" <+> ppr res_ty ]) $ DmdType -> CoreExpr -> WithDmdType CoreExpr forall a. DmdType -> a -> WithDmdType a WithDmdType DmdType res_ty (CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr forall b. Expr b -> b -> Type -> [Alt b] -> Expr b Case CoreExpr scrut' Id case_bndr' Type ty [Alt Id] alts') dmdAnal' AnalEnv env SubDemand dmd (Let Bind Id bind CoreExpr body) = DmdType -> CoreExpr -> WithDmdType CoreExpr forall a. DmdType -> a -> WithDmdType a WithDmdType DmdType final_ty (Bind Id -> CoreExpr -> CoreExpr forall b. Bind b -> Expr b -> Expr b Let Bind Id bind' CoreExpr body') where !(WithDmdType DmdType final_ty (R Bind Id bind' CoreExpr body')) = TopLevelFlag -> AnalEnv -> SubDemand -> Bind Id -> (AnalEnv -> WithDmdType CoreExpr) -> WithDmdType (DmdResult (Bind Id) CoreExpr) forall a. TopLevelFlag -> AnalEnv -> SubDemand -> Bind Id -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult (Bind Id) a) dmdAnalBind TopLevelFlag NotTopLevel AnalEnv env SubDemand dmd Bind Id bind AnalEnv -> WithDmdType CoreExpr go' go' :: AnalEnv -> WithDmdType CoreExpr go' !AnalEnv env' = AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr dmdAnal AnalEnv env' SubDemand dmd CoreExpr body -- | A simple, syntactic analysis of whether an expression MAY throw a precise -- exception when evaluated. It's always sound to return 'True'. -- See Note [Which scrutinees may throw precise exceptions]. exprMayThrowPreciseException :: FamInstEnvs -> CoreExpr -> Bool exprMayThrowPreciseException :: FamInstEnvs -> CoreExpr -> Bool exprMayThrowPreciseException FamInstEnvs envs CoreExpr e | Bool -> Bool not (FamInstEnvs -> Type -> Bool forcesRealWorld FamInstEnvs envs ((() :: Constraint) => CoreExpr -> Type CoreExpr -> Type exprType CoreExpr e)) = Bool False -- 1. in the Note | (Var Id f, [CoreExpr] _) <- CoreExpr -> (CoreExpr, [CoreExpr]) forall b. Expr b -> (Expr b, [Expr b]) collectArgs CoreExpr e , Just PrimOp op <- Id -> Maybe PrimOp isPrimOpId_maybe Id f , PrimOp op PrimOp -> PrimOp -> Bool forall a. Eq a => a -> a -> Bool /= PrimOp RaiseIOOp = Bool False -- 2. in the Note | (Var Id f, [CoreExpr] _) <- CoreExpr -> (CoreExpr, [CoreExpr]) forall b. Expr b -> (Expr b, [Expr b]) collectArgs CoreExpr e , Just ForeignCall fcall <- Id -> Maybe ForeignCall isFCallId_maybe Id f , Bool -> Bool not (ForeignCall -> Bool isSafeForeignCall ForeignCall fcall) = Bool False -- 3. in the Note | Bool otherwise = Bool True -- _. in the Note -- | Recognises types that are -- * @State# RealWorld@ -- * Unboxed tuples with a @State# RealWorld@ field -- modulo coercions. This will detect 'IO' actions (even post Nested CPR! See -- T13380e) and user-written variants thereof by their type. forcesRealWorld :: FamInstEnvs -> Type -> Bool forcesRealWorld :: FamInstEnvs -> Type -> Bool forcesRealWorld FamInstEnvs fam_envs Type ty | Type ty Type -> Type -> Bool `eqType` Type realWorldStatePrimTy = Bool True | Just (TyCon tc, [Type] tc_args, Coercion _co) <- FamInstEnvs -> Type -> Maybe (TyCon, [Type], Coercion) normSplitTyConApp_maybe FamInstEnvs fam_envs Type ty , TyCon -> Bool isUnboxedTupleTyCon TyCon tc , let field_tys :: [Scaled Type] field_tys = DataCon -> [Type] -> [Scaled Type] dataConInstArgTys (TyCon -> DataCon tyConSingleDataCon TyCon tc) [Type] tc_args = (Scaled Type -> Bool) -> [Scaled Type] -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool any (Type -> Type -> Bool eqType Type realWorldStatePrimTy (Type -> Bool) -> (Scaled Type -> Type) -> Scaled Type -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . Scaled Type -> Type forall a. Scaled a -> a scaledThing) [Scaled Type] field_tys | Bool otherwise = Bool False dmdAnalSumAlts :: AnalEnv -> SubDemand -> Id -> [CoreAlt] -> WithDmdType [CoreAlt] dmdAnalSumAlts :: AnalEnv -> SubDemand -> Id -> [Alt Id] -> WithDmdType [Alt Id] dmdAnalSumAlts AnalEnv _ SubDemand _ Id _ [] = DmdType -> [Alt Id] -> WithDmdType [Alt Id] forall a. DmdType -> a -> WithDmdType a WithDmdType DmdType botDmdType [] -- Base case is botDmdType, for empty case alternatives -- This is a unit for lubDmdType, and the right result -- when there really are no alternatives dmdAnalSumAlts AnalEnv env SubDemand dmd Id case_bndr (Alt Id alt:[Alt Id] alts) = let WithDmdType DmdType cur_ty Alt Id alt' = AnalEnv -> SubDemand -> Id -> Alt Id -> WithDmdType (Alt Id) dmdAnalSumAlt AnalEnv env SubDemand dmd Id case_bndr Alt Id alt WithDmdType DmdType rest_ty [Alt Id] alts' = AnalEnv -> SubDemand -> Id -> [Alt Id] -> WithDmdType [Alt Id] dmdAnalSumAlts AnalEnv env SubDemand dmd Id case_bndr [Alt Id] alts in DmdType -> [Alt Id] -> WithDmdType [Alt Id] forall a. DmdType -> a -> WithDmdType a WithDmdType (DmdType -> DmdType -> DmdType lubDmdType DmdType cur_ty DmdType rest_ty) (Alt Id alt'Alt Id -> [Alt Id] -> [Alt Id] forall a. a -> [a] -> [a] :[Alt Id] alts') dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> CoreAlt -> WithDmdType CoreAlt dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Id -> WithDmdType (Alt Id) dmdAnalSumAlt AnalEnv env SubDemand dmd Id case_bndr (Alt AltCon con [Id] bndrs CoreExpr rhs) | let rhs_env :: AnalEnv rhs_env = AnalEnv -> [Id] -> AnalEnv addInScopeAnalEnvs AnalEnv env (Id case_bndrId -> [Id] -> [Id] forall a. a -> [a] -> [a] :[Id] bndrs) -- See Note [Bringing a new variable into scope] , WithDmdType DmdType rhs_ty CoreExpr rhs' <- AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr dmdAnal AnalEnv rhs_env SubDemand dmd CoreExpr rhs , WithDmdType DmdType alt_ty [Demand] dmds <- AnalEnv -> DmdType -> [Id] -> WithDmdType [Demand] findBndrsDmds AnalEnv env DmdType rhs_ty [Id] bndrs , let (Card _ :* SubDemand case_bndr_sd) = DmdType -> Id -> Demand findIdDemand DmdType alt_ty Id case_bndr -- See Note [Demand on case-alternative binders] -- we can't use the scrut_sd, because it says 'Prod' and we'll use -- topSubDmd anyway for scrutinees of sum types. scrut_sd :: SubDemand scrut_sd = SubDemand -> [Demand] -> SubDemand scrutSubDmd SubDemand case_bndr_sd [Demand] dmds dmds' :: [Demand] dmds' = SubDemand -> Arity -> [Demand] fieldBndrDmds SubDemand scrut_sd ([Demand] -> Arity forall a. [a] -> Arity forall (t :: * -> *) a. Foldable t => t a -> Arity length [Demand] dmds) -- Do not put a thunk into the Alt !new_ids :: [Id] new_ids = HasCallStack => [Id] -> [Demand] -> [Id] [Id] -> [Demand] -> [Id] setBndrsDemandInfo [Id] bndrs [Demand] dmds' = -- pprTrace "dmdAnalSumAlt" (ppr con $$ ppr case_bndr $$ ppr dmd $$ ppr alt_ty) $ DmdType -> Alt Id -> WithDmdType (Alt Id) forall a. DmdType -> a -> WithDmdType a WithDmdType DmdType alt_ty (AltCon -> [Id] -> CoreExpr -> Alt Id forall b. AltCon -> [b] -> Expr b -> Alt b Alt AltCon con [Id] new_ids CoreExpr rhs') -- See Note [Demand on the scrutinee of a product case] scrutSubDmd :: SubDemand -> [Demand] -> SubDemand scrutSubDmd :: SubDemand -> [Demand] -> SubDemand scrutSubDmd SubDemand case_sd [Demand] fld_dmds = -- pprTraceWith "scrutSubDmd" (\scrut_sd -> ppr case_sd $$ ppr fld_dmds $$ ppr scrut_sd) $ SubDemand case_sd SubDemand -> SubDemand -> SubDemand `plusSubDmd` Boxity -> [Demand] -> SubDemand mkProd Boxity Unboxed [Demand] fld_dmds -- See Note [Demand on case-alternative binders] fieldBndrDmds :: SubDemand -- on the scrutinee -> Arity -> [Demand] -- Final demands for the components of the DataCon fieldBndrDmds :: SubDemand -> Arity -> [Demand] fieldBndrDmds SubDemand scrut_sd Arity n_flds = case Arity -> SubDemand -> Maybe (Boxity, [Demand]) viewProd Arity n_flds SubDemand scrut_sd of Just (Boxity _, [Demand] ds) -> [Demand] ds Maybe (Boxity, [Demand]) Nothing -> Arity -> Demand -> [Demand] forall a. Arity -> a -> [a] replicate Arity n_flds Demand topDmd -- Either an arity mismatch or scrut_sd was a call demand. -- See Note [Untyped demand on case-alternative binders] {- Note [Anticipating ANF in demand analysis] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When analysing non-complex (e.g., trivial) thunks and complex function arguments, we have to pretend that the expression is really in administrative normal form (ANF), the conversion to which is done by CorePrep. Consider ``` f x = let y = x |> co in y `seq` y `seq` () ``` E.g., 'y' is a let-binding with a trivial RHS. That may occur if 'y' can't be inlined, for example. Now, is 'x' used once? It may appear as if that is the case, since its only occurrence is in 'y's memoised RHS. But actually, CorePrep will *not* allocate a thunk for 'y', because it is trivial and could just re-use the memoisation mechanism of 'x'! By saying that 'x' is used once it becomes a single-entry thunk and a call to 'f' will evaluate it twice. The same applies to trivial arguments, e.g., `f z` really evaluates `z` twice. So, somewhat counter-intuitively, trivial arguments and let RHSs will *not* be memoised. On the other hand, evaluation of non-trivial arguments and let RHSs *will* be memoised. In fact, consider the effect of conversion to ANF on complex function arguments (as done by 'GHC.Core.Prep.mkFloat'): ``` f2 (g2 x) ===> let y = g2 x in f2 y (if `y` is lifted) f3 (g3 x) ===> case g3 x of y { __DEFAULT -> f3 y } (if `y` is not lifted) ``` So if a lifted argument like `g2 x` is complex enough, it will be memoised. Regardless how many times 'f2' evaluates its parameter, the argument will be evaluated at most once to WHNF. Similarly, when an unlifted argument like `g3 x` is complex enough, we will evaluate it *exactly* once to WHNF, no matter how 'f3' evaluates its parameter. Note that any evaluation beyond WHNF is not affected by memoisation. So this Note affects the outer 'Card' of a 'Demand', but not its nested 'SubDemand'. 'anticipateANF' predicts the effect of case-binding and let-binding complex arguments, as well as the lack of memoisation for trivial let RHSs. In particular, this takes care of the gripes in Note [Analysing with absent demand] relating to unlifted types. Note [Analysing with absent demand] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we analyse an expression with demand A. The "A" means "absent", so this expression will never be needed. What should happen? There are several wrinkles: * We *do* want to analyse the expression regardless. Reason: Note [Always analyse in virgin pass] But we can post-process the results to ignore all the usage demands coming back. This is done by 'multDmdType' with the appropriate (absent) evaluation cardinality A or B. * Nevertheless, which sub-demand should we pick for analysis? Since the demand was absent, any would do. Worker/wrapper will replace absent bindings with an absent filler anyway, so annotations in the RHS of an absent binding don't matter much. Picking 'botSubDmd' would be the most useful, but would also look a bit misleading in the Core output of DmdAnal, because all nested annotations would be bottoming. Better pick 'seqSubDmd', so that we annotate many of those nested bindings with A themselves. * Since we allow unlifted arguments that are not ok-for-speculation, we need to be extra careful in the following situation, because unlifted values are evaluated even if they are not used. Example from #9254: f :: (() -> (# Int#, () #)) -> () -- Strictness signature is -- <1C(1,P(A,1L))> -- I.e. calls k, but discards first component of result f k = case k () of (# _, r #) -> r g :: Int -> () g y = f (\n -> (# case y of I# y2 -> y2, n #)) Here, f's strictness signature says (correctly) that it calls its argument function and ignores the first component of its result. But in function g, we *will* evaluate the 'case y of ...', because it has type Int#. So in the program as written, 'y' will be evaluated. Hence we must record this usage of 'y', else 'g' will say 'y' is absent, and will w/w so that 'y' is bound to an absent filler (see Note [Absent fillers]), leading to a crash when 'y' is evaluated. Now, worker/wrapper could be smarter and replace `case y of I# y2 -> y2` with a suitable absent filler such as `RUBBISH[IntRep] @Int#`. But as long as worker/wrapper isn't equipped to do so, we must be cautious, and follow Note [Anticipating ANF in demand analysis]. That is, in 'dmdAnalStar', we will set the evaluation cardinality to C_11, anticipating the case binding of the complex argument `case y of I# y2 -> y2`. This cardinlities' only effect is in the call to 'multDmdType', where it makes sure that the demand on the arg's free variable 'y' is not absent and strict, so that it is ultimately passed unboxed to 'g'. Note [Always analyse in virgin pass] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Tricky point: make sure that we analyse in the 'virgin' pass. Consider rec { f acc x True = f (...rec { g y = ...g... }...) f acc x False = acc } In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type. That might mean that we analyse the sub-expression containing the E = "...rec g..." stuff in a bottom demand. Suppose we *didn't analyse* E, but just returned botType. Then in the *next* (non-virgin) iteration for 'f', we might analyse E in a weaker demand, and that will trigger doing a fixpoint iteration for g. But *because it's not the virgin pass* we won't start g's iteration at bottom. Disaster. (This happened in $sfibToList' of nofib/spectral/fibheaps.) So in the virgin pass we make sure that we do analyse the expression at least once, to initialise its signatures. Note [Which scrutinees may throw precise exceptions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This is the specification of 'exprMayThrowPreciseExceptions', which is important for Scenario 2 of Note [Precise exceptions and strictness analysis] in GHC.Types.Demand. For an expression @f a1 ... an :: ty@ we determine that 1. False If ty is *not* @State# RealWorld@ or an unboxed tuple thereof. This check is done by 'forcesRealWorld'. (Why not simply unboxed pairs as above? This is motivated by T13380{d,e}.) 2. False If f is a PrimOp, and it is *not* raiseIO# 3. False If f is an unsafe FFI call ('PlayRisky') _. True Otherwise "give up". It is sound to return False in those cases, because 1. We don't give any guarantees for unsafePerformIO, so no precise exceptions from pure code. 2. raiseIO# is the only primop that may throw a precise exception. 3. Unsafe FFI calls may not interact with the RTS (to throw, for example). See haddock on GHC.Types.ForeignCall.PlayRisky. We *need* to return False in those cases, because 1. We would lose too much strictness in pure code, all over the place. 2. We would lose strictness for primops like getMaskingState#, which introduces a substantial regression in GHC.IO.Handle.Internals.wantReadableHandle. 3. We would lose strictness for code like GHC.Fingerprint.fingerprintData, where an intermittent FFI call to c_MD5Init would otherwise lose strictness on the arguments len and buf, leading to regressions in T9203 (2%) and i386's haddock.base (5%). Tested by T13380f. In !3014 we tried a more sophisticated analysis by introducing ConOrDiv (nic) 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. This code happens in want_precise_field_dmds in the Case equation for dmdAnal. 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]. 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 worker, so the worker will rebuild x = (a, absent-error) and that'll crash. Note [Demand on case-alternative binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The demand on a binder in a case alternative comes (a) From the demand on the binder itself (b) From the demand on the case binder Forgetting (b) led directly to #10148. Example. Source code: f x@(p,_) = if p then foo x else True foo (p,True) = True foo (p,q) = foo (q,p) After strictness analysis, forgetting (b): f = \ (x_an1 [Dmd=1P(1L,ML)] :: (Bool, Bool)) -> case x_an1 of wild_X7 [Dmd=MP(ML,ML)] { (p_an2 [Dmd=1L], ds_dnz [Dmd=A]) -> case p_an2 of _ { False -> GHC.Types.True; True -> foo wild_X7 } Note that ds_dnz is syntactically dead, but the expression bound to it is reachable through the case binder wild_X7. Now watch what happens if we inline foo's wrapper: f = \ (x_an1 [Dmd=1P(1L,ML)] :: (Bool, Bool)) -> case x_an1 of _ [Dmd=MP(ML,ML)] { (p_an2 [Dmd=1L], ds_dnz [Dmd=A]) -> case p_an2 of _ { False -> GHC.Types.True; True -> $wfoo_soq GHC.Types.True ds_dnz } Look at that! ds_dnz has come back to life in the call to $wfoo_soq! A second run of demand analysis would no longer infer ds_dnz to be absent. But unlike occurrence analysis, which infers properties of the *syntactic* shape of the program, the results of demand analysis describe expressions *semantically* and are supposed to be mostly stable across Simplification. That's why we should better account for (b). In #10148, we ended up emitting a single-entry thunk instead of an updateable thunk for a let binder that was an an absent case-alt binder during DmdAnal. This is needed even for non-product types, in case the case-binder is used but the components of the case alternative are not. Note [Untyped demand on case-alternative binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ With unsafeCoerce, #8037 and #22039 taught us that the demand on the case binder may be a call demand or have a different number of fields than the constructor of the case alternative it is used in. From T22039: blarg :: (Int, Int) -> Int blarg (x,y) = x+y -- blarg :: <1!P(1L,1L)> f :: Either Int Int -> Int f Left{} = 0 f e = blarg (unsafeCoerce e) ==> { desugars to } f = \ (ds_d1nV :: Either Int Int) -> case ds_d1nV of wild_X1 { Left ds_d1oV -> lvl_s1Q6; Right ipv_s1Pl -> blarg (case unsafeEqualityProof @(*) @(Either Int Int) @(Int, Int) of { UnsafeRefl co_a1oT -> wild_X1 `cast` (Sub (Sym co_a1oT) :: Either Int Int ~R# (Int, Int)) }) } The case binder `e`/`wild_X1` has demand 1!P(1L,1L), with two fields, from the call to `blarg`, but `Right` only has one field. Although the code will crash when executed, we must be able to analyse it in 'fieldBndrDmds' and conservatively approximate with Top instead of panicking because of the mismatch. In #22039, this kind of code was guarded behind a safe `cast` and thus dead code, but nevertheless led to a panic of the compiler. You might wonder why the same problem doesn't come up when scrutinising a product type instead of a sum type. It appears that for products, `wild_X1` will be inlined before DmdAnal. See also Note [mkWWstr and unsafeCoerce] for a related issue. Note [Aggregated demand for cardinality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ FIXME: This Note should be named [LetUp vs. LetDown] and probably predates said separation. SG We use different strategies for strictness and usage/cardinality to "unleash" demands captured on free variables by bindings. Let us consider the example: f1 y = let {-# NOINLINE h #-} h = y in (h, h) We are interested in obtaining cardinality demand U1 on |y|, as it is used only in a thunk, and, therefore, is not going to be updated any more. Therefore, the demand on |y|, captured and unleashed by usage of |h| is U1. However, if we unleash this demand every time |h| is used, and then sum up the effects, the ultimate demand on |y| will be U1 + U1 = U. In order to avoid it, we *first* collect the aggregate demand on |h| in the body of let-expression, and only then apply the demand transformer: transf[x](U) = {y |-> U1} so the resulting demand on |y| is U1. The situation is, however, different for strictness, where this aggregating approach exhibits worse results because of the nature of |both| operation for strictness. Consider the example: f y c = let h x = y |seq| x in case of True -> h True False -> y It is clear that |f| is strict in |y|, however, the suggested analysis will infer from the body of |let| that |h| is used lazily (as it is used in one branch only), therefore lazy demand will be put on its free variable |y|. Conversely, if the demand on |h| is unleashed right on the spot, we will get the desired result, namely, that |f| is strict in |y|. ************************************************************************ * * Demand transformer * * ************************************************************************ -} dmdTransform :: AnalEnv -- ^ The analysis environment -> Id -- ^ The variable -> SubDemand -- ^ The evaluation context of the var -> DmdType -- ^ The demand type unleashed by the variable in this -- context. The returned DmdEnv includes the demand on -- this function plus demand on its free variables -- See Note [What are demand signatures?] in "GHC.Types.Demand" dmdTransform :: AnalEnv -> Id -> SubDemand -> DmdType dmdTransform AnalEnv env Id var SubDemand sd -- Data constructors | Just DataCon con <- Id -> Maybe DataCon isDataConWorkId_maybe Id var = -- pprTraceWith "dmdTransform:DataCon" (\ty -> ppr con $$ ppr sd $$ ppr ty) $ [StrictnessMark] -> SubDemand -> DmdType dmdTransformDataConSig (DataCon -> [StrictnessMark] dataConRepStrictness DataCon con) SubDemand sd -- See Note [DmdAnal for DataCon wrappers] | Id -> Bool isDataConWrapId Id var, let rhs :: CoreExpr rhs = Unfolding -> CoreExpr uf_tmpl (Id -> Unfolding realIdUnfolding Id var) , WithDmdType DmdType dmd_ty CoreExpr _rhs' <- AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr dmdAnal AnalEnv env SubDemand sd CoreExpr rhs = DmdType dmd_ty -- Dictionary component selectors -- Used to be controlled by a flag. -- See #18429 for some perf measurements. | Just Class _ <- Id -> Maybe Class isClassOpId_maybe Id var = -- pprTrace "dmdTransform:DictSel" (ppr var $$ ppr (idDmdSig var) $$ ppr sd) $ DmdSig -> SubDemand -> DmdType dmdTransformDictSelSig (Id -> DmdSig idDmdSig Id var) SubDemand sd -- Imported functions | Id -> Bool isGlobalId Id var , let res :: DmdType res = DmdSig -> SubDemand -> DmdType dmdTransformSig (Id -> DmdSig idDmdSig Id var) SubDemand sd = -- pprTrace "dmdTransform:import" (vcat [ppr var, ppr (idDmdSig var), ppr sd, ppr res]) DmdType res -- Top-level or local let-bound thing for which we use LetDown ('useLetUp'). -- In that case, we have a strictness signature to unleash in our AnalEnv. | Just (DmdSig sig, TopLevelFlag top_lvl) <- AnalEnv -> Id -> Maybe (DmdSig, TopLevelFlag) lookupSigEnv AnalEnv env Id var , let fn_ty :: DmdType fn_ty = DmdSig -> SubDemand -> DmdType dmdTransformSig DmdSig sig SubDemand sd = -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr sd, ppr fn_ty]) $ case TopLevelFlag top_lvl of TopLevelFlag NotTopLevel -> DmdType -> Id -> Demand -> DmdType addVarDmd DmdType fn_ty Id var (Card C_11 (() :: Constraint) => Card -> SubDemand -> Demand Card -> SubDemand -> Demand :* SubDemand sd) TopLevelFlag TopLevel | Id -> Bool isInterestingTopLevelFn Id var -- Top-level things will be used multiple times or not at -- all anyway, hence the multDmd below: It means we don't -- have to track whether @var@ is used strictly or at most -- once, because ultimately it never will. -> DmdType -> Id -> Demand -> DmdType addVarDmd DmdType fn_ty Id var (Card C_0N Card -> Demand -> Demand `multDmd` (Card C_11 (() :: Constraint) => Card -> SubDemand -> Demand Card -> SubDemand -> Demand :* SubDemand sd)) -- discard strictness | Bool otherwise -> DmdType fn_ty -- don't bother tracking; just annotate with 'topDmd' later -- Everything else: -- * Local let binders for which we use LetUp (cf. 'useLetUp') -- * Lambda binders -- * Case and constructor field binders | Bool otherwise = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr boxity, ppr sd]) $ DmdEnv -> DmdType unitDmdType (Id -> Demand -> DmdEnv forall a. Id -> a -> VarEnv a unitVarEnv Id var (Card C_11 (() :: Constraint) => Card -> SubDemand -> Demand Card -> SubDemand -> Demand :* SubDemand sd)) {- ********************************************************************* * * Binding right-hand sides * * ********************************************************************* -} -- | @dmdAnalRhsSig@ analyses the given RHS to compute a demand signature -- for the LetDown rule. It works as follows: -- -- * assuming the weakest possible body sub-demand, L -- * looking at the definition -- * determining a strictness signature -- -- Since it assumed a body sub-demand of L, the resulting signature is -- applicable at any call site. dmdAnalRhsSig :: TopLevelFlag -> RecFlag -> AnalEnv -> SubDemand -> Id -> CoreExpr -> (AnalEnv, DmdEnv, Id, CoreExpr) -- Process the RHS of the binding, add the strictness signature -- to the Id, and augment the environment with the signature as well. -- See Note [NOINLINE and strictness] dmdAnalRhsSig :: TopLevelFlag -> RecFlag -> AnalEnv -> SubDemand -> Id -> CoreExpr -> (AnalEnv, DmdEnv, Id, CoreExpr) dmdAnalRhsSig TopLevelFlag top_lvl RecFlag rec_flag AnalEnv env SubDemand let_dmd Id id CoreExpr rhs = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr lazy_fv) $ (AnalEnv final_env, DmdEnv lazy_fv, Id final_id, CoreExpr final_rhs) where threshold_arity :: Arity threshold_arity = Id -> CoreExpr -> Arity thresholdArity Id id CoreExpr rhs rhs_dmd :: SubDemand rhs_dmd = Arity -> SubDemand -> SubDemand mkCalledOnceDmds Arity threshold_arity SubDemand body_dmd body_dmd :: SubDemand body_dmd | Id -> Bool isJoinId Id id -- See Note [Demand analysis for join points] -- See Note [Invariants on join points] invariant 2b, in GHC.Core -- threshold_arity matches the join arity of the join point -- See Note [Unboxed demand on function bodies returning small products] = AnalEnv -> RecFlag -> Maybe Type -> SubDemand -> SubDemand unboxedWhenSmall AnalEnv env RecFlag rec_flag (Id -> Maybe Type resultType_maybe Id id) SubDemand let_dmd | Bool otherwise -- See Note [Unboxed demand on function bodies returning small products] = AnalEnv -> RecFlag -> Maybe Type -> SubDemand -> SubDemand unboxedWhenSmall AnalEnv env RecFlag rec_flag (Id -> Maybe Type resultType_maybe Id id) SubDemand topSubDmd WithDmdType DmdType rhs_dmd_ty CoreExpr rhs' = AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr dmdAnal AnalEnv env SubDemand rhs_dmd CoreExpr rhs DmdType DmdEnv rhs_fv [Demand] rhs_dmds Divergence rhs_div = DmdType rhs_dmd_ty -- See Note [Boxity for bottoming functions] ([Demand] final_rhs_dmds, CoreExpr final_rhs) = AnalEnv -> Id -> Arity -> CoreExpr -> Divergence -> Maybe ([Demand], CoreExpr) finaliseArgBoxities AnalEnv env Id id Arity threshold_arity CoreExpr rhs' Divergence rhs_div Maybe ([Demand], CoreExpr) -> ([Demand], CoreExpr) -> ([Demand], CoreExpr) forall a. Maybe a -> a -> a `orElse` ([Demand] rhs_dmds, CoreExpr rhs') sig :: DmdSig sig = Arity -> DmdType -> DmdSig mkDmdSigForArity Arity threshold_arity (DmdEnv -> [Demand] -> Divergence -> DmdType DmdType DmdEnv sig_fv [Demand] final_rhs_dmds Divergence rhs_div) opts :: DmdAnalOpts opts = AnalEnv -> DmdAnalOpts ae_opts AnalEnv env final_id :: Id final_id = DmdAnalOpts -> Id -> DmdSig -> Id setIdDmdAndBoxSig DmdAnalOpts opts Id id DmdSig sig !final_env :: AnalEnv final_env = TopLevelFlag -> AnalEnv -> Id -> DmdSig -> AnalEnv extendAnalEnv TopLevelFlag top_lvl AnalEnv env Id final_id DmdSig sig -- See Note [Aggregated demand for cardinality] -- FIXME: That Note doesn't explain the following lines at all. The reason -- is really much different: When we have a recursive function, we'd -- have to also consider the free vars of the strictness signature -- when checking whether we found a fixed-point. That is expensive; -- we only want to check whether argument demands of the sig changed. -- reuseEnv makes it so that the FV results are stable as long as the -- last argument demands were. Strictness won't change. But used-once -- might turn into used-many even if the signature was stable and -- we'd have to do an additional iteration. reuseEnv makes sure that -- we never get used-once info for FVs of recursive functions. -- See #14816 where we try to get rid of reuseEnv. rhs_fv1 :: DmdEnv rhs_fv1 = case RecFlag rec_flag of RecFlag Recursive -> DmdEnv -> DmdEnv reuseEnv DmdEnv rhs_fv RecFlag NonRecursive -> DmdEnv rhs_fv -- See Note [Absence analysis for stable unfoldings and RULES] rhs_fv2 :: DmdEnv rhs_fv2 = DmdEnv rhs_fv1 DmdEnv -> VarSet -> DmdEnv `keepAliveDmdEnv` Id -> VarSet bndrRuleAndUnfoldingIds Id id -- See Note [Lazy and unleashable free variables] !(!DmdEnv lazy_fv, !DmdEnv sig_fv) = (Demand -> Bool) -> DmdEnv -> (DmdEnv, DmdEnv) forall a. (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a) partitionVarEnv Demand -> Bool isWeakDmd DmdEnv rhs_fv2 thresholdArity :: Id -> CoreExpr -> Arity -- See Note [Demand signatures are computed for a threshold arity based on idArity] thresholdArity :: Id -> CoreExpr -> Arity thresholdArity Id fn CoreExpr rhs = case Id -> Maybe Arity isJoinId_maybe Id fn of Just Arity join_arity -> (Id -> Bool) -> [Id] -> Arity forall a. (a -> Bool) -> [a] -> Arity count Id -> Bool isId ([Id] -> Arity) -> [Id] -> Arity forall a b. (a -> b) -> a -> b $ ([Id], CoreExpr) -> [Id] forall a b. (a, b) -> a fst (([Id], CoreExpr) -> [Id]) -> ([Id], CoreExpr) -> [Id] forall a b. (a -> b) -> a -> b $ Arity -> CoreExpr -> ([Id], CoreExpr) forall b. Arity -> Expr b -> ([b], Expr b) collectNBinders Arity join_arity CoreExpr rhs Maybe Arity Nothing -> Id -> Arity idArity Id fn -- | The result type after applying 'idArity' many arguments. Returns 'Nothing' -- when the type doesn't have exactly 'idArity' many arrows. resultType_maybe :: Id -> Maybe Type resultType_maybe :: Id -> Maybe Type resultType_maybe Id id | ([PiTyBinder] pis,Type ret_ty) <- Type -> ([PiTyBinder], Type) splitPiTys (Id -> Type idType Id id) , (PiTyBinder -> Bool) -> [PiTyBinder] -> Arity forall a. (a -> Bool) -> [a] -> Arity count PiTyBinder -> Bool isAnonPiTyBinder [PiTyBinder] pis Arity -> Arity -> Bool forall a. Eq a => a -> a -> Bool == Id -> Arity idArity Id id = Type -> Maybe Type forall a. a -> Maybe a Just (Type -> Maybe Type) -> Type -> Maybe Type forall a b. (a -> b) -> a -> b $! Type ret_ty | Bool otherwise = Maybe Type forall a. Maybe a Nothing unboxedWhenSmall :: AnalEnv -> RecFlag -> Maybe Type -> SubDemand -> SubDemand -- See Note [Unboxed demand on function bodies returning small products] unboxedWhenSmall :: AnalEnv -> RecFlag -> Maybe Type -> SubDemand -> SubDemand unboxedWhenSmall AnalEnv _ RecFlag _ Maybe Type Nothing SubDemand sd = SubDemand sd unboxedWhenSmall AnalEnv env RecFlag rec_flag (Just Type ret_ty) SubDemand sd = Arity -> Type -> SubDemand -> SubDemand go Arity 1 Type ret_ty SubDemand sd where -- Magic constant, bounding the depth of optimistic 'Unboxed' flags. We -- might want to minmax in the future. max_depth :: Arity max_depth | RecFlag -> Bool isRec RecFlag rec_flag = Arity 3 -- So we get at most something as deep as !P(L!P(L!L)) | Bool otherwise = Arity 1 -- Otherwise be unbox too deep in T18109, T18174 and others and get a bunch of stack overflows go :: Int -> Type -> SubDemand -> SubDemand go :: Arity -> Type -> SubDemand -> SubDemand go Arity depth Type ty SubDemand sd | Arity depth Arity -> Arity -> Bool forall a. Ord a => a -> a -> Bool <= Arity max_depth , Just (TyCon tc, [Type] tc_args, Coercion _co) <- FamInstEnvs -> Type -> Maybe (TyCon, [Type], Coercion) normSplitTyConApp_maybe (AnalEnv -> FamInstEnvs ae_fam_envs AnalEnv env) Type ty , Just DataCon dc <- TyCon -> Maybe DataCon tyConSingleAlgDataCon_maybe TyCon tc , [Id] -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null (DataCon -> [Id] dataConExTyCoVars DataCon dc) -- Can't unbox results with existentials , DataCon -> Arity dataConRepArity DataCon dc Arity -> Arity -> Bool forall a. Ord a => a -> a -> Bool <= DmdAnalOpts -> Arity dmd_unbox_width (AnalEnv -> DmdAnalOpts ae_opts AnalEnv env) , Just (Boxity _, [Demand] ds) <- Arity -> SubDemand -> Maybe (Boxity, [Demand]) viewProd (DataCon -> Arity dataConRepArity DataCon dc) SubDemand sd , [Type] arg_tys <- (Scaled Type -> Type) -> [Scaled Type] -> [Type] forall a b. (a -> b) -> [a] -> [b] map Scaled Type -> Type forall a. Scaled a -> a scaledThing ([Scaled Type] -> [Type]) -> [Scaled Type] -> [Type] forall a b. (a -> b) -> a -> b $ DataCon -> [Type] -> [Scaled Type] dataConInstArgTys DataCon dc [Type] tc_args , [Demand] -> [Type] -> Bool forall a b. [a] -> [b] -> Bool equalLength [Demand] ds [Type] arg_tys = Boxity -> [Demand] -> SubDemand mkProd Boxity Unboxed ([Demand] -> SubDemand) -> [Demand] -> SubDemand forall a b. (a -> b) -> a -> b $! (Type -> Demand -> Demand) -> [Type] -> [Demand] -> [Demand] forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] strictZipWith (Arity -> Type -> Demand -> Demand go_dmd (Arity depthArity -> Arity -> Arity forall a. Num a => a -> a -> a +Arity 1)) [Type] arg_tys [Demand] ds | Bool otherwise = SubDemand sd go_dmd :: Int -> Type -> Demand -> Demand go_dmd :: Arity -> Type -> Demand -> Demand go_dmd Arity depth Type ty Demand dmd = case Demand dmd of Demand AbsDmd -> Demand AbsDmd Demand BotDmd -> Demand BotDmd Card n :* SubDemand sd -> Card n (() :: Constraint) => Card -> SubDemand -> Demand Card -> SubDemand -> Demand :* Arity -> Type -> SubDemand -> SubDemand go Arity depth Type ty SubDemand sd -- | If given the (local, non-recursive) let-bound 'Id', 'useLetUp' determines -- whether we should process the binding up (body before rhs) or down (rhs -- before body). -- -- We use LetDown if there is a chance to get a useful strictness signature to -- unleash at call sites. LetDown is generally more precise than LetUp if we can -- correctly guess how it will be used in the body, that is, for which incoming -- demand the strictness signature should be computed, which allows us to -- unleash higher-order demands on arguments at call sites. This is mostly the -- case when -- -- * The binding takes any arguments before performing meaningful work (cf. -- 'idArity'), in which case we are interested to see how it uses them. -- * The binding is a join point, hence acting like a function, not a value. -- As a big plus, we know *precisely* how it will be used in the body; since -- it's always tail-called, we can directly unleash the incoming demand of -- the let binding on its RHS when computing a strictness signature. See -- [Demand analysis for join points]. -- -- Thus, if the binding is not a join point and its arity is 0, we have a thunk -- and use LetUp, implying that we have no usable demand signature available -- when we analyse the let body. -- -- Since thunk evaluation is memoised, we want to unleash its 'DmdEnv' of free -- vars at most once, regardless of how many times it was forced in the body. -- This makes a real difference wrt. usage demands. The other reason is being -- able to unleash a more precise product demand on its RHS once we know how the -- thunk was used in the let body. -- -- Characteristic examples, always assuming a single evaluation: -- -- * @let x = 2*y in x + x@ => LetUp. Compared to LetDown, we find out that -- the expression uses @y@ at most once. -- * @let x = (a,b) in fst x@ => LetUp. Compared to LetDown, we find out that -- @b@ is absent. -- * @let f x = x*2 in f y@ => LetDown. Compared to LetUp, we find out that -- the expression uses @y@ strictly, because we have @f@'s demand signature -- available at the call site. -- * @join exit = 2*y in if a then exit else if b then exit else 3*y@ => -- LetDown. Compared to LetUp, we find out that the expression uses @y@ -- strictly, because we can unleash @exit@'s signature at each call site. -- * For a more convincing example with join points, see Note [Demand analysis -- for join points]. -- useLetUp :: TopLevelFlag -> Var -> Bool useLetUp :: TopLevelFlag -> Id -> Bool useLetUp TopLevelFlag top_lvl Id f = TopLevelFlag -> Bool isNotTopLevel TopLevelFlag top_lvl Bool -> Bool -> Bool && Id -> Arity idArity Id f Arity -> Arity -> Bool forall a. Eq a => a -> a -> Bool == Arity 0 Bool -> Bool -> Bool && Bool -> Bool not (Id -> Bool isJoinId Id f) {- Note [Demand analysis for join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider g :: (Int,Int) -> Int g (p,q) = p+q f :: T -> Int -> Int f x p = g (join j y = (p,y) in case x of A -> j 3 B -> j 4 C -> (p,7)) If j was a vanilla function definition, we'd analyse its body with evalDmd, and think that it was lazy in p. But for join points we can do better! We know that j's body will (if called at all) be evaluated with the demand that consumes the entire join-binding, in this case the argument demand from g. Whizzo! g evaluates both components of its argument pair, so p will certainly be evaluated if j is called. For f to be strict in p, we need /all/ paths to evaluate p; in this case the C branch does so too, so we are fine. So, as usual, we need to transport demands on free variables to the call site(s). Compare Note [Lazy and unleashable free variables]. The implementation is easy. When analysing a join point, we can analyse its body with the demand from the entire join-binding (written let_dmd here). Another win for join points! #13543. However, note that the strictness signature for a join point can look a little puzzling. E.g. (join j x = \y. error "urk") (in case v of ) ( A -> j 3 ) x ( B -> j 4 ) ( C -> \y. blah ) The entire thing is in a C(1,L) context, so j's strictness signature will be [A]b meaning one absent argument, returns bottom. That seems odd because there's a \y inside. But it's right because when consumed in a C(1,L) context the RHS of the join point is indeed bottom. Note [Demand signatures are computed for a threshold arity based on idArity] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Given a binding { f = rhs }, we compute a "theshold arity", and do demand analysis based on a call with that many value arguments. The threshold we use is * Ordinary bindings: idArity f. Why idArity arguments? Because that's a conservative estimate of how many arguments we must feed a function before it does anything interesting with them. Also it elegantly subsumes the trivial RHS and PAP case. idArity is /at least/ the number of manifest lambdas, but might be higher for PAPs and trivial RHS (see Note [Demand analysis for trivial right-hand sides]). * Join points: the value-binder subset of the JoinArity. This can be less than the number of visible lambdas; e.g. join j x = \y. blah in ...(jump j 2)....(jump j 3).... We know that j will never be applied to more than 1 arg (its join arity, and we don't eta-expand join points, so here a threshold of 1 is the best we can do. Note that the idArity of a function varies independently of its cardinality properties (cf. Note [idArity varies independently of dmdTypeDepth]), so we implicitly encode the arity for when a demand signature is sound to unleash in its 'dmdTypeDepth', not in its idArity (cf. Note [Understanding DmdType and DmdSig] in GHC.Types.Demand). It is unsound to unleash a demand signature when the incoming number of arguments is less than that. See GHC.Types.Demand Note [What are demand signatures?] for more details on soundness. Note that there might, in principle, be functions for which we might want to analyse for more incoming arguments than idArity. Example: f x = if expensive then \y -> ... y ... else \y -> ... y ... We'd analyse `f` under a unary call demand C(1,L), corresponding to idArity being 1. That's enough to look under the manifest lambda and find out how a unary call would use `x`, but not enough to look into the lambdas in the if branches. On the other hand, if we analysed for call demand C(1,C(1,L)), we'd get useful strictness info for `y` (and more precise info on `x`) and possibly CPR information, but * We would no longer be able to unleash the signature at unary call sites * Performing the worker/wrapper split based on this information would be implicitly eta-expanding `f`, playing fast and loose with divergence and even being unsound in the presence of newtypes, so we refrain from doing so. Also see Note [Don't eta expand in w/w] in GHC.Core.Opt.WorkWrap. Since we only compute one signature, we do so for arity 1. Computing multiple signatures for different arities (i.e., polyvariance) would be entirely possible, if it weren't for the additional runtime and implementation complexity. Note [idArity varies independently of dmdTypeDepth] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In general, an Id `f` has two independently varying attributes: * f's idArity, and * the dmdTypeDepth of f's demand signature For example, if f's demand signature is <L><L>, f's arity could be greater than, or less than 2. Why? Because both are conservative approximations: * Arity n means "does no expensive work until applied to at least n args" (e.g. (f x1..xm) is cheap to bring to HNF for m<n) * Dmd sig with n args means "here is how to transform the incoming demand when applied to n args". This is /semantic/ property, unrelated to arity. See GHC.Types.Demand Note [Understanding DmdType and DmdSig] We used to check in GHC.Core.Lint that dmdTypeDepth <= idArity for a let-bound identifier. But that means we would have to zap demand signatures every time we reset or decrease arity. For example, consider the following expression: (let go x y = `x` seq ... in go) |> co `go` might have a strictness signature of `<1L><L>`. The simplifier will identify `go` as a nullary join point through `joinPointBinding_maybe` and float the coercion into the binding, leading to an arity decrease: join go = (\x y -> `x` seq ...) |> co in go With the CoreLint check, we would have to zap `go`'s perfectly viable strictness signature. However, in the case of a /bottoming/ signature, f : <L><L>b, we /can/ say that f's arity is no greater than 2, because it'd be false to say that f does no work when applied to 3 args. Lint checks this constraint, in `GHC.Core.Lint.lintLetBind`. Note [Demand analysis for trivial right-hand sides] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider foo = plusInt |> co where plusInt is an arity-2 function with known strictness. Clearly we want plusInt's strictness to propagate to foo! But because it has no manifest lambdas, it won't do so automatically, and indeed 'co' might have type (Int->Int->Int) ~ T. Fortunately, GHC.Core.Opt.Arity gives 'foo' arity 2, which is enough for LetDown to forward plusInt's demand signature, and all is well (see Note [Newtype arity] in GHC.Core.Opt.Arity)! A small example is the test case NewtypeArity. Note [Absence analysis for stable unfoldings and RULES] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Ticket #18638 shows that it's really important to do absence analysis for stable unfoldings. Consider g = blah f = \x. ...no use of g.... {- f's stable unfolding is f = \x. ...g... -} If f is ever inlined we use 'g'. But f's current RHS makes no use of 'g', so if we don't look at the unfolding we'll mark g as Absent, and transform to g = error "Entered absent value" f = \x. ... {- f's stable unfolding is f = \x. ...g... -} Now if f is subsequently inlined, we'll use 'g' and ... disaster. SOLUTION: if f has a stable unfolding, adjust its DmdEnv (the demands on its free variables) so that no variable mentioned in its unfolding is Absent. This is done by the function Demand.keepAliveDmdEnv. ALSO: do the same for Ids free in the RHS of any RULES for f. PS: You may wonder how it can be that f's optimised RHS has somehow discarded 'g', but when f is inlined we /don't/ discard g in the same way. I think a simple example is g = (a,b) f = \x. fst g {-# INLINE f #-} Now f's optimised RHS will be \x.a, but if we change g to (error "..") (since it is apparently Absent) and then inline (\x. fst g) we get disaster. But regardless, #18638 was a more complicated version of this, that actually happened in practice. Note [DmdAnal for DataCon wrappers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We give DataCon wrappers a (necessarily flat) demand signature in `GHC.Types.Id.Make.mkDataConRep`, so that passes such as the Simplifier can exploit it via the call to `GHC.Core.Opt.Simplify.Utils.isStrictArgInfo` in `GHC.Core.Opt.Simplify.Iteration.rebuildCall`. But during DmdAnal, we *ignore* the demand signature of a DataCon wrapper, and instead analyse its unfolding at every call site. The reason is that DataCon *worker*s have very precise demand transformers, computed by `dmdTransformDataConSig`. It would be awkward if DataCon *wrappers* would behave much less precisely during DmdAnal. Example: data T1 = MkT1 { get_x1 :: Int, get_y1 :: Int } data T2 = MkT2 { get_x2 :: !Int, get_y2 :: Int } f1 x y = get_x1 (MkT1 x y) f2 x y = get_x2 (MkT2 x y) Here `MkT1` has no wrapper. `get_x1` puts a demand `!P(1!L,A)` on its argument, and `dmdTransformDataConSig` will transform that demand to an absent demand on `y` in `f1` and an unboxing demand on `x`. But `MkT2` has a wrapper (to evaluate the first field). If demand analysis deals with `MkT2` only through its demand signature, demand signatures can't transform an incoming demand `P(1!L,A)` in a useful way, so we won't get an absent demand on `y` in `f2` or see that `x` can be unboxed. That's a serious loss. The example above will not actually occur, because $WMkT2 would be inlined. Nevertheless, we can get interesting sub-demands on DataCon wrapper applications in boring contexts; see T22241. You might worry about the efficiency cost of demand-analysing datacon wrappers at every call site. But in fact they are inlined /anyway/ in the Final phase, which happens before DmdAnal, so few wrappers remain. And analysing the unfoldings for the remaining calls (which are those in a boring context) will be exactly as (in)efficent as if we'd inlined those calls. It turns out to be not measurable in practice. See also Note [CPR for DataCon wrappers] in `GHC.Core.Opt.CprAnal`. Note [Boxity for bottoming functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider (A) indexError :: Show a => (a, a) -> a -> String -> b -- Str=<..><1!P(S,S)><1S><S>b indexError rng i s = error (show rng ++ show i ++ show s) get :: (Int, Int) -> Int -> [a] -> a get p@(l,u) i xs | l <= i, i < u = xs !! (i-u) | otherwise = indexError p i "get" The hot path of `get` certainly wants to unbox `p` as well as `l` and `u`, but the unimportant, diverging error path needs `l::a` and `u::a` boxed, since `indexError` can't unbox them because they are polymorphic. This pattern often occurs in performance sensitive code that does bounds-checking. So we want to give `indexError` a signature like `<1!P(!S,!S)><1!S><S!S>b` where the !S (meaning Poly Unboxed C1N) says that the polymorphic arguments are unboxed (recursively). The wrapper for `indexError` won't /acutally/ unbox them (because their polymorphic type doesn't allow that) but when demand-analysing /callers/, we'll behave as if that call needs the args unboxed. Then at call sites of `indexError`, we will end up doing some reboxing, because `$windexError` still takes boxed arguments. This reboxing should usually float into the slow, diverging code path; but sometimes (sadly) it doesn't: see Note [Reboxed crud for bottoming calls]. Here is another important case (B): f x = Just x -- Suppose f is not inlined for some reason -- Main point: f takes its argument boxed wombat x = error (show (f x)) g :: Bool -> Int -> a g True x = x+1 g False x = wombat x Again we want `wombat` to pretend to take its Int-typed argument unboxed, even though it has to pass it boxed to `f`, so that `g` can take its argument unboxed (and rebox it before calling `wombat`). So here's what we do: while summarising `indexError`'s boxity signature in `finaliseArgBoxities`: * To address (B), for bottoming functions, we start by using `unboxDeeplyDmd` to make all its argument demands unboxed, right to the leaves; regardless of what the analysis said. * To address (A), for bottoming functions, in the DontUnbox case when the argument is a type variable, we /refrain/ from using trimBoxity. (Remember the previous bullet: we have already doen `unboxDeeplyDmd`.) Wrinkle: * Remember Note [No lazy, Unboxed demands in demand signature]. So unboxDeeplyDmd doesn't recurse into lazy demands. It's extremely unusual to have lazy demands in the arguments of a bottoming function anyway. But it can happen, when the demand analyser gives up because it encounters a recursive data type; see Note [Demand analysis for recursive data constructors]. Note [Reboxed crud for bottoming calls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For functions like `get` in Note [Boxity for bottoming functions], it's clear that the reboxed crud will be floated inside to the call site of `$windexError`. But here's an example where that is not the case: ```hs import GHC.Ix theresCrud :: Int -> Int -> Int theresCrud x y = go x where go 0 = index (0,y) 0 go 1 = index (x,y) 1 go n = go (n-1) {-# NOINLINE theresCrud #-} ``` If you look at the Core, you'll see that `y` will be reboxed and used in the two exit join points for the `$windexError` calls, while `x` is only reboxed in the exit join point for `index (x,y) 1` (happens in lvl below): ``` $wtheresCrud = \ ww ww1 -> let { y = I# ww1 } in join { lvl2 = ... case lvl1 ww y of wild { }; ... } in join { lvl3 = ... case lvl y of wild { }; ... } in ... ``` This is currently a bug that we willingly accept and it's documented in #21128. See also Note [indexError] in base:GHC.Ix, which describes how we use SPECIALISE to mitigate this problem for indexError. -} {- ********************************************************************* * * Finalising boxity * * ********************************************************************* -} {- Note [Finalising boxity for demand signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The worker/wrapper pass must strictly adhere to the boxity decisions encoded in the demand signature, because that is the information that demand analysis propagates throughout the program. Failing to implement the strategy laid out in the signature can result in reboxing in unexpected places. Hence, we must completely anticipate unboxing decisions during demand analysis and reflect these decisions in demand annotations. That is the job of 'finaliseArgBoxities', which is defined here and called from demand analysis. Here is a list of different Notes it has to take care of: * Note [No lazy, Unboxed demands in demand signature] such as `L!P(L)` in general, but still allow Note [Unboxing evaluated arguments] * Note [No nested Unboxed inside Boxed in demand signature] such as `1P(1!L)` * Note [mkWWstr and unsafeCoerce] NB: Then, the worker/wrapper blindly trusts the boxity info in the demand signature; that is why 'canUnboxArg' does not look at strictness -- it is redundant to do so. Note [Finalising boxity for let-bound Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider let x = e in body where the demand on 'x' is 1!P(blah). We want to unbox x according to Note [Thunk splitting] in GHC.Core.Opt.WorkWrap. We must do this because worker/wrapper ignores strictness and looks only at boxity flags; so if x's demand is L!P(blah) we might still split it (wrongly). We want to switch to Boxed on any lazy demand. That is what finaliseLetBoxity does. It has no worker-arg budget, so it is much simpler than finaliseArgBoxities. Note [No nested Unboxed inside Boxed in demand signature] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider ``` f p@(x,y) | even (x+y) = [] | otherwise = [p] ``` Demand analysis will infer that the function body puts a demand of `1P(1!L,1!L)` on 'p', e.g., Boxed on the outside but Unboxed on the inside. But worker/wrapper can't unbox the pair components without unboxing the pair! So we better say `1P(1L,1L)` in the demand signature in order not to spread wrong Boxity info. That happens via the call to trimBoxity in 'finaliseArgBoxities'/'finaliseLetBoxity'. Note [No lazy, Unboxed demands in demand signature] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider T19407: data Huge = Huge Bool () ... () -- think: DynFlags data T = T { h :: Huge, n :: Int } f t@(T h _) = g h t g (H b _ ... _) t = if b then 1 else n t The body of `g` puts (approx.) demand `L!P(A,1)` on `t`. But we better not put that demand in `g`'s demand signature, because worker/wrapper will not in general unbox a lazy-and-unboxed demand like `L!P(..)`. (The exception are known-to-be-evaluated arguments like strict fields, see Note [Unboxing evaluated arguments].) The program above is an example where spreading misinformed boxity through the signature is particularly egregious. If we give `g` that signature, then `f` puts demand `S!P(1!P(1L,A,..),ML)` on `t`. Now we will unbox `t` in `f` it and we get f (T (H b _ ... _) n) = $wf b n $wf b n = $wg b (T (H b x ... x) n) $wg = ... Massive reboxing in `$wf`! Solution: Trim boxity on lazy demands in 'trimBoxity', modulo Note [Unboxing evaluated arguments]. Note [Unboxing evaluated arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this program (due to Roman): data X a = X !a foo :: X Int -> Int -> Int foo x@(X a) n = go 0 where go i | i < n = a + go (i+1) | otherwise = 0 We want the worker for 'foo' to look like this: $wfoo :: Int# -> Int# -> Int# with the first argument unboxed, so that it is not eval'd each time around the 'go' loop (which would otherwise happen, since 'foo' is not strict in 'a'). It is sound for the wrapper to pass an unboxed arg because X is strict (see Note [Strictness and Unboxing] in "GHC.Core.Opt.DmdAnal"), so its argument must be evaluated. And if we *don't* pass an unboxed argument, we can't even repair it by adding a `seq` thus: foo (X a) n = a `seq` go 0 because the seq is discarded (very early) since X is strict! So here's what we do * Since this has nothing to do with how 'foo' uses 'a', we leave demand analysis alone, but account for the additional evaluatedness when annotating the binder 'finaliseArgBoxities', which will retain the Unboxed boxity on 'a' in the definition of 'foo' in the demand 'L!P(L)'; meaning it's used lazily but unboxed nonetheless. This seems to contradict Note [No lazy, Unboxed demands in demand signature], but we know that 'a' is evaluated and thus can be unboxed. * When 'finaliseArgBoxities' decides to unbox a record, it will zip the field demands together with the respective 'StrictnessMark'. In case of 'x', it will pair up the lazy field demand 'L!P(L)' on 'a' with 'MarkedStrict' to account for the strict field. * Said 'StrictnessMark' is passed to the recursive invocation of 'go_args' in 'finaliseArgBoxities' when deciding whether to unbox 'a'. 'a' was used lazily, but since it also says 'MarkedStrict', we'll retain the 'Unboxed' boxity on 'a'. * Worker/wrapper will consult 'canUnboxArg' for its unboxing decision. It will /not/ look at the strictness bits of the demand, only at Boxity flags. As such, it will happily unbox 'a' despite the lazy demand on it. The net effect is that boxity analysis and the w/w transformation are more aggressive about unboxing the strict arguments of a data constructor than when looking at strictness info exclusively. It is very much like (Nested) CPR, which needs its nested fields to be evaluated in order for it to unbox nestedly. There is the usual danger of reboxing, which as usual we ignore. But if X is monomorphic, and has an UNPACK pragma, then this optimisation is even more important. We don't want the wrapper to rebox an unboxed argument, and pass an Int to $wfoo! This works in nested situations like T10482 data family Bar a data instance Bar (a, b) = BarPair !(Bar a) !(Bar b) newtype instance Bar Int = Bar Int foo :: Bar ((Int, Int), Int) -> Int -> Int foo f k = case f of BarPair x y -> case burble of True -> case x of BarPair p q -> ... False -> ... The extra eagerness lets us produce a worker of type: $wfoo :: Int# -> Int# -> Int# -> Int -> Int $wfoo p# q# y# = ... even though the `case x` is only lazily evaluated. --------- Historical note ------------ We used to add data-con strictness demands when demand analysing case expression. However, it was noticed in #15696 that this misses some cases. For instance, consider the program (from T10482) data family Bar a data instance Bar (a, b) = BarPair !(Bar a) !(Bar b) newtype instance Bar Int = Bar Int foo :: Bar ((Int, Int), Int) -> Int -> Int foo f k = case f of BarPair x y -> case burble of True -> case x of BarPair p q -> ... False -> ... We really should be able to assume that `p` is already evaluated since it came from a strict field of BarPair. This strictness would allow us to produce a worker of type: $wfoo :: Int# -> Int# -> Int# -> Int -> Int $wfoo p# q# y# = ... even though the `case x` is only lazily evaluated Indeed before we fixed #15696 this would happen since we would float the inner `case x` through the `case burble` to get: foo f k = case f of BarPair x y -> case x of BarPair p q -> case burble of True -> ... False -> ... However, after fixing #15696 this could no longer happen (for the reasons discussed in ticket:15696#comment:76). This means that the demand placed on `f` would then be significantly weaker (since the False branch of the case on `burble` is not strict in `p` or `q`). Consequently, we now instead account for data-con strictness in mkWWstr_one, applying the strictness demands to the final result of DmdAnal. The result is that we get the strict demand signature we wanted even if we can't float the case on `x` up through the case on `burble`. Note [Do not unbox class dictionaries] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We never unbox class dictionaries in worker/wrapper. 1. INLINABLE functions If we have f :: Ord a => [a] -> Int -> a {-# INLINABLE f #-} and we worker/wrapper f, we'll get a worker with an INLINABLE pragma (see Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap), which can still be specialised by the type-class specialiser, something like fw :: Ord a => [a] -> Int# -> a BUT if f is strict in the Ord dictionary, we might unpack it, to get fw :: (a->a->Bool) -> [a] -> Int# -> a and the type-class specialiser can't specialise that. An example is #6056. Historical note: #14955 describes how I got this fix wrong the first time. I got aware of the issue in T5075 by the change in boxity of loop between demand analysis runs. 2. -fspecialise-aggressively. As #21286 shows, the same phenomenon can occur occur without INLINABLE, when we use -fexpose-all-unfoldings and -fspecialise-aggressively to do vigorous cross-module specialisation. 3. #18421 found that unboxing a dictionary can also make the worker less likely to inline; the inlining heuristics seem to prefer to inline a function applied to a dictionary over a function applied to a bunch of functions. TL;DR we /never/ unbox class dictionaries. Unboxing the dictionary, and passing a raft of higher-order functions isn't a huge win anyway -- you really want to specialise the function. Note [Worker argument budget] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In 'finaliseArgBoxities' we don't want to generate workers with zillions of argument when, say given a strict record with zillions of fields. So we limit the maximum number of worker args ('max_wkr_args') to the maximum of - -fmax-worker-args=N - The number of args in the original function; if it already has has zillions of arguments we don't want to seek /fewer/ args in the worker. (Maybe we should /add/ them instead of maxing?) We pursue a "layered" strategy for unboxing: we unbox the top level of the argument(s), subject to budget; if there are any arguments left we unbox the next layer, using that depleted budget. Unboxing an argument *increases* the budget for the inner layer roughly according to how many registers that argument takes (unboxed tuples take multiple registers, see below), as determined by 'unariseArity'. Budget is spent when we have to pass a non-absent field as a parameter. To achieve this, we use the classic almost-circular programming technique in which we we write one pass that takes a lazy list of the Budgets for every layer. The effect is that of a breadth-first search (over argument type and demand structure) to compute Budgets followed by a depth-first search to construct the product demands, but laziness allows us to do it all in one pass and without intermediate data structures. Suppose we have -fmax-worker-args=4 for the remainder of this Note. Then consider this example function: boxed :: (Int, Int) -> (Int, (Int, Int, Int)) -> Int boxed (a,b) (c, (d,e,f)) = a + b + c + d + e + f With a budget of 4 args to spend (number of args is only 2), we'd be served well to unbox both pairs, but not the triple. Indeed, that is what the algorithm computes, and the following pictogram shows how the budget layers are computed. Each layer is started with `n ~>`, where `n` is the budget at the start of the layer. We write -n~> when we spend budget (and n is the remaining budget) and +n~> when we earn budget. We separate unboxed args with ][ and indicate inner budget threads becoming negative in braces {{}}, so that we see which unboxing decision we do *not* commit to. Without further ado: 4 ~> ][ (a,b) -3~> ][ (c, ...) -2~> ][ | | ][ | | ][ | +-------------+ ][ | +-----------------+ ][ | | ][ | | ][ v v ][ v v 2 ~> ][ +3~> a -2~> ][ b -1~> ][ +2~> c -1~> ][ (d, e, f) -0~> ][ | ][ | ][ | ][ {{ | | | }} ][ | ][ | ][ | ][ {{ | | +----------------+ }} ][ v ][ v ][ v ][ {{ v +------v v }} 0 ~> ][ +1~> I# -0~> ][ +1~> I# -0~> ][ +1~> I# -0~> ][ {{ +1~> d -0~> ][ e -(-1)~> ][ f -(-2)~> }} Unboxing increments the budget we have on the next layer (because we don't need to retain the boxed arg), but in turn the inner layer must afford to retain all non-absent fields, each decrementing the budget. Note how the budget becomes negative when trying to unbox the triple and the unboxing decision is "rolled back". This is done by the 'positiveTopBudget' guard. There's a bit of complication as a result of handling unboxed tuples correctly; specifically, handling nested unboxed tuples. Consider (#21737) unboxed :: (Int, Int) -> (# Int, (# Int, Int, Int #) #) -> Int unboxed (a,b) (# c, (# d, e, f #) #) = a + b + c + d + e + f Recall that unboxed tuples will be flattened to individual arguments during unarisation. Here, `unboxed` will have 5 arguments at runtime because of the nested unboxed tuple, which will be flattened to 4 args. So it's best to leave `(a,b)` boxed (because we already are above our arg threshold), but unbox `c` through `f` because that doesn't increase the number of args post unarisation. Note that the challenge is that syntactically, `(# d, e, f #)` occurs in a deeper layer than `(a, b)`. Treating unboxed tuples as a regular data type, we'd make the same unboxing decisions as for `boxed` above; although our starting budget is 5 (Here, the number of args is greater than -fmax-worker-args), it's not enough to unbox the triple (we'd finish with budget -1). So we'd unbox `a` through `c`, but not `d` through `f`, which is silly, because then we'd end up having 6 arguments at runtime, of which `d` through `f` weren't unboxed. Hence we pretend that the fields of unboxed tuples appear in the same budget layer as the tuple itself. For example at the top-level, `(# x,y #)` is to be treated just like two arguments `x` and `y`. Of course, for that to work, our budget calculations must initialise 'max_wkr_args' to 5, based on the 'unariseArity' of each Core arg: That would be 1 for the pair and 4 for the unboxed pair. Then when we decide whether to unbox the unboxed pair, we *directly* recurse into the fields, spending our budget on retaining `c` and (after recursing once more) `d` through `f` as arguments, depleting our budget completely in the first layer. Pictorially: 5 ~> ][ (a,b) -4~> ][ (# c, ... #) ][ {{ | | }} ][ c -3~> ][ (# d, e, f #) ][ {{ | +-------+ }} ][ | ][ d -2~> ][ e -1~> ][ f -0~> ][ {{ | | }} ][ | ][ | ][ | ][ | ][ {{ v v }} ][ v ][ v ][ v ][ v 0 ~> ][ {{ +1~> a -0~> ][ b -(-1)~> }} ][ +1~> I# -0~> ][ +1~> I# -0~> ][ +1~> I# -0~> ][ +1~> I# -0~> As you can see, we have no budget left to justify unboxing `(a,b)` on the second layer, which is good, because it would increase the number of args. Also note that we can still unbox `c` through `f` in this layer, because doing so has a net zero effect on budget. Note [The OPAQUE pragma and avoiding the reboxing of arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In https://gitlab.haskell.org/ghc/ghc/-/issues/13143 it was identified that when a function 'f' with a NOINLINE pragma is W/W transformed, then the worker for 'f' should get the NOINLINE annotation, while the wrapper /should/ be inlined. That's because if the wrapper for 'f' had stayed NOINLINE, then any worker of a W/W-transformed /caller of/ 'f' would immediately rebox any unboxed arguments that is applied to the wrapper of 'f'. When the wrapper is inlined, that kind of reboxing does not happen. But now we have functions with OPAQUE pragmas, which by definition (See Note [OPAQUE pragma]) do not get W/W-transformed. So in order to avoid reboxing workers of any W/W-transformed /callers of/ 'f' we need to strip all boxity information from 'f' in the demand analysis. This will inform the W/W-transformation code that boxed arguments of 'f' must definitely be passed along in boxed form and as such dissuade the creation of reboxing workers. -} -- | How many registers does this type take after unarisation? unariseArity :: Type -> Arity unariseArity :: Type -> Arity unariseArity Type ty = [PrimRep] -> Arity forall a. [a] -> Arity forall (t :: * -> *) a. Foldable t => t a -> Arity length ((() :: Constraint) => Type -> [PrimRep] Type -> [PrimRep] typePrimRep Type ty) data Budgets = MkB !Arity Budgets -- An infinite list of arity budgets earnTopBudget :: Budgets -> Budgets earnTopBudget :: Budgets -> Budgets earnTopBudget (MkB Arity n Budgets bg) = Arity -> Budgets -> Budgets MkB (Arity nArity -> Arity -> Arity forall a. Num a => a -> a -> a +Arity 1) Budgets bg spendTopBudget :: Arity -> Budgets -> Budgets spendTopBudget :: Arity -> Budgets -> Budgets spendTopBudget Arity m (MkB Arity n Budgets bg) = Arity -> Budgets -> Budgets MkB (Arity nArity -> Arity -> Arity forall a. Num a => a -> a -> a -Arity m) Budgets bg positiveTopBudget :: Budgets -> Bool positiveTopBudget :: Budgets -> Bool positiveTopBudget (MkB Arity n Budgets _) = Arity n Arity -> Arity -> Bool forall a. Ord a => a -> a -> Bool >= Arity 0 finaliseArgBoxities :: AnalEnv -> Id -> Arity -> CoreExpr -> Divergence -> Maybe ([Demand], CoreExpr) finaliseArgBoxities :: AnalEnv -> Id -> Arity -> CoreExpr -> Divergence -> Maybe ([Demand], CoreExpr) finaliseArgBoxities AnalEnv env Id fn Arity arity CoreExpr rhs Divergence div | Arity arity Arity -> Arity -> Bool forall a. Ord a => a -> a -> Bool > (Id -> Bool) -> [Id] -> Arity forall a. (a -> Bool) -> [a] -> Arity count Id -> Bool isId [Id] bndrs -- Can't find enough binders = Maybe ([Demand], CoreExpr) forall a. Maybe a Nothing -- This happens if we have f = g -- Then there are no binders; we don't worker/wrapper; and we -- simply want to give f the same demand signature as g | Bool otherwise -- NB: arity is the threshold_arity, which might be less than -- manifest arity for join points = -- pprTrace "finaliseArgBoxities" ( -- vcat [text "function:" <+> ppr fn -- , text "dmds before:" <+> ppr (map idDemandInfo (filter isId bndrs)) -- , text "dmds after: " <+> ppr arg_dmds' ]) $ ([Demand], CoreExpr) -> Maybe ([Demand], CoreExpr) forall a. a -> Maybe a Just ([Demand] arg_dmds', [Demand] -> CoreExpr -> CoreExpr add_demands [Demand] arg_dmds' CoreExpr rhs) -- add_demands: we must attach the final boxities to the lambda-binders -- of the function, both because that's kosher, and because CPR analysis -- uses the info on the binders directly. where opts :: DmdAnalOpts opts = AnalEnv -> DmdAnalOpts ae_opts AnalEnv env ([Id] bndrs, CoreExpr _body) = CoreExpr -> ([Id], CoreExpr) forall b. Expr b -> ([b], Expr b) collectBinders CoreExpr rhs unarise_arity :: Arity unarise_arity = [Arity] -> Arity forall a. Num a => [a] -> a forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a sum [ Type -> Arity unariseArity (Id -> Type idType Id b) | Id b <- [Id] bndrs, Id -> Bool isId Id b ] max_wkr_args :: Arity max_wkr_args = DmdAnalOpts -> Arity dmd_max_worker_args DmdAnalOpts opts Arity -> Arity -> Arity forall a. Ord a => a -> a -> a `max` Arity unarise_arity -- This is the budget initialisation step of -- Note [Worker argument budget] -- This is the key line, which uses almost-circular programming -- The remaining budget from one layer becomes the initial -- budget for the next layer down. See Note [Worker argument budget] (Budgets remaining_budget, [Demand] arg_dmds') = Budgets -> [(Type, StrictnessMark, Demand)] -> (Budgets, [Demand]) go_args (Arity -> Budgets -> Budgets MkB Arity max_wkr_args Budgets remaining_budget) [(Type, StrictnessMark, Demand)] arg_triples arg_triples :: [(Type, StrictnessMark, Demand)] arg_triples :: [(Type, StrictnessMark, Demand)] arg_triples = Arity -> [(Type, StrictnessMark, Demand)] -> [(Type, StrictnessMark, Demand)] forall a. Arity -> [a] -> [a] take Arity arity ([(Type, StrictnessMark, Demand)] -> [(Type, StrictnessMark, Demand)]) -> [(Type, StrictnessMark, Demand)] -> [(Type, StrictnessMark, Demand)] forall a b. (a -> b) -> a -> b $ [ (Type bndr_ty, StrictnessMark NotMarkedStrict, Id -> Type -> Demand get_dmd Id bndr Type bndr_ty) | Id bndr <- [Id] bndrs , Id -> Bool isRuntimeVar Id bndr, let bndr_ty :: Type bndr_ty = Id -> Type idType Id bndr ] get_dmd :: Id -> Type -> Demand get_dmd :: Id -> Type -> Demand get_dmd Id bndr Type bndr_ty | Type -> Bool isClassPred Type bndr_ty = Demand -> Demand trimBoxity Demand dmd -- See Note [Do not unbox class dictionaries] -- NB: 'ty' has not been normalised, so this will (rightly) -- catch newtype dictionaries too. -- NB: even for bottoming functions, don't unbox dictionaries | Bool is_bot_fn = Demand -> Demand unboxDeeplyDmd Demand dmd -- See Note [Boxity for bottoming functions], case (B) | Bool is_opaque = Demand -> Demand trimBoxity Demand dmd -- See Note [OPAQUE pragma] -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments] | Bool otherwise = Demand dmd where dmd :: Demand dmd = Id -> Demand idDemandInfo Id bndr is_opaque :: Bool is_opaque = InlinePragma -> Bool isOpaquePragma (Id -> InlinePragma idInlinePragma Id fn) -- is_bot_fn: see Note [Boxity for bottoming functions] is_bot_fn :: Bool is_bot_fn = Divergence div Divergence -> Divergence -> Bool forall a. Eq a => a -> a -> Bool == Divergence botDiv go_args :: Budgets -> [(Type,StrictnessMark,Demand)] -> (Budgets, [Demand]) go_args :: Budgets -> [(Type, StrictnessMark, Demand)] -> (Budgets, [Demand]) go_args Budgets bg [(Type, StrictnessMark, Demand)] triples = (Budgets -> (Type, StrictnessMark, Demand) -> (Budgets, Demand)) -> Budgets -> [(Type, StrictnessMark, Demand)] -> (Budgets, [Demand]) forall (t :: * -> *) s a b. Traversable t => (s -> a -> (s, b)) -> s -> t a -> (s, t b) mapAccumL Budgets -> (Type, StrictnessMark, Demand) -> (Budgets, Demand) go_arg Budgets bg [(Type, StrictnessMark, Demand)] triples go_arg :: Budgets -> (Type,StrictnessMark,Demand) -> (Budgets, Demand) go_arg :: Budgets -> (Type, StrictnessMark, Demand) -> (Budgets, Demand) go_arg bg :: Budgets bg@(MkB Arity bg_top Budgets bg_inner) (Type ty, StrictnessMark str_mark, dmd :: Demand dmd@(Card n :* SubDemand _)) = case AnalEnv -> Type -> StrictnessMark -> Demand -> UnboxingDecision [(Type, StrictnessMark, Demand)] wantToUnboxArg AnalEnv env Type ty StrictnessMark str_mark Demand dmd of UnboxingDecision [(Type, StrictnessMark, Demand)] DropAbsent -> (Budgets bg, Demand dmd) UnboxingDecision [(Type, StrictnessMark, Demand)] DontUnbox | Bool is_bot_fn, Type -> Bool isTyVarTy Type ty -> (Budgets retain_budget, Demand dmd) | Bool otherwise -> (Budgets retain_budget, Demand -> Demand trimBoxity Demand dmd) -- If bot: Keep deep boxity even though WW won't unbox -- See Note [Boxity for bottoming functions] case (A) -- trimBoxity: see Note [No lazy, Unboxed demands in demand signature] where retain_budget :: Budgets retain_budget = Arity -> Budgets -> Budgets spendTopBudget (Type -> Arity unariseArity Type ty) Budgets bg -- spendTopBudget: spend from our budget the cost of the -- retaining the arg -- The unboxed case does happen here, for example -- app g x = g x :: (# Int, Int #) -- here, `x` is used `L`azy and thus Boxed DoUnbox [(Type, StrictnessMark, Demand)] triples | Type -> Bool isUnboxedTupleType Type ty , (Budgets bg', [Demand] dmds') <- Budgets -> [(Type, StrictnessMark, Demand)] -> (Budgets, [Demand]) go_args Budgets bg [(Type, StrictnessMark, Demand)] triples -> (Budgets bg', Card n (() :: Constraint) => Card -> SubDemand -> Demand Card -> SubDemand -> Demand :* (Boxity -> [Demand] -> SubDemand mkProd Boxity Unboxed ([Demand] -> SubDemand) -> [Demand] -> SubDemand forall a b. (a -> b) -> a -> b $! [Demand] dmds')) -- See Note [Worker argument budget] -- unboxed tuples are always unboxed, deeply -- NB: Recurse with bg, *not* bg_inner! The unboxed fields -- are at the same budget layer. | Type -> Bool isUnboxedSumType Type ty -> String -> SDoc -> (Budgets, Demand) forall a. HasCallStack => String -> SDoc -> a pprPanic String "Unboxing through unboxed sum" (Id -> SDoc forall a. Outputable a => a -> SDoc ppr Id fn SDoc -> SDoc -> SDoc forall doc. IsLine doc => doc -> doc -> doc <+> Type -> SDoc forall a. Outputable a => a -> SDoc ppr Type ty) -- We currently don't return DoUnbox for unboxed sums. -- But hopefully we will at some point. When that happens, -- it would still be impossible to predict the effect -- of dropping absent fields and unboxing others on the -- unariseArity of the sum without losing sanity. -- We could overwrite bg_top with the one from -- retain_budget while still unboxing inside the alts as in -- the tuple case for a conservative solution, though. | Bool otherwise -> (Arity -> Budgets -> Budgets spendTopBudget Arity 1 (Arity -> Budgets -> Budgets MkB Arity bg_top Budgets final_bg_inner), Demand final_dmd) where (Budgets bg_inner', [Demand] dmds') = Budgets -> [(Type, StrictnessMark, Demand)] -> (Budgets, [Demand]) go_args (Budgets -> Budgets earnTopBudget Budgets bg_inner) [(Type, StrictnessMark, Demand)] triples -- earnTopBudget: give back the cost of retaining the -- arg we are insted unboxing. dmd' :: Demand dmd' = Card n (() :: Constraint) => Card -> SubDemand -> Demand Card -> SubDemand -> Demand :* (Boxity -> [Demand] -> SubDemand mkProd Boxity Unboxed ([Demand] -> SubDemand) -> [Demand] -> SubDemand forall a b. (a -> b) -> a -> b $! [Demand] dmds') ~(Budgets final_bg_inner, Demand final_dmd) -- "~": This match *must* be lazy! | Budgets -> Bool positiveTopBudget Budgets bg_inner' = (Budgets bg_inner', Demand dmd') | Bool otherwise = (Budgets bg_inner, Demand -> Demand trimBoxity Demand dmd) add_demands :: [Demand] -> CoreExpr -> CoreExpr -- Attach the demands to the outer lambdas of this expression add_demands :: [Demand] -> CoreExpr -> CoreExpr add_demands [] CoreExpr e = CoreExpr e add_demands (Demand dmd:[Demand] dmds) (Lam Id v CoreExpr e) | Id -> Bool isTyVar Id v = Id -> CoreExpr -> CoreExpr forall b. b -> Expr b -> Expr b Lam Id v ([Demand] -> CoreExpr -> CoreExpr add_demands (Demand dmdDemand -> [Demand] -> [Demand] forall a. a -> [a] -> [a] :[Demand] dmds) CoreExpr e) | Bool otherwise = Id -> CoreExpr -> CoreExpr forall b. b -> Expr b -> Expr b Lam (Id v Id -> Demand -> Id `setIdDemandInfo` Demand dmd) ([Demand] -> CoreExpr -> CoreExpr add_demands [Demand] dmds CoreExpr e) add_demands [Demand] dmds CoreExpr e = String -> SDoc -> CoreExpr forall a. HasCallStack => String -> SDoc -> a pprPanic String "add_demands" ([Demand] -> SDoc forall a. Outputable a => a -> SDoc ppr [Demand] dmds SDoc -> SDoc -> SDoc forall doc. IsDoc doc => doc -> doc -> doc $$ CoreExpr -> SDoc forall a. Outputable a => a -> SDoc ppr CoreExpr e) finaliseLetBoxity :: AnalEnv -> Type -- ^ Type of the let-bound Id -> Demand -- ^ How the Id is used -> Demand -- See Note [Finalising boxity for let-bound Ids] -- This function is like finaliseArgBoxities, but much simpler because -- it has no "budget". It simply unboxes strict demands, and stops -- when it reaches a lazy one. finaliseLetBoxity :: AnalEnv -> Type -> Demand -> Demand finaliseLetBoxity AnalEnv env Type ty Demand dmd = (Type, StrictnessMark, Demand) -> Demand go (Type ty, StrictnessMark NotMarkedStrict, Demand dmd) where go :: (Type,StrictnessMark,Demand) -> Demand go :: (Type, StrictnessMark, Demand) -> Demand go (Type ty, StrictnessMark str, dmd :: Demand dmd@(Card n :* SubDemand _)) = case AnalEnv -> Type -> StrictnessMark -> Demand -> UnboxingDecision [(Type, StrictnessMark, Demand)] wantToUnboxArg AnalEnv env Type ty StrictnessMark str Demand dmd of UnboxingDecision [(Type, StrictnessMark, Demand)] DropAbsent -> Demand dmd UnboxingDecision [(Type, StrictnessMark, Demand)] DontUnbox -> Demand -> Demand trimBoxity Demand dmd DoUnbox [(Type, StrictnessMark, Demand)] triples -> Card n (() :: Constraint) => Card -> SubDemand -> Demand Card -> SubDemand -> Demand :* (Boxity -> [Demand] -> SubDemand mkProd Boxity Unboxed ([Demand] -> SubDemand) -> [Demand] -> SubDemand forall a b. (a -> b) -> a -> b $! ((Type, StrictnessMark, Demand) -> Demand) -> [(Type, StrictnessMark, Demand)] -> [Demand] forall a b. (a -> b) -> [a] -> [b] map (Type, StrictnessMark, Demand) -> Demand go [(Type, StrictnessMark, Demand)] triples) wantToUnboxArg :: AnalEnv -> Type -> StrictnessMark -> Demand -> UnboxingDecision [(Type, StrictnessMark, Demand)] wantToUnboxArg :: AnalEnv -> Type -> StrictnessMark -> Demand -> UnboxingDecision [(Type, StrictnessMark, Demand)] wantToUnboxArg AnalEnv env Type ty StrictnessMark str_mark dmd :: Demand dmd@(Card n :* SubDemand _) = case FamInstEnvs -> Type -> Demand -> UnboxingDecision (DataConPatContext Demand) canUnboxArg (AnalEnv -> FamInstEnvs ae_fam_envs AnalEnv env) Type ty Demand dmd of UnboxingDecision (DataConPatContext Demand) DropAbsent -> UnboxingDecision [(Type, StrictnessMark, Demand)] forall unboxing_info. UnboxingDecision unboxing_info DropAbsent UnboxingDecision (DataConPatContext Demand) DontUnbox -> UnboxingDecision [(Type, StrictnessMark, Demand)] forall unboxing_info. UnboxingDecision unboxing_info DontUnbox DoUnbox (DataConPatContext{ dcpc_dc :: forall s. DataConPatContext s -> DataCon dcpc_dc = DataCon dc , dcpc_tc_args :: forall s. DataConPatContext s -> [Type] dcpc_tc_args = [Type] tc_args , dcpc_args :: forall s. DataConPatContext s -> [s] dcpc_args = [Demand] dmds }) -- OK, so we /can/ unbox it; but do we /want/ to? | Bool -> Bool not (Card -> Bool isStrict Card n Bool -> Bool -> Bool || StrictnessMark -> Bool isMarkedStrict StrictnessMark str_mark) -- Don't unbox a lazy field -- isMarkedStrict: see Note [Unboxing evaluated arguments] in DmdAnal -> UnboxingDecision [(Type, StrictnessMark, Demand)] forall unboxing_info. UnboxingDecision unboxing_info DontUnbox | IsRecDataConResult DefinitelyRecursive <- AnalEnv -> DataCon -> IsRecDataConResult ae_rec_dc AnalEnv env DataCon dc -- See Note [Which types are unboxed?] -- and Note [Demand analysis for recursive data constructors] -> UnboxingDecision [(Type, StrictnessMark, Demand)] forall unboxing_info. UnboxingDecision unboxing_info DontUnbox | Bool otherwise -- Bad cases dealt with: we want to unbox! -> [(Type, StrictnessMark, Demand)] -> UnboxingDecision [(Type, StrictnessMark, Demand)] forall unboxing_info. unboxing_info -> UnboxingDecision unboxing_info DoUnbox ([Type] -> [StrictnessMark] -> [Demand] -> [(Type, StrictnessMark, Demand)] forall a b c. [a] -> [b] -> [c] -> [(a, b, c)] zip3 (DataCon -> [Type] -> [Type] dubiousDataConInstArgTys DataCon dc [Type] tc_args) (DataCon -> [StrictnessMark] dataConRepStrictness DataCon dc) [Demand] dmds) {- ********************************************************************* * * Fixpoints * * ********************************************************************* -} -- Recursive bindings dmdFix :: TopLevelFlag -> AnalEnv -- Does not include bindings for this binding -> SubDemand -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with strictness info dmdFix :: TopLevelFlag -> AnalEnv -> SubDemand -> [(Id, CoreExpr)] -> (AnalEnv, DmdEnv, [(Id, CoreExpr)]) dmdFix TopLevelFlag top_lvl AnalEnv env SubDemand let_dmd [(Id, CoreExpr)] orig_pairs = Arity -> [(Id, CoreExpr)] -> (AnalEnv, DmdEnv, [(Id, CoreExpr)]) loop Arity 1 [(Id, CoreExpr)] initial_pairs where opts :: DmdAnalOpts opts = AnalEnv -> DmdAnalOpts ae_opts AnalEnv env -- See Note [Initialising strictness] initial_pairs :: [(Id, CoreExpr)] initial_pairs | AnalEnv -> Bool ae_virgin AnalEnv env = [(DmdAnalOpts -> Id -> DmdSig -> Id setIdDmdAndBoxSig DmdAnalOpts opts Id id DmdSig botSig, CoreExpr rhs) | (Id id, CoreExpr rhs) <- [(Id, CoreExpr)] orig_pairs ] | Bool otherwise = [(Id, CoreExpr)] orig_pairs -- If fixed-point iteration does not yield a result we use this instead -- See Note [Safe abortion in the fixed-point iteration] abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)]) abort :: (AnalEnv, DmdEnv, [(Id, CoreExpr)]) abort = (AnalEnv env, DmdEnv lazy_fv', [(Id, CoreExpr)] zapped_pairs) where (DmdEnv lazy_fv, [(Id, CoreExpr)] pairs') = Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)]) step Bool True ([(Id, CoreExpr)] -> [(Id, CoreExpr)] zapIdDmdSig [(Id, CoreExpr)] orig_pairs) -- Note [Lazy and unleashable free variables] non_lazy_fvs :: DmdEnv non_lazy_fvs = [DmdEnv] -> DmdEnv forall a. [VarEnv a] -> VarEnv a plusVarEnvList ([DmdEnv] -> DmdEnv) -> [DmdEnv] -> DmdEnv forall a b. (a -> b) -> a -> b $ ((Id, CoreExpr) -> DmdEnv) -> [(Id, CoreExpr)] -> [DmdEnv] forall a b. (a -> b) -> [a] -> [b] map (DmdSig -> DmdEnv dmdSigDmdEnv (DmdSig -> DmdEnv) -> ((Id, CoreExpr) -> DmdSig) -> (Id, CoreExpr) -> DmdEnv forall b c a. (b -> c) -> (a -> b) -> a -> c . Id -> DmdSig idDmdSig (Id -> DmdSig) -> ((Id, CoreExpr) -> Id) -> (Id, CoreExpr) -> DmdSig forall b c a. (b -> c) -> (a -> b) -> a -> c . (Id, CoreExpr) -> Id forall a b. (a, b) -> a fst) [(Id, CoreExpr)] pairs' lazy_fv' :: DmdEnv lazy_fv' = DmdEnv lazy_fv DmdEnv -> DmdEnv -> DmdEnv forall a. VarEnv a -> VarEnv a -> VarEnv a `plusVarEnv` (Demand -> Demand) -> DmdEnv -> DmdEnv forall a b. (a -> b) -> VarEnv a -> VarEnv b mapVarEnv (Demand -> Demand -> Demand forall a b. a -> b -> a const Demand topDmd) DmdEnv non_lazy_fvs zapped_pairs :: [(Id, CoreExpr)] zapped_pairs = [(Id, CoreExpr)] -> [(Id, CoreExpr)] zapIdDmdSig [(Id, CoreExpr)] pairs' -- The fixed-point varies the idDmdSig field of the binders, and terminates if that -- annotation does not change any more. loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) loop :: Arity -> [(Id, CoreExpr)] -> (AnalEnv, DmdEnv, [(Id, CoreExpr)]) loop Arity n [(Id, CoreExpr)] pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id) -- | (id,_) <- pairs]) $ Arity -> [(Id, CoreExpr)] -> (AnalEnv, DmdEnv, [(Id, CoreExpr)]) loop' Arity n [(Id, CoreExpr)] pairs loop' :: Arity -> [(Id, CoreExpr)] -> (AnalEnv, DmdEnv, [(Id, CoreExpr)]) loop' Arity n [(Id, CoreExpr)] pairs | Bool found_fixpoint = (AnalEnv final_anal_env, DmdEnv lazy_fv, [(Id, CoreExpr)] pairs') | Arity n Arity -> Arity -> Bool forall a. Eq a => a -> a -> Bool == Arity 10 = (AnalEnv, DmdEnv, [(Id, CoreExpr)]) abort | Bool otherwise = Arity -> [(Id, CoreExpr)] -> (AnalEnv, DmdEnv, [(Id, CoreExpr)]) loop (Arity nArity -> Arity -> Arity forall a. Num a => a -> a -> a +Arity 1) [(Id, CoreExpr)] pairs' where found_fixpoint :: Bool found_fixpoint = ((Id, CoreExpr) -> DmdSig) -> [(Id, CoreExpr)] -> [DmdSig] forall a b. (a -> b) -> [a] -> [b] map (Id -> DmdSig idDmdSig (Id -> DmdSig) -> ((Id, CoreExpr) -> Id) -> (Id, CoreExpr) -> DmdSig forall b c a. (b -> c) -> (a -> b) -> a -> c . (Id, CoreExpr) -> Id forall a b. (a, b) -> a fst) [(Id, CoreExpr)] pairs' [DmdSig] -> [DmdSig] -> Bool forall a. Eq a => a -> a -> Bool == ((Id, CoreExpr) -> DmdSig) -> [(Id, CoreExpr)] -> [DmdSig] forall a b. (a -> b) -> [a] -> [b] map (Id -> DmdSig idDmdSig (Id -> DmdSig) -> ((Id, CoreExpr) -> Id) -> (Id, CoreExpr) -> DmdSig forall b c a. (b -> c) -> (a -> b) -> a -> c . (Id, CoreExpr) -> Id forall a b. (a, b) -> a fst) [(Id, CoreExpr)] pairs first_round :: Bool first_round = Arity n Arity -> Arity -> Bool forall a. Eq a => a -> a -> Bool == Arity 1 (DmdEnv lazy_fv, [(Id, CoreExpr)] pairs') = Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)]) step Bool first_round [(Id, CoreExpr)] pairs final_anal_env :: AnalEnv final_anal_env = TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv extendAnalEnvs TopLevelFlag top_lvl AnalEnv env (((Id, CoreExpr) -> Id) -> [(Id, CoreExpr)] -> [Id] forall a b. (a -> b) -> [a] -> [b] map (Id, CoreExpr) -> Id forall a b. (a, b) -> a fst [(Id, CoreExpr)] pairs') step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)]) step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)]) step Bool first_round [(Id, CoreExpr)] pairs = (DmdEnv lazy_fv, [(Id, CoreExpr)] pairs') where -- In all but the first iteration, delete the virgin flag start_env :: AnalEnv start_env | Bool first_round = AnalEnv env | Bool otherwise = AnalEnv -> AnalEnv nonVirgin AnalEnv env start :: (AnalEnv, DmdEnv) start = (TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv extendAnalEnvs TopLevelFlag top_lvl AnalEnv start_env (((Id, CoreExpr) -> Id) -> [(Id, CoreExpr)] -> [Id] forall a b. (a -> b) -> [a] -> [b] map (Id, CoreExpr) -> Id forall a b. (a, b) -> a fst [(Id, CoreExpr)] pairs), DmdEnv forall a. VarEnv a emptyVarEnv) !((AnalEnv _,!DmdEnv lazy_fv), ![(Id, CoreExpr)] pairs') = ((AnalEnv, DmdEnv) -> (Id, CoreExpr) -> ((AnalEnv, DmdEnv), (Id, CoreExpr))) -> (AnalEnv, DmdEnv) -> [(Id, CoreExpr)] -> ((AnalEnv, DmdEnv), [(Id, CoreExpr)]) forall (t :: * -> *) s a b. Traversable t => (s -> a -> (s, b)) -> s -> t a -> (s, t b) mapAccumL (AnalEnv, DmdEnv) -> (Id, CoreExpr) -> ((AnalEnv, DmdEnv), (Id, CoreExpr)) my_downRhs (AnalEnv, DmdEnv) start [(Id, CoreExpr)] pairs -- mapAccumL: Use the new signature to do the next pair -- The occurrence analyser has arranged them in a good order -- so this can significantly reduce the number of iterations needed my_downRhs :: (AnalEnv, DmdEnv) -> (Id, CoreExpr) -> ((AnalEnv, DmdEnv), (Id, CoreExpr)) my_downRhs (AnalEnv env, DmdEnv lazy_fv) (Id id,CoreExpr rhs) = -- pprTrace "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) $ ((AnalEnv env', DmdEnv lazy_fv'), (Id id', CoreExpr rhs')) where !(!AnalEnv env', !DmdEnv lazy_fv1, !Id id', !CoreExpr rhs') = TopLevelFlag -> RecFlag -> AnalEnv -> SubDemand -> Id -> CoreExpr -> (AnalEnv, DmdEnv, Id, CoreExpr) dmdAnalRhsSig TopLevelFlag top_lvl RecFlag Recursive AnalEnv env SubDemand let_dmd Id id CoreExpr rhs !lazy_fv' :: DmdEnv lazy_fv' = (Demand -> Demand -> Demand) -> DmdEnv -> DmdEnv -> DmdEnv forall a. (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a plusVarEnv_C Demand -> Demand -> Demand plusDmd DmdEnv lazy_fv DmdEnv lazy_fv1 zapIdDmdSig :: [(Id, CoreExpr)] -> [(Id, CoreExpr)] zapIdDmdSig :: [(Id, CoreExpr)] -> [(Id, CoreExpr)] zapIdDmdSig [(Id, CoreExpr)] pairs = [(Id -> DmdSig -> Id setIdDmdSig Id id DmdSig nopSig, CoreExpr rhs) | (Id id, CoreExpr rhs) <- [(Id, CoreExpr)] pairs ] {- Note [Safe abortion in the fixed-point iteration] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Fixed-point iteration may fail to terminate. But we cannot simply give up and return the environment and code unchanged! We still need to do one additional round, for two reasons: * To get information on used free variables (both lazy and strict!) (see Note [Lazy and unleashable free variables]) * To ensure that all expressions have been traversed at least once, and any left-over strictness annotations have been updated. This final iteration does not add the variables to the strictness signature environment, which effectively assigns them 'nopSig' (see "getStrictness") Note [Trimming a demand to a type] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There are two reasons we sometimes trim a demand to match a type. 1. GADTs 2. Recursive products and widening More on both below. But the bottom line is: we really don't want to have a binder whose demand is more deeply-nested than its type "allows". So in findBndrDmd we call trimToType and findTypeShape to trim the demand on the binder to a form that matches the type Now to the reasons. For (1) consider f :: a -> Bool f x = case ... of A g1 -> case (x |> g1) of (p,q) -> ... B -> error "urk" where A,B are the constructors of a GADT. We'll get a 1P(L,L) demand on x from the A branch, but that's a stupid demand for x itself, which has type 'a'. Indeed we get ASSERTs going off (notably in splitUseProdDmd, #8569). For (2) consider data T = MkT Int T -- A recursive product f :: Int -> T -> Int f 0 _ = 0 f _ (MkT n t) = f n t Here f is lazy in T, but its *usage* is infinite: P(L,P(L,P(L, ...))). Notice that this happens because T is a product type, and is recursive. If we are not careful, we'll fail to iterate to a fixpoint in dmdFix, and bale out entirely, which is inefficient and over-conservative. Worse, as we discovered in #18304, the size of the usages we compute can grow /exponentially/, so even 10 iterations costs far too much. Especially since we then discard the result. To avoid this we use the same findTypeShape function as for (1), but arrange that it trims the demand if it encounters the same type constructor twice (or three times, etc). We use our standard RecTcChecker mechanism for this -- see GHC.Core.Opt.WorkWrap.Utils.findTypeShape. This is usually call "widening". We could do it just in dmdFix, but since are doing this findTypeShape business /anyway/ because of (1), and it has all the right information to hand, it's extremely convenient to do it there. -} {- ********************************************************************* * * Strictness signatures and types * * ********************************************************************* -} unitDmdType :: DmdEnv -> DmdType unitDmdType :: DmdEnv -> DmdType unitDmdType DmdEnv dmd_env = DmdEnv -> [Demand] -> Divergence -> DmdType DmdType DmdEnv dmd_env [] Divergence topDiv coercionDmdEnv :: Coercion -> DmdEnv coercionDmdEnv :: Coercion -> DmdEnv coercionDmdEnv Coercion co = [Coercion] -> DmdEnv coercionsDmdEnv [Coercion co] coercionsDmdEnv :: [Coercion] -> DmdEnv coercionsDmdEnv :: [Coercion] -> DmdEnv coercionsDmdEnv [Coercion] cos = (Id -> Demand) -> VarEnv Id -> DmdEnv forall a b. (a -> b) -> VarEnv a -> VarEnv b mapVarEnv (Demand -> Id -> Demand forall a b. a -> b -> a const Demand topDmd) (VarSet -> VarEnv Id forall a. UniqSet a -> UniqFM a a getUniqSet (VarSet -> VarEnv Id) -> VarSet -> VarEnv Id forall a b. (a -> b) -> a -> b $ [Coercion] -> VarSet coVarsOfCos [Coercion] cos) -- The VarSet from coVarsOfCos is really a VarEnv Var addVarDmd :: DmdType -> Var -> Demand -> DmdType addVarDmd :: DmdType -> Id -> Demand -> DmdType addVarDmd (DmdType DmdEnv fv [Demand] ds Divergence res) Id var Demand dmd = DmdEnv -> [Demand] -> Divergence -> DmdType DmdType ((Demand -> Demand -> Demand) -> DmdEnv -> Id -> Demand -> DmdEnv forall a. (a -> a -> a) -> VarEnv a -> Id -> a -> VarEnv a extendVarEnv_C Demand -> Demand -> Demand plusDmd DmdEnv fv Id var Demand dmd) [Demand] ds Divergence res addLazyFVs :: DmdType -> DmdEnv -> DmdType addLazyFVs :: DmdType -> DmdEnv -> DmdType addLazyFVs DmdType dmd_ty DmdEnv lazy_fvs = DmdType dmd_ty DmdType -> PlusDmdArg -> DmdType `plusDmdType` DmdEnv -> PlusDmdArg mkPlusDmdArg DmdEnv lazy_fvs -- Using plusDmdType (rather than just plus'ing the envs) -- is vital. Consider -- let f = \x -> (x,y) -- in error (f 3) -- Here, y is treated as a lazy-fv of f, but we must `plusDmd` that L -- demand with the bottom coming up from 'error' -- -- I got a loop in the fixpointer without this, due to an interaction -- with the lazy_fv filtering in dmdAnalRhsSig. Roughly, it was -- letrec f n x -- = letrec g y = x `fatbar` -- letrec h z = z + ...g... -- in h (f (n-1) x) -- in ... -- In the initial iteration for f, f=Bot -- Suppose h is found to be strict in z, but the occurrence of g in its RHS -- is lazy. Now consider the fixpoint iteration for g, esp the demands it -- places on its free variables. Suppose it places none. Then the -- x `fatbar` ...call to h... -- will give a x->V demand for x. That turns into a L demand for x, -- which floats out of the defn for h. Without the modifyEnv, that -- L demand doesn't get both'd with the Bot coming up from the inner -- call to f. So we just get an L demand for x for g. setBndrsDemandInfo :: HasCallStack => [Var] -> [Demand] -> [Var] setBndrsDemandInfo :: HasCallStack => [Id] -> [Demand] -> [Id] setBndrsDemandInfo (Id b:[Id] bs) [Demand] ds | Id -> Bool isTyVar Id b = Id b Id -> [Id] -> [Id] forall a. a -> [a] -> [a] : HasCallStack => [Id] -> [Demand] -> [Id] [Id] -> [Demand] -> [Id] setBndrsDemandInfo [Id] bs [Demand] ds setBndrsDemandInfo (Id b:[Id] bs) (Demand d:[Demand] ds) = let !new_info :: Id new_info = Id -> Demand -> Id setIdDemandInfo Id b Demand d !vars :: [Id] vars = HasCallStack => [Id] -> [Demand] -> [Id] [Id] -> [Demand] -> [Id] setBndrsDemandInfo [Id] bs [Demand] ds in Id new_info Id -> [Id] -> [Id] forall a. a -> [a] -> [a] : [Id] vars setBndrsDemandInfo [] [Demand] ds = Bool -> [Id] -> [Id] forall a. HasCallStack => Bool -> a -> a assert ([Demand] -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [Demand] ds) [] setBndrsDemandInfo [Id] bs [Demand] _ = String -> SDoc -> [Id] forall a. HasCallStack => String -> SDoc -> a pprPanic String "setBndrsDemandInfo" ([Id] -> SDoc forall a. Outputable a => a -> SDoc ppr [Id] bs) annotateLamIdBndr :: AnalEnv -> DmdType -- Demand type of body -> Id -- Lambda binder -> WithDmdType Id -- Demand type of lambda -- and binder annotated with demand annotateLamIdBndr :: AnalEnv -> DmdType -> Id -> WithDmdType Id annotateLamIdBndr AnalEnv env DmdType dmd_ty Id id -- For lambdas we add the demand to the argument demands -- Only called for Ids = Bool -> WithDmdType Id -> WithDmdType Id forall a. HasCallStack => Bool -> a -> a assert (Id -> Bool isId Id id) (WithDmdType Id -> WithDmdType Id) -> WithDmdType Id -> WithDmdType Id forall a b. (a -> b) -> a -> b $ -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $ DmdType -> Id -> WithDmdType Id forall a. DmdType -> a -> WithDmdType a WithDmdType DmdType main_ty Id new_id where new_id :: Id new_id = Id -> Demand -> Id setIdDemandInfo Id id Demand dmd main_ty :: DmdType main_ty = Demand -> DmdType -> DmdType addDemand Demand dmd DmdType dmd_ty' WithDmdType DmdType dmd_ty' Demand dmd = AnalEnv -> DmdType -> Id -> WithDmdType Demand findBndrDmd AnalEnv env DmdType dmd_ty Id id {- Note [NOINLINE and strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ At one point we disabled strictness for NOINLINE functions, on the grounds that they should be entirely opaque. But that lost lots of useful semantic strictness information, so now we analyse them like any other function, and pin strictness information on them. That in turn forces us to worker/wrapper them; see Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. Note [Lazy and unleashable free variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We put the strict and once-used FVs in the DmdType of the Id, so that at its call sites we unleash demands on its strict fvs. An example is 'roll' in imaginary/wheel-sieve2 Something like this: roll x = letrec go y = if ... then roll (x-1) else x+1 in go ms We want to see that roll is strict in x, which is because go is called. So we put the DmdEnv for x in go's DmdType. Another example: f :: Int -> Int -> Int f x y = let t = x+1 h z = if z==0 then t else if z==1 then x+1 else x + h (z-1) in h y Calling h does indeed evaluate x, but we can only see that if we unleash a demand on x at the call site for t. Incidentally, here's a place where lambda-lifting h would lose the cigar --- we couldn't see the joint strictness in t/x ON THE OTHER HAND We don't want to put *all* the fv's from the RHS into the DmdType. Because * it makes the strictness signatures larger, and hence slows down fixpointing and * it is useless information at the call site anyways: For lazy, used-many times fv's we will never get any better result than that, no matter how good the actual demand on the function at the call site is (unless it is always absent, but then the whole binder is useless). Therefore we exclude lazy multiple-used fv's from the environment in the DmdType. But now the signature lies! (Missing variables are assumed to be absent.) To make up for this, the code that analyses the binding keeps the demand on those variable separate (usually called "lazy_fv") and adds it to the demand of the whole binding later. What if we decide _not_ to store a strictness signature for a binding at all, as we do when aborting a fixed-point iteration? The we risk losing the information that the strict variables are being used. In that case, we take all free variables mentioned in the (unsound) strictness signature, conservatively approximate the demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix". ************************************************************************ * * \subsection{Strictness signatures} * * ************************************************************************ -} data AnalEnv = AE { AnalEnv -> DmdAnalOpts ae_opts :: !DmdAnalOpts -- ^ Analysis options , AnalEnv -> SigEnv ae_sigs :: !SigEnv , AnalEnv -> Bool ae_virgin :: !Bool -- ^ True on first iteration only. See Note [Initialising strictness] , AnalEnv -> FamInstEnvs ae_fam_envs :: !FamInstEnvs , AnalEnv -> DataCon -> IsRecDataConResult 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 -- We do so if it's a LocalId, but not top-level -- -- The DmdEnv gives the demand on the free vars of the function -- when it is given enough args to satisfy the strictness signature type SigEnv = VarEnv (DmdSig, TopLevelFlag) instance Outputable AnalEnv where ppr :: AnalEnv -> SDoc ppr AnalEnv env = String -> SDoc forall doc. IsLine doc => String -> doc text String "AE" SDoc -> SDoc -> SDoc forall doc. IsLine doc => doc -> doc -> doc <+> SDoc -> SDoc forall doc. IsLine doc => doc -> doc braces ([SDoc] -> SDoc forall doc. IsDoc doc => [doc] -> doc vcat [ String -> SDoc forall doc. IsLine doc => String -> doc text String "ae_virgin =" SDoc -> SDoc -> SDoc forall doc. IsLine doc => doc -> doc -> doc <+> Bool -> SDoc forall a. Outputable a => a -> SDoc ppr (AnalEnv -> Bool ae_virgin AnalEnv env) , String -> SDoc forall doc. IsLine doc => String -> doc text String "ae_sigs =" SDoc -> SDoc -> SDoc forall doc. IsLine doc => doc -> doc -> doc <+> SigEnv -> SDoc forall a. Outputable a => a -> SDoc ppr (AnalEnv -> SigEnv ae_sigs AnalEnv env) ]) emptyAnalEnv :: DmdAnalOpts -> FamInstEnvs -> AnalEnv emptyAnalEnv :: DmdAnalOpts -> FamInstEnvs -> AnalEnv emptyAnalEnv DmdAnalOpts opts FamInstEnvs fam_envs = AE { ae_opts :: DmdAnalOpts ae_opts = DmdAnalOpts opts , ae_sigs :: SigEnv ae_sigs = SigEnv emptySigEnv , ae_virgin :: Bool ae_virgin = Bool True , ae_fam_envs :: FamInstEnvs ae_fam_envs = FamInstEnvs fam_envs , ae_rec_dc :: DataCon -> IsRecDataConResult ae_rec_dc = (DataCon -> IsRecDataConResult) -> DataCon -> IsRecDataConResult forall k a. Uniquable k => (k -> a) -> k -> a memoiseUniqueFun (FamInstEnvs -> IntWithInf -> DataCon -> IsRecDataConResult isRecDataCon FamInstEnvs fam_envs IntWithInf 3) } -- | Unset the 'dmd_strict_dicts' flag if any of the given bindings is a DFun -- binding. Part of the mechanism that detects -- Note [Do not strictify a DFun's parameter dictionaries]. enterDFun :: CoreBind -> AnalEnv -> AnalEnv enterDFun :: Bind Id -> AnalEnv -> AnalEnv enterDFun Bind Id bind AnalEnv env | (Id -> Bool) -> [Id] -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool any Id -> Bool isDFunId (Bind Id -> [Id] forall b. Bind b -> [b] bindersOf Bind Id bind) = AnalEnv env { ae_opts = (ae_opts env) { dmd_strict_dicts = False } } | Bool otherwise = AnalEnv env emptySigEnv :: SigEnv emptySigEnv :: SigEnv emptySigEnv = SigEnv forall a. VarEnv a emptyVarEnv -- | Extend an environment with the strictness sigs attached to the Ids extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv extendAnalEnvs TopLevelFlag top_lvl AnalEnv env [Id] vars = AnalEnv env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars } extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv extendSigEnvs TopLevelFlag top_lvl SigEnv sigs [Id] vars = SigEnv -> [(Id, (DmdSig, TopLevelFlag))] -> SigEnv forall a. VarEnv a -> [(Id, a)] -> VarEnv a extendVarEnvList SigEnv sigs [ (Id var, (Id -> DmdSig idDmdSig Id var, TopLevelFlag top_lvl)) | Id var <- [Id] vars] extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> DmdSig -> AnalEnv extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> DmdSig -> AnalEnv extendAnalEnv TopLevelFlag top_lvl AnalEnv env Id var DmdSig sig = AnalEnv env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig } extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> DmdSig -> SigEnv extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> DmdSig -> SigEnv extendSigEnv TopLevelFlag top_lvl SigEnv sigs Id var DmdSig sig = SigEnv -> Id -> (DmdSig, TopLevelFlag) -> SigEnv forall a. VarEnv a -> Id -> a -> VarEnv a extendVarEnv SigEnv sigs Id var (DmdSig sig, TopLevelFlag top_lvl) lookupSigEnv :: AnalEnv -> Id -> Maybe (DmdSig, TopLevelFlag) lookupSigEnv :: AnalEnv -> Id -> Maybe (DmdSig, TopLevelFlag) lookupSigEnv AnalEnv env Id id = SigEnv -> Id -> Maybe (DmdSig, TopLevelFlag) forall a. VarEnv a -> Id -> Maybe a lookupVarEnv (AnalEnv -> SigEnv ae_sigs AnalEnv env) Id id addInScopeAnalEnv :: AnalEnv -> Var -> AnalEnv addInScopeAnalEnv :: AnalEnv -> Id -> AnalEnv addInScopeAnalEnv AnalEnv env Id id = AnalEnv env { ae_sigs = delVarEnv (ae_sigs env) id } addInScopeAnalEnvs :: AnalEnv -> [Var] -> AnalEnv addInScopeAnalEnvs :: AnalEnv -> [Id] -> AnalEnv addInScopeAnalEnvs AnalEnv env [Id] ids = AnalEnv env { ae_sigs = delVarEnvList (ae_sigs env) ids } nonVirgin :: AnalEnv -> AnalEnv nonVirgin :: AnalEnv -> AnalEnv nonVirgin AnalEnv env = AnalEnv env { ae_virgin = False } findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> WithDmdType [Demand] -- Return the demands on the Ids in the [Var] findBndrsDmds :: AnalEnv -> DmdType -> [Id] -> WithDmdType [Demand] findBndrsDmds AnalEnv env DmdType dmd_ty [Id] bndrs = DmdType -> [Id] -> WithDmdType [Demand] go DmdType dmd_ty [Id] bndrs where go :: DmdType -> [Id] -> WithDmdType [Demand] go DmdType dmd_ty [] = DmdType -> [Demand] -> WithDmdType [Demand] forall a. DmdType -> a -> WithDmdType a WithDmdType DmdType dmd_ty [] go DmdType dmd_ty (Id b:[Id] bs) | Id -> Bool isId Id b = let WithDmdType DmdType dmd_ty1 [Demand] dmds = DmdType -> [Id] -> WithDmdType [Demand] go DmdType dmd_ty [Id] bs WithDmdType DmdType dmd_ty2 Demand dmd = AnalEnv -> DmdType -> Id -> WithDmdType Demand findBndrDmd AnalEnv env DmdType dmd_ty1 Id b in DmdType -> [Demand] -> WithDmdType [Demand] forall a. DmdType -> a -> WithDmdType a WithDmdType DmdType dmd_ty2 (Demand dmd Demand -> [Demand] -> [Demand] forall a. a -> [a] -> [a] : [Demand] dmds) | Bool otherwise = DmdType -> [Id] -> WithDmdType [Demand] go DmdType dmd_ty [Id] bs findBndrDmd :: AnalEnv -> DmdType -> Id -> WithDmdType Demand -- See Note [Trimming a demand to a type] findBndrDmd :: AnalEnv -> DmdType -> Id -> WithDmdType Demand findBndrDmd AnalEnv env DmdType dmd_ty Id id = -- pprTrace "findBndrDmd" (ppr id $$ ppr dmd_ty $$ ppr starting_dmd $$ ppr dmd') $ DmdType -> Demand -> WithDmdType Demand forall a. DmdType -> a -> WithDmdType a WithDmdType DmdType dmd_ty' Demand dmd' where dmd' :: Demand dmd' = Demand -> Demand strictify (Demand -> Demand) -> Demand -> Demand forall a b. (a -> b) -> a -> b $ Demand -> TypeShape -> Demand trimToType Demand starting_dmd (FamInstEnvs -> Type -> TypeShape findTypeShape FamInstEnvs fam_envs Type id_ty) (DmdType dmd_ty', Demand starting_dmd) = DmdType -> Id -> (DmdType, Demand) peelFV DmdType dmd_ty Id id id_ty :: Type id_ty = Id -> Type idType Id id strictify :: Demand -> Demand strictify Demand dmd -- See Note [Making dictionary parameters strict] -- and Note [Do not strictify a DFun's parameter dictionaries] | DmdAnalOpts -> Bool dmd_strict_dicts (AnalEnv -> DmdAnalOpts ae_opts AnalEnv env) = Type -> Demand -> Demand strictifyDictDmd Type id_ty Demand dmd | Bool otherwise = Demand dmd fam_envs :: FamInstEnvs fam_envs = AnalEnv -> FamInstEnvs ae_fam_envs AnalEnv env {- Note [Bringing a new variable into scope] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider f x = blah g = ...(\f. ...f...)... In the body of the '\f', any occurrence of `f` refers to the lambda-bound `f`, not the top-level `f` (which will be in `ae_sigs`). So it's very important to delete `f` from `ae_sigs` when we pass a lambda/case/let-up binding of `f`. Otherwise chaos results (#22718). Note [Making dictionary parameters strict] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Opt_DictsStrict flag makes GHC use call-by-value for dictionaries. Why? * Generally CBV is more efficient. * A datatype dictionary is always non-bottom and never takes much work to compute. E.g. a DFun from an instance decl always returns a dictionary record immediately. See DFunUnfolding in CoreSyn. See also Note [Recursive superclasses] in TcInstDcls. See #17758 for more background and perf numbers. Wrinkles: * A newtype dictionary is *not* always non-bottom. E.g. class C a where op :: a -> a instance C Int where op = error "urk" Now a value of type (C Int) is just a newtype wrapper (a cast) around the error thunk. Don't strictify these! * Strictifying DFuns risks destroying the invariant that DFuns never take much work to compute, so we don't do it. See Note [Do not strictify a DFun's parameter dictionaries] for details. * Although worker/wrapper *could* unbox strictly used dictionaries, we do not do so; see Note [Do not unbox class dictionaries]. The implementation is extremely simple: just make the strictness analyser strictify the demand on a dictionary binder in 'findBndrDmd' if the binder does not belong to a DFun. Note [Do not strictify a DFun's parameter dictionaries] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The typechecker can tie recursive knots involving (non-recursive) DFuns, so we must not strictify a DFun's parameter dictionaries (#22549). T22549 has an example involving undecidable instances that <<loop>>s when we strictify the DFun of, e.g., `$fEqSeqT`: Main.$fEqSeqT = \@m @a ($dEq :: Eq (m (ViewT m a))) ($dMonad :: Monad m) -> GHC.Classes.C:Eq @(SeqT m a) ($c== @m @a $dEq $dMonad) ($c/= @m @a $dEq $dMonad) Rec { $dEq_a = Main.$fEqSeqT @Identity @Int $dEq_b Main.$fMonadIdentity $dEq_b = ... $dEq_a ... <another strict context due to DFun> } If we make `$fEqSeqT` strict in `$dEq`, we'll collapse the Rec group into a giant, <<loop>>ing thunk. To prevent that, we never strictify dictionary params when inside a DFun. That is implemented by unsetting 'dmd_strict_dicts' when entering a DFun. See also Note [Speculative evaluation] in GHC.CoreToStg.Prep which has a rather similar example in #20836. We may never speculate *arguments* of (recursive) DFun calls, likewise we should not mark *formal parameters* of recursive DFuns as strict. Note [Initialising strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See section 9.2 (Finding fixpoints) of the paper. Our basic plan is to initialise the strictness of each Id in a recursive group to "bottom", and find a fixpoint from there. However, this group B might be inside an *enclosing* recursive group A, in which case we'll do the entire fixpoint shebang on for each iteration of A. This can be illustrated by the following example: Example: f [] = [] f (x:xs) = let g [] = f xs g (y:ys) = y+1 : g ys in g (h x) At each iteration of the fixpoint for f, the analyser has to find a fixpoint for the enclosed function g. In the meantime, the demand values for g at each iteration for f are *greater* than those we encountered in the previous iteration for f. Therefore, we can begin the fixpoint for g not with the bottom value but rather with the result of the previous analysis. I.e., when beginning the fixpoint process for g, we can start from the demand signature computed for g previously and attached to the binding occurrence of g. To speed things up, we initialise each iteration of A (the enclosing one) from the result of the last one, which is neatly recorded in each binder. That way we make use of earlier iterations of the fixpoint algorithm. (Cunning plan.) But on the *first* iteration we want to *ignore* the current strictness of the Id, and start from "bottom". Nowadays the Id can have a current strictness, because interface files record strictness for nested bindings. To know when we are in the first iteration, we look at the ae_virgin field of the AnalEnv. Note [Final Demand Analyser run] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Some of the information that the demand analyser determines is not always preserved by the simplifier. For example, the simplifier will happily rewrite \y [Demand=MU] let x = y in x + x to \y [Demand=MU] y + y which is quite a lie: Now y occurs more than just once. The once-used information is (currently) only used by the code generator, though. So: * We zap the used-once info in the worker-wrapper; see Note [Zapping Used Once info in WorkWrap] in GHC.Core.Opt.WorkWrap. If it's not reliable, it's better not to have it at all. * Just before TidyCore, we add a pass of the demand analyser, but WITHOUT subsequent worker/wrapper and simplifier, right before TidyCore. See SimplCore.getCoreToDo. This way, correct information finds its way into the module interface (strictness signatures!) and the code generator (single-entry thunks!) Note that, in contrast, the single-call information (C(M,..)) /can/ be relied upon, as the simplifier tends to be very careful about not duplicating actual function calls. Also see #11731. Note [Space Leaks in Demand Analysis] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Ticket: #15455 MR: !5399 In the past the result of demand analysis was not forced until the whole module had finished being analysed. In big programs, this led to a big build up of thunks which were all ultimately forced at the end of the analysis. This was because the return type of the analysis was a lazy pair: dmdAnal :: AnalEnv -> SubDemand -> CoreExpr -> (DmdType, CoreExpr) To avoid space leaks we added extra bangs to evaluate the DmdType component eagerly; but we were never sure we had added enough. The easiest way to systematically fix this was to use a strict pair type for the return value of the analysis so that we can be more confident that the result is incrementally computed rather than all at the end. A second, only loosely related point is that the updating of Ids was not forced because the result of updating an Id was placed into a lazy field in CoreExpr. This meant that until the end of demand analysis, the unforced Ids would retain the DmdEnv which the demand information was fetch from. Now we are quite careful to force Ids before putting them back into core expressions so that we can garbage-collect the environments more eagerly. For example see the `Case` branch of `dmdAnal'` where `case_bndr'` is forced or `dmdAnalSumAlt`. The net result of all these improvements is the peak live memory usage of compiling jsaddle-dom decreases about 4GB (from 6.5G to 2.5G). A bunch of bytes allocated benchmarks also decrease because we allocate a lot fewer thunks which we immediately overwrite and also runtime for the pass is faster! Overall, good wins. -}