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 )
17 import NewDemand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..),
18 Demands(..), mkTopDmdType, isBotRes, returnsCPR, topSig, isAbsent
21 import BasicTypes ( RecFlag(..), isNonRec, isNeverActive,
22 Activation, inlinePragmaActivation )
23 import VarEnv ( isEmptyVarEnv )
24 import Maybes ( orElse )
26 import Util ( lengthIs, notNull )
30 #include "HsVersions.h"
33 We take Core bindings whose binders have:
37 \item Strictness attached (by the front-end of the strictness
40 \item Constructed Product Result information attached by the CPR
45 and we return some ``plain'' bindings which have been
46 worker/wrapper-ified, meaning:
50 \item Functions have been split into workers and wrappers where
51 appropriate. If a function has both strictness and CPR properties
52 then only one worker/wrapper doing both transformations is produced;
54 \item Binders' @IdInfos@ have been updated to reflect the existence of
55 these workers/wrappers (this is where we get STRICTNESS and CPR pragma
56 info for exported values).
60 wwTopBinds :: UniqSupply -> [CoreBind] -> [CoreBind]
62 wwTopBinds us top_binds
64 top_binds' <- mapM wwBind top_binds
65 return (concat top_binds')
68 %************************************************************************
70 \subsection[wwBind-wwExpr]{@wwBind@ and @wwExpr@}
72 %************************************************************************
74 @wwBind@ works on a binding, trying each \tr{(binder, expr)} pair in
75 turn. Non-recursive case first, then recursive...
79 -> UniqSM [CoreBind] -- returns a WwBinding intermediate form;
80 -- the caller will convert to Expr/Binding,
83 wwBind (NonRec binder rhs) = do
85 new_pairs <- tryWW NonRecursive binder new_rhs
86 return [NonRec b e | (b,e) <- new_pairs]
87 -- Generated bindings must be non-recursive
88 -- because the original binding was.
91 = return . Rec <$> concatMapM do_one pairs
93 do_one (binder, rhs) = do new_rhs <- wwExpr rhs
94 tryWW Recursive binder new_rhs
97 @wwExpr@ basically just walks the tree, looking for appropriate
98 annotations that can be used. Remember it is @wwBind@ that does the
99 matching by looking for strict arguments of the correct type.
100 @wwExpr@ is a version that just returns the ``Plain'' Tree.
103 wwExpr :: CoreExpr -> UniqSM CoreExpr
105 wwExpr e@(Type {}) = return e
106 wwExpr e@(Lit {}) = return e
107 wwExpr e@(Var {}) = return e
108 wwExpr e@(Note InlineMe _) = return e
109 -- Don't w/w inside InlineMe's
111 wwExpr (Lam binder expr)
112 = Lam binder <$> wwExpr expr
115 = App <$> wwExpr f <*> wwExpr a
117 wwExpr (Note note expr)
118 = Note note <$> wwExpr expr
120 wwExpr (Cast expr co) = do
121 new_expr <- wwExpr expr
122 return (Cast new_expr co)
124 wwExpr (Let bind expr)
125 = mkLets <$> wwBind bind <*> wwExpr expr
127 wwExpr (Case expr binder ty alts) = do
128 new_expr <- wwExpr expr
129 new_alts <- mapM ww_alt alts
130 return (Case new_expr binder ty new_alts)
132 ww_alt (con, binders, rhs) = do
133 new_rhs <- wwExpr rhs
134 return (con, binders, new_rhs)
137 %************************************************************************
139 \subsection[tryWW]{@tryWW@: attempt a worker/wrapper pair}
141 %************************************************************************
143 @tryWW@ just accumulates arguments, converts strictness info from the
144 front-end into the proper form, then calls @mkWwBodies@ to do
147 We have to BE CAREFUL that we don't worker-wrapperize an Id that has
148 already been w-w'd! (You can end up with several liked-named Ids
149 bouncing around at the same time---absolute mischief.) So the
150 criterion we use is: if an Id already has an unfolding (for whatever
151 reason), then we don't w-w it.
153 The only reason this is monadised is for the unique supply.
155 Note [Don't w/w inline things (a)]
156 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
157 It's very important to refrain from w/w-ing an INLINE function
158 If we do so by mistake we transform
159 f = __inline (\x -> E)
161 f = __inline (\x -> case x of (a,b) -> fw E)
162 fw = \ab -> (__inline (\x -> E)) (a,b)
163 and the original __inline now vanishes, so E is no longer
164 inside its __inline wrapper. Death! Disaster!
166 Furthermore, if the programmer has marked something as INLINE,
167 we may lose by w/w'ing it.
169 If the strictness analyser is run twice, this test also prevents
170 wrappers (which are INLINEd) from being re-done.
172 Notice that we refrain from w/w'ing an INLINE function even if it is
173 in a recursive group. It might not be the loop breaker. (We could
174 test for loop-breaker-hood, but I'm not sure that ever matters.)
176 Note [Don't w/w inline things (b)]
177 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
178 In general, therefore, we refrain from w/w-ing *small* functions,
179 because they'll inline anyway. But we must take care: it may look
180 small now, but get to be big later after other inling has happened.
181 So we take the precaution of adding an INLINE pragma to any such
184 I made this change when I observed a big function at the end of
185 compilation with a useful strictness signature but no w-w. When
186 I measured it on nofib, it didn't make much difference; just a few
187 percent improved allocation on one benchmark (bspt/Euclid.space).
188 But nothing got worse.
193 -> Id -- The fn binder
194 -> CoreExpr -- The bound rhs; its innards
196 -> UniqSM [(Id, CoreExpr)] -- either *one* or *two* pairs;
197 -- if one, then no worker (only
198 -- the orig "wrapper" lives on);
199 -- if two, then a worker and a
201 tryWW is_rec fn_id rhs
202 | isNeverActive inline_act
203 -- No point in worker/wrappering if the thing is never inlined!
204 -- Because the no-inline prag will prevent the wrapper ever
205 -- being inlined at a call site.
207 -- Furthermore, don't even expose strictness info
208 = return [ (fn_id, rhs) ]
210 | is_thunk && worthSplittingThunk maybe_fn_dmd res_info
211 = ASSERT2( isNonRec is_rec, ppr new_fn_id ) -- The thunk must be non-recursive
212 checkSize new_fn_id rhs $
213 splitThunk new_fn_id rhs
215 | is_fun && worthSplittingFun wrap_dmds res_info
216 = checkSize new_fn_id rhs $
217 splitFun new_fn_id fn_info wrap_dmds res_info inline_act rhs
220 = return [ (new_fn_id, rhs) ]
223 fn_info = idInfo fn_id
224 maybe_fn_dmd = newDemandInfo fn_info
225 inline_act = inlinePragmaActivation (inlinePragInfo fn_info)
227 -- In practice it always will have a strictness
228 -- signature, even if it's a uninformative one
229 strict_sig = newStrictnessInfo fn_info `orElse` topSig
230 StrictSig (DmdType env wrap_dmds res_info) = strict_sig
232 -- new_fn_id has the DmdEnv zapped.
233 -- (a) it is never used again
234 -- (b) it wastes space
235 -- (c) it becomes incorrect as things are cloned, because
236 -- we don't push the substitution into it
237 new_fn_id | isEmptyVarEnv env = fn_id
238 | otherwise = fn_id `setIdNewStrictness`
239 StrictSig (mkTopDmdType wrap_dmds res_info)
241 is_fun = notNull wrap_dmds
242 is_thunk = not is_fun && not (exprIsHNF rhs)
244 ---------------------
245 checkSize :: Id -> CoreExpr -> UniqSM [(Id,CoreExpr)] -> UniqSM [(Id,CoreExpr)]
246 -- See Note [Don't w/w inline things (a) and (b)]
247 checkSize fn_id rhs thing_inside
248 | certainlyWillInline unfolding = return [ (fn_id, mkInlineMe rhs) ]
249 -- Note [Don't w/w inline things (b)]
250 | otherwise = thing_inside
252 unfolding = idUnfolding fn_id
254 ---------------------
255 splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> Activation -> Expr Var
256 -> UniqSM [(Id, CoreExpr)]
257 splitFun fn_id fn_info wrap_dmds res_info inline_act rhs
258 = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) )
260 -- The arity should match the signature
261 (work_demands, wrap_fn, work_fn) <- mkWwBodies fun_ty wrap_dmds res_info one_shots
262 ; work_uniq <- getUniqueM
264 work_rhs = work_fn rhs
265 work_id = mkWorkerId work_uniq fn_id (exprType work_rhs)
266 `setInlineActivation` inline_act
267 -- Any inline activation (which sets when inlining is active)
268 -- on the original function is duplicated on the worker and wrapper
269 -- It *matters* that the pragma stays on the wrapper
270 -- It seems sensible to have it on the worker too, although we
271 -- can't think of a compelling reason. (In ptic, INLINE things are
272 -- not w/wd). However, the RuleMatchInfo is not transferred since
273 -- it does not make sense for workers to be constructorlike.
274 `setIdNewStrictness` StrictSig (mkTopDmdType work_demands work_res_info)
275 -- Even though we may not be at top level,
276 -- it's ok to give it an empty DmdEnv
277 `setIdArity` (exprArity work_rhs)
278 -- Set the arity so that the Core Lint check that the
279 -- arity is consistent with the demand type goes through
281 wrap_rhs = wrap_fn work_id
282 wrap_id = fn_id `setIdWorkerInfo` HasWorker work_id arity
284 ; return ([(work_id, work_rhs), (wrap_id, wrap_rhs)]) })
285 -- Worker first, because wrapper mentions it
286 -- mkWwBodies has already built a wrap_rhs with an INLINE pragma wrapped around it
288 fun_ty = idType fn_id
290 arity = arityInfo fn_info -- The arity is set by the simplifier using exprEtaExpandArity
291 -- So it may be more than the number of top-level-visible lambdas
293 work_res_info | isBotRes res_info = BotRes -- Cpr stuff done by wrapper
296 one_shots = get_one_shots rhs
298 -- If the original function has one-shot arguments, it is important to
299 -- make the wrapper and worker have corresponding one-shot arguments too.
300 -- Otherwise we spuriously float stuff out of case-expression join points,
301 -- which is very annoying.
302 get_one_shots :: Expr Var -> [Bool]
303 get_one_shots (Lam b e)
304 | isId b = isOneShotLambda b : get_one_shots e
305 | otherwise = get_one_shots e
306 get_one_shots (Note _ e) = get_one_shots e
307 get_one_shots _ = noOneShotInfo
312 Suppose x is used strictly (never mind whether it has the CPR
319 splitThunk transforms like this:
322 x* = case x-rhs of { I# a -> I# a }
325 Now simplifier will transform to
328 I# a -> let x* = I# a
331 which is what we want. Now suppose x-rhs is itself a case:
333 x-rhs = case e of { T -> I# a; F -> I# b }
335 The join point will abstract over a, rather than over (which is
336 what would have happened before) which is fine.
338 Notice that x certainly has the CPR property now!
340 In fact, splitThunk uses the function argument w/w splitting
341 function, so that if x's demand is deeper (say U(U(L,L),L))
342 then the splitting will go deeper too.
345 -- splitThunk converts the *non-recursive* binding
350 -- I# y -> let x = I# y in x }
351 -- See comments above. Is it not beautifully short?
353 splitThunk :: Var -> Expr Var -> UniqSM [(Var, Expr Var)]
354 splitThunk fn_id rhs = do
355 (_, wrap_fn, work_fn) <- mkWWstr [fn_id]
356 return [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ]
360 %************************************************************************
362 \subsection{Functions over Demands}
364 %************************************************************************
367 worthSplittingFun :: [Demand] -> DmdResult -> Bool
368 -- True <=> the wrapper would not be an identity function
369 worthSplittingFun ds res
370 = any worth_it ds || returnsCPR res
371 -- worthSplitting returns False for an empty list of demands,
372 -- and hence do_strict_ww is False if arity is zero and there is no CPR
373 -- See Note [Worker-wrapper for bottoming functions]
375 worth_it Abs = True -- Absent arg
376 worth_it (Eval (Prod _)) = True -- Product arg to evaluate
379 worthSplittingThunk :: Maybe Demand -- Demand on the thunk
380 -> DmdResult -- CPR info for the thunk
382 worthSplittingThunk maybe_dmd res
383 = worth_it maybe_dmd || returnsCPR res
385 -- Split if the thing is unpacked
386 worth_it (Just (Eval (Prod ds))) = not (all isAbsent ds)
390 Note [Worker-wrapper for bottoming functions]
391 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
392 We used not to split if the result is bottom.
393 [Justification: there's no efficiency to be gained.]
395 But it's sometimes bad not to make a wrapper. Consider
396 fw = \x# -> let x = I# x# in case e of
400 The re-boxing code won't go away unless error_fn gets a wrapper too.
401 [We don't do reboxing now, but in general it's better to pass an
402 unboxed thing to f, and have it reboxed in the error cases....]
405 %************************************************************************
407 \subsection{The worker wrapper core}
409 %************************************************************************
411 @mkWrapper@ is called when importing a function. We have the type of
412 the function and the name of its worker, and we want to make its body (the wrapper).
415 mkWrapper :: Type -- Wrapper type
416 -> StrictSig -- Wrapper strictness info
417 -> UniqSM (Id -> CoreExpr) -- Wrapper body, missing worker Id
419 mkWrapper fun_ty (StrictSig (DmdType _ demands res_info)) = do
420 (_, wrap_fn, _) <- mkWwBodies fun_ty demands res_info noOneShotInfo
423 noOneShotInfo :: [Bool]
424 noOneShotInfo = repeat False