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 )
11 import CoreUtils ( exprType, exprIsHNF, mkInlineMe )
12 import CoreArity ( exprArity )
14 import Id ( Id, idType, isOneShotLambda, idUnfolding,
15 setIdNewStrictness, mkWorkerId,
16 setIdWorkerInfo, setInlineActivation,
18 import MkId ( lazyIdKey, lazyIdUnfolding )
21 import NewDemand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..),
22 Demands(..), mkTopDmdType, isBotRes, returnsCPR, topSig, isAbsent
25 import Unique ( hasKey )
26 import BasicTypes ( RecFlag(..), isNonRec, isNeverActive,
27 Activation, inlinePragmaActivation )
28 import VarEnv ( isEmptyVarEnv )
29 import Maybes ( orElse )
31 import Util ( lengthIs, notNull )
35 #include "HsVersions.h"
38 We take Core bindings whose binders have:
42 \item Strictness attached (by the front-end of the strictness
45 \item Constructed Product Result information attached by the CPR
50 and we return some ``plain'' bindings which have been
51 worker/wrapper-ified, meaning:
55 \item Functions have been split into workers and wrappers where
56 appropriate. If a function has both strictness and CPR properties
57 then only one worker/wrapper doing both transformations is produced;
59 \item Binders' @IdInfos@ have been updated to reflect the existence of
60 these workers/wrappers (this is where we get STRICTNESS and CPR pragma
61 info for exported values).
65 wwTopBinds :: UniqSupply -> [CoreBind] -> [CoreBind]
67 wwTopBinds us top_binds
69 top_binds' <- mapM wwBind top_binds
70 return (concat top_binds')
73 %************************************************************************
75 \subsection[wwBind-wwExpr]{@wwBind@ and @wwExpr@}
77 %************************************************************************
79 @wwBind@ works on a binding, trying each \tr{(binder, expr)} pair in
80 turn. Non-recursive case first, then recursive...
84 -> UniqSM [CoreBind] -- returns a WwBinding intermediate form;
85 -- the caller will convert to Expr/Binding,
88 wwBind (NonRec binder rhs) = do
90 new_pairs <- tryWW NonRecursive binder new_rhs
91 return [NonRec b e | (b,e) <- new_pairs]
92 -- Generated bindings must be non-recursive
93 -- because the original binding was.
96 = return . Rec <$> concatMapM do_one pairs
98 do_one (binder, rhs) = do new_rhs <- wwExpr rhs
99 tryWW Recursive binder new_rhs
102 @wwExpr@ basically just walks the tree, looking for appropriate
103 annotations that can be used. Remember it is @wwBind@ that does the
104 matching by looking for strict arguments of the correct type.
105 @wwExpr@ is a version that just returns the ``Plain'' Tree.
108 wwExpr :: CoreExpr -> UniqSM CoreExpr
110 wwExpr e@(Type _) = return e
111 wwExpr e@(Lit _) = return e
112 wwExpr e@(Note InlineMe _) = return e
113 -- Don't w/w inside InlineMe's
116 | v `hasKey` lazyIdKey = return lazyIdUnfolding
117 | otherwise = return e
118 -- HACK alert: Inline 'lazy' after strictness analysis
119 -- (but not inside InlineMe's)
121 wwExpr (Lam binder expr)
122 = Lam binder <$> wwExpr expr
125 = App <$> wwExpr f <*> wwExpr a
127 wwExpr (Note note expr)
128 = Note note <$> wwExpr expr
130 wwExpr (Cast expr co) = do
131 new_expr <- wwExpr expr
132 return (Cast new_expr co)
134 wwExpr (Let bind expr)
135 = mkLets <$> wwBind bind <*> wwExpr expr
137 wwExpr (Case expr binder ty alts) = do
138 new_expr <- wwExpr expr
139 new_alts <- mapM ww_alt alts
140 return (Case new_expr binder ty new_alts)
142 ww_alt (con, binders, rhs) = do
143 new_rhs <- wwExpr rhs
144 return (con, binders, new_rhs)
147 %************************************************************************
149 \subsection[tryWW]{@tryWW@: attempt a worker/wrapper pair}
151 %************************************************************************
153 @tryWW@ just accumulates arguments, converts strictness info from the
154 front-end into the proper form, then calls @mkWwBodies@ to do
157 We have to BE CAREFUL that we don't worker-wrapperize an Id that has
158 already been w-w'd! (You can end up with several liked-named Ids
159 bouncing around at the same time---absolute mischief.) So the
160 criterion we use is: if an Id already has an unfolding (for whatever
161 reason), then we don't w-w it.
163 The only reason this is monadised is for the unique supply.
165 Note [Don't w/w inline things (a)]
166 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
167 It's very important to refrain from w/w-ing an INLINE function
168 If we do so by mistake we transform
169 f = __inline (\x -> E)
171 f = __inline (\x -> case x of (a,b) -> fw E)
172 fw = \ab -> (__inline (\x -> E)) (a,b)
173 and the original __inline now vanishes, so E is no longer
174 inside its __inline wrapper. Death! Disaster!
176 Furthermore, if the programmer has marked something as INLINE,
177 we may lose by w/w'ing it.
179 If the strictness analyser is run twice, this test also prevents
180 wrappers (which are INLINEd) from being re-done.
182 Notice that we refrain from w/w'ing an INLINE function even if it is
183 in a recursive group. It might not be the loop breaker. (We could
184 test for loop-breaker-hood, but I'm not sure that ever matters.)
186 Note [Don't w/w inline things (b)]
187 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
188 In general, therefore, we refrain from w/w-ing *small* functions,
189 because they'll inline anyway. But we must take care: it may look
190 small now, but get to be big later after other inling has happened.
191 So we take the precaution of adding an INLINE pragma to any such
194 I made this change when I observed a big function at the end of
195 compilation with a useful strictness signature but no w-w. When
196 I measured it on nofib, it didn't make much difference; just a few
197 percent improved allocation on one benchmark (bspt/Euclid.space).
198 But nothing got worse.
203 -> Id -- The fn binder
204 -> CoreExpr -- The bound rhs; its innards
206 -> UniqSM [(Id, CoreExpr)] -- either *one* or *two* pairs;
207 -- if one, then no worker (only
208 -- the orig "wrapper" lives on);
209 -- if two, then a worker and a
211 tryWW is_rec fn_id rhs
212 | isNeverActive inline_act
213 -- No point in worker/wrappering if the thing is never inlined!
214 -- Because the no-inline prag will prevent the wrapper ever
215 -- being inlined at a call site.
217 -- Furthermore, don't even expose strictness info
218 = return [ (fn_id, rhs) ]
220 | is_thunk && worthSplittingThunk maybe_fn_dmd res_info
221 = ASSERT2( isNonRec is_rec, ppr new_fn_id ) -- The thunk must be non-recursive
222 checkSize new_fn_id rhs $
223 splitThunk new_fn_id rhs
225 | is_fun && worthSplittingFun wrap_dmds res_info
226 = checkSize new_fn_id rhs $
227 splitFun new_fn_id fn_info wrap_dmds res_info inline_act rhs
230 = return [ (new_fn_id, rhs) ]
233 fn_info = idInfo fn_id
234 maybe_fn_dmd = newDemandInfo fn_info
235 inline_act = inlinePragmaActivation (inlinePragInfo fn_info)
237 -- In practice it always will have a strictness
238 -- signature, even if it's a uninformative one
239 strict_sig = newStrictnessInfo fn_info `orElse` topSig
240 StrictSig (DmdType env wrap_dmds res_info) = strict_sig
242 -- new_fn_id has the DmdEnv zapped.
243 -- (a) it is never used again
244 -- (b) it wastes space
245 -- (c) it becomes incorrect as things are cloned, because
246 -- we don't push the substitution into it
247 new_fn_id | isEmptyVarEnv env = fn_id
248 | otherwise = fn_id `setIdNewStrictness`
249 StrictSig (mkTopDmdType wrap_dmds res_info)
251 is_fun = notNull wrap_dmds
252 is_thunk = not is_fun && not (exprIsHNF rhs)
254 ---------------------
255 checkSize :: Id -> CoreExpr -> UniqSM [(Id,CoreExpr)] -> UniqSM [(Id,CoreExpr)]
256 -- See Note [Don't w/w inline things (a) and (b)]
257 checkSize fn_id rhs thing_inside
258 | certainlyWillInline unfolding = return [ (fn_id, mkInlineMe rhs) ]
259 -- Note [Don't w/w inline things (b)]
260 | otherwise = thing_inside
262 unfolding = idUnfolding fn_id
264 ---------------------
265 splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> Activation -> Expr Var
266 -> UniqSM [(Id, CoreExpr)]
267 splitFun fn_id fn_info wrap_dmds res_info inline_act rhs
268 = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) )
270 -- The arity should match the signature
271 (work_demands, wrap_fn, work_fn) <- mkWwBodies fun_ty wrap_dmds res_info one_shots
272 ; work_uniq <- getUniqueM
274 work_rhs = work_fn rhs
275 work_id = mkWorkerId work_uniq fn_id (exprType work_rhs)
276 `setInlineActivation` inline_act
277 -- Any inline activation (which sets when inlining is active)
278 -- on the original function is duplicated on the worker and wrapper
279 -- It *matters* that the pragma stays on the wrapper
280 -- It seems sensible to have it on the worker too, although we
281 -- can't think of a compelling reason. (In ptic, INLINE things are
282 -- not w/wd). However, the RuleMatchInfo is not transferred since
283 -- it does not make sense for workers to be constructorlike.
284 `setIdNewStrictness` StrictSig (mkTopDmdType work_demands work_res_info)
285 -- Even though we may not be at top level,
286 -- it's ok to give it an empty DmdEnv
287 `setIdArity` (exprArity work_rhs)
288 -- Set the arity so that the Core Lint check that the
289 -- arity is consistent with the demand type goes through
291 wrap_rhs = wrap_fn work_id
292 wrap_id = fn_id `setIdWorkerInfo` HasWorker work_id arity
294 ; return ([(work_id, work_rhs), (wrap_id, wrap_rhs)]) })
295 -- Worker first, because wrapper mentions it
296 -- mkWwBodies has already built a wrap_rhs with an INLINE pragma wrapped around it
298 fun_ty = idType fn_id
300 arity = arityInfo fn_info -- The arity is set by the simplifier using exprEtaExpandArity
301 -- So it may be more than the number of top-level-visible lambdas
303 work_res_info | isBotRes res_info = BotRes -- Cpr stuff done by wrapper
306 one_shots = get_one_shots rhs
308 -- If the original function has one-shot arguments, it is important to
309 -- make the wrapper and worker have corresponding one-shot arguments too.
310 -- Otherwise we spuriously float stuff out of case-expression join points,
311 -- which is very annoying.
312 get_one_shots :: Expr Var -> [Bool]
313 get_one_shots (Lam b e)
314 | isId b = isOneShotLambda b : get_one_shots e
315 | otherwise = get_one_shots e
316 get_one_shots (Note _ e) = get_one_shots e
317 get_one_shots _ = noOneShotInfo
322 Suppose x is used strictly (never mind whether it has the CPR
329 splitThunk transforms like this:
332 x* = case x-rhs of { I# a -> I# a }
335 Now simplifier will transform to
338 I# a -> let x* = I# a
341 which is what we want. Now suppose x-rhs is itself a case:
343 x-rhs = case e of { T -> I# a; F -> I# b }
345 The join point will abstract over a, rather than over (which is
346 what would have happened before) which is fine.
348 Notice that x certainly has the CPR property now!
350 In fact, splitThunk uses the function argument w/w splitting
351 function, so that if x's demand is deeper (say U(U(L,L),L))
352 then the splitting will go deeper too.
355 -- splitThunk converts the *non-recursive* binding
360 -- I# y -> let x = I# y in x }
361 -- See comments above. Is it not beautifully short?
363 splitThunk :: Var -> Expr Var -> UniqSM [(Var, Expr Var)]
364 splitThunk fn_id rhs = do
365 (_, wrap_fn, work_fn) <- mkWWstr [fn_id]
366 return [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ]
370 %************************************************************************
372 \subsection{Functions over Demands}
374 %************************************************************************
377 worthSplittingFun :: [Demand] -> DmdResult -> Bool
378 -- True <=> the wrapper would not be an identity function
379 worthSplittingFun ds res
380 = any worth_it ds || returnsCPR res
381 -- worthSplitting returns False for an empty list of demands,
382 -- and hence do_strict_ww is False if arity is zero and there is no CPR
383 -- See Note [Worker-wrapper for bottoming functions]
385 worth_it Abs = True -- Absent arg
386 worth_it (Eval (Prod _)) = True -- Product arg to evaluate
389 worthSplittingThunk :: Maybe Demand -- Demand on the thunk
390 -> DmdResult -- CPR info for the thunk
392 worthSplittingThunk maybe_dmd res
393 = worth_it maybe_dmd || returnsCPR res
395 -- Split if the thing is unpacked
396 worth_it (Just (Eval (Prod ds))) = not (all isAbsent ds)
400 Note [Worker-wrapper for bottoming functions]
401 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
402 We used not to split if the result is bottom.
403 [Justification: there's no efficiency to be gained.]
405 But it's sometimes bad not to make a wrapper. Consider
406 fw = \x# -> let x = I# x# in case e of
410 The re-boxing code won't go away unless error_fn gets a wrapper too.
411 [We don't do reboxing now, but in general it's better to pass an
412 unboxed thing to f, and have it reboxed in the error cases....]
415 %************************************************************************
417 \subsection{The worker wrapper core}
419 %************************************************************************
421 @mkWrapper@ is called when importing a function. We have the type of
422 the function and the name of its worker, and we want to make its body (the wrapper).
425 mkWrapper :: Type -- Wrapper type
426 -> StrictSig -- Wrapper strictness info
427 -> UniqSM (Id -> CoreExpr) -- Wrapper body, missing worker Id
429 mkWrapper fun_ty (StrictSig (DmdType _ demands res_info)) = do
430 (_, wrap_fn, _) <- mkWwBodies fun_ty demands res_info noOneShotInfo
433 noOneShotInfo :: [Bool]
434 noOneShotInfo = repeat False