{- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 \section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser} -} module GHC.Core.Opt.WorkWrap ( wwTopBinds ) where import GHC.Prelude import GHC.Driver.Session import GHC.Core import GHC.Core.Unfold.Make import GHC.Core.Utils ( exprType, exprIsHNF ) import GHC.Core.Type import GHC.Core.Opt.WorkWrap.Utils import GHC.Core.FamInstEnv import GHC.Core.SimpleOpt import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Unique.Supply import GHC.Types.Basic import GHC.Types.Demand import GHC.Types.Cpr import GHC.Types.SourceText import GHC.Types.Unique import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Monad import GHC.Utils.Trace import GHC.Unit.Types import GHC.Core.DataCon {- We take Core bindings whose binders have: \begin{enumerate} \item Strictness attached (by the front-end of the strictness analyser), and / or \item Constructed Product Result information attached by the CPR analysis pass. \end{enumerate} and we return some ``plain'' bindings which have been worker/wrapper-ified, meaning: \begin{enumerate} \item Functions have been split into workers and wrappers where appropriate. If a function has both strictness and CPR properties then only one worker/wrapper doing both transformations is produced; \item Binders' @IdInfos@ have been updated to reflect the existence of these workers/wrappers (this is where we get STRICTNESS and CPR pragma info for exported values). \end{enumerate} -} wwTopBinds :: Module -> DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram wwTopBinds :: Module -> DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram wwTopBinds Module this_mod DynFlags dflags FamInstEnvs fam_envs UniqSupply us CoreProgram top_binds = UniqSupply -> UniqSM CoreProgram -> CoreProgram forall a. UniqSupply -> UniqSM a -> a initUs_ UniqSupply us (UniqSM CoreProgram -> CoreProgram) -> UniqSM CoreProgram -> CoreProgram forall a b. (a -> b) -> a -> b $ do [CoreProgram] top_binds' <- (CoreBind -> UniqSM CoreProgram) -> CoreProgram -> UniqSM [CoreProgram] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b] mapM (WwOpts -> CoreBind -> UniqSM CoreProgram wwBind WwOpts ww_opts) CoreProgram top_binds CoreProgram -> UniqSM CoreProgram forall a. a -> UniqSM a forall (m :: * -> *) a. Monad m => a -> m a return ([CoreProgram] -> CoreProgram forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat [CoreProgram] top_binds') where ww_opts :: WwOpts ww_opts = Module -> DynFlags -> FamInstEnvs -> WwOpts initWwOpts Module this_mod DynFlags dflags FamInstEnvs fam_envs {- ************************************************************************ * * \subsection[wwBind-wwExpr]{@wwBind@ and @wwExpr@} * * ************************************************************************ @wwBind@ works on a binding, trying each \tr{(binder, expr)} pair in turn. Non-recursive case first, then recursive... -} wwBind :: WwOpts -> CoreBind -> UniqSM [CoreBind] -- returns a WwBinding intermediate form; -- the caller will convert to Expr/Binding, -- as appropriate. wwBind :: WwOpts -> CoreBind -> UniqSM CoreProgram wwBind WwOpts ww_opts (NonRec Var binder CoreExpr rhs) = do CoreExpr new_rhs <- WwOpts -> CoreExpr -> UniqSM CoreExpr wwExpr WwOpts ww_opts CoreExpr rhs [(Var, CoreExpr)] new_pairs <- WwOpts -> RecFlag -> Var -> CoreExpr -> UniqSM [(Var, CoreExpr)] tryWW WwOpts ww_opts RecFlag NonRecursive Var binder CoreExpr new_rhs CoreProgram -> UniqSM CoreProgram forall a. a -> UniqSM a forall (m :: * -> *) a. Monad m => a -> m a return [Var -> CoreExpr -> CoreBind forall b. b -> Expr b -> Bind b NonRec Var b CoreExpr e | (Var b,CoreExpr e) <- [(Var, CoreExpr)] new_pairs] -- Generated bindings must be non-recursive -- because the original binding was. wwBind WwOpts ww_opts (Rec [(Var, CoreExpr)] pairs) = CoreBind -> CoreProgram forall a. a -> [a] forall (m :: * -> *) a. Monad m => a -> m a return (CoreBind -> CoreProgram) -> ([(Var, CoreExpr)] -> CoreBind) -> [(Var, CoreExpr)] -> CoreProgram forall b c a. (b -> c) -> (a -> b) -> a -> c . [(Var, CoreExpr)] -> CoreBind forall b. [(b, Expr b)] -> Bind b Rec ([(Var, CoreExpr)] -> CoreProgram) -> UniqSM [(Var, CoreExpr)] -> UniqSM CoreProgram forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ((Var, CoreExpr) -> UniqSM [(Var, CoreExpr)]) -> [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)] forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b] concatMapM (Var, CoreExpr) -> UniqSM [(Var, CoreExpr)] do_one [(Var, CoreExpr)] pairs where do_one :: (Var, CoreExpr) -> UniqSM [(Var, CoreExpr)] do_one (Var binder, CoreExpr rhs) = do CoreExpr new_rhs <- WwOpts -> CoreExpr -> UniqSM CoreExpr wwExpr WwOpts ww_opts CoreExpr rhs WwOpts -> RecFlag -> Var -> CoreExpr -> UniqSM [(Var, CoreExpr)] tryWW WwOpts ww_opts RecFlag Recursive Var binder CoreExpr new_rhs {- @wwExpr@ basically just walks the tree, looking for appropriate annotations that can be used. Remember it is @wwBind@ that does the matching by looking for strict arguments of the correct type. @wwExpr@ is a version that just returns the ``Plain'' Tree. -} wwExpr :: WwOpts -> CoreExpr -> UniqSM CoreExpr wwExpr :: WwOpts -> CoreExpr -> UniqSM CoreExpr wwExpr WwOpts _ e :: CoreExpr e@(Type {}) = CoreExpr -> UniqSM CoreExpr forall a. a -> UniqSM a forall (m :: * -> *) a. Monad m => a -> m a return CoreExpr e wwExpr WwOpts _ e :: CoreExpr e@(Coercion {}) = CoreExpr -> UniqSM CoreExpr forall a. a -> UniqSM a forall (m :: * -> *) a. Monad m => a -> m a return CoreExpr e wwExpr WwOpts _ e :: CoreExpr e@(Lit {}) = CoreExpr -> UniqSM CoreExpr forall a. a -> UniqSM a forall (m :: * -> *) a. Monad m => a -> m a return CoreExpr e wwExpr WwOpts _ e :: CoreExpr e@(Var {}) = CoreExpr -> UniqSM CoreExpr forall a. a -> UniqSM a forall (m :: * -> *) a. Monad m => a -> m a return CoreExpr e wwExpr WwOpts ww_opts (Lam Var binder CoreExpr expr) = Var -> CoreExpr -> CoreExpr forall b. b -> Expr b -> Expr b Lam Var new_binder (CoreExpr -> CoreExpr) -> UniqSM CoreExpr -> UniqSM CoreExpr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> WwOpts -> CoreExpr -> UniqSM CoreExpr wwExpr WwOpts ww_opts CoreExpr expr where new_binder :: Var new_binder | Var -> Bool isId Var binder = Var -> Var zapIdUsedOnceInfo Var binder | Bool otherwise = Var binder -- See Note [Zapping Used Once info in WorkWrap] wwExpr WwOpts ww_opts (App CoreExpr f CoreExpr a) = CoreExpr -> CoreExpr -> CoreExpr forall b. Expr b -> Expr b -> Expr b App (CoreExpr -> CoreExpr -> CoreExpr) -> UniqSM CoreExpr -> UniqSM (CoreExpr -> CoreExpr) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> WwOpts -> CoreExpr -> UniqSM CoreExpr wwExpr WwOpts ww_opts CoreExpr f UniqSM (CoreExpr -> CoreExpr) -> UniqSM CoreExpr -> UniqSM CoreExpr forall a b. UniqSM (a -> b) -> UniqSM a -> UniqSM b forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> WwOpts -> CoreExpr -> UniqSM CoreExpr wwExpr WwOpts ww_opts CoreExpr a wwExpr WwOpts ww_opts (Tick CoreTickish note CoreExpr expr) = CoreTickish -> CoreExpr -> CoreExpr forall b. CoreTickish -> Expr b -> Expr b Tick CoreTickish note (CoreExpr -> CoreExpr) -> UniqSM CoreExpr -> UniqSM CoreExpr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> WwOpts -> CoreExpr -> UniqSM CoreExpr wwExpr WwOpts ww_opts CoreExpr expr wwExpr WwOpts ww_opts (Cast CoreExpr expr CoercionR co) = do CoreExpr new_expr <- WwOpts -> CoreExpr -> UniqSM CoreExpr wwExpr WwOpts ww_opts CoreExpr expr CoreExpr -> UniqSM CoreExpr forall a. a -> UniqSM a forall (m :: * -> *) a. Monad m => a -> m a return (CoreExpr -> CoercionR -> CoreExpr forall b. Expr b -> CoercionR -> Expr b Cast CoreExpr new_expr CoercionR co) wwExpr WwOpts ww_opts (Let CoreBind bind CoreExpr expr) = CoreProgram -> CoreExpr -> CoreExpr forall b. [Bind b] -> Expr b -> Expr b mkLets (CoreProgram -> CoreExpr -> CoreExpr) -> UniqSM CoreProgram -> UniqSM (CoreExpr -> CoreExpr) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> WwOpts -> CoreBind -> UniqSM CoreProgram wwBind WwOpts ww_opts CoreBind bind UniqSM (CoreExpr -> CoreExpr) -> UniqSM CoreExpr -> UniqSM CoreExpr forall a b. UniqSM (a -> b) -> UniqSM a -> UniqSM b forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> WwOpts -> CoreExpr -> UniqSM CoreExpr wwExpr WwOpts ww_opts CoreExpr expr wwExpr WwOpts ww_opts (Case CoreExpr expr Var binder Type ty [Alt Var] alts) = do CoreExpr new_expr <- WwOpts -> CoreExpr -> UniqSM CoreExpr wwExpr WwOpts ww_opts CoreExpr expr [Alt Var] new_alts <- (Alt Var -> UniqSM (Alt Var)) -> [Alt Var] -> UniqSM [Alt Var] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b] mapM Alt Var -> UniqSM (Alt Var) ww_alt [Alt Var] alts let new_binder :: Var new_binder = Var -> Var zapIdUsedOnceInfo Var binder -- See Note [Zapping Used Once info in WorkWrap] CoreExpr -> UniqSM CoreExpr forall a. a -> UniqSM a forall (m :: * -> *) a. Monad m => a -> m a return (CoreExpr -> Var -> Type -> [Alt Var] -> CoreExpr forall b. Expr b -> b -> Type -> [Alt b] -> Expr b Case CoreExpr new_expr Var new_binder Type ty [Alt Var] new_alts) where ww_alt :: Alt Var -> UniqSM (Alt Var) ww_alt (Alt AltCon con [Var] binders CoreExpr rhs) = do CoreExpr new_rhs <- WwOpts -> CoreExpr -> UniqSM CoreExpr wwExpr WwOpts ww_opts CoreExpr rhs let new_binders :: [Var] new_binders = [ if Var -> Bool isId Var b then Var -> Var zapIdUsedOnceInfo Var b else Var b | Var b <- [Var] binders ] -- See Note [Zapping Used Once info in WorkWrap] Alt Var -> UniqSM (Alt Var) forall a. a -> UniqSM a forall (m :: * -> *) a. Monad m => a -> m a return (AltCon -> [Var] -> CoreExpr -> Alt Var forall b. AltCon -> [b] -> Expr b -> Alt b Alt AltCon con [Var] new_binders CoreExpr new_rhs) {- ************************************************************************ * * \subsection[tryWW]{@tryWW@: attempt a worker/wrapper pair} * * ************************************************************************ @tryWW@ just accumulates arguments, converts strictness info from the front-end into the proper form, then calls @mkWwBodies@ to do the business. The only reason this is monadised is for the unique supply. Note [Don't w/w INLINE things] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's very important to refrain from w/w-ing an INLINE function (ie one with a stable unfolding) because the wrapper will then overwrite the old stable unfolding with the wrapper code. Furthermore, if the programmer has marked something as INLINE, we may lose by w/w'ing it. If the strictness analyser is run twice, this test also prevents wrappers (which are INLINEd) from being re-done. (You can end up with several liked-named Ids bouncing around at the same time---absolute mischief.) Notice that we refrain from w/w'ing an INLINE function even if it is in a recursive group. It might not be the loop breaker. (We could test for loop-breaker-hood, but I'm not sure that ever matters.) Note [Worker/wrapper for INLINABLE functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have {-# INLINABLE f #-} f :: Ord a => [a] -> Int -> a f x y = ....f.... where f is strict in y, we might get a more efficient loop by w/w'ing f. But that would make a new unfolding which would overwrite the old one! So the function would no longer be INLINABLE, and in particular will not be specialised at call sites in other modules. This comes up in practice (#6056). Solution: do the w/w for strictness analysis, but transfer the Stable unfolding to the *worker*. So we will get something like this: {-# INLINE[2] f #-} f :: Ord a => [a] -> Int -> a f d x y = case y of I# y' -> fw d x y' {-# INLINABLE[2] fw #-} fw :: Ord a => [a] -> Int# -> a fw d x y' = let y = I# y' in ...f... How do we "transfer the unfolding"? Easy: by using the old one, wrapped in work_fn! See GHC.Core.Unfold.Make.mkWorkerUnfolding. Note [No worker/wrapper for record selectors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We sometimes generate a lot of record selectors, and generally the don't benefit from worker/wrapper. Yes, mkWwBodies would find a w/w split, but it is then suppressed by the certainlyWillInline test in splitFun. The wasted effort in mkWwBodies makes a measurable difference in compile time (see MR !2873), so although it's a terribly ad-hoc test, we just check here for record selectors, and do a no-op in that case. I did look for a generalisation, so that it's not just record selectors that benefit. But you'd need a cheap test for "this function will definitely get a w/w split" and that's hard to predict in advance...the logic in mkWwBodies is complex. So I've left the super-simple test, with this Note to explain. NB: record selectors are ordinary functions, inlined iff GHC wants to, so won't be caught by the preceding isInlineUnfolding test in tryWW. Note [Worker/wrapper for NOINLINE functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used to disable worker/wrapper for NOINLINE things, but it turns out this can cause unnecessary reboxing of values. Consider {-# NOINLINE f #-} f :: Int -> a f x = error (show x) g :: Bool -> Bool -> Int -> Int g True True p = f p g False True p = p + 1 g b False p = g b True p the strictness analysis will discover f and g are strict, but because f has no wrapper, the worker for g will rebox p. So we get $wg x y p# = let p = I# p# in -- Yikes! Reboxing! case x of False -> case y of False -> $wg False True p# True -> +# p# 1# True -> case y of False -> $wg True True p# True -> case f p of { } g x y p = case p of (I# p#) -> $wg x y p# Now, in this case the reboxing will float into the True branch, and so the allocation will only happen on the error path. But it won't float inwards if there are multiple branches that call (f p), so the reboxing will happen on every call of g. Disaster. Solution: do worker/wrapper even on NOINLINE things; but move the NOINLINE pragma to the worker. (See #13143 for a real-world example.) It is crucial that we do this for *all* NOINLINE functions. #10069 demonstrates what happens when we promise to w/w a (NOINLINE) leaf function, but fail to deliver: data C = C Int# Int# {-# NOINLINE c1 #-} c1 :: C -> Int# c1 (C _ n) = n {-# NOINLINE fc #-} fc :: C -> Int# fc c = 2 *# c1 c Failing to w/w `c1`, but still w/wing `fc` leads to the following code: c1 :: C -> Int# c1 (C _ n) = n $wfc :: Int# -> Int# $wfc n = let c = C 0# n in 2 #* c1 c fc :: C -> Int# fc (C _ n) = $wfc n Yikes! The reboxed `C` in `$wfc` can't cancel out, so we are in a bad place. This generalises to any function that derives its strictness signature from its callees, so we have to make sure that when a function announces particular strictness properties, we have to w/w them accordingly, even if it means splitting a NOINLINE function. Note [Worker activation] ~~~~~~~~~~~~~~~~~~~~~~~~ Follows on from Note [Worker/wrapper for INLINABLE functions] It is *vital* that if the worker gets an INLINABLE pragma (from the original function), then the worker has the same phase activation as the wrapper (or later). That is necessary to allow the wrapper to inline into the worker's unfolding: see GHC.Core.Opt.Simplify.Utils Note [Simplifying inside stable unfoldings]. If the original is NOINLINE, it's important that the worker inherits the original activation. Consider {-# NOINLINE expensive #-} expensive x = x + 1 f y = let z = expensive y in ... If expensive's worker inherits the wrapper's activation, we'll get this (because of the compromise in point (2) of Note [Wrapper activation]) {-# NOINLINE[Final] $wexpensive #-} $wexpensive x = x + 1 {-# INLINE[Final] expensive #-} expensive x = $wexpensive x f y = let z = expensive y in ... and $wexpensive will be immediately inlined into expensive, followed by expensive into f. This effectively removes the original NOINLINE! Otherwise, nothing is lost by giving the worker the same activation as the wrapper, because the worker won't have any chance of inlining until the wrapper does; there's no point in giving it an earlier activation. Note [Don't w/w inline small non-loop-breaker things] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In general, we refrain from w/w-ing *small* functions, which are not loop breakers, because they'll inline anyway. But we must take care: it may look small now, but get to be big later after other inlining has happened. So we take the precaution of adding a StableUnfolding for any such functions. I made this change when I observed a big function at the end of compilation with a useful strictness signature but no w-w. (It was small during demand analysis, we refrained from w/w, and then got big when something was inlined in its rhs.) When I measured it on nofib, it didn't make much difference; just a few percent improved allocation on one benchmark (bspt/Euclid.space). But nothing got worse. There is an infelicity though. We may get something like f = g val ==> g x = case gw x of r -> I# r f {- InlineStable, Template = g val -} f = case gw x of r -> I# r The code for f duplicates that for g, without any real benefit. It won't really be executed, because calls to f will go via the inlining. Note [Don't w/w join points for CPR] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There's no point in exploiting CPR info on a join point. If the whole function is getting CPR'd, then the case expression around the worker function will get pushed into the join point by the simplifier, which will have the same effect that w/w'ing for CPR would have - the result will be returned in an unboxed tuple. f z = let join j x y = (x+1, y+1) in case z of A -> j 1 2 B -> j 2 3 => f z = case $wf z of (# a, b #) -> (a, b) $wf z = case (let join j x y = (x+1, y+1) in case z of A -> j 1 2 B -> j 2 3) of (a, b) -> (# a, b #) => f z = case $wf z of (# a, b #) -> (a, b) $wf z = let join j x y = (# x+1, y+1 #) in case z of A -> j 1 2 B -> j 2 3 Note that we still want to give `j` the CPR property, so that `f` has it. So CPR *analyse* join points as regular functions, but don't *transform* them. We could retain the CPR /signature/ on the worker after W/W, but it would become outright wrong if the Simplifier pushes a non-trivial continuation into it. For example: case (let $j x = (x,x) in ...) of alts ==> let $j x = case (x,x) of alts in case ... of alts Before pushing the case in, `$j` has the CPR property, but not afterwards. So we simply zap the CPR signature for join pints as part of the W/W pass. The signature served its purpose during CPR analysis in propagating the CPR property of `$j`. Doing W/W for returned products on a join point would be tricky anyway, as the worker could not be a join point because it would not be tail-called. However, doing the *argument* part of W/W still works for join points, since the wrapper body will make a tail call: f z = let join j x y = x + y in ... => f z = let join $wj x# y# = x# +# y# j x y = case x of I# x# -> case y of I# y# -> $wj x# y# in ... Note [Wrapper activation] ~~~~~~~~~~~~~~~~~~~~~~~~~ When should the wrapper inlining be active? 1. It must not be active earlier than the current Activation of the Id, because we must give rewrite rules mentioning the wrapper and specialisation a chance to fire. See Note [Worker/wrapper for INLINABLE functions] and Note [Worker activation] 2. It should be active at some point, despite (1) because of Note [Worker/wrapper for NOINLINE functions] 3. For ordinary functions with no pragmas we want to inline the wrapper as early as possible (#15056). Suppose another module defines f !x xs = ... foldr k z xs ... and suppose we have the usual foldr/build RULE. Then if we have a call `f x [1..x]`, we'd expect to inline f and the RULE will fire. But if f is w/w'd (which it might be), we want the inlining to occur just as if it hadn't been. (This only matters if f's RHS is big enough to w/w, but small enough to inline given the call site, but that can happen.) 4. We do not want to inline the wrapper before specialisation. module Foo where f :: Num a => a -> Int -> a f n 0 = n -- Strict in the Int, hence wrapper f n x = f (n+n) (x-1) g :: Int -> Int g x = f x x -- Provokes a specialisation for f module Bar where import Foo h :: Int -> Int h x = f 3 x In module Bar we want to give specialisations a chance to fire before inlining f's wrapper. (Historical note: At one stage I tried making the wrapper inlining always-active, and that had a very bad effect on nofib/imaginary/x2n1; a wrapper was inlined before the specialisation fired.) 4a. If we have {-# SPECIALISE foo :: (Int,Int) -> Bool -> Int #-} {-# NOINLINE [n] foo #-} then specialisation will generate a SPEC rule active from Phase n. See Note [Auto-specialisation and RULES] in GHC.Core.Opt.Specialise This SPEC specialisation rule will compete with inlining, but we don't mind that, because if inlining succeeds, it should be better. Now, if we w/w foo, we must ensure that the wrapper (which is very keen to inline) has a phase /after/ 'n', else it'll always "win" over the SPEC rule -- disaster (#20709). Conclusion: the activation for the wrapper should be the /later/ of (a) the current activation of the function, or FinalPhase if it is NOINLINE (b) one phase /after/ the activation of any rules This is implemented by mkStrWrapperInlinePrag. Reminder: Note [Don't w/w INLINE things], so we don't need to worry about INLINE things here. What if `foo` has no specialiations, is worker/wrappered (with the wrapper inlining very early), and exported; and then in an importing module we have {-# SPECIALISE foo : ... #-}? Well then, we'll specialise foo's wrapper, which will expose a specialisation for foo's worker, which we will do too. That seems fine. (To work reliably, `foo` would need an INLINABLE pragma, in which case we don't unpack dictionaries for the worker; see see Note [Do not unbox class dictionaries].) Note [Wrapper NoUserInlinePrag] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We use NoUserInlinePrag on the wrapper, to say that there is no user-specified inline pragma. (The worker inherits that; see Note [Worker/wrapper for INLINABLE functions].) The wrapper has no pragma given by the user. (Historical note: we used to give the wrapper an INLINE pragma, but CSE will not happen if there is a user-specified pragma, but should happen for w/w’ed things (#14186). We don't need a pragma, because everything we needs is expressed by (a) the stable unfolding and (b) the inl_act activation.) Note [Drop absent bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider (#19824): let t = ...big... in ...(f t x)... were `f` ignores its first argument. With luck f's wrapper will inline thereby dropping `t`, but maybe not: the arguments to f all look boring. So we pre-empt the problem by replacing t's RHS with an absent filler. Simple and effective. -} tryWW :: WwOpts -> RecFlag -> Id -- The fn binder -> CoreExpr -- The bound rhs; its innards -- are already ww'd -> UniqSM [(Id, CoreExpr)] -- either *one* or *two* pairs; -- if one, then no worker (only -- the orig "wrapper" lives on); -- if two, then a worker and a -- wrapper. tryWW :: WwOpts -> RecFlag -> Var -> CoreExpr -> UniqSM [(Var, CoreExpr)] tryWW WwOpts ww_opts RecFlag is_rec Var fn_id CoreExpr rhs -- See Note [Drop absent bindings] | Demand -> Bool isAbsDmd (IdInfo -> Demand demandInfo IdInfo fn_info) , Bool -> Bool not (Var -> Bool isJoinId Var fn_id) , Just CoreExpr filler <- WwOpts -> Var -> StrictnessMark -> Maybe CoreExpr mkAbsentFiller WwOpts ww_opts Var fn_id StrictnessMark NotMarkedStrict = [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)] forall a. a -> UniqSM a forall (m :: * -> *) a. Monad m => a -> m a return [(Var new_fn_id, CoreExpr filler)] -- See Note [Don't w/w INLINE things] | IdInfo -> Bool hasInlineUnfolding IdInfo fn_info = [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)] forall a. a -> UniqSM a forall (m :: * -> *) a. Monad m => a -> m a return [(Var new_fn_id, CoreExpr rhs)] -- See Note [No worker/wrapper for record selectors] | Var -> Bool isRecordSelector Var fn_id = [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)] forall a. a -> UniqSM a forall (m :: * -> *) a. Monad m => a -> m a return [ (Var new_fn_id, CoreExpr rhs ) ] -- Don't w/w OPAQUE things -- See Note [OPAQUE pragma] -- -- Whilst this check might seem superfluous, since we strip boxity -- information in GHC.Core.Opt.DmdAnal.finaliseArgBoxities and -- CPR information in GHC.Core.Opt.CprAnal.cprAnalBind, it actually -- isn't. That is because we would still perform w/w when: -- -- - An argument is used strictly, and -fworker-wrapper-cbv is -- enabled, or, -- - When demand analysis marks an argument as absent. -- -- In a debug build we do assert that boxity and CPR information -- are actually stripped, since we want to prevent callers of OPAQUE -- things to do reboxing. See: -- - Note [The OPAQUE pragma and avoiding the reboxing of arguments] -- - Note [The OPAQUE pragma and avoiding the reboxing of results] | InlinePragma -> Bool isOpaquePragma (IdInfo -> InlinePragma inlinePragInfo IdInfo fn_info) = Bool -> SDoc -> UniqSM [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)] forall a. HasCallStack => Bool -> SDoc -> a -> a assertPpr (DmdSig -> Bool onlyBoxedArguments (IdInfo -> DmdSig dmdSigInfo IdInfo fn_info) Bool -> Bool -> Bool && CprSig -> Bool isTopCprSig (IdInfo -> CprSig cprSigInfo IdInfo fn_info)) (String -> SDoc text String "OPAQUE fun with boxity" SDoc -> SDoc -> SDoc $$ Var -> SDoc forall a. Outputable a => a -> SDoc ppr Var new_fn_id SDoc -> SDoc -> SDoc $$ DmdSig -> SDoc forall a. Outputable a => a -> SDoc ppr (IdInfo -> DmdSig dmdSigInfo IdInfo fn_info) SDoc -> SDoc -> SDoc $$ CprSig -> SDoc forall a. Outputable a => a -> SDoc ppr (IdInfo -> CprSig cprSigInfo IdInfo fn_info) SDoc -> SDoc -> SDoc $$ CoreExpr -> SDoc forall a. Outputable a => a -> SDoc ppr CoreExpr rhs) (UniqSM [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)]) -> UniqSM [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)] forall a b. (a -> b) -> a -> b $ [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)] forall a. a -> UniqSM a forall (m :: * -> *) a. Monad m => a -> m a return [ (Var new_fn_id, CoreExpr rhs) ] -- Do this even if there is a NOINLINE pragma -- See Note [Worker/wrapper for NOINLINE functions] | Bool is_fun = WwOpts -> Var -> CoreExpr -> UniqSM [(Var, CoreExpr)] splitFun WwOpts ww_opts Var new_fn_id CoreExpr rhs -- See Note [Thunk splitting] | RecFlag -> Bool isNonRec RecFlag is_rec, Bool is_thunk = WwOpts -> RecFlag -> Var -> CoreExpr -> UniqSM [(Var, CoreExpr)] splitThunk WwOpts ww_opts RecFlag is_rec Var new_fn_id CoreExpr rhs | Bool otherwise = [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)] forall a. a -> UniqSM a forall (m :: * -> *) a. Monad m => a -> m a return [ (Var new_fn_id, CoreExpr rhs) ] where fn_info :: IdInfo fn_info = (() :: Constraint) => Var -> IdInfo Var -> IdInfo idInfo Var fn_id ([Demand] wrap_dmds, Divergence _) = DmdSig -> ([Demand], Divergence) splitDmdSig (IdInfo -> DmdSig dmdSigInfo IdInfo fn_info) new_fn_id :: Var new_fn_id = Var -> Var zap_join_cpr (Var -> Var) -> Var -> Var forall a b. (a -> b) -> a -> b $ Var -> Var zap_usage Var fn_id zap_usage :: Var -> Var zap_usage = Var -> Var zapIdUsedOnceInfo (Var -> Var) -> (Var -> Var) -> Var -> Var forall b c a. (b -> c) -> (a -> b) -> a -> c . Var -> Var zapIdUsageEnvInfo -- See Note [Zapping DmdEnv after Demand Analyzer] and -- See Note [Zapping Used Once info in WorkWrap] zap_join_cpr :: Var -> Var zap_join_cpr Var id | Var -> Bool isJoinId Var id = Var id Var -> CprSig -> Var `setIdCprSig` CprSig topCprSig | Bool otherwise = Var id -- See Note [Don't w/w join points for CPR] is_fun :: Bool is_fun = [Demand] -> Bool forall (f :: * -> *) a. Foldable f => f a -> Bool notNull [Demand] wrap_dmds Bool -> Bool -> Bool || Var -> Bool isJoinId Var fn_id is_thunk :: Bool is_thunk = Bool -> Bool not Bool is_fun Bool -> Bool -> Bool && Bool -> Bool not (CoreExpr -> Bool exprIsHNF CoreExpr rhs) Bool -> Bool -> Bool && Bool -> Bool not (Var -> Bool isJoinId Var fn_id) Bool -> Bool -> Bool && Bool -> Bool not ((() :: Constraint) => Type -> Bool Type -> Bool isUnliftedType (Var -> Type idType Var fn_id)) {- Note [Zapping DmdEnv after Demand Analyzer] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In the worker-wrapper pass we zap the DmdEnv. Why? (a) it is never used again (b) it wastes space (c) it becomes incorrect as things are cloned, because we don't push the substitution into it Why here? * Because we don’t want to do it in the Demand Analyzer, as we never know there when we are doing the last pass. * We want them to be still there at the end of DmdAnal, so that -ddump-str-anal contains them. * We don’t want a second pass just for that. * WorkWrap looks at all bindings anyway. We also need to do it in TidyCore.tidyLetBndr to clean up after the final, worker/wrapper-less run of the demand analyser (see Note [Final Demand Analyser run] in GHC.Core.Opt.DmdAnal). Note [Zapping Used Once info in WorkWrap] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ During the work/wrap pass, using zapIdUsedOnceInfo, we zap the "used once" info * on every binder (let binders, case binders, lambda binders) * in both demands and in strictness signatures * recursively Why? * The simplifier may happen to transform code in a way that invalidates the data (see #11731 for an example). * It is not used in later passes, up to code generation. At first it's hard to see how the simplifier might invalidate it (and indeed for a while I thought it couldn't: #19482), but it's not quite as simple as I thought. Consider this: {-# STRICTNESS SIG <SP(M,A)> #-} f p = let v = case p of (a,b) -> a in p `seq` (v,v) I think we'll give `f` the strictness signature `<SP(M,A)>`, where the `M` sayd that we'll evaluate the first component of the pair at most once. Why? Because the RHS of the thunk `v` is evaluated at most once. But now let's worker/wrapper f: {-# STRICTNESS SIG <M> #-} $wf p1 = let p2 = absentError "urk" in let p = (p1,p2) in let v = case p of (a,b) -> a in p `seq` (v,v) where I've gotten the demand on `p1` by decomposing the P(M,A) argument demand. This rapidly simplifies to {-# STRICTNESS SIG <M> #-} $wf p1 = let v = p1 in (v,v) and thence to `(p1,p1)` by inlining the trivial let. Now the demand on `p1` should not be at most once!! Conclusion: used-once info is fragile to simplification, because of the non-monotonic behaviour of let's, which turn used-many into used-once. So indeed we should zap this info in worker/wrapper. Conclusion: kill it during worker/wrapper, using `zapUsedOnceInfo`. Both the *demand signature* of the binder, and the *demand-info* of the binder. Moreover, do so recursively. You might wonder: why do we generate used-once info if we then throw it away. The main reason is that we do a final run of the demand analyser, immediately before CoreTidy, which is /not/ followed by worker/wrapper; it is there only to generate used-once info for single-entry thunks. Note [Don't eta expand in w/w] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A binding where the manifestArity of the RHS is less than idArity of the binder means GHC.Core.Opt.Arity didn't eta expand that binding. When this happens, it does so for a reason (see Note [exprArity invariant] in GHC.Core.Opt.Arity) and we probably have a PAP, cast or trivial expression as RHS. Below is a historical account of what happened when w/w still did eta expansion. Nowadays, it doesn't do that, but will simply w/w for the wrong arity, unleashing a demand signature meant for e.g. 2 args to be unleashed for e.g. 1 arg (manifest arity). That's at least as terrible as doing eta expansion, so don't do it. --- When worker/wrapper did eta expansion, it implictly eta expanded the binding to idArity, overriding GHC.Core.Opt.Arity's decision. Other than playing fast and loose with divergence, it's also broken for newtypes: f = (\xy.blah) |> co where co :: (Int -> Int -> Char) ~ T Then idArity is 2 (despite the type T), and it can have a DmdSig based on a threshold of 2. But we can't w/w it without a type error. The situation is less grave for PAPs, but the implicit eta expansion caused a compiler allocation regression in T15164, where huge recursive instance method groups, mostly consisting of PAPs, got w/w'd. This caused great churn in the simplifier, when simply waiting for the PAPs to inline arrived at the same output program. Note there is the worry here that such PAPs and trivial RHSs might not *always* be inlined. That would lead to reboxing, because the analysis tacitly assumes that we W/W'd for idArity and will propagate analysis information under that assumption. So far, this doesn't seem to matter in practice. See https://gitlab.haskell.org/ghc/ghc/merge_requests/312#note_192064. Note [Inline pragma for certainlyWillInline] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this (#19824 comment on 15 May 21): f _ (x,y) = ...big... v = ...big... g x = f v x + 1 So `f` will generate a worker/wrapper split; and `g` (since it is small) will trigger the certainlyWillInline case of splitFun. The danger is that we end up with g {- StableUnfolding = \x -> f v x + 1 -} = ...blah... Since (a) that unfolding for g is AlwaysActive (b) the unfolding for f's wrapper is ActiveAfterInitial the call of f will never inline in g's stable unfolding, thereby keeping `v` alive. I thought of changing g's unfolding to be ActiveAfterInitial, but that too is bad: it delays g's inlining into other modules, which makes fewer specialisations happen. Example in perf/should_run/DeriveNull. So I decided to live with the problem. In fact v's RHS will be replaced by LitRubbish (see Note [Drop absent bindings]) so there is no great harm. -} --------------------- splitFun :: WwOpts -> Id -> CoreExpr -> UniqSM [(Id, CoreExpr)] splitFun :: WwOpts -> Var -> CoreExpr -> UniqSM [(Var, CoreExpr)] splitFun WwOpts ww_opts Var fn_id CoreExpr rhs | Bool -> Bool not ([Demand] wrap_dmds [Demand] -> Arity -> Bool forall a. [a] -> Arity -> Bool `lengthIs` (Var -> Bool) -> [Var] -> Arity forall a. (a -> Bool) -> [a] -> Arity count Var -> Bool isId [Var] arg_vars) -- See Note [Don't eta expand in w/w] = [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)] forall a. a -> UniqSM a forall (m :: * -> *) a. Monad m => a -> m a return [(Var fn_id, CoreExpr rhs)] | Bool otherwise = Bool -> String -> SDoc -> UniqSM [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)] forall a. HasCallStack => Bool -> String -> SDoc -> a -> a warnPprTrace (Bool -> Bool not ([Demand] wrap_dmds [Demand] -> Arity -> Bool forall a. [a] -> Arity -> Bool `lengthIs` (IdInfo -> Arity arityInfo IdInfo fn_info))) String "splitFun" (Var -> SDoc forall a. Outputable a => a -> SDoc ppr Var fn_id SDoc -> SDoc -> SDoc <+> ([Demand] -> SDoc forall a. Outputable a => a -> SDoc ppr [Demand] wrap_dmds SDoc -> SDoc -> SDoc $$ Cpr -> SDoc forall a. Outputable a => a -> SDoc ppr Cpr cpr)) (UniqSM [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)]) -> UniqSM [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)] forall a b. (a -> b) -> a -> b $ do { Maybe WwResult mb_stuff <- WwOpts -> Var -> [Var] -> Type -> [Demand] -> Cpr -> UniqSM (Maybe WwResult) mkWwBodies WwOpts ww_opts Var fn_id [Var] arg_vars ((() :: Constraint) => CoreExpr -> Type CoreExpr -> Type exprType CoreExpr body) [Demand] wrap_dmds Cpr cpr ; case Maybe WwResult mb_stuff of Maybe WwResult Nothing -> -- No useful wrapper; leave the binding alone [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)] forall a. a -> UniqSM a forall (m :: * -> *) a. Monad m => a -> m a return [(Var fn_id, CoreExpr rhs)] Just WwResult stuff | let opt_wwd_rhs :: CoreExpr opt_wwd_rhs = (() :: Constraint) => SimpleOpts -> CoreExpr -> CoreExpr SimpleOpts -> CoreExpr -> CoreExpr simpleOptExpr (WwOpts -> SimpleOpts wo_simple_opts WwOpts ww_opts) CoreExpr rhs -- We need to stabilise the WW'd (and optimised) RHS below , Just Unfolding stable_unf <- UnfoldingOpts -> IdInfo -> CoreExpr -> Maybe Unfolding certainlyWillInline UnfoldingOpts uf_opts IdInfo fn_info CoreExpr opt_wwd_rhs -- We could make a w/w split, but in fact the RHS is small -- See Note [Don't w/w inline small non-loop-breaker things] , let id_w_unf :: Var id_w_unf = Var fn_id Var -> Unfolding -> Var `setIdUnfolding` Unfolding stable_unf -- See Note [Inline pragma for certainlyWillInline] -> [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)] forall a. a -> UniqSM a forall (m :: * -> *) a. Monad m => a -> m a return [ (Var id_w_unf, CoreExpr rhs) ] | Bool otherwise -> do { Unique work_uniq <- UniqSM Unique forall (m :: * -> *). MonadUnique m => m Unique getUniqueM ; [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)] forall a. a -> UniqSM a forall (m :: * -> *) a. Monad m => a -> m a return (WwOpts -> Var -> IdInfo -> [Var] -> CoreExpr -> Unique -> Divergence -> WwResult -> [(Var, CoreExpr)] mkWWBindPair WwOpts ww_opts Var fn_id IdInfo fn_info [Var] arg_vars CoreExpr body Unique work_uniq Divergence div WwResult stuff) } } where uf_opts :: UnfoldingOpts uf_opts = SimpleOpts -> UnfoldingOpts so_uf_opts (WwOpts -> SimpleOpts wo_simple_opts WwOpts ww_opts) fn_info :: IdInfo fn_info = (() :: Constraint) => Var -> IdInfo Var -> IdInfo idInfo Var fn_id ([Var] arg_vars, CoreExpr body) = CoreExpr -> ([Var], CoreExpr) forall b. Expr b -> ([b], Expr b) collectBinders CoreExpr rhs ([Demand] wrap_dmds, Divergence div) = DmdSig -> ([Demand], Divergence) splitDmdSig (IdInfo -> DmdSig dmdSigInfo IdInfo fn_info) cpr_ty :: CprType cpr_ty = CprSig -> CprType getCprSig (IdInfo -> CprSig cprSigInfo IdInfo fn_info) -- Arity of the CPR sig should match idArity when it's not a join point. -- See Note [Arity trimming for CPR signatures] in GHC.Core.Opt.CprAnal cpr :: Cpr cpr = Bool -> SDoc -> Cpr -> Cpr forall a. HasCallStack => Bool -> SDoc -> a -> a assertPpr (Var -> Bool isJoinId Var fn_id Bool -> Bool -> Bool || CprType cpr_ty CprType -> CprType -> Bool forall a. Eq a => a -> a -> Bool == CprType topCprType Bool -> Bool -> Bool || CprType -> Arity ct_arty CprType cpr_ty Arity -> Arity -> Bool forall a. Eq a => a -> a -> Bool == IdInfo -> Arity arityInfo IdInfo fn_info) (Var -> SDoc forall a. Outputable a => a -> SDoc ppr Var fn_id SDoc -> SDoc -> SDoc <> SDoc colon SDoc -> SDoc -> SDoc <+> String -> SDoc text String "ct_arty:" SDoc -> SDoc -> SDoc <+> Arity -> SDoc int (CprType -> Arity ct_arty CprType cpr_ty) SDoc -> SDoc -> SDoc <+> String -> SDoc text String "arityInfo:" SDoc -> SDoc -> SDoc <+> Arity -> SDoc forall a. Outputable a => a -> SDoc ppr (IdInfo -> Arity arityInfo IdInfo fn_info)) (Cpr -> Cpr) -> Cpr -> Cpr forall a b. (a -> b) -> a -> b $ CprType -> Cpr ct_cpr CprType cpr_ty mkWWBindPair :: WwOpts -> Id -> IdInfo -> [Var] -> CoreExpr -> Unique -> Divergence -> ([Demand],JoinArity, Id -> CoreExpr, Expr CoreBndr -> CoreExpr) -> [(Id, CoreExpr)] mkWWBindPair :: WwOpts -> Var -> IdInfo -> [Var] -> CoreExpr -> Unique -> Divergence -> WwResult -> [(Var, CoreExpr)] mkWWBindPair WwOpts ww_opts Var fn_id IdInfo fn_info [Var] fn_args CoreExpr fn_body Unique work_uniq Divergence div ([Demand] work_demands, Arity join_arity, Var -> CoreExpr wrap_fn, CoreExpr -> CoreExpr work_fn) = -- pprTrace "mkWWBindPair" (ppr fn_id <+> ppr wrap_id <+> ppr work_id $$ ppr wrap_rhs) $ [(Var work_id, CoreExpr work_rhs), (Var wrap_id, CoreExpr wrap_rhs)] -- Worker first, because wrapper mentions it where arity :: Arity arity = IdInfo -> Arity arityInfo IdInfo fn_info -- The arity is set by the simplifier using exprEtaExpandArity -- So it may be more than the number of top-level-visible lambdas simpl_opts :: SimpleOpts simpl_opts = WwOpts -> SimpleOpts wo_simple_opts WwOpts ww_opts work_rhs :: CoreExpr work_rhs = CoreExpr -> CoreExpr work_fn ([Var] -> CoreExpr -> CoreExpr forall b. [b] -> Expr b -> Expr b mkLams [Var] fn_args CoreExpr fn_body) work_act :: Activation work_act = case InlineSpec fn_inline_spec of -- See Note [Worker activation] NoInline SourceText _ -> InlinePragma -> Activation inl_act InlinePragma fn_inl_prag InlineSpec _ -> InlinePragma -> Activation inl_act InlinePragma wrap_prag work_prag :: InlinePragma work_prag = InlinePragma { inl_src :: SourceText inl_src = String -> SourceText SourceText String "{-# INLINE" , inl_inline :: InlineSpec inl_inline = InlineSpec fn_inline_spec , inl_sat :: Maybe Arity inl_sat = Maybe Arity forall a. Maybe a Nothing , inl_act :: Activation inl_act = Activation work_act , inl_rule :: RuleMatchInfo inl_rule = RuleMatchInfo FunLike } -- inl_inline: copy from fn_id; see Note [Worker/wrapper for INLINABLE functions] -- inl_act: see Note [Worker activation] -- inl_rule: it does not make sense for workers to be constructorlike. work_join_arity :: Maybe Arity work_join_arity | Var -> Bool isJoinId Var fn_id = Arity -> Maybe Arity forall a. a -> Maybe a Just Arity join_arity | Bool otherwise = Maybe Arity forall a. Maybe a Nothing -- worker is join point iff wrapper is join point -- (see Note [Don't w/w join points for CPR]) work_id :: Var work_id = Var -> Var asWorkerLikeId (Var -> Var) -> Var -> Var forall a b. (a -> b) -> a -> b $ Unique -> Var -> Type -> Var mkWorkerId Unique work_uniq Var fn_id ((() :: Constraint) => CoreExpr -> Type CoreExpr -> Type exprType CoreExpr work_rhs) Var -> OccInfo -> Var `setIdOccInfo` IdInfo -> OccInfo occInfo IdInfo fn_info -- Copy over occurrence info from parent -- Notably whether it's a loop breaker -- Doesn't matter much, since we will simplify next, but -- seems right-er to do so Var -> InlinePragma -> Var `setInlinePragma` InlinePragma work_prag Var -> Unfolding -> Var `setIdUnfolding` SimpleOpts -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding mkWorkerUnfolding SimpleOpts simpl_opts CoreExpr -> CoreExpr work_fn Unfolding fn_unfolding -- See Note [Worker/wrapper for INLINABLE functions] Var -> DmdSig -> Var `setIdDmdSig` [Demand] -> Divergence -> DmdSig mkClosedDmdSig [Demand] work_demands Divergence div -- Even though we may not be at top level, -- it's ok to give it an empty DmdEnv Var -> CprSig -> Var `setIdCprSig` CprSig topCprSig Var -> Demand -> Var `setIdDemandInfo` Demand worker_demand Var -> Arity -> Var `setIdArity` Arity work_arity -- Set the arity so that the Core Lint check that the -- arity is consistent with the demand type goes -- through Var -> Maybe Arity -> Var `asJoinId_maybe` Maybe Arity work_join_arity work_arity :: Arity work_arity = [Demand] -> Arity forall a. [a] -> Arity forall (t :: * -> *) a. Foldable t => t a -> Arity length [Demand] work_demands :: Int -- See Note [Demand on the worker] single_call :: Bool single_call = Arity -> Demand -> Bool saturatedByOneShots Arity arity (IdInfo -> Demand demandInfo IdInfo fn_info) worker_demand :: Demand worker_demand | Bool single_call = Arity -> Demand mkWorkerDemand Arity work_arity | Bool otherwise = Demand topDmd wrap_rhs :: CoreExpr wrap_rhs = Var -> CoreExpr wrap_fn Var work_id wrap_prag :: InlinePragma wrap_prag = InlinePragma -> [CoreRule] -> InlinePragma mkStrWrapperInlinePrag InlinePragma fn_inl_prag [CoreRule] fn_rules wrap_unf :: Unfolding wrap_unf = SimpleOpts -> CoreExpr -> Arity -> Unfolding mkWrapperUnfolding SimpleOpts simpl_opts CoreExpr wrap_rhs Arity arity wrap_id :: Var wrap_id = Var fn_id Var -> Unfolding -> Var `setIdUnfolding` Unfolding wrap_unf Var -> InlinePragma -> Var `setInlinePragma` InlinePragma wrap_prag Var -> OccInfo -> Var `setIdOccInfo` OccInfo noOccInfo -- Zap any loop-breaker-ness, to avoid bleating from Lint -- about a loop breaker with an INLINE rule fn_inl_prag :: InlinePragma fn_inl_prag = IdInfo -> InlinePragma inlinePragInfo IdInfo fn_info fn_inline_spec :: InlineSpec fn_inline_spec = InlinePragma -> InlineSpec inl_inline InlinePragma fn_inl_prag fn_unfolding :: Unfolding fn_unfolding = IdInfo -> Unfolding realUnfoldingInfo IdInfo fn_info fn_rules :: [CoreRule] fn_rules = RuleInfo -> [CoreRule] ruleInfoRules (IdInfo -> RuleInfo ruleInfo IdInfo fn_info) mkStrWrapperInlinePrag :: InlinePragma -> [CoreRule] -> InlinePragma -- See Note [Wrapper activation] mkStrWrapperInlinePrag :: InlinePragma -> [CoreRule] -> InlinePragma mkStrWrapperInlinePrag (InlinePragma { inl_act :: InlinePragma -> Activation inl_act = Activation act, inl_rule :: InlinePragma -> RuleMatchInfo inl_rule = RuleMatchInfo rule_info }) [CoreRule] rules = InlinePragma { inl_src :: SourceText inl_src = String -> SourceText SourceText String "{-# INLINE" , inl_inline :: InlineSpec inl_inline = InlineSpec NoUserInlinePrag -- See Note [Wrapper NoUserInlinePrag] , inl_sat :: Maybe Arity inl_sat = Maybe Arity forall a. Maybe a Nothing , inl_act :: Activation inl_act = CompilerPhase -> Activation activeAfter CompilerPhase wrapper_phase , inl_rule :: RuleMatchInfo inl_rule = RuleMatchInfo rule_info } -- RuleMatchInfo is (and must be) unaffected where -- See Note [Wrapper activation] wrapper_phase :: CompilerPhase wrapper_phase = (CoreRule -> CompilerPhase -> CompilerPhase) -> CompilerPhase -> [CoreRule] -> CompilerPhase forall a b. (a -> b -> b) -> b -> [a] -> b forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr (CompilerPhase -> CompilerPhase -> CompilerPhase laterPhase (CompilerPhase -> CompilerPhase -> CompilerPhase) -> (CoreRule -> CompilerPhase) -> CoreRule -> CompilerPhase -> CompilerPhase forall b c a. (b -> c) -> (a -> b) -> a -> c . CoreRule -> CompilerPhase get_rule_phase) CompilerPhase earliest_inline_phase [CoreRule] rules earliest_inline_phase :: CompilerPhase earliest_inline_phase = Activation -> CompilerPhase beginPhase Activation act CompilerPhase -> CompilerPhase -> CompilerPhase `laterPhase` CompilerPhase -> CompilerPhase nextPhase CompilerPhase InitialPhase -- laterPhase (nextPhase InitialPhase) is a temporary hack -- to inline no earlier than phase 2. I got regressions in -- 'mate', due to changes in full laziness due to Note [Case -- MFEs], when I did earlier inlining. get_rule_phase :: CoreRule -> CompilerPhase -- The phase /after/ the rule is first active get_rule_phase :: CoreRule -> CompilerPhase get_rule_phase CoreRule rule = CompilerPhase -> CompilerPhase nextPhase (Activation -> CompilerPhase beginPhase (CoreRule -> Activation ruleActivation CoreRule rule)) {- Note [Demand on the worker] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ If the original function is called once, according to its demand info, then so is the worker. This is important so that the occurrence analyser can attach OneShot annotations to the worker’s lambda binders. Example: -- Original function f [Demand=<L,1*C1(U)>] :: (a,a) -> a f = \p -> ... -- Wrapper f [Demand=<L,1*C1(U)>] :: a -> a -> a f = \p -> case p of (a,b) -> $wf a b -- Worker $wf [Demand=<L,1*C1(C1(U))>] :: Int -> Int $wf = \a b -> ... We need to check whether the original function is called once, with sufficiently many arguments. This is done using saturatedByOneShots, which takes the arity of the original function (resp. the wrapper) and the demand on the original function. The demand on the worker is then calculated using mkWorkerDemand, and always of the form [Demand=<L,1*(C1(...(C1(U))))>] Note [Thunk splitting] ~~~~~~~~~~~~~~~~~~~~~~ Suppose x is used strictly; never mind whether it has the CPR property. I'll use a '*' to mean "x* is demanded strictly". let x* = x-rhs in body splitThunk transforms like this: let x* = let x = x-rhs in case x of { I# a -> I# a } in body This is a little strange: we are re-using the same `x` in the RHS; and the RHS takes `x` apart and reboxes it. But because the outer 'let' is strict, and the inner let mentions `x` only once, the simplifier transform it to case x-rhs of I# a -> let x* = I# a in body That is good: in `body` we know the form of `x`, which * gives the CPR property, and * allows case-of-case to happen on x Notes * I tried transforming like this: let x* = let x = x-rhs in case x of { I# a -> x } in body where I return `x` itself, rather than reboxing it. But this turned out to cause some regressions, which I never fully investigated. * Suppose x-rhs is itself a case: x-rhs = case e of { T -> I# e1; F -> I# e2 } Then we'll get join j a = let x* = I# a in body in case e of { T -> j e1; F -> j e2 } which is good (no boxing). But in the original, unsplit program we would transform let x* = case e of ... in body ==> join j2 x = body in case e of { T -> j2 (I# e1); F -> j (I# e2) } which is not good (boxing). * In fact, splitThunk uses the function argument w/w splitting function, mkWWstr_one, so that if x's demand is deeper (say U(U(L,L),L)) then the splitting will go deeper too. * For recursive thunks, the Simplifier is unable to float `x-rhs` out of `x*`'s RHS, because `x*` occurs freely in `x-rhs`, and will just change it back to the original definition, so we just split non-recursive thunks. Note [Thunk splitting for top-level binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Top-level bindings are never strict. Yet they can be absent, as T14270 shows: module T14270 (mkTrApp) where mkTrApp x y | Just ... <- ... typeRepKind x ... = undefined | otherwise = undefined typeRepKind = Tick scc undefined (T19180 is a profiling-free test case for this) Note that `typeRepKind` is not exported and its only use site in `mkTrApp` guards a bottoming expression. Thus, demand analysis figures out that `typeRepKind` is absent and splits the thunk to typeRepKind = let typeRepKind = Tick scc undefined in let typeRepKind = absentError in typeRepKind But now we have a local binding with an External Name (See Note [About the NameSorts]). That will trigger a CoreLint error, which we get around by localising the Id for the auxiliary bindings in 'splitThunk'. -} -- | See Note [Thunk splitting]. -- -- splitThunk converts the *non-recursive* binding -- x = e -- into -- x = let x' = e in -- case x' of I# y -> let x' = I# y in x' -- See comments above. Is it not beautifully short? -- Moreover, it works just as well when there are -- several binders, and if the binders are lifted -- E.g. x = e -- --> x = let x' = e in -- case x' of (a,b) -> let x' = (a,b) in x' -- Here, x' is a localised version of x, in case x is a -- top-level Id with an External Name, because Lint rejects local binders with -- External Names; see Note [About the NameSorts] in GHC.Types.Name. -- -- How can we do thunk-splitting on a top-level binder? See -- Note [Thunk splitting for top-level binders]. splitThunk :: WwOpts -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)] splitThunk :: WwOpts -> RecFlag -> Var -> CoreExpr -> UniqSM [(Var, CoreExpr)] splitThunk WwOpts ww_opts RecFlag is_rec Var x CoreExpr rhs = Bool -> UniqSM [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)] forall a. HasCallStack => Bool -> a -> a assert (Bool -> Bool not (Var -> Bool isJoinId Var x)) (UniqSM [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)]) -> UniqSM [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)] forall a b. (a -> b) -> a -> b $ do { let x' :: Var x' = Var -> Var localiseId Var x -- See comment above ; (Bool useful,[(Var, StrictnessMark)] _args, CoreExpr -> CoreExpr wrap_fn, CoreExpr fn_arg) <- WwOpts -> Var -> StrictnessMark -> UniqSM (Bool, [(Var, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr) mkWWstr_one WwOpts ww_opts Var x' StrictnessMark NotMarkedStrict ; let res :: [(Var, CoreExpr)] res = [ (Var x, CoreBind -> CoreExpr -> CoreExpr forall b. Bind b -> Expr b -> Expr b Let (Var -> CoreExpr -> CoreBind forall b. b -> Expr b -> Bind b NonRec Var x' CoreExpr rhs) (CoreExpr -> CoreExpr wrap_fn CoreExpr fn_arg)) ] ; if Bool useful then Bool -> SDoc -> ([(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)]) -> [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)] forall a. HasCallStack => Bool -> SDoc -> a -> a assertPpr (RecFlag -> Bool isNonRec RecFlag is_rec) (Var -> SDoc forall a. Outputable a => a -> SDoc ppr Var x) -- The thunk must be non-recursive [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)] forall a. a -> UniqSM a forall (m :: * -> *) a. Monad m => a -> m a return [(Var, CoreExpr)] res else [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)] forall a. a -> UniqSM a forall (m :: * -> *) a. Monad m => a -> m a return [(Var x, CoreExpr rhs)] }