2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser}
7 #include "HsVersions.h"
9 module WorkWrap ( workersAndWrappers ) where
14 import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..), SimpleUnfolding )
15 import MagicUFs ( MagicUnfoldingFun )
17 import CoreUtils ( coreExprType )
18 import Id ( idWantsToBeINLINEd, getIdStrictness, mkWorkerId,
19 addIdStrictness, addInlinePragma,
22 import IdInfo ( noIdInfo, addInfo_UF, indicatesWorker,
23 mkStrictnessInfo, StrictnessInfo(..)
26 import UniqSupply ( returnUs, thenUs, mapUs, getUnique, SYN_IE(UniqSM) )
30 We take Core bindings whose binders have their strictness attached (by
31 the front-end of the strictness analyser), and we return some
32 ``plain'' bindings which have been worker/wrapper-ified, meaning:
35 Functions have been split into workers and wrappers where appropriate;
37 Binders' @IdInfos@ have been updated to reflect the existence
38 of these workers/wrappers (this is where we get STRICTNESS pragma
39 info for exported values).
43 workersAndWrappers :: [CoreBinding] -> UniqSM [CoreBinding]
45 workersAndWrappers top_binds
46 = mapUs (wwBind True{-top-level-}) top_binds `thenUs` \ top_binds2 ->
48 top_binds3 = map make_top_binding top_binds2
50 returnUs (concat top_binds3)
52 make_top_binding :: WwBinding -> [CoreBinding]
54 make_top_binding (WwLet binds) = binds
57 %************************************************************************
59 \subsection[wwBind-wwExpr]{@wwBind@ and @wwExpr@}
61 %************************************************************************
63 @wwBind@ works on a binding, trying each \tr{(binder, expr)} pair in
64 turn. Non-recursive case first, then recursive...
67 wwBind :: Bool -- True <=> top-level binding
69 -> UniqSM WwBinding -- returns a WwBinding intermediate form;
70 -- the caller will convert to Expr/Binding,
73 wwBind top_level (NonRec binder rhs)
74 = wwExpr rhs `thenUs` \ new_rhs ->
75 tryWW binder new_rhs `thenUs` \ new_pairs ->
76 returnUs (WwLet [NonRec b e | (b,e) <- new_pairs])
77 -- Generated bindings must be non-recursive
78 -- because the original binding was.
80 ------------------------------
82 wwBind top_level (Rec pairs)
83 = mapUs do_one pairs `thenUs` \ new_pairs ->
84 returnUs (WwLet [Rec (concat new_pairs)])
86 do_one (binder, rhs) = wwExpr rhs `thenUs` \ new_rhs ->
90 @wwExpr@ basically just walks the tree, looking for appropriate
91 annotations that can be used. Remember it is @wwBind@ that does the
92 matching by looking for strict arguments of the correct type.
93 @wwExpr@ is a version that just returns the ``Plain'' Tree.
97 wwExpr :: CoreExpr -> UniqSM CoreExpr
99 wwExpr e@(Var _) = returnUs e
100 wwExpr e@(Lit _) = returnUs e
101 wwExpr e@(Con _ _) = returnUs e
102 wwExpr e@(Prim _ _) = returnUs e
104 wwExpr (Lam binder expr)
105 = wwExpr expr `thenUs` \ new_expr ->
106 returnUs (Lam binder new_expr)
109 = wwExpr f `thenUs` \ new_f ->
110 returnUs (App new_f a)
113 = wwExpr expr `thenUs` \ new_expr ->
114 returnUs (SCC cc new_expr)
116 wwExpr (Coerce c ty expr)
117 = wwExpr expr `thenUs` \ new_expr ->
118 returnUs (Coerce c ty new_expr)
120 wwExpr (Let bind expr)
121 = wwBind False{-not top-level-} bind `thenUs` \ intermediate_bind ->
122 wwExpr expr `thenUs` \ new_expr ->
123 returnUs (mash_ww_bind intermediate_bind new_expr)
125 mash_ww_bind (WwLet binds) body = mkCoLetsNoUnboxed binds body
126 mash_ww_bind (WwCase case_fn) body = case_fn body
128 wwExpr (Case expr alts)
129 = wwExpr expr `thenUs` \ new_expr ->
130 ww_alts alts `thenUs` \ new_alts ->
131 returnUs (Case new_expr new_alts)
133 ww_alts (AlgAlts alts deflt)
134 = mapUs ww_alg_alt alts `thenUs` \ new_alts ->
135 ww_deflt deflt `thenUs` \ new_deflt ->
136 returnUs (AlgAlts new_alts new_deflt)
138 ww_alts (PrimAlts alts deflt)
139 = mapUs ww_prim_alt alts `thenUs` \ new_alts ->
140 ww_deflt deflt `thenUs` \ new_deflt ->
141 returnUs (PrimAlts new_alts new_deflt)
143 ww_alg_alt (con, binders, rhs)
144 = wwExpr rhs `thenUs` \ new_rhs ->
145 returnUs (con, binders, new_rhs)
147 ww_prim_alt (lit, rhs)
148 = wwExpr rhs `thenUs` \ new_rhs ->
149 returnUs (lit, new_rhs)
154 ww_deflt (BindDefault binder rhs)
155 = wwExpr rhs `thenUs` \ new_rhs ->
156 returnUs (BindDefault binder new_rhs)
159 %************************************************************************
161 \subsection[tryWW]{@tryWW@: attempt a worker/wrapper pair}
163 %************************************************************************
165 @tryWW@ just accumulates arguments, converts strictness info from the
166 front-end into the proper form, then calls @mkWwBodies@ to do
169 We have to BE CAREFUL that we don't worker-wrapperize an Id that has
170 already been w-w'd! (You can end up with several liked-named Ids
171 bouncing around at the same time---absolute mischief.) So the
172 criterion we use is: if an Id already has an unfolding (for whatever
173 reason), then we don't w-w it.
175 The only reason this is monadised is for the unique supply.
178 tryWW :: Id -- the fn binder
179 -> CoreExpr -- the bound rhs; its innards
181 -> UniqSM [(Id, CoreExpr)] -- either *one* or *two* pairs;
182 -- if one, then no worker (only
183 -- the orig "wrapper" lives on);
184 -- if two, then a worker and a
187 | idWantsToBeINLINEd fn_id
188 -- No point in worker/wrappering something that is going to be
189 -- INLINEd wholesale anyway. If the strictness analyser is run
190 -- twice, this test also prevents wrappers (which are INLINEd)
191 -- from being re-done.
195 = case (getIdStrictness fn_id) of
197 NoStrictnessInfo -> do_nothing
198 BottomGuaranteed -> do_nothing
199 StrictnessInfo [] _ -> do_nothing -- V weird (but possible?)
201 StrictnessInfo args_info _ ->
202 if not (indicatesWorker args_info) then
206 -- OK, it looks as if a worker is worth a try
208 (uvars, tyvars, args, body) = collectBinders rhs
209 body_ty = coreExprType body
211 mkWwBodies body_ty tyvars args args_info `thenUs` \ result ->
214 Nothing -> -- Very peculiar. This can only happen if we hit an
215 -- abstract type, which we shouldn't have since we've
216 -- constructed the args_info in this module!
218 -- False. We might hit the all-args-absent-and-the-
219 -- body-is-unboxed case. A Nothing is legit. (WDP 94/10)
222 Just (wrapper_w_hole, worker_w_hole, worker_strictness, worker_ty_w_hole) ->
224 -- Terrific! It worked!
225 getUnique `thenUs` \ worker_uniq ->
227 worker_ty = worker_ty_w_hole body_ty
229 worker_id = mkWorkerId worker_uniq fn_id worker_ty
230 (noIdInfo `addInfo` worker_strictness)
232 wrapper_rhs = wrapper_w_hole worker_id
233 worker_rhs = worker_w_hole body
235 revised_strictness_info
236 = -- We know the basic strictness info already, but
237 -- we need to slam in the exact identity of the
239 mkStrictnessInfo args_info (Just worker_id)
241 wrapper_id = addInlinePragma (fn_id `addIdStrictness`
242 revised_strictness_info)
243 -- NB the "addInlinePragma" part; we want to inline wrappers everywhere
245 returnUs [ (worker_id, worker_rhs), -- worker comes first
246 (wrapper_id, wrapper_rhs) ] -- because wrapper mentions it
248 do_nothing = returnUs [ (fn_id, rhs) ]