2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[WwLib]{A library for the ``worker/wrapper'' back-end to the strictness analyser}
7 #include "HsVersions.h"
12 mkWwBodies, mAX_WORKER_ARGS
18 import Id ( idType, mkSysLocal, dataConArgTys )
19 import IdInfo ( mkStrictnessInfo, nonAbsentArgs, Demand(..) )
20 import PrelVals ( aBSENT_ERROR_ID )
21 import SrcLoc ( noSrcLoc )
22 import Type ( isPrimType, mkTyVarTys, mkForAllTys, mkFunTys,
23 maybeAppDataTyConExpandingDicts
25 import UniqSupply ( returnUs, thenUs, thenMaybeUs,
26 getUniques, SYN_IE(UniqSM)
28 import Util ( zipWithEqual, assertPanic, panic )
31 %************************************************************************
33 \subsection[datatype-WwLib]{@WwBinding@: a datatype for worker/wrapper-ing}
35 %************************************************************************
37 In the worker/wrapper stuff, we want to carry around @CoreBindings@ in
38 an ``intermediate form'' that can later be turned into a \tr{let} or
39 \tr{case} (depending on strictness info).
44 | WwCase (CoreExpr -> CoreExpr)
45 -- the "case" will be a "strict let" of the form:
50 -- (instead of "let <blah> = rhs in body")
52 -- The expr you pass to the function is "body" (the
53 -- expression that goes "in the corner").
56 %************************************************************************
58 \subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}
60 %************************************************************************
62 ************ WARNING ******************
63 these comments are rather out of date
64 *****************************************
66 @mkWrapperAndWorker@ is given:
69 The {\em original function} \tr{f}, of the form:
71 f = /\ tyvars -> \ args -> body
73 The original-binder \tr{f}, the \tr{tyvars}, \tr{args}, and \tr{body}
76 We use the Id \tr{f} mostly to get its type.
79 Strictness information about \tr{f}, in the form of a list of
86 @mkWrapperAndWorker@ produces (A BIT OUT-OF-DATE...):
89 Maybe @Nothing@: no worker/wrappering going on in this case. This can
90 happen (a)~if the strictness info says that there is nothing
91 interesting to do or (b)~if *any* of the argument types corresponding
92 to ``active'' arg postitions is abstract or will be to the outside
93 world (i.e., {\em this} module can see the constructors, but nobody
94 else will be able to). An ``active'' arg position is one which the
95 wrapper has to unpack. An importing module can't do this unpacking,
96 so it simply has to give up and call the wrapper only.
99 Maybe \tr{Just (wrapper_Id, wrapper_body, worker_Id, worker_body)}.
101 The @wrapper_Id@ is just the one that was passed in, with its
102 strictness IdInfo updated.
105 The \tr{body} of the original function may not be given (i.e., it's
106 BOTTOM), in which case you'd jolly well better not tug on the
109 Here's an example. The original function is:
111 g :: forall a . Int -> [a] -> a
113 g = /\ a -> \ x ys ->
119 From this, we want to produce:
121 -- wrapper (an unfolding)
122 g :: forall a . Int -> [a] -> a
124 g = /\ a -> \ x ys ->
126 I# x# -> g.wrk a x# ys
127 -- call the worker; don't forget the type args!
130 g.wrk :: forall a . Int# -> [a] -> a
132 g.wrk = /\ a -> \ x# ys ->
136 case x of -- note: body of g moved intact
141 Something we have to be careful about: Here's an example:
143 -- "f" strictness: U(P)U(P)
144 f (I# a) (I# b) = a +# b
146 g = f -- "g" strictness same as "f"
148 \tr{f} will get a worker all nice and friendly-like; that's good.
149 {\em But we don't want a worker for \tr{g}}, even though it has the
150 same strictness as \tr{f}. Doing so could break laziness, at best.
152 Consequently, we insist that the number of strictness-info items is
153 exactly the same as the number of lambda-bound arguments. (This is
154 probably slightly paranoid, but OK in practice.) If it isn't the
155 same, we ``revise'' the strictness info, so that we won't propagate
156 the unusable strictness-info into the interfaces.
158 ==========================
160 Here's the real fun... The wrapper's ``deconstructing'' of arguments
161 and the worker's putting them back together again are ``duals'' in
164 What we do is walk along the @Demand@ list, producing two
165 expressions (one for wrapper, one for worker...), each with a ``hole''
166 in it, where we will later plug in more information. For our previous
167 example, the expressions-with-HOLES are:
171 I# x# -> <<HOLE>> x# ys
179 (Actually, we add the lambda-bound arguments at the end...) (The big
180 Lambdas are added on the front later.)
184 :: Type -- Type of the *body* of the orig
185 -- function; i.e. /\ tyvars -> \ vars -> body
186 -> [TyVar] -- Type lambda vars of original function
187 -> [Id] -- Args of original function
188 -> [Demand] -- Strictness info for those args
190 -> UniqSM (Maybe -- Nothing iff (a) no interesting split possible
191 -- (b) any unpack on abstract type
192 (Id -> CoreExpr, -- Wrapper expr w/
193 -- hole for worker id
194 CoreExpr -> CoreExpr, -- Worker expr w/ hole
195 -- for original fn body
196 StrictnessInfo Id, -- Worker strictness info
197 Type -> Type) -- Worker type w/ hole
198 ) -- for type of original fn body
201 mkWwBodies body_ty tyvars args arg_infos
202 = ASSERT(length args == length arg_infos)
203 -- or you can get disastrous user/definer-module mismatches
204 if (all_absent_args_and_unboxed_value body_ty arg_infos)
205 then returnUs Nothing
208 mk_ww_arg_processing args arg_infos
209 False -- Initialise the "useful-split" flag
210 (mAX_WORKER_ARGS - nonAbsentArgs arg_infos)
211 `thenMaybeUs` \ (wrap_frag, work_args_info, work_frag) ->
213 (work_args, wrkr_demands) = unzip work_args_info
215 wrkr_strictness = mkStrictnessInfo wrkr_demands Nothing -- no worker-of-worker...
217 wrapper_w_hole = \ worker_id ->
220 mkTyApp (Var worker_id) (mkTyVarTys tyvars)
223 worker_w_hole = \ orig_body ->
224 mkLam tyvars work_args (
228 worker_ty_w_hole = \ body_ty ->
230 mkFunTys (map idType work_args) body_ty
232 returnUs (Just (wrapper_w_hole, worker_w_hole, wrkr_strictness, worker_ty_w_hole))
234 -- "all_absent_args_and_unboxed_value":
235 -- check for the obscure case of "\ x y z ... -> body" where
236 -- (a) *all* of the args x, y, z,... are absent, and
237 -- (b) the type of body is unboxed
238 -- If these conditions are true, we must *not* play worker/wrapper games!
240 all_absent_args_and_unboxed_value body_ty arg_infos
241 = not (null arg_infos)
242 && all is_absent_arg arg_infos
243 && isPrimType body_ty
245 is_absent_arg (WwLazy True) = True
246 is_absent_arg _ = False
249 Important: mk_ww_arg_processing doesn't check
250 for an "interesting" split. It just races ahead and makes the
251 split, even if there's no unpacking at all. This is important for
252 when it calls itself recursively.
254 It returns Nothing only if it encounters an abstract type in mid-flight.
257 mAX_WORKER_ARGS :: Int -- ToDo: set via flag
258 mAX_WORKER_ARGS = 6 -- Hmm... but this is an everything-must-
259 -- be-compiled-with-the-same-val thing...
262 :: [Id] -- Args of original function
263 -> [Demand] -- Strictness info for those args
264 -- must be at least as long as args
266 -> Bool -- False <=> we've done nothing useful in an enclosing call
267 -- If this is False when we hit the end of the arg list, we
268 -- don't want to do a w/w split... the wrapper would be the identity fn!
269 -- So we return Nothing
271 -> Int -- Number of extra args we are prepared to add.
272 -- This prevents over-eager unpacking, leading
273 -- to huge-arity functions.
275 -> UniqSM (Maybe -- Nothing iff any unpack on abstract type
276 -- or if the wrapper would be the identity fn (can happen if we unpack
277 -- a huge structure, and decide not to do it)
279 (CoreExpr -> CoreExpr, -- Wrapper expr w/
280 -- hole for worker id
282 [(Id,Demand)], -- Worker's args
283 -- and their strictness info
284 CoreExpr -> CoreExpr) -- Worker body expr w/ hole
285 ) -- for original fn body
287 mk_ww_arg_processing [] _ useful_split _ = if useful_split then
288 returnUs (Just (id, [], id))
292 mk_ww_arg_processing (arg : args) (WwLazy True : infos) useful_split max_extra_args
294 -- So, finish args to the right...
295 --pprTrace "Absent; num_wrkr_args=" (ppInt num_wrkr_args) (
299 mk_ww_arg_processing args infos True {- useful split -} max_extra_args
300 -- We've already discounted for absent args,
301 -- so we don't change max_extra_args
302 `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
304 -- wrapper doesn't pass this arg to worker:
307 \ hole -> wrap_rest hole,
310 work_args_info, -- NB: no argument added
311 \ hole -> mk_absent_let arg arg_ty (work_rest hole)
315 mk_absent_let arg arg_ty body
316 = if not (isPrimType arg_ty) then
317 Let (NonRec arg (mkTyApp (Var aBSENT_ERROR_ID) [arg_ty])) body
318 else -- quite horrible
319 panic "WwLib: haven't done mk_absent_let for primitives yet"
322 mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) useful_split max_extra_args
323 | new_max_extra_args > 0 -- Check that we are prepared to add arguments
324 = -- this is the complicated one.
325 --pprTrace "Unpack; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr "; new_max=", ppInt new_num_wrkr_args, ppStr "; arg=", ppr PprDebug arg, ppr PprDebug (WwUnpack cmpnt_infos)]) $
327 case (maybeAppDataTyConExpandingDicts arg_ty) of
329 Nothing -> -- Not a data type
330 panic "mk_ww_arg_processing: not datatype"
332 Just (_, _, []) -> -- An abstract type
333 -- We have to give up on the whole idea
336 Just (_, _, (_:_:_)) -> -- Two or more constructors; that's odd
337 panic "mk_ww_arg_processing: multi-constr"
339 Just (arg_tycon, tycon_arg_tys, [data_con]) ->
340 -- The main event: a single-constructor data type
343 inst_con_arg_tys = dataConArgTys data_con tycon_arg_tys
345 getUniques (length inst_con_arg_tys) `thenUs` \ uniqs ->
348 unpk_args = zipWithEqual "mk_ww_arg_processing"
349 (\ u t -> mkSysLocal SLIT("upk") u t noSrcLoc)
350 uniqs inst_con_arg_tys
352 -- In processing the rest, push the sub-component args
353 -- and infos on the front of the current bunch
354 mk_ww_arg_processing (unpk_args ++ args) (cmpnt_infos ++ infos) True {- useful split -} new_max_extra_args
355 `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
358 -- wrapper: unpack the value
359 \ hole -> mk_unpk_case arg unpk_args
363 -- worker: expect the unpacked value;
364 -- reconstruct the orig value with a "let"
366 \ hole -> work_rest (mk_pk_let arg data_con tycon_arg_tys unpk_args hole)
373 + 1 -- We won't pass the original arg now
374 - nonAbsentArgs cmpnt_infos -- But we will pass an arg for each cmpt
376 mk_unpk_case arg unpk_args boxing_con boxing_tycon body
378 AlgAlts [(boxing_con, unpk_args, body)]
382 mk_pk_let arg boxing_con con_tys unpk_args body
383 = Let (NonRec arg (Con boxing_con
384 (map TyArg con_tys ++ map VarArg unpk_args)))
387 mk_ww_arg_processing (arg : args) (arg_demand : infos) useful_split max_extra_args
389 = -- For all others at the moment, we just
390 -- pass them to the worker unchanged.
391 --pprTrace "Other; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr ";arg=", ppr PprDebug arg, ppr PprDebug arg_demand]) (
393 -- Finish args to the right...
394 mk_ww_arg_processing args infos useful_split max_extra_args
395 `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
399 \ hole -> wrap_rest (App hole (VarArg arg)),
402 (arg, arg_demand) : work_args_info,
403 \ hole -> work_rest hole
407 nonAbsentArgs :: [Demand] -> Int
408 nonAbsentArgs cmpts = length [() | WwLazy True <- cmpts]