{- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 ----------------- A demand analysis ----------------- -} {-# LANGUAGE CPP #-} module GHC.Core.Opt.DmdAnal ( DmdAnalOpts(..) , dmdAnalProgram ) where #include "HsVersions.h" 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.FVs ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds ) import GHC.Core.Coercion ( Coercion, coVarsOfCo ) import GHC.Core.FamInstEnv import GHC.Core.Opt.Arity ( typeArity ) import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Data.Maybe ( isJust ) import GHC.Builtin.PrimOps import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) import GHC.Types.Unique.Set -- import GHC.Driver.Ppr {- ************************************************************************ * * \subsection{Top level stuff} * * ************************************************************************ -} -- | Options for the demand analysis newtype DmdAnalOpts = DmdAnalOpts { DmdAnalOpts -> Bool dmd_strict_dicts :: Bool -- ^ Use strict dictionaries } -- | 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 = (DmdType, CoreProgram) -> CoreProgram forall a b. (a, b) -> b snd ((DmdType, CoreProgram) -> CoreProgram) -> (DmdType, CoreProgram) -> CoreProgram forall a b. (a -> b) -> a -> b $ AnalEnv -> CoreProgram -> (DmdType, 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 -> (DmdType, CoreProgram) go AnalEnv _ [] = (DmdType nopDmdType, []) go AnalEnv env (Bind Var b:CoreProgram bs) = (DmdType, Bind Var, CoreProgram) -> (DmdType, CoreProgram) forall a b. (a, b, [b]) -> (a, [b]) cons_up ((DmdType, Bind Var, CoreProgram) -> (DmdType, CoreProgram)) -> (DmdType, Bind Var, CoreProgram) -> (DmdType, CoreProgram) forall a b. (a -> b) -> a -> b $ TopLevelFlag -> AnalEnv -> SubDemand -> Bind Var -> (AnalEnv -> (DmdType, CoreProgram)) -> (DmdType, Bind Var, CoreProgram) forall a. TopLevelFlag -> AnalEnv -> SubDemand -> Bind Var -> (AnalEnv -> (DmdType, a)) -> (DmdType, Bind Var, a) dmdAnalBind TopLevelFlag TopLevel AnalEnv env SubDemand topSubDmd Bind Var b AnalEnv -> (DmdType, CoreProgram) anal_body where anal_body :: AnalEnv -> (DmdType, CoreProgram) anal_body AnalEnv env' | (DmdType body_ty, CoreProgram bs') <- AnalEnv -> CoreProgram -> (DmdType, CoreProgram) go AnalEnv env' CoreProgram bs = (AnalEnv -> DmdType -> [Var] -> DmdType add_exported_uses AnalEnv env' DmdType body_ty (Bind Var -> [Var] forall b. Bind b -> [b] bindersOf Bind Var b), CoreProgram bs') cons_up :: (a, b, [b]) -> (a, [b]) cons_up :: forall a b. (a, b, [b]) -> (a, [b]) cons_up (a dmd_ty, b b', [b] bs') = (a 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 -> [Var] -> DmdType add_exported_uses AnalEnv env = (DmdType -> Var -> DmdType) -> DmdType -> [Var] -> DmdType forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl' (AnalEnv -> DmdType -> Var -> 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 -> Var -> DmdType add_exported_use AnalEnv env DmdType dmd_ty Var id | Var -> Bool isExportedId Var id Bool -> Bool -> Bool || Var -> VarSet -> Bool elemVarSet Var 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 (Var -> CoreExpr forall b. Var -> Expr b Var Var 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 :: Var -> Bool isInterestingTopLevelFn Var id = Type -> [OneShotInfo] typeArity (Var -> Type idType Var id) [OneShotInfo] -> Arity -> Bool forall a. [a] -> Arity -> Bool `lengthExceeds` 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 [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 @LCL(CM(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 'idStrictnessInfo') 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 -> (DmdType, a)) -- ^ How to analyse the "body", e.g. -- where the binding is in scope -> (DmdType, CoreBind, a) dmdAnalBind :: forall a. TopLevelFlag -> AnalEnv -> SubDemand -> Bind Var -> (AnalEnv -> (DmdType, a)) -> (DmdType, Bind Var, a) dmdAnalBind TopLevelFlag top_lvl AnalEnv env SubDemand dmd Bind Var bind AnalEnv -> (DmdType, a) anal_body = case Bind Var bind of NonRec Var id CoreExpr rhs | TopLevelFlag -> Var -> Bool useLetUp TopLevelFlag top_lvl Var id -> TopLevelFlag -> AnalEnv -> Var -> CoreExpr -> (AnalEnv -> (DmdType, a)) -> (DmdType, Bind Var, a) forall a. TopLevelFlag -> AnalEnv -> Var -> CoreExpr -> (AnalEnv -> (DmdType, a)) -> (DmdType, Bind Var, a) dmdAnalBindLetUp TopLevelFlag top_lvl AnalEnv env Var id CoreExpr rhs AnalEnv -> (DmdType, a) anal_body Bind Var _ -> TopLevelFlag -> AnalEnv -> SubDemand -> Bind Var -> (AnalEnv -> (DmdType, a)) -> (DmdType, Bind Var, a) forall a. TopLevelFlag -> AnalEnv -> SubDemand -> Bind Var -> (AnalEnv -> (DmdType, a)) -> (DmdType, Bind Var, a) dmdAnalBindLetDown TopLevelFlag top_lvl AnalEnv env SubDemand dmd Bind Var bind AnalEnv -> (DmdType, a) anal_body -- | Annotates uninteresting top level functions ('isInterestingTopLevelFn') -- with 'topDmd', the rest with the given demand. setBindIdDemandInfo :: TopLevelFlag -> Id -> Demand -> Id setBindIdDemandInfo :: TopLevelFlag -> Var -> Demand -> Var setBindIdDemandInfo TopLevelFlag top_lvl Var id Demand dmd = Var -> Demand -> Var setIdDemandInfo Var id (Demand -> Var) -> Demand -> Var forall a b. (a -> b) -> a -> b $ case TopLevelFlag top_lvl of TopLevelFlag TopLevel | Bool -> Bool not (Var -> Bool isInterestingTopLevelFn Var id) -> Demand topDmd TopLevelFlag _ -> Demand dmd -- | 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 -> (DmdType, a)) -> (DmdType, CoreBind, a) dmdAnalBindLetUp :: forall a. TopLevelFlag -> AnalEnv -> Var -> CoreExpr -> (AnalEnv -> (DmdType, a)) -> (DmdType, Bind Var, a) dmdAnalBindLetUp TopLevelFlag top_lvl AnalEnv env Var id CoreExpr rhs AnalEnv -> (DmdType, a) anal_body = (DmdType final_ty, Var -> CoreExpr -> Bind Var forall b. b -> Expr b -> Bind b NonRec Var id' CoreExpr rhs', a body') where (DmdType body_ty, a body') = AnalEnv -> (DmdType, a) anal_body AnalEnv env (DmdType body_ty', Demand id_dmd) = AnalEnv -> Bool -> DmdType -> Var -> (DmdType, Demand) findBndrDmd AnalEnv env Bool notArgOfDfun DmdType body_ty Var id id' :: Var id' = TopLevelFlag -> Var -> Demand -> Var setBindIdDemandInfo TopLevelFlag top_lvl Var id Demand id_dmd (PlusDmdArg rhs_ty, CoreExpr rhs') = AnalEnv -> Demand -> CoreExpr -> (PlusDmdArg, CoreExpr) dmdAnalStar AnalEnv env (CoreExpr -> Demand -> Demand dmdTransformThunkDmd CoreExpr rhs Demand id_dmd) CoreExpr rhs -- See Note [Absence analysis for stable unfoldings and RULES] rule_fvs :: VarSet rule_fvs = Var -> VarSet bndrRuleAndUnfoldingIds Var 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 -> (DmdType, a)) -> (DmdType, CoreBind, a) dmdAnalBindLetDown :: forall a. TopLevelFlag -> AnalEnv -> SubDemand -> Bind Var -> (AnalEnv -> (DmdType, a)) -> (DmdType, Bind Var, a) dmdAnalBindLetDown TopLevelFlag top_lvl AnalEnv env SubDemand dmd Bind Var bind AnalEnv -> (DmdType, a) anal_body = case Bind Var bind of NonRec Var id CoreExpr rhs | (AnalEnv env', DmdEnv lazy_fv, Var id1, CoreExpr rhs1) <- TopLevelFlag -> RecFlag -> AnalEnv -> SubDemand -> Var -> CoreExpr -> (AnalEnv, DmdEnv, Var, CoreExpr) dmdAnalRhsSig TopLevelFlag top_lvl RecFlag NonRecursive AnalEnv env SubDemand dmd Var id CoreExpr rhs -> AnalEnv -> DmdEnv -> [(Var, CoreExpr)] -> ([(Var, CoreExpr)] -> Bind Var) -> (DmdType, Bind Var, a) do_rest AnalEnv env' DmdEnv lazy_fv [(Var id1, CoreExpr rhs1)] ((Var -> CoreExpr -> Bind Var) -> (Var, CoreExpr) -> Bind Var forall a b c. (a -> b -> c) -> (a, b) -> c uncurry Var -> CoreExpr -> Bind Var forall b. b -> Expr b -> Bind b NonRec ((Var, CoreExpr) -> Bind Var) -> ([(Var, CoreExpr)] -> (Var, CoreExpr)) -> [(Var, CoreExpr)] -> Bind Var forall b c a. (b -> c) -> (a -> b) -> a -> c . [(Var, CoreExpr)] -> (Var, CoreExpr) forall a. [a] -> a only) Rec [(Var, CoreExpr)] pairs | (AnalEnv env', DmdEnv lazy_fv, [(Var, CoreExpr)] pairs') <- TopLevelFlag -> AnalEnv -> SubDemand -> [(Var, CoreExpr)] -> (AnalEnv, DmdEnv, [(Var, CoreExpr)]) dmdFix TopLevelFlag top_lvl AnalEnv env SubDemand dmd [(Var, CoreExpr)] pairs -> AnalEnv -> DmdEnv -> [(Var, CoreExpr)] -> ([(Var, CoreExpr)] -> Bind Var) -> (DmdType, Bind Var, a) do_rest AnalEnv env' DmdEnv lazy_fv [(Var, CoreExpr)] pairs' [(Var, CoreExpr)] -> Bind Var forall b. [(b, Expr b)] -> Bind b Rec where do_rest :: AnalEnv -> DmdEnv -> [(Var, CoreExpr)] -> ([(Var, CoreExpr)] -> Bind Var) -> (DmdType, Bind Var, a) do_rest AnalEnv env' DmdEnv lazy_fv [(Var, CoreExpr)] pairs1 [(Var, CoreExpr)] -> Bind Var build_bind = (DmdType final_ty, [(Var, CoreExpr)] -> Bind Var build_bind [(Var, CoreExpr)] pairs2, a body') where (DmdType body_ty, a body') = AnalEnv -> (DmdType, 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 (!DmdType final_ty, [Demand] id_dmds) = AnalEnv -> DmdType -> [Var] -> (DmdType, [Demand]) findBndrsDmds AnalEnv env' DmdType dmd_ty (((Var, CoreExpr) -> Var) -> [(Var, CoreExpr)] -> [Var] forall a b. (a -> b) -> [a] -> [b] map (Var, CoreExpr) -> Var forall a b. (a, b) -> a fst [(Var, CoreExpr)] pairs1) pairs2 :: [(Var, CoreExpr)] pairs2 = ((Var, CoreExpr) -> Demand -> (Var, CoreExpr)) -> [(Var, CoreExpr)] -> [Demand] -> [(Var, CoreExpr)] forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith (Var, CoreExpr) -> Demand -> (Var, CoreExpr) do_one [(Var, CoreExpr)] pairs1 [Demand] id_dmds do_one :: (Var, CoreExpr) -> Demand -> (Var, CoreExpr) do_one (Var id', CoreExpr rhs') Demand dmd = (TopLevelFlag -> Var -> Demand -> Var setBindIdDemandInfo TopLevelFlag top_lvl Var id' Demand dmd, 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. -- If e is complicated enough to become a thunk, its contents will be evaluated -- at most once, so oneify it. dmdTransformThunkDmd :: CoreExpr -> Demand -> Demand dmdTransformThunkDmd :: CoreExpr -> Demand -> Demand dmdTransformThunkDmd CoreExpr e | CoreExpr -> Bool exprIsTrivial CoreExpr e = Demand -> Demand forall a. a -> a id | Bool otherwise = Demand -> Demand oneifyDmd -- 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 -- Should obey the let/app invariant -> (PlusDmdArg, CoreExpr) dmdAnalStar :: AnalEnv -> Demand -> CoreExpr -> (PlusDmdArg, CoreExpr) dmdAnalStar AnalEnv env (Card n :* SubDemand cd) CoreExpr e | (DmdType dmd_ty, CoreExpr e') <- AnalEnv -> SubDemand -> CoreExpr -> (DmdType, CoreExpr) dmdAnal AnalEnv env SubDemand cd CoreExpr e = ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e ) -- The argument 'e' should satisfy the let/app invariant -- See Note [Analysing with absent demand] in GHC.Types.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 Analsysis machinery dmdAnal, dmdAnal' :: AnalEnv -> SubDemand -- The main one takes a *SubDemand* -> CoreExpr -> (DmdType, CoreExpr) dmdAnal :: AnalEnv -> SubDemand -> CoreExpr -> (DmdType, CoreExpr) dmdAnal AnalEnv env SubDemand d CoreExpr e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $ AnalEnv -> SubDemand -> CoreExpr -> (DmdType, CoreExpr) dmdAnal' AnalEnv env SubDemand d CoreExpr e dmdAnal' :: AnalEnv -> SubDemand -> CoreExpr -> (DmdType, CoreExpr) dmdAnal' AnalEnv _ SubDemand _ (Lit Literal lit) = (DmdType nopDmdType, Literal -> CoreExpr forall b. Literal -> Expr b Lit Literal lit) dmdAnal' AnalEnv _ SubDemand _ (Type Type ty) = (DmdType nopDmdType, Type -> CoreExpr forall b. Type -> Expr b Type Type ty) -- Doesn't happen, in fact dmdAnal' AnalEnv _ SubDemand _ (Coercion Coercion co) = (DmdEnv -> DmdType unitDmdType (Coercion -> DmdEnv coercionDmdEnv Coercion co), Coercion -> CoreExpr forall b. Coercion -> Expr b Coercion Coercion co) dmdAnal' AnalEnv env SubDemand dmd (Var Var var) = (AnalEnv -> Var -> SubDemand -> DmdType dmdTransform AnalEnv env Var var SubDemand dmd, Var -> CoreExpr forall b. Var -> Expr b Var Var var) dmdAnal' AnalEnv env SubDemand dmd (Cast CoreExpr e Coercion co) = (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 (DmdType dmd_ty, CoreExpr e') = AnalEnv -> SubDemand -> CoreExpr -> (DmdType, CoreExpr) dmdAnal AnalEnv env SubDemand dmd CoreExpr e dmdAnal' AnalEnv env SubDemand dmd (Tick CoreTickish t CoreExpr e) = (DmdType dmd_ty, CoreTickish -> CoreExpr -> CoreExpr forall b. CoreTickish -> Expr b -> Expr b Tick CoreTickish t CoreExpr e') where (DmdType dmd_ty, CoreExpr e') = AnalEnv -> SubDemand -> CoreExpr -> (DmdType, CoreExpr) dmdAnal AnalEnv env SubDemand dmd CoreExpr e dmdAnal' AnalEnv env SubDemand dmd (App CoreExpr fun (Type Type ty)) = (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 (DmdType fun_ty, CoreExpr fun') = AnalEnv -> SubDemand -> CoreExpr -> (DmdType, 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 (DmdType fun_ty, CoreExpr fun') = AnalEnv -> SubDemand -> CoreExpr -> (DmdType, 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 (CoreExpr -> Demand -> Demand dmdTransformThunkDmd CoreExpr arg 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 `bothDmdType` arg_ty) ]) (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 Var var CoreExpr body) | Var -> Bool isTyVar Var var = let (DmdType body_ty, CoreExpr body') = AnalEnv -> SubDemand -> CoreExpr -> (DmdType, CoreExpr) dmdAnal AnalEnv env SubDemand dmd CoreExpr body in (DmdType body_ty, Var -> CoreExpr -> CoreExpr forall b. b -> Expr b -> Expr b Lam Var 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 (DmdType body_ty, CoreExpr body') = AnalEnv -> SubDemand -> CoreExpr -> (DmdType, CoreExpr) dmdAnal AnalEnv env SubDemand body_dmd CoreExpr body (DmdType lam_ty, Var var') = AnalEnv -> Bool -> DmdType -> Var -> (DmdType, Var) annotateLamIdBndr AnalEnv env Bool notArgOfDfun DmdType body_ty Var var in (Card -> DmdType -> DmdType multDmdType Card n DmdType lam_ty, Var -> CoreExpr -> CoreExpr forall b. b -> Expr b -> Expr b Lam Var var' CoreExpr body') dmdAnal' AnalEnv env SubDemand dmd (Case CoreExpr scrut Var case_bndr Type ty [Alt AltCon alt [Var] bndrs CoreExpr rhs]) -- Only one alternative. -- If it's a DataAlt, it should be the only constructor of the type. | AltCon -> Bool is_single_data_alt AltCon alt = let (DmdType rhs_ty, CoreExpr rhs') = AnalEnv -> SubDemand -> CoreExpr -> (DmdType, CoreExpr) dmdAnal AnalEnv env SubDemand dmd CoreExpr rhs (DmdType alt_ty1, [Demand] dmds) = AnalEnv -> DmdType -> [Var] -> (DmdType, [Demand]) findBndrsDmds AnalEnv env DmdType rhs_ty [Var] bndrs (DmdType alt_ty2, Demand case_bndr_dmd) = AnalEnv -> Bool -> DmdType -> Var -> (DmdType, Demand) findBndrDmd AnalEnv env Bool False DmdType alt_ty1 Var case_bndr -- Evaluation cardinality on the case binder is irrelevant and a no-op. -- What matters is its nested sub-demand! (Card _ :* SubDemand case_bndr_sd) = Demand case_bndr_dmd -- Compute demand on the scrutinee ([Var] bndrs', SubDemand scrut_sd) | DataAlt DataCon _ <- AltCon alt , [Demand] id_dmds <- SubDemand -> [Demand] -> [Demand] addCaseBndrDmd SubDemand case_bndr_sd [Demand] dmds -- See Note [Demand on scrutinee of a product case] = ([Var] -> [Demand] -> [Var] setBndrsDemandInfo [Var] bndrs [Demand] id_dmds, [Demand] -> SubDemand mkProd [Demand] id_dmds) | Bool otherwise -- __DEFAULT and literal alts. Simply add demands and discard the -- evaluation cardinality, as we evaluate the scrutinee exactly once. = ASSERT( null bndrs ) (bndrs, case_bndr_sd) fam_envs :: FamInstEnvs fam_envs = AnalEnv -> FamInstEnvs ae_fam_envs AnalEnv env alt_ty3 :: DmdType alt_ty3 -- 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_ty2 | Bool otherwise = DmdType alt_ty2 (DmdType scrut_ty, CoreExpr scrut') = AnalEnv -> SubDemand -> CoreExpr -> (DmdType, 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 case_bndr' :: Var case_bndr' = Var -> Demand -> Var setIdDemandInfo Var case_bndr Demand case_bndr_dmd 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 res_ty, CoreExpr -> Var -> Type -> [Alt Var] -> CoreExpr forall b. Expr b -> b -> Type -> [Alt b] -> Expr b Case CoreExpr scrut' Var case_bndr' Type ty [AltCon -> [Var] -> CoreExpr -> Alt Var forall b. AltCon -> [b] -> Expr b -> Alt b Alt AltCon alt [Var] bndrs' CoreExpr rhs']) where is_single_data_alt :: AltCon -> Bool is_single_data_alt (DataAlt DataCon dc) = Maybe DataCon -> Bool forall a. Maybe a -> Bool isJust (Maybe DataCon -> Bool) -> Maybe DataCon -> Bool forall a b. (a -> b) -> a -> b $ TyCon -> Maybe DataCon tyConSingleAlgDataCon_maybe (TyCon -> Maybe DataCon) -> TyCon -> Maybe DataCon forall a b. (a -> b) -> a -> b $ DataCon -> TyCon dataConTyCon DataCon dc is_single_data_alt AltCon _ = Bool True dmdAnal' AnalEnv env SubDemand dmd (Case CoreExpr scrut Var case_bndr Type ty [Alt Var] alts) = let -- Case expression with multiple alternatives ([DmdType] alt_tys, [Alt Var] alts') = (Alt Var -> (DmdType, Alt Var)) -> [Alt Var] -> ([DmdType], [Alt Var]) forall a b c. (a -> (b, c)) -> [a] -> ([b], [c]) mapAndUnzip (AnalEnv -> SubDemand -> Var -> Alt Var -> (DmdType, Alt Var) dmdAnalSumAlt AnalEnv env SubDemand dmd Var case_bndr) [Alt Var] alts (DmdType scrut_ty, CoreExpr scrut') = AnalEnv -> SubDemand -> CoreExpr -> (DmdType, CoreExpr) dmdAnal AnalEnv env SubDemand topSubDmd CoreExpr scrut (DmdType alt_ty, Var case_bndr') = AnalEnv -> DmdType -> Var -> (DmdType, Var) annotateBndr AnalEnv env ((DmdType -> DmdType -> DmdType) -> DmdType -> [DmdType] -> DmdType forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr DmdType -> DmdType -> DmdType lubDmdType DmdType botDmdType [DmdType] alt_tys) Var case_bndr -- NB: Base case is botDmdType, for empty case alternatives -- This is a unit for lubDmdType, and the right result -- when there really are no alternatives 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_ty | Bool otherwise = DmdType alt_ty 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_tys" <+> ppr alt_tys -- , text "alt_ty2" <+> ppr alt_ty2 -- , text "res_ty" <+> ppr res_ty ]) $ (DmdType res_ty, CoreExpr -> Var -> Type -> [Alt Var] -> CoreExpr forall b. Expr b -> b -> Type -> [Alt b] -> Expr b Case CoreExpr scrut' Var case_bndr' Type ty [Alt Var] alts') dmdAnal' AnalEnv env SubDemand dmd (Let Bind Var bind CoreExpr body) = (DmdType final_ty, Bind Var -> CoreExpr -> CoreExpr forall b. Bind b -> Expr b -> Expr b Let Bind Var bind' CoreExpr body') where (DmdType final_ty, Bind Var bind', CoreExpr body') = TopLevelFlag -> AnalEnv -> SubDemand -> Bind Var -> (AnalEnv -> (DmdType, CoreExpr)) -> (DmdType, Bind Var, CoreExpr) forall a. TopLevelFlag -> AnalEnv -> SubDemand -> Bind Var -> (AnalEnv -> (DmdType, a)) -> (DmdType, Bind Var, a) dmdAnalBind TopLevelFlag NotTopLevel AnalEnv env SubDemand dmd Bind Var bind AnalEnv -> (DmdType, CoreExpr) go' go' :: AnalEnv -> (DmdType, CoreExpr) go' AnalEnv env' = AnalEnv -> SubDemand -> CoreExpr -> (DmdType, 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 (CoreExpr -> Type exprType CoreExpr e)) = Bool False -- 1. in the Note | (Var Var f, [CoreExpr] _) <- CoreExpr -> (CoreExpr, [CoreExpr]) forall b. Expr b -> (Expr b, [Expr b]) collectArgs CoreExpr e , Just PrimOp op <- Var -> Maybe PrimOp isPrimOpId_maybe Var f , PrimOp op PrimOp -> PrimOp -> Bool forall a. Eq a => a -> a -> Bool /= PrimOp RaiseIOOp = Bool False -- 2. in the Note | (Var Var f, [CoreExpr] _) <- CoreExpr -> (CoreExpr, [CoreExpr]) forall b. Expr b -> (Expr b, [Expr b]) collectArgs CoreExpr e , Just ForeignCall fcall <- Var -> Maybe ForeignCall isFCallId_maybe Var 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 DataConPatContext{ dcpc_dc :: DataConPatContext -> DataCon dcpc_dc = DataCon dc, dcpc_tc_args :: DataConPatContext -> [Type] dcpc_tc_args = [Type] tc_args } <- FamInstEnvs -> Type -> Maybe DataConPatContext splitArgType_maybe FamInstEnvs fam_envs Type ty , DataCon -> Bool isUnboxedTupleDataCon DataCon dc , let field_tys :: [Scaled Type] field_tys = DataCon -> [Type] -> [Scaled Type] dataConInstArgTys DataCon dc [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 dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> (DmdType, Alt Var) dmdAnalSumAlt :: AnalEnv -> SubDemand -> Var -> Alt Var -> (DmdType, Alt Var) dmdAnalSumAlt AnalEnv env SubDemand dmd Var case_bndr (Alt AltCon con [Var] bndrs CoreExpr rhs) | (DmdType rhs_ty, CoreExpr rhs') <- AnalEnv -> SubDemand -> CoreExpr -> (DmdType, CoreExpr) dmdAnal AnalEnv env SubDemand dmd CoreExpr rhs , (DmdType alt_ty, [Demand] dmds) <- AnalEnv -> DmdType -> [Var] -> (DmdType, [Demand]) findBndrsDmds AnalEnv env DmdType rhs_ty [Var] bndrs , let (Card _ :* SubDemand case_bndr_sd) = DmdType -> Var -> Demand findIdDemand DmdType alt_ty Var case_bndr -- See Note [Demand on scrutinee of a product case] id_dmds :: [Demand] id_dmds = SubDemand -> [Demand] -> [Demand] addCaseBndrDmd SubDemand case_bndr_sd [Demand] dmds = (DmdType alt_ty, AltCon -> [Var] -> CoreExpr -> Alt Var forall b. AltCon -> [b] -> Expr b -> Alt b Alt AltCon con ([Var] -> [Demand] -> [Var] setBndrsDemandInfo [Var] bndrs [Demand] id_dmds) CoreExpr rhs') {- 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. * In a previous incarnation of GHC we needed to be extra careful in the case of an *unlifted type*, because unlifted values are evaluated even if they are not used. Example (see #9254): f :: (() -> (# Int#, () #)) -> () -- Strictness signature is -- <CS(S(A,SU))> -- 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. This is correct in the sense that it'd be fine to (say) modify the function so that always returned 0# in the first component. But in function g, we *will* evaluate the 'case y of ...', because it has type Int#. So 'y' will be evaluated. So 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_ERROR thunk. However, the argument of toSubDmd always satisfies the let/app invariant; so if it is unlifted it is also okForSpeculation, and so can be evaluated in a short finite time -- and that rules out nasty cases like the one above. (I'm not quite sure why this was a problem in an earlier version of GHC, but it isn't now.) 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 on the scrutinee of a product case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When figuring out the demand on the scrutinee of a product case, we use the demands of the case alternative, i.e. id_dmds. But note that these include the demand on the case binder; see Note [Demand on case-alternative binders] in GHC.Types.Demand. 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 [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 strictness environment -> Id -- ^ The function -> SubDemand -- ^ The demand on the function -> DmdType -- ^ The demand type of the function in this context -- 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 -> Var -> SubDemand -> DmdType dmdTransform AnalEnv env Var var SubDemand dmd -- Data constructors | Var -> Bool isDataConWorkId Var var = Arity -> SubDemand -> DmdType dmdTransformDataConSig (Var -> Arity idArity Var var) SubDemand dmd -- Dictionary component selectors -- Used to be controlled by a flag. -- See #18429 for some perf measurements. | Just Class _ <- Var -> Maybe Class isClassOpId_maybe Var var = -- pprTrace "dmdTransform:DictSel" (ppr var $$ ppr dmd) $ StrictSig -> SubDemand -> DmdType dmdTransformDictSelSig (Var -> StrictSig idStrictness Var var) SubDemand dmd -- Imported functions | Var -> Bool isGlobalId Var var , let res :: DmdType res = StrictSig -> SubDemand -> DmdType dmdTransformSig (Var -> StrictSig idStrictness Var var) SubDemand dmd = -- pprTrace "dmdTransform:import" (vcat [ppr var, ppr (idStrictness var), ppr dmd, 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 (StrictSig sig, TopLevelFlag top_lvl) <- AnalEnv -> Var -> Maybe (StrictSig, TopLevelFlag) lookupSigEnv AnalEnv env Var var , let fn_ty :: DmdType fn_ty = StrictSig -> SubDemand -> DmdType dmdTransformSig StrictSig sig SubDemand dmd = -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $ case TopLevelFlag top_lvl of TopLevelFlag NotTopLevel -> DmdType -> Var -> Demand -> DmdType addVarDmd DmdType fn_ty Var var (Card C_11 Card -> SubDemand -> Demand :* SubDemand dmd) TopLevelFlag TopLevel | Var -> Bool isInterestingTopLevelFn Var 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 -> Var -> Demand -> DmdType addVarDmd DmdType fn_ty Var var (Card C_0N Card -> Demand -> Demand `multDmd` (Card C_11 Card -> SubDemand -> Demand :* SubDemand dmd)) -- 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 sig, ppr dmd, ppr res]) $ DmdEnv -> DmdType unitDmdType (Var -> Demand -> DmdEnv forall a. Var -> a -> VarEnv a unitVarEnv Var var (Card C_11 Card -> SubDemand -> Demand :* SubDemand dmd)) {- ********************************************************************* * * 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 -> Var -> CoreExpr -> (AnalEnv, DmdEnv, Var, CoreExpr) dmdAnalRhsSig TopLevelFlag top_lvl RecFlag rec_flag AnalEnv env SubDemand let_dmd Var id CoreExpr rhs = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr sig $$ ppr lazy_fv) $ (AnalEnv env', DmdEnv lazy_fv, Var id', CoreExpr rhs') where rhs_arity :: Arity rhs_arity = Var -> Arity idArity Var id -- See Note [Demand signatures are computed for a threshold demand based on idArity] rhs_dmd :: SubDemand rhs_dmd -- See Note [Demand analysis for join points] -- See Note [Invariants on join points] invariant 2b, in GHC.Core -- rhs_arity matches the join arity of the join point | Var -> Bool isJoinId Var id = Arity -> SubDemand -> SubDemand mkCalledOnceDmds Arity rhs_arity SubDemand let_dmd | Bool otherwise = Arity -> SubDemand -> SubDemand mkCalledOnceDmds Arity rhs_arity SubDemand topSubDmd (DmdType rhs_dmd_ty, CoreExpr rhs') = AnalEnv -> SubDemand -> CoreExpr -> (DmdType, CoreExpr) dmdAnal AnalEnv env SubDemand rhs_dmd CoreExpr rhs DmdType DmdEnv rhs_fv [Demand] rhs_dmds Divergence rhs_div = DmdType rhs_dmd_ty sig :: StrictSig sig = Arity -> DmdType -> StrictSig mkStrictSigForArity Arity rhs_arity (DmdEnv -> [Demand] -> Divergence -> DmdType DmdType DmdEnv sig_fv [Demand] rhs_dmds Divergence rhs_div) id' :: Var id' = Var id Var -> StrictSig -> Var `setIdStrictness` StrictSig sig env' :: AnalEnv env' = TopLevelFlag -> AnalEnv -> Var -> StrictSig -> AnalEnv extendAnalEnv TopLevelFlag top_lvl AnalEnv env Var id' StrictSig 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. 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` Var -> VarSet bndrRuleAndUnfoldingIds Var 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 -- | 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 -> Var -> Bool useLetUp TopLevelFlag top_lvl Var f = TopLevelFlag -> Bool isNotTopLevel TopLevelFlag top_lvl Bool -> Bool -> Bool && Var -> Arity idArity Var f Arity -> Arity -> Bool forall a. Eq a => a -> a -> Bool == Arity 0 Bool -> Bool -> Bool && Bool -> Bool not (Var -> Bool isJoinId Var 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 C1(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 C1(L) context the RHS of the join point is indeed bottom. Note [Demand signatures are computed for a threshold demand based on idArity] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We compute demand signatures assuming idArity incoming arguments to approximate behavior for when we have a call site with at least that many arguments. 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]). Because idArity of a function varies independently of its cardinality properties (cf. Note [idArity varies independently of dmdTypeDepth]), we implicitly encode the arity for when a demand signature is sound to unleash in its 'dmdTypeDepth' (cf. Note [Understanding DmdType and StrictSig] in GHC.Types.Demand). It is unsound to unleash a demand signature when the incoming number of arguments is less than that. See Note [What are demand signatures?] in GHC.Types.Demand for more details on soundness. 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. There might 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 C1(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 C1(C1(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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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. That's an unnecessary dependency, because * The demand signature captures a semantic property that is independent of what the binding's current arity is * idArity is analysis information itself, thus volatile * We already *have* dmdTypeDepth, wo why not just use it to encode the threshold for when to unleash the signature (cf. Note [Understanding DmdType and StrictSig] in GHC.Types.Demand) Consider the following expression, for example: (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. 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. Historical Note [Product demands for function body] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In 2013 I spotted this example, in shootout/binary_trees: Main.check' = \ b z ds. case z of z' { I# ip -> case ds_d13s of Main.Nil -> z' Main.Node s14k s14l s14m -> Main.check' (not b) (Main.check' b (case b { False -> I# (-# s14h s14k); True -> I# (+# s14h s14k) }) s14l) s14m } } } Here we *really* want to unbox z, even though it appears to be used boxed in the Nil case. Partly the Nil case is not a hot path. But more specifically, the whole function gets the CPR property if we do. That motivated using a demand of C1(C1(C1(P(L,L)))) for the RHS, where (solely because the result was a product) we used a product demand (albeit with lazy components) for the body. But that gives very silly behaviour -- see #17932. Happily it turns out now to be entirely unnecessary: we get good results with C1(C1(C1(L))). So I simply deleted the special case. -} {- ********************************************************************* * * 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 -> [(Var, CoreExpr)] -> (AnalEnv, DmdEnv, [(Var, CoreExpr)]) dmdFix TopLevelFlag top_lvl AnalEnv env SubDemand let_dmd [(Var, CoreExpr)] orig_pairs = Arity -> [(Var, CoreExpr)] -> (AnalEnv, DmdEnv, [(Var, CoreExpr)]) loop Arity 1 [(Var, CoreExpr)] initial_pairs where -- See Note [Initialising strictness] initial_pairs :: [(Var, CoreExpr)] initial_pairs | AnalEnv -> Bool ae_virgin AnalEnv env = [(Var -> StrictSig -> Var setIdStrictness Var id StrictSig botSig, CoreExpr rhs) | (Var id, CoreExpr rhs) <- [(Var, CoreExpr)] orig_pairs ] | Bool otherwise = [(Var, 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, [(Var, CoreExpr)]) abort = (AnalEnv env, DmdEnv lazy_fv', [(Var, CoreExpr)] zapped_pairs) where (DmdEnv lazy_fv, [(Var, CoreExpr)] pairs') = Bool -> [(Var, CoreExpr)] -> (DmdEnv, [(Var, CoreExpr)]) step Bool True ([(Var, CoreExpr)] -> [(Var, CoreExpr)] zapIdStrictness [(Var, 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 $ ((Var, CoreExpr) -> DmdEnv) -> [(Var, CoreExpr)] -> [DmdEnv] forall a b. (a -> b) -> [a] -> [b] map (StrictSig -> DmdEnv strictSigDmdEnv (StrictSig -> DmdEnv) -> ((Var, CoreExpr) -> StrictSig) -> (Var, CoreExpr) -> DmdEnv forall b c a. (b -> c) -> (a -> b) -> a -> c . Var -> StrictSig idStrictness (Var -> StrictSig) -> ((Var, CoreExpr) -> Var) -> (Var, CoreExpr) -> StrictSig forall b c a. (b -> c) -> (a -> b) -> a -> c . (Var, CoreExpr) -> Var forall a b. (a, b) -> a fst) [(Var, 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 :: [(Var, CoreExpr)] zapped_pairs = [(Var, CoreExpr)] -> [(Var, CoreExpr)] zapIdStrictness [(Var, CoreExpr)] pairs' -- The fixed-point varies the idStrictness field of the binders, and terminates if that -- annotation does not change any more. loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) loop :: Arity -> [(Var, CoreExpr)] -> (AnalEnv, DmdEnv, [(Var, CoreExpr)]) loop Arity n [(Var, CoreExpr)] pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idStrictness id) -- | (id,_)<- pairs]) $ Arity -> [(Var, CoreExpr)] -> (AnalEnv, DmdEnv, [(Var, CoreExpr)]) loop' Arity n [(Var, CoreExpr)] pairs loop' :: Arity -> [(Var, CoreExpr)] -> (AnalEnv, DmdEnv, [(Var, CoreExpr)]) loop' Arity n [(Var, CoreExpr)] pairs | Bool found_fixpoint = (AnalEnv final_anal_env, DmdEnv lazy_fv, [(Var, CoreExpr)] pairs') | Arity n Arity -> Arity -> Bool forall a. Eq a => a -> a -> Bool == Arity 10 = (AnalEnv, DmdEnv, [(Var, CoreExpr)]) abort | Bool otherwise = Arity -> [(Var, CoreExpr)] -> (AnalEnv, DmdEnv, [(Var, CoreExpr)]) loop (Arity nArity -> Arity -> Arity forall a. Num a => a -> a -> a +Arity 1) [(Var, CoreExpr)] pairs' where found_fixpoint :: Bool found_fixpoint = ((Var, CoreExpr) -> StrictSig) -> [(Var, CoreExpr)] -> [StrictSig] forall a b. (a -> b) -> [a] -> [b] map (Var -> StrictSig idStrictness (Var -> StrictSig) -> ((Var, CoreExpr) -> Var) -> (Var, CoreExpr) -> StrictSig forall b c a. (b -> c) -> (a -> b) -> a -> c . (Var, CoreExpr) -> Var forall a b. (a, b) -> a fst) [(Var, CoreExpr)] pairs' [StrictSig] -> [StrictSig] -> Bool forall a. Eq a => a -> a -> Bool == ((Var, CoreExpr) -> StrictSig) -> [(Var, CoreExpr)] -> [StrictSig] forall a b. (a -> b) -> [a] -> [b] map (Var -> StrictSig idStrictness (Var -> StrictSig) -> ((Var, CoreExpr) -> Var) -> (Var, CoreExpr) -> StrictSig forall b c a. (b -> c) -> (a -> b) -> a -> c . (Var, CoreExpr) -> Var forall a b. (a, b) -> a fst) [(Var, CoreExpr)] pairs first_round :: Bool first_round = Arity n Arity -> Arity -> Bool forall a. Eq a => a -> a -> Bool == Arity 1 (DmdEnv lazy_fv, [(Var, CoreExpr)] pairs') = Bool -> [(Var, CoreExpr)] -> (DmdEnv, [(Var, CoreExpr)]) step Bool first_round [(Var, CoreExpr)] pairs final_anal_env :: AnalEnv final_anal_env = TopLevelFlag -> AnalEnv -> [Var] -> AnalEnv extendAnalEnvs TopLevelFlag top_lvl AnalEnv env (((Var, CoreExpr) -> Var) -> [(Var, CoreExpr)] -> [Var] forall a b. (a -> b) -> [a] -> [b] map (Var, CoreExpr) -> Var forall a b. (a, b) -> a fst [(Var, CoreExpr)] pairs') step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)]) step :: Bool -> [(Var, CoreExpr)] -> (DmdEnv, [(Var, CoreExpr)]) step Bool first_round [(Var, CoreExpr)] pairs = (DmdEnv lazy_fv, [(Var, 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 -> [Var] -> AnalEnv extendAnalEnvs TopLevelFlag top_lvl AnalEnv start_env (((Var, CoreExpr) -> Var) -> [(Var, CoreExpr)] -> [Var] forall a b. (a -> b) -> [a] -> [b] map (Var, CoreExpr) -> Var forall a b. (a, b) -> a fst [(Var, CoreExpr)] pairs), DmdEnv emptyDmdEnv) ((AnalEnv _,DmdEnv lazy_fv), [(Var, CoreExpr)] pairs') = ((AnalEnv, DmdEnv) -> (Var, CoreExpr) -> ((AnalEnv, DmdEnv), (Var, CoreExpr))) -> (AnalEnv, DmdEnv) -> [(Var, CoreExpr)] -> ((AnalEnv, DmdEnv), [(Var, CoreExpr)]) forall (t :: * -> *) s a b. Traversable t => (s -> a -> (s, b)) -> s -> t a -> (s, t b) mapAccumL (AnalEnv, DmdEnv) -> (Var, CoreExpr) -> ((AnalEnv, DmdEnv), (Var, CoreExpr)) my_downRhs (AnalEnv, DmdEnv) start [(Var, 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) -> (Var, CoreExpr) -> ((AnalEnv, DmdEnv), (Var, CoreExpr)) my_downRhs (AnalEnv env, DmdEnv lazy_fv) (Var id,CoreExpr rhs) = -- pprTrace "my_downRhs" (ppr id $$ ppr (idStrictness id) $$ ppr sig) $ ((AnalEnv env', DmdEnv lazy_fv'), (Var id', CoreExpr rhs')) where (AnalEnv env', DmdEnv lazy_fv1, Var id', CoreExpr rhs') = TopLevelFlag -> RecFlag -> AnalEnv -> SubDemand -> Var -> CoreExpr -> (AnalEnv, DmdEnv, Var, CoreExpr) dmdAnalRhsSig TopLevelFlag top_lvl RecFlag Recursive AnalEnv env SubDemand let_dmd Var 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 zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)] zapIdStrictness :: [(Var, CoreExpr)] -> [(Var, CoreExpr)] zapIdStrictness [(Var, CoreExpr)] pairs = [(Var -> StrictSig -> Var setIdStrictness Var id StrictSig nopSig, CoreExpr rhs) | (Var id, CoreExpr rhs) <- [(Var, 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 botttom 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 recrusive. 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 = (Var -> Demand) -> VarEnv Var -> DmdEnv forall a b. (a -> b) -> VarEnv a -> VarEnv b mapVarEnv (Demand -> Var -> Demand forall a b. a -> b -> a const Demand topDmd) (VarSet -> VarEnv Var forall a. UniqSet a -> UniqFM a a getUniqSet (VarSet -> VarEnv Var) -> VarSet -> VarEnv Var forall a b. (a -> b) -> a -> b $ Coercion -> VarSet coVarsOfCo Coercion co) -- The VarSet from coVarsOfCo is really a VarEnv Var addVarDmd :: DmdType -> Var -> Demand -> DmdType addVarDmd :: DmdType -> Var -> Demand -> DmdType addVarDmd (DmdType DmdEnv fv [Demand] ds Divergence res) Var var Demand dmd = DmdEnv -> [Demand] -> Divergence -> DmdType DmdType ((Demand -> Demand -> Demand) -> DmdEnv -> Var -> Demand -> DmdEnv forall a. (a -> a -> a) -> VarEnv a -> Var -> a -> VarEnv a extendVarEnv_C Demand -> Demand -> Demand plusDmd DmdEnv fv Var 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. {- Note [Do not strictify the argument dictionaries of a dfun] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The typechecker can tie recursive knots involving dfuns, so we do the conservative thing and refrain from strictifying a dfun's argument dictionaries. -} setBndrsDemandInfo :: [Var] -> [Demand] -> [Var] setBndrsDemandInfo :: [Var] -> [Demand] -> [Var] setBndrsDemandInfo (Var b:[Var] bs) [Demand] ds | Var -> Bool isTyVar Var b = Var b Var -> [Var] -> [Var] forall a. a -> [a] -> [a] : [Var] -> [Demand] -> [Var] setBndrsDemandInfo [Var] bs [Demand] ds setBndrsDemandInfo (Var b:[Var] bs) (Demand d:[Demand] ds) = Var -> Demand -> Var setIdDemandInfo Var b Demand d Var -> [Var] -> [Var] forall a. a -> [a] -> [a] : [Var] -> [Demand] -> [Var] setBndrsDemandInfo [Var] bs [Demand] ds setBndrsDemandInfo [] [Demand] ds = ASSERT( null ds ) [] setBndrsDemandInfo [Var] bs [Demand] _ = String -> SDoc -> [Var] forall a. HasCallStack => String -> SDoc -> a pprPanic String "setBndrsDemandInfo" ([Var] -> SDoc forall a. Outputable a => a -> SDoc ppr [Var] bs) annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var) -- The returned env has the var deleted -- The returned var is annotated with demand info -- according to the result demand of the provided demand type -- No effect on the argument demands annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var) annotateBndr AnalEnv env DmdType dmd_ty Var var | Var -> Bool isId Var var = (DmdType dmd_ty', Var -> Demand -> Var setIdDemandInfo Var var Demand dmd) | Bool otherwise = (DmdType dmd_ty, Var var) where (DmdType dmd_ty', Demand dmd) = AnalEnv -> Bool -> DmdType -> Var -> (DmdType, Demand) findBndrDmd AnalEnv env Bool False DmdType dmd_ty Var var annotateLamIdBndr :: AnalEnv -> DFunFlag -- is this lambda at the top of the RHS of a dfun? -> DmdType -- Demand type of body -> Id -- Lambda binder -> (DmdType, -- Demand type of lambda Id) -- and binder annotated with demand annotateLamIdBndr :: AnalEnv -> Bool -> DmdType -> Var -> (DmdType, Var) annotateLamIdBndr AnalEnv env Bool arg_of_dfun DmdType dmd_ty Var id -- For lambdas we add the demand to the argument demands -- Only called for Ids = ASSERT( isId id ) -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $ (DmdType final_ty, Var -> Demand -> Var setIdDemandInfo Var id Demand dmd) where -- Watch out! See note [Lambda-bound unfoldings] final_ty :: DmdType final_ty = case Unfolding -> Maybe CoreExpr maybeUnfoldingTemplate (Var -> Unfolding idUnfolding Var id) of Maybe CoreExpr Nothing -> DmdType main_ty Just CoreExpr unf -> DmdType main_ty DmdType -> PlusDmdArg -> DmdType `plusDmdType` PlusDmdArg unf_ty where (PlusDmdArg unf_ty, CoreExpr _) = AnalEnv -> Demand -> CoreExpr -> (PlusDmdArg, CoreExpr) dmdAnalStar AnalEnv env Demand dmd CoreExpr unf main_ty :: DmdType main_ty = Demand -> DmdType -> DmdType addDemand Demand dmd DmdType dmd_ty' (DmdType dmd_ty', Demand dmd) = AnalEnv -> Bool -> DmdType -> Var -> (DmdType, Demand) findBndrDmd AnalEnv env Bool arg_of_dfun DmdType dmd_ty Var 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". Note [Lambda-bound unfoldings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We allow a lambda-bound variable to carry an unfolding, a facility that is used exclusively for join points; see Note [Case binders and join points]. If so, we must be careful to demand-analyse the RHS of the unfolding! Example \x. \y{=Just x}. <body> Then if <body> uses 'y', then transitively it uses 'x', and we must not forget that fact, otherwise we might make 'x' absent when it isn't. ************************************************************************ * * \subsection{Strictness signatures} * * ************************************************************************ -} type DFunFlag = Bool -- indicates if the lambda being considered is in the -- sequence of lambdas at the top of the RHS of a dfun notArgOfDfun :: DFunFlag notArgOfDfun :: Bool notArgOfDfun = Bool False data AnalEnv = AE { AnalEnv -> Bool ae_strict_dicts :: !Bool -- ^ Enable strict dict , 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 } -- 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 (StrictSig, TopLevelFlag) instance Outputable AnalEnv where ppr :: AnalEnv -> SDoc ppr AnalEnv env = String -> SDoc text String "AE" SDoc -> SDoc -> SDoc <+> SDoc -> SDoc braces ([SDoc] -> SDoc vcat [ String -> SDoc text String "ae_virgin =" SDoc -> SDoc -> SDoc <+> Bool -> SDoc forall a. Outputable a => a -> SDoc ppr (AnalEnv -> Bool ae_virgin AnalEnv env) , String -> SDoc text String "ae_strict_dicts =" SDoc -> SDoc -> SDoc <+> Bool -> SDoc forall a. Outputable a => a -> SDoc ppr (AnalEnv -> Bool ae_strict_dicts AnalEnv env) , String -> SDoc text String "ae_sigs =" SDoc -> SDoc -> SDoc <+> 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_strict_dicts :: Bool ae_strict_dicts = DmdAnalOpts -> Bool dmd_strict_dicts 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 } emptySigEnv :: SigEnv emptySigEnv :: SigEnv emptySigEnv = SigEnv forall a. VarEnv a emptyVarEnv -- | Extend an environment with the strictness IDs attached to the id extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Var] -> AnalEnv extendAnalEnvs TopLevelFlag top_lvl AnalEnv env [Var] vars = AnalEnv env { ae_sigs :: SigEnv ae_sigs = TopLevelFlag -> SigEnv -> [Var] -> SigEnv extendSigEnvs TopLevelFlag top_lvl (AnalEnv -> SigEnv ae_sigs AnalEnv env) [Var] vars } extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv extendSigEnvs :: TopLevelFlag -> SigEnv -> [Var] -> SigEnv extendSigEnvs TopLevelFlag top_lvl SigEnv sigs [Var] vars = SigEnv -> [(Var, (StrictSig, TopLevelFlag))] -> SigEnv forall a. VarEnv a -> [(Var, a)] -> VarEnv a extendVarEnvList SigEnv sigs [ (Var var, (Var -> StrictSig idStrictness Var var, TopLevelFlag top_lvl)) | Var var <- [Var] vars] extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv extendAnalEnv :: TopLevelFlag -> AnalEnv -> Var -> StrictSig -> AnalEnv extendAnalEnv TopLevelFlag top_lvl AnalEnv env Var var StrictSig sig = AnalEnv env { ae_sigs :: SigEnv ae_sigs = TopLevelFlag -> SigEnv -> Var -> StrictSig -> SigEnv extendSigEnv TopLevelFlag top_lvl (AnalEnv -> SigEnv ae_sigs AnalEnv env) Var var StrictSig sig } extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv extendSigEnv :: TopLevelFlag -> SigEnv -> Var -> StrictSig -> SigEnv extendSigEnv TopLevelFlag top_lvl SigEnv sigs Var var StrictSig sig = SigEnv -> Var -> (StrictSig, TopLevelFlag) -> SigEnv forall a. VarEnv a -> Var -> a -> VarEnv a extendVarEnv SigEnv sigs Var var (StrictSig sig, TopLevelFlag top_lvl) lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag) lookupSigEnv :: AnalEnv -> Var -> Maybe (StrictSig, TopLevelFlag) lookupSigEnv AnalEnv env Var id = SigEnv -> Var -> Maybe (StrictSig, TopLevelFlag) forall a. VarEnv a -> Var -> Maybe a lookupVarEnv (AnalEnv -> SigEnv ae_sigs AnalEnv env) Var id nonVirgin :: AnalEnv -> AnalEnv nonVirgin :: AnalEnv -> AnalEnv nonVirgin AnalEnv env = AnalEnv env { ae_virgin :: Bool ae_virgin = Bool False } findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Demand]) -- Return the demands on the Ids in the [Var] findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Demand]) findBndrsDmds AnalEnv env DmdType dmd_ty [Var] bndrs = DmdType -> [Var] -> (DmdType, [Demand]) go DmdType dmd_ty [Var] bndrs where go :: DmdType -> [Var] -> (DmdType, [Demand]) go DmdType dmd_ty [] = (DmdType dmd_ty, []) go DmdType dmd_ty (Var b:[Var] bs) | Var -> Bool isId Var b = let (DmdType dmd_ty1, [Demand] dmds) = DmdType -> [Var] -> (DmdType, [Demand]) go DmdType dmd_ty [Var] bs (DmdType dmd_ty2, Demand dmd) = AnalEnv -> Bool -> DmdType -> Var -> (DmdType, Demand) findBndrDmd AnalEnv env Bool False DmdType dmd_ty1 Var b in (DmdType dmd_ty2, Demand dmd Demand -> [Demand] -> [Demand] forall a. a -> [a] -> [a] : [Demand] dmds) | Bool otherwise = DmdType -> [Var] -> (DmdType, [Demand]) go DmdType dmd_ty [Var] bs findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand) -- See Note [Trimming a demand to a type] findBndrDmd :: AnalEnv -> Bool -> DmdType -> Var -> (DmdType, Demand) findBndrDmd AnalEnv env Bool arg_of_dfun DmdType dmd_ty Var id = -- pprTrace "findBndrDmd" (ppr id $$ ppr dmd_ty $$ ppr starting_dmd $$ ppr dmd') $ (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 -> Var -> (DmdType, Demand) peelFV DmdType dmd_ty Var id id_ty :: Type id_ty = Var -> Type idType Var id strictify :: Demand -> Demand strictify Demand dmd | AnalEnv -> Bool ae_strict_dicts AnalEnv env -- We never want to strictify a recursive let. At the moment -- annotateBndr is only call for non-recursive lets; if that -- changes, we need a RecFlag parameter and another guard here. , Bool -> Bool not Bool arg_of_dfun -- See Note [Do not strictify the argument dictionaries of a dfun] = 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 [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 (CM(..)) /can/ be relied upon, as the simplifier tends to be very careful about not duplicating actual function calls. Also see #11731. -}