\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,
+ 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, inlinePragmaActivation )
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:
\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')
\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
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)
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
-- 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.
-- (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
- = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) ) do
+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_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
- (work_demands, wrap_fn, work_fn) <- mkWwBodies fun_ty wrap_dmds res_info one_shots
- work_uniq <- getUniqueM
- let
+ (work_demands, wrap_fn, work_fn) <- mkWwBodies fun_ty wrap_dmds res_info one_shots
+ ; work_uniq <- getUniqueM
+ ; 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)
-- 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)])
+ ; 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
-- 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
-- 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)))) ]
-- 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
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]
(_, wrap_fn, _) <- mkWwBodies fun_ty demands res_info noOneShotInfo
return wrap_fn
+noOneShotInfo :: [Bool]
noOneShotInfo = repeat False
\end{code}
projects / ghc-hetmet.git / blobdiff