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 ( mkUnknownSrcLoc )
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, -- 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 (mAX_WORKER_ARGS - nonAbsentArgs arg_infos)
209 `thenMaybeUs` \ (wrap_frag, work_args_info, work_frag) ->
211 (work_args, wrkr_demands) = unzip work_args_info
213 wrkr_strictness = mkStrictnessInfo wrkr_demands Nothing -- no worker-of-worker...
215 wrapper_w_hole = \ worker_id ->
218 mkTyApp (Var worker_id) (mkTyVarTys tyvars)
221 worker_w_hole = \ orig_body ->
222 mkLam tyvars work_args (
226 worker_ty_w_hole = \ body_ty ->
228 mkFunTys (map idType work_args) body_ty
230 returnUs (Just (wrapper_w_hole, worker_w_hole, wrkr_strictness, worker_ty_w_hole))
232 -- "all_absent_args_and_unboxed_value":
233 -- check for the obscure case of "\ x y z ... -> body" where
234 -- (a) *all* of the args x, y, z,... are absent, and
235 -- (b) the type of body is unboxed
236 -- If these conditions are true, we must *not* play worker/wrapper games!
238 all_absent_args_and_unboxed_value body_ty arg_infos
239 = not (null arg_infos)
240 && all is_absent_arg arg_infos
241 && isPrimType body_ty
243 is_absent_arg (WwLazy True) = True
244 is_absent_arg _ = False
247 Important: mk_ww_arg_processing doesn't check
248 for an "interesting" split. It just races ahead and makes the
249 split, even if there's no unpacking at all. This is important for
250 when it calls itself recursively.
252 It returns Nothing only if it encounters an abstract type in mid-flight.
255 mAX_WORKER_ARGS :: Int -- ToDo: set via flag
256 mAX_WORKER_ARGS = 6 -- Hmm... but this is an everything-must-
257 -- be-compiled-with-the-same-val thing...
260 :: [Id] -- Args of original function
261 -> [Demand] -- Strictness info for those args
262 -- must be at least as long as args
264 -> Int -- Number of extra args we are prepared to add.
265 -- This prevents over-eager unpacking, leading
266 -- to huge-arity functions.
268 -> UniqSM (Maybe -- Nothing iff any unpack on abstract type
269 (CoreExpr -> CoreExpr, -- Wrapper expr w/
270 -- hole for worker id
272 [(Id,Demand)], -- Worker's args
273 -- and their strictness info
274 CoreExpr -> CoreExpr) -- Worker body expr w/ hole
275 ) -- for original fn body
277 mk_ww_arg_processing [] _ _ = returnUs (Just (id, [], id))
279 mk_ww_arg_processing (arg : args) (WwLazy True : infos) max_extra_args
281 -- So, finish args to the right...
282 --pprTrace "Absent; num_wrkr_args=" (ppInt num_wrkr_args) (
286 mk_ww_arg_processing args infos max_extra_args
287 -- we've already discounted for absent args,
288 -- so we don't change max_extra_args
289 `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
291 -- wrapper doesn't pass this arg to worker:
294 \ hole -> wrap_rest hole,
297 work_args_info, -- NB: no argument added
298 \ hole -> mk_absent_let arg arg_ty (work_rest hole)
302 mk_absent_let arg arg_ty body
303 = if not (isPrimType arg_ty) then
304 Let (NonRec arg (mkTyApp (Var aBSENT_ERROR_ID) [arg_ty])) body
305 else -- quite horrible
306 panic "WwLib: haven't done mk_absent_let for primitives yet"
309 mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args
310 | new_max_extra_args > 0 -- Check that we are prepared to add arguments
311 = -- this is the complicated one.
312 --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)]) $
314 case (maybeAppDataTyConExpandingDicts arg_ty) of
316 Nothing -> -- Not a data type
317 panic "mk_ww_arg_processing: not datatype"
319 Just (_, _, []) -> -- An abstract type
320 -- We have to give up on the whole idea
322 Just (_, _, (_:_:_)) -> -- Two or more constructors; that's odd
323 panic "mk_ww_arg_processing: multi-constr"
325 Just (arg_tycon, tycon_arg_tys, [data_con]) ->
326 -- The main event: a single-constructor data type
329 inst_con_arg_tys = dataConArgTys data_con tycon_arg_tys
331 getUniques (length inst_con_arg_tys) `thenUs` \ uniqs ->
334 unpk_args = zipWithEqual "mk_ww_arg_processing"
335 (\ u t -> mkSysLocal SLIT("upk") u t mkUnknownSrcLoc)
336 uniqs inst_con_arg_tys
338 -- In processing the rest, push the sub-component args
339 -- and infos on the front of the current bunch
340 mk_ww_arg_processing (unpk_args ++ args) (cmpnt_infos ++ infos) new_max_extra_args
341 `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
344 -- wrapper: unpack the value
345 \ hole -> mk_unpk_case arg unpk_args
349 -- worker: expect the unpacked value;
350 -- reconstruct the orig value with a "let"
352 \ hole -> work_rest (mk_pk_let arg data_con tycon_arg_tys unpk_args hole)
359 + 1 -- We won't pass the original arg now
360 - nonAbsentArgs cmpnt_infos -- But we will pass an arg for each cmpt
362 mk_unpk_case arg unpk_args boxing_con boxing_tycon body
364 AlgAlts [(boxing_con, unpk_args, body)]
368 mk_pk_let arg boxing_con con_tys unpk_args body
369 = Let (NonRec arg (Con boxing_con
370 (map TyArg con_tys ++ map VarArg unpk_args)))
373 mk_ww_arg_processing (arg : args) (arg_demand : infos) max_extra_args
375 = -- For all others at the moment, we just
376 -- pass them to the worker unchanged.
377 --pprTrace "Other; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr ";arg=", ppr PprDebug arg, ppr PprDebug arg_demand]) (
379 -- Finish args to the right...
380 mk_ww_arg_processing args infos max_extra_args
381 `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
385 \ hole -> wrap_rest (App hole (VarArg arg)),
388 (arg, arg_demand) : work_args_info,
389 \ hole -> work_rest hole