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, getWorkerId ) where
9 #include "HsVersions.h"
12 import CoreUnfold ( Unfolding, certainlySmallEnoughToInline, calcUnfoldingGuidance )
13 import CmdLineOpts ( opt_UF_CreationThreshold , opt_D_verbose_core2core,
14 opt_D_dump_worker_wrapper
16 import CoreLint ( beginPass, endPass )
17 import CoreUtils ( coreExprType )
18 import Const ( Con(..) )
19 import DataCon ( DataCon )
20 import MkId ( mkWorkerId )
21 import Id ( Id, getIdStrictness, setIdArity,
23 setIdWorkerInfo, getIdCprInfo )
25 import Type ( splitAlgTyConApp_maybe )
26 import IdInfo ( mkStrictnessInfo, noStrictnessInfo, StrictnessInfo(..),
27 CprInfo(..), exactArity
29 import Demand ( wwLazy )
31 import UniqSupply ( UniqSupply, initUs_, returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
37 We take Core bindings whose binders have:
41 \item Strictness attached (by the front-end of the strictness
44 \item Constructed Product Result information attached by the CPR
49 and we return some ``plain'' bindings which have been
50 worker/wrapper-ified, meaning:
54 \item Functions have been split into workers and wrappers where
55 appropriate. If a function has both strictness and CPR properties
56 then only one worker/wrapper doing both transformations is produced;
58 \item Binders' @IdInfos@ have been updated to reflect the existence of
59 these workers/wrappers (this is where we get STRICTNESS and CPR pragma
60 info for exported values).
65 wwTopBinds :: UniqSupply
71 beginPass "Worker Wrapper binds";
73 -- Create worker/wrappers, and mark binders with their
74 -- "strictness info" [which encodes their worker/wrapper-ness]
75 let { binds' = workersAndWrappers us binds };
77 endPass "Worker Wrapper binds" (opt_D_dump_worker_wrapper ||
78 opt_D_verbose_core2core) binds'
84 workersAndWrappers :: UniqSupply -> [CoreBind] -> [CoreBind]
86 workersAndWrappers us top_binds
88 mapUs (wwBind True{-top-level-}) top_binds `thenUs` \ top_binds2 ->
90 top_binds3 = map make_top_binding top_binds2
92 returnUs (concat top_binds3)
94 make_top_binding :: WwBinding -> [CoreBind]
96 make_top_binding (WwLet binds) = binds
99 %************************************************************************
101 \subsection[wwBind-wwExpr]{@wwBind@ and @wwExpr@}
103 %************************************************************************
105 @wwBind@ works on a binding, trying each \tr{(binder, expr)} pair in
106 turn. Non-recursive case first, then recursive...
109 wwBind :: Bool -- True <=> top-level binding
111 -> UniqSM WwBinding -- returns a WwBinding intermediate form;
112 -- the caller will convert to Expr/Binding,
115 wwBind top_level (NonRec binder rhs)
116 = wwExpr rhs `thenUs` \ new_rhs ->
117 tryWW True {- non-recursive -} binder new_rhs `thenUs` \ new_pairs ->
118 returnUs (WwLet [NonRec b e | (b,e) <- new_pairs])
119 -- Generated bindings must be non-recursive
120 -- because the original binding was.
122 ------------------------------
124 wwBind top_level (Rec pairs)
125 = mapUs do_one pairs `thenUs` \ new_pairs ->
126 returnUs (WwLet [Rec (concat new_pairs)])
128 do_one (binder, rhs) = wwExpr rhs `thenUs` \ new_rhs ->
129 tryWW False {- recursive -} binder new_rhs
132 @wwExpr@ basically just walks the tree, looking for appropriate
133 annotations that can be used. Remember it is @wwBind@ that does the
134 matching by looking for strict arguments of the correct type.
135 @wwExpr@ is a version that just returns the ``Plain'' Tree.
136 ???????????????? ToDo
139 wwExpr :: CoreExpr -> UniqSM CoreExpr
141 wwExpr e@(Type _) = returnUs e
142 wwExpr e@(Var _) = returnUs e
144 wwExpr e@(Con con args)
145 = mapUs wwExpr args `thenUs` \ args' ->
146 returnUs (Con con args')
148 wwExpr (Lam binder expr)
149 = wwExpr expr `thenUs` \ new_expr ->
150 returnUs (Lam binder new_expr)
153 = wwExpr f `thenUs` \ new_f ->
154 wwExpr a `thenUs` \ new_a ->
155 returnUs (App new_f new_a)
157 wwExpr (Note note expr)
158 = wwExpr expr `thenUs` \ new_expr ->
159 returnUs (Note note new_expr)
161 wwExpr (Let bind expr)
162 = wwBind False{-not top-level-} bind `thenUs` \ intermediate_bind ->
163 wwExpr expr `thenUs` \ new_expr ->
164 returnUs (mash_ww_bind intermediate_bind new_expr)
166 mash_ww_bind (WwLet binds) body = mkLets binds body
167 mash_ww_bind (WwCase case_fn) body = case_fn body
169 wwExpr (Case expr binder alts)
170 = wwExpr expr `thenUs` \ new_expr ->
171 mapUs ww_alt alts `thenUs` \ new_alts ->
172 returnUs (Case new_expr binder new_alts)
174 ww_alt (con, binders, rhs)
175 = wwExpr rhs `thenUs` \ new_rhs ->
176 returnUs (con, binders, new_rhs)
179 %************************************************************************
181 \subsection[tryWW]{@tryWW@: attempt a worker/wrapper pair}
183 %************************************************************************
185 @tryWW@ just accumulates arguments, converts strictness info from the
186 front-end into the proper form, then calls @mkWwBodies@ to do
189 We have to BE CAREFUL that we don't worker-wrapperize an Id that has
190 already been w-w'd! (You can end up with several liked-named Ids
191 bouncing around at the same time---absolute mischief.) So the
192 criterion we use is: if an Id already has an unfolding (for whatever
193 reason), then we don't w-w it.
195 The only reason this is monadised is for the unique supply.
198 tryWW :: Bool -- True <=> a non-recursive binding
199 -> Id -- The fn binder
200 -> CoreExpr -- The bound rhs; its innards
202 -> UniqSM [(Id, CoreExpr)] -- either *one* or *two* pairs;
203 -- if one, then no worker (only
204 -- the orig "wrapper" lives on);
205 -- if two, then a worker and a
207 tryWW non_rec fn_id rhs
208 | (non_rec && -- Don't split if its non-recursive and small
209 certainlySmallEnoughToInline unfold_guidance
211 -- No point in worker/wrappering something that is going to be
212 -- INLINEd wholesale anyway. If the strictness analyser is run
213 -- twice, this test also prevents wrappers (which are INLINEd)
214 -- from being re-done.
216 || not (do_strict_ww || do_cpr_ww)
217 = returnUs [ (fn_id, rhs) ]
219 | otherwise -- Do w/w split
221 (tyvars, wrap_args, body) = collectTyAndValBinders rhs
223 mkWwBodies tyvars wrap_args
225 revised_wrap_args_info
227 `thenUs` \ (wrap_fn, work_fn, work_demands) ->
228 getUniqueUs `thenUs` \ work_uniq ->
230 work_rhs = work_fn body
231 work_id = mkWorkerId work_uniq fn_id (coreExprType work_rhs) `setIdStrictness`
232 (if has_strictness_info then mkStrictnessInfo (work_demands, result_bot)
233 else noStrictnessInfo)
235 wrap_rhs = wrap_fn work_id
236 wrap_id = fn_id `setIdStrictness`
237 (if has_strictness_info then mkStrictnessInfo (revised_wrap_args_info, result_bot)
238 else noStrictnessInfo)
239 `setIdWorkerInfo` Just work_id
240 `setIdArity` exactArity (length wrap_args)
241 -- Add info to the wrapper:
242 -- (a) we want to inline it everywhere
243 -- (b) we want to pin on its revised strictness info
244 -- (c) we pin on its worker id
246 returnUs ([(work_id, work_rhs), (wrap_id, wrap_rhs)])
247 -- Worker first, because wrapper mentions it
249 strictness_info = getIdStrictness fn_id
250 has_strictness_info = case strictness_info of
251 StrictnessInfo _ _ -> True
254 StrictnessInfo wrap_args_info result_bot = strictness_info
256 revised_wrap_args_info = if has_strictness_info
257 then setUnpackStrategy wrap_args_info
260 do_strict_ww = has_strictness_info && worthSplitting revised_wrap_args_info result_bot
262 cpr_info = getIdCprInfo fn_id
263 has_cpr_info = case cpr_info of
267 do_cpr_ww = has_cpr_info
268 unfold_guidance = calcUnfoldingGuidance opt_UF_CreationThreshold rhs
270 -- This rather (nay! extremely!) crude function looks at a wrapper function, and
271 -- snaffles out the worker Id from the wrapper.
272 -- This is needed when we write an interface file.
273 -- [May 1999: we used to get the constructors too, but that's no longer
274 -- necessary, because the renamer hauls in all type decls in
277 -- <Mar 1999 (keving)> - Well, since the addition of the CPR transformation this function
279 -- Now the worker id is stored directly in the id's Info field. We still use this function to
280 -- snaffle the wrapper's constructors but I don't trust the code to find the worker id.
281 getWorkerId :: Id -> CoreExpr -> Id
282 getWorkerId wrap_id wrapper_fn
287 = case get_work_id wrapper_fn of
288 [] -> case work_id_try2 wrapper_fn of
289 [] -> pprPanic "getWorkerId: can't find worker id" (ppr wrap_id)
291 _ -> pprPanic "getWorkerId: found too many worker ids" (ppr wrap_id)
293 _ -> pprPanic "getWorkerId: found too many worker ids" (ppr wrap_id)
295 get_work_id (Lam _ body) = get_work_id body
296 get_work_id (Case _ _ [(_,_,rhs@(Case _ _ _))]) = get_work_id rhs
297 get_work_id (Case scrut _ [(_,_,rhs)]) = (get_work_id scrut) ++ (get_work_id rhs)
298 get_work_id (Note _ body) = get_work_id body
299 get_work_id (Let _ body) = get_work_id body
300 get_work_id (App (Var work_id) _) = [work_id]
301 get_work_id (App fn _) = get_work_id fn
302 get_work_id (Var work_id) = []
303 get_work_id other = []
305 work_id_try2 (Lam _ body) = work_id_try2 body
306 work_id_try2 (Note _ body) = work_id_try2 body
307 work_id_try2 (Let _ body) = work_id_try2 body
308 work_id_try2 (App fn _) = work_id_try2 fn
309 work_id_try2 (Var work_id) = [work_id]
310 work_id_try2 other = []