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
9 #include "HsVersions.h"
12 import CoreUnfold ( certainlyWillInline )
13 import CoreUtils ( exprType, exprIsHNF )
14 import CoreArity ( exprArity )
16 import Id ( Id, idType, isOneShotLambda,
17 setIdNewStrictness, mkWorkerId,
18 setIdWorkerInfo, setInlineActivation,
20 import MkId ( lazyIdKey, lazyIdUnfolding )
23 import NewDemand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..),
24 Demands(..), mkTopDmdType, isBotRes, returnsCPR, topSig, isAbsent
27 import Unique ( hasKey )
28 import BasicTypes ( RecFlag(..), isNonRec, isNeverActive,
29 Activation, inlinePragmaActivation )
30 import VarEnv ( isEmptyVarEnv )
31 import Maybes ( orElse )
33 import Util ( lengthIs, notNull )
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]
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.)
188 -> Id -- The fn binder
189 -> CoreExpr -- The bound rhs; its innards
191 -> UniqSM [(Id, CoreExpr)] -- either *one* or *two* pairs;
192 -- if one, then no worker (only
193 -- the orig "wrapper" lives on);
194 -- if two, then a worker and a
196 tryWW is_rec fn_id rhs
197 | -- isNonRec is_rec && -- Now omitted: see Note [Don't w/w inline things]
198 certainlyWillInline unfolding
200 || isNeverActive inline_act
201 -- No point in worker/wrappering if the thing is never inlined!
202 -- Because the no-inline prag will prevent the wrapper ever
203 -- being inlined at a call site.
204 = return [ (new_fn_id, rhs) ]
206 | is_thunk && worthSplittingThunk maybe_fn_dmd res_info
207 = ASSERT2( isNonRec is_rec, ppr new_fn_id ) -- The thunk must be non-recursive
208 splitThunk new_fn_id rhs
210 | is_fun && worthSplittingFun wrap_dmds res_info
211 = splitFun new_fn_id fn_info wrap_dmds res_info inline_act rhs
214 = return [ (new_fn_id, rhs) ]
217 fn_info = idInfo fn_id
218 maybe_fn_dmd = newDemandInfo fn_info
219 unfolding = unfoldingInfo fn_info
220 inline_act = inlinePragmaActivation (inlinePragInfo fn_info)
222 -- In practice it always will have a strictness
223 -- signature, even if it's a uninformative one
224 strict_sig = newStrictnessInfo fn_info `orElse` topSig
225 StrictSig (DmdType env wrap_dmds res_info) = strict_sig
227 -- new_fn_id has the DmdEnv zapped.
228 -- (a) it is never used again
229 -- (b) it wastes space
230 -- (c) it becomes incorrect as things are cloned, because
231 -- we don't push the substitution into it
232 new_fn_id | isEmptyVarEnv env = fn_id
233 | otherwise = fn_id `setIdNewStrictness`
234 StrictSig (mkTopDmdType wrap_dmds res_info)
236 is_fun = notNull wrap_dmds
237 is_thunk = not is_fun && not (exprIsHNF rhs)
239 ---------------------
240 splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> Activation -> Expr Var
241 -> UniqSM [(Id, CoreExpr)]
242 splitFun fn_id fn_info wrap_dmds res_info inline_act rhs
243 = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) )
245 -- The arity should match the signature
246 (work_demands, wrap_fn, work_fn) <- mkWwBodies fun_ty wrap_dmds res_info one_shots
247 ; work_uniq <- getUniqueM
249 work_rhs = work_fn rhs
250 work_id = mkWorkerId work_uniq fn_id (exprType work_rhs)
251 `setInlineActivation` inline_act
252 -- Any inline activation (which sets when inlining is active)
253 -- on the original function is duplicated on the worker and wrapper
254 -- It *matters* that the pragma stays on the wrapper
255 -- It seems sensible to have it on the worker too, although we
256 -- can't think of a compelling reason. (In ptic, INLINE things are
257 -- not w/wd). However, the RuleMatchInfo is not transferred since
258 -- it does not make sense for workers to be constructorlike.
259 `setIdNewStrictness` StrictSig (mkTopDmdType work_demands work_res_info)
260 -- Even though we may not be at top level,
261 -- it's ok to give it an empty DmdEnv
262 `setIdArity` (exprArity work_rhs)
263 -- Set the arity so that the Core Lint check that the
264 -- arity is consistent with the demand type goes through
266 wrap_rhs = wrap_fn work_id
267 wrap_id = fn_id `setIdWorkerInfo` HasWorker work_id arity
269 ; return ([(work_id, work_rhs), (wrap_id, wrap_rhs)]) })
270 -- Worker first, because wrapper mentions it
271 -- mkWwBodies has already built a wrap_rhs with an INLINE pragma wrapped around it
273 fun_ty = idType fn_id
275 arity = arityInfo fn_info -- The arity is set by the simplifier using exprEtaExpandArity
276 -- So it may be more than the number of top-level-visible lambdas
278 work_res_info | isBotRes res_info = BotRes -- Cpr stuff done by wrapper
281 one_shots = get_one_shots rhs
283 -- If the original function has one-shot arguments, it is important to
284 -- make the wrapper and worker have corresponding one-shot arguments too.
285 -- Otherwise we spuriously float stuff out of case-expression join points,
286 -- which is very annoying.
287 get_one_shots :: Expr Var -> [Bool]
288 get_one_shots (Lam b e)
289 | isId b = isOneShotLambda b : get_one_shots e
290 | otherwise = get_one_shots e
291 get_one_shots (Note _ e) = get_one_shots e
292 get_one_shots _ = noOneShotInfo
297 Suppose x is used strictly (never mind whether it has the CPR
304 splitThunk transforms like this:
307 x* = case x-rhs of { I# a -> I# a }
310 Now simplifier will transform to
313 I# a -> let x* = I# a
316 which is what we want. Now suppose x-rhs is itself a case:
318 x-rhs = case e of { T -> I# a; F -> I# b }
320 The join point will abstract over a, rather than over (which is
321 what would have happened before) which is fine.
323 Notice that x certainly has the CPR property now!
325 In fact, splitThunk uses the function argument w/w splitting
326 function, so that if x's demand is deeper (say U(U(L,L),L))
327 then the splitting will go deeper too.
330 -- splitThunk converts the *non-recursive* binding
335 -- I# y -> let x = I# y in x }
336 -- See comments above. Is it not beautifully short?
338 splitThunk :: Var -> Expr Var -> UniqSM [(Var, Expr Var)]
339 splitThunk fn_id rhs = do
340 (_, wrap_fn, work_fn) <- mkWWstr [fn_id]
341 return [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ]
345 %************************************************************************
347 \subsection{Functions over Demands}
349 %************************************************************************
352 worthSplittingFun :: [Demand] -> DmdResult -> Bool
353 -- True <=> the wrapper would not be an identity function
354 worthSplittingFun ds res
355 = any worth_it ds || returnsCPR res
356 -- worthSplitting returns False for an empty list of demands,
357 -- and hence do_strict_ww is False if arity is zero and there is no CPR
358 -- See Note [Worker-wrapper for bottoming functions]
360 worth_it Abs = True -- Absent arg
361 worth_it (Eval (Prod _)) = True -- Product arg to evaluate
364 worthSplittingThunk :: Maybe Demand -- Demand on the thunk
365 -> DmdResult -- CPR info for the thunk
367 worthSplittingThunk maybe_dmd res
368 = worth_it maybe_dmd || returnsCPR res
370 -- Split if the thing is unpacked
371 worth_it (Just (Eval (Prod ds))) = not (all isAbsent ds)
375 Note [Worker-wrapper for bottoming functions]
376 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
377 We used not to split if the result is bottom.
378 [Justification: there's no efficiency to be gained.]
380 But it's sometimes bad not to make a wrapper. Consider
381 fw = \x# -> let x = I# x# in case e of
385 The re-boxing code won't go away unless error_fn gets a wrapper too.
386 [We don't do reboxing now, but in general it's better to pass an
387 unboxed thing to f, and have it reboxed in the error cases....]
390 %************************************************************************
392 \subsection{The worker wrapper core}
394 %************************************************************************
396 @mkWrapper@ is called when importing a function. We have the type of
397 the function and the name of its worker, and we want to make its body (the wrapper).
400 mkWrapper :: Type -- Wrapper type
401 -> StrictSig -- Wrapper strictness info
402 -> UniqSM (Id -> CoreExpr) -- Wrapper body, missing worker Id
404 mkWrapper fun_ty (StrictSig (DmdType _ demands res_info)) = do
405 (_, wrap_fn, _) <- mkWwBodies fun_ty demands res_info noOneShotInfo
408 noOneShotInfo :: [Bool]
409 noOneShotInfo = repeat False