2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 \section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser}
7 module WorkWrap ( wwTopBinds, mkWrapper ) where
10 import CoreUnfold ( certainlyWillInline, mkInlineRule, mkWwInlineRule )
11 import CoreUtils ( exprType, exprIsHNF )
12 import CoreArity ( exprArity )
14 import Id ( idType, isOneShotLambda, idUnfolding,
15 setIdNewStrictness, mkWorkerId,
16 setInlineActivation, setIdUnfolding,
20 import NewDemand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..),
21 Demands(..), mkTopDmdType, isBotRes, returnsCPR, topSig, isAbsent
24 import BasicTypes ( RecFlag(..), isNonRec, isNeverActive,
25 Activation, inlinePragmaActivation )
26 import VarEnv ( isEmptyVarEnv )
27 import Maybes ( orElse )
29 import Util ( lengthIs, notNull )
33 #include "HsVersions.h"
36 We take Core bindings whose binders have:
40 \item Strictness attached (by the front-end of the strictness
43 \item Constructed Product Result information attached by the CPR
48 and we return some ``plain'' bindings which have been
49 worker/wrapper-ified, meaning:
53 \item Functions have been split into workers and wrappers where
54 appropriate. If a function has both strictness and CPR properties
55 then only one worker/wrapper doing both transformations is produced;
57 \item Binders' @IdInfos@ have been updated to reflect the existence of
58 these workers/wrappers (this is where we get STRICTNESS and CPR pragma
59 info for exported values).
63 wwTopBinds :: UniqSupply -> [CoreBind] -> [CoreBind]
65 wwTopBinds us top_binds
67 top_binds' <- mapM wwBind top_binds
68 return (concat top_binds')
71 %************************************************************************
73 \subsection[wwBind-wwExpr]{@wwBind@ and @wwExpr@}
75 %************************************************************************
77 @wwBind@ works on a binding, trying each \tr{(binder, expr)} pair in
78 turn. Non-recursive case first, then recursive...
82 -> UniqSM [CoreBind] -- returns a WwBinding intermediate form;
83 -- the caller will convert to Expr/Binding,
86 wwBind (NonRec binder rhs) = do
88 new_pairs <- tryWW NonRecursive binder new_rhs
89 return [NonRec b e | (b,e) <- new_pairs]
90 -- Generated bindings must be non-recursive
91 -- because the original binding was.
94 = return . Rec <$> concatMapM do_one pairs
96 do_one (binder, rhs) = do new_rhs <- wwExpr rhs
97 tryWW Recursive binder new_rhs
100 @wwExpr@ basically just walks the tree, looking for appropriate
101 annotations that can be used. Remember it is @wwBind@ that does the
102 matching by looking for strict arguments of the correct type.
103 @wwExpr@ is a version that just returns the ``Plain'' Tree.
106 wwExpr :: CoreExpr -> UniqSM CoreExpr
108 wwExpr e@(Type {}) = return e
109 wwExpr e@(Lit {}) = return e
110 wwExpr e@(Var {}) = return e
112 wwExpr (Lam binder expr)
113 = Lam binder <$> wwExpr expr
116 = App <$> wwExpr f <*> wwExpr a
118 wwExpr (Note note expr)
119 = Note note <$> wwExpr expr
121 wwExpr (Cast expr co) = do
122 new_expr <- wwExpr expr
123 return (Cast new_expr co)
125 wwExpr (Let bind expr)
126 = mkLets <$> wwBind bind <*> wwExpr expr
128 wwExpr (Case expr binder ty alts) = do
129 new_expr <- wwExpr expr
130 new_alts <- mapM ww_alt alts
131 return (Case new_expr binder ty new_alts)
133 ww_alt (con, binders, rhs) = do
134 new_rhs <- wwExpr rhs
135 return (con, binders, new_rhs)
138 %************************************************************************
140 \subsection[tryWW]{@tryWW@: attempt a worker/wrapper pair}
142 %************************************************************************
144 @tryWW@ just accumulates arguments, converts strictness info from the
145 front-end into the proper form, then calls @mkWwBodies@ to do
148 We have to BE CAREFUL that we don't worker-wrapperize an Id that has
149 already been w-w'd! (You can end up with several liked-named Ids
150 bouncing around at the same time---absolute mischief.) So the
151 criterion we use is: if an Id already has an unfolding (for whatever
152 reason), then we don't w-w it.
154 The only reason this is monadised is for the unique supply.
156 Note [Don't w/w inline things (a)]
157 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
158 It's very important to refrain from w/w-ing an INLINE function
159 because the wrapepr will then overwrite the InlineRule unfolding.
161 It was wrong with the old InlineMe Note too: if we do so by mistake
163 f = __inline (\x -> E)
165 f = __inline (\x -> case x of (a,b) -> fw E)
166 fw = \ab -> (__inline (\x -> E)) (a,b)
167 and the original __inline now vanishes, so E is no longer
168 inside its __inline wrapper. Death! Disaster!
170 Furthermore, if the programmer has marked something as INLINE,
171 we may lose by w/w'ing it.
173 If the strictness analyser is run twice, this test also prevents
174 wrappers (which are INLINEd) from being re-done.
176 Notice that we refrain from w/w'ing an INLINE function even if it is
177 in a recursive group. It might not be the loop breaker. (We could
178 test for loop-breaker-hood, but I'm not sure that ever matters.)
180 Note [Don't w/w inline things (b)]
181 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
182 In general, therefore, we refrain from w/w-ing *small* functions,
183 because they'll inline anyway. But we must take care: it may look
184 small now, but get to be big later after other inling has happened.
185 So we take the precaution of adding an INLINE pragma to any such
188 I made this change when I observed a big function at the end of
189 compilation with a useful strictness signature but no w-w. When
190 I measured it on nofib, it didn't make much difference; just a few
191 percent improved allocation on one benchmark (bspt/Euclid.space).
192 But nothing got worse.
197 -> Id -- The fn binder
198 -> CoreExpr -- The bound rhs; its innards
200 -> UniqSM [(Id, CoreExpr)] -- either *one* or *two* pairs;
201 -- if one, then no worker (only
202 -- the orig "wrapper" lives on);
203 -- if two, then a worker and a
205 tryWW is_rec fn_id rhs
206 | isNeverActive inline_act
207 -- No point in worker/wrappering if the thing is never inlined!
208 -- Because the no-inline prag will prevent the wrapper ever
209 -- being inlined at a call site.
211 -- Furthermore, don't even expose strictness info
212 = return [ (fn_id, rhs) ]
214 | is_thunk && worthSplittingThunk maybe_fn_dmd res_info
215 = ASSERT2( isNonRec is_rec, ppr new_fn_id ) -- The thunk must be non-recursive
216 checkSize new_fn_id rhs $
217 splitThunk new_fn_id rhs
219 | is_fun && worthSplittingFun wrap_dmds res_info
220 = checkSize new_fn_id rhs $
221 splitFun new_fn_id fn_info wrap_dmds res_info inline_act rhs
224 = return [ (new_fn_id, rhs) ]
227 fn_info = idInfo fn_id
228 maybe_fn_dmd = newDemandInfo fn_info
229 inline_act = inlinePragmaActivation (inlinePragInfo fn_info)
231 -- In practice it always will have a strictness
232 -- signature, even if it's a uninformative one
233 strict_sig = newStrictnessInfo fn_info `orElse` topSig
234 StrictSig (DmdType env wrap_dmds res_info) = strict_sig
236 -- new_fn_id has the DmdEnv zapped.
237 -- (a) it is never used again
238 -- (b) it wastes space
239 -- (c) it becomes incorrect as things are cloned, because
240 -- we don't push the substitution into it
241 new_fn_id | isEmptyVarEnv env = fn_id
242 | otherwise = fn_id `setIdNewStrictness`
243 StrictSig (mkTopDmdType wrap_dmds res_info)
245 is_fun = notNull wrap_dmds
246 is_thunk = not is_fun && not (exprIsHNF rhs)
248 ---------------------
249 checkSize :: Id -> CoreExpr
250 -> UniqSM [(Id,CoreExpr)] -> UniqSM [(Id,CoreExpr)]
251 -- See Note [Don't w/w inline things (a) and (b)]
252 checkSize fn_id rhs thing_inside
253 | isStableUnfolding unfolding -- For DFuns and INLINE things, leave their
254 = return [ (fn_id, rhs) ] -- unfolding unchanged; but still attach
255 -- strictness info to the Id
257 | certainlyWillInline unfolding
258 = return [ (fn_id `setIdUnfolding` inline_rule, rhs) ]
259 -- Note [Don't w/w inline things (b)]
261 | otherwise = thing_inside
263 unfolding = idUnfolding fn_id
264 inline_rule = mkInlineRule InlUnSat rhs (unfoldingArity unfolding)
266 ---------------------
267 splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> Activation -> Expr Var
268 -> UniqSM [(Id, CoreExpr)]
269 splitFun fn_id fn_info wrap_dmds res_info inline_act rhs
270 = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) )
272 -- The arity should match the signature
273 (work_demands, wrap_fn, work_fn) <- mkWwBodies fun_ty wrap_dmds res_info one_shots
274 ; work_uniq <- getUniqueM
276 work_rhs = work_fn rhs
277 work_id = mkWorkerId work_uniq fn_id (exprType work_rhs)
278 `setInlineActivation` inline_act
279 -- Any inline activation (which sets when inlining is active)
280 -- on the original function is duplicated on the worker and wrapper
281 -- It *matters* that the pragma stays on the wrapper
282 -- It seems sensible to have it on the worker too, although we
283 -- can't think of a compelling reason. (In ptic, INLINE things are
284 -- not w/wd). However, the RuleMatchInfo is not transferred since
285 -- it does not make sense for workers to be constructorlike.
286 `setIdNewStrictness` StrictSig (mkTopDmdType work_demands work_res_info)
287 -- Even though we may not be at top level,
288 -- it's ok to give it an empty DmdEnv
289 `setIdArity` (exprArity work_rhs)
290 -- Set the arity so that the Core Lint check that the
291 -- arity is consistent with the demand type goes through
293 wrap_rhs = wrap_fn work_id
294 wrap_id = fn_id `setIdUnfolding` mkWwInlineRule work_id wrap_rhs arity
296 ; return ([(work_id, work_rhs), (wrap_id, wrap_rhs)]) })
297 -- Worker first, because wrapper mentions it
298 -- mkWwBodies has already built a wrap_rhs with an INLINE pragma wrapped around it
300 fun_ty = idType fn_id
302 arity = arityInfo fn_info -- The arity is set by the simplifier using exprEtaExpandArity
303 -- So it may be more than the number of top-level-visible lambdas
305 work_res_info | isBotRes res_info = BotRes -- Cpr stuff done by wrapper
308 one_shots = get_one_shots rhs
310 -- If the original function has one-shot arguments, it is important to
311 -- make the wrapper and worker have corresponding one-shot arguments too.
312 -- Otherwise we spuriously float stuff out of case-expression join points,
313 -- which is very annoying.
314 get_one_shots :: Expr Var -> [Bool]
315 get_one_shots (Lam b e)
316 | isId b = isOneShotLambda b : get_one_shots e
317 | otherwise = get_one_shots e
318 get_one_shots (Note _ e) = get_one_shots e
319 get_one_shots _ = noOneShotInfo
324 Suppose x is used strictly (never mind whether it has the CPR
331 splitThunk transforms like this:
334 x* = case x-rhs of { I# a -> I# a }
337 Now simplifier will transform to
340 I# a -> let x* = I# a
343 which is what we want. Now suppose x-rhs is itself a case:
345 x-rhs = case e of { T -> I# a; F -> I# b }
347 The join point will abstract over a, rather than over (which is
348 what would have happened before) which is fine.
350 Notice that x certainly has the CPR property now!
352 In fact, splitThunk uses the function argument w/w splitting
353 function, so that if x's demand is deeper (say U(U(L,L),L))
354 then the splitting will go deeper too.
357 -- splitThunk converts the *non-recursive* binding
362 -- I# y -> let x = I# y in x }
363 -- See comments above. Is it not beautifully short?
365 splitThunk :: Var -> Expr Var -> UniqSM [(Var, Expr Var)]
366 splitThunk fn_id rhs = do
367 (_, wrap_fn, work_fn) <- mkWWstr [fn_id]
368 return [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ]
372 %************************************************************************
374 \subsection{Functions over Demands}
376 %************************************************************************
379 worthSplittingFun :: [Demand] -> DmdResult -> Bool
380 -- True <=> the wrapper would not be an identity function
381 worthSplittingFun ds res
382 = any worth_it ds || returnsCPR res
383 -- worthSplitting returns False for an empty list of demands,
384 -- and hence do_strict_ww is False if arity is zero and there is no CPR
385 -- See Note [Worker-wrapper for bottoming functions]
387 worth_it Abs = True -- Absent arg
388 worth_it (Eval (Prod _)) = True -- Product arg to evaluate
391 worthSplittingThunk :: Maybe Demand -- Demand on the thunk
392 -> DmdResult -- CPR info for the thunk
394 worthSplittingThunk maybe_dmd res
395 = worth_it maybe_dmd || returnsCPR res
397 -- Split if the thing is unpacked
398 worth_it (Just (Eval (Prod ds))) = not (all isAbsent ds)
402 Note [Worker-wrapper for bottoming functions]
403 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
404 We used not to split if the result is bottom.
405 [Justification: there's no efficiency to be gained.]
407 But it's sometimes bad not to make a wrapper. Consider
408 fw = \x# -> let x = I# x# in case e of
412 The re-boxing code won't go away unless error_fn gets a wrapper too.
413 [We don't do reboxing now, but in general it's better to pass an
414 unboxed thing to f, and have it reboxed in the error cases....]
417 %************************************************************************
419 \subsection{The worker wrapper core}
421 %************************************************************************
423 @mkWrapper@ is called when importing a function. We have the type of
424 the function and the name of its worker, and we want to make its body (the wrapper).
427 mkWrapper :: Type -- Wrapper type
428 -> StrictSig -- Wrapper strictness info
429 -> UniqSM (Id -> CoreExpr) -- Wrapper body, missing worker Id
431 mkWrapper fun_ty (StrictSig (DmdType _ demands res_info)) = do
432 (_, wrap_fn, _) <- mkWwBodies fun_ty demands res_info noOneShotInfo
435 noOneShotInfo :: [Bool]
436 noOneShotInfo = repeat False