X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fstranal%2FWorkWrap.lhs;h=4e7a494bc990c869e8b2eecff994ac672677c627;hp=71f9ef831756df690335096bcec0ad9a648b3272;hb=2662dbc5b2c30fc11ccb99e7f9b2dba794d680ba;hpb=62eeda5aed31173b234b2965ccf4bd6979ffd9a4 diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs index 71f9ef8..4e7a494 100644 --- a/compiler/stranal/WorkWrap.lhs +++ b/compiler/stranal/WorkWrap.lhs @@ -6,32 +6,31 @@ \begin{code} module WorkWrap ( wwTopBinds, mkWrapper ) where -#include "HsVersions.h" - import CoreSyn -import CoreUnfold ( certainlyWillInline ) +import CoreUnfold ( certainlyWillInline, mkInlineRule, mkWwInlineRule ) import CoreUtils ( exprType, exprIsHNF ) import CoreArity ( exprArity ) import Var -import Id ( Id, idType, isOneShotLambda, - setIdNewStrictness, mkWorkerId, - setIdWorkerInfo, setInlinePragma, - setIdArity, idInfo ) -import MkId ( lazyIdKey, lazyIdUnfolding ) +import Id ( idType, isOneShotLambda, idUnfolding, + setIdStrictness, mkWorkerId, + setInlineActivation, setIdUnfolding, + setIdArity ) import Type ( Type ) import IdInfo -import NewDemand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), +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, inlinePragmaActivation ) import VarEnv ( isEmptyVarEnv ) import Maybes ( orElse ) import WwLib import Util ( lengthIs, notNull ) import Outputable import MonadUtils + +#include "HsVersions.h" \end{code} We take Core bindings whose binders have: @@ -106,16 +105,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 _) = 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 @@ -161,10 +153,13 @@ 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 +because the wrapepr will then overwrite the InlineRule unfolding. + +It was wrong with the old InlineMe Note too: if we do so by mistake +we transform f = __inline (\x -> E) into f = __inline (\x -> case x of (a,b) -> fw E) @@ -182,6 +177,21 @@ 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, therefore, 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. + + \begin{code} tryWW :: RecFlag -> Id -- The fn binder @@ -193,34 +203,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 inline_act 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. @@ -229,16 +239,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 :: Id -> IdInfo -> [Demand] -> DmdResult -> InlinePragInfo -> Expr Var +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 InlUnSat rhs (unfoldingArity unfolding) + +--------------------- +splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> Activation -> Expr Var -> UniqSM [(Id, CoreExpr)] -splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs +splitFun fn_id fn_info wrap_dmds res_info inline_act 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 @@ -247,14 +275,15 @@ 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) + `setInlineActivation` inline_act + -- Any inline activation (which sets when inlining is active) -- on the original function is duplicated on the worker and wrapper -- 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) @@ -262,7 +291,7 @@ splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs -- 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_id = fn_id `setIdUnfolding` mkWwInlineRule work_id wrap_rhs arity ; return ([(work_id, work_rhs), (wrap_id, wrap_rhs)]) }) -- Worker first, because wrapper mentions it