X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fstranal%2FWorkWrap.lhs;h=33ca298d1f0619ed2b824fc5a4eaeb00ca952e57;hp=8bd89c084fac1df049b5f010aa27b8f0db1fc77b;hb=76dfa3944cbf149a30398d29e6762a44772c0174;hpb=fb236fbbea7f12293b030892c6dc866a96566200 diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs index 8bd89c0..33ca298 100644 --- a/compiler/stranal/WorkWrap.lhs +++ b/compiler/stranal/WorkWrap.lhs @@ -4,43 +4,34 @@ \section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser} \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module WorkWrap ( wwTopBinds, mkWrapper ) where -#include "HsVersions.h" - import CoreSyn -import CoreUnfold ( certainlyWillInline ) -import CoreLint ( showPass, endPass ) -import CoreUtils ( exprType, exprIsHNF, exprArity ) -import Id ( Id, idType, isOneShotLambda, - setIdNewStrictness, mkWorkerId, - setIdWorkerInfo, setInlinePragma, - setIdArity, idInfo ) -import MkId ( lazyIdKey, lazyIdUnfolding ) +import CoreUnfold ( certainlyWillInline, mkInlineRule, mkWwInlineRule ) +import CoreUtils ( exprType, exprIsHNF ) +import CoreArity ( exprArity ) +import Var +import Id ( idType, isOneShotLambda, idUnfolding, + setIdStrictness, mkWorkerId, setInlinePragma, + setInlineActivation, setIdUnfolding, + setIdArity ) import Type ( Type ) -import IdInfo ( WorkerInfo(..), arityInfo, - newDemandInfo, newStrictnessInfo, unfoldingInfo, inlinePragInfo - ) -import NewDemand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), +import IdInfo +import Demand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), Demands(..), mkTopDmdType, isBotRes, returnsCPR, topSig, isAbsent ) import UniqSupply -import Unique ( hasKey ) -import BasicTypes ( RecFlag(..), isNonRec, isNeverActive ) +import BasicTypes ( RecFlag(..), isNonRec, isNeverActive, + Activation(..), InlinePragma(..), + inlinePragmaActivation, inlinePragmaRuleMatchInfo ) import VarEnv ( isEmptyVarEnv ) import Maybes ( orElse ) -import DynFlags import WwLib import Util ( lengthIs, notNull ) import Outputable import MonadUtils + +#include "HsVersions.h" \end{code} We take Core bindings whose binders have: @@ -70,30 +61,9 @@ info for exported values). \end{enumerate} \begin{code} +wwTopBinds :: UniqSupply -> [CoreBind] -> [CoreBind] -wwTopBinds :: DynFlags - -> UniqSupply - -> [CoreBind] - -> IO [CoreBind] - -wwTopBinds dflags us binds - = do { - showPass dflags "Worker Wrapper binds"; - - -- Create worker/wrappers, and mark binders with their - -- "strictness info" [which encodes their worker/wrapper-ness] - let { binds' = workersAndWrappers us binds }; - - endPass dflags "Worker Wrapper binds" - Opt_D_dump_worker_wrapper binds' - } -\end{code} - - -\begin{code} -workersAndWrappers :: UniqSupply -> [CoreBind] -> [CoreBind] - -workersAndWrappers us top_binds +wwTopBinds us top_binds = initUs_ us $ do top_binds' <- mapM wwBind top_binds return (concat top_binds') @@ -136,16 +106,9 @@ matching by looking for strict arguments of the correct type. \begin{code} wwExpr :: CoreExpr -> UniqSM CoreExpr -wwExpr e@(Type _) = return e -wwExpr e@(Lit _) = return e -wwExpr e@(Note InlineMe expr) = return e - -- Don't w/w inside InlineMe's - -wwExpr e@(Var v) - | v `hasKey` lazyIdKey = return lazyIdUnfolding - | otherwise = return e - -- HACK alert: Inline 'lazy' after strictness analysis - -- (but not inside InlineMe's) +wwExpr e@(Type {}) = return e +wwExpr e@(Lit {}) = return e +wwExpr e@(Var {}) = return e wwExpr (Lam binder expr) = Lam binder <$> wwExpr expr @@ -183,35 +146,69 @@ wwExpr (Case expr binder ty alts) = do front-end into the proper form, then calls @mkWwBodies@ to do the business. -We have to BE CAREFUL that we don't worker-wrapperize an Id that has -already been w-w'd! (You can end up with several liked-named Ids -bouncing around at the same time---absolute mischief.) So the -criterion we use is: if an Id already has an unfolding (for whatever -reason), then we don't w-w it. - The only reason this is monadised is for the unique supply. -Note [Don't w/w inline things] +Note [Don't w/w inline things (a)] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's very important to refrain from w/w-ing an INLINE function -If we do so by mistake we transform - f = __inline (\x -> E) -into - f = __inline (\x -> case x of (a,b) -> fw E) - fw = \ab -> (__inline (\x -> E)) (a,b) -and the original __inline now vanishes, so E is no longer -inside its __inline wrapper. Death! Disaster! + +It's very important to refrain from w/w-ing an INLINE function (ie one +with an InlineRule) because the wrapper will then overwrite the +InlineRule unfolding. 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. +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 [Don't w/w inline things (b)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general, we refrain from w/w-ing *small* functions, because they'll +inline anyway. But we must take care: it may look small now, but get +to be big later after other inling has happened. So we take the +precaution of adding an INLINE pragma to 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. 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. + +Note [Wrapper activation] +~~~~~~~~~~~~~~~~~~~~~~~~~ +When should the wrapper inlining be active? It must not be active +earlier than the current Activation of the Id (eg it might have a +NOINLINE pragma). But in fact strictness analysis happens fairly +late in the pipeline, and we want to prioritise specialisations over +strictness. Eg if we have + 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 Bsr where + import Foo + + h :: Int -> Int + h x = f 3 x + +Then we want the specialisation for 'f' to kick in before the wrapper does. + +Now in fact the 'gentle' simplification pass encourages this, by +having rules on, but inlinings off. But that's kind of lucky. It seems +more robust to give the wrapper an Activation of (ActiveAfter 0), +so that it becomes active in an importing module at the same time that +it appears in the first place in the defining module. + \begin{code} tryWW :: RecFlag -> Id -- The fn binder @@ -223,34 +220,34 @@ tryWW :: RecFlag -- if two, then a worker and a -- wrapper. tryWW is_rec fn_id rhs - | -- isNonRec is_rec && -- Now omitted: see Note [Don't w/w inline things] - certainlyWillInline unfolding - - || isNeverActive inline_prag + | isNeverActive inline_act -- No point in worker/wrappering if the thing is never inlined! -- Because the no-inline prag will prevent the wrapper ever -- being inlined at a call site. - = return [ (new_fn_id, rhs) ] + -- + -- Furthermore, don't even expose strictness info + = return [ (fn_id, rhs) ] | is_thunk && worthSplittingThunk maybe_fn_dmd res_info = ASSERT2( isNonRec is_rec, ppr new_fn_id ) -- The thunk must be non-recursive + checkSize new_fn_id rhs $ splitThunk new_fn_id rhs | is_fun && worthSplittingFun wrap_dmds res_info - = splitFun new_fn_id fn_info wrap_dmds res_info inline_prag rhs + = checkSize new_fn_id rhs $ + splitFun new_fn_id fn_info wrap_dmds res_info rhs | otherwise = return [ (new_fn_id, rhs) ] where fn_info = idInfo fn_id - maybe_fn_dmd = newDemandInfo fn_info - unfolding = unfoldingInfo fn_info - inline_prag = inlinePragInfo fn_info + maybe_fn_dmd = demandInfo fn_info + inline_act = inlinePragmaActivation (inlinePragInfo fn_info) -- In practice it always will have a strictness -- signature, even if it's a uninformative one - strict_sig = newStrictnessInfo fn_info `orElse` topSig + strict_sig = strictnessInfo fn_info `orElse` topSig StrictSig (DmdType env wrap_dmds res_info) = strict_sig -- new_fn_id has the DmdEnv zapped. @@ -259,14 +256,34 @@ tryWW is_rec fn_id rhs -- (c) it becomes incorrect as things are cloned, because -- we don't push the substitution into it new_fn_id | isEmptyVarEnv env = fn_id - | otherwise = fn_id `setIdNewStrictness` + | otherwise = fn_id `setIdStrictness` StrictSig (mkTopDmdType wrap_dmds res_info) is_fun = notNull wrap_dmds is_thunk = not is_fun && not (exprIsHNF rhs) --------------------- -splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs +checkSize :: Id -> CoreExpr + -> UniqSM [(Id,CoreExpr)] -> UniqSM [(Id,CoreExpr)] + -- See Note [Don't w/w inline things (a) and (b)] +checkSize fn_id rhs thing_inside + | isStableUnfolding unfolding -- For DFuns and INLINE things, leave their + = return [ (fn_id, rhs) ] -- unfolding unchanged; but still attach + -- strictness info to the Id + + | certainlyWillInline unfolding + = return [ (fn_id `setIdUnfolding` inline_rule, rhs) ] + -- Note [Don't w/w inline things (b)] + + | otherwise = thing_inside + where + unfolding = idUnfolding fn_id + inline_rule = mkInlineRule unSaturatedOk rhs (unfoldingArity unfolding) + +--------------------- +splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> Expr Var + -> UniqSM [(Id, CoreExpr)] +splitFun fn_id fn_info wrap_dmds res_info rhs = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) ) (do { -- The arity should match the signature @@ -275,31 +292,45 @@ splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs ; let work_rhs = work_fn rhs work_id = mkWorkerId work_uniq fn_id (exprType work_rhs) - `setInlinePragma` inline_prag - -- Any inline pragma (which sets when inlining is active) - -- on the original function is duplicated on the worker and wrapper + `setInlineActivation` (inlinePragmaActivation inl_prag) + -- Any inline activation (which sets when inlining is active) + -- on the original function is duplicated on the worker -- It *matters* that the pragma stays on the wrapper -- It seems sensible to have it on the worker too, although we -- can't think of a compelling reason. (In ptic, INLINE things are - -- not w/wd) - `setIdNewStrictness` StrictSig (mkTopDmdType work_demands work_res_info) + -- not w/wd). However, the RuleMatchInfo is not transferred since + -- it does not make sense for workers to be constructorlike. + + `setIdStrictness` StrictSig (mkTopDmdType work_demands work_res_info) -- Even though we may not be at top level, -- it's ok to give it an empty DmdEnv + `setIdArity` (exprArity work_rhs) -- Set the arity so that the Core Lint check that the -- arity is consistent with the demand type goes through - wrap_rhs = wrap_fn work_id - wrap_id = fn_id `setIdWorkerInfo` HasWorker work_id arity + wrap_rhs = wrap_fn work_id + wrap_prag = InlinePragma { inl_inline = True + , inl_act = ActiveAfter 0 + , inl_rule = rule_match_info } + + wrap_id = fn_id `setIdUnfolding` mkWwInlineRule work_id wrap_rhs arity + `setInlinePragma` wrap_prag + -- See Note [Wrapper activation] + -- The RuleMatchInfo is (and must be) unaffected + -- The inl_inline is bound to be False, else we would not be + -- making a wrapper ; return ([(work_id, work_rhs), (wrap_id, wrap_rhs)]) }) -- Worker first, because wrapper mentions it -- mkWwBodies has already built a wrap_rhs with an INLINE pragma wrapped around it where - fun_ty = idType fn_id - - arity = arityInfo fn_info -- The arity is set by the simplifier using exprEtaExpandArity - -- So it may be more than the number of top-level-visible lambdas + fun_ty = idType fn_id + inl_prag = inlinePragInfo fn_info + rule_match_info = inlinePragmaRuleMatchInfo inl_prag + arity = arityInfo fn_info + -- The arity is set by the simplifier using exprEtaExpandArity + -- So it may be more than the number of top-level-visible lambdas work_res_info | isBotRes res_info = BotRes -- Cpr stuff done by wrapper | otherwise = TopRes @@ -310,11 +341,12 @@ splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs -- make the wrapper and worker have corresponding one-shot arguments too. -- Otherwise we spuriously float stuff out of case-expression join points, -- which is very annoying. +get_one_shots :: Expr Var -> [Bool] get_one_shots (Lam b e) | isId b = isOneShotLambda b : get_one_shots e | otherwise = get_one_shots e get_one_shots (Note _ e) = get_one_shots e -get_one_shots other = noOneShotInfo +get_one_shots _ = noOneShotInfo \end{code} Thunk splitting @@ -360,6 +392,7 @@ then the splitting will go deeper too. -- I# y -> let x = I# y in x } -- See comments above. Is it not beautifully short? +splitThunk :: Var -> Expr Var -> UniqSM [(Var, Expr Var)] splitThunk fn_id rhs = do (_, wrap_fn, work_fn) <- mkWWstr [fn_id] return [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ] @@ -382,8 +415,8 @@ worthSplittingFun ds res -- See Note [Worker-wrapper for bottoming functions] where worth_it Abs = True -- Absent arg - worth_it (Eval (Prod ds)) = True -- Product arg to evaluate - worth_it other = False + worth_it (Eval (Prod _)) = True -- Product arg to evaluate + worth_it _ = False worthSplittingThunk :: Maybe Demand -- Demand on the thunk -> DmdResult -- CPR info for the thunk @@ -393,7 +426,7 @@ worthSplittingThunk maybe_dmd res where -- Split if the thing is unpacked worth_it (Just (Eval (Prod ds))) = not (all isAbsent ds) - worth_it other = False + worth_it _ = False \end{code} Note [Worker-wrapper for bottoming functions] @@ -429,5 +462,6 @@ mkWrapper fun_ty (StrictSig (DmdType _ demands res_info)) = do (_, wrap_fn, _) <- mkWwBodies fun_ty demands res_info noOneShotInfo return wrap_fn +noOneShotInfo :: [Bool] noOneShotInfo = repeat False \end{code}